;-*- Mode:Common-Lisp; Package:System-Internals; Base:8.; Cold-Load:t; -*-

;;;                           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 **
;;;
;;; Edit History
;;;
;;;                   Patch
;;;   Date    Author  Number   Description
;;;--------------------------------------------------------------------
;;; 01-17-86   ab       --     Common Lisp conversion for VM2.
;;;                            This file is composed of the old AREA
;;;                            file, plus some stuff from QRAND.
;;; 02-07-86   ab              Patches Integrated:
;;;                              System 2-64 (to Reset-Temporary-Area).
;;; 02-12-86   ab              Moved Region-True-<thing> routines here
;;;                            from SYS;QMISC.
;;; 03-24-86   ab              Changed :element-type '(unsigned-byte 1)
;;;                            to :type 'art-1b because the cold load
;;;                            uses make-area before subtypes work.
;;; 07-22-86   ab       --     Rel 2.1 Patches Integrated:
;;;                              - System 2-56 (to Reset-Temporary-Area).
;;;                              - System 2-39 (to Return-Storage).
;;;                              Also fixed Return-Storage to make its
;;;                            garbage array a simple array.
;;; 07-31-86    ab      --     - Revised the info displayed for Describe-Area and 
;;;                            Room.  Added optional VERBOSE arg to describe-area.
;;;                            When non-nil, will not display region info.
;;;                            (Describe-Area & friends moved here from 
;;;                            UNKERNEL; DESCRIBE file.  Room here from 
;;;                            MEMORY-MANAGEMENT; ROOM.)
;;; 08-15-86    ab      --     - Added optional reclaim-regions arg to
;;;                            Reset-Temporary-Area.
;;;                            - Wrote %return-region which should be
;;;                            able to replace %gc-reclaim-region miscop
;;;                            someday.
;;; 08-29-86    ab      --     - Moved Allocate-Device-Descriptor-Space
;;;                            here from WINDOW-INITS.  Is used by SIB
;;;                            inits and by new Lisp %Add-Page-Device.
;;; 09-11-86    ab      --     - Added Memory-Status function, which displays
;;;                            general memory-usage figures.
;;; 10-05-86    ab      --     - Moved primitive fns to AREA-DEFS.
;;; 01-08-87    ab      --     - Changes for TGC.  Rewrote MAKE-AREA.
;;;                            New subroutines for area/region info display.
;;;                            Other misc.
;;; 02-08-87    ab      --     - Add FORCE-TEMPORARY flag to MAKE-AREA.
;;;                            Few other misc TGC changes.
;;; 02-11-87    ab      --     - Change to make-area:  gc type of STATIC forces the
;;;                            cache-inhibit flag on (for Explorer 2).
;;; 03-12-87    ab             - Added SCAV-INHIBIT hidden option to MAKE-AREA.
;;;                            Fixed some documentation.  Some speed hacks.
;;;                            Small change to ROOM.
;;; 04-23-87    ab   *O GC 14  - Fix make-area :gc :static to force volatility = 3.
;;;                            - Also add %fill-up-region support so regions made
;;;                            static can be filled up to prevent further consing
;;;                            in them.
;;; 05-19-87    ab   *P Sys 12 - Display area swapin quantum.
;;; 06-25-87    ab   Sys 37    - Change one use of IO-SPACE-VIRTUAL-ADDRESS to
;;;                            *IO-SPACE-VIRTUAL-ADDRESS*.
;;; 07-09-87    ab   Sys 44    - DESCRIBE-AREA and DESCRIBE-REGION changes for TGC training.
;;; 08-05-87    ab   Sys 64    - Force area region size to be one quantum.  [SPR 6152]
;;; 11-30-87    RJF     --     - Fixed arglist for describe-region [spr 6949]
;;; 01-25-88	HRC/JHO	       - Changed describe-area, print-as-region-bits, and format-region-info 
;;;				 to handle the new EAS types.
;;; 01-29-88    RJF            - Added support for region-area-map
;;; 02-27-89    JLM            - Changed Make-area to allow two regions made at once.

;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Make-Area & friends
;;;

(DEFVAR *make-area-debug* nil)

