; -*- Package:SYSTEM-INTERNALS; Mode:Common-Lisp; Base:8 -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (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 routines for generating statistics on memory usage ;; that are used by garbage collection and the "GC Daemons". ;;; ;;; Edit History ;;; ;;; Patch ;;; Date Author Number Description ;;;------------------------------------------------------------------------------ ;;; 07-22-86 ab -- - Derived from MEMORY-MANAGEMENT; ROOM #8. ;;; 07-30-86 rjf -- - Renamed Get-Fixed-Wired-Space-Size and Get-Fixed- ;;; Space-Size to Get-Fixed-Wired-Pages and Get-Fixed-Pages, ;;; respetively. ;;; - Broke Get-Free-Address-Space up into two functions, ;;; one to be used by the address space daemon and the other ;;; by the garbage collector when estimating free space. ;;; - Changed Get-Space-Sizes to use new free-space function. ;;; 07-31-86 ab - Corrected fencepost error in Get-Fixed-Wired-Pages. ;;; - Changed Get-Free-Swap-Space to be much faster by ;;; just looking directly at %Free-Page-Cluster-Count. ;;; - Made separate function for calculating ;;; Usable-Address-Space-Limit. Renamed & documented ;;; rjf's new address space functions. ;;; 08-21-86 ab -- Moved calculations for GC space sizes here from ;;; MEMORY; GC file. ;;; 09-23-86 ab -- Moved specific gc area/region manipulating routines here ;;; from GC file. ;;; 01-25-87 ab - Minimal integration for TGC compatibility. Incorporated ;;; routines for initiating young consing. ;;; 02-08-87 ab - More re-writing for TGC. Worked on area/region change routines ;;; and general routine for getting all space sizes. ;;; 04-23-87 ab - Make sure MAKE-AREA-REGIONS-STATIC fills generation 3 regions. ;;; Have USABLE-ADDRESS-SPACE-LIMIT return what address space is ;;; limited by. Distinguish between *max-address-space-size* and ;;; *max-virtual-address*. ;;; 05-04-87 ab - Rewrote GET-GC-SPACE-SIZES and GET-SPACE-NEEDED-FOR-GC to ;;; calculate batch-gc space needed properly. ;;; - Fix GET-UNASSIGNED-ADDRESS-SPACE-SIZE and make both ;;; USABLE-ADDRESS-SPACE and GET-FREE-ADDRESS-SPACE just synonyms ;;; for it. ;;; 05-14-87 ab *P GC 5 - Add MAKE-GENERATION-THREE-COPYSPACE-STATIC support for new ;;; training session scheme. ;;; 07-09-87 ab -- - Moved *max-virtual-address* vars to AREA-DEFS and the SPACE-SIZE ;;; DEFSTRUCT to GC-DEFS to get rid of compiler warnings. ;;; 08-26-87 ab GC 18 - Added misc debug fns ;;; 09-14-87 Rjf/BC GC 22 - Added SNAPSHOT-OLDSPACE-SIZE used to snapshot oldspace size at ;;; flip ;;; 11/17/87 rjf GC 26 - Changed snapshot-oldspace-size to save more info about oldspace ;;; at flip time. ;;; 01/25/88 hrc/jho - Changed make-area-regions-dynamic to not CONVERT STATIC REGIONS ;;; TO DYNAMIC REGIONS WITH EXTENDED ADDRESS SPACE. ;;; 02/25/88 ab - Add FS:PATHNAME-AREA to *areas-not-static-after-training* list. ;;; 04/25/89 RJF/HRC - EAS changes: Changed SNAPSHOT-OLDSPACE-SIZE. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Address space calculations ;;; ;;; The current maximum address space on the Explorer is 128 MB. However, the amount of ;;; usable address space may be somewhat less than that. The variable *max-virtual-address* ;;; contains the system's estimate of usable virtual memory, which is 128 MB (32 Mwords) ;;; minus 1Kb for A-Memory and 128Kb reserved for the TV IO buffer. ;;; Thus Virtual-Memory-Size is the maximum amount of address space usable for creating ;;; Lisp objects. ;;; ;;; The amount available is further constrained by the size of the swap space. You cannot ;;; use a page of virtual memory if there is no swap space available for it. (More accurately, ;;; you cannot DIRTY a page of virtual memory unless there is swap space available.) So, ;;; our Addres Space Limit (in the current configuration) is: ;;; ;;; Address Space Limit = Min (Virtual-Memory-Size Swap-Space-Size) ;;; (DEFUN get-fixed-wired-pages () "Returns the number of pages allocated to fixed, wired areas." (FLOOR (AREF #'region-origin (AREF #'area-region-list (SYMBOL-VALUE first-non-fixed-wired-area-name))) page-size)) (DEFF get-fixed-wired-space-size 'get-fixed-wired-pages) (DEFUN get-fixed-pages () "Returns the number of pages allocated to fixed areas." (LET ((region (AREF #'area-region-list (SYMBOL-VALUE last-fixed-area-name)))) (- (FLOOR (+ (AREF #'region-origin region) (AREF #'region-length region)) page-size) (get-fixed-wired-pages)))) (DEFF get-fixed-space-size 'get-fixed-pages) (DEFUN get-free-swap-space () "Returns the amount of free swap space remaining (in words) rounded to the nearest swap space quantum." (* %free-cluster-count cluster-size-in-words)) (DEFUN usable-address-space-limit () "Returns the limiting item for usable virtual memory size in words. This will be the smaller of 32 megawords and the total swap space available in the current configuration. Returns a second value of :SWAP-SPACE or :ADDRESS-SPACE indicating what the address space is limited by in the current configuration." (DECLARE (VALUES address-space-limit limited-by)) (LET ((swap-space-total-size (* (swap-space-info) Page-Size))) (IF (> swap-space-total-size ;; to get the "most swap space we'd ever need, we can also subtract out ;; wired pages which don't need swap space. (- *max-virtual-address* (get-fixed-wired-pages))) (VALUES *max-virtual-address* :address-space) (VALUES swap-space-total-size :swap-space)))) ;;; Calculates maximum free address space available for assignment to new ;;; regions. Does this by traversing address space map and counting unused ;;; quanta. This is an upper bound on free address space quanta, since ;;; we may not have enough swap space for all that free address space. ;;; (NOTE: this is not the same as calculating the UNALLOCATED address space) ;;; ;;; This is used by the address space warning daemon. (DEFUN get-unassigned-address-space-size () "Returns the number of words of address space currently available for assignment to regions. Also returns the number of words currently assigned." (DECLARE (VALUES unassigned-address-space assigned-address-space)) (LET* ((last-fixed-region (AREF #'area-region-list (SYMBOL-VALUE last-fixed-area-name))) (fixed-area-address-space (+ (AREF #'region-origin last-fixed-region) (AREF #'region-length last-fixed-region))) unused) (SETQ unused (LOOP FOR i FROM (TRUNCATE fixed-area-address-space %Address-Space-Quantum-Size) BELOW (FLOOR *max-virtual-address* %Address-Space-Quantum-Size) COUNT (ZEROP (AREF #'Address-Space-Map i)) INTO quanta-unused FINALLY (return (* quanta-unused %Address-Space-Quantum-Size)))) (VALUES unused (- *max-address-space-size* unused))) ) (DEFF get-free-address-space 'get-unassigned-address-space-size) (DEFF get-free-space-size 'get-unassigned-address-space-size) (DEFF usable-address-space 'get-unassigned-address-space-size) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Space Size Calculations ;;; (DEFUN gen-size-allocated (gen &optional (space-size-struct (get-space-size-info (make-space-size-info)))) (SELECT gen (0 (gen0-alloc space-size-struct)) (1 (gen1-alloc space-size-struct)) (2 (gen2-alloc space-size-struct)) (3 (gen3-alloc space-size-struct)) (:static (static-alloc space-size-struct)) (:old (old-alloc space-size-struct)) (:copy (copy-alloc space-size-struct)) (:train (train-alloc space-size-struct)))) (DEFUN get-space-size-info (&optional (space-size-struct *tem-space-size-info*)) (LET ((gen0-alloc 0) (gen0-used 0) (gen1-alloc 0) (gen1-used 0) (gen2-alloc 0) (gen2-used 0) (gen3-alloc 0) (gen3-used 0) (copy-alloc 0) (copy-used 0) (static-alloc 0) (static-used 0) (stat-reg-alloc 0) (stat-reg-used 0) (stat-area-alloc 0) (stat-area-used 0) (fixed-alloc 0) (fixed-used 0) (old-alloc 0) (old-used 0) (train-alloc 0) (train-used 0) (areas 0) (regions 0) reg-bits alloc used) (LOOP FOR area-sym IN area-list FOR area = (SYMBOL-VALUE area-sym) DO (INCF areas) (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) UNTIL (MINUSP region) DO (INCF regions) (SETQ alloc (AREF #'region-length region) used (AREF #'region-free-pointer region) reg-bits (AREF #'region-bits region)) (SELECT (region-space-type region reg-bits) (:new (SELECT (region-generation region reg-bits) (3 (PROGN (INCF gen3-alloc alloc) (INCF gen3-used used))) (2 (PROGN (INCF gen2-alloc alloc) (INCF gen2-used used))) (1 (PROGN (INCF gen1-alloc alloc) (INCF gen1-used used))) (0 (PROGN (INCF gen0-alloc alloc) (INCF gen0-used used))))) (:static (COND ((area-static-p area (AREF #'area-region-bits area)) (INCF stat-area-alloc alloc) (INCF stat-area-used used)) (t (INCF stat-reg-alloc alloc) (INCF stat-reg-used used)))) (:old (PROGN (INCF old-alloc alloc) (INCF old-used used))) (:copy (PROGN (INCF copy-alloc alloc) (INCF copy-used used))) (:fixed (PROGN (INCF static-alloc alloc) (INCF static-used used) (INCF fixed-alloc alloc)) (INCF fixed-used used)) (:train (PROGN (INCF train-alloc alloc) (INCF train-used used))) (:otherwise (FERROR nil "Invalid region type"))))) (SETF (new-alloc space-size-struct) (+ gen0-alloc gen1-alloc gen2-alloc gen3-alloc)) (SETF (new-used space-size-struct) (+ gen0-used gen1-used gen2-used gen3-used)) (SETF (gen0-alloc space-size-struct) gen0-alloc) (SETF (gen0-used space-size-struct) gen0-used) (SETF (gen1-alloc space-size-struct) gen1-alloc) (SETF (gen1-used space-size-struct) gen1-used) (SETF (gen2-alloc space-size-struct) gen2-alloc) (SETF (gen2-used space-size-struct) gen2-used) (SETF (gen3-alloc space-size-struct) gen3-alloc) (SETF (gen3-used space-size-struct) gen3-used) (SETF (copy-alloc space-size-struct) copy-alloc) (SETF (copy-used space-size-struct) copy-used) (SETF (static-alloc space-size-struct) (+ stat-reg-alloc stat-area-alloc fixed-alloc)) (SETF (static-used space-size-struct) (+ stat-reg-used stat-area-used fixed-used)) (SETF (stat-reg-alloc space-size-struct) stat-reg-alloc) (SETF (stat-reg-used space-size-struct) stat-reg-used) (SETF (stat-area-alloc space-size-struct) stat-area-alloc) (SETF (stat-area-used space-size-struct) stat-area-used) (SETF (fixed-alloc space-size-struct) fixed-alloc) (SETF (fixed-used space-size-struct) fixed-used) (SETF (old-alloc space-size-struct) old-alloc) (SETF (old-used space-size-struct) old-used) (SETF (train-alloc space-size-struct) train-alloc) (SETF (train-used space-size-struct) train-used) (SETF (areas space-size-struct) areas) (SETF (regions space-size-struct) regions)) space-size-struct) (DEFUN get-gc-space-sizes (&key (max-gen 3) static-regions-are-dynamic space-size-struct) "Returns total current sizes (in words) of dynamic space, stactic space, and oldspace. Also returns space needed for a batch collection up to generation MAX-GEN both if promotion is used and if it is not." (DECLARE (VALUES dynamic-space static-space old-space space-needed-promote space-needed-no-promote)) (LET ((space-sizes (OR space-size-struct (get-space-size-info *tem-space-size-info*))) space-needed-promote space-needed-no-promote copyspace-gen) ;; Compute space needed. Depends on max-gen and promote. ;; If promoting, have to sum all generation sizes up to max-gen. ;; If not promoting, just need maximum of all generation sizes. (LOOP WITH space-needed = 0 FOR gen FROM 0 TO max-gen SUMMING (gen-size-allocated gen space-sizes) INTO tot-new MAXIMIZE (gen-size-allocated gen space-sizes) INTO max-dyn-size FINALLY (LET () ;; Current copyspace may have to be added to dynamic. (WHEN (gc-in-progress-p) (SETQ copyspace-gen (CEILING gc-type-of-flip 2)) (WHEN (<= copyspace-gen max-gen) (INCF space-needed (gen-size-allocated :copy space-sizes)))) ;; Handle static regions that will be made dynamic (WHEN (AND (= max-gen 3) static-regions-are-dynamic) (INCF space-needed (stat-reg-alloc space-sizes))) (SETQ space-needed-promote (+ space-needed tot-new)) (SETQ space-needed-no-promote (+ space-needed max-dyn-size)))) (VALUES ;; Total Dynamic = New + Copy + Static that will be made dynamic if gen 3 (+ (new-alloc space-sizes) (copy-alloc space-sizes) (IF static-regions-are-dynamic (stat-reg-alloc space-sizes) 0)) ;; Static (minus any that will become dynamic) (IF static-regions-are-dynamic (- (static-alloc space-sizes) (stat-reg-alloc space-sizes)) (static-alloc space-sizes)) ;; Old (old-alloc space-sizes) ;; Space needed space-needed-promote space-needed-no-promote))) (DEFUN get-space-needed-for-gc (&key (max-gen 3) promote space-size-struct static-regions-are-dynamic) (DECLARE (VALUES space-needed space-free dynamic-size static-size old-size)) (UNLESS space-size-struct (SETQ space-size-struct (get-space-size-info *tem-space-size-info*))) (LET ((space-free 0) dynamic-size static-size old-size space-needed-promote space-needed-no-promote address-space-limit limited-by) (MULTIPLE-VALUE-SETQ (dynamic-size static-size old-size space-needed-promote space-needed-no-promote) (get-gc-space-sizes :max-gen max-gen :space-size-struct space-size-struct :static-regions-are-dynamic static-regions-are-dynamic)) (MULTIPLE-VALUE-SETQ (address-space-limit limited-by) (usable-address-space-limit)) ;; TOTAL Address Space = D0 + D1 + D2 + D3 + STATIC + FREE. ;; Therefore FREE = VAS - (D0 + D1 + D2 + D3 + STATIC) (SETQ space-free (- address-space-limit (+ dynamic-size static-size))) ;; Free space can be negative if VAS is limited by swap space because ;; we can have allocated virtual memory that doesn't have swap space allocated yet ;; (ie, load band pages). In this case try to give a more liberal estimate of ;; free space (in any case, no less than 0. (WHEN (AND (MINUSP space-free) (EQ limited-by :SWAP-SPACE)) (SETQ space-free (MAX 0 (- address-space-limit (+ space-needed-promote static-size))))) (VALUES (IF promote space-needed-promote space-needed-no-promote) space-free dynamic-size static-size old-size))) ;;; Determines oldspace sizes and saves them in GC-INITIAL-OLDSPACE-SIZES. ;;; Should be called after a flip so oldspace sizes are correct. (DEFUN SNAPSHOT-OLDSPACE-SIZE () (LET ((OLD 0) (OLD-ALLOCATED 0)) (SETF (aref GC-INITIAL-OLDSPACE-SIZES 2) 0) (SETF (aref GC-INITIAL-OLDSPACE-SIZES 3) 0) (SETF (aref GC-INITIAL-OLDSPACE-SIZES 4) 0) (SETF (aref GC-INITIAL-OLDSPACE-SIZES 5) 0) (LOOP FOR area IN area-list DO (LOOP FOR region = (AREF #'area-region-list (SYMBOL-VALUE area)) THEN (AREF #'region-list-thread region) UNTIL (MINUSP region) DO (WHEN (= (LDB %%REGION-SPACE-TYPE (AREF #'REGION-BITS region)) %REGION-SPACE-OLD) (INCF OLD (AREF #'REGION-FREE-POINTER region)) (INCF OLD-ALLOCATED (AREF #'REGION-LENGTH region)) (INCF (AREF GC-INITIAL-OLDSPACE-SIZES (+ (region-usage region (AREF #'region-bits region)) 2)) (AREF #'region-length region)) ))) (SETF (aref GC-INITIAL-OLDSPACE-SIZES 0) OLD) (SETF (aref GC-INITIAL-OLDSPACE-SIZES 1) OLD-ALLOCATED))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Area/Region change routines ;;; (DEFUN %make-region-static (region &optional (bits (AREF #'region-bits region))) "Changes REGION to static immediately. No error checking!" (SETF (AREF #'region-bits region) (%LOGDPB 1 %%region-scavenge-enable (%LOGDPB %region-space-static %%region-space-type bits)))) (DEFUN %make-region-dynamic (region &optional (bits (AREF #'region-bits region))) "Changes REGION to a dynamic (newspace) region immediately. No error checking!" (SETF (AREF #'region-bits region) (%LOGDPB 0 %%region-scavenge-enable (%LOGDPB %Region-Meta-Bit-Not-Oldspace %%region-oldspace-meta-bit (%LOGDPB %region-space-new %%region-space-type bits))))) ;; ;; Used by routines that enable/disable temporary areas. ;; (DEFUN ensure-area-regions-safe (area-number) "Errors if any regions in area AREA-NUMBER are not NEW or STATIC and generation 3." (LOOP FOR reg = (AREF #'area-region-list area-number) THEN (AREF #'region-list-thread reg) WITH bits = nil WITH typ = nil UNTIL (MINUSP reg) DO (SETQ bits (AREF #'region-bits reg)) (WHEN (/= %region-gen-3 (region-generation reg bits)) (FERROR nil "Region ~a in area ~a is not generation 3." reg (AREA-NAME area-number))) (UNLESS (OR (EQ :new (SETQ typ (region-space-type reg bits))) (EQ :static typ)) (FERROR nil "Region ~a in area ~a is not newspace." reg (AREA-NAME area-number))) FINALLY (RETURN t))) (DEFUN %make-area-static (area) "Changes AREA and all its regions from dynamic to static immediately. Will error it is not safe to do this to any of AREA's regions." (WITHOUT-INTERRUPTS (ensure-area-regions-safe area) ;; Change to static & enable scavenging in area's region bits (LET ((bits (AREF #'area-region-bits area))) (WHEN (area-dynamic-p area bits) (SETF (AREF #'area-region-bits area) (%LOGDPB 1 %%region-scavenge-enable (%LOGDPB %Region-Gen-3 %%REGION-GENERATION (%LOGDPB %region-space-static %%region-space-type bits)))) ;; Do same for all regions in area (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) WITH bits UNTIL (MINUSP region) DO (SETQ bits (AREF #'region-bits region)) (WHEN (region-newspace-p region bits) (%make-region-static region bits))) ))) ) (DEFUN %make-area-dynamic (area) "Changes AREA and all its regions from static to dynamic immediately. Will error it is not safe to do this to any of AREA's regions." (WITHOUT-INTERRUPTS (ensure-area-regions-safe area) ;; Change to dynamic (LET ((bits (AREF #'area-region-bits area))) (WHEN (area-static-p area bits) (SETF (AREF #'area-region-bits area) (%LOGDPB 0 %%region-scavenge-enable (%LOGDPB %region-space-new %%region-space-type bits))) ;; Do same for all regions in area (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) WITH bits UNTIL (MINUSP region) DO (SETQ bits (AREF #'region-bits region)) (WHEN (region-static-p region bits) (%make-region-dynamic region bits)))))) ) (DEFUN %make-area-temporary (area-number) "Make an area (specified by number) as temporary." (WITHOUT-INTERRUPTS (%make-area-static area-number) (SETF (AREF area-temporary-flag-array area-number) 1))) (DEFUN %make-temporary-area-dynamic (temporary-area-number) "Make a temporary area (specified by number) back into dynamic newspace." (WITHOUT-INTERRUPTS (%make-area-dynamic temporary-area-number) (SETF (AREF area-temporary-flag-array temporary-area-number) 0) ;; Remember this area was temporary! (PUSH (AREF #'AREA-NAME temporary-area-number) *areas-not-made-temporary-list*))) ;;; Used to convert regions in a dynamic area to/from static. (DEFUN fill-gen-3-regions (area &aux (%inhibit-read-only t)) ;; Only if default-cons-generation of area is 3. (WHEN (= %region-gen-3 (region-generation nil (AREF #'area-region-bits area))) (WITHOUT-INTERRUPTS (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) WITH bits = NIL WITH l-free = 0 WITH s-free = 0 UNTIL (MINUSP region) DO (SETQ bits (AREF #'region-bits region)) (COND ((EQ :list (region-representation-type region bits)) (INCF l-free (- (AREF #'region-length region) (AREF #'region-free-pointer region)))) ((EQ :structure (region-representation-type region bits)) (INCF s-free (- (AREF #'region-length region) (AREF #'region-free-pointer region))))) FINALLY (LOOP FOR i FROM 0 BELOW l-free DO (MAKE-LIST 1 :area area)) (LOOP FOR i FROM 0 BELOW s-free DO (MAKE-ARRAY 0 :type 'art-string :area area))))) ) (DEFUN make-area-regions-dynamic (area) "Mark the static regions of AREA as dynamic." ;; CONVERSION OF STATIC REGIONS TO DYNAMIC REGIONS CANNOT BE ALLOWED WITH EXTENDED ADDRESS SPACE. (WHEN EXTENDED-ADDRESS-SPACE (RETURN-FROM MAKE-AREA-REGIONS-DYNAMIC)) (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area size-of-area-arrays)) "an area number") (WITHOUT-INTERRUPTS (WHEN (generation-collection-in-progress-p 3) (FERROR nil "Cannot make regions of area ~a dynamic while collection of generation 3 is in progress." (AREA-NAME area))) (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) WITH bits = NIL UNTIL (MINUSP region) DO ;; Only when generation 3 and static. (WHEN (AND (EQ :static (region-space-type region (SETQ bits (AREF #'region-bits region)))) (= %region-gen-3 (region-generation region bits))) (%make-region-dynamic region)))) ) (DEFUN make-area-regions-static (area) "Mark the filled generation 3 newspace regions of AREA as static." (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area size-of-area-arrays)) "an area number") (WITHOUT-INTERRUPTS (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) WITH bits = NIL UNTIL (MINUSP region) DO (SETQ bits (AREF #'region-bits region)) (UNLESS (ZEROP (AREF #'region-free-pointer region)) ;; Only when generation 3 and dynamic. (WHEN (AND (EQ :new (region-space-type region bits)) (= %region-gen-3 (region-generation region bits))) (deallocate-end-of-region region) (%make-region-static region))) FINALLY (fill-gen-3-regions area))) ) (DEFUN make-area-copyspace-regions-static (area) "Mark the generation 3 copyspace regions of AREA as static." (UNLESS (AND (NUMBERP area) (>= area 0) (< area size-of-area-arrays)) (FERROR nil "~a is not a valid area number" area)) (WITHOUT-INTERRUPTS (LOOP FOR region = (AREF #'area-region-list area) THEN (AREF #'region-list-thread region) WITH bits = NIL UNTIL (MINUSP region) DO (SETQ bits (AREF #'region-bits region)) ;; Only when generation 3 and copyspace, and when ;; we've got at least a page of stuff. (WHEN (AND (EQ :copy (region-space-type region bits)) (= %region-gen-3 (region-generation region bits)) (>= (AREF #'region-free-pointer region) page-size)) (deallocate-end-of-region region) (%make-region-static region)))) ) (DEFUN set-generation-three-space-type (new-type &optional (list-of-areas area-list)) "Converts all suitable generation three regions in the dynamic areas of LIST-OF-AREAs to space type NEW-TYPE." (LOOP FOR area-sym IN list-of-areas FOR area = (SYMBOL-VALUE area-sym) UNLESS (= area Indirection-Cell-Area) WHEN (area-dynamic-p area (AREF #'area-region-bits area)) DO (SELECT new-type (:new-from-copy (make-area-copyspace-regions-static area)) ((:new %region-space-new) (make-area-regions-dynamic area)) ((:static %region-space-static) (make-area-regions-static area)))) ) (DEFUN trim-static-area-regions () (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ) FOR area-num = (SYMBOL-VALUE area) ;; Only AREAs marked STATIC (vs regions marked that way) that ;; do not have a MAXIMUM-SIZE DO (WHEN (AND (area-static-p area-num (AREF #'area-region-bits area-num)) (NOT (area-has-maximum-size area-num))) (LOOP FOR region = (AREF #'area-region-list area-num) THEN (AREF #'region-list-thread region) UNTIL (MINUSP region) DO (deallocate-end-of-region region)))) ) ;;; ;;; Used when conducting a training session. (DEFVAR *areas-not-static-after-training* '(sg-and-bind-pdl-area pdl-area indirection-cell-area fasl-table-area fs:pathname-area ;ab 2/25/88 )) (DEFUN make-generation-three-copyspace-static (&aux areas) "Convert all copyspace regions in generation three dynamic areas to static." (LOOP FOR area IN (MEMBER first-non-fixed-area-name area-list :test #'EQ) WITH tem DO (UNLESS (MEMBER area *areas-not-static-after-training* :test #'EQ) (PUSH area tem)) FINALLY (SETQ areas (REVERSE tem))) (set-generation-three-space-type :new-from-copy areas) (with-batch-gc-notifications (gc-report "TRAINING SESSION: ~a of COPYSPACE made static." (gc-marked-size-smallest (stat-reg-alloc (get-space-size-info *tem-space-size-info*))))) ) (DEFUN make-generation-three-static () "Convert all new space regions in generation three and in dynamic areas to static." (set-generation-three-space-type %region-space-static (MEMBER first-non-fixed-area-name area-list :test #'EQ)) (with-batch-gc-notifications (gc-report "TRAINING SESSION: ~a of DYNAMIC space made static." (gc-marked-size-smallest (stat-reg-alloc (get-space-size-info *tem-space-size-info*))))) ) (DEFUN make-generation-three-dynamic () "Converts all static space regions in generation three and in dynamic areas to newspace." (get-space-size-info *tem-space-size-info*) (set-generation-three-space-type %region-space-new (MEMBER first-non-fixed-area-name area-list :test #'EQ)) (with-batch-gc-notifications (gc-report "TRAINING SESSION: ~a of STATIC space made dynamic." (gc-marked-size-smallest (stat-reg-alloc *tem-space-size-info*)))) ) ;;; ;;; Used by Tgc-Enable (DEFUN %set-area-default-cons-generation (area generation) "Set the default cons generation for new objects allocated in this area. The area must be dynamic or no action will be taken since static areas must always be in generation 3." (CHECK-ARG area (AND (NUMBERP area) (>= area 0) (< area Size-Of-Area-Arrays)) "an area number") (LET ((bits (AREF #'area-region-bits area))) (WHEN (region-newspace-p nil bits) (SETF (AREF #'area-region-bits area) (%LOGDPB generation %%region-generation bits)))) ) (DEFUN start-young-consing () (DECLARE (SPECIAL *tgc-non-generation-0-consers*)) (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ) FOR area-num = (SYMBOL-VALUE area) ;; AREAs marked STATIC (vs regions marked that way) must be left alone! ;; They may contain wired pages. DO (UNLESS (area-static-p area-num (AREF #'area-region-bits area-num)) (%set-area-default-cons-generation (SYMBOL-VALUE area) 0))) (LOOP FOR (area gen) IN *tgc-non-generation-0-consers* DO (WHEN (BOUNDP area) (%set-area-default-cons-generation (SYMBOL-VALUE area) gen))) ;; Get rid of any empty generation 3 regions. (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ) FOR area-num = (SYMBOL-VALUE area) WITH default-cons-generation WITH bits ;; AREAs marked STATIC (vs regions marked that way) must be left alone! ;; Also any areas that have default cons generation of 3 or have ;; the volatility-lock bit set. DO (SETQ default-cons-generation (region-generation area-num (SETQ bits (AREF #'area-region-bits area-num)))) (UNLESS (OR (area-static-p area-num bits) (= 3 default-cons-generation) (region-volatility-locked-p area-num bits)) (LOOP FOR reg = (AREF #'area-region-list area-num) THEN (AREF #'region-list-thread reg) UNTIL (MINUSP reg) DO (WHEN (AND (= 3 (region-generation reg (SETQ bits (AREF #'region-bits reg)))) (EQ :new (region-space-type reg bits)) (ZEROP (AREF #'region-free-pointer reg))) (%set-region-generation reg default-cons-generation (AREF #'region-bits reg)) (%set-region-volatility reg default-cons-generation (AREF #'region-bits reg)))))) ) (DEFUN stop-young-consing () (LOOP FOR area in (MEMBER first-non-fixed-area-name area-list :test #'EQ) FOR area-num = (SYMBOL-VALUE area) ;; AREAs marked STATIC (vs regions marked that way) must be left alone! ;; They may contain wired pages. DO (UNLESS (area-static-p area-num) (%set-area-default-cons-generation (SYMBOL-VALUE area) 3))) ) ;;; Debug stuff (DEFVAR ary-list nil) (DEFUN cons-10kb (n) (DOTIMES (i n) (PUSH (MAKE-ARRAY (- (* 5 page-size) 2)) ary-list))) (DEFUN cons-100kb (n) (DOTIMES (i n) (cons-10kb 10.))) (DEFUN cons-1mb (n) (DOTIMES (i n) (cons-100kb 10.))) (DEFUN force-gen-1-collection () (LOOP until (= 1 (FLOOR gc-type-of-flip 2)) do (cons-1mb 1))) (defun set-scav-quantum (nwords) (write-meter '%max-scav-quantum (* nwords 16.)) (read-meter '%max-scav-quantum)) (defmacro scav-work-internal (form) `(let ((scav-work (read-meter '%count-scavenger-work)) (cons-work (read-meter '%count-cons-work)) scav-after cons-after) (eval ,form) (setq cons-after (read-meter '%count-cons-work)) (setq scav-after (read-meter '%count-scavenger-work)) (format t "~%Cons work before: ~10d. Scav work before: ~10d.~ ~%Cons work after: ~10d. Scav work after: ~10d.~ ~%Cons work done: ~10d. Scav work done: ~10d.~ ~%Words: ~10d." cons-work scav-work cons-after scav-after (- cons-after cons-work) (- scav-after scav-work) (floor (- cons-after cons-work) 16.)))) (defun scav-work (form) (scav-work-internal form)) (DEFUN BUBBLE-LIST () (LET ((LIST NIL) (COUNT 0)) (DOTIMES (I (ARRAY-TOTAL-SIZE #'ADDRESS-SPACE-MAP)) (IF (= 0 (AREF #'ADDRESS-SPACE-MAP I)) (INCF COUNT) (WHEN (/= 0 COUNT) (PUSH COUNT LIST) (SETF COUNT 0)))) (WHEN (/= 0 COUNT) (PUSH COUNT LIST)) (SORT LIST '<)))