LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031662. :SYSTEM-TYPE :LOGICAL :VERSION 11. :TYPE "LISP" :NAME "GC" :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 2758727846. :AUTHOR "REL3" :LENGTH-IN-BYTES 46343. :LENGTH-IN-BLOCKS 46. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                       ;;; -*- Mode:Common-Lisp; Package:System-Internals; Base:8.; patch-file t; -*-;;;                           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 the Lisp-coded support for the Garbage Collector;;;;;; Edit History;;;;;;                   Patch;;;   Date    Author  Number   Description;;;------------------------------------------------------------------------------;;; 07-22-86    ab      --     - Integration for VM2.  Derived from;;;                            SYS:MEMORY-MANAGEMENT; GC.LISP#39;;;                              Removed conditionalized code.;;;                              Translated to Common Lisp.;;; 08-19-86    ab      --     - Moved space-size-computing routines & area/region;;;                            manipulation routines to GC-AREA-SUPPORT.;;; 09-86       ab             - Major re-write.;;; 01-25-87    ab             - Minimal integration for TGC compatibility.;;; 02-08-87    ab             - More re-writing for TGC.;;; 04-13-87    ab   *N 11     - Make gc notifications behave as documented.;;; 04-15-87    ab   *N 12     - Fix GC-RECLAIM-OLDSPACE-AREA always to call;;;                            %gc-free-region on oldspace regions, even on an;;;                            area's last region.  Otherwise, the oldspace bit;;;                            in the level-1 maps stay set confusing the transporter.;;; 04-23-87    ab   *O GC 14  - Make sure AFTER-SYSTEM-BUILD stuff is run before;;;                            anything else (esp collapse dup pnames).  Also,;;;                            don't do collapse-duplicate-pnames unless collecting gen 3.;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; GC Status & Report routines.;;;(DEFUN gc-reset-history-counters ()  "This function will reset the GC history counters."  (ARRAY-INITIALIZE gc-collection-counters 0)  (ARRAY-INITIALIZE gc-garbage-collected 0)  (ARRAY-INITIALIZE gc-work-done 0));; Args like FORMAT, but stream comes from GC-REPORT-STREAM(DEFUN gc-report (format-control &rest format-args)  (LET* ((mode (AND (VARIABLE-BOUNDP gc-process)    (EQ current-process gc-process)    (EQ *gc-notifications* t))) (gc-report (OR mode gc-report)))    (COND      ((OR (NULL gc-report)   (NULL gc-report-stream))       nil)      ((AND (EQ gc-report-stream t)    (FBOUNDP 'w:notify))       (APPLY 'process-run-function '(:name "GC notification" :priority 10.) #'w:notify nil      format-control format-args))      (t (WHEN (EQ gc-report-stream t)   (SETQ gc-report-stream *Standard-Output*)) (FUNCALL gc-report-stream :fresh-line) (APPLY #'FORMAT gc-report-stream format-control format-args))))  (PROCESS-ALLOW-SCHEDULE))(DEFUN process-gc-start-stats (gc-type)  (MULTIPLE-VALUE-BIND (generation promote)      (FLOOR gc-type 2)    (GC-REPORT"GC: About to begin collecting generation ~O ~[without~;with~] promotion."generation promote))  )(DEFUN process-gc-done-stats ()  (LET ((generation (FLOOR gc-type-of-flip 2))(old 0)(copy 0)bits)    ;; Tally up the size of oldspace and copy space.    (LOOP FOR area IN area-list DO  (LOOP FOR reg = (AREF #'area-region-list (SYMBOL-VALUE area)) THEN (AREF #'region-list-thread reg)UNTIL (MINUSP reg) DO(SETQ bits (AREF #'region-bits reg))(COND ((region-oldspace-p reg bits)       (INCF old (AREF #'region-free-pointer reg)))      ((region-copyspace-p reg bits)       (INCF copy (AREF #'region-free-pointer reg))))))    ;; Update the history statistics    (INCF (AREF gc-collection-counters generation))    (INCF (AREF gc-garbage-collected generation) (+ gc-initial-copyspace-size (- old copy)))    (INCF (AREF gc-work-done generation) (- copy gc-initial-copyspace-size))    (GC-REPORT      "GC: Generation ~D collection complete.  Old space size = ~:D words, Copy space size = ~:D words."      generation old (- copy gc-initial-copyspace-size))))(DEFUN process-gc-flip-stats (gc-type)  ;; Update the gc-generational-flip-counters.  ;; This array is indexed by generation and all entries less than or  ;; equal to the current flip generation need to be bumped.  ;; Each array entry is a dtp-fix word with a modulo 2^23 COUNTER.  (DO ((g (FLOOR gc-type 2) (1- g)))      ((MINUSP g))    (SETF (AREF gc-generational-flip-counters g)  (DPB (1+ (LDB (BYTE 23. 0)(AREF gc-generational-flip-counters g)))       (BYTE 23. 0) 0))));;;;;;;;;;;;;;;;;;;;;;;;; ;;; GC Status;;;(DEFVAR gc-status-var-list'(gc-report-stream *gc-notifications*  *gc-max-incremental-generation*   *gc-console-delay-interval*))(DEFVAR gc-status-var-list-verbose'(inhibit-scavenging-flag %gc-generation-number  %gc-flip-ready gc-oldspace-exists gc-type-of-flip   inhibit-idle-scavenging-flag gc-idle-scavenge-quantum  inhibit-gc-flips gc-flip-lock  Gc-Batch-Mode  gc-fraction-of-ram-for-generation-zero  *training-session-started*  gc-report gc-size-in-kb))(DEFUN find-max-print-name-length (lst)  (LOOP WITH max-len = 0  WITH len = nilFOR var IN lst DO(WHEN  (> (SETQ len (LENGTH (THE string (SYMBOL-NAME var))))     max-len)  (SETQ max-len len))FINALLY (RETURN max-len)))(DEFUN gc-status-variables (&key (STREAM t) (verbose nil))  (LET (len)    (SETQ len (MAX (find-max-print-name-length gc-status-var-list)   (find-max-print-name-length gc-status-var-list-verbose)))    (FORMAT stream "~2%VARIABLES~                    ~%------------")    (LOOP FOR var IN gc-status-var-list DO  (FORMAT stream "~%~s~vt~s"  var (+ len 7) (SYMBOL-VALUE var)))    (WHEN verbose      (LOOP FOR var IN gc-status-var-list-verbose DO    (FORMAT stream "~%~s~vt~s"    var (+ len 7) (SYMBOL-VALUE var))))))(DEFVAR gc-size-in-kb nil)(DEFUN gc-size-marker ()  (IF gc-size-in-kb "kbytes" "words"))(DEFUN gc-size-raw (size-in-words)  (IF gc-size-in-kb (FLOOR (* size-in-words 4.) 1k-byte) size-in-words))(DEFUN gc-size (size-in-words)  (IF gc-size-in-kb      (FORMAT nil "~10,,:d" (FLOOR (* size-in-words 4.) 1k-byte))      (FORMAT nil "~10,,:d" size-in-words)))(DEFUN gc-marked-size (size-in-words)  (IF gc-size-in-kb      (FORMAT nil "~9,,:d kbytes" (FLOOR (* size-in-words 4) 1k-byte))      (FORMAT nil "~10,,:d words" size-in-words)))(DEFUN gc-status-general-info (&key (STREAM t) &allow-other-keys)  (LET* ((dump-size (estimate-dump-size)) addr-space-limit limited-by unassigned-addr-space usable-swap-space swap-space-used)    (SETQ dump-size (* dump-size disk-block-word-size))    (MULTIPLE-VALUE-SETQ (usable-swap-space nil swap-space-used)      (swap-space-info))    (SETQ usable-swap-space (* usable-swap-space page-size)  swap-space-used (* swap-space-used page-size))    (MULTIPLE-VALUE-SETQ (addr-space-limit limited-by)      (usable-address-space-limit))    (MULTIPLE-VALUE-SETQ (unassigned-addr-space nil)      (get-unassigned-address-space-size))    (FORMAT stream    "~2%GENERAL INFO~              ~%------------~              ~%Swap Space Usage:          ~30t~a available, ~58t~a used ~73t(~D%)~              ~%Address Space Usage:       ~30t~a maximum,   ~58t~a used ~73t(~D%)~              ~%Virtual Memory Size Limit: ~30t~a (limited by ~a)~              ~%Estimated dump size:       ~30t~a ~a"    (gc-marked-size usable-swap-space) (gc-size swap-space-used)    (FLOOR (* (/ swap-space-used usable-swap-space) 100.))    (gc-marked-size *max-address-space-size*) (gc-size unassigned-addr-space)    (FLOOR (* (/ unassigned-addr-space *max-address-space-size*) 100.))    (gc-marked-size addr-space-limit) (SYMBOL-NAME limited-by)    (gc-marked-size dump-size)    (IF gc-size-in-kb"(blocks)"(FORMAT nil "(~:d blocks)" (FLOOR dump-size disk-block-word-size))))))(DEFUN gc-status-auto-gc (&key (STREAM t) (verbose nil)  &aux reasons)  (FORMAT stream "~2%AUTOMATIC GC STATUS~                   ~%-------------------")  (COND ((gc-active-p) (FORMAT stream "~%Automatic GC is ON.") (FORMAT stream "~%Garbage collection of generation ~d (~[without~;with~] promotion) now in progress." (FLOOR gc-type-of-flip 2) (REM gc-type-of-flip 2)) (WHEN verbose   ()))((AND (gc-in-progress-p)      (SETQ reasons (gc-arrest-reasons))) (FORMAT stream "~%Automatic GC is ON, but has been arrested for reason~p: ~a." (LENGTH reasons) reasons) (FORMAT stream "~%Garbage collection of generation ~d (~[without~;with~] promotion) now in progress." (FLOOR gc-type-of-flip 2) (REM gc-type-of-flip 2)))(t (FORMAT stream "~%Automatic GC is OFF."))))(DEFUN GET-GENERATION-SIZES ()  (LET ((w (MAKE-ARRAY 7 :initial-element 0))(d (MAKE-ARRAY 7 :initial-element 0))bits gen)    (DOLIST (area area-list)      (DO ((REGION (AREF #'area-region-list (SYMBOL-VALUE area))   (AREF #'region-list-thread region)))  ((MINUSP region))(SETQ bits (AREF #'region-bits region)      gen (region-generation region bits))(IF (OR (region-static-p region bits)(region-fixed-p region bits)(region-extra-pdl-p region bits))    (SETF gen 4))(IF (region-oldspace-p region bits)    (SETF gen 5))(IF (region-copyspace-p region bits)    (SETF gen 6))(INCF (AREF d gen) (AREF #'region-length region))(INCF (AREF w gen) (AREF #'region-free-pointer region))))    (RETURN-FROM get-generation-sizes w d)))(DEFUN gc-status-history (&key (STREAM *STANDARD-OUTPUT*) &allow-other-keys)  (LET ((TGC 0)(TWD 0) (TCS 0)(TVAS 0))    (FORMAT STREAM "~2%GENERATION STATISTICS~                     ~%---------------------")    (MULTIPLE-VALUE-BIND (W D)(GET-GENERATION-SIZES)      (UNLESS (OR %GC-FLIP-READY  (= 0 GC-INITIAL-COPYSPACE-SIZE));; JIMI THE BOOKS SO THAT THE NEWSPACE DATA CONVERTED TO COPYSPACE BEFORE;; THE FLIP DOES NOT REPORT OUT ON THE COPYSPACE LINE.(LET ((GEN (1+ (TRUNCATE GC-TYPE-OF-FLIP 2))))  (SETF (AREF W GEN) (+ (AREF W GEN) GC-INITIAL-COPYSPACE-SIZE)(AREF D GEN) (+ (AREF D GEN) GC-INITIAL-COPYSPACE-SIZE)(AREF W 6) (- (AREF W 6) GC-INITIAL-COPYSPACE-SIZE)(AREF D 6) (- (AREF D 6) GC-INITIAL-COPYSPACE-SIZE))))      (FORMAT STREAM "~%~14TNUMBER OF~26TGARBAGE~40TWORK~51TCURRENT~63TCURRENT~75TFLIP")      (FORMAT STREAM "~&GENERATION~13TCOLLECTIONS~25TCOLLECTED~40TDONE~52TSIZE~64TVAS~75TSIZE~2%")      (DO ((GEN 0 (1+ GEN)))  ((= GEN 4))(SETF TGC (+ TGC (AREF GC-GARBAGE-COLLECTED GEN))      TWD (+ TWD (AREF GC-WORK-DONE GEN))      TCS (+ TCS (AREF W GEN))      TVAS (+ TVAS (AREF D GEN)))(FORMAT STREAM "~&~6D~13D~14:D~12:D~12:D~12:D~12:D"GEN(AREF GC-COLLECTION-COUNTERS GEN)(CEILING (AREF GC-GARBAGE-COLLECTED GEN) 256.)(CEILING (AREF GC-WORK-DONE GEN) 256.)(CEILING (AREF W GEN) 256.)(CEILING (AREF D GEN) 256.)(CEILING (AREF FLIP-SIZE GEN) 256.)))      (FORMAT STREAM "~&  STATIC~45T~12:D~12:D"      (CEILING (AREF W 4) 256.)      (CEILING (AREF D 4) 256.))      (FORMAT STREAM "~&OLDSPACE~45T~12:D~12:D"      (CEILING (AREF W 5) 256.)      (CEILING (AREF D 5) 256.))     (FORMAT STREAM "~&COPYSPACE~45T~12:D~12:D"      (CEILING (AREF W 6) 256.)      (CEILING (AREF D 6) 256.))      (FORMAT T "~%~%  TOTALS~19T~14:D~12:D~12:D~12:D~%"      (CEILING TGC 256.)      (CEILING TWD 256.)      (CEILING (+ TCS (AREF W 4) (AREF W 5) (AREF W 6)) 256.)      (CEILING (+ TVAS (AREF D 4) (AREF D 5) (AREF D 6)) 256.)))))(DEFUN display-gc-work-remaining (&optional (stream t) min-work max-work copying free old)  (WHEN (gc-in-progress-p)    (UNLESS min-work      (MULTIPLE-VALUE-SETQ (min-work max-work copying)(get-max-gc-work-remaining))      (MULTIPLE-VALUE-SETQ (nil free nil nil old)(get-space-needed-for-gc))      (WHEN (gc-in-progress-p) (DECF free old)))    (FORMAT stream "~%  Collection status: ~30tBetween ~:D and ~:D words of scavenging left to do.~                    ~%                     ~30tFree space ~:D (of which ~:D might be needed for copying).~                    ~%                     ~30tRatio scavenging work/free space = ~3F"    min-work max-work    free copying    (/ (FLOAT max-work) (- (- free old) copying))))  (VALUES))(DEFUN gc-status-batch-gc (&key (STREAM t) (verbose nil))  (LET (gc-distancespace-free dynamic-size static-size old-sizespace-needed)        (MULTIPLE-VALUE-SETQ (space-needed space-free dynamic-size static-size old-size)      (get-space-needed-for-gc))    (WHEN (gc-in-progress-p) (DECF space-free old-size))        (SETQ gc-distance (- space-free space-needed))        (FORMAT stream "~2%BATCH GC STATUS:~                     ~%----------------")        (COND      ((AND (gc-in-progress-p)    gc-batch-mode)       (FORMAT stream "~%  Status:            ~30t~a"       (COND ((scavenger-active-p)      "In progress.")     (t "Collection started but the scavenger is not active.")))       (FORMAT stream "~%  Collection type:   ~30t~a" gc-batch-mode);;       (MULTIPLE-VALUE-BIND (max-work min-work copying-work);;   (get-max-gc-work-remaining);; (display-gc-work-remaining stream min-work max-work copying-work space-free old-size))       )      ;; GC not in progress      (t       (FORMAT stream "~%FULL-GC:")       (FORMAT stream "~%  Status: ~30t~a"       (COND ((MINUSP gc-distance)      "No longer advisable.")     (t "READY.")))       (FORMAT stream  "~%  Free space needed:    ~30t~:D words (assuming 100% live data)."       space-needed)       (FORMAT stream  "~%  Next collection:")       (COND ((PLUSP gc-distance)      (FORMAT stream "~30tA FULL-GC garbage collection will remain~                              ~%~30t   possible for ~:D more words."      gc-distance))     (t      (FORMAT stream "~30tIt is ~:D words too late to do a FULL-GC"      (- gc-distance))))))))(DEFUN gc-status (&key (verbose nil) (stream *Standard-Output*))  "Print information about the status of garbage collection."  (gc-status-auto-gc :stream stream :verbose verbose)  (gc-status-batch-gc :stream stream :verbose verbose)  (gc-status-history :stream stream :verbose verbose)  (gc-status-variables :stream stream :verbose verbose)  (gc-status-general-info :stream stream :verbose verbose)  );;;;;;;;;;;;;;;;;;;;;;;;;; GC Process;;;;;; THE FOLLOWING PROVIDES A DESCRIPTION OF THE CONTROL USED IN TGC.;;;;;; GENERAL;;;;;; IN GENERAL WE WANT TO HOLD THE SCAVENGER INACTIVE FOR A WHILE AFTER A FLIP. THIS;;; IS DONE TO ALLOW DYNAMIC PROGRAM EXECUTION THE OPPORTUNITY TO CAUSE DYNAMICALLY;;; ACTIVE OBJECTS TO BE EVACUATED FROM OLDSPACE BEFORE THE SCAVENGER STARTS EVACUATION;;; USING THE STATIC GRAPH. THE HOLDOFF OF SCAVENGER ACTION IS IMPLEMENTED BY INITIALIZING;;; THE A-SCAV-WORK-DONE TO A NON-ZERO BIAS AT FLIP TIME. THIS WILL ALLOW A CONTROLLED AMOUNT;;; OF CONSING TO BE DONE AFTER THE FLIP BEFORE THE SCAVENGER IS ALLOWED TO START. INDEED;;; THIS SCAVENGER HOLDOFF IS ALSO THE PRIMARY CONTROL FOR GENERATION ZERO SIZE.;;; ;;; GENERATION 0;;; ;;; THE FLIPPING OF GENERATION 0 IS CONTROLLED TO HOLD THE SIZE BELOW A THRESHOLD WHICH ;;; IS CALCULATED AS A PERCENT OF THE SYSTEM RAM SIZE. THE INTENT IS TO ALLOW GENERATION ;;; ZERO TO BE MEMORY RESIDENT AND THE CURRENT PERCENT IS 10% OF RAM SIZE. WHEN GENERATION;;; ONE IS BELOW IT'S SIZE THRESHOLD (AS DESCRIBED BELOW) WE FLIP GENERATION ZERO ALLOWING;;; CONSING IN THE AMOUNT OF 10% OF RAM SIZE BEFORE SCAVENGER ACTION IS ALLOWED TO START.;;; NOTE: SINCE THIS CONSING MAY BE IN EITHER GENERATION ZERO OR ONE THE SIZE CONTROL;;; OF GENERATION ZERO IS NOT PRECISE.;;; ;;; GENERATIONS 1 AND 2.;;; ;;; UNLIKE GENERATION 0 WE EXPECT THAT COLLECTION OF THESE GENERATIONS WILL REQUIRE DISK ;;; I/O. WE WOULD LIKE TO CONTROL THE FLIPPING BASED ON SOME FORM OF SIZE THRESHOLD FOR ;;; SIMPLICITY. WE ALSO WOULD LIKE TO MAXIMIZE THE AMOUNT OF USABLE ADDRESS SPACE AND;;; OPERATE SAFELY.;;; ;;; SOME DEFINITIONS AND THEN SOME EQUATIONS.;;; ;;; S3 = STATIC, FIXED AND EXTRA PDL SPACE IN GENERATION THREE.;;; D3 = DYNAMIC SPACE IN GENERATION 3;;; D2 = DYNAMIC SPACE IN GENERATION 2;;; D1 = DYNAMIC SPACE IN GENERATION 1;;; D0 = DYNAMIC SPACE IN GENERATION 0;;; ;;; NOTE: THE FOLLOWING DEFINITION OF SCAVENGER WORK IS DIFFERENT FROM PAST ;;; PRACTICE. IN THE PAST THE AMOUNT OF WORK REQUIRED TO EVACUATE A WORD FROM;;; OLDSPACE HAS BEEN CONSIDERED EQUAL TO THE AMOUNT OF WORK REQUIRED TO SCAVENGE;;; A WORD. THIS IS SIMPLY NOT TRUE BY A LARGE FACTOR. THE WORK REQUIRED TO ACCESS;;; AND TRANSPORT A WORD FROM OLDSPACE IS MUCH LARGER THAN THE WORK REQUIRED TO;;; ACCESS AND SCAVENGE A WORD. IN THE FOLLOWING EQUATIONS THIS DIFFERENCE IS ;;; REFLECTED AS A FACTOR OF 8. THIS CORRECTION MAY NOT BE EXACT BUT IT IS MUCH ;;; CLOSER TO TRUTH THAN TREATING THE TWO DIFFERENT FORMS OF WORK EQUAL.;;; ;;; WHEN THE DO A FLIP THE SCAVENGER WORK TO BE DONE IS DEFINED AS:;;; ;;; THE WORK TO COPY NON-GARBAGE FROM OLDSPACE TO COPY SPACE;;; +;;; THE WORK TO SCAVENGE COPY SPACE;;; +;;; THE WORK TO SCAVENGE THE REQUIRED OTHER REGIONS.;;; ;;; INCLUDING THE FACTOR OF 8 DIFFERENCE BETWEEN THE TWO KINDS OF WORK THE SCAVENGER WORK;;; CAN BE EXPRESSED AS:;;; ;;; SW = 8*CS + CS + SS;;; ;;; THE SCAVENGER IS DRIVEN BY CONSING ACTIVITY. IN THE PAST A FACTOR OF 4 HAS BEEN USED;;; TO SCALE CONS WORK TO SCAVENGER WORK. WE WANT TO HOLD THE RELATIONSHIP OF CONS WORK ;;; TO COPY SPACE ABOUT THE SAME AS IT HAS BEEN IN THE PAST BUT NOW COPY SPACE;;; FEEDS INTO THE NEW DEFINITION OF SCAVENGER WORK WITH A COEFFICIENT OF 9 RATHER THAN 2;;; SO WE NEED TO SCALE CONS WORK BY A FACTOR OF 16 RATHER THAN 4. ;;; ;;; SW = 16*CW,;;; ;;; WHERE,;;; ;;; SW = SCAVENGER WORK;;; ;;; CW = CONS WORK.;;; ;;; FOR SAFETY PLANNING WE MUST TAKE THE PESSIMISTIC VIEW THAT ALL OF OLDSPACE WILL;;; SURVIVE TO COPYSPACE. THIS ALLOWS US TO CALCULATE THE "RESERVE" ADDRESS SPACE ;;; REQUIRED IN ORDER TO BE ABLE TO DO A FLIP AND INCREMENTAL COLLECTION.;;; ;;; RI = DI + CWI + BIAS = DI + SWI/16 + BIAS = DI + (9*DI + SSI)/16 + BIAS = DI*25/16 + SSI/16 + BIAS;;; ;;; WHERE, ;;; ;;; SSI = THE WORK TO SCAVENGE THE REQUIRED OTHER REGIONS FOR A FLIP OF DI.;;; ;;; EXPANDING THIS EQUATION OUT WE HAVE,;;; ;;; R1 = (D1*25 + D0)/16 + BIAS;;;;;;    (ASSUMING THE SIZE OF HIGHER GENERATION 0, AND 1 VOLATILITY REGIONS IS VERY SMALL.);;;;;; NOW, IF VAS IS THE TOTAL VIRTUAL ADDRESS SPACE OF THE MACHINE WE HAVE:;;;;;; VAS = S3 + D3 + D2 + D1 + D0 + R1;;;;;;     = S3 + D3 + D2 + BIAS + D0*17/16 + D1*41/16;;;;;; SOLVING FOR D1 AND CALLING THIS VALUE MAX-SAFE-D1 WE HAVE:;;;;;; MAX-SAFE-D1 = (VAS - S3 - D3 - D2 - BIAS - D0*17/16)*16/41 ;;;;;; WE ALSO HAVE:;;;;;; MAX-SAFE-D2 = (VAS - S3 - D3 - BIAS - (D1 + D0)*17/16)*16/41;;;(DEFUN gc-process ()  (LET ((usable-address-space-limit (ROUND (* 95. (usable-address-space-limit))   100.)) ;; PUT IN A 5% SAFETY PAD(MAX-SAFE-D1)(MAX-SAFE-D2)(PREVIOUS-GENERATION-HIGH T)(SCAV-WORK-BIAS  (ROUND (* GC-FRACTION-OF-RAM-FOR-GENERATION-ZERO    (SYSTEM:SYSTEM-COMMUNICATION-AREA      SYSTEM:%SYS-COM-MEMORY-SIZE)))))    (SETF (AREF FLIP-SIZE 0) SCAV-WORK-BIAS)    (DO ()(NIL);Do forever      (OR %GC-FLIP-READY (PROCESS-WAIT "Await scavenge" 'SYMBOL-VALUE '%GC-FLIP-READY))      (GC-RECLAIM-OLDSPACE)      (MULTIPLE-VALUE-BIND (W D)  (GET-GENERATION-SIZES)(IF (= *GC-MAX-INCREMENTAL-GENERATION* 0)    (SETF (AREF FLIP-SIZE 1) 0)    (SETF MAX-SAFE-D1 (ROUND (* 16.(- USABLE-ADDRESS-SPACE-LIMIT   (AREF D 4)   (AREF D 3)   (AREF D 2)   SCAV-WORK-BIAS   (ROUND (* (AREF D 0)     17.)  16.)))     41.))    (SETF (AREF FLIP-SIZE 1) MAX-SAFE-D1))(IF (< *GC-MAX-INCREMENTAL-GENERATION* 2.)    (SETF (AREF FLIP-SIZE 2) 0)    ;; THE VALUE SET BELOW IS AN ESTIMATE TO GIVE A REASONABLE    ;; VALUE FOR THE GC-STATUS DISPLAY. THIS CALCULATION ESTIMATES WHAT THE SIZE OF GENERATIONS 0 AND 1    ;; WILL BE WHEN GENERATION 2 IS FLIPPED. (NOTE THAT A GENERATION 2 INCREMENTAL COLLECTION WILL    ;; ALWAYS BE IMMEDIATELY PRECEEDED BY AN INCREMENTAL COLLECTION OF GENERATIONS 0 AND THEN 1.)    ;; THE REAL OPERATIVE GENERATION 2 FLIP THRESHOLD IS CALCULATED ON THE FLY IMMEDIATELY AFTER    ;; THE GENERATION 1 COLLECTION USING THE ACTUAL KNOWN SIZES FOR GENERATIONS 0 AND 1.    (SETF (AREF FLIP-SIZE 2) (ROUND (* 16.       (- USABLE-ADDRESS-SPACE-LIMIT  (AREF D 4)  (AREF D 3)  SCAV-WORK-BIAS ;; CONSING ALLOWED AT THE FRONT OF THE G1 COLLECTION.  (ROUND MAX-SAFE-D1  ;; CONSING REQUIRED TO DRIVE G1 TO COMPLETION. 2.)))    41.)))(COND ((OR PREVIOUS-GENERATION-HIGH   (= 0 *GC-MAX-INCREMENTAL-GENERATION*)   (< (AREF D 1) MAX-SAFE-D1))       ;; THIS LEG WILL FLIP GENERATION 0.       (SETF PREVIOUS-GENERATION-HIGH NIL)       (GC-FLIP-NOW 1 (* 16. SCAV-WORK-BIAS)))      (T       ;; THIS LEG WILL FLIP GENERATION 1 AND POSSIBLY GENERATION 2.       (SETF PREVIOUS-GENERATION-HIGH T); FLIP GENERATION 1 WITH PROMOTION.       (GC-FLIP-NOW 3 (* 16. SCAV-WORK-BIAS))       (WHEN (> *GC-MAX-INCREMENTAL-GENERATION* 1.) ;; WAIT IN THIS LEG SO WE CAN LOOK AT THE RESULTS (PROCESS-WAIT "Await scavenge" 'SYMBOL-VALUE '%GC-FLIP-READY) (GC-RECLAIM-OLDSPACE) ;; GET UPDATED SIZE INFORMATION (MULTIPLE-VALUE-SETQ (W D) (GET-GENERATION-SIZES)) (SETF MAX-SAFE-D2 (ROUND (* 16.     (- USABLE-ADDRESS-SPACE-LIMIT(AREF D 4)(AREF D 3)SCAV-WORK-BIAS(ROUND (* (+ (AREF D 0)     (AREF D 1))  17.)       16.)))  41.)) (WHEN (> (AREF D 2) MAX-SAFE-D2)   ;; FLIP GENERATION 2 WITHOUT PROMOTION.   (GC-FLIP-NOW 4. (* 16. SCAV-WORK-BIAS))   ;; WAIT IN THIS LEG SO WE CAN LOOK AT THE RESULTS   (PROCESS-WAIT "Await scavenge" 'SYMBOL-VALUE '%GC-FLIP-READY)   (GC-RECLAIM-OLDSPACE)   ;; GET UPDATED SIZE INFORMATION   (MULTIPLE-VALUE-SETQ (W D) (GET-GENERATION-SIZES))   (WHEN (> (AREF D 2) MAX-SAFE-D2)     ;; GENERATION 2 IS STILL ABOVE THE SAFE SIZE TO FLIP.     ;; SHUT IT DOWN.     (with-gc-notifications-forced-maybe       (SETF (AREF FLIP-SIZE 2) 0)       (SETF *GC-MAX-INCREMENTAL-GENERATION* 1.)       (GC-REPORT "GC: GENERATION 2 IS FULL AND WILL NOT BE INCREMENTALLY COLLECTED IN THE FUTURE.")))))))))))(DEFUN arrest-gc (reason &aux arrest-reasons)  "Arrests GC if it is active.  REASON be added to the gc process's arrest reasons,if not already present."  (COND ((gc-active-p) (SEND gc-process :arrest-reason reason) (SETQ inhibit-scavenging-flag t))((AND (VARIABLE-BOUNDP gc-process)      (NOT (NULL gc-process))      (SETQ arrest-reasons (SEND gc-process :arrest-reasons))) (UNLESS (MEMBER reason arrest-reasons :test #'EQUAL)   (SEND gc-process :arrest-reason reason))))  )(DEFUN unarrest-gc (reason)  "Unarrests the GC process by removing REASON from its arrest reasons if itis present."  (WHEN (AND (VARIABLE-BOUNDP gc-process)     (NOT (NULL gc-process))     (SETQ reason   (CAR (MEMBER reason (SEND gc-process :arrest-reasons) :test #'EQUAL))))    (SEND gc-process :revoke-arrest-reason reason)    (UNLESS (SEND gc-process :arrest-reasons)      (SETQ inhibit-scavenging-flag nil))))(DEFUN GC-ON ()  "Turn on automatic garbage collection."  (UNLESS %tgc-enabled (enable-tgc))  (UNLESS (gc-active-p)    (gc-maybe-set-flip-ready);Set flip ready if no oldspace    (with-batch-gc-notifications      (gc-reclaim-oldspace)      (GC-REPORT "GC: Starting automatic garbage collection."))    (WHEN (NULL gc-process)      (SETQ gc-process (MAKE-PROCESS 'gc-process)))    ;; Start flipper process.    (UNLESS (SEND gc-process :arrest-reasons)      (PROCESS-PRESET gc-process #'gc-process)      (PROCESS-ENABLE gc-process))    (SETQ inhibit-scavenging-flag nil);Enable scavenging during cons    (ADD-INITIALIZATION "GC-PROCESS" '(GC-ON) '(WARM))    (PROCESS-ALLOW-SCHEDULE)    t))(DEFUN GC-OFF (&key (finish-current t))  "Turn off automatic garbage collection."  (DECLARE (ARGLIST))  (WHEN (AND (gc-active-p)     (OR (NEQ GC-FLIP-LOCK GC-PROCESS) (YES-OR-NO-P "The gc process is currently locking the GC lock.  Turn it off anyway? ")))    (DELETE-INITIALIZATION "GC-PROCESS" '(WARM));Don't start GC on warm boots anymore    (PROCESS-DISABLE gc-process);Disable flipper process    (WHEN (EQ GC-FLIP-LOCK GC-PROCESS);Unlock the lock so user can SI:FULL-GC.      (SETQ GC-FLIP-LOCK NIL))    (WHEN finish-current      (with-batch-gc-notifications(gc-report (FORMAT nil "GC: Turning off automatic garbage collection~a"   (IF gc-oldspace-exists       " (after completing pending collection)."       "."))))      ;; Batch reclaim any oldspace      (with-verbose-gc-notifications-only(GC-RECLAIM-OLDSPACE))))  ;; Disable scavenge during cons  (SETQ inhibit-scavenging-flag t))(DEFUN gc-maybe-set-flip-ready ()  "Sets up %GC-FLIP-READY if no oldspace anywhere."  (LOOP FOR area-sym IN area-listFOR 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 (region-oldspace-p reg (AREF #'region-bits reg))(RETURN-FROM gc-maybe-set-flip-ready nil)))FINALLY (PROGN   (WRITE-METER '%Count-Scavenger-Work #o10000000000)  (SETQ %Gc-Flip-Ready t))));;;;;;;;;;;;;;;;;;;;; Flipping;;;(DEFUN deallocate-end-of-region (region)  "Return as much as possible of unused part of region REGION to free pool.It can then be allocated to other regions."  (WITHOUT-INTERRUPTS    (LET* ((free-pointer (AREF #'region-free-pointer region))   (origin (AREF #'region-origin region))   (size (AREF #'region-length region))   (n-quanta (TRUNCATE size %address-space-quantum-size))   ;; MAX 1 below is so we don't truncate a region to zero length.   (first-free-quantum (MIN n-quanta    (MAX 1 (CEILING free-pointer  %address-space-quantum-size)))))      (UNLESS (= first-free-quantum n-quanta);; Less than one quantum is free.(DO ((i first-free-quantum (1+ i))     (origin-quantum       (LDB %%va-quantum-number origin)))    ((= i n-quanta))  (SETF (AREF #'address-space-map (+ origin-quantum i)) 0))(SETF (AREF #'region-length region) (* first-free-quantum %address-space-quantum-size))(DEALLOCATE-PAGES (%POINTER-PLUS origin (AREF #'region-length region))  (TRUNCATE (%POINTER-DIFFERENCE size (AREF #'region-length region))    page-size)))))  );;; This is the only function that actually performs a flip.(DEFUN gc-flip-now (gc-type &optional (scav-work-bias 0) &aux generation promote bits)  (WITH-LOCK (gc-flip-lock)    ;; Just in case scavenging not done yet, finish it up.    (IF (NOT %gc-flip-ready)(gc-reclaim-oldspace))    ;; Reset counters and     (SETQ %Page-Cons-Alarm 0  %Region-Cons-Alarm 0)    ;; Set all daemon alarms to go off soon.    (WHEN (FBOUNDP 'init-gc-daemon-queue)      (init-gc-daemon-queue))    ;; Deliver flip message, etc.    (process-gc-start-stats gc-type)    (WITHOUT-INTERRUPTS      (PROCESS-WAIT "Flip inhibited" #'(LAMBDA () (NOT Inhibit-Gc-Flips)))      ;; Perform whatever actions other programs need to do on flips      (MAPC #'EVAL Gc-Every-Flip-List)      (MULTIPLE-VALUE-SETQ (generation promote)(FLOOR gc-type 2))      (SETF gc-initial-copyspace-size 0)      (LOOP FOR area-sym IN AREA-LIST    FOR area = (SYMBOL-VALUE area-sym)    WITH l-enable  WITH s-enable  DO    (SETQ l-enable t s-enable t)    (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region)  UNTIL (MINUSP region) DO  ;; Set back scavenger pointer for all regions.  (SETF (AREF #'region-gc-pointer region) 0)  (SETQ bits (AREF #'region-bits region))  ;; For promoting collections, want to use EXISTING newspace regions in the  ;; next generation up as our copyspace to avoid fragmentation.  (WHEN (AND (= promote 1)     (region-newspace-p region bits)     ;; Generation = volatility = generation we're promoting to     (= (region-generation region bits)(region-volatility region bits)(1+ generation))     (<= (region-generation nil (AREF #'area-region-bits area)) generation)     ;; The term below says "don't convert more than one active region for     ;; each representation type per area." This avoids excess creation of     ;; active newspace regions.     (OR (region-inactive-p region bits) (AND l-enable (region-list-p region bits)) (AND s-enable (region-structure-p region bits)))     ;; And there's some room worth mentioning....     (> (- (AREF #'region-length region) (AREF #'region-free-pointer region))500.))     ;; Convert this region to copyspace so that it may be used for the     ;; evacuation of objects from the younger generation.     (WHEN (region-active-p region bits)       (IF (region-list-p region bits)   (SETF l-enable nil)   (SETF s-enable nil)))     (INCF gc-initial-copyspace-size (AREF #'region-free-pointer region))     (SETF (AREF #'region-bits region)   (%LOGDPB %region-space-copy %%region-space-type    (%LOGDPB 1 %%region-scavenge-enable bits)))     (SETF (AREF #'region-gc-pointer region) (AREF #'region-free-pointer region)))))      ;; 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))))      (MAPC #'EVAL Gc-After-Flip-List)      (SETQ Gc-Oldspace-Exists t))    ))(DEFUN gc-reclaim-oldspace ()  "This function finishes a collection.  It scavengs any un-scavenged oldspacethen frees all oldspace for later use.  Does nothing if there is no oldspace."  (WITH-LOCK (Gc-Flip-Lock)    (WHEN GC-Oldspace-Exists      ;; Make sure all regions are clean (no pointers to oldspace)      (DO ()  (%Gc-Flip-Ready);stop when scavenger says all is clean(%gc-scavenge #o10000))      ;; Report oldspace statistics,etc      (process-gc-done-stats)      (IF %gc-flip-ready  (WITHOUT-INTERRUPTS     ;; Return oldspace regions to free region pool.    (DOLIST (area Area-List)      (LET ((area-number (SYMBOL-VALUE area)))(WHEN (OR (MINUSP area-number) (>= area-number Size-Of-Area-Arrays))  (FERROR nil "Area-symbol ~S clobbered" area))(gc-reclaim-oldspace-area area-number)))    (SETQ Gc-Oldspace-Exists nil))  (FERROR nil "Semaphore error in GC-Reclaim-Oldspace"))      ;; Wake up daemon process      (WHEN (FBOUNDP 'check-all-gc-daemons)(check-all-gc-daemons)))));;; Deletes all old-space regions of a specified area, unthreading from the lists;;; and returning the regions to the free list.;;; Note that if an area has only one oldspace region, we change its type to NEW but;;; leave it as the one region in the area.(DEFUN gc-reclaim-oldspace-area (area)  (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area Size-Of-Area-Arrays)) "an area number")  (WITHOUT-INTERRUPTS   (UNLESS %Gc-Flip-Ready (FERROR nil "You cannot reclaim oldspace now; GC is still in progress"))   (DO ((region (AREF #'area-region-list area) (AREF #'region-list-thread region))(region-to-free)(prev-region nil region)bits new-region)       ((MINUSP region))     LP     (WHEN (MINUSP region) (RETURN nil))     (SETQ bits (AREF #'region-bits region))     ;; If region is oldspace, we will reclaim it.     (WHEN (region-oldspace-p region bits)       ;; Free this region.  First advance vars for next iteration       (SETQ region-to-free region     region (AREF #'region-list-thread region))       ;; Before freeing region, un-link it from region list.       (IF (AND (= region-to-free (AREF #'area-region-list area))(last-area-region region-to-free))   ;; Only region is oldspace.  We can't leave area with no regions,   ;; but can't just convert it to NEWSPACE because the level 1 maps   ;; will still say OLDSPACE.  We will make a new NEWSPACE region   ;; and link it in here.   (PROGN     (SETQ new-region   (%make-region      (%LOGDPB 0 %%region-scavenge-enable      (%LOGDPB %Region-Meta-Bit-Not-Oldspace %%region-oldspace-meta-bit       (%LOGDPB %region-space-new %%region-space-typebits)))     (AREF #'region-length region-to-free)))     (SETF (AREF #'region-list-thread new-region) region)     (SETF (AREF #'AREA-REGION-LIST area) new-region))   ;; Not only region in area.  Just un-link.   (IF prev-region       (SETF (AREF #'REGION-LIST-THREAD prev-region) region)       (SETF (AREF #'AREA-REGION-LIST area) region)))       ;; Now free up the swap space, return region to free pool, and go to next loop iteration.       (deallocate-swap-space region-to-free)       (%gc-free-region region-to-free)       (GO LP))     (WHEN (region-copyspace-p region)       ;; Release as much space as possible from a copy space       ;; region since we already have a new space consing region       ;; if this is generation 0 and new consing will be in       ;; generation 0 if it is a higher generation.       (deallocate-end-of-region region)       ;;; Change this region to NEW space.       (%make-region-dynamic region)))));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; User-callable batch-style GC routines;;;;; This is internal function.  Won't be documented in the manuals, but will have;; doc string just in case someone runs into it.(DEFUN gc (&key (max-gen 3) (first-gen 0) (promote nil)   (type :immediate) before-disk-save duplicate-pnames   (silent nil) after-system-build debug)  "Perform a garbage collection.  The TYPE keyword permits some control over the type of GC performed.  The BEFORE-DISK-SAVE keyword, when non-nil, means that you intend to do adisk-save right after the GC.  This knowledge allows GC to perform additional services that would normally only be done before a disk-save, such as dismounting the file system and clearing the namespace.  The DUPLICATE-PNAMES keyword will collapse duplicate symbol print names if theyexist.  This is useful in reclaiming space after the loading of large systems."  (DECLARE (ARGLIST (&key (max-gen 2) (promote nil) (:type :immediate)  (silent nil) before-disk-save duplicate-pnames))   (SPECIAL GC-System-Build-Forms-Before GC-System-Build-Forms-After))  (WHEN (> max-gen %region-max-generation)    (SETQ max-gen %region-max-generation))  (LET (gc-was-on-flag space-sizes)    ;; Turn off automatic GC.    (WHEN (gc-active-p)      (IF silent  (with-gc-notifications-inhibited (GC-OFF))  (GC-OFF))      (SETQ gc-was-on-flag t))    ;; Do after-system-build stuff before anything else    (WHEN after-system-build      (MAPC #'EVAL GC-System-Build-Forms-Before))    (WHEN (EQ type :full)      ;; Run list of forms that releases large data structures.      (IF silent  (INITIALIZATIONS 'Full-Gc-Initialization-List t)  (with-batch-gc-notifications    (gc-report "Running FULL-GC initializations.")    (LET ((qld-mini-done (IF debug nil t)))      (DECLARE (SPECIAL qld-mini-done))      (INITIALIZATIONS 'Full-Gc-Initialization-List t)))))    (WHEN (AND duplicate-pnames       (= max-gen %region-max-generation))      (IF silent  (collapse-duplicate-pnames)  (with-batch-gc-notifications (collapse-duplicate-pnames))))    (WHEN before-disk-save      (IF (FBOUNDP 'fs:dismount-file-system) (fs:dismount-file-system))      (IF (FBOUNDP 'name:clear-namespaces) (name:clear-namespaces)))    ;; Perform the collection...    (WITH-LOCK (Gc-Flip-Lock)      (with-batch-gc-notifications(LET-GLOBALLY ((gc-report (IF silent nil gc-report))       (Gc-Batch-Mode type)       (Inhibit-Scavenging-Flag nil))  ;; When oldspace exists, we're not done with a previous GC cycle, so  ;; just finish it (by reclaiming oldspace).  Otherwise, start new cycle  ;; and do a complete collection.  (WHEN Gc-Oldspace-Exists (gc-reclaim-oldspace))  (SETQ space-sizes (make-space-size-info))  (DO* ((gen first-gen (1+ gen)))       ((> gen max-gen))    (WHEN (PLUSP (gen-size-allocated gen (get-space-size-info space-sizes)))      (gc-flip-now (+ gen gen (IF (AND promote (/= gen 3)) 1 0)))      (gc-reclaim-oldspace))));; Some cleanup...(WHEN (EQ type :full)  (INITIALIZATIONS 'After-Full-Gc-Initialization-List t))(WHEN after-system-build  (MAPC #'EVAL GC-System-Build-Forms-After))))    (WHEN gc-was-on-flag      (IF silent  (with-gc-notifications-inhibited    (LET ((gc-gen (1+ %gc-generation-number)))      (GC-ON)      (PROCESS-WAIT "Await flip";give gc process chance to run    #'(lambda () (= %gc-generation-number gc-gen)))))  (GC-ON))))  (PROCESS-ALLOW-SCHEDULE))(DEFUN gc-immediately (&key (max-gen 2) (promote nil) (silent nil))  "Perform a quick batch-style garbage collection."  (gc :type :immediate :max-gen max-gen :silent silent :promote promote))(DEFUN full-gc (&key (silent nil) (before-disk-save t) duplicate-pnames(max-gen 3) (promote nil)after-system-build debug &allow-other-keys)  "Perform a complete garbage collection aimed at reclaiming the largest amountof garbage, thus reducing the size of the resulting Lisp world.  When :BEFORE-DISK-SAVE is non-NIL (the default), extra shutdown proceduresare performed that release large data structures, such as dismounting the filesystem and clearing the namespaces.  The :DUPLICATE-PNAMES keyword, if non-NIL, will collapse duplicate symbol print namesif they exist.  This is useful in reclaiming space after the loading of large systems."  (DECLARE (ARGLIST &key (max-gen 3) (promote nil) (before-disk-save t) duplicate-pnames silent))  (gc :type :full      :silent silent      :max-gen max-gen :promote promote      :duplicate-pnames duplicate-pnames      :before-disk-save before-disk-save      :after-system-build after-system-build      :debug debug))(DEFUN gc-and-disk-save (partition &optional (unit *Default-Disk-Unit*)           &key (partition-comment System-Additional-Info)         no-query)  "Perform a complete garbage collection then DISK-SAVE the resulting Lisp world.This is equivalent to doing (FULL-GC :BEFORE-DISK-SAVE T :DUPLICATE-PNAMES T)follwed by (DISK-SAVE partition unit :NO-QUERY t :PARTITION-COMMENT partition-comment).  GC-AND-DISK-SAVE warns you up front about the partition you are using and anyspace problems it can detect.  However, if the space problems are not solved bythe garbage collection, the subsequent DISK-SAVE will not complete.  With a NON-nil :NO-QUERY keyword value, no questions will be asked at all.  Thisoption should be used with caution."  (BLOCK gc-and-disk-save    (LET (save-part-name save-part-name-hi-16-bits save-part-name-lo-16-bits  save-part-base save-part-size estimated-dump-size dump-size-delta  vm-size free-space-delta free-space-needed free-space dyn-size stat-size)      ;; Decode partition argument.      (MULTIPLE-VALUE-SETQ (save-part-name save-part-name-hi-16-bits   save-part-name-lo-16-bits)   (disk-restore-decode partition))      ;; Get base & start for partition to save into.      (UNLESS (MULTIPLE-VALUE-SETQ (save-part-base save-part-size)(IF no-query    (find-disk-partition-for-read save-part-name nil unit)    (IF (AND (EQ unit *Default-Disk-Unit*)     (STRING-EQUAL save-part-name *Loaded-Band*))(PROGN  (UNLESS (YES-OR-NO-P *Save-Over-Self-Warning*       *Loaded-Band* *Default-Disk-Unit*)    (RETURN-FROM GC-And-Disk-Save nil))  (find-disk-partition-for-read save-part-name nil unit))(find-disk-partition-for-write save-part-name nil unit))))(RETURN-FROM gc-and-disk-save nil))      ;; Check if enough space to GC.      (MULTIPLE-VALUE-SETQ (free-space-needed free-space dyn-size stat-size)(get-space-needed-for-gc))      (SETQ vm-size (+ dyn-size stat-size)    free-space-delta (- free-space-needed free-space))      ;; Check for partition too small      (SETQ estimated-dump-size (estimate-dump-size)    dump-size-delta (* (- estimated-dump-size save-part-size) disk-block-word-size))      (COND (no-query nil)    ((AND (PLUSP free-space-delta)  (> free-space-delta dump-size-delta))     ;; Looks like there might not be enough space to GC.     (FORMAT *Query-Io*     "~%WARNING:  Full GC may require up to ~:d words of free space, ~                      ~%~:d words more than currently available.  Therefore GC may not ~                      ~%complete successfully unless about ~d% of your currently allocated ~                      ~%memory is garbage."     free-space-needed free-space-delta     (CEILING (* free-space-delta 100.) vm-size))     (UNLESS (YES-OR-NO-P "~%Try GC anyway? ")       (RETURN-FROM gc-and-disk-save nil)))    ((AND (PLUSP dump-size-delta)  (>= dump-size-delta free-space-delta))     (FORMAT *Query-Io*     "~%WARNING:  Disk-Saving the current Lisp world would require ~d blocks,~                      ~%but partition ~a on unit ~d is only ~d blocks long.  To fit in this partition ~                      ~%GC must collect ~:d words of garbage (~d% of currently allocated storage).~                      ~%If less garbage is reclaimed the Disk-Save will not be done.~%"     estimated-dump-size save-part-name unit save-part-size     dump-size-delta (CEILING (* dump-size-delta 100.) vm-size))     (UNLESS (YES-OR-NO-P "~%Try GC and DISK-SAVE anyway? ")       (RETURN-FROM gc-and-disk-save nil))))      (FULL-GC :max-gen 3 :promote nil :duplicate-pnames t :before-disk-save t :silent no-query)            (LET ((*Dont-Warn-About-Disk-Save-Over-Current-Band* t))(DECLARE (SPECIAL *Dont-Warn-About-Disk-Save-Over-Current-Band*))(DISK-SAVE partition unit :no-query t :partition-comment partition-comment))      )));;;;;; Training Support;;;(DEFVAR gc-on-before-training nil)(DEFUN start-training-session ()  "This function is used to start a dynamic training session."  (UNLESS *training-session-started*    ;; Turn off automatic GC if it is on.    (WHEN (gc-active-p)      (SETQ gc-on-before-training t)      (GC-OFF))    (make-generation-three-dynamic)    ;; Flip generation 3 to oldspace, but don't start scavenger.    (gc-flip-now 6.)    (with-batch-gc-notifications      (gc-report "Dynamic training session started."))    (SETQ *training-session-started* t))  )(DEFUN end-training-session (&key (make-gen3-static t))  "This function is used to terminate a dynamic training session."  ;;  1. Finish the pending Reclaim the rest of generation three oldspace.  ;;  2. Make generation three static (if specified by user).  ;;  3. Perform a promoting GC to collect the garbage from the training and  ;;     place the non-garbage in generation 3.  ;;  4. Turn GC-ON.  (DECLARE (ARGLIST))  (WHEN *training-session-started*    ;; Finish pending collection of generation 3 by batch scavenging.    (with-batch-gc-notifications      (gc-report "Finishing pending generation 3 collection.  This will take a while..."))    (with-verbose-gc-notifications-only      (gc-reclaim-oldspace))    ;; Make all generation 3 survivors static (if specified by user).    (WHEN make-gen3-static      (MAKE-GENERATION-THREE-STATIC))    ;; Clean out 0 and 1, then full-gc.    (gc-immediately :max-gen 1 :promote t)    (FULL-GC :max-gen 2 :promote nil)    (WHEN gc-on-before-training      (GC-ON)      (SETQ gc-on-before-training nil))    (SETQ *training-session-started* nil))  );;;;;; TGC Enable/Disable support(DEFUN collect-generation (generation)  (gc :first-gen generation :max-gen generation :type :immediate :promote t))(DEFUN enable-tgc ()  (WITHOUT-INTERRUPTS     ;; Get rid of temporary areas, except for special one.    (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ)  FOR area-num = (SYMBOL-VALUE area)  DO  (WHEN (AND (area-temporary-p area-num)     (/= area-num chaos:chaos-buffer-area);temp     (NOT (MEMBER area *permanent-temporary-areas-list* :test #'eq)))    (%make-temporary-area-dynamic area-num)))    ;; Change default-cons-generation of dynamic areas to 0 (or 1).  This    ;; will begin the consing of most new objects in young generations.    (start-young-consing)    (SETQ %tgc-enabled t)))(DEFUN disable-tgc ()  ;; Turn off the consing of new objects in young generations (0 or 1).  All  ;; future objects will be consed in generation 3.  (stop-young-consing)  ;; Garbage collect all generations, promoting as we go.  At end of this  ;; everything will be in generation 3, and there will be no more indirection cells.  (LOOP FOR gen = 0 THEN (1+ gen)WITH space-sizes = (make-space-size-info)UNTIL (> gen Number-Of-Generations)DO(gc-immediately :max-gen gen :promote t)(FORMAT t "~%Space sizes: ~a" (get-space-size-info space-sizes)))  ;; Restore temporary areas  (LOOP FOR area IN *areas-not-made-temporary-list*;user wanted these temporary, but we wouldn't let him...FOR area-num = (SYMBOL-VALUE area)DO (%make-area-temporary area-num))  (SETQ %tgc-enabled nil))ween end of wired space and start of;;; non-fixed areas (ie, the fixed but not wired space).(Defun Save-Fixed-Non-Wired-Space (new-dpmt save-part-base save-part-size save-unit   &aux first-cluster-va)  (DECLARE (INLINE convert-to-unsigned))  ;; If Fixed areas start in middle of cluster, save off first partial cluster specially.  (save-first-partial-cluster new-dpmt save-part-base save-unit)  (setq first-cluster-va(* Cluster-Size-In-Words     (ceiling (AREF #'system-communication-area %Sys-Com-Wired-Size)      Cluster-Size-In-Words)))  ;; Now save off rest of Fixed-Non-Wired areas.  (init-disk-vars save-part-base first-cluster-va)  (do* ((end-address  (* Cluster-Size-In-Words     (ceiling        (+ (convert-to-unsigned (AREF 