;;AB 8/5/87.  Remove support for :REGION-SIZE keyword; it will default to one quantum.  [SPR 6152]
(DEFUN make-area (&key (name nil)
		       (region-size nil)
		       (representation :structure)
		       (gc :dynamic)
		       (size :infinite)
		       ((:room rm) nil)
		       (read-only nil)
		       ;;
		       ;; rest are hidden
		       (pdl nil)
		       (generation nil)
		       (volatility-lock nil)
		       (scav-inhibit nil)
		       (swapin-quantum nil)
		       (force-temporary nil)
		       (cache-inhibit nil)
		       (real-region-size nil)
		       (real-list-region-size nil)
		       (real-struct-region-size nil)
		       &allow-other-keys
		       &aux area-number region-number
		       the-region-bits
		       real-size)
  "Creates a new area and gives it one initial region.  Returns the area number.
The keyword arguments are:
  :NAME           - The name of the area.  This keyword is required.
  :GC             - Space type for garbage collection.  This defaults to :DYNAMIC, which means
                    garbage in the area may be reclaimed by the garbage collector.  Use a space type
                    of :STATIC when the area will contain data that MUST NOT be moved by the garbage
                    collector (such as wired-down objects).
  :SIZE           - The maximum area size, in words.  The default is :INFINITE, which means
                    the area can grow arbitrarily large.  If you specify a :SIZE other than :INFINITE,
                    the size will be rounded up to the next address space quantum, and the area will
                    be limited to one region of that size.
  :READ-ONLY      - If non-NIL, the area will be read-only.  Default is Read/Write.
  :REPRESENTATION - Representation type of the area's initial region.
                    Can be :LIST or :STRUCTURE or :BOTH (default = :STRUCTURE).
  :ROOM           - If non-nil, push this area onto ROOM, so that (ROOM) will list it.
  :REGION-SIZE    - An obsolete keyword.  Its value will be ignored."
  ;; The following are available but undocumented.
  ;;     :PDL -             Used for areas containing REGULAR-PDLs of stack groups.
  ;;     :GENERNATION -     Default generation for regions created in this area.
  ;;                        Defaults to 3 before TGC is enabled; thereafter defaults to 0.
  ;;     :VOLATILITY-LOCK - Locks the volatility of area regions at 0.
  ;;     :FORCE-TEMPORARY - The only way to FORCE an area to be temporary if TGC enabled.
  ;;     :SWAPIN-QUANTUM -  For pre-paging, should it ever work.
  ;;     :CACHE-INHIBIT -   Overrides default cache-inhibit (cache-inhibit ON for all STATIC areas).
  ;;     :SCAV-INHIBIT -    Overrides default of scav-enable (STATIC areas only).
  ;;     :REAL-REGION-SIZE -Used to specify default region size now that :REGION-SIZE ignored.
  (DECLARE
    (ARGLIST &key name gc size representation read-only room region-size ))

;; :REPRESENTATION
  (CHECK-ARG representation (OR (EQ representation :list)
				(EQ representation :structure)
				(EQ representation :both))
	     "a valid representation-type (:LIST, :STRUCTURE, or :BOTH)")

  (dolist (real-representation (if (eq representation :both)
				   '(:list :structure)
				   (list representation))
			             ;; Return area number
			       area-number)
    (setq real-size size)
    (WHEN (NOT (VARIABLE-BOUNDP Area-Temporary-Flag-Array))
      (SETQ Area-Temporary-Flag-Array
	    (MAKE-ARRAY size-of-area-arrays :type 'art-1b :initial-element 0)))

    ;;; Concordance and error checking.

    ;; :NAME
    (UNLESS name (FERROR nil "The :NAME keyword to MAKE-AREA must be supplied."))
    (CHECK-ARG name (symbolp name) "a symbol")
  
    ;; :REGION-SIZE
    (setq real-region-size
	  (cond ((and real-list-region-size
		      (EQ real-representation :list))
		 real-list-region-size)
		((and real-struct-region-size
		      (EQ real-representation :structure))
		 real-struct-region-size)))

    (SETQ region-size
	  (COND ((AND real-region-size
		      (FIXNUMP real-region-size)
		      (PLUSP real-region-size))
		 (* %address-space-quantum-size
		    (CEILING real-region-size %address-space-quantum-size)))
		(t  %address-space-quantum-size)))

    (UNLESS (FIXNUMP region-size)
      (DECF region-size %address-space-quantum-size))
  
    ;; :SIZE (of AREA)
    (CHECK-ARG real-size (OR (EQ real-size :infinite)
			     (AND (FIXNUMP real-size) (PLUSP real-size)))
	       "a positive fixnum or the keyword :INFINITE")
    (COND ((EQ real-size :infinite)
	   (SETQ real-size most-positive-fixnum))
	  (t
	   ;; Round up to next quantum, but make sure it stays a fixnum.
	   (SETQ real-size (* %address-space-quantum-size
			 (CEILING real-size %address-space-quantum-size)))
	   (UNLESS (FIXNUMP real-size)
	     (DECF real-size %address-space-quantum-size))
	   ;; If SIZE of area specified, assume user wants a 1-region area.
	   (SETQ region-size real-size)))


    ;; :GC
    (CHECK-ARG gc (MEMBER gc '(:static :dynamic :temporary) :test #'EQ)
	       "a valid GC mode (:STATIC, :DYNAMIC or :TEMPORARY)")
    (COND ((AND (EQ gc :temporary)
		%tgc-enabled
		(NOT force-temporary))
	   ;; The :TEMPORARY keyword is allowed, but we convert it to dynmic if TGC is on
	   ;; (and remember that user wanted it temporary, just in case...)
	   (SETQ gc :dynamic)
	   (PUSH name *areas-not-made-temporary-list*))
	  ((AND (EQ gc :temporary)
		force-temporary)
	   ;; If using force flag, area will be made temporary in any event.
	   ;; Put it on the "ALWAYS-TEMPORARY" list.
	   (PUSH name *permanent-temporary-areas-list*)))

    ;; Defaults:
    ;;   Access/status - R/W first
    ;;   Rep type - structure
    ;;   Oldspace-meta - not oldspace
    ;;   Generation - 3, not extra pdl
    ;;   Space type - New
    ;;   Scav enable - off
    ;;   Vol lock - off
    ;;   Volatility - 0 (point to any)
    ;;   Usage - 0 (active)
    ;;   Cache-Inhibit - 0 (off)
    ;;   Swapin quantum - 3
    (SETQ the-region-bits (%default-region-bits))

    ;; Fix generation
    (UNLESS (AND generation (FIXNUMP generation))	;user supplied hidden keyword
      (SETQ generation (IF %tgc-enabled
			   %region-gen-0
			   %region-gen-3)))
    (SETQ the-region-bits
	  (%logdpb generation %%region-generation the-region-bits))
    ;; Region bits volatility = generation unless vol lock; if vol lock then 0.
    ;; Note below: area region bits volatility doesn't matter, so set to 0.
    (SETQ the-region-bits
	  (%logdpb (COND (volatility-lock 0)
			 ((EQ gc :static) 3)
			 (t generation))
		   %%region-volatility
		   the-region-bits)) 

    (WHEN (EQ real-representation :LIST)
      (SETQ the-region-bits
	    (%LOGDPB %region-representation-type-list
		     %%region-representation-type the-region-bits)))

    ;; For gc mode of :STATIC or :TEMPORARY, make space-type static,
    ;; turn on enable-scavenger bit, and set generation to 3.
    (WHEN (NEQ gc :dynamic)
      (SETQ the-region-bits
	    (%LOGDPB %region-space-static %%region-space-type the-region-bits))
      (SETQ the-region-bits
	    (%LOGDPB (COND (scav-inhibit 0)
			   (t 1))
		     %%region-scavenge-enable
		     the-region-bits))
      (SETQ the-region-bits
	    (%logdpb %REGION-GEN-STATIC %%region-generation the-region-bits)))

    ;; Fix cache-inhibit
    (SETQ the-region-bits
	  (%LOGDPB (COND ((NUMBERP cache-inhibit)
			  cache-inhibit)
			 ((EQ gc :static) 1)
			 (t 0))
		   %%region-cache-inhibit
		   the-region-bits))

    ;; Set up access/status bits.
    (SETQ the-region-bits
	  (%logdpb (COND
		     (pdl %pht-map-status-pdl-buffer)
		     (read-only %pht-map-status-read-only)
		     (t %pht-map-status-read-write-first)) 
		   %%region-map-status-bits
		   (%logdpb (COND
			      (pdl 0)
			      (read-only %PHT-Map-Access-Read-Only)
			      (t %PHT-Map-Access-Read-Write))
			    %%region-map-access-bits the-region-bits)))

    ;; Process hidden keywords.  These can over-ride defaults.
    (WHEN volatility-lock
      (SETQ the-region-bits
	    (%LOGDPB 1 %%REGION-ZERO-VOLATILITY-LOCK the-region-bits)))
    (WHEN (AND swapin-quantum (FIXNUMP swapin-quantum))
      (SETQ the-region-bits
	    (%LOGDPB swapin-quantum %%REGION-SWAPIN-QUANTUM the-region-bits)))


    (WHEN *make-area-debug*
      (FORMAT t "~%AREA ~a~
               ~%  SIZE: #x+~x, REGION-SIZE: #x+~x~
               ~%  GC: ~a" name real-size region-size gc)
      (print-as-region-bits the-region-bits))
        
    ;; Lock the area data-structure
    (LET ((inhibit-scheduling-flag t)
	  (inhibit-scavenging-flag t))
      (IF (MEMBER name area-list :test #'EQ)
	  (unless (and (eq representation :both)
		       (eq real-representation :structure))
	    (FERROR nil "The area ~S already exists" name)
	    ())
	  (SETQ area-number (AREF #'system-communication-area %sys-com-free-area#-list))
	  (IF (ZEROP area-number)
	      (FERROR nil "Out of area numbers, cannot create ~S" name))
	  (SETF (AREF #'system-communication-area %sys-com-free-area#-list) (AREF #'area-region-list area-number))
	  ;; Next two lines set up cdr codes correctly and CONCs onto end of area-list
	  ;; Array leader should be right, but store anyway just in case
	  (SETF (ARRAY-LEADER #'AREA-NAME 0) area-number)
	  (VECTOR-PUSH name #'AREA-NAME)
	  ;; Give area name symbol its value.
	  (SET name area-number)
	  (SETF (AREF area-temporary-flag-array area-number)
		(IF (EQ gc :temporary) 1 0))
	  ;; Try to leave in consistant state if bomb out.
	  (SETF (AREF #'area-region-list area-number) (%logdpb 1 %%q-boxed-sign-bit area-number))
	  (SETF (AREF #'area-region-size area-number) region-size)
	  (SETF (AREF #'area-maximum-size area-number) real-size)
	  (SETF (AREF #'area-region-bits area-number)
		(%logdpb 0 %%region-volatility the-region-bits)))
      ;; Call Ucode to cons the region.
      (SETQ region-number (%make-region the-region-bits region-size))
      (SETF (AREF #'REGION-AREA-MAP REGION-NUMBER) AREA-NUMBER)                        ;;Rjf
      (if (not (eq representation :both))
	  (progn (SETF (AREF #'area-region-list area-number) region-number)
		 (SETF (AREF #'region-list-thread region-number) (%logdpb 1 %%q-boxed-sign-bit area-number)))
	  (if (eq real-representation :list)
	      (progn
		(SETF (AREF #'area-region-list area-number) region-number)
		(SETF (AREF #'region-list-thread region-number) (%logdpb 1 %%q-boxed-sign-bit area-number)))
	      (progn
		(setf (aref #'region-list-thread region-number) (AREF #'area-region-list area-number))
		(SETF (AREF #'area-region-list area-number) region-number))))
      (WHEN rm (PUSH name room))
      )))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Temporary Area support
;;;

;;; Temporary areas are not in general supported once the temporal garbage collector
;;; is in the system.

;; This can be substituted for %GC-Free-Region miscop.
(DEFUN %return-region (region)
  "Returns REGION to the free region pool.  Assumes that caller has already
unlinked REGION from its area's region list.  Also assumes region is no longer
being used."
  (WITHOUT-INTERRUPTS
    (LET* ((adr (AREF #'region-origin region))
	   (npages (TRUNCATE (AREF #'region-length region) page-size))
	   (nquanta (TRUNCATE npages %address-space-quantum-size-in-pages)))
      ;; Free pages that might be in core (also bashes h/w maps).
      (deallocate-pages adr npages)
      ;; Mark as FREE in region bits.
      (SETF (AREF #'region-bits region) 0)
      ;; Link into free-region list.
      (SETF (AREF #'region-list-thread region) (AREF #'system-communication-area %sys-com-free-region#-list))
      (SETF (AREF #'system-communication-area %sys-com-free-region#-list) region)
      ;; Bash address-space-map entries.
      (DO ((quantum (LDB %%VA-Quantum-Number adr)
		    (1+ quantum))
	   (cnt 0 (1+ cnt)))
	  ((>= cnt nquanta))
	(SETF (AREF #'address-space-map quantum) 0)))
    ))

(DEFUN Reset-Temporary-Area (area &optional (reclaim-regions nil))
  "Obsolete function.  Returns nil."
  (DECLARE (ARGLIST area &optional (reclaim-regions nil)))
  ;; Always reset area when TGC is not on, but 
  (WHEN (OR (NOT %tgc-enabled)
	    (area-temporary-p area))
    (WITHOUT-INTERRUPTS
      ;; Don't let the area's region list change
      (DO ((region (AREF #'area-region-list area) (AREF #'region-list-thread region))
	   (prev-reg nil region))
	  ((MINUSP region))
	
	LP (WHEN (MINUSP region) (RETURN nil))
	;; Reset free and GC pointers.
	(gc-reset-free-pointer region 0)
	(WHEN reclaim-regions
	  ;; Recover the swap space
	  (deallocate-swap-space region)
	  ;; Return region to free region pool, if not last in area.
	  (IF (last-area-region region)
	      ;; Last region in area.  Just free any pages that might be in core.
	      (deallocate-pages (AREF #'region-origin region)
				(TRUNCATE (AREF #'region-length region) Page-Size))
	      ;; Not last region.  Free it up.
	      (LET ((next-reg (AREF #'region-list-thread region)))
		;; Unlink from the area's region list.
		(IF prev-reg
		    (SETF (AREF #'region-list-thread prev-reg) next-reg)
		    (SETF (AREF #'area-region-list area) next-reg))
		;; Return region to pool.	      
		(%return-region region)
		;; Advance vars & loop again
		(SETQ region next-reg)
		(GO LP))))))
    t))


;;; This function is used to adjust the free pointer of a region up or down,
;;; for functions other than the normal microcoded CONS.
;;; It must do the following:
;;;  Store into REGION-FREE-POINTER
;;;  If REGION-GC-POINTER >= the old free pointer, set it to the new free pointer
;;;    (This is actually only necessary when decreasing the free pointer, but it
;;;     doesn't hurt to do it all the time.)
;;;  Reset the scavenger if it is in that region.
;;;  Adjust A-CONS-WORK-DONE
(DEFUN gc-reset-free-pointer (region newfp &optional ignore-if-downward-flag)
  (OR inhibit-scheduling-flag
      (FERROR nil "This function must be called with scheduling inhibited"))
  (LET ((oldfp (AREF #'region-free-pointer region)))
    (WHEN (OR (< oldfp newfp) (NOT ignore-if-downward-flag))
      (SETF (AREF #'region-free-pointer region) newfp)
      (COND
	((> (AREF #'region-gc-pointer region) oldfp)
	 (FERROR nil "The free pointer of region ~S is inconsistent" region))
	((OR (= (AREF #'region-gc-pointer region) oldfp) (>= (AREF #'region-gc-pointer region) newfp))
	 (SETF (AREF #'region-gc-pointer region) newfp)))
      (%gc-scav-reset region)
      (%gc-cons-work (- newfp oldfp))))) 


(DEFUN mark-not-free (pointer)
  "Move up a region's free pointer, if necessary, so that location POINTER is not free."
  (WITHOUT-INTERRUPTS
    (gc-reset-free-pointer (%region-number pointer)
			   (1+ (%pointer-difference pointer
						    (AREF #'region-origin (%region-number pointer))))
			   t)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Special storage allocation
;;;


(DEFUN %create-swap-space (start-va num-pages)
  "Make sure there is swap space assigned to NUM-PAGES of address
space starting with page containing virtual address START-VA.
   This only creates the swap space.  It does not adjust region
free pointers or fill the pages with anything."
  (WITHOUT-INTERRUPTS 
    (DO ((adr (LOGAND start-va (- page-size))
	      (%pointer-plus adr page-size))
	 (cnt 0 (1+ cnt))
	 (pfn)
	 (si:%inhibit-read-only t))
	((>= cnt num-pages))
      
      (UNLESS (OR (pointer-valid-p adr)		;; If valid, there is already swap space.
		  (%page-status adr))		;; If already swapped in, there will be swap space.
	;; Get some physical memory & associate a virtual page with it.
	(SETQ pfn (%findcore))
	(%page-in pfn (LSH adr (- (BYTE-SIZE %%VA-Offset-Into-Page))))
	;; Now dirty page.  This guarantees it will be swapped out eventually.
	;; When that happens the DPMT swap space will be allocated.
	(%P-DPB (%P-LDB (BYTE 1 0) adr) (BYTE 1 0) adr)))
    ))


(DEFUN %allocate-storage-lisp (start-va nwords)
  "Given START-VA, a virtual address at the free pointer of some region,
allocate NWORDS of storage in the region.  Swap space is created for th
new memory if necessary.  The storage is initialized to NILs if in list
space, and empty strings if in structure space."
  (WITHOUT-INTERRUPTS
    (LET ((reg (%region-number start-va))
	  (%inhibit-read-only t)
	  fp len orig free bits last-adr first-pg last-pg)
      (UNLESS reg
	(FERROR nil "Address ~a is not associated with any region." start-va))
      (SETQ fp (AREF #'region-free-pointer reg)
	    len (AREF #'region-length reg)
	    orig (AREF #'region-origin reg)
	    bits (AREF #'region-bits reg)
	    free (- len fp))
      (WHEN (/= (%pointer-plus orig fp) start-va)
	(FERROR nil "Address ~a is not the first free word in region ~a." start-va reg))
      (WHEN (< free nwords)
	(FERROR nil "There are not ~a words available in region ~a." free reg))
      (SETQ last-adr (%pointer-plus start-va (1- nwords))
	    first-pg (LDB %%va-page-number start-va)
	    last-pg (LDB %%va-page-number last-adr))
      ;; Create the underlying swap space so can legally read/write these locations
      (%create-swap-space start-va (1+ (- last-pg first-pg)))
      ;; Put a valid structure in the locations.
      ;; For list space, NWORDS of (list NIL)s. 
      ;; For structure space, NWORDS of "".
      (COND ((region-list-p reg bits)
	     (%p-dpb cdr-nil %%q-cdr-code start-va)
	     (%p-dpb dtp-symbol %%q-data-type start-va)
	     (%p-dpb 0 %%q-pointer start-va)
	     (WHEN (> nwords 1)
	       (%blt start-va (%pointer-plus start-va 1) (1- nwords) 1)))
	    ((region-structure-p reg bits)
	     (%p-dpb cdr-normal %%q-cdr-code start-va)
	     (%p-dpb (%p-ldb %%q-data-type "") %%q-data-type start-va)
	     (%p-dpb (%p-ldb %%q-pointer "") %%q-pointer start-va)
	     (WHEN (> nwords 1)
	       (%blt start-va (%pointer-plus start-va 1) (1- nwords) 1))))
      ;; Now adjust free pointer.
      (SETF (AREF #'region-free-pointer reg) (+ fp nwords)))))


(DEFUN %fill-up-region (region)
  (WHEN (region-free-p region (AREF #'region-bits region))
      (FERROR nil "Cannot allocate storage in free region ~a." region))
  (WITHOUT-INTERRUPTS 
    (LET ((orig (AREF #'region-origin region))
	  (fp (AREF #'region-free-pointer region))
	  (len (AREF #'region-length region)))
      (UNLESS (= fp len)
	(%allocate-storage-lisp
	  (%pointer-plus orig fp) (- len fp))))))


(DEFUN allocate-device-descriptor-space (amount)
  "Allocate the requested number of words in the Device Descriptor Area.  Returns 
address of allocated block."
  (LET* ((free-pointer (AREF #'system-communication-area %Sys-Com-Descriptor-Space-Free-Pointer))
	 (new-free-pointer (+ free-pointer amount)))

    (WHEN (> new-free-pointer (+ (AREF #'region-origin device-descriptor-area)
				 (AREF #'region-length device-descriptor-area)))
      (IF (VARIABLE-BOUNDP Error-Stack-Group)
	  (FERROR nil "Attempt to allocate beyond end of Device-Descriptor-Area.")
	  (PROGN
	    (PRINT "Attempt to allocate beyond end of Device-Descriptor-Area.")
	    (%crash Device-Descriptor-Space-Overflow
		    new-free-pointer t))))
    (SETF (AREF #'system-communication-area %Sys-Com-Descriptor-Space-Free-Pointer) new-free-pointer)
    free-pointer))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Area/Region Utility routines
;;;

(DEFUN region-origin-true-value (region)
  ;; Avoid returning a negative number if region starts above
  ;; half way point in address space.  It can make a bignum so be careful!
  (convert-to-unsigned (AREF #'region-origin region))) 

(DEFUN region-true-length (region)
  ;; Avoid returning a negative number if region length is large.
  (convert-to-unsigned (AREF #'region-length region)))	

(DEFUN region-true-free-pointer (region)
  ;; Avoid returning a negative number if region free pointer is large.
  (convert-to-unsigned (AREF #'region-free-pointer region)))

;; Temp strings for printing.
(DEFVAR *region-info-string* (MAKE-ARRAY 150. :type art-string :adjustable t :fill-pointer t))
(DEFVAR reg-orig-string (MAKE-ARRAY 11. :type art-string :adjustable t :fill-pointer t))
(DEFVAR reg-len-string (MAKE-ARRAY 10. :type art-string :adjustable t :fill-pointer t))
(DEFVAR reg-fp-string (MAKE-ARRAY 10. :type art-string :adjustable t :fill-pointer t))
(DEFVAR reg-gcp-string (MAKE-ARRAY 10. :type art-string :adjustable t :fill-pointer t))

(DEFUN format-region-info (region &optional (stream *Standard-Output*) (verbose nil) (base 10.))
  (DECLARE (UNSPECIAL base))
  (LET* ((bits (AREF #'region-bits region))
	 (status (LDB %%region-map-status-bits bits))
	 (vol (LDB %%Region-Volatility bits))
	 (gen (LDB %%region-generation bits))
	 (base-marker (SELECT base (8. "#o")(16. "#x")(t "  ")))
	 (*print-base* base))
    (WITH-OUTPUT-TO-STRING (strm *region-info-string* (ARRAY-LEADER *region-info-string* 0))
      (IF (NULL stream)
	  (SETF (ARRAY-LEADER *region-info-string* 0) 0)
	  (SETQ strm stream))
      (SETF (ARRAY-LEADER reg-orig-string 0) 0)
      (SETF (ARRAY-LEADER reg-len-string 0) 0)
      (SETF (ARRAY-LEADER reg-fp-string 0) 0)
      (SETF (ARRAY-LEADER reg-gcp-string 0) 0)
      (FORMAT strm "~4d: ~@11a Origin, ~@10a Length, ~@10a Used, ~@10a GC;  "
	      region
	      (WITH-OUTPUT-TO-STRING (st reg-orig-string (ARRAY-LEADER reg-orig-string 0))
		(FORMAT st "~a~a" base-marker (region-origin-true-value region)) reg-orig-string)
	      (WITH-OUTPUT-TO-STRING (st reg-len-string (ARRAY-LEADER reg-len-string 0))
		(FORMAT st "~a~a" base-marker (AREF #'region-length region)) reg-len-string)
	      (WITH-OUTPUT-TO-STRING (st reg-fp-string (ARRAY-LEADER reg-fp-string 0))
		(FORMAT st "~a~a" base-marker (AREF #'region-free-pointer region)) reg-fp-string)
	      (WITH-OUTPUT-TO-STRING (st reg-gcp-string (ARRAY-LEADER reg-gcp-string 0))
		(FORMAT st "~a~a" base-marker (AREF #'region-gc-pointer region)) reg-gcp-string))
      (FORMAT strm "Type ~5A ~7A ~10a"
	      (NTH (LDB %%region-representation-type bits) '(list struc "REP2" "REP3"))
	      (NTH (LDB %%region-space-type bits)
		   '("FREE" "OLD" "NEW" "OLD-A" "UNUSD5" "UNUSD4" "UNUSD3" "UNUSD2" "UNUSD1"
		     "STATIC" "FIXED" "EX-PDL" "COPY" "TRAIN" "ENTRY" "TRAINA"))
	      (SELECT (LDB %%region-usage bits)
		(%REGION-USAGE-ACTIVE :active)
		(%REGION-USAGE-INACTIVE-1 :inactive-1)
		(%REGION-USAGE-INACTIVE-2 :inactive-2)
		(%REGION-USAGE-INACTIVE-3 :inactive-3)))
      (FORMAT strm "  Gen ~1a"
	      (LDB %%region-generation bits))
      (UNLESS (= gen vol)
	(FORMAT strm ", Vol ~1a" vol))
      (WHEN verbose
	(FORMAT strm "~%")
	(FORMAT strm "~80a" "")
	(FORMAT strm "~[NoScav,~;Scav,  ~] " (LDB %%region-scavenge-enable bits))
	(FORMAT strm "~:[Read/Write,~;Read Only, ~] " (= status %PHT-Map-Status-Read-Only))
	(FORMAT strm "~[Cache On ~;Cache Off~] " (LDB %%region-cache-inhibit bits))
	(WHEN (= status %PHT-Map-Status-MAR) (FORMAT strm ", Mar-Set"))))
    (WHEN (NULL stream) *region-info-string*)))



(DEFUN describe-region (region &key (verbose nil) (base 10.))
  "Tell all about the region number REGION.  With VERBOSE non-NIL, dumps out
interpreted region bits also."
  (DECLARE (UNSPECIAL base))
  (FORMAT t "~%")
  (format-region-info region *standard-output* verbose base)
  (WHEN (EQ verbose :really)
    (TERPRI)
    (print-as-region-bits (AREF #'region-bits region))))

(DEFUN describe-all-regions (&key (base 10.))
  "Tell all about all regions."
  (DECLARE (UNSPECIAL base))
  (TERPRI)
  (DOTIMES (region size-of-region-arrays)
    (describe-region region :base base)))



(DEFUN describe-area (area &key (verbose t) (base 10.) region-verbose)
  "Tell all about the area AREA.  With :VERBOSE non-nil, includes information
about all of AREA's regions.  By default region information is displayed.
The :BASE keyword controls the base for printing region-origin information.
:BASE defaults to base 10."
  (DECLARE (UNSPECIAL base)
	   (ARGLIST area &key (verbose t) (base 10.)))
  (WHEN (NUMBERP area)
      (SETQ area (AREF #'AREA-NAME area)))
  (LET* ((area-number (SYMBOL-VALUE area))
	 (bits (AREF #'area-region-bits area-number))
	 (max-size (area-has-maximum-size area-number))
	 (fixed (area-fixed-p area-number))
	 (base-marker (SELECT base (8. "#o")(16. "#x")(t "")))
	 (*print-base* base)
	 length used n-regions)

    (FORMAT t "~%Area ~@3a:  ~s" area-number area)
    (MULTIPLE-VALUE-SETQ (length used n-regions)
      (room-get-area-length-used area-number))
    (FORMAT t "~%  ")
    (FORMAT t "There are ~:[now ~;~]~a~a words assigned, ~a~a used."
	    max-size base-marker length base-marker used)
    (IF max-size
	(FORMAT t " (~d%)."
		(- 100.
		   (COND
		     ((ZEROP length) 0)
		     ((< length %address-space-quantum-size)
		      (TRUNCATE (* 100. (- length used)) length))	
		     (t (TRUNCATE (- length used) (TRUNCATE length 100.))))))
	(FORMAT t "  The area is growable."))
    (COND (fixed
	   (FORMAT t "  Limited to one region (system FIXED area)."))
	  (max-size
	   (FORMAT t "  Maximum size ~a~a words.  Limited to one region." base-marker max-size))
	  (t
	   (FORMAT t "  ~a region~:P currently." n-regions)))

    (UNLESS fixed
      (FORMAT t "~%  ")
      (FORMAT t "Space type ~a."
	      (NTH (LDB %%region-space-type bits)
		   '("FREE" "OLD" "DYNAMIC" "OLD-A" "UNUSD5" "UNUSD4" "UNUSD3" "UNUSD2" "UNUSD1"
		     "STATIC" "FIXED" "EX-PDL" "COPY" "TRAIN" "ENTRY" "TRAINA")))
      (WHEN (area-temporary-p area-number)
	(FORMAT t "  A TEMPORARY area."))
      (FORMAT t "  Default Cons Generation = ~d." (LDB %%region-generation bits))
      (UNLESS max-size
	(FORMAT t "  Mature region size = ~a~a words." base-marker (AREF #'area-region-size area-number))))

    (FORMAT t "~%  ")
    (LET* ((vol (region-volatility-locked-p nil bits))
	   (cache-inhib (region-cache-inhibit-p nil bits))
	   (swapin (region-swapin-quantum nil bits)))
      (UNLESS (ZEROP swapin) (FORMAT t "Swapin quantum = ~a pages.  " (EXPT 2 swapin)))
      (WHEN vol (FORMAT t "Volatility lock ON.  "))
      (WHEN (EQ :read-only (region-map-status nil bits))
	(FORMAT t "It is a READ-ONLY area.  "))
      (WHEN cache-inhib (FORMAT t "The cache is inhibited.  ")))
    
    (WHEN verbose
      (DO ((region (AREF #'area-region-list area-number) (AREF #'region-list-thread region)))
	  ((MINUSP region))
	(describe-region region :base base :verbose region-verbose)))
    (VALUES)))


(DEFUN describe-all-areas (&key (verbose nil) (base 10.))
  "Give information about all areas.  With :VERBOSE non-nil, provides information
about each area's regions also."
  (DECLARE (UNSPECIAL base))
  (FORMAT t "~2%(All numbers are in base ~d.)" *print-base*)
  (DOTIMES (area size-of-area-arrays)
    (WHEN (AREF #'AREA-NAME area)
      (TERPRI)
      (DESCRIBE-AREA area :verbose verbose :base base)))
  (VALUES))

(DEFUN describe-generation (generation &key (volatility :any) (verbose nil))
  "Tell all about the regions in the specified generation and optionally
report only those with the specified volatility."
  (DOLIST (area Area-List)
    (DO ((region (AREF #'area-region-list (SYMBOL-VALUE area))
		 (AREF #'region-list-thread region)))
	((MINUSP region))
      (LET ((bits (AREF #'region-bits region)))
	(WHEN (AND (= generation (LDB %%region-generation bits))
		   (OR volatility
		       (= volatility (LDB %%region-volatility bits))))
	  (TERPRI)
	  (format-region-info region)
	  (WHEN verbose (print-as-region-bits bits)))))))

(DEFUN print-as-region-bits (bits)
  "Display BITS, an integer, interpreted as region-bits."
  (LET ((access (LDB %%region-map-access-bits bits))
	(status (LDB %%region-map-status-bits bits))
	(rep (LDB %%region-representation-type bits))
	(os (LDB %%region-oldspace-meta-bit bits))
	(epdl (LDB %%region-extra-pdl-bit bits))
	(gen (LDB %%region-generation bits))
	(space (LDB %%region-space-type bits))
	(scav (LDB %%region-scavenge-enable bits))
	(vol-lock (LDB %%region-zero-volatility-lock bits))
	(vol (LDB %%region-volatility bits))
	(usage (LDB %%region-usage bits))
	(cache-inhibit (LDB %%region-cache-inhibit bits))
	(swap (LDB %%region-swapin-quantum bits)))
    (FORMAT T "~%   REGION-BITS: #x+~x~
               ~%     Access:          ~@18a (~a)~
               ~%     Status:          ~@18a (~a)~
               ~%     Rep. type:       ~@18a (~a)~
               ~%     Oldspace:        ~@18a (~a)~
               ~%     Extra PDL:       ~@18a (~a)~
               ~%     Generation:      ~@18a~
               ~%     Space type:      ~@18a (~a)~
               ~%     Scav enable:     ~@18a (~a)~
               ~%     Vol lock:        ~@18a (~a)~
               ~%     Volatility:      ~@18a~
               ~%     Cache inhibit:   ~@18a (~a)~
               ~%     Usage            ~@18a (~a)~
               ~%     Swapin quantum:  ~@18a"
	    bits
	    (SELECT access
	      ((0 1) :none)
	      (%PHT-Map-Access-Read-Only :read-only)
	      (%PHT-Map-Access-Read-Write :read-write)) access
	    (SELECT status
	      (%PHT-Map-Status-Map-Not-Valid :NOT-SET-UP)
	      (%PHT-Map-Status-Meta-Bits-Only :META-BITS-ONLY)
	      (%PHT-Map-Status-Read-Only :READ-ONLY)
	      (%PHT-Map-Status-Read-Write-First :READ-WRITE-FIRST)
	      (%PHT-Map-Status-Read-Write :READ-WRITE)
	      (%PHT-Map-Status-PDL-Buffer :PDL-BUFFER)
	      (%PHT-Map-Status-MAR :MAR-SET)) status
	    (SELECT rep
	      (%region-representation-type-list :LIST)
	      (%region-representation-type-structure :STRUCTURE)) rep
	    (SELECT os (0 t) (1 nil)) os
	    (SELECT epdl (0 nil) (1 t)) epdl
	    gen
	    (SELECT space
	      (%region-space-free :FREE)
	      (%region-space-old :OLD)
	      (%region-space-new :NEW)
	      (%REGION-SPACE-OLD-A :OLD-A)
	      (%REGION-SPACE-NOT-USED-5 :UNUSED5)
	      (%REGION-SPACE-NOT-USED-4 :UNUSED4)
	      (%REGION-SPACE-NOT-USED-3 :UNUSED3)
	      (%REGION-SPACE-NOT-USED-2 :UNUSED2)
	      (%REGION-SPACE-NOT-USED-1 :UNUSED1)
	      (%region-space-static :STATIC)
	      (%region-space-fixed :FIXED)
	      (%region-space-extra-pdl :EXTRA-PDL)
	      (%region-space-copy :COPY)
	      (%REGION-SPACE-TRAIN :TRAIN)
	      (%REGION-SPACE-ENTRY :ENTRY)
	      (%REGION-SPACE-TRAIN-A :TRAIN-A)
	      ) space
	    (SELECT scav (0 nil) (1 t)) scav
	    (SELECT vol-lock (0 nil) (1 t)) vol-lock
	    vol
	    (IF (ZEROP cache-inhibit) "OFF" "ON") cache-inhibit
	    (SELECT (LDB %%region-usage bits)
		(%REGION-USAGE-ACTIVE :active)
		(%REGION-USAGE-INACTIVE-1 :inactive-1)
		(%REGION-USAGE-INACTIVE-2 :inactive-2)
		(%REGION-USAGE-INACTIVE-3 :inactive-3))
	    usage
	    swap))
  )



(DEFVAR room '(Working-Storage-Area Macro-Compiled-Program)
   "Areas to mention when ROOM is called with no args.") 

(DEFUN room-get-area-length-used (area)
  "Returns the total number of words currently assigned to AREA, the number currently
used, and the number of regions in AREA."
  (DECLARE (VALUES (length-assigned used nbr-regions)))
  (DO ((region (AREF #'area-region-list area) (AREF #'region-list-thread region))
       (n-regions 0 (1+ n-regions))
       (length 0 (+ length (convert-to-unsigned (AREF #'region-length region))))
       (used 0 (+ used (convert-to-unsigned (AREF #'region-free-pointer region)))))
      ((MINUSP region)
       (RETURN (VALUES length used n-regions)))))

(DEFUN format-physical-memory-info (&optional (stream *standard-output*))
  (LET (n-wired-pages n-fixed-wired-pages words)
    (MULTIPLE-VALUE-SETQ (n-wired-pages n-fixed-wired-pages)
	(count-wired-pages))
    (FORMAT stream "Physical Memory: ~:d words (~d MB).  Wired Pages: ~D System + ~D User."
	    (SETQ words (words-of-physical-memory))
	    (FLOOR (* words 4) 1m-byte)
	    n-fixed-wired-pages
	    (- n-wired-pages n-fixed-wired-pages))
  ))

(DEFUN format-free-space-info (&optional (stream *standard-output*) &aux free-size)
  (WHEN (FBOUNDP 'usable-address-space)
      (SETQ free-size (usable-address-space))
      (FORMAT stream "Address space free size: ~:d words (~:d pages)."
	      free-size (TRUNCATE free-size Page-Size))))

(DEFVAR *area-info-string* (MAKE-ARRAY 100. :type 'art-string :adjustable t :fill-pointer t))

(DEFUN format-area-info (area &optional (STREAM *standard-output*) (print-dots t) (base 10.))
  (DECLARE (UNSPECIAL base))
  (WHEN (AREF #'AREA-NAME area)
    (LET ((max-size (area-has-maximum-size area))
	  length used n-regions
	  (ch (IF print-dots #\. #\space))
	  (base-marker (SELECT base (8. "#o")(16. "#x") (t "")))
	  (*print-base* base))
     (MULTIPLE-VALUE-SETQ (length used n-regions)
	(room-get-area-length-used area))
     (WITH-OUTPUT-TO-STRING (strm *area-info-string* (ARRAY-LEADER *area-info-string* 0))
       (IF (STREAMP stream)
	   (SETQ strm stream)
	   (SETF (ARRAY-LEADER *area-info-string* 0) 0))
       (FORMAT strm "~42,,,va~3,v,d region~a ~21,1,1,,<~a~a/~a~> used"
	       ch (AREF #'AREA-NAME area) ch n-regions
	       (IF (> n-regions 1) "s" " ")
	       base-marker used length)
       (IF max-size
	   (FORMAT strm "  (~3d%)"
		   (- 100.
		      (COND
			((ZEROP length) 0)
			((< length %address-space-quantum-size)
			 (TRUNCATE (* 100. (- length used)) length))	
			(t (TRUNCATE (- length used) (TRUNCATE length 100.))))))
	   (FORMAT strm "  (growable)")))
    (WHEN (NULL stream) *area-info-string*)))
  )

;; (ROOM) tells about the default areas
;; (ROOM area1 area2...) tells about those areas
;; (ROOM T) tells about all areas
;; (ROOM NIL) prints only the header, does not do any areas

(DEFUN room (&REST ARGS)
  "Print size and free space of some areas.
ARGS can be areas, or T as arg means all areas.
No args means use the areas whose names are members of the value of ROOM.
NIL as arg means print a header but mention no areas."
  (COND
    ((NULL args) (SETQ args room))
    ((EQUAL args '(t))
     (SETQ args area-list)))
  (TERPRI)
  (format-physical-memory-info)
  (TERPRI)
  (format-free-space-info)
  (TERPRI)
  (COND
    ((NOT (EQUAL args '(nil)))
     (DOLIST (area args)
       (FORMAT t "  ")
       (format-area-info (IF (SYMBOLP area)
			     (SYMBOL-VALUE area)
			     area))
       (TERPRI)))))


(DEFUN virtual-memory-status ()
  "Display general statistics on virtual memory usage."
  (LET* ((fixed-size (+ (AREF #'region-origin (SYMBOL-VALUE last-fixed-area-name))
			(AREF #'region-length (SYMBOL-VALUE last-fixed-area-name))))
	 (a-mem-and-io-size
	   (* %address-space-quantum-size
	      (CEILING (- (EXPT 2 (BYTE-SIZE %%Q-Pointer))
			  (convert-to-unsigned *Io-Space-Virtual-Address*))
		       %address-space-quantum-size)))
	 (total-system-reserved-size
	   (+ fixed-size a-mem-and-io-size))
	 (max-available-to-user
	   (- (EXPT 2 (BYTE-SIZE %%Q-Pointer))
	      total-system-reserved-size))
	 (num-system-regions (1+ (SYMBOL-VALUE last-fixed-area-name)))
	 (non-fixed-areas-list (MEMBER First-Non-Fixed-Area-Name Area-List :test #'EQ)) 
	 (num-non-fixed-areas (LENGTH non-fixed-areas-list))
	 (allocated 0) (unallocated) (used 0)
	 (fragmented 0) (num-user-regions 0)
	 (num-regions-in-use 0) (ave-size 0) area-size
	 largest-area (largest-area-size -1)
	 largest-region (largest-region-size -1)
	 (list-size 0) (struct-size 0) (num-list-regions 0) (num-struct-regions 0))
    
    (DOLIST (area-sym non-fixed-areas-list)
      (SETQ area-size 0)
      (DO ((reg (AREF #'area-region-list (SYMBOL-VALUE area-sym))
		(AREF #'region-list-thread reg)))
	  ((MINUSP reg)
	   (WHEN (> area-size largest-area-size)
	     (SETQ largest-area-size area-size
		   largest-area (SYMBOL-VALUE area-sym))))
	  
	(INCF num-user-regions)
	(INCF used (AREF #'region-free-pointer reg))
	
	(LET ((len (AREF #'region-length reg)))
	  (INCF allocated len)
	  (INCF area-size len)
	  (WHEN (> len largest-region-size)
	    (SETQ largest-region-size len
		  largest-region reg))
	  (SELECT (region-representation-type reg)
	    (:LIST (INCF list-size len) (INCF num-list-regions))
	    (:STRUCTURE (INCF struct-size len) (INCF num-struct-regions))))))

    (SETQ fragmented (- allocated used)
	  unallocated (- max-available-to-user allocated)
	  ave-size (ROUND allocated num-user-regions)
	  num-regions-in-use (+ num-system-regions num-user-regions))
    
    (FORMAT t "~2%-----------------------------------------------------------------------------------~
                ~%  VIRTUAL MEMORY STATUS    (size figures are in octal words)~
                ~%-----------------------------------------------------------------------------------")
    (FORMAT t "~2%SYSTEM MEMORY:~
                ~%  Size of fixed areas:                  ~11,,:o~
                ~%  A-Memory & TV buffer size:            ~11,,:o~
                ~%  Total system reserved size:           ~11,,:o  (~d% of total)"
	    fixed-size a-mem-and-io-size total-system-reserved-size
	    (ROUND (* total-system-reserved-size 100.)
		   (EXPT 2 (BYTE-SIZE %%Q-Pointer))))
    (FORMAT t "~2%NON-SYSTEM MEMORY:~
                ~%  Maximum user-available size:          ~11,,:o~
                ~%  Currently unallocated:                ~11,,:o~
                ~%  Currently allocated to regions:       ~11,,:o  (~d% of user-available)~
                ~%  Currently used in regions:            ~11,,:o~
                ~%  Fragmentation:                        ~11,,:o  (~d% of allocated)~
                ~%  Average fragmentation per region:     ~11,,:o"
	    max-available-to-user unallocated allocated
	    (ROUND (* allocated 100.) max-available-to-user)
	    used fragmented (ROUND (* fragmented 100.) allocated)
	    (ROUND fragmented num-user-regions))
    (FORMAT t "~2%REGION USAGE:~
                ~%  Total number of regions:              ~11,,:d.~
                ~%  Number of unused regions:             ~11,,:d.~
                ~%  Number of system regions:             ~11,,:d.~
                ~%  Number of non-system regions:         ~11,,:d.~
                ~%  Total regions in use:                 ~11,,:d. (~d% of all regions)~
                ~%  Average non-system region size:       ~11,,:o  (~d. quanta)~
                ~%  Largest region length:                ~11,,:o  (~d. quanta, number ~d.)"
	    Size-Of-Region-Arrays (number-of-free-regions)
	    num-system-regions num-user-regions
	    num-regions-in-use (ROUND (* num-regions-in-use 100.) Size-Of-Region-Arrays)
	    ave-size (ROUND ave-size %address-space-quantum-size)
	    largest-region-size (ROUND largest-region-size %Address-Space-Quantum-Size)
	    largest-region)
    (FORMAT t "~2%REPRESENTATION TYPES:~
                ~%  Number of list regions:               ~11,,:d.~
                ~%  List space size:                      ~11,,:o  (~d%)~
                ~%  Number of structure regions:          ~11,,:d.~
                ~%  Structure space size:                 ~11,,:o  (~d%)"
	    num-list-regions list-size (ROUND (* list-size 100.) allocated)
	    num-struct-regions struct-size (ROUND (* struct-size 100.) allocated))
    (FORMAT t "~2%AREA USAGE:~
                ~%  Total number of areas:                ~11,,:d.~
                ~%  Number of unused areas:               ~11,,:d.~
                ~%  Number of system areas:               ~11,,:d.~
                ~%  Number of non-system areas:           ~11,,:d.~
                ~%  Average regions per non-system area:  ~11,,:d.~
                ~%  Largest area:                         ~11,,:o (~a, ~d. region~:p)"
	    Size-of-Area-Arrays (- Size-of-Area-Arrays (LENGTH area-list))
	    (SYMBOL-VALUE first-non-fixed-area-name) num-non-fixed-areas
	    (ROUND num-user-regions num-non-fixed-areas)
	    largest-area-size (AREF #'AREA-NAME largest-area)
	    (DO ((r (AREF #'area-region-list largest-area) (AREF #'region-list-thread r))
		 (c 0 (1+ c)))
		((MINUSP r) c)))
    (VALUES)
    ))


;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Return Storage
;;;

(DEFPARAMETER return-storage-garbage-list (LIST nil))  

(DEFUN return-storage (object &optional (force-p nil) &aux region object-origin object-size)
  "Dispose of OBJECT, returning its storage to free if possible.
If OBJECT is a displaced array, the displaced-array header is what is freed.
You had better get rid of all pointers to OBJECT before calling this,
 e.g. (RETURN-STORAGE (PROG1 FOO (SETQ FOO NIL)))
Returns T if storage really reclaimed, NIL if not."
  (DECLARE (ARGLIST object))
  (WHEN (OR (NOT %tgc-enabled)
	    force-p)
    ;;Turn off garbage collection, allocation in this region
    (WITHOUT-INTERRUPTS
      (SETQ region (%region-number object)
	    object-origin (%POINTER  (%FIND-STRUCTURE-LEADER object))
	    object-size (%STRUCTURE-TOTAL-SIZE object))
      (SETQ ar-1-array-pointer-1 nil)
      (SETQ ar-1-array-pointer-2 nil)
      (WHEN (= (%P-DATA-TYPE object) DTP-Header-Forward)
	;; If object is structure forwarded, first try to return storage
	;; of ancestor structure(s).  Since ancestors are likely to be
	;; allocated right after current structure, doing this first increases
	;; our chances of being able to return current structure.
	(WHEN (return-storage (%FIND-STRUCTURE-HEADER (%P-POINTER object)))
	  (IF (= %region-representation-type-list
		 (%LOGLDB %%region-representation-type
			  (AREF #'region-bits region)))
	      ;; List.  Just make hdr-forward point to our garbage list.
	      (%P-STORE-POINTER object Return-Storage-Garbage-List)
	      ;; Structure.  Replace with 32b array of appropriate length.
	      ;; If ancestor structure freed, make current structure look like something
	      ;; valid:  ie, "erase" the forwarding.  This prevents problems
	      ;; if current, forwarded structure can't be returned (ie, since ancestor
	      ;; returned, where will our header-forward now point?).
	      (LET ((long-length (> (1- object-size) %array-max-simple-index-length))
		    (ptr (%POINTER object)))
		;; Remove DTP-HEADER-FORWARD.  If array with leader, and someone still
		;; has pointers to it, this will cause the inevitable crash to happen quicker.
		(%P-STORE-TAG-AND-POINTER ptr DTP-Free ptr)
		;; Make new header word at real start of structure.
		(%P-DPB DTP-Array-Header %%Q-Data-Type object-origin)
		(%P-DPB (%MAKE-POINTER-OFFSET DTP-Fix
					      Art-32b
					      (DPB (IF long-length 0 (1- object-size))
						   %%ARRAY-INDEX-LENGTH-IF-SIMPLE 
						   (DPB 1 %%ARRAY-NUMBER-DIMENSIONS
							(DPB 1 %%ARRAY-SIMPLE-BIT 0))))
			%%Q-Pointer object-origin)
		;; Make long length word if necessary, & set long length flag in header.
		(WHEN long-length
		  (%P-DPB 1 %%array-long-length-flag object-origin)
		  (%P-DPB DTP-Fix %%Q-Data-Type (1+ object-origin))
		  (%P-DPB (- object-size 2) %%Q-Pointer (1+ object-origin)))))))
      ;; Now return current structure if possible.
      (COND ((= (%MAKE-POINTER-OFFSET DTP-Fix object-origin object-size)
		(%MAKE-POINTER-OFFSET DTP-Fix
				      (AREF #'region-origin region) (AREF #'region-free-pointer region)))
	     (gc-reset-free-pointer region (%POINTER-DIFFERENCE object-origin
								(AREF #'region-origin region)))
	     t)
	    (t nil))))
  )

(DEFF return-array 'return-storage)