;;; -*- Mode:Common-Lisp; Package:System-Internals; Base:8.; -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(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- 1989 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. ;;; 05-04-87 ab *P GC 2 - Rewrote, expanded GC-STATUS. ;;; 05-05-87 ab *P GC 3 - Couple more fixes/changes to GC-STATUS (fix batch status). ;;; - Also wrote VERIFY-GC-SAFE routine to assure there is enough ;;; space to do batch GC and warn if not. Have batch GC fns ;;; (GC, GC-AND-DISk-SAVE, etc) call it. ;;; 05-13-87 ab *P GC 4 - Allow GC to do COLLAPSE-DUPLICATE-PNAMES only when max-gen ;;; is at least 2. ;;; - Fix doc strings on FULL-GC, GC-IMMEDIATELY. Make FULL-GC ;;; promote by default. ;;; - Also put in routines for turning off GC temporarily then back on. ;;; 05-14-87 ab *P GC 5 - Change TRAINING-SESSION routines to minimize memory locked up ;;; static by training: ;;; o END-TRAINING-SESSION makes generation 3 COPYSPACE static (ie, ;;; only exactly what has been trained) before reclaiming oldspace. ;;; o START-TRAINING-SESSION by default does not make the currently ;;; static part of generation 3 dynamic so previous training ;;; is not undone. It also now does (GC-IMMEDIATELY :promote t) ;;; to get stuff into 3 for training. ;;; o END-TRAINING-SESSION-AND-DISK-SAVE for doing GC-AND-DISK-SAVE too. ;;; - Make GC-OFF wait for GC-FLIP-LOCK. ;;; 05-22-87 ab *P GC 6 - Fix GC-MAYBE-SET-FLIP-READY to set GC-OLDSPACE-EXISTS properly. ;;; Make sure batch GC routines and GC-OFF call GC-MAYBE-SET-FLIP-READY. ;;; Also first turn off automatic GC in DISABLE-TGC. ;;; 05-28-87 ab *P GC 7 - Fix GC-FLIP-NOW if SCAV-WORK-BIAS is a BIGNUM (on large memory systems). ;;; Also fix ENABLE-TGC if chaos not in band. ;;; 07-09-87 ab GC 8 - Change GC-PROCESS to calculate flip thresholds for generations 1 and 2 ;;; differently to reduce frequency of generation 1 collections. ;;; GC 9 - Additions/changes for TGC training support. ;;; 08-04-87 ab/hrc GC 11 - Take into account core pages needing swap space when calculating free swap space. ;;; - Also try to catch case where gen 2 is uncollectable before trying to flip it. ;;; 08-05-87 ab/hrc GC 12 - Add CONSOLIDATE-AREAS hack to reduce band size in light of adaptive training. ;;; 08-18-87 rjf GC 15 - Make sure scav-work-bias isn't too big to fit ;;; in space provided. ;;; 08-19-87 rjf GC 16 - fixed so can arrest gc process that is stopped, so it can't be restarted ;;; 09-03-87 rjf GC 19 - print message if skipping generation because if is empty. ;;; 09-03-87 rjf GC 20 - fixed verify-gc-safe to do the right thing for when :max-gen 0 is used. ;;; 09-09-87 rjf/hc GC 21 - Improvement in gc-process control logic for deciding when to flip gen 1 so gen 2 is ;;; still flipable. ;;; 09-14-87 rjf/hc GC 22 - Added support for oversize region changes. ;;; 09/15/87 rjf GC 23 - Fixed so it would set %gc-flip-ready correctly, this was causing the ;;; semaphore error. ;;; 09/30/87 rjf GC 24 - Fixed divide by zero problem in process-gc-done-stats. ;;; 11/17/87. rjf GC 26 - Save all info about oldspace at flip time and used them in gc-status ;;; display if in a flip state. ;;; 1/15/88 DNG - Fix bug in GC-REPORT when window system not present. ;;; 1/19/88 DNG - Modify GC-STATUS-VARIABLES to avoid using LISTARRAY. ;;; 1/25/88 hrc/jho - Modified gc-immediately, gc, full-gc, gc-flip-now, gc-process, ;;; gc-reclaim-oldspace, get-generation-sizes, gc-status-history ;;; gc-size, training-off, gc-status-auto-gc, and ;;; gc-reclaim-oldspace-area for EAS. ;;; Added gc-external and gc-inhibit-usage-increment. ;;; 2/15/88 RJF - Added code to gc-reclaim-oldspace-area maintain region-area-map. ;;; 2/20/88 DNG - Collect unused pathnames on full-gc before disk save. ;;; 7/13/88 RJF GC 4-4 - Added BC fix for consolidate-area-current-content to handle train ;;; space and update area-region-map. ;;; 7/18/88 clm --- - Fix for the problem in spr 6416 - trouble doing a logout after a gc ;;; and before a disk-save. The gc blasts the net so you cannot do some ;;; of the logout items. Solution, logout before you start the gc ;;; 8/29/88 ab GC 5-1 - Add support to GC-AND-DISK-SAVE to create the save partition dynamically. ;;; For microExplorer only. ;;; - Also fixed the following long-standing bugs in GC-AND-DISK-SAVE: ;;; .. Warning about save partition too small garbled. ;;; .. Asks you twice for confirmation about the MAX-GEN of the GC. ;;; 10/19/88 RJF/BC - Changed GC-process and GC-external ;;; 12/7/88 ab GC 5-4 - In gc-reclaim-oldspace, don't automatically lock up NR-SYM regions as static ;;; or TREE-SHAKER will no longer work. ;;; 02/27/89 JLM - Changed gc-immediately and full-gc to extend the reboot time on an MP. ;;; Changed to disallow gc-and-disk-save when multiple processors booted. ;;; 03/08/89 JLM - Began removing references in reconcile-areas which already use working-storage ;;; 04/25/89 RJF/HRC - Changed GC-Report to exit when gc-report is nil without calling ;;; process-allow-schedule so can do silent gc in disk-save. ;;; 04/25/89 RJF/HRC - EAS changes: Added ACTIVE-OVERSIZED-P and SHIFT-GEN-THREE function. ;;; Changed get-generation-sizes, GC-process, gc-reclaim-oldspace, GC, ;;; GC-External, GC-status-auto-gc, GC-reset-history-counters, GC-ON ;;; GC-status-history, Consolidate-Area-Current-Content, and gc-flip-now ;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GC Status ;;; ;;AB 8/12/87. Call it "adaptive" training. (DEFVAR gc-status-var-list '(*gc-report-stream* *gc-notifications* *gc-max-incremental-generation* *gc-console-delay-interval* *adaptive-training-enabled*)) (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 %tgc-train-space-exists gc-initial-copyspace-size gc-initial-copyspace-array gc-work-done gc-garbage-collected gc-collection-counters gc-generational-flip-counters *areas-not-static-after-training*)) (DEFVAR SET-MP-REBOOT-TIME :unbound "Function to be used to set MP reboot time.") ;jlm 2/28/89 (DEFVAR GC-INHIBIT-USAGE-INCREMENT NIL "If this variable is true usage counters will not be incremented.") (DEFUN find-max-print-name-length (lst) (LOOP WITH max-len = 0 WITH len = nil FOR var IN lst DO (WHEN (> (SETQ len (LENGTH (THE string (SYMBOL-NAME var)))) max-len) (SETQ max-len len)) FINALLY (RETURN max-len))) ;;AB 8/13/87. Get rid of ~Ts. ;;DNG 1/19/88. Bind *PRINT-ARRAY* to T instead of using obsolete function LISTARRAY. (DEFUN gc-status-variables (&key (STREAM *standard-output*) (verbose nil)) (LET ((*print-length* 3) 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 "~%~vs~s" (+ len 7) var (SYMBOL-VALUE var))) (WHEN verbose (LET ((*print-array* t) (*print-length* 4)) (LOOP FOR var IN gc-status-var-list-verbose DO (FORMAT stream "~%~vs~s" (+ len 7) var (SYMBOL-VALUE var)) ))))) (DEFVAR gc-size-in-kb t) (DEFUN gc-size-marker () (IF gc-size-in-kb "kbytes" "kwords")) (DEFUN gc-size-raw (size-in-words) (IF gc-size-in-kb (FLOOR (* size-in-words 4.) 1k-byte) (FLOOR size-in-words 1k-byte))) (DEFUN gc-max-field-width () (IF gc-size-in-kb 7. 7.)) (DEFUN gc-size (size-in-words) (IF (= SIZE-IN-WORDS 0) (FORMAT NIL " ") (IF gc-size-in-kb (FORMAT nil " ~7,,:d " (FLOOR (* size-in-words 4.) 1k-byte)) (FORMAT nil " ~7,,:d " (FLOOR size-in-words 1k-byte))))) (DEFUN gc-marked-size (size-in-words) (IF gc-size-in-kb (FORMAT nil "~7,,:d kbytes" (FLOOR (* size-in-words 4) 1k-byte)) (FORMAT nil "~7,,:d kwords" (FLOOR size-in-words 1k-byte)))) (DEFF gc-marked-size-rj 'gc-marked-size) (DEFUN gc-marked-size-smallest (size-in-words) (IF gc-size-in-kb (FORMAT nil "~:d kbytes" (FLOOR (* size-in-words 4) 1k-byte)) (FORMAT nil "~:d kwords" (FLOOR size-in-words 1k-byte)))) ;;AB 8/13/87. Get rid of ~T's. (DEFUN gc-status-general-info (&key (STREAM *Standard-Output*) &allow-other-keys) (LET* ((dump-size (estimate-dump-size)) addr-space-limit limited-by unassigned-addr-space usable-swap-space swap-space-free) (SETQ dump-size (* dump-size disk-block-word-size)) (MULTIPLE-VALUE-SETQ (usable-swap-space swap-space-free) (swap-space-info)) (SETQ usable-swap-space (* usable-swap-space page-size) swap-space-free (* swap-space-free 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: ~a available, ~a free ~73t(~D%)~ ~%Address Space Usage: ~a maximum, ~a free ~73t(~D%)~ ~%Maximum Virtual Memory: ~a (limited by ~a)~ ~%Estimated Dump Size: ~a ~a" (gc-marked-size usable-swap-space) (gc-marked-size swap-space-free) (FLOOR (* (/ swap-space-free usable-swap-space) 100.)) (gc-marked-size *max-address-space-size*) (gc-marked-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)))))) ;;AB 8/13/87. Call it "adaptive" training. (DEFUN gc-status-auto-gc (&key (STREAM *standard-output*) (verbose nil) &aux tem) (DECLARE (IGNORE verbose)) (FORMAT stream "~%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)) (IF (SETQ tem (gc-arrest-reasons)) (FORMAT stream ",~%but has been arrested for reason~p: ~a." (LENGTH tem) tem) (FORMAT stream ".")) (FORMAT stream "~%The highest generation that will be collected automatically is ~d." *gc-max-incremental-generation*)) (t (FORMAT stream "~%Automatic GC is OFF."))) (FORMAT stream "~%Adaptive Training is ~a" (IF *adaptive-training-enabled* "ENABLED" "DISABLED")) (IF (training-active) (LET () (IF *adaptive-training-enabled* (FORMAT stream " and ACTIVE.") (FORMAT stream " but is currently still ACTIVE."))) (IF *adaptive-training-enabled* (FORMAT stream " but is currently INACTIVE (until the next garbage collection begins).") (FORMAT stream " and INACTIVE."))) (WHEN EXTENDED-ADDRESS-SPACE (LET ((NUMBER-OF-WORLDS (IF (LISTP EXTENDED-ADDRESS-SPACE) (LENGTH EXTENDED-ADDRESS-SPACE) 0))) (FORMAT stream "~%Extended Address Space is active with ~d. external worlds." NUMBER-OF-WORLDS) (FORMAT stream "~%There have been ~d. shifts of the active generation 3 domains." *gc-active-shift-count*) (FORMAT stream "~%The current faultin safety pad is ~@11a" (gc-size (IF (> (READ-METER '%GC-SAFETY-PAD) 32000000.) 0. (READ-METER '%GC-SAFETY-PAD))))))) (DEFCONSTANT static 4) (DEFCONSTANT oldsp 5) (DEFCONSTANT copysp 6) (DEFCONSTANT TRAIN-A 7) (DEFVAR gc-used-array (MAKE-ARRAY 8 :initial-element 0)) (DEFVAR gc-length-array (MAKE-ARRAY 8 :initial-element 0)) (DEFVAR gc-used-active-array (MAKE-ARRAY '(8 4) :initial-element 0)) (DEFUN get-generation-sizes (&optional (used gc-used-array) (length gc-length-array) (used-active gc-used-active-array)) (LET (bits gen usage (pdl 0)) (ARRAY-INITIALIZE used 0) (ARRAY-INITIALIZE length 0) (ARRAY-INITIALIZE used-active 0) (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) usage (region-usage region bits) 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 static)) (IF (OR (region-oldspace-p region bits) (region-oldspace-a-p region bits)) (SETF gen oldsp)) (IF (region-copyspace-p region bits) (SETF gen copysp)) (IF (OR (region-train-a-p region bits) (region-entry-p region bits)) (SETF gen train-a)) (WHEN (region-volatility-locked-p REGION BITS) (SETF USAGE 3.) ;; REPORT VOLATILITY LOCKED REGIONS IN THE USAGE 3 BUCKET. (WHEN (= GEN 3.) (INCF PDL (AREF #'region-length region)))) (INCF (AREF used-active gen usage) (AREF #'region-length region)) ; TGCT (INCF (AREF used gen) (AREF #'region-free-pointer region)) (INCF (AREF length gen) (AREF #'region-length region)))) (VALUES used length used-active pdl))) (DEFUN ACTIVE-OVERSIZED-P (ACTIVE-BUCKET) (IF (AND EXTENDED-ADDRESS-SPACE (> ACTIVE-BUCKET *GC-MAX-BUCKET-SIZE*)) ;; SHIFTABLE STUFF MAY BE OVERSIZED. GO TALLY IT UP. (LET ((BUCKET 0.)) (DOLIST (area area-list) (DO ((REGION (AREF #'area-region-list (SYMBOL-VALUE area)) (AREF #'region-list-thread region)) (BITS)) ((MINUSP region)) (SETQ bits (AREF #'region-bits region)) (WHEN (AND (= (LDB %%REGION-SPACE-TYPE BITS) %REGION-SPACE-NEW) (= (LDB %%REGION-GENERATION BITS) (LDB %%REGION-VOLATILITY BITS) 3.) (= (LDB %%REGION-ZERO-VOLATILITY-LOCK BITS) 0.) (= (LDB %%REGION-USAGE BITS) 0.)) (INCF BUCKET (REGION-LENGTH REGION))))) ;; NOW TEST TO SEE IF THE REAL SHIFTABLE STUFF IS OVER SIZED. (IF (> BUCKET *GC-MAX-BUCKET-SIZE*) (RETURN-FROM ACTIVE-OVERSIZED-P T) (RETURN-FROM ACTIVE-OVERSIZED-P NIL))) ;; ELSE OF IF (RETURN-FROM ACTIVE-OVERSIZED-P NIL))) ;;AB 8/13/87. Get rid of ~Ts. Label Activity levels better. ;;rjf 11/17/87. Used saved oldspace sizes if gc is active. ;;hrc 01/25/88. Massive EAS changes (DEFUN gc-status-history (&key (stream *STANDARD-OUTPUT*) &allow-other-keys) (LET ((tot-gc 0) (tot-wd 0) (tot-cs 0) (tot-vas 0) (tot-active (MAKE-ARRAY 4 :INITIAL-ELEMENT 0.)) gc-size (tot-gc-size 0) used length used-active) (MULTIPLE-VALUE-SETQ (used length used-active) (get-generation-sizes)) (WHEN gc-oldspace-exists ;; 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)))) (DOTIMES (USAGE 4) (INCF (AREF USED-ACTIVE GEN USAGE) (AREF GC-INITIAL-COPYSPACE-ARRAY USAGE)) (DECF (AREF USED-ACTIVE COPYSP USAGE) (AREF GC-INITIAL-COPYSPACE-ARRAY USAGE))) (INCF (AREF used gen) gc-initial-copyspace-size) (INCF (AREF length gen) gc-initial-copyspace-size) (DECF (AREF used copysp) gc-initial-copyspace-size) (DECF (AREF length copysp) gc-initial-copyspace-size)) ;; Used original oldspace size if in the middle of a gc, because some oldspace may ;; have been changed to copyspace directly (setf (AREF used oldsp) (aref gc-initial-oldspace-sizes 0)) (setf (AREF length oldsp) (aref gc-initial-oldspace-sizes 1)) (setf (AREF used-active oldsp 0) (aref gc-initial-oldspace-sizes 2)) (setf (AREF used-active oldsp 1) (aref gc-initial-oldspace-sizes 3)) (setf (AREF used-active oldsp 2) (aref gc-initial-oldspace-sizes 4)) (setf (AREF used-active oldsp 3) (aref gc-initial-oldspace-sizes 5)) ) (DOTIMES (USAGE 4) (DOTIMES (GEN 8) (INCF (AREF tot-active usage) (AREF USED-ACTIVE GEN USAGE)))) (FORMAT stream "~% GARBAGE COLLECTION STATISTICS (sizes in ~a)" (gc-size-marker)) (FORMAT stream "~%----------------------------------------------------------------------------------------~ -------------------------------") (FORMAT stream "~% Total Total Current Current ~ Current Size by Activity") (FORMAT stream "~% Garbage Data Percent Size Size Flip") (FORMAT stream "~% Space Type # GCs Collected Surviving Garbage Used Allocated Threshold ~ Active Inact-1 Inact-2 Inact-3") (FORMAT stream "~%-----------------------------------------------------------------------------------------~ ------------------------------") ;; 0 1 2 3 4 5 6 7 8 9 0 (DO ((gen 0 (1+ gen))) ((= gen static)) (SETF tot-gc (+ tot-gc (AREF gc-garbage-collected gen)) tot-wd (+ tot-wd (AREF gc-work-done gen)) tot-cs (+ tot-cs (AREF used gen)) tot-vas (+ tot-vas (AREF length gen)) gc-size (+ (AREF gc-work-done gen) (AREF gc-garbage-collected gen)) tot-gc-size (+ tot-gc-size gc-size)) (FORMAT stream "~% ~9a ~4d~@13a~@12a~5d %~@10a~@10a~@10a~@10a~@10a~@10a~@10a" (FORMAT nil "Gen ~d" gen) (AREF gc-collection-counters gen) (gc-size (AREF gc-garbage-collected gen)) (gc-size (AREF gc-work-done gen)) (IF (ZEROP gc-size) 0 (FLOOR (* (/ (AREF gc-garbage-collected gen) gc-size) 100.))) (gc-size (AREF used gen)) (gc-size (AREF length gen)) (gc-size (AREF flip-size gen)) (gc-size (AREF used-active gen 0)) (gc-size (AREF used-active gen 1)) (gc-size (AREF used-active gen 2)) (gc-size (AREF used-active gen 3)))) (WHEN EXTENDED-ADDRESS-SPACE (FORMAT STREAM "~% ~17a ~27a~@11a~@10a~@20a~@30a" "External-Fault-In" "" (gc-size (AREF used train-a)) (gc-size (AREF length train-a)) (gc-size (AREF used-active train-a 0)) (gc-size (AREF used-active train-a 3)))) (FORMAT STREAM "~% ~9a ~35a~@11a~@10a~@20a~@10a~@10a~@10a" "Static" "" (gc-size (AREF used static)) (gc-size (AREF length static)) (gc-size (AREF used-active static 0)) (gc-size (AREF used-active static 1)) (gc-size (AREF used-active static 2)) (gc-size (AREF used-active static 3))) (FORMAT STREAM "~% ~9a ~35a~@11a~@10a~@20a~@10a~@10a~@10a" "Oldspace" "" (gc-size (AREF used oldsp)) (gc-size (AREF length oldsp)) (gc-size (AREF used-active oldsp 0)) (gc-size (AREF used-active oldsp 1)) (gc-size (AREF used-active oldsp 2)) (gc-size (AREF used-active oldsp 3))) (FORMAT STREAM "~% ~9a ~35a~@11a~@10a~@20a~@10a~@10a~@10a" "Copyspace" "" (gc-size (AREF used copysp)) (gc-size (AREF length copysp)) (gc-size (AREF used-active copysp 0)) (gc-size (AREF used-active copysp 1)) (gc-size (AREF used-active copysp 2)) (gc-size (AREF used-active copysp 3))) (FORMAT STREAM "~2% TOTALS: ~@13a~@12a~5d %~@10a~@10a~@20a~@10a~@10a~@10a" (gc-size tot-gc) (gc-size tot-wd) (IF (ZEROP tot-gc-size) 0 (FLOOR (* (/ tot-gc tot-gc-size) 100.))) (gc-size (+ tot-cs (AREF used static) (AREF used oldsp) (AREF used copysp) (AREF used train-a))) (gc-size (+ tot-vas (AREF length static) (AREF length oldsp) (AREF length copysp) (AREF length train-a))) (gc-size (AREF tot-active 0)) (gc-size (AREF tot-active 1)) (gc-size (AREF tot-active 2)) (gc-size (AREF tot-active 3))) (WHEN EXTENDED-ADDRESS-SPACE (LET ((EXTERNAL-USED (- (AREF USED-ACTIVE TRAIN-A 0) (AREF used train-a))) (EXTERNAL-LENGTH (- (AREF USED-ACTIVE TRAIN-A 0) (AREF length train-a)))) (WHEN (LISTP EXTENDED-ADDRESS-SPACE) (DO* ((WORLD-LIST EXTENDED-ADDRESS-SPACE (CDR WORLD-LIST)) (WORLD (CAR WORLD-LIST) (CAR WORLD-LIST))) ((NOT WORLD)) (DO* ((REGION-LIST (AREF WORLD %EXTERNAL-REGIONS) (CDR REGION-LIST)) (REGION-DESCRIPTOR (CAR REGION-LIST) (CAR REGION-LIST))) ((NOT REGION-DESCRIPTOR)) (INCF EXTERNAL-USED (NTH %EXTERNAL-REGION-FREE-POINTER REGION-DESCRIPTOR)) (INCF EXTERNAL-LENGTH (* %address-space-quantum-size (CEILING (NTH %EXTERNAL-REGION-FREE-POINTER REGION-DESCRIPTOR) %address-space-quantum-size)))))) (FORMAT STREAM "~2% EXTERNAL ~49T~@10A~@10A~@50A" (GC-SIZE EXTERNAL-USED) (GC-SIZE EXTERNAL-LENGTH) (GC-SIZE EXTERNAL-LENGTH)) (INCF TOT-CS EXTERNAL-USED) (INCF TOT-VAS EXTERNAL-LENGTH) (INCF (AREF tot-active 3) EXTERNAL-LENGTH) (FORMAT STREAM "~2% GRAND TOTALS: ~@13a~@12a~5d %~@10a~@10a~@20a~@10a~@10a~@10a" (gc-size tot-gc) (gc-size tot-wd) (IF (ZEROP tot-gc-size) 0 (FLOOR (* (/ tot-gc tot-gc-size) 100.))) (gc-size (+ tot-cs (AREF used static) (AREF used oldsp) (AREF used copysp) (AREF used train-a))) (gc-size (+ tot-vas (AREF length static) (AREF length oldsp) (AREF length copysp) (AREF length train-a))) (gc-size (AREF tot-active 0)) (gc-size (AREF tot-active 1)) (gc-size (AREF tot-active 2)) (gc-size (AREF tot-active 3))))))) ;;AB 8/13/87. Get rid of ~Ts. (DEFUN gc-status-batch-gc (&key (STREAM *standard-output*) (verbose nil)) (LET ((space-size-struct (get-space-size-info *tem-space-size-info*)) space-needed space-free distance) (FORMAT stream "~2%BATCH GC STATUS~ ~%---------------") (COND ((AND (gc-in-progress-p) gc-batch-mode) (FORMAT stream "~%A ~a is now in progress." (COND ((EQ gc-batch-mode :full) "FULL-GC") ((EQ gc-batch-mode :immediate) "GC-IMMEDIATELY") (t "GC-IMMEDIATELY"))) (FORMAT stream "~%Currently collecting generation ~a ~[without~;with~] promotion." (FLOOR gc-type-of-flip 2) (REM gc-type-of-flip 2))) ;; Batch GC not in progress (t ;; FULL-GC :promote t (MULTIPLE-VALUE-SETQ (space-needed space-free) (get-space-needed-for-gc :max-gen 3 :promote t :space-size-struct space-size-struct)) (SETQ distance (- space-free space-needed)) (FORMAT stream "~%(FULL-GC :max-gen 3 :promote t) ~a. ~a." (IF (PLUSP distance) (FORMAT nil "OK for another ~a" (gc-marked-size-rj distance)) (FORMAT nil "~a too late" (gc-marked-size-smallest (- distance)))) (FORMAT nil "~a needed" (gc-marked-size-rj space-needed))) ;; FULL-GC :promote nil (MULTIPLE-VALUE-SETQ (space-needed space-free) (get-space-needed-for-gc :max-gen 3 :promote nil :space-size-struct space-size-struct)) (SETQ distance (- space-free space-needed)) (FORMAT stream "~%(GC-IMMEDIATELY :max-gen 3 :promote nil) ~a. ~a." (IF (PLUSP distance) (FORMAT nil "OK for another ~a" (gc-marked-size-rj distance)) (FORMAT nil "~a too late" (gc-marked-size-smallest (- distance)))) (FORMAT nil "~a needed" (gc-marked-size-rj space-needed))) ;; GC-IMMEDIATELY :max-gen 2 :promote nil (MULTIPLE-VALUE-SETQ (space-needed space-free) (get-space-needed-for-gc :max-gen 2 :promote nil :space-size-struct space-size-struct)) (SETQ distance (- space-free space-needed)) (FORMAT stream "~%(GC-IMMEDIATELY :max-gen 2 :promote nil) ~a. ~a." (IF (PLUSP distance) (FORMAT nil "OK for another ~a" (gc-marked-size-rj distance)) (FORMAT nil "~a too late" (gc-marked-size-smallest (- distance)))) (FORMAT nil "~a needed" (gc-marked-size-rj space-needed))) (WHEN verbose ;; Training session. All gen 3 static regions will become dynamic. (MULTIPLE-VALUE-SETQ (space-needed space-free) (get-space-needed-for-gc :max-gen 3 :promote nil :static-regions-are-dynamic t :space-size-struct space-size-struct)) (SETQ distance (- space-free space-needed)) (FORMAT stream "~%(SYS:START-TRAINING-SESSION T) ~a. ~a." (IF (PLUSP distance) (FORMAT nil "OK for another ~a" (gc-marked-size-rj distance)) (FORMAT nil "~a too late" (gc-marked-size-smallest (- distance)))) (FORMAT nil "~a needed" (gc-marked-size-rj space-needed)))) (FORMAT stream "~%Estimated free space:~@34a." (gc-marked-size-smallest space-free)) (FORMAT stream "~%All status estimates conservatively assume 100% live data.") ))) ) (DEFUN gc-status-internal (&key (verbose nil) (stream *Standard-Output*) &aux strm) "Print information about the status of garbage collection." (IF (NULL stream) (SETQ strm *Standard-Output*) (SETQ strm stream)) (gc-status-history :stream strm :verbose verbose) (gc-status-auto-gc :stream strm :verbose verbose) (gc-status-batch-gc :stream strm :verbose verbose) (gc-status-general-info :stream strm :verbose verbose) (gc-status-variables :stream strm :verbose verbose) (VALUES)) (DEFUN gc-status (&rest args) "Print information about the status of garbage collection." (DECLARE (ARGLIST &key (verbose nil) (stream *Standard-Output*))) (IF (KEYWORDP (FIRST args)) (gc-status-internal :verbose (SECOND (MEMBER :verbose args :test #'EQ)) :stream (SECOND (MEMBER :stream args :test #'EQ))) ;; Support TV:KBD-GC-STATUS (TERM-G) old calling ;; sequence of (GC-STATUS stream) (gc-status-internal :stream (FIRST args))) ) (DEFUN SHIFT-GEN-THREE () (INCF *GC-ACTIVE-SHIFT-COUNT*) (DOLIST (area area-list) (DO ((REGION (AREF #'area-region-list (SYMBOL-VALUE area)) (AREF #'region-list-thread region)) BITS) ((MINUSP region)) (SETQ bits (AREF #'region-bits region)) (WHEN (AND (= (LDB %%REGION-SPACE-TYPE BITS) %REGION-SPACE-NEW) (= (LDB %%REGION-GENERATION BITS) (LDB %%REGION-VOLATILITY BITS) 3.) (= (LDB %%REGION-ZERO-VOLATILITY-LOCK BITS) 0.) (< (LDB %%REGION-USAGE BITS) 3.)) (SETF (AREF #'REGION-BITS REGION) (%LOGDPB (1+ (LDB %%REGION-USAGE BITS)) %%REGION-USAGE BITS)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; GC Report routines. ;;; (DEFUN gc-reset-history-counters () "This function will reset the GC history counters." (SETF *GC-ACTIVE-SHIFT-COUNT* 0.) (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 ;; 1/15/88 DNG - Fixed to not change the value of GC-REPORT-STREAM. ;; 4/25/89 HRC - Changed exit when gc-report is nil to NOT call ;; process-allow-schedule so can do silent gc in disk-save. (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)) (return-from gc-report 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 (let ((stream (if (EQ gc-report-stream t) *Standard-Output* gc-report-stream))) (FUNCALL stream :fresh-line) (APPLY #'FORMAT 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)) ) ;;; rjf 9/30/87 Fixed divide by zero problem. ;;; rjf 11/17/87 Use new gc-initial-oldspace-sizes array. (DEFUN process-gc-done-stats () (LET ((generation (FLOOR gc-type-of-flip 2)) (copy 0) (marker (gc-size-marker)) (initial-used-oldspace-size (aref GC-INITIAL-OLDSPACE-SIZES 0)) bits garbage) ;; Tally up the size of 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-copyspace-p reg bits) (INCF copy (AREF #'region-free-pointer reg)))))) ;; Update the history statistics (SETQ garbage (+ gc-initial-copyspace-size (- initial-used-oldspace-size copy))) (INCF (AREF gc-collection-counters generation)) (INCF (AREF gc-garbage-collected generation) garbage) (INCF (AREF gc-work-done generation) (- copy gc-initial-copyspace-size)) (GC-REPORT "GC of generation ~D complete. Oldspace ~:D ~a, Copyspace ~:D ~a, (~d% garbage)." generation (gc-size-raw initial-used-oldspace-size) marker (gc-size-raw (- copy gc-initial-copyspace-size)) marker (if (> initial-used-oldspace-size 0) (FLOOR (* (/ garbage initial-used-oldspace-size) 100.)) 0) ))) (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 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, 2, AND 3. ;;; ;;; THE GENERAL APPROACH TO CALCULATING THE FLIP SIZE THRESHOLDS FOR GENERATIONS 1, 2, AND 3 ;;; IS TO PICK THE FLIP THRESHOLD AS LARGE AS POSSIBLE CONSISTENT WITH SAFE ABILITY TO PERFORM ;;; AN INCREMENTAL COLLECTION SEQUENCE ASSUMING 100% NON-GARBAGE AND FULLY CONS DRIVEN SCAVENGING. ;;; NOTE: THESE ASSUMPTIONS ARE OFTEN CONSERVATIVE BECAUSE SOME OF OLDSPACE IS GARBAGE AND ;;; THE SCAVENGING MAY BE DRIVEN BY IDLE SCAVENGING. HOWEVER, NEITHER OF THESE ITEMS CAN BE SAFELY ;;; ASSUMED. ;;; ;;; THE GOAL SEQUENCE IS DEPENDENT ON THE VALUE OF *GC-MAX-INCREMENTAL-GENERATION*. FOR ;;; *GC-MAX-INCREMENTAL-GENERATION* = 1 THE ONLY GOAL IS TO BE ABLE TO INCREMENTALLY ;;; COLLECT GENERATION 1. AT THE OTHER EXTREME, WHEN *GC-MAX-INCREMENTAL-GENERATION* IS 3 ;;; THE GENERATION 1 FLIP THRESHOLD IS SELECTED TO BE ABLE TO COLLECT GENERATION 1 FOLLOWED ;;; BY A COLLECTION OF GENERATION 2, AND FINALLY FOLLOWED BE A COLLECTION OF GENERATION 3. ;;; ;;; NOTE: WHEN EXTENDED-ADDRESS-SPACE IS NOT NIL, *GC-MAX-INCREMENTAL-GENERATION* WILL BE FORCED ;;; TO 3. WHEN EXTENDED-ADDRESS-SPACE IS NIL, *GC-MAX-INCREMENTAL-GENERATION* WILL BE NO LARGER THAN 2. ;;; ;;; 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 ;;; ;;; WHEN WE 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 ;;; ;;; WHERE CS = COPY SPACE SIZE ;;; SS = THE SIZE OF OTHER REGIONS WHICH MUST BE SCAVENGED. ;;; ;;; SCAVENGER WORK IS RELATED TO CONSING REQUIRED TO DRIVE THE SCAVENGER BY: ;;; ;;; SW = 16*C, ;;; ;;; WHERE, ;;; ;;; SW = SCAVENGER WORK ;;; ;;; C = CONSING REQUIRED TO DRIVE THE SCAVENGER. ;;; ;;; 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. ;;; ;;; R = D + C + B = D + SW/16 + B = D + (9*D + SS)/16 + B = D*25/16 + SS/16 + B = (D*25 + SS)/16 + B ;;; ;;; WHERE, ;;; ;;; R = THE RESERVE NEEDED TO FLIP AND INCREMENTALLY COLLECT A DYNAMIC VOLUME D. ;;; B = THE AMOUNT OF NEW CONSING WE ALLOW BEFORE THE SCAVENGER IS ALLOWED TO ACT. ;;; ;;; WHEN *GC-MAX-INCREMENTAL-GENERATION* = 1 THE RESERVE NEEDED TO FLIP AND COLLECT GENERATION 1 IS: ;;; ;;; R11 = (D1*25 + D0)/16 + B ;;; ;;; THEN SETTING THE FLIP THRESHOLD, T11, TO D1 AND ASSUMING THAT THE SIZE OF INDIRECTION CELLS AND PDLS IS SMALL WE HAVE: ;;; ;;; T11 = ((R11 - B)*16 - D0)/25 ;;; ;;; WHEN *GC-MAX-INCREMENTAL-GENERATION* = 2 THE RESERVE NEEDED TO SEQUENTIALLY COLLECT GENERATION 1 AND 2 IS: ;;; ;;; R12 = R11 + ((D1 + D2)*25 + D0 + R11 - D1)/16 + B - D1 ;;; = (D2*25 + D1*(34 + 9/16) + D0*(2 + 1/16))/16 + B*(2 + 1/16) ;;; ;;; ROUNDING TO THE NEAREST INTEGER COEFFICIENT. ;;; ;;; R12 = (D2*25 + D1*35 + D0*2)/16 + B*2 ;;; ;;; THEN ;;; ;;; T12 = ((R12 - B*2)*16 - D2*25 - D0*2)/35 ;;; ;;; AFTER THE COMPLETION OF THE GENERATION 1 COLLECTION THE RESERVE NEEDED FOR THE GENERATION 2 COLLECTION IS: ;;; ;;; R22 = (D2*25 + D0 + D1)/16 + B ;;; ;;; T22 = ((R22 - B)*16 -D0 -D1)/25 ;;; ;;; WHEN *GC-MAX-INCREMENTAL-GENERATION* = 3, THE RESERVE NEEDED TO SEQUENTIALLY COLLECT GENERATION 1, 2, AND 3 IS: ;;; ;;; R13 = R12 + ((D1 + D2 + D3)*25 + D0 + R11 - D1 + R12 - D1 - D2)/16 + B - D1 - D2 ;;; = (D2*25 + D1*35 + D0*2)/16 + B*2 + ;;; ((D1 + D2 + D3)*25 + D0 + (D1*25 + D0)/16 + B - D1 + (D2*25 + D1*35 +D0*2)/16 + B*2 - D1 - D2)/16 + ;;; B - D1 - D2 ;;; ;;; ROUNDING TO THE NEAREST INTEGER COEFFICIENT. ;;; ;;; R13 = (D3*25 + D2*35 + D1*46 + D0*3 + 51*B)/16 ;;; ;;; T13 = (R13*16 - D3*25 - D2*35 - D0*3 -51*B)/46 ;;; ;;; AFTER THE COMPLETION OF THE GENERATION 1 COLLECTION THE RESERVE NEEDED FOR THE GENERATION 2, 3 SEQUENCE IS: ;;; ;;; R23 = (D2*25 + D0 + D1)/16 + B + ((D2 + D3)*25 + D0 + D1 + (D2*9 + D0 + D1)/16 + B)/16 + B - D2 ;;; ;;; ROUNDING TO THE NEAREST INTEGER COEFFICIENT. ;;; ;;; R23 = (D3*25 + D2*35 + D1*2 + D0*2 + B*32)/16 ;;; ;;; T23 = (R23*16 - D3*25 -D1*2 - D0*2 - B*32)/35 ;;; ;;; AFTER THE COMPLETION OF THE GENERATION 2 COLLECTION THE RESERVE NEEDED FOR THE GENERATION 3 COLLECTION IS: ;;; ;;; R33 = (D3*25 + D2 + D1 + D0)/16 + B ;;; ;;; T33 = (R33*16 - B*16 - D2 - D1 - D0)/25 ;;; (DEFUN gc-process () (LET (THRESHOLD USED-VIRTUAL-ADDRESS-SPACE RESERVE (VA-RESERVE 0.) (PREVIOUS-GENERATION-HIGH T) (C 200000.) (B (ROUND (* GC-FRACTION-OF-RAM-FOR-GENERATION-ZERO (SYSTEM:SYSTEM-COMMUNICATION-AREA SYSTEM:%SYS-COM-MEMORY-SIZE))))) (SETF *GC-MAX-BUCKET-SIZE* (MIN 2500000. (* B 8.))) (SETF (AREF FLIP-SIZE 0) B (AREF FLIP-SIZE 1) 0 (AREF FLIP-SIZE 2) 0 (AREF FLIP-SIZE 3) 0) (DO () (NIL) ;Do forever (OR %GC-FLIP-READY (PROCESS-WAIT "Await scavenge" 'SYMBOL-VALUE '%GC-FLIP-READY)) (GC-RECLAIM-OLDSPACE) (SETF B (ROUND (* GC-FRACTION-OF-RAM-FOR-GENERATION-ZERO (SYSTEM:SYSTEM-COMMUNICATION-AREA SYSTEM:%SYS-COM-MEMORY-SIZE)))) (SETF (AREF FLIP-SIZE 0) B) (IF EXTENDED-ADDRESS-SPACE (SETF *GC-MAX-INCREMENTAL-GENERATION* 3) (IF (> *GC-MAX-INCREMENTAL-GENERATION* 2) (SETF *GC-MAX-INCREMENTAL-GENERATION* 2))) (MULTIPLE-VALUE-BIND (W D used-active PDL) (GET-GENERATION-SIZES) (SETF USED-VIRTUAL-ADDRESS-SPACE 0) (DOTIMES (I 8.) (INCF USED-VIRTUAL-ADDRESS-SPACE (AREF D I))) (MULTIPLE-VALUE-BIND (USABLE-SWAP-SPACE SWAP-SPACE-FREE) (SWAP-SPACE-INFO) (SETF SWAP-SPACE-FREE (* (- SWAP-SPACE-FREE (COUNT-PAGES-NEEDING-WRITABLE-PAGING-STORE (NOT EXTENDED-ADDRESS-SPACE))) PAGE-SIZE)) ; Also check phys mem. (SETF RESERVE (FLOOR (* 95. (MIN (SETF VA-RESERVE (- *max-virtual-address* USED-VIRTUAL-ADDRESS-SPACE 2097152.)) SWAP-SPACE-FREE)) 100.)) (COND ((= *GC-MAX-INCREMENTAL-GENERATION* 0) (SETF THRESHOLD 0)) ((= *GC-MAX-INCREMENTAL-GENERATION* 1) (SETF THRESHOLD (FLOOR (+ (* 16. (AREF D 1)) (- (* 16. RESERVE) (* 16. B) (* 16. C) (* 22. (AREF D 0)))) 35.))) ((= *GC-MAX-INCREMENTAL-GENERATION* 2) (SETF THRESHOLD (FLOOR (+ (* 16. (AREF D 1)) (- (* 16. RESERVE) (* 16. B) (* 32. C) (* 25. (AREF D 0)) (* 19. (AREF D 2)))) 38.))) (T (SETF THRESHOLD (FLOOR (+ (* 16. (AREF D 1)) (- (* 16. RESERVE) (* 16. B) (* 48. C) (* 28. (AREF D 0)) (* 22. (AREF D 2)) (* 19. (AREF USED-ACTIVE 3 3)) (AREF USED-ACTIVE 3 0) (AREF USED-ACTIVE 3 1) (AREF USED-ACTIVE 3 2) (AREF D 4.))) 41.)))) (SETF THRESHOLD (MIN THRESHOLD (* 2. B))) ;; DON'T LET GENERATION 1 GET LARGER THAN 20% OF RAM SIZE. (SETF (AREF FLIP-SIZE 1) THRESHOLD) (COND ((OR PREVIOUS-GENERATION-HIGH (= 0 *GC-MAX-INCREMENTAL-GENERATION*) (AND (< (AREF D 1) THRESHOLD) (NOT (AND (ACTIVE-OVERSIZED-P (AREF USED-ACTIVE 3. 0)) (> (- (+ (AREF USED-ACTIVE 3. 2.) (AREF USED-ACTIVE 3. 3.)) PDL) (FLOOR (* 3. *GC-MAX-BUCKET-SIZE*) 2.)))))) ;; THIS LEG WILL FLIP GENERATION 0. (WRITE-METER '%GC-SAFETY-PAD (FLOOR (* 8. (MAX (- VA-RESERVE (FLOOR (* 17. B) 16.) C (FLOOR (* (AREF D 0) 355.) 256.) (FLOOR (* (AREF D 1) 19.) 16.)) 0.)) 10.)) (SETF PREVIOUS-GENERATION-HIGH NIL) (WHEN (AND (ACTIVE-OVERSIZED-P (AREF USED-ACTIVE 3. 0)) (<= (- (+ (AREF USED-ACTIVE 3. 2.) (AREF USED-ACTIVE 3. 3.)) PDL) (FLOOR (* 3. *GC-MAX-BUCKET-SIZE*) 2.))) (SHIFT-GEN-THREE)) (GC-FLIP-NOW 1 (* 16. B))) (T ;; THIS LEG WILL FLIP GENERATION 1 AND POSSIBLY GENERATIONS 2 AND 3. (SETF PREVIOUS-GENERATION-HIGH T) ;; FLIP GENERATION 1 WITH PROMOTION. (WRITE-METER '%GC-SAFETY-PAD (FLOOR (* 8. (MAX (- VA-RESERVE (FLOOR (* C 33.) 16.) (FLOOR (* (AREF D 1) 355.) 256.) (FLOOR (* (AREF D 2) 19.) 16.) (FLOOR (* (AREF D 0) 17.) 256.)) 0.)) 10.)) (GC-FLIP-NOW 3 (* 16. C)) (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 USED-ACTIVE PDL) (GET-GENERATION-SIZES)) (SETF USED-VIRTUAL-ADDRESS-SPACE 0) (DOTIMES (I 8.) (INCF USED-VIRTUAL-ADDRESS-SPACE (AREF D I))) (MULTIPLE-VALUE-SETQ (USABLE-SWAP-SPACE SWAP-SPACE-FREE) (SWAP-SPACE-INFO)) (SETF SWAP-SPACE-FREE (* (- SWAP-SPACE-FREE (COUNT-PAGES-NEEDING-WRITABLE-PAGING-STORE (NOT EXTENDED-ADDRESS-SPACE))) PAGE-SIZE)) (SETF RESERVE (FLOOR (* 95. (MIN (SETF VA-RESERVE (- *max-virtual-address* USED-VIRTUAL-ADDRESS-SPACE 2097152.)) SWAP-SPACE-FREE)) 100.)) (COND ((= *GC-MAX-INCREMENTAL-GENERATION* 2) (SETF THRESHOLD (FLOOR (+ (* 16. (AREF D 2)) (- (* 16. RESERVE) (* 16. B) (* 32. C) (* 25. (AREF D 0)) (* 22. (AREF D 1)))) 35.)) ;; DON'T LET GENERATION 2 GET LARGER THAN 40% OF RAM SIZE. (SETF THRESHOLD (MIN THRESHOLD (* 4. B))) (SETF (AREF FLIP-SIZE 2.) THRESHOLD) (WHEN (> (AREF D 2) THRESHOLD) ;; FLIP GENERATION 2 WITH PROMOTION. (GC-FLIP-NOW 5. (* 16. C)))) (T (SETF THRESHOLD (FLOOR (+ (* 16. (AREF D 2)) (- (* 16. RESERVE) (* 16. B) (* 48. C) (* 28. (AREF D 0)) (* 25. (AREF D 1)) (* 19. (AREF USED-ACTIVE 3 3)) (AREF USED-ACTIVE 3 0) (AREF USED-ACTIVE 3 1) (AREF USED-ACTIVE 3 2) (AREF D 4.))) 38.)) ;; DON'T LET GENERATION 2 GET LARGER THAN 40% OF RAM SIZE. (SETF THRESHOLD (MIN THRESHOLD (* 4. B))) (SETF (AREF FLIP-SIZE 2.) THRESHOLD) (WHEN (OR (> (AREF D 2) THRESHOLD) (AND (ACTIVE-OVERSIZED-P (AREF USED-ACTIVE 3. 0)) (> (- (+ (AREF USED-ACTIVE 3. 2.) (AREF USED-ACTIVE 3. 3.)) PDL) (FLOOR (* 3. *GC-MAX-BUCKET-SIZE*) 2.)))) ;; FLIP GENERATION 2 WITH PROMOTION. (WRITE-METER '%GC-SAFETY-PAD (FLOOR (* 8. (MAX (- VA-RESERVE (FLOOR (* C 33.) 16.) (FLOOR (* (AREF D 2) 355.) 256.) (FLOOR (* (AREF USED-ACTIVE 3 3) 19.) 16.) (FLOOR (+ (AREF D 4) (AREF USED-ACTIVE 3 0) (AREF USED-ACTIVE 3 1) (AREF USED-ACTIVE 3 2)) 16.) (FLOOR (* (+ (AREF D 0) (AREF D 1)) 17.) 256.)) 0.)) 10.)) (GC-FLIP-NOW 5. (* 16. C)) ;; 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 USED-ACTIVE PDL) (GET-GENERATION-SIZES)) (SETF USED-VIRTUAL-ADDRESS-SPACE 0) (DOTIMES (I 8.) (INCF USED-VIRTUAL-ADDRESS-SPACE (AREF D I))) (MULTIPLE-VALUE-SETQ (USABLE-SWAP-SPACE SWAP-SPACE-FREE) (SWAP-SPACE-INFO)) (SETF SWAP-SPACE-FREE (* (- SWAP-SPACE-FREE (COUNT-PAGES-NEEDING-WRITABLE-PAGING-STORE (NOT EXTENDED-ADDRESS-SPACE))) PAGE-SIZE)) (SETF RESERVE (FLOOR (* 95. (MIN (SETF VA-RESERVE (- *max-virtual-address* USED-VIRTUAL-ADDRESS-SPACE 2097152.)) SWAP-SPACE-FREE)) 100.)) (SETF THRESHOLD (FLOOR (+ (* 16. (AREF USED-ACTIVE 3 3)) (- (* 16 RESERVE) (* 16. B) (* 48. C) (* 28. (AREF D 0)) (* 25. (AREF D 1)) (* 22. (AREF D 2)) (AREF USED-ACTIVE 3 0) (AREF USED-ACTIVE 3 1) (AREF USED-ACTIVE 3 2) (AREF D 4.))) 35.)) (SETF THRESHOLD (MIN THRESHOLD (+ (FLOOR (* 3. *GC-MAX-BUCKET-SIZE*) 2.) PDL))) (SETF (AREF FLIP-SIZE 3.) THRESHOLD) (WHEN (OR (> (AREF USED-ACTIVE 3 3) THRESHOLD) (AND (ACTIVE-OVERSIZED-P (AREF USED-ACTIVE 3. 0)) (> (- (+ (AREF USED-ACTIVE 3. 2.) (AREF USED-ACTIVE 3. 3.)) PDL) (FLOOR (* 3. *GC-MAX-BUCKET-SIZE*) 2.)))) (WRITE-METER '%GC-SAFETY-PAD (FLOOR (* 8. (MAX (- VA-RESERVE C (FLOOR (* (AREF USED-ACTIVE 3 3) 3.) 16.) (FLOOR (+ (AREF D 0) (AREF D 1) (AREF D 2) (AREF D 4) (AREF USED-ACTIVE 3 0) (AREF USED-ACTIVE 3 1) (AREF USED-ACTIVE 3 2)) 16.) (AREF USED-ACTIVE 3 3)) 0.)) 10.)) ;; FLIP GENERATION 3 WITH EXPORT, SET LARGE BIAS. (GC-FLIP-NOW 7. (* 32. B)) ;; FIRE OFF THE IDLE SCAVENGER IMMEDIATELY (SETF %scavenger-ws-enable NIL) ;; SHIFT GENERATION 3 IF THE USAGE 0 BUCKET IS OVERSIZED. (WHEN (ACTIVE-OVERSIZED-P (AREF USED-ACTIVE 3 0)) (SHIFT-GEN-THREE)))))))))))))) ;; Rjf 8/19/87 - fixed so can arrest process that is stopped. (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) (typep gc-process '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 it is 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)))) ;;AB 8/13/87. Don't finish pending collection when turning GC on. (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-REPORT "GC: Starting automatic garbage collection.")) (WHEN (NULL gc-process) (SETQ gc-process (MAKE-PROCESS 'gc-process :PRIORITY 1))) ;; 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) &aux got-lock) "Turn off automatic garbage collection." (DECLARE (ARGLIST)) (WHEN (gc-active-p) (LOOP (SETQ got-lock (PROCESS-WAIT-WITH-TIMEOUT ;time out after 30. seconds "Await GC Lock" 1800. #'(lambda () (NULL gc-flip-lock)))) (IF got-lock (WITHOUT-INTERRUPTS (WHEN (NULL gc-flip-lock) (PROCESS-DISABLE gc-process) ;Disable flipper process (RETURN t))) (FERROR nil "Timed out waiting for GC flip lock (current value ~s)" gc-flip-lock))) (DELETE-INITIALIZATION "GC-PROCESS" '(WARM)) ;Don't start GC on warm boots anymore (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-maybe-set-flip-ready) (GC-RECLAIM-OLDSPACE)))) ;; Disable scavenge during cons (SETQ inhibit-scavenging-flag t)) ;;; rjf 9/15/87 Fixed so it would set %gc-flip-ready correctly, this was causing the ;;; semaphore error. (DEFUN gc-maybe-set-flip-ready () "Sets up %GC-FLIP-READY if no oldspace anywhere." (WITHOUT-INTERRUPTS (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 (region-oldspace-p reg (AREF #'region-bits reg)) (SETQ gc-oldspace-exists t) (setq %gc-flip-ready nil) ;preset flip-ready to nil (%gc-scavenge 10) ;and let the scavenger tell us if it is done (RETURN-FROM gc-maybe-set-flip-ready %gc-flip-ready))) FINALLY (PROGN (WRITE-METER '%Count-Scavenger-Work #o10000000000) (SETQ %Gc-Flip-Ready t gc-oldspace-exists nil)))) ) (DEFVAR gc-was-active nil) (DEFUN gc-off-temporarily (&optional (stream *standard-output*)) (WHEN (gc-active-p) (FORMAT stream "~%Turning GC off temporarily...") (GC-OFF) (SETQ gc-was-active t))) (DEFUN gc-off-temporarily-back-on (&optional (stream *standard-output*)) (WHEN gc-was-active (FORMAT stream "~%Turning GC back on...") (GC-ON) (SETQ gc-was-active nil))) ;;;;;;;;;;;;;;; ;;; ;;; 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))))) ) (DEFUN CONSOLIDATE-AREA-CURRENT-CONTENT (AREA-TO-CONSOLIDATE AREA-TO-CONSOLIDATE-INTO &OPTIONAL (GEN NIL)) ;; LOCK THE AREA STRUCTURE (WHEN EXTENDED-ADDRESS-SPACE (RETURN-FROM CONSOLIDATE-AREA-CURRENT-CONTENT NIL)) (LET ((inhibit-scheduling-flag t) (inhibit-scavenging-flag t)) (DO ((REGION (AREA-REGION-LIST AREA-TO-CONSOLIDATE)) NEXT-REGION (PREV-REGION NIL)) ((MINUSP REGION)) (COND ((AND ;; DON'T RIP OFF THE ONLY REGION. (OR PREV-REGION (PLUSP (REGION-LIST-THREAD REGION))) ;; DON'T RIP OFF A REGION WHICH DOES NOT MATCH THE GENERATION SPEC. IF THERE IS ONE. (OR (NOT GEN) (= GEN (LDB %%REGION-GENERATION (REGION-BITS REGION)))) ;; DON'T RIP OFF A TRAINSPACE-A REGION (/= %REGION-SPACE-TRAIN-A (LDB %%REGION-SPACE-TYPE (REGION-BITS REGION)))) ;; HERE WE WANT TO DISCONNECT THE REGION FROM AREA-TO-CONSOLIDATE ;; AND ATTACH IT TO THE FRONT OF THE LIST FOR THE AREA-TO-CONSOLIDATE-INTO ;; ;; FIRST SAVE THE NEXT REGION TO EXAMINE ;; (SETF NEXT-REGION (REGION-LIST-THREAD REGION)) ;; ;; NEXT DISCONNECT THE REGION FROM IT'S CURRENT LIST ;; (IF PREV-REGION (SETF (AREF #'REGION-LIST-THREAD PREV-REGION) NEXT-REGION) (SETF (AREF #'AREA-REGION-LIST AREA-TO-CONSOLIDATE) NEXT-REGION)) ;; ;; NOW ATTACH THE REGION TO THE FRONT OF IT'S NEW LIST. ;; (SETF (AREF #'REGION-LIST-THREAD REGION) (AREA-REGION-LIST AREA-TO-CONSOLIDATE-INTO)) (SETF (AREF #'AREA-REGION-LIST AREA-TO-CONSOLIDATE-INTO) REGION) ;; ;; UPDATE THE REGION-AREA-MAP FOR THIS REGION ;; (SETF (AREF #'REGION-AREA-MAP REGION) AREA-TO-CONSOLIDATE-INTO) ;; ;; AND FINALLY ADVANCE TO THE NEXT REGION FOR THE NEXT LOOP. ;; (SETF REGION NEXT-REGION)) ;; ;; HERE WE DON'T WANT TO CONSOLIDATE THIS REGION. ;; (T (SETF PREV-REGION REGION) (SETF REGION (REGION-LIST-THREAD REGION))))))) (DEFPARAMETER CONSOLIDATE-AREAS '((PERMANENT-STORAGE-AREA WORKING-STORAGE-AREA) (SYS:FASL-TABLE-AREA WORKING-STORAGE-AREA) (SYS:FASL-TEMP-AREA WORKING-STORAGE-AREA) (SYS:CONTROL-TABLES WORKING-STORAGE-AREA) (SYS:PROPERTY-LIST-AREA WORKING-STORAGE-AREA) (COMPILER:SOURCE-CODE-AREA WORKING-STORAGE-AREA) (SYS:*KERNEL-SYMBOL-AREA* SYS:NR-SYM) (SYS:*COMPILER-SYMBOL-AREA* SYS:NR-SYM) (SYS:*USER-SYMBOL-AREA* SYS:NR-SYM) (EH::ERROR-HANDLER-AREA WORKING-STORAGE-AREA) (FS::LOCAL-FILE-SYSTEM-AREA WORKING-STORAGE-AREA) (TV:SHEET-AREA WORKING-STORAGE-AREA) (TV::WHO-LINE-AREA WORKING-STORAGE-AREA) (TV::BLINKER-AREA WORKING-STORAGE-AREA) (TV::SOUND-AREA WORKING-STORAGE-AREA) (TV::SCROLL-LIST-AREA WORKING-STORAGE-AREA) ; (GLOSS::GLOSSARY-AREA WORKING-STORAGE-AREA) ; jlm 3/08/89 (CHAOS::CHAOS-AREA WORKING-STORAGE-AREA) (NAME::GENERAL-NAMESPACE WORKING-STORAGE-AREA) (NAME::NAMESPACE-OBJECTS WORKING-STORAGE-AREA) (ZWEI::ZWEI-AREA WORKING-STORAGE-AREA) (SYS:PKG-AREA WORKING-STORAGE-AREA) (SYS::FLAVOR-DATA-AREA WORKING-STORAGE-AREA))) (DEFUN CONSOLIDATE-AREAS (&OPTIONAL (GEN NIL) &aux tem) (DOLIST (PAIR CONSOLIDATE-AREAS) (IF (MEMBER (CAR PAIR) AREA-LIST) (CONSOLIDATE-AREA-CURRENT-CONTENT (SYMBOL-VALUE (CAR PAIR)) (SYMBOL-VALUE (CADR PAIR)) GEN))) ;;Special case this one so user can load this patch when IP not in. (WHEN (AND (FIND-PACKAGE "IP") (SETQ tem (FIND-SYMBOL "IP-AREA" 'ip)) ;ab 2/24/88 (BOUNDP tem)) (consolidate-area-current-content (SYMBOL-VALUE tem) (SYMBOL-VALUE 'working-storage-area) gen))) ;;AB 8/5/87. Add call to CONSOLIDATE-AREAS. ;;; This is the only function that actually performs a flip. ;;RJF 8/18/87 Make sure scav-work-bias isn't too big to fit ;;; in space provided. ;;HC/RJF 9/14/87 Added support for oversize regions. (DEFUN gc-flip-now (gc-type &optional (scav-work-bias 0) &aux generation promote bits) (if (> scav-work-bias most-positive-fixnum) (setq scav-work-bias most-positive-fixnum)) (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)) ;; CONSOLIDATE DATA IN AREAS WE WISH WE DID NOT HAVE. (WHEN (FBOUNDP 'consolidate-areas) (FUNCALL #'consolidate-areas GENERATION)) (SETF gc-initial-copyspace-size 0) (ARRAY-INITIALIZE GC-INITIAL-COPYSPACE-ARRAY 0.) ; TGCT (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)) ;; PROVIDE SPECIAL LOGIC TO FACILITATE PACKING 3,1,0 OBJECT FAULTIN REGIONS. (WHEN (AND (> GENERATION 0.) (= (region-generation region bits) 3.) (= (region-volatility region bits) 1.) (= (region-usage region bits) 0.) (NOT (region-volatility-locked-p region bits)) (region-newspace-p region bits) (= (AREF #'region-length region) %ADDRESS-SPACE-QUANTUM-SIZE) (> (- (AREF #'region-length region) (AREF #'region-free-pointer region)) 500.)) ;; CONVERT THIS REGION TO A COPYSPACE REGION SO THAT HE WILL NOT BE CONVERTED TO A 3,3,0 ;; REGION UNTIL HE FILLS UP. (INCF gc-initial-copyspace-size (AREF #'region-free-pointer region)) (INCF (AREF GC-INITIAL-COPYSPACE-ARRAY (REGION-USAGE REGION BITS)) ; TGCT (AREF #'REGION-FREE-POINTER REGION)) (SETF (AREF #'region-bits region) (%LOGDPB %region-space-copy %%region-space-type (%LOGDPB 1 %%region-scavenge-enable bits)))) ;; 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)) (INCF (AREF GC-INITIAL-COPYSPACE-ARRAY (REGION-USAGE REGION BITS)) ; TGCT (AREF #'REGION-FREE-POINTER REGION)) ; TGCT (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) ;; Get the batch-promote-collection-flag setup. Only the incremental collector uses a ;; non-zero scav-work-bias so we can use this to detect calls from the batch collector. (IF (OR (AND (= SCAV-WORK-BIAS 0) ; TGCT (/= GENERATION 3) ; EAS (ODDP GC-TYPE)) ; TGCT GC-INHIBIT-USAGE-INCREMENT) (SET-DISK-SWITCHES :BATCH-PROMOTE-COLLECTION-FLAG 1.) ; TGCT (SET-DISK-SWITCHES :BATCH-PROMOTE-COLLECTION-FLAG 0.)) ; TGCT ;; Maintain the variable %tgc-train-space-exists for disk save. ; TGCT (COND ((AND (/= GENERATION 3) ; TGCT %TGC-TRAINING-ENABLED) ; TGCT (SETF %TGC-TRAIN-SPACE-EXISTS T)) ; TGCT ((= GENERATION 3) ; TGCT (SETF %TGC-TRAIN-SPACE-EXISTS NIL))) ; TGCT ;; Do flip (change newspace to oldspace in all dynamic areas). (SETF GC-TYPE-OF-FLIP GC-TYPE) (IF (AND EXTENDED-ADDRESS-SPACE (> GC-TYPE 5)) (EXTENDED-ADDRESS-SPACE-BEFORE-FLIP-PROCESSING)) (%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) (SNAPSHOT-OLDSPACE-SIZE) (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 oldspace then 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 250000.)) ;; Report oldspace statistics,etc (process-gc-done-stats) (WHEN (AND EXTENDED-ADDRESS-SPACE (> GC-TYPE-OF-FLIP 5.)) (EXTENDED-ADDRESS-SPACE-AFTER-COLLECTION-PROCESSING)) (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 GC-Initial-Copyspace-Size 0)) ;for gc-status (FERROR nil "Semaphore error in GC-Reclaim-Oldspace")) (WHEN (AND EXTENDED-ADDRESS-SPACE (= 5 GC-TYPE-OF-FLIP)) ;; DON'T LET ANY NON-STATIC SYMBOL REGIONS CREEP INTO GENERATION 3. (make-area-regions-static NR-SYM)) ;; 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 (OR (region-oldspace-p region bits) (REGION-OLDSPACE-A-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-type bits))) (AREF #'region-length region-to-free))) (SETF (AREF #'REGION-AREA-MAP new-region) area) ;;Rjf (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 & help fns ;;; (DEFUN verify-gc-safe (max-gen promote &optional (type :immediate) silent space-size-struct &aux gc-type distance) "Determines if a GC of max-gen MAX-GEN with promote PROMOTE is possible. With SILENT argument of NIL, will query the user if the success of the collection is in doubt and give the user an opportunity to perform a safer collection if one is possible. With a SILENT value of true, just tries to calculate and return a safe MAX-GEN/PROMOTE combination without asking. Returns the MAX-GEN and PROMOTE combination that are finally determined to be safe or selected by the user (or NILs if none safe or selected)." (DECLARE (VALUES safe-max-gen safe-promote)) (UNLESS space-size-struct (SETQ space-size-struct (get-space-size-info *tem-space-size-info*))) (SETQ gc-type (COND ((EQ type :immediate) "GC-IMMEDIATELY") ((EQ type :full) "FULL-GC") (t "GC-IMMEDIATELY"))) (MULTIPLE-VALUE-BIND (space-needed space-free) (get-space-needed-for-gc :max-gen max-gen :promote promote :space-size-struct space-size-struct :static-regions-are-dynamic (EQ type :train)) (SETQ distance (- space-free space-needed)) (COND ((PLUSP distance) (VALUES max-gen promote)) ((and silent (= max-gen 0) (not promote)) nil) (silent (verify-gc-safe (IF promote max-gen (1- max-gen)) (IF promote (NOT promote) promote) type silent)) (t (FORMAT t "~%It may be ~a too late to do a ~a,~ ~%unless a lot of your consing has been garbage." (gc-marked-size-smallest (- distance)) (FORMAT nil "(~a :max-gen ~a :promote ~a)" gc-type max-gen promote)) (MULTIPLE-VALUE-BIND (safe-max-gen safe-promote) (if (or promote (> max-gen 0)) (verify-gc-safe (IF promote max-gen (1- max-gen)) nil type t)) (WHEN (NOT safe-max-gen) (FORMAT t "~%And it may also be too late to do any kind of GC.")) (IF (and (or promote (> max-gen 0)) (Y-OR-N-P "~%Try ~a instead? It ~:[is still safe~;has a better chance~]." (FORMAT nil "(~a :max-gen ~a :promote ~a)" gc-type (OR safe-max-gen 0) safe-promote) (NOT safe-max-gen))) (VALUES (OR safe-max-gen 0) safe-promote) (IF (Y-OR-N-P "Try ~a anyway?" (FORMAT nil "(~a :max-gen ~a :promote ~a)" gc-type max-gen promote)) (VALUES max-gen promote) (VALUES nil nil))))))) ) ;; 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) (train-off t) (export nil) (type :immediate) before-disk-save duplicate-pnames (silent nil) after-system-build debug) "Perform a garbage collection. All generations up to and including :MAX-GEN will be collected. If the :PROMOTE keyword is true, survivors from lower generations will be promoted into higher generations. The default is not to promote. Before starting the collection, GC will try to verify if there is enough free virtual memory to do a collection given the :MAX-GEN and :PROMOTE parameters. If so, the collection will proceed. If not, the user will be queried (when the :SILENT keyword is NIL) and given the option of choosing a collection with a safer :MAX-GEN/:PROMOTE combination. If the :SILENT keyword is true, GC will just change the :MAX-GEN/:PROMOTE combination to a safe one and proceed (or in rare cases, just return NIL if no GC seems safe). A true :SILENT keyword value also suppresses all status notifications. The TYPE keyword permits some control over the type of GC performed. It can be :IMMEDIATE or :FULL. If :FULL, the FULL-GC-INITIALIZATION-LIST is run before starting the GC. The BEFORE-DISK-SAVE keyword, when non-nil, means that you intend to do a disk-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. If the :EXPORT keyword is true and :MAX-GEN is 3 and the EXTENDED-ADDRESS-SPACE variable is not nil then the current contents of generation 3, usage 3 will exported to external worlds. The DUPLICATE-PNAMES keyword will collapse duplicate symbol print names if they exist. This is useful in reclaiming space after the loading of large systems." (DECLARE (ARGLIST (&key (max-gen 2) (promote nil) (:type :immediate) (train-off t) (export nil) (silent nil) before-disk-save duplicate-pnames)) (SPECIAL GC-System-Build-Forms-Before GC-System-Build-Forms-After)) (WHEN EXTENDED-ADDRESS-SPACE (WRITE-METER '%GC-SAFETY-PAD 0.)) (WHEN (> max-gen %region-max-generation) (SETQ max-gen %region-max-generation)) (LET (gc-was-on-flag space-sizes) ;; Ensure that collection can be done (or that user knows it may fail). (MULTIPLE-VALUE-SETQ (max-gen promote) (verify-gc-safe max-gen promote type silent)) (UNLESS max-gen (RETURN-FROM gc nil)) ;; Assure our oldspace-exists flags are right. (gc-maybe-set-flip-ready) ;; 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) ;; (FULL-GC :max-gen 3) will turn off training. (WHEN (AND (= max-gen 3) train-off) (TRAINING-OFF :clear-train-space nil :silent t :reset-counters NIL)) ;; 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 promote (>= max-gen 2)) (IF silent (collapse-duplicate-pnames) (with-batch-gc-notifications (collapse-duplicate-pnames)))) (WHEN before-disk-save ;;7/19/88 clm - process a logout before a disk-save (unless silent (with-batch-gc-notifications (gc-report "Processing logout"))) (Logout);Undo user inits and get username off screen. (when (fboundp 'Fs::Lmfs-Close-All-Files) (unless silent (with-batch-gc-notifications (gc-report "Shutting down file system"))) ;;Close any open streams our local file system ;; is serving. Not done by file sys dismount, ;; but may be redundant considering what comes next. (Fs::Lmfs-Close-All-Files) ) (IF (FBOUNDP 'fs:dismount-file-system) (fs:dismount-file-system)) (IF (FBOUNDP 'name:clear-namespaces) (name:clear-namespaces)) (when (fboundp 'fs:clear-pathnames-before-gc) (fs:clear-pathnames-before-gc)) ) ;; Perform the collection... (WITH-LOCK (Gc-Flip-Lock) (with-batch-gc-notifications (unwind-protect (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)) (if (PLUSP (gen-size-allocated gen (get-space-size-info space-sizes))) (progn (gc-flip-now (+ gen gen (IF (OR (AND promote (/= gen 3)) (AND promote EXPORT (= GEN 3) EXTENDED-ADDRESS-SPACE)) 1 0))) (gc-reclaim-oldspace)) (GC-REPORT "GC: Generation ~O currently empty, no garbage collection necessary." gen) ))) ;;RJF ;; Some cleanup... (WHEN before-disk-save (when (fboundp 'fs:clear-pathnames-before-gc) (fs:restore-pathnames-after-gc))) (WHEN (EQ type :full) (INITIALIZATIONS 'After-Full-Gc-Initialization-List t)) ) ; end of unwind-protect (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) (export nil)) "Perform a batch garbage collection. Use this when you intend to continue using the system after the collection. To collect in preparation for a DISK-SAVE, use FULL-GC. All generations up to and including :MAX-GEN will be collected. Since generations 0, 1 and 2 will generally only contain objects created since you last booted, a default (GC-IMMEDIATELY) means roughly \"batch garbage collect my working set\". If the :PROMOTE keyword is true, survivors from each collected generation are promoted into the next higher generation except for generation 3. If the :EXPORT keyword is true and :MAX-GEN is 3 and the EXTENDED-ADDRESS-SPACE variable is not nil and :PROMOTE is true then the current contents of generation 3, usage 3 will exported to external worlds. A true :SILENT keyword suppresses all GC queries and status notifications." (when (and (mp-system-p) ; jlm 2/28/89 (boundp 'set-mp-reboot-time)) (funcall set-mp-reboot-time 20.)) (gc :type :immediate :max-gen max-gen :silent silent :promote promote :export export) (when (and (mp-system-p) ; jlm 2/28/89 (boundp 'set-mp-reboot-time)) (funcall set-mp-reboot-time *MP-CHECK-NEIGHBOR-DELAY-SECONDS*))) (DEFUN full-gc (&key (silent nil) (before-disk-save t) duplicate-pnames (max-gen 3) (promote t) (train-off t) (export nil) after-system-build debug &allow-other-keys) "Perform a complete garbage collection aimed at reclaiming the largest amount of garbage and reducing the size of the resulting Lisp load band. Use FULL-GC before a DISK-SAVE. To perform a quick batch collection then continue using the system, use GC-IMMEDIATELY. All generations up to and including :MAX-GEN will be collected. When the :PROMOTE keyword is true, (the default), survivors from each collected generation are promoted into the next higher generation. When :BEFORE-DISK-SAVE is true (the default), extra shutdown procedures are performed that release large data structures, such as dismounting the file system and clearing the namespaces. The :DUPLICATE-PNAMES keyword, if true, will collapse duplicate symbol print names if they exist. This is useful in reclaiming space after the loading of large systems. If the :EXPORT keyword is true and :MAX-GEN is 3 and the EXTENDED-ADDRESS-SPACE variable is not nil and :PROMOTE is true then the current contents of generation 3, usage 3 will exported to external worlds. A true :SILENT keyword suppresses all GC queries and status notifications." (DECLARE (ARGLIST &key (max-gen 3) (promote t) (before-disk-save t) (export nil) duplicate-pnames silent)) (when (and (mp-system-p) ; jlm 2/28/89 (boundp 'set-mp-reboot-time)) (funcall set-mp-reboot-time 20.)) (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 :export export :debug debug :train-off train-off) (when (and (mp-system-p) ; jlm 2/28/89 (boundp 'set-mp-reboot-time)) (funcall set-mp-reboot-time *MP-CHECK-NEIGHBOR-DELAY-SECONDS*))) (DEFUN gc-and-disk-save (partition &optional (unit *Default-Disk-Unit*) &key (partition-comment System-Additional-Info) no-query (max-gen 3) (partition-size 30000.)) ;ab 10/6/88 "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 any space problems it can detect. However, if the space problems are not solved by the garbage collection, the subsequent DISK-SAVE will not complete. With a NON-nil :NO-QUERY keyword value, no questions will be asked at all. This option should be used with caution." (BLOCK gc-and-disk-save (when (and (mp-system-p) (> (length *MP-EXPLORER-SLOT-NUMBERS*) 1)) (format *Standard-OutPut* "~2%It is not possible to Disk-Save when more than one processor is booted.~ ~%You must re-boot as a single processor system before performing ~ ~%the Disk-Save.") (return-from gc-and-disk-save nil)) (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 safe-max-gen safe-promote) ;; 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)) (WHEN (AND (NOT (resource-present-p :disk)) (FBOUNDP 'add-or-modify-partition)) ;ab 8/29/88 (add-or-modify-partition save-part-name unit partition-size ;size it to user's guess. may be re-sized later after GC. :load (NOT no-query))) ;; 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 (safe-max-gen safe-promote) (verify-gc-safe max-gen t :full no-query)) (UNLESS safe-max-gen (RETURN-FROM gc-and-disk-save nil)) ;; 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)) (MULTIPLE-VALUE-SETQ (nil vm-size) (get-unassigned-address-space-size)) (WHEN (AND (PLUSP dump-size-delta) (NOT no-query)) (FORMAT *Query-Io* "~2%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 ~a of garbage (~d% of currently allocated storage).~ ~%If less garbage is reclaimed the DISK-SAVE will not be done." estimated-dump-size ;ab 8/29/88 save-part-name unit save-part-size (gc-marked-size-smallest 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 safe-max-gen :promote safe-promote :duplicate-pnames t :before-disk-save t :silent t) ;ab 8/29/88 (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)) ))) ;;; ;;; Dynamic Training Support ;;; (DEFUN bump-usage-counters (&aux bits) (DOTIMES (region Size-Of-Region-Arrays) (WHEN (AND (= %region-space-new (region-space region (SETQ bits (AREF #'REGION-BITS REGION)))) (= (region-generation region bits) (region-volatility region bits)) (= 0 (region-usage region bits))) (SETF (AREF #'region-bits region) (%LOGDPB 1 %%Region-Usage bits))))) (DEFUN reset-usage-counters () (DOTIMES (region Size-Of-Region-Arrays) (SETF (AREF #'region-bits region) (%LOGDPB %Region-Usage-Active %%REGION-USAGE (AREF #'region-bits region))))) (DEFUN training-enabled-p () "T if TGC training has been enabled; else NIL." %tgc-training-enabled) (DEFUN train-space-exists-p () "T if there is any train space; else NIL." (WITHOUT-INTERRUPTS (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 (EQ :train (region-space-type reg (AREF #'region-bits reg))) (RETURN-FROM train-space-exists-p t)) FINALLY (RETURN nil)))) ) (DEFF training-active 'train-space-exists-p) (DEFUN %set-train-space-exists () "Sets %TGC-TRAIN-SPACE-EXISTS to its proper value." (WITHOUT-INTERRUPTS (IF (train-space-exists-p) (SETQ %tgc-train-space-exists t) (SETQ %tgc-train-space-exists nil)))) ;;AB 8/13/87. Call it "Adaptive" training. (DEFUN training-on (&key bump-counters) "Enable Adaptive Training and turn it on at the start of the next collection. Training will remain active until either (FULL-GC :max-gen 3) or (TRAINING-OFF) is done. NOTE: Training cannot be active in a DISK-SAVE'd band. Therefore once training is on either (FULL-GC :max-gen 3) or (TRAINING-OFF) is required before a DISK-SAVE can be done." (DECLARE (arglist)) (WHEN bump-counters (bump-usage-counters)) (SETF %TGC-Training-Enabled t)) ;;AB 8/13/87. Call it "Adaptive" training. (DEFUN training-off (&key (clear-train-space t) reset-counters silent) ;; DON'T WANT TO RESET USAGE COUNTERS WITH EAS!!! "Disable Adaptive Training. When :CLEAR-TRAIN-SPACE is true (the default), a (GC-IMMEDIATELY :max-gen 3) is performed to clear out all train space so that a DISK-SAVE can later be done. This procedure can take a while." (DECLARE (IGNORE RESET-COUNTERS)) (DECLARE (ARGLIST &key (clear-train-space t) silent)) (SETF %TGC-Training-Enabled nil) (WHEN (AND clear-train-space (train-space-exists-p)) (UNLESS silent (FORMAT t "~%Performing (GC-IMMEDIATELY :max-gen 3) to clear out training space. This will take a while...")) (GC-IMMEDIATELY :max-gen 3 :promote nil :silent silent)) (%set-train-space-exists)) ;;; ;;; Training Session Support ;;; (DEFVAR gc-on-before-training nil) (DEFUN start-training-session (&optional (undo-previous-training nil) no-query (gc-first t) &aux distance) "Use this to start a dynamic training session. A dynamic training session allows you to group together related and frequently used code and data objects in order to improve locality of reference and hence improve paging performance. After executing SYS:START-TRAINING-SESSION, use the machine as you would expect it to be used in a typical boot session, invoking and using applications as normal. After this, use SYS:END-TRAINING-SESSION or SYS:END-TRAINING-SESSION-AND-DISK-SAVE to clean out the environment and capture the training you have done. UNDO-PREVIOUS-TRAINING, when true, will cause ALL previous band training to be lost. This is not recommended. GC-FIRST when true first does a promoting GC." (UNLESS *training-session-started* ;; Turn off automatic GC if it is on. (WHEN (gc-active-p) (SETQ gc-on-before-training t) (GC-OFF)) ;; Ensure training off (TRAINING-OFF :clear-train-space nil :silent t :reset-counters t) ;; Get stuff into gen 3 to train. (COND (gc-first (GC-IMMEDIATELY :max-gen 2 :promote t)) ; TGCT ; If TRAIN space exists then we must collect the younger generations ; TGCT ; before we flip generation 3 below or we will go down the tubes!! ; TGCT (%TGC-TRAIN-SPACE-EXISTS (GC-IMMEDIATELY :MAX-GEN 2 :PROMOTE NIL))) ; TGCT (UNLESS no-query (MULTIPLE-VALUE-BIND (space-needed space-free) (get-space-needed-for-gc :max-gen 3 :promote nil :static-regions-are-dynamic undo-previous-training) (UNLESS (PLUSP (SETQ distance (- space-free space-needed))) (FORMAT t "~2%It appears to be ~a too late to complete the SYS:END-TRAINING-SESSION collection,~ ~%unless a lot of memory is garbage." (gc-marked-size-smallest (- distance))) (UNLESS (Y-OR-N-P "~%Start the training session anyway?") (RETURN-FROM start-training-session nil))))) (WHEN undo-previous-training (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 () "Use this function to end a dynamic training session. It captures the training you have done since initiating SYS:START-TRAINING-SESSION and cleans up the environment. Since several garbage collections are done, this may take some time." (WHEN *training-session-started* ;; Make all currently trained generation 3 copyspace static to "capture the training". (make-generation-three-copyspace-static) ;; 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)) ;; Get stuff created during training up into generation 2 then collect. (GC-IMMEDIATELY :max-gen 1 :promote t) (GC-IMMEDIATELY :max-gen 2 :promote nil) (WHEN gc-on-before-training (GC-ON) (SETQ gc-on-before-training nil)) (SETQ *training-session-started* nil)) ) (DEFUN end-training-session-and-disk-save (partition &key (unit *default-disk-unit*) (partition-comment system-additional-info)) "Use this function to end a dynamic training session then do a DISK-SAVE and capture the training you have done since initiating SYS:START-TRAINING-SESSION. This function is equivalent to (SYS:END-TRAINING-SESSION) followed by a \(GC-AND-DISK-SAVE :no-query t)." (WHEN *training-session-started* ;; Make all currently trained generation 3 copyspace static to "capture the training". (make-generation-three-copyspace-static) ;; 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)) (WHEN gc-on-before-training (GC-ON) (SETQ gc-on-before-training nil)) (SETQ *training-session-started* nil) ;; This does a FULL-GC then DISK-SAVE. (GC-AND-DISK-SAVE partition unit :partition-comment partition-comment :no-query t)) ) ;;; ;;; TGC Enable/Disable support (DEFUN collect-generation (generation) (gc :first-gen generation :max-gen generation :type :immediate :promote t)) (DEFUN enable-tgc (&optional after-system-build) (DECLARE (SPECIAL GC-System-Build-Forms-After Gc-System-Build-Forms-Before)) (WHEN after-system-build (MAPC #'EVAL Gc-System-Build-Forms-Before)) (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) (IF (VARIABLE-BOUNDP chaos:chaos-buffer-area) (/= area-num chaos:chaos-buffer-area) t) (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)) (WHEN after-system-build (MAPC #'EVAL Gc-System-Build-Forms-After)) t) (DEFUN disable-tgc () (gc-off) ;; 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)) (DEFUN GC-EXTERNAL () (WHEN EXTENDED-ADDRESS-SPACE ;; 1. TURN OFF THE INCREMENTAL COLLECTOR. (with-gc-notifications-inhibited (GC-OFF)) ;; 2. PERFORM AN INITIAL EXPORTING COLLECTION TO CLEAN OUT THE ACTIVE WORLD. (FORMAT T "~%Performing initial cleanout collection.") (GC-IMMEDIATELY :MAX-GEN 3 :PROMOTE T :EXPORT T) ;; 3. COLLECT THE EXTERNAL WORLDS IN REVERSE ORDER. (LET ((NUMBER-DONE 0.) (NUMBER-TO-DO (LENGTH EXTENDED-ADDRESS-SPACE)) (NUMBER-IN-PROCESS 0.)) (DOLIST (WORLD (REVERSE EXTENDED-ADDRESS-SPACE)) ;; 3.1 CHECK TO SEE IF WE HAVE ENOUGH SPACE TO BE ABLE TO SAFELY FAULT THE NEXT WORLD IN. (LET (USED-VIRTUAL-ADDRESS-SPACE RESERVE) (MULTIPLE-VALUE-BIND (W D USED-ACTIVE) (GET-GENERATION-SIZES) (DECLARE (IGNORE W)) (SETF USED-VIRTUAL-ADDRESS-SPACE 0) (DOTIMES (I 8.) (INCF USED-VIRTUAL-ADDRESS-SPACE (AREF D I))) (MULTIPLE-VALUE-BIND (USABLE-SWAP-SPACE SWAP-SPACE-FREE) (SWAP-SPACE-INFO) (DECLARE (IGNORE USABLE-SWAP-SPACE)) (SETF SWAP-SPACE-FREE (* (- SWAP-SPACE-FREE (COUNT-PAGES-NEEDING-WRITABLE-PAGING-STORE (NOT EXTENDED-ADDRESS-SPACE))) PAGE-SIZE)) ; Also check phys mem. (SETF RESERVE (MIN (- *max-virtual-address* USED-VIRTUAL-ADDRESS-SPACE 2097152.) SWAP-SPACE-FREE)) (IF (< RESERVE (FLOOR (* 12. (+ (AREF D 0) (AREF D 1) (AREF D 2) (AREF USED-ACTIVE 3 3) (AREF USED-ACTIVE 7 3) (* 2. (READ-METER '%MAX-EXTERNAL-WORLD-SIZE)))) 10.)) ;; TIME TO CLEAN THINGS UP. (PROGN (FORMAT T "~%Collecting the next ~d. external worlds with ~d. more to go." NUMBER-IN-PROCESS (- NUMBER-TO-DO NUMBER-DONE NUMBER-IN-PROCESS)) (INCF NUMBER-DONE NUMBER-IN-PROCESS) (SETF NUMBER-IN-PROCESS 0.) (GC-IMMEDIATELY :MAX-GEN 3 :PROMOTE T :EXPORT T)))))) ;; 3.2 FAULT THE NEXT WORLD IN. (DO ((REGION (AREF WORLD %ENTRY-REGIONS) (AREF REGION-WORLD-LIST-THREAD REGION))) ((= 0 REGION)) (DO ((ADDR (REGION-ORIGIN REGION) (%MAKE-POINTER-OFFSET DTP-FIX ADDR 1)) (MAX-ADDR (%MAKE-POINTER-OFFSET DTP-FIX (REGION-ORIGIN REGION) (REGION-FREE-POINTER REGION)))) ((= ADDR MAX-ADDR)) (WHEN (= (%P-LDB %%Q-DATA-TYPE ADDR) DTP-FIX) ;; DON'T LOOK WHILE I DO THIS. (WITHOUT-INTERRUPTS (%IMPORT-OBJECT (%MAKE-POINTER DTP-LOCATIVE ADDR)))))) ;; 3.3 CHANGE THE WORLD TO STATE 2. (SETF (AREF WORLD %WORLD-RECORD-STATE) 2.) ;; 3.4 MAKE THE EXIT REGIONS OF THIS WORLD NEWSPACE SO THEY WILL GO TO OLDSPACE, BE RECLAIMED, AND NOT BE SCAVENGED. (DO ((REGION (AREF WORLD %EXIT-REGIONS) (AREF REGION-WORLD-LIST-THREAD REGION))) ((= 0 REGION)) (SETF (AREF #'REGION-BITS REGION) (%LOGDPB %REGION-SPACE-NEW %%REGION-SPACE-TYPE (AREF #'REGION-BITS REGION)))) ;; 3.5 BUMP THE IN PROCESS COUNTER (INCF NUMBER-IN-PROCESS)) ;; 4. ONE FINAL GC. (FORMAT T "~%Collecting the last ~d. external worlds." NUMBER-IN-PROCESS) (GC-IMMEDIATELY :MAX-GEN 3 :PROMOTE T :EXPORT T)) ;; 5. TURN THE INCREMENTAL COLLECTOR BACK ON AND EXIT. (with-gc-notifications-inhibited (GC-ON))))