;-*- 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) 1986-1989 Texas Instruments Incorporated. All rights reserved.

;;; This file contains definitions, subst's & macros for storage management.

;;;
;;; Edit History
;;;
;;;                   Patch
;;;   Date    Author  Number   Description
;;;--------------------------------------------------------------------
;;; 09-11-86    ab      --     - Added some more region-info primitives.
;;; 09-22-86    ab      --     - Moved Va-Valid-P here from DISK-SAVE-INTERNAL.
;;; 11-24-86    ab             - New region accessors for TGC.
;;; 01-13-87    ab             - Other TGC revisions.
;;; 02-08-97    ab             - Improve area/region accessors.  Include
;;;                              virtual address predicates here (pointer-valid-p, etc).
;;; 02-11-87    ab             - Additions for explorer2 region-cache-inhibit.
;;; 03-11-87    ab             - Couple small changes.  Remove INLINE proclamation
;;;                              from REGION-REPRESENTATION-TYPE.  Some speed hacks.
;;; 03-29-87    ab             - Fix NUMBER-OF-FREE-REGIONS not to get faked out
;;;                              when called while a new region was being consed.
;;; 04-20-87    ab             - Define GET-IO-SPACE-VIRTUAL-ADDRESS.
;;; 05-19-87    ab   *P Sys 12 - Define routines to set swapin quanta of areas.
;;; 07-09-87    ab      --     - Moved *max-virtual-address* vars here from GC-AREA-SUPPORT
;;;                              to clean up compiler warnings.  Also added a PROCLAIM.
;;; 08-05-87    ab    Sys 64   - Routines for manipulating area region size.  For [SPR 6152]
;;; 01/25/88	hrc/jho	       - Changed region-space-type to now handle EAS entry-space and old-a.
;;;				 Added region-oldspace-a-p, region-entry-p, and region-train-a-p.
;;; 02/11/88	jho	       - added EAS defs
;;; 02/26/88	DNG	       - Fix AREA-TEMPORARY-P to not error if called before 
;;;				AREA-TEMPORARY-FLAG-ARRAY is initialized.
;;; 08/23/88    clm            - moved inhibit-gc-flips defvar and macro to this file so they 
;;;                              get into the cold band; these are now used in the kernel.
;;; 02/27/89    jlm            - Added %set-area-shared and area-shared-p using region-usage-bits of 
;;;  				 area-bits.

;;;;;;;;;;;;
;;;
;;; Vars
;;;

(PROCLAIM '(SPECIAL %address-space-quantum-size-in-pages
		    *processor-ucode-name-alist* *microcode-name-alist*))

;; True if TGC system has been loaded; else false.  This is referred to by temporary-area
;; support routines.
(DEFVAR %tgc-enabled nil
  "When non-NIL, indicates that temporal garbage collection is enabled (ie, that young consing is on).")

(DEFVAR Area-Temporary-Flag-Array :unbound
  "Array, indexed by area number, containing 1 if area is temporary, else 0.")

(DEFVAR *areas-not-made-temporary-list* nil)
(DEFVAR *permanent-temporary-areas-list* nil)

;; The next 2 are A-Memory locations.
(DEFVAR Default-Cons-Area :unbound
  "The area used for consing by CONS, LIST, MAKE-ARRAY, etc. if nothing else is specified.") 

