LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031665. :SYSTEM-TYPE :LOGICAL :VERSION 12. :TYPE "LISP" :NAME "GC-AREA-SUPPORT" :DIRECTORY ("REL3-SOURCE" "MEMORY-MANAGEMENT") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758727885. :AUTHOR "REL3" :LENGTH-IN-BYTES 29808. :LENGTH-IN-BLOCKS 30. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          ; -*- Package:SYSTEM-INTERNALS; Mode:Common-Lisp; Base:8 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1984,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **;; This file contains routines for generating statistics on memory usage ;; that are used by garbage collection and the "GC Daemons".;;;;;; Edit History;;;;;;                   Patch;;;   Date    Author  Number   Description;;;------------------------------------------------------------------------------;;; 07-22-86    ab      --     - Derived from MEMORY-MANAGEMENT; ROOM #8.;;; 07-30-86    rjf     --     - Renamed Get-Fixed-Wired-Space-Size and Get-Fixed-;;;                            Space-Size to Get-Fixed-Wired-Pages and Get-Fixed-Pages,;;;                            respetively.;;;                            - Broke Get-Free-Address-Space up into two functions,;;;                            one to be used by the address space daemon and the other;;;                            by the garbage collector when estimating free space.;;;                            - Changed Get-Space-Sizes to use new free-space function.;;; 07-31-86    ab             - Corrected fencepost error in Get-Fixed-Wired-Pages.;;;                            - Changed Get-Free-Swap-Space to be much faster by;;;                            just looking directly at %Free-Page-Cluster-Count.;;;                            - Made separate function for calculating ;;;                            Usable-Address-Space-Limit.  Renamed & documented;;;                            rjf's new address space functions.;;; 08-21-86    ab             -- Moved calculations for GC space sizes here from;;;                            MEMORY; GC file.  Re-wrote documentation of flip-determining;;;                            formulas.  Re-wrote GC-Get-Committed-Free-Space to be;;;                            algebraically simpler and faster.  Changed ;;;                            GC-Get-Committed-Free-Space to return more values so its;;;                            callers don't have to repeat calls to Get-Space-Sizes.;;; 09-23-86    ab             -- Moved specific gc area/region manipulating routines here;;;                            from GC file.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Address space calculations;;;;;; The current maximum address space on the Explorer is 128 MB.  However, the amount of ;;; usable address space may be somewhat less than that.  The variable Virtual-Memory-Size;;; contains the system's estimate of usable virtual memory, which is 128 MB (32 Mwords) ;;; minus 1Kb for A-Memory and 128Kb reserved for the TV IO buffer (total of 132096. words).;;; Thus Virtual-Memory-Size is the maximum amount of usable address space.;;;;;; The amount available is further constrained by the size of the swap space.  You cannot;;; use a page of virtual memory if there is no swap space available for it.  (More accurately,;;; you cannot DIRTY a page of virtual memory unless there is swap space available.)  So,;;; at first glance it would appear that ;;;                ;;;       Usable Address Space = Min (Virtual-Memory-Size Swap-Space-Size);;;;;; This is not quite true, though.  Analysis of address space usage shows that some portion;;; of the address space is fixed wired.  This means that the pages in that part of the address;;; space will never be swapped out.  Therefore, we can add the total address space used for;;; fixed wired pages to the swap band size to yield the real usable address space total.;;;;;;       Usable Address Space = Min (Virtual-Memory-Size (+ Swap-Space-Size Fixed-Wired-Size));;;(DEFUN get-fixed-wired-pages ()  "Returns the number of pages allocated to fixed, wired areas."  (FLOOR (AREF #'region-origin (AREF #'area-region-list      (SYMBOL-VALUE first-non-fixed-wired-area-name))) page-size))(DEFF get-fixed-wired-space-size 'get-fixed-wired-pages)(DEFUN get-fixed-pages ()  "Returns the number of pages allocated to fixed areas."  (LET ((region (AREF #'area-region-list (SYMBOL-VALUE last-fixed-area-name))))    (- (FLOOR (+ (AREF #'region-origin region) (AREF #'region-length region)) page-size)       (get-fixed-wired-pages))))(DEFF get-fixed-space-size 'get-fixed-pages)(DEFUN get-free-swap-space ()  "Returns the amount of free swap space remaining (in words) rounded to the nearestswap space quantum."  (* %free-cluster-count cluster-size-in-words))(DEFPARAMETER *max-address-space-size* (1+ (byte-mask %%q-pointer)))(DEFVAR *max-virtual-address* (convert-to-unsigned (set-io-space-virtual-address)))(DEFUN find-max-virtual-address ()  (SETQ *max-virtual-address*(convert-to-unsigned *io-space-virtual-address*)))(DEFUN usable-address-space-limit ()  "Returns the limiting item for usable virtual memory size in words.  Thiswill be the smaller of 32 megawords and the total swap space available inthe current configuration.  Returns a second value of :SWAP-SPACE or:ADDRESS-SPACE indicating what the address space is limited by in thecurrent configuration."  (DECLARE (VALUES address-space-limit limited-by))  (LET ((swap-space-total-size (* (swap-space-info) Page-Size)))    (IF (> swap-space-total-size *max-virtual-address*)(VALUES *max-virtual-address* :address-space)(VALUES swap-space-total-size :swap-space))));;; Calculates maximum free address space available for assignment to new;;; regions.  Does this by traversing address space map and counting unused ;;; quanta.  This is an upper bound on free address space quanta, since;;; we may not have enough swap space for all that free address space.;;; (NOTE: this is not the same as calculating the UNALLOCATED address space);;;;;; This is used by the address space warning daemon. (DEFUN get-unassigned-address-space-size ()  "Returns the number of words of address space currently available for assignmentto regions.  Also returns the number of words currently assigned."  (DECLARE (VALUES unassigned-address-space assigned-address-space))    (LET* ((last-fixed-region (AREF #'area-region-list (SYMBOL-VALUE last-fixed-area-name)))   (fixed-area-address-space (+ (AREF #'region-origin last-fixed-region)(AREF #'region-length last-fixed-region)))   unused)      (SETQ unused    (LOOP FOR i FROM (TRUNCATE fixed-area-address-space       %Address-Space-Quantum-Size)  BELOW (FLOOR *max-virtual-address* %Address-Space-Quantum-Size)  COUNT (ZEROP (AREF #'Address-Space-Map i)) INTO quanta-unused  FINALLY (return (* quanta-unused %Address-Space-Quantum-Size))))      (VALUES unused(- *max-address-space-size* unused)))    )(DEFF get-free-address-space 'get-unassigned-address-space-size);;; This function returns the gross amount of usable (free) address space.;;;;;; "Usable address space" is affected by both the currently available address;;; space (that not yet assigned to quanta) and by the maximum available swap;;; space.  There may be lots of address space assigned to regions, but not yet ;;; out on the page bands (because it has never been dirtied).  Since we can;;; potentially dirty any memory page (through normal use or during GC), we need;;; to have swap band space to accomodate this address space.;;;;;; GC uses this value as a first-approximation to gc-usable-free-space (amount;;; of free space that can be used to copy objects), but then adjusts it in;;; several ways.  See below.(DEFUN usable-address-space ()  "Returns the amount of free address space (in words) that is available ifyou do not run garbage collection."  (LET* ((usable-address-space-limit   (usable-address-space-limit)) (pages-not-needing-swap-space   (* (get-fixed-wired-pages) Page-Size)) assigned-virtual-memory)    (MULTIPLE-VALUE-SETQ (nil assigned-virtual-memory)       (get-unassigned-address-space-size))    ;; Usable address space is this machine's maximum virtual memory.    ;; Used size is how many quanta are consumed by assigned regions.    ;; In some cases, the USED SIZE can be GREATER than the usable address    ;; space limit.  For example, when you boot up a 40 MB load band with    ;; only 20 MB of page bands, you're using 10 megawords worth of address    ;; space quanta, but all of it is still on the load band.  If you    ;; were to dirty every page, you would not have enough swap space to    ;; hold all this "used" address space.    ;;    ;; In the above example, you actually have a negative amount of    ;; "usable" address space.  However, for practical reasons, we    ;; limit the minimum usable address space to 0.    (MAX (- (+ usable-address-space-limit pages-not-needing-swap-space)    assigned-virtual-memory) 0)))(DEFF get-free-address-space 'get-unassigned-address-space);;;;;;;;;;;;;;;;;;(DEFUN get-scav-work-remaining ()  "Return the number of words now waiting to be scavenged.Note: More data may appear and need to be scavanged before we are finished."  (LOOP WITH ind-cell-work = 0   WITH copy-work = 0WITH stat-work = 0  WITH new-work = 0WITH copy-size = 0 WITH old-size = 0 WITH bitsWITH copy-gen = (MULTIPLE-VALUE-BIND (generation promote)    (FLOOR gc-type-of-flip 2)  (IF (ZEROP promote) generation (1+ generation)))WITH gen = (FLOOR gc-type-of-flip 2)FOR area-sym IN area-listFOR area = (SYMBOL-VALUE area-sym) DO(IF (= area Indirection-Cell-Area)    (LOOP FOR reg = (AREF #'area-region-list area) THEN (AREF #'region-list-thread reg)  UNTIL (MINUSP reg) DO  (WHEN (<= (region-volatility reg bits)    gen)    (INCF ind-cell-work  (FLOOR (- (AREF #'region-free-pointer reg)    (AREF #'region-gc-pointer reg)) indirection-cell-size))))    (LOOP FOR reg = (AREF #'area-region-list area) THEN (AREF #'region-list-thread reg)      UNTIL (MINUSP reg) DO      (SETQ bits (AREF #'region-bits reg))      (COND ((region-copyspace-p reg bits)     (UNLESS (AND (region-scavenge-enabled reg bits)  (= copy-gen (region-generation reg bits)))       (FERROR nil "Inconsistent copyspace region ~d." reg))     (INCF copy-work (- (AREF #'region-free-pointer reg)(AREF #'region-gc-pointer reg)))     (INCF copy-size (AREF #'region-free-pointer reg)))    ((region-oldspace-p reg bits)     (UNLESS (= copy-gen (region-generation reg bits))       (FERROR nil "Inconsistent oldspace region ~d." reg))     (INCF old-size (AREF #'region-free-pointer reg)))    ((region-scavenge-enabled reg bits)     (IF (OR (region-fixed-p reg bits)     (region-static-p reg bits)) (INCF stat-work (- (AREF #'region-free-pointer reg)    (AREF #'region-gc-pointer reg))) (IF (< (region-volatility reg bits) gen)     (INCF new-work (- (AREF #'region-free-pointer reg)       (AREF #'region-gc-pointer reg)))     (FERROR nil "Inconsistent scavengeable region ~d." reg)))))))FINALLY (RETURN (+ ind-cell-work copy-work stat-work new-work)(- old-size (- copy-size gc-initial-copyspace-size)))));; Note this does not take into account consing into static areas that might;; occur between now and flip.(DEFUN get-max-gc-work-remaining (&aux (copying 0))  "Return an upper bound on the number of words to be scavenged before reclamation.The second value is the minimum amount of scavenging remaining (lower bound), andthird value is the part which is not certain (upper bound minus lower bound)."  (DECLARE (VALUES max-work min-work delta))  (DOLIST (area area-list)    (LET ((area-number (SYMBOL-VALUE area)))      ;; For each area, look at all regions.  Max amount of copying to      ;; be done in this area is the current old size minus the current      ;; copy size (ie, what has not already been copied to copyspace).      (DO ((region (AREF #'area-region-list area-number) (AREF #'region-list-thread region))   (old-size 0)   (copy-size 0))  ((MINUSP region)   (SETQ copying (+ copying (max 0 (- old-size copy-size)))))(SELECT (region-space-type region)   (:OLD    (INCF old-size (AREF #'region-free-pointer region)))   (:COPY    (INCF copy-size (AREF #'region-free-pointer region)))))))  ;; Max total scavenging work involves scavenging the so-far uncopied objects  ;; (computed above), plus scavenging everything currently between scav ptr  ;; and free ptr in copy space.  ;; (once to copy, second to scavenge)  (LET ((min-work (get-direct-gc-work-remaining)))    (VALUES (+ copying min-work) min-work copying))  );;(DEFUN scav-gen-size (&optional (generation :current));;  (LET ((indir-cell 0) (other);;old-and-copy-gen promote)    ;;    (WHEN (EQ generation :current);;      (MULTIPLE-VALUE-SETQ (generation promote);;(current-collection-type));;      (UNLESS generation (RETURN-FROM get-gc-work-remaining nil));;      (WHEN promote (SETQ old-and-copy-gen (1+ generation))))      ;;    (LOOP FOR area-sym IN area-list;;  FOR area = (SYMBOL-VALUE area) DO;;  (LOOP FOR reg = (AREF #'area-region-list area) THEN (AREF #'region-list-thread reg);;UNTIL (MINUSP reg);;WITH bits DO;;(SETQ bits (AREF #'region-bits reg));;(IF (= area Indirection-cell-area);;    (WHEN (AND  );;    ( ));;)))));;(defun scav-gen-zero-size ();;  (let ((ind-cell 0);;(other 0));;    (dolist (area area-list);;      (let ((area-number (symbol-value area)));;(when (>= area-number working-storage-area);;  (do ((region (aref #'area-region-list area-number) (aref #'region-list-thread region)));;      ((minusp region));;    (when (and (/= %region-space-old (ldb %%region-space-type (aref #'region-bits region)));;       (= 0 (ldb %%region-volatility (aref #'region-bits region)));;       (/= 0 (ldb %%region-generation (aref #'region-bits region))));;      (print area);;      (if (= %region-representation-type-list (ldb %%region-representation-type (aref #'region-bits region)));;  (if (/= area-number indirection-cell-area);;      (setf other (+ other (aref #'region-free-pointer region)));;      (setf ind-cell (+ ind-cell (aref #'region-free-pointer region))));;  (do ((addr (aref #'region-origin region);;     (%make-pointer-offset dtp-fix addr (%structure-total-size addr)));;       (end (%make-pointer-offset dtp-fix;;  (aref #'region-origin region) (aref #'region-free-pointer region))));;      ((>= addr end));;    (if (/= area-number indirection-cell-area);;(setf other (+ other (%structure-boxed-size addr)));;(setf ind-cell (+ ind-cell (%structure-boxed-size addr)))))))))));;    (format t "~%total size of zero volatility boxed q's not in generation zero = ~d. kb.";;    (ceiling (+ ind-cell other) 256.));;    (format t "~%this consists of ~d. kb of indirection cells and ~d. kb of other stuff.";;    (ceiling ind-cell 256.);;    (ceiling other 256.))));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Area/Region change routines;;;(DEFUN %make-region-static (region &optional (bits (AREF #'region-bits region)))  "Changes REGION to static immediately.  No error checking!"  (SETF (AREF #'region-bits region)(%LOGDPB 1 %%region-scavenge-enable (%LOGDPB %region-space-static %%region-space-type bits))))(DEFUN %make-region-dynamic (region &optional (bits (AREF #'region-bits region)))  "Changes REGION to a dynamic (newspace) region immediately.  No error checking!"  (SETF (AREF #'region-bits region)(%LOGDPB 0 %%region-scavenge-enable (%LOGDPB %Region-Meta-Bit-Not-Oldspace %%region-oldspace-meta-bit  (%LOGDPB %region-space-new %%region-space-type   bits)))));;;; Used by routines that enable/disable temporary areas.;;(DEFUN ensure-area-regions-safe (area-number)  "Errors if any regions in area AREA-NUMBER are not NEW or STATIC and generation 3."  (LOOP FOR reg = (AREF #'area-region-list area-number) THEN (AREF #'region-list-thread reg)WITH bits = nilWITH typ = nilUNTIL (MINUSP reg) DO(SETQ bits (AREF #'region-bits reg))(WHEN (/= %region-gen-3 (region-generation reg bits))  (FERROR nil "Region ~a in area ~a is not generation 3."  reg (AREA-NAME area-number)))(UNLESS (OR (EQ :new (SETQ typ (region-space-type reg bits)))    (EQ :static typ))  (FERROR nil "Region ~a in area ~a is not newspace."  reg (AREA-NAME area-number)))FINALLY (RETURN t)))(DEFUN %make-area-static (area)  "Changes AREA and all its regions from dynamic to static immediately.Will error it is not safe to do this to any of AREA's regions."  (WITHOUT-INTERRUPTS    (ensure-area-regions-safe area)    ;; Change to static & enable scavenging in area's region bits    (LET ((bits (AREF #'area-region-bits area)))      (WHEN (area-dynamic-p area bits)(SETF (AREF #'area-region-bits area)      (%LOGDPB 1 %%region-scavenge-enable       (%LOGDPB %Region-Gen-3 %%REGION-GENERATION(%LOGDPB %region-space-static %%region-space-type bits))));; Do same for all regions in area(LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)      WITH bits      UNTIL (MINUSP region) DO      (SETQ bits (AREF #'region-bits region))      (WHEN (region-newspace-p region bits)(%make-region-static region bits))))))  )(DEFUN %make-area-dynamic (area)  "Changes AREA and all its regions from static to dynamic immediately.Will error it is not safe to do this to any of AREA's regions."  (WITHOUT-INTERRUPTS    (ensure-area-regions-safe area)    ;; Change to dynamic    (LET ((bits (AREF #'area-region-bits area)))      (WHEN (area-static-p area bits)(SETF (AREF #'area-region-bits area)      (%LOGDPB 0 %%region-scavenge-enable       (%LOGDPB %region-space-new %%region-space-type bits)));; Do same for all regions in area(LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)      WITH bits      UNTIL (MINUSP region) DO      (SETQ bits (AREF #'region-bits region))      (WHEN (region-static-p region bits)(%make-region-dynamic region bits))))))  )(DEFUN %make-area-temporary (area-number)  "Make an area (specified by number) as temporary."  (WITHOUT-INTERRUPTS    (%make-area-static area-number)    (SETF (AREF area-temporary-flag-array area-number) 1)))(DEFUN %make-temporary-area-dynamic (temporary-area-number)  "Make a temporary area (specified by number) back into dynamic newspace."  (WITHOUT-INTERRUPTS    (%make-area-dynamic temporary-area-number)    (SETF (AREF area-temporary-flag-array temporary-area-number) 0)    ;; Remember this area was temporary!    (PUSH (AREF #'AREA-NAME temporary-area-number) *areas-not-made-temporary-list*)));;; Used to convert regions in a dynamic area to/from static.(DEFUN make-area-regions-static (area)  "Mark the filled generation 3 newspace regions of AREA as static."  (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area size-of-area-arrays)) "an area number")  (WITHOUT-INTERRUPTS    (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)  WITH bits = NIL  UNTIL (MINUSP region) DO  (SETQ bits (AREF #'region-bits region))  (UNLESS (ZEROP (AREF #'region-free-pointer region))    ;; Only when generation 3 and dynamic.    (WHEN (AND (EQ :new (region-space-type region bits))       (= %region-gen-3 (region-generation region bits)))      (deallocate-end-of-region region)      (%make-region-static region)      (%fill-up-region region)))))  )(DEFUN make-area-regions-dynamic (area)  "Mark the static regions of AREA as dynamic."  (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area size-of-area-arrays)) "an area number")  (WITHOUT-INTERRUPTS    (WHEN (generation-collection-in-progress-p 3)      (FERROR nil "Cannot make regions of area ~a dynamic while collection of generation 3 is in progress."      (AREA-NAME area)))    (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)  WITH bits = NIL  UNTIL (MINUSP region) DO  ;; Only when generation 3 and static.  (WHEN (AND (EQ :static (region-space-type region (SETQ bits (AREF #'region-bits region))))     (= %region-gen-3 (region-generation region bits)))    (%make-region-dynamic region))))  )(DEFUN set-generation-three-space-type (new-type &optional (list-of-areas area-list))  "Converts all suitable generation three regions in the dynamic areas of LIST-OF-AREAsto space type NEW-TYPE."  (LOOP FOR area-sym IN list-of-areasFOR area = (SYMBOL-VALUE area-sym)UNLESS (= area Indirection-Cell-Area)WHEN (area-dynamic-p area (AREF #'area-region-bits area)) DO(SELECT new-type  (%region-space-new (make-area-regions-dynamic area))  (%region-space-static (make-area-regions-static area))))  );;;;;; Used when conducting a training session.(DEFUN make-generation-three-static () "Convert all new space regions in generation three and in dynamic areas to static."  (set-generation-three-space-type    %region-space-static    (MEMBER first-non-fixed-area-name area-list :test #'EQ)))(DEFUN make-generation-three-dynamic ()  "Converts all static space regions in generation three and in dynamic areas to newspace."  (set-generation-three-space-type    %region-space-new    (MEMBER first-non-fixed-area-name area-list :test #'EQ)));;;;;; Used by Tgc-Enable(DEFUN %set-area-default-cons-generation (area generation)  "Set the default cons generation for new objects allocated in thisarea. The area must be dynamic or no action will be taken since staticareas must always be in generation 3."  (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area Size-Of-Area-Arrays)) "an area number")  (LET ((bits (AREF #'area-region-bits area)))    (WHEN (region-newspace-p nil bits)      (SETF (AREF #'area-region-bits area)    (%LOGDPB generation     %%region-generation     bits))))  )(DEFUN start-young-consing ()  (DECLARE (SPECIAL *tgc-non-generation-0-consers*))  (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ)FOR area-num = (SYMBOL-VALUE area);; AREAs marked STATIC (vs regions marked that way) must be left alone!;; They may contain wired pages.DO (UNLESS (area-static-p area-num)     (%set-area-default-cons-generation (SYMBOL-VALUE area) 0)))  (LOOP FOR (area gen) IN *tgc-non-generation-0-consers*DO (WHEN (BOUNDP area)     (%set-area-default-cons-generation (SYMBOL-VALUE area) gen)))  )(DEFUN stop-young-consing ()  (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ)FOR area-num = (SYMBOL-VALUE area);; AREAs marked STATIC (vs regions marked that way) must be left alone!;; They may contain wired pages.DO (UNLESS (area-static-p area-num)     (%set-area-default-cons-generation (SYMBOL-VALUE area) 3)))  );;;;;;;;;;;;;;(DEFSTRUCT (space-size-info (:conc-name nil))   "Structure containing information about space sizes."  new-alloc            new-used    gen0-alloc           gen0-used    gen1-alloc           gen1-used    gen2-alloc           gen2-used    gen3-alloc           gen3-used  copy-alloc           copy-used  static-alloc         static-used    stat-reg-alloc       stat-reg-used    stat-area-alloc      stat-area-used    fixed-alloc          fixed-used  old-alloc          old-used  train-alloc        train-used  areas  regions)(DEFUN gen-size-allocated (gen &optional (space-size-struct   (get-space-size-info (make-space-size-info))))  (SELECT gen    (0 (gen0-alloc space-size-struct))    (1 (gen1-alloc space-size-struct))    (2 (gen2-alloc space-size-struct))    (3 (gen3-alloc space-size-struct))    (:static (static-alloc space-size-struct))    (:old (old-alloc space-size-struct))    (:copy (copy-alloc space-size-struct))    (:train (train-alloc space-size-struct))))(DEFVAR *space-size-info* (make-space-size-info))(DEFVAR *tem-space-size-info* (make-space-size-info))(DEFUN get-space-size-info (&optional (space-size-struct *tem-space-size-info*))  (LET ((gen0-alloc 0)      (gen0-used 0)(gen1-alloc 0)      (gen1-used 0)(gen2-alloc 0)      (gen2-used 0)(gen3-alloc 0)      (gen3-used 0)(copy-alloc 0)      (copy-used 0)(static-alloc 0)    (static-used 0)(stat-reg-alloc 0)  (stat-reg-used 0)(stat-area-alloc 0) (stat-area-used 0)(fixed-alloc 0)     (fixed-used 0)(old-alloc 0)       (old-used 0)(train-alloc 0)     (train-used 0)(areas 0)           (regions 0)reg-bits alloc used)    (LOOP FOR area-sym IN area-list  FOR area = (SYMBOL-VALUE area-sym) DO  (INCF areas)  (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)UNTIL (MINUSP region) DO(INCF regions)(SETQ alloc (AREF #'region-length region)      used (AREF #'region-free-pointer region)      reg-bits (AREF #'region-bits region))(SELECT (region-space-type region reg-bits)  (:new (SELECT (region-generation region reg-bits)  (3 (PROGN (INCF gen3-alloc alloc)    (INCF gen3-used used)))  (2 (PROGN (INCF gen2-alloc alloc)    (INCF gen2-used used)))  (1 (PROGN (INCF gen1-alloc alloc)    (INCF gen1-used used)))  (0 (PROGN (INCF gen0-alloc alloc)    (INCF gen0-used used)))))  (:static (COND ((area-static-p area (AREF #'area-region-bits area))  (INCF stat-area-alloc alloc)  (INCF stat-area-used used)) (t (INCF stat-reg-alloc alloc)    (INCF stat-reg-used used))))  (:old (PROGN (INCF old-alloc alloc)       (INCF old-used used)))  (:copy (PROGN (INCF copy-alloc alloc)(INCF copy-used used)))  (:fixed (PROGN (INCF static-alloc alloc) (INCF static-used used) (INCF fixed-alloc alloc))  (INCF fixed-used used))  (:train (PROGN (INCF train-alloc alloc) (INCF train-used used)))  (:otherwise (FERROR nil "Invalid region type")))))    (SETF (new-alloc space-size-struct)  (+ gen0-alloc gen1-alloc gen2-alloc gen3-alloc))    (SETF (new-used space-size-struct)  (+ gen0-used gen1-used gen2-used gen3-used))    (SETF (gen0-alloc space-size-struct) gen0-alloc)    (SETF (gen0-used space-size-struct) gen0-used)    (SETF (gen1-alloc space-size-struct) gen1-alloc)    (SETF (gen1-used space-size-struct) gen1-used)    (SETF (gen2-alloc space-size-struct) gen2-alloc)    (SETF (gen2-used space-size-struct) gen2-used)    (SETF (gen3-alloc space-size-struct) gen3-alloc)    (SETF (gen3-used space-size-struct) gen3-used)    (SETF (copy-alloc space-size-struct) copy-alloc)    (SETF (copy-used space-size-struct) copy-used)    (SETF (static-alloc space-size-struct)  (+ stat-reg-alloc stat-area-alloc fixed-alloc))    (SETF (static-used space-size-struct)  (+ stat-reg-used stat-area-used fixed-used))    (SETF (stat-reg-alloc space-size-struct) stat-reg-alloc)    (SETF (stat-reg-used space-size-struct) stat-reg-used)    (SETF (stat-area-alloc space-size-struct) stat-area-alloc)    (SETF (stat-area-used space-size-struct) stat-area-used)    (SETF (fixed-alloc space-size-struct) fixed-alloc)    (SETF (fixed-used space-size-struct) fixed-used)    (SETF (old-alloc space-size-struct) old-alloc)    (SETF (old-used space-size-struct) old-used)    (SETF (train-alloc space-size-struct) train-alloc)    (SETF (train-used space-size-struct) train-used)    (SETF (areas space-size-struct) areas)    (SETF (regions space-size-struct) regions))  space-size-struct)(DEFUN get-gc-space-sizes (&optional static-regions-are-dynamic space-size-struct)  "Returns total current sizes (in words) of dynamic space, stactic space, free-spaceand old space."  (DECLARE    (VALUES dynamic-space static-space gc-usable-free-space old-space))  (LET ((space-sizes (OR space-size-struct (get-space-size-info *tem-space-size-info*)))(gc-usable-free-space (usable-address-space)))    (VALUES      ;; Dynamic = New + Copy + Static that will be made dynamic      (+ (new-alloc space-sizes) (copy-alloc space-sizes) (IF static-regions-are-dynamic     (stat-reg-alloc space-sizes)     0))      ;; Static (minus any that will become dynamic)      (IF static-regions-are-dynamic  (- (static-alloc space-sizes)     (stat-reg-alloc space-sizes))  (static-alloc space-sizes))      ;; Free      gc-usable-free-space      ;; Old      (old-alloc space-sizes))))(DEFUN get-free-space-size ()  "Returns total free space available for garbage collection at the nextcollection (ie, includes current oldspace)."  (LET ((space-sizes (get-space-size-info *tem-space-size-info*))(gc-usable-free-space (usable-address-space)))    (+ gc-usable-free-space (old-alloc space-sizes))))(DEFUN get-space-needed-for-gc (&optional static-regions-of-dynamic-areas-are-dynamicspace-size-struct &aux free-space-needed)  (DECLARE (VALUES free-space-needed free-space-available dynamic-size static-size old-size))  (MULTIPLE-VALUE-BIND (dynamic-size static-size free-space-available old-size)(get-gc-space-sizes static-regions-of-dynamic-areas-are-dynamic space-size-struct)    ;; Old space will be reclaimed    (INCF free-space-available old-size)    (SETQ free-space-needed  ;; SPACE-NEEDED = (F0 + D0) / 2,  and add extra fudge for region breakage.  (+ (FLOOR (+ free-space-available dynamic-size)    2)     (* 4 %address-space-quantum-size)))    (VALUES free-space-needed free-space-available dynamic-size static-size old-size)))egion)))))      ;; Invalidate AR-1's cache.      (SETQ Ar-1-Array-Pointer-1 nil    Ar-1-Array-Pointer-2 nil)      ;; Do flip (change newspace to oldspace in all dynamic areas).      (SETF GC-TYPE-OF-FLIP GC-TYPE)      (%GC-FLIP (%LOGDPB (IF %TGC-Training-Enabled 1 0) (BYTE 1. 24.) (DEPOSIT-FIELD SCAV-WORK-BIAS (BYTE 21. 3.) gc-type)))      (SETQ %Gc-Generation-Number (1+ %Gc-Generation-Number))      (process-gc-flip-stats gc-type)      ;; If possible, free up space at the end of the oldspace regions so more      ;; space available for copying.      (LOOP FOR area-sym IN area-list    FOR area = (SYMBOL-VALUE area-sym) DO    (LOOP FOR reg = (AREF #'area-region-list area) THEN (AREF #'region-list-thread reg)  UNTIL (MINUSP reg) DO  (WHEN (OR (region-oldspace-p reg (SETQ bits (AREF #'region-bits reg)))    (region-train-p reg bits))    (deallocate-end-of-region reg)))