LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031541. :SYSTEM-TYPE :LOGICAL :VERSION 5. :TYPE "LISP" :NAME "STORAGE-INTERNALS" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758657531. :AUTHOR "REL3" :LENGTH-IN-BYTES 17579. :LENGTH-IN-BLOCKS 18. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    ;;; -*- Package:SYSTEM-INTERNALS; Mode:Common-LISP; Base:8; Cold-load: T -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;** (c) Copyright 1980 Massachusetts Institute of Technology **;;; Edit History;;;                   Patch;;;   Date    Author  Number   Description;;;--------------------------------------------------------------------;;; 01-15-86   ab       --     Common Lisp conversion for VM2.;;;                              Most of these functions formerly lived in QMISC.;;;                            Functions converted:  %pointerp, %pointer-type-p,;;;                              %p-contents-safe-p, %p-safe-contents-offset;;;                            Changed list of numbers (generated by #. macro);;;                              to list of symbols in following functions to;;;                              work around VM2 integration problem with #. :;;;                              %pointerp, %pointer-type-p, %p-contents-safe-p,;;;                              %p-safe-contents-offset.;;;                            Eliminated use of #. macro in location-boundp;;;                              and cdr-location-force.  Fixed escaping also.;;;                            System patches integrated: ;;;                              2-36 (follow-structure-forwarding);;; 08-13-86   ab              Changed name to STORAGE-INTERNALS under;;;                              MEMORY-MANAGEMENT directory.;;; 08-14-86   ab              Moved Return-Storage here.  Also LOCATIVES file;;;                              and stuff from LOW-LEVEL-INTERNALS.;;; 10-27-86   ab              Made sure %Pointerp, %P-Contents-Safe-P, %Pointer-Type-P;;;                              will work properly in #-elroy. ;;; 10-27-86   ab              Changes for TGC support:;;;                              o Added %p-<field>-offset & %p-store-<field>-offset;;;                                functions.;;;                              o Change to Structure-Forward.;;;                              o Changes to %P-Pointerp-Offset and %P-Safe-Contents-Offset.;;;                            All of these changes can be made in the absence of TGC.;;; 11-11-86   ab              Moved COPY-OBJECT and COPY-OBJECT-TREE here from ARRAYS.;;;                              Fixed for TGC.;;; 01-11-86   ab              Change DTP-Unused-28 to DTP-GC-Young-Pointer;;; 01-15-87   ab              Move Return-Storage to AREAS.;;; 03-10-87   pad             Deff'ed copy to copy-object for next edition of Steele.;;; 03-19-87   ab              Fixed %P-Safe-Contents-Offset not to use a self reference;;;                              pointer as a locative.;;; 03-26-87   ab              Re-introduce read-time EVALs since now safe. Use CASE for efficiency.;;;                              Make %pointer-type-p return t for GC-Young-Pointer.;;;;;; Pointer hacking routines;;;(DEFUN %Pointerp (x)  "T if X points to storage; NIL if it is an immediate quantity."  (CASE (%data-type x)    (#-elroy     (#.DTP-FIX #.DTP-SMALL-FLONUM #.DTP-U-ENTRY #.DTP-CHARACTER)     #+elroy     (#.DTP-Fix #.DTP-Short-Float #.DTP-U-Entry #.DTP-Character)     nil)    (otherwise t)))    (DEFUN %Pointer-Type-P (data-type-code)  "T if DATA-TYPE-CODE is a the code for a data type that points to storage."  (CASE data-type-code    (#-elroy     (#.DTP-FIX #.DTP-SMALL-FLONUM #.DTP-U-ENTRY #.DTP-CHARACTER      #.DTP-TRAP #.DTP-SELF-REF-POINTER #.DTP-HEADER #.DTP-ARRAY-HEADER      #.DTP-fef-header #.DTP-free)     #+elroy     (#.DTP-Fix #.DTP-Short-Float #.DTP-U-Entry #.DTP-Character      #.DTP-Trap #.DTP-Self-Ref-Pointer #.DTP-Header #.DTP-Array-Header #.DTP-FEF-Header      #.DTP-Free #.DTP-Ones-Trap)     NIL)    (otherwise t)))(DEFUN %P-Pointerp (pointer)  "T if the word POINTER points to contains a data type that points to some storage.This includes various header and forwarding data typeswhich point to storage."  (%POINTER-TYPE-P (%P-DATA-TYPE pointer)))(DEFUN %P-Pointerp-Offset (pointer offset)  "T if the word POINTER+OFFSET points to contains a data type that points to some storage.This includes various header and forwarding data typeswhich point to storage."  (%POINTER-TYPE-P (%P-DATA-TYPE-OFFSET pointer offset)))(DEFUN %P-Contents-Safe-P (pointer)  "T if the word POINTER points to contains data safe to read out.It will be NIL if the word contains a forwarding pointer or a header."  (CASE (%P-DATA-TYPE pointer)    (#-elroy     (#.DTP-SYMBOL #.DTP-FIX #.DTP-EXTENDED-NUMBER #.DTP-LOCATIVE #.DTP-LIST      #.DTP-U-ENTRY #.DTP-FEF-POINTER #.DTP-ARRAY-POINTER      #.DTP-STACK-GROUP #.DTP-CLOSURE #.DTP-SMALL-FLONUM #.DTP-SELECT-METHOD      #.DTP-INSTANCE #.DTP-ENTITY #.DTP-STACK-CLOSURE #.DTP-CHARACTER      #.DTP-single-float)     #+elroy     (#.DTP-Symbol #.DTP-Fix #.DTP-Extended-Number #.DTP-Locative #.DTP-List      #.DTP-U-Entry #.DTP-Function #.DTP-Array      #.DTP-Stack-List  #.DTP-Lexical-Closure      #.DTP-Stack-Group #.DTP-Closure      #.DTP-Single-Float #.DTP-Short-Float      #.DTP-Instance #.DTP-Character)     t)    (otherwise nil)));;(DEFUN tester (old-fn new-fn);;  (DOTIMES (i 32.);;    (LET ((old (FUNCALL old-fn i));;  (new (FUNCALL new-fn i)));;      (UNLESS (EQ old new);;(FORMAT t "~%DTP ~s:  old ~a new ~a";;(Q-DATA-TYPES i) old new)))));;3-19-87 -ab.  Remove DTP-Self-Ref-Pointer from list of "forwarding pointers".  Should NEVER;;consider a SRP as a locative!! ;;; The following definition is only used by FEF-EQUAL in the file SYS:KERNEL;FLAVOR(DEFUN %P-Safe-Contents-Offset (pointer offset)  (CASE (%P-DATA-TYPE-OFFSET pointer offset)    ((#.DTP-External-Value-Cell-Pointer      #.DTP-One-Q-Forward)     (%P-CONTENTS-AS-LOCATIVE-OFFSET pointer offset))    (otherwise     (%P-CONTENTS-OFFSET pointer offset))));;;;;; Forwarding, Structure & Object hacking;;;(Defun Find-Structure-Header (pointer)  "Returns the structure into which POINTER points.  Follows structure forwarding."  (follow-structure-forwarding (%find-structure-header pointer)))(Defun Find-Structure-Leader (pointer)  "Returns the structure into which POINTER points, except that if structure is an array with a leader,returns a locative pointer to the leader-header.Follows structure forwarding."  (follow-structure-forwarding (%find-structure-leader pointer)))(Defun Structure-Boxed-Size (object)  "Returns the number of boxed Q's in OBJECT.  Follows structure forwarding."  (%structure-boxed-size (follow-structure-forwarding object)))(Defun Structure-Total-Size (object)  "Returns the total number of words occupied by the representation of OBJECT.Follows structure forwarding."  (%structure-total-size (follow-structure-forwarding object)))(DEFUN Follow-Structure-Forwarding (x)  "Get the final structure this one may be forwarded to.Given a pointer to a structure, if it has been forwarded by STRUCTURE-FORWARD,ADJUST-ARRAY-SIZE, or the like, this will return the target structure,following any number of levels of forwarding."  ;; PHD 11/13/85 changed from recursive to iterative.  (WITHOUT-INTERRUPTS     (LOOP        (COND ((= (%P-DATA-TYPE x) DTP-Header-Forward)     (SETQ x       (%MAKE-POINTER (%DATA-TYPE x) (%P-CONTENTS-AS-LOCATIVE x))))    ((= (%P-DATA-TYPE x) DTP-Body-Forward)     (LET ((hdrp (%P-CONTENTS-AS-LOCATIVE x)))       (SETQ x (%MAKE-POINTER-OFFSET (%DATA-TYPE x)       (%P-CONTENTS-AS-LOCATIVE hdrp)       (%POINTER-DIFFERENCE x hdrp)))))  (t (RETURN x))))));; The argument must really be a structure, not a locative into the middle;; of something, and must not be in list space.  We store DTP-HEADER-FORWARD;; and DTP-BODY-FORWARDs from the old instance to the new instance, and return the old.(DEFUN STRUCTURE-FORWARD (OLD NEW &AUX SIZE BASE-WORD NUMBER-BOXED)  "Forward the entire contents of the OLD structure to the NEW one."  (setq old (follow-structure-forwarding old))  (OR (= (%DATA-TYPE OLD) (%DATA-TYPE NEW))      (FERROR NIL "~S and ~S seem incompatible" OLD NEW))  (OR (= (LDB %%REGION-REPRESENTATION-TYPE (REGION-BITS (%REGION-NUMBER OLD))) %REGION-REPRESENTATION-TYPE-STRUCTURE)      (FERROR NIL "~S is not in a structure region" OLD))  (WITHOUT-INTERRUPTS;Don't let anything move while in inconsistent state    (SETQ BASE-WORD (%FIND-STRUCTURE-LEADER OLD))    ;; Must fill even formerly unboxed words with body-forwards    ;; since that is how scavenger will tell how big the structure was.    (SETQ SIZE (%STRUCTURE-TOTAL-SIZE BASE-WORD))    ;; Store NIL in old boxed Q's so TGC can see no pointers.    (WHEN (> (SETQ number-boxed (%STRUCTURE-BOXED-SIZE base-word)) 0)      (%P-STORE-CONTENTS base-word nil)      (%BLT-TYPED base-word  (%MAKE-POINTER-OFFSET Dtp-Locative base-word 1)  (1- number-boxed)  1))    ;; Note that the body-forwards all point at the old structure's header.    (%P-STORE-TAG-AND-POINTER BASE-WORD DTP-BODY-FORWARD OLD)    (%BLT BASE-WORD (%MAKE-POINTER-OFFSET DTP-FIX BASE-WORD 1) (1- SIZE) 1)    ;; Force a DTP-Fix into the header slot so it is    ;; legally boxed before the store-tag-and-pointer    (%P-DPB DTP-FIX %%Q-DATA-TYPE OLD)    ;; in which we place a header-forward to the new structure.    (%P-STORE-TAG-AND-POINTER OLD DTP-HEADER-FORWARD NEW)    (SETQ AR-1-ARRAY-POINTER-1 NIL)    (SETQ AR-1-ARRAY-POINTER-2 NIL)    OLD))(DEFUN Forward-Value-Cell (from-symbol to-symbol)  "Make FROM-SYMBOL a synonym for TO-SYMBOL when used as a special variable.Does not declare either symbol special, however.Do not do this within a special binding of FROM-SYMBOL;it would get undone by unbinding FROM-SYMBOL.Only call this at times when FROM-SYMBOL has its global binding."  (CHECK-ARG from-symbol symbolp "a symbol")  (CHECK-ARG to-symbol symbolp "a symbol")  (AND (EQ from-symbol to-symbol)       (FERROR nil "Forwarding symbol's value to itself"))  (%P-STORE-TAG-AND-POINTER (VALUE-CELL-LOCATION from-symbol)    DTP-One-Q-Forward    (VALUE-CELL-LOCATION to-symbol)));; Like FOLLOW-STRUCTURE-FORWARDING(DEFUN Follow-Cell-Forwarding (loc evcp-p)  "Given a locative pointer to a cell, return a locative to where it is forwarded to.The value will equal the argument if there is no forwarding.EVCP-P says whether to follow external-value-cell pointersas well as other kinds of forwarding."  (DO () (nil)    (SELECT (%P-DATA-TYPE loc)      ((DTP-Header-Forward DTP-Body-Forward)       (SETQ loc (FOLLOW-STRUCTURE-FORWARDING loc)))      (DTP-One-Q-Forward       (SETQ loc (%MAKE-POINTER (%DATA-TYPE loc) (%P-CONTENTS-AS-LOCATIVE loc))))      (DTP-External-Value-Cell-Pointer       (OR evcp-p (RETURN loc))       (SETQ loc (%MAKE-POINTER (%DATA-TYPE loc) (%P-CONTENTS-AS-LOCATIVE loc))))      (otherwise (RETURN loc)))));; Given an EVCP (with a data type of DTP-LOCATIVE, presumably),;; return the symbol or function spec whose value or function cell it points to,;; and a keyword saying what cell is pointed to.;; The keyword is a global function name which, applied to the first value,;; would yield the contents of the cell.(DEFUN Decode-Evcp (ptr-as-locative &aux ptr cell offset)  (SETQ ptr (%FIND-STRUCTURE-HEADER ptr-as-locative)offset (%POINTER-DIFFERENCE ptr-as-locative ptr))  (COND ((SYMBOLP ptr) (SETQ cell (NTH offset '(%p-contents symeval fdefinition plist symbol-package))))((CONSP ptr) (SETQ ptr (CAR ptr) cell 'fdefinition))(t (SETQ cell 'car)))  (VALUES ptr cell));;PAD 3/10/87 Added for the next Steele book.(deff copy 'copy-object)(DEFUN Copy-Object (object)  "Copy any kind of object that occupies memory, except stack groups.The copy has the same contents as the original.  Fixnums and other immediatetypes are simply returned as supplied."  (TYPECASE object    ((OR fixnum character symbol short-float microcode-function locative)     object)    (cons (COPY-LIST object))    (closure (COPY-CLOSURE object))    (stack-group (FERROR nil "It is not possible to copy a stack group"))    (t     (IF (AND (ARRAYP object)      (= (%STRUCTURE-TOTAL-SIZE (FOLLOW-STRUCTURE-FORWARDING object)) 1)) (MAKE-ARRAY 0 :type (ARRAY-TYPE object)) ;; else (LET* ((real-object (FOLLOW-STRUCTURE-FORWARDING object))(leader (%FIND-STRUCTURE-LEADER real-object))(total (%STRUCTURE-TOTAL-SIZE leader))(boxed (%STRUCTURE-BOXED-SIZE leader))(new (%ALLOCATE-AND-INITIALIZE (%DATA-TYPE real-object)       (%P-DATA-TYPE leader)       (%P-POINTER leader)       0       default-cons-area       total)))   (%BLT-TYPED leader new boxed 1)   (WITHOUT-INTERRUPTS     (%BLT (%MAKE-POINTER-OFFSET Dtp-Locative leader boxed)   (%MAKE-POINTER-OFFSET Dtp-Locative new boxed)   (- total boxed) 1))   (%MAKE-POINTER-OFFSET (%DATA-TYPE real-object) new (%POINTER-DIFFERENCE real-object leader)))))));Copy an object, and the objects it points to, and ...(DEFUN copy-object-tree (object &optional temporary-areas-only depth)  "Copy all components of object for DEPTH levels.  Symbols, packages and stack groupswill not be copied.  If TEMPORARY-AREAS-ONLY is non-NIL, objects in non-temporary areas are left alone."  (IF (OR (MEMBER (%DATA-TYPE object) '(#.DTP-FIX #.DTP-U-ENTRY #.DTP-CHARACTER;ford  8-30-84#.DTP-SMALL-FLONUM #.DTP-LOCATIVE#.DTP-SYMBOL)  :test #'eq)  (TYPEP object 'package)  (AND temporary-areas-only       (NOT (AREA-TEMPORARY-P (%AREA-NUMBER object)))))      object      (LET* ((new (COPY-OBJECT object))     (leader (%FIND-STRUCTURE-LEADER new)))(DO ((i 0 (1+ i)))    ((= i (%STRUCTURE-BOXED-SIZE new)))  (COND ((MEMBER (%P-DATA-TYPE-OFFSET leader i) '(#.DTP-NULL #.DTP-HEADER #.DTP-ARRAY-HEADER #.DTP-INSTANCE-HEADER   #.DTP-FIX #.DTP-SELF-REF-POINTER   #.DTP-U-ENTRY #.DTP-SMALL-FLONUM #.DTP-LOCATIVE   #.DTP-SYMBOL #.DTP-ONE-Q-FORWARD   #.DTP-EXTERNAL-VALUE-CELL-POINTER   #.DTP-HEADER-FORWARD #.DTP-BODY-FORWARD) :test #'eq))(t (SETF (%P-CONTENTS-OFFSET leader i)       (IF (EQ depth 0)   nil   (COPY-OBJECT-TREE (%P-CONTENTS-OFFSET leader i) temporary-areas-only     (IF depth (1- depth))))))))new)));;;;;; Locatives;;;(DEFUN Location-Makunbound (location &optional variable-name)  "Cause the word LOCATION points to to be unbound.If LOCATION points to a symbol value cell, the symbol becomes unbound.VARIABLE-NAME is a value to put in the pointer field of the DTP-NULLvalue; it should be the variable or function-spec whose value,in some sense, LOCATION represents."  (CHECK-ARG location (OR (CONSP location) (LOCATIVEP location))     "a location (something to take CONTENTS of)")  (TYPECASE location    (LIST (location-makunbound (cdr-location-force location)))    (t     ;; Cell could be forwarded somewhere, e.g. into microcode memory     (DO ((loc location (%P-CONTENTS-AS-LOCATIVE loc))) ((/= (%P-DATA-TYPE loc) DTP-One-Q-Forward);; TGC  (without-interrupts (%p-store-data-type loc DTP-Null);; TGC      (%p-store-pointer loc (or variable-name location)))  (%p-store-data-type-and-pointer loc dtp-null (or variable-name location)))       ))  ))(DEFUN Location-Boundp (location)  "T if the contents of LOCATION is not \"unbound\"."  (CHECK-ARG location (OR (CONSP location) (LOCATIVEP location))     "a location (something to take CONTENTS of)")  (TYPECASE location    (list     ;; If the list has an explicit cdr-pointer, check its data type.     ;; Otherwise the answer is always T.     (SELECT (%P-CDR-CODE location)       (CDR-Normal (/= DTP-Null (%p-data-type-offset  (if (= (%P-DATA-TYPE location) DTP-Header-Forward)      (FOLLOW-STRUCTURE-FORWARDING location)      location)  1)))       (CDR-Error (FERROR NIL "Invalid CDR code in list at #o~O." (%POINTER location)))       (t t)))    (t     ;; Cell could be forwarded somewhere, e.g. into microcode memory     (do ((loc location (%P-CONTENTS-AS-LOCATIVE loc))) ((/= (%P-DATA-TYPE loc) DTP-One-Q-Forward)  (/= DTP-Null (%P-DATA-TYPE loc))))))) (Defun Cdr-Location-Force (list)  "Return a locative pointing at the place where the cdr pointer of a list cell is stored.This causes the list to be forwarded if it did not have an explicit cdr pointer."  (SELECT (%P-CDR-CODE list)    (CDR-Normal     (%MAKE-POINTER-OFFSET DTP-Locative   (IF (= (%P-DATA-TYPE list) DTP-Header-Forward)       (follow-structure-forwarding list)       list)   1))    (CDR-Error (FERROR nil "Invalid CDR code in list at #o~O." (%POINTER list)))    (t (WITHOUT-INTERRUPTS (RPLACD list (CDR list)))       (%MAKE-POINTER-OFFSET DTP-Locative (FOLLOW-STRUCTURE-FORWARDING list) 1))))(DEFUN Store-Conditional (location old new)  "If the cdr of LOCATION matches OLD, store NEW there instead."  (CHECK-ARG location (OR (CONSP location) (LOCATIVEP location))     "a location (something to take CONTENTS of)")  (AND (CONSP location) (SETQ location (cdr-location-force location)))  (%STORE-CONDITIONAL location old new))ecords are reshuffled."  (PROG (SORT-ARRAY-TEMP-V)(SETQ SORT-ARRAY-TEMP-V (MAKE-ARRAY GROUP-SIZE))(SORT-GROUPED-ARRAY-QUICK ARRAY 0 (- (ARRAY-ACTIVE-LENGTH ARRAY) GROUP-SIZE) GROUP-SIZE)(RETURN-STORAGE (PROG1 SORT-ARRAY-TEMP-V (SETQ SORT-ARRAY-TEMP-V NIL)))(RETURN ARRAY)))(DEFUN SORT-GROUPED-ARRAY-QUICK (A L R GS)  (COND     ((> L (- R (* GS SORT-QS-BREAKEVEN)));SEE IF SHOULD DO AN INSERTION SORT     (DO ((I (+ L GS) (+ I GS)));THIS CLAUSE ALSO APPLIES WHEN L>R ((> I R))       (DO ((C 0 (1+ C)))   ((= C GS));COPY GUY OUT (SETF (AREF SORT-ARRAY-TEMP-V C)        (AREF A (+ I C))))       (DO ((J (- I GS) (- J GS))    (X (AREF A I)))   ((OR (< J L) (NOT (FUNCALL SORT-LESSP-PREDICATE X (AREF A J))))    (DO ((C 0 (1+ C)))((= C GS));ON EXIT, STICK THAT ENTRY      (SETF (AREF A (+ J GS C))    (AREF SO