(DEFVAR Background-Cons-Area :unbound
  "The area used for consing which is supposed to never be in a temporary area.
This area is used by functions which want to update permanent data structures
and may be called even when DEFAULT-CONS-AREA is a temporary area.") 

;;;
;;; Extended Address Space

(DEFVAR EXTENDED-ADDRESS-SPACE NIL
  "This variable controls the extended address space feature. NIL means that the
feature is not active. T means that the feature is authorized for activation, but
no external worlds have been formed yet. A list indicates that the extended address 
space feature is active and external worlds are present. In this later case the world
records in states 1, 2, and 3 are in the list anchored by EXTENDED-ADDRESS-SPACE.")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Area attributes, predicates, etc
;;;
  

(PROCLAIM '(inline area-temporary-p))
(DEFUN area-temporary-p (area-number)
  "Return T if the specified area is a temporary area."
  ;; If area-temporary-flag-array is not initialized yet, then there can't 
  ;; have been any temporary areas created yet either.
  (and (boundp 'area-temporary-flag-array)
       (NOT (ZEROP (AREF area-temporary-flag-array area-number)))))

(PROCLAIM '(inline area-fixed-p))
(DEFUN area-fixed-p (area)
  "Returns t if an area is fixed (limited to one region per area)."
  (< area (SYMBOL-VALUE first-non-fixed-area-name)))


(DEFUN area-has-maximum-size (area)
  "Returns the maximum size of an area, if the area is non-expandable; else nil.
An area is non-expandable if it is one if the fixed areas, or if it was created
with an explicit area-maximum size."
  (IF (area-fixed-p area)
      (region-length area)
      (LET ((size (area-maximum-size area)))
	(UNLESS (= size most-positive-fixnum)
	  size)))
  )

(PROCLAIM '(inline last-area-region))
(DEFUN last-area-region (region)
  "Returns T if REGION is the last region in its area's region list; else NIL."
  (MINUSP (AREF #'region-list-thread region)))

(PROCLAIM '(inline end-of-region-list))
(DEFUN end-of-region-list (region)
  "Returns T if REGION is not actually a region number, but a special marker
indicating there are no more regions in this area; else returns NIL."
  (MINUSP region))

;; moved to 
;(proclaim '(inline area-shared-p))
;(defun area-shared-p (area &optional (bits (AREF #'area-region-bits area)))
;  "Returns T if AREA is currently a shared area."
;  (plusp (ldb %%REGION-USAGE bits)))

(DEFUN %set-area-shared (area &optional (bits (AREF #'area-region-bits area)))
  (SETF (AREF #'area-region-bits area)
	(%LOGDPB 1 %%region-usage bits)))


(PROCLAIM '(inline area-static-p))
(DEFUN area-static-p (area &optional (bits (AREF #'area-region-bits area)))
  "Returns T if AREA is currently a static area."
  (= (LDB %%region-space-type bits) %region-space-static))

(DEFUN %set-area-static (area &optional (bits (AREF #'area-region-bits area)))
  (SETF (AREF #'area-region-bits area)
	(%LOGDPB %region-space-static %%region-space-type bits)))


(PROCLAIM '(inline area-dynamic-p))
(DEFUN area-dynamic-p (area &optional (bits (AREF #'area-region-bits area)))
  "Returns T if AREA is currently a dynamic (newspace) area."
  (= (LDB %%region-space-type bits) %region-space-new))

(DEFUN %set-area-dynamic (area &optional (bits (AREF #'area-region-bits area)))
  (SETF (AREF #'area-region-bits area)
	(%LOGDPB %region-space-new %%region-space-type bits)))

;;AB 8/5/87.  Support number as AREA arg.
(DEFUN set-swapin-quantum-of-area (area &optional (swapin-quantum 3.))
  (LET ((area-number (IF (NUMBERP area) area (SYMBOL-VALUE area))))
    (SETF (AREF #'area-region-bits area-number)
	  (DPB swapin-quantum 
	       %%region-swapin-quantum
	       (AREF #'area-region-bits area-number)))
    (DO ((region (AREF #'area-region-list area-number)
		 (AREF #'region-list-thread region)))
	((MINUSP region))
      (SETF (AREF #'region-bits region)
	    (DPB swapin-quantum 
		 %%region-swapin-quantum
		 (AREF #'region-bits region))))))

(DEFUN set-all-swapin-quanta (&optional (swapin-quantum 3.))
  (dolist (area (MEMBER first-non-fixed-area-name area-list :test #'EQ))
    (set-swapin-quantum-of-area area swapin-quantum)))

;;AB 8/5/87.  New, for [SPR 6152]
(DEFUN set-area-region-size (area &optional (num-quanta 1))
  (LET ((area-number (IF (NUMBERP area) area (SYMBOL-VALUE area))))
    (SETF (AREF #'area-region-size area-number)
	  (* num-quanta %address-space-quantum-size))))

;;AB 8/5/87.  New, for [SPR 6152]
(DEFUN set-all-area-region-sizes (&optional (num-quanta 1))
  (dolist (area (MEMBER first-non-fixed-area-name area-list :test #'EQ))
    (set-area-region-size area num-quanta)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;; Region attributes, predicates, etc
;;;

(PROCLAIM '(inline region-static-p))
(DEFUN region-static-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is currently a static region."
  (= (LDB %%region-space-type bits) %region-space-static))

(PROCLAIM '(inline %set-region-static))
(DEFUN %set-region-static (region &optional (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(%LOGDPB %region-space-static
		 %%region-space-type
		 bits)))

(DEFUN region-newspace-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a newspace region."
  (= (LDB %%region-space-type bits) %region-space-new)
  )

(PROCLAIM '(inline %set-region-new))
(DEFUN %set-region-new (region &optional (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(%LOGDPB %region-space-new
		 %%region-space-type
		 bits)))

(PROCLAIM '(inline region-free-p))
(DEFUN region-free-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a free region."
  (= (LDB %%region-space-type bits) %region-space-free))

(PROCLAIM '(inline %set-region-free))
(DEFUN %set-region-free (region &optional (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(%LOGDPB %region-space-free
		 %%region-space-type
		 bits)))

(PROCLAIM '(inline region-oldspace-p))
(DEFUN region-oldspace-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is an oldspace region type."
  (= (LDB %%region-space-type bits) %region-space-old))

(PROCLAIM '(inline region-copyspace-p))
(DEFUN region-copyspace-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a copyspace region."
  (= (LDB %%region-space-type bits) %region-space-copy))

(DEFUN region-dynamic-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is dynamic (ie, either newspace or copyspace)"
  (OR (region-newspace-p region bits)
      (region-copyspace-p region bits))
  )

(PROCLAIM '(inline region-fixed-p))
(DEFUN region-fixed-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a fixed region."
  (= (LDB %%region-space-type bits) %region-space-fixed))

(PROCLAIM '(inline region-train-p))
(DEFUN region-train-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a training region of oldspace."
  (= (LDB %%region-space-type bits) %region-space-train))

(PROCLAIM '(inline region-extra-pld-p))
(DEFUN region-extra-pdl-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is an extra-pdl region."
  (= (LDB %%region-space-type bits) %region-space-extra-pdl))

(PROCLAIM '(inline region-oldspace-a-p))
(DEFUN region-oldspace-a-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is an oldspace-a region type."
  (= (LDB %%region-space-type bits) %region-space-old-a))

(PROCLAIM '(inline region-entry-p))
(DEFUN region-entry-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is an entry region type."
  (= (LDB %%region-space-type bits) %region-space-entry))

(PROCLAIM '(inline region-train-a-p))
(DEFUN region-train-a-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is an train-a region type."
  (= (LDB %%region-space-type bits) %region-space-train-a))


(PROCLAIM '(notinline region-space-type))
(DEFUN region-space-type (region &optional (bits (AREF #'region-bits region)))
  (SELECT (LDB %%region-space-type bits)
    (%region-space-free :FREE)
    (%region-space-new :NEW)
    ((%region-space-static %REGION-SPACE-ENTRY) :STATIC)
    ((%region-space-old %REGION-SPACE-OLD-A) :OLD)
    (%region-space-copy :COPY)
    ((%region-space-train %REGION-SPACE-TRAIN-A) :TRAIN)
    ((%region-space-fixed %region-space-extra-pdl) :FIXED)))


(PROCLAIM '(inline region-space))
(DEFUN region-space (region &optional (bits (AREF #'region-bits region)))
  (LDB %%region-space-type bits))

(PROCLAIM '(inline %set-region-space-type))
(DEFUN %set-region-space-type (region &optional (type-number %region-space-new)
			                        (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB type-number %%region-space-type bits)))


;;; Region representation type 

(PROCLAIM '(inline list-region-p))
(DEFUN region-list-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a region containing only lists."
  (= (LDB %%region-representation-type bits) %region-representation-type-list))

(PROCLAIM '(inline structure-region-p))
(DEFUN region-structure-p (region &optional (bits (AREF #'region-bits region)))
  "Returns T if REGION is a region contains non-list objects (ie, general structures)."
  (= (LDB %%region-representation-type bits) %region-representation-type-structure))

(DEFF structure-region-p 'region-structure-p)
(DEFF list-region-p 'region-list-p)

(DEFUN region-representation-type (region &optional (bits (AREF #'region-bits region)))
  (SELECT (LDB %%region-representation-type bits)
    (%region-representation-type-list :LIST)
    (%region-representation-type-structure :STRUCTURE))
  )

(PROCLAIM '(inline region-representation))
(DEFUN region-representation (region &optional (bits (AREF #'region-bits region)))
  (LDB %%region-representation-type bits))

(PROCLAIM '(inline %set-region-representation-type))
(DEFUN %set-region-representation-type (region &optional
					(representation-type %region-representation-type-structure)
					(bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB representation-type
	     %%region-representation-type
	     bits)))
 

;;; Region scavenge bit

(PROCLAIM '(inline region-scavenge-enabled))
(DEFUN region-scavenge-enabled (region &optional (bits (AREF #'region-bits region)))
  "Returns T if scavenging is enabled in the region; else NIL."
  (LDB-TEST %%region-scavenge-enable bits))

(PROCLAIM '(inline %set-region-scavenge-enable))
(DEFUN %set-region-scavenge-enable (region &optional (enabled nil)
				                     (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB (IF enabled 1 0)
	     %%region-scavenge-enable
	     bits)))


;;; Region map status 

(PROCLAIM '(inline region-pdl-buffer-p))
(DEFUN region-pdl-buffer-p (region &optional (bits (AREF #'region-bits region)))
  (= (LDB %%region-map-status-bits bits)
     %PHT-Map-Status-PDL-Buffer))

(PROCLAIM '(inline region-mar-set-p))
(DEFUN region-mar-set-p (region &optional (bits (AREF #'region-bits region)))
  (= (LDB %%region-map-status-bits bits)
     %PHT-Map-Status-MAR ))

(DEFUN region-map-status (region &optional (bits (AREF #'region-bits region)))
  (SELECT (LDB %%region-map-status-bits bits)
    (%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))
  )

(PROCLAIM '(inline %set-region-map-status))
(DEFUN %set-region-map-status (region &optional (status-code %PHT-Map-Status-Read-Write-First)
			                        (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB status-code
	     %%region-map-status-bits
	     bits)))


;;; Region access bits

(DEFUN region-map-access (region &optional (bits (AREF #'region-bits region)))
  (SELECT (LDB %%region-map-access-bits bits)
    ((0 1) :NONE)
    (%PHT-Map-Access-Read-Only :read-only)
    (%PHT-Map-Access-Read-Write :read-write))
  )

(PROCLAIM '(inline %set-region-map-access))
(DEFUN %set-region-map-access (region &optional (status-code %PHT-Map-Access-Read-Write)
			                        (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB status-code
	     %%region-map-access-bits
	     bits)))


;;; Region oldspace meta bit

(PROCLAIM '(inline region-oldspace-map-meta-bit))
(DEFUN region-oldspace-map-meta-bit (region &optional (bits (AREF #'region-bits region)))
  (LDB %%REGION-OLDSPACE-META-BIT bits))

(PROCLAIM '(inline region-really-oldspace-p))
(DEFUN region-really-oldspace-p (region &optional (bits (AREF #'region-bits region)))
  (= %Region-Meta-Bit-Oldspace
     (LDB %%Region-Oldspace-Meta-Bit bits)))

(PROCLAIM '(inline %set-region-oldspace-meta-bit))
(DEFUN %set-region-oldspace-meta-bit (region &optional (oldspace-p nil)
				                       (bits (AREF #'region-bits region)))
  (DPB (IF oldspace-p
	   %Region-Meta-Bit-Oldspace
	   %Region-Meta-Bit-Not-Oldspace)
       %%REGION-OLDSPACE-META-BIT
       bits))


;;; Region generation

(PROCLAIM '(inline region-generation))
(DEFUN region-generation (region &optional (bits (AREF #'region-bits region)))
  (LDB %%Region-generation bits))

(PROCLAIM '(inline region-generation-extra-pdl-p))
(DEFUN region-generation-extra-pdl-p (region &optional (bits (AREF #'region-bits region)))
  (LDB-TEST %%REGION-EXTRA-PDL-BIT bits)) 

(PROCLAIM '(inline %set-region-generation))
(DEFUN %set-region-generation (region &optional (generation-number %REGION-GEN-3)
			                        (bits (AREF #'region-bits region)))
  (CHECK-ARG generation-number
	     (AND (NUMBERP generation-number)
		  (<= -1 generation-number 3))
	     "a valid generation number")
  (SETF (AREF #'region-bits region)
	(DPB (IF (MINUSP generation-number)
		 %Region-Gen-Extra-Pdl
		 generation-number)
	     %%Region-All-Generation-Bits
	     bits)))


;;; Region volatility

(PROCLAIM '(inline region-volatility))
(DEFUN region-volatility (region &optional (bits (AREF #'region-bits region)))
  (LDB %%region-volatility bits))

(PROCLAIM '(inline region-volatility-type))
(DEFUN region-volatility-type (region &optional (bits (AREF #'region-bits region)))
  (SELECT (LDB %%region-volatility bits)
    (%VOL-POINT-TO-ANY :point-to-any)
    (%VOL-POINT-TO-1-OR-HIGHER  :point-to-1-or-higher)
    (%VOL-POINT-TO-2-OR-HIGHER  :point-to-2-or-higher)
    (%VOL-POINT-TO-OLDEST-ONLY  :point-to-oldest-only))
  )

(PROCLAIM '(inline %set-region-volatility))
(DEFUN %set-region-volatility (region &optional (volatility %VOL-POINT-TO-ANY)
			                        (bits (AREF #'region-bits region))) 
  (SETF (AREF #'region-bits region)
	(DPB volatility %%region-volatility bits)))


;;; Region volatility lock

(PROCLAIM '(inline region-volatility-locked-p))
(DEFUN region-volatility-locked-p (region &optional (bits (AREF #'region-bits region)))
  (LDB-TEST %%REGION-ZERO-VOLATILITY-LOCK bits))

(PROCLAIM '(inline %set-region-volatility-lock))
(DEFUN %set-region-volatility-lock (region &optional (locked nil)
				                     (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB (IF locked 1 0)
	     %%REGION-ZERO-VOLATILITY-LOCK
	     bits)))


;;; Region usage

(PROCLAIM '(inline region-usage))
(DEFUN region-usage (region &optional (bits (AREF #'region-bits region)))
  (LDB %%region-usage bits))

(PROCLAIM '(inline region-active-p))
(DEFUN region-active-p (region &optional (bits (AREF #'region-bits region)))
  (= %region-usage-active (LDB %%region-usage bits)))

(PROCLAIM '(inline region-inactive-p))
(DEFUN region-inactive-p (region &optional (bits (AREF #'region-bits region)))
  (/= %region-usage-active (LDB %%region-usage bits)))

(PROCLAIM '(inline %set-region-usage))
(DEFUN %set-region-usage (region &optional (quantum 0) (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB quantum %%REGION-usage bits)))


;; Region cache-inhibit (explorer 2 only)

(PROCLAIM '(inline region-cache-inhibit))
(DEFUN region-cache-inhibit-p (region &optional (bits (AREF #'region-bits region)))
  (LDB-TEST %%region-cache-inhibit bits))

(PROCLAIM '(inline %set-region-cache-inhibit))
(DEFUN %set-region-cache-inhibit (region &optional (inhibit-p t) (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB (IF inhibit-p 1 0)
	     %%REGION-Cache-Inhibit
	     bits)))


;;; Region swapin quantum

(PROCLAIM '(inline region-swapin-quantum))
(DEFUN region-swapin-quantum (region &optional (bits (AREF #'region-bits region)))
  (LDB %%REGION-SWAPIN-QUANTUM bits))

(PROCLAIM '(inline %set-region-swapin-quantum))
(DEFUN %set-region-swapin-quantum (region &optional (quantum 0) (bits (AREF #'region-bits region)))
  (SETF (AREF #'region-bits region)
	(DPB quantum %%REGION-SWAPIN-QUANTUM bits)))


;;; Default region bits

;;AB 8/5/87.  Default swapin-quantum to 3 (8 pages).
(DEFUN %default-region-bits ()
  (%LOGDPB %PHT-Map-Status-Read-Write-First %%region-map-status-bits
       (%LOGDPB %region-representation-type-structure %%region-representation-type 
	    (%LOGDPB %Region-Meta-Bit-Not-Oldspace %%REGION-OLDSPACE-META-BIT
		 (%LOGDPB %REGION-GEN-3 %%Region-All-Generation-Bits
		      (%LOGDPB %region-space-new %%region-space-type 
			   (%LOGDPB 0 %%region-scavenge-enable 
				(%LOGDPB %VOL-POINT-TO-ANY %%region-volatility 
				     (%LOGDPB 0 %%REGION-ZERO-VOLATILITY-LOCK
					  (%LOGDPB %region-usage-active %%REGION-USAGE
					       (%LOGDPB 0 %%REGION-CACHE-INHIBIT
						    (%LOGDPB 3 %%REGION-SWAPIN-QUANTUM 0)))))))))))
  )


;;; Misc

(DEFUN number-of-free-regions ()
  "Returns number of regions currently in the free region list."
  (LOOP FOR region FROM 0 BELOW Size-Of-Region-Arrays
	COUNT (region-free-p region (AREF #'region-bits region)) INTO total
	FINALLY (RETURN total)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Virtual Address hacking
;;;

(DEFPARAMETER *max-address-space-size* (1+ (byte-mask %%q-pointer)))

(DEFVAR *max-virtual-address* (convert-to-unsigned (set-io-space-virtual-address)))

(DEFUN find-max-virtual-address ()
  (DECLARE (SPECIAL *io-space-virtual-address*))
  (SETQ *max-virtual-address*
	(convert-to-unsigned *io-space-virtual-address*)))


(PROCLAIM '(inline a-memory-address-p))
(DEFUN a-memory-address-p (ptr)
  "Returns non-NIL if PTR is in A-Memory virtual memory."
  (AND (%pointer<= a-memory-virtual-address ptr)
       (%pointer<= ptr -1)))

(PROCLAIM '(inline io-space-address-p))
(DEFUN io-space-address-p (ptr)
  "Returns non-NIL if PTR is in IO-Space virtual memory."
  (DECLARE (SPECIAL *io-space-virtual-address*))
  (AND (%pointer<= *io-space-virtual-address* ptr)
       (%pointer<= ptr (%POINTER-DIFFERENCE a-memory-virtual-address 1))))

(PROCLAIM '(inline perm-wired-address-p))
(DEFUN perm-wired-address-p (ptr)
  "Returns T if address PTR is in assigned to a permanently-wired system area.
This does NOT necessarily mean the address is allocated to an object."
  (%pointer< ptr (AREF #'region-origin (SYMBOL-VALUE first-non-fixed-wired-area-name))))


(DEFUN pointer-valid-p (pointer)
  "Returns non-NIL if the pointer POINTER is valid (ie, is within the
allocated portion of an assigned region or is in io-space or a-memory).
Otherwise returns NIL."
  (DECLARE (inline a-memory-address-p io-space-address-p))
  (LET ((region (%REGION-NUMBER pointer)))
    (OR 
      (AND region
	   (%pointer< pointer
		      (%POINTER-PLUS (AREF #'region-origin region)
				     (AREF #'region-free-pointer region))))
      (a-memory-address-p pointer)
      (io-space-address-p pointer))
    ))


;; Used by disk-save

(DEFUN va-valid-p (va)
  "Returns non-NIL if virtual address VA is valid (ie, is within the
allocated portion of an assigned region); otherwise returns NIL.
  VA can be a fixnum or a bignum."
  (DECLARE (INLINE convert-to-unsigned convert-to-signed))
  (LET ((region (%REGION-NUMBER (convert-to-signed va))))
    (AND region	(< region Size-Of-Region-Arrays)
	 (< (convert-to-unsigned va)
	    (+ (convert-to-unsigned (AREF #'region-origin region))
	       (convert-to-unsigned (AREF #'region-free-pointer region)))))
    ))



;;;
;;; GC Inlines, Macros
;;;

(DEFVAR inhibit-gc-flips nil
  "Non-NIL prevents flipping from happening.  See the macro INHIBIT-GC-FLIPS.")

;;; 8/3/88 clm - a problem was occurring where the variable inhibit-gc-flips
;;; was being reset to a killed process, thus preventing flips from ever occurring.
;;; the problem was in the way we maintained the variable.  now if there are more
;;; than one process calling inhibit-gc-flips, we keep a list, then as each process
;;; ends we remove it from that list.
(defmacro inhibit-gc-flips (&body body)
  "Execute the BODY making sure no GC flip happens during it."
  `(unwind-protect
       (progn
	 (without-interrupts
	   (if inhibit-gc-flips
	       (if (listp  inhibit-gc-flips)
		   (push current-process inhibit-gc-flips)
		   (setq inhibit-gc-flips (list  current-process inhibit-gc-flips)))
	       (setq  inhibit-gc-flips current-process) ))
	 . ,body)
     (without-interrupts
       (setq inhibit-gc-flips
	     (if (consp inhibit-gc-flips)
		 (delete current-process inhibit-gc-flips :count 1)
		 nil)))))