(FILECREATED "12-Aug-85 14:48:56" {ERIS}<LISPCORE>SOURCES>LLDATATYPE.;54 55231
changes to: (FNS \SET.STORAGE.STATE)
previous date: "11-Aug-85 15:20:27" {ERIS}<LISPCORE>SOURCES>LLDATATYPE.;53)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLDATATYPECOMS)
(RPAQQ LLDATATYPECOMS ((COMS (* Storage management)
(FNS NTYPX \TYPEMASK.UFN \TYPEP.UFN \ALLOCMDSPAGE \ALLOCPAGEBLOCK
\ALLOCVIRTUALPAGEBLOCK \MAPMDS \CHECKFORSTORAGEFULL
\DOSTORAGEFULLINTERRUPT \SET.STORAGE.STATE \SETTYPEMASK
\ADVANCE.STORAGE.STATE \NEW2PAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE
\ASSIGNDATATYPE1 \ASSIGN.DATATYPE \TYPENUMBERFROMNAME CREATECELL
\CREATECELL)
(INITVARS (CROSSCOMPILING)
(ASSIGNDATATYPE.ASKUSERWAIT 300)
(\STORAGEFULLSTATE)
(\STORAGEFULL))
(GLOBALVARS CROSSCOMPILING \STORAGEFULLSTATE \STORAGEFULL
\SYSTEMCACHEVARS \NxtArrayPage)
(SPECVARS ASSIGNDATATYPE.ASKUSERWAIT))
[COMS (* fetch and replace)
(FNS FETCHFIELD REPLACEFIELD BOXCOUNT CONSCOUNT \DTEST \TYPECHECK \DTEST.UFN
\TYPECHECK.UFN GETDESCRIPTORS GETFIELDSPECS NCREATE NCREATE2 REPLACEFIELDVAL
PUTBASEPTRX /REPLACEFIELD TYPENAME \TYPENAMEFROMNUMBER \BLOCKDATAP USERDATATYPES
DATATYPEP DATATYPES)
(P (MOVD? (QUOTE FETCHFIELD)
(QUOTE FFETCHFIELD))
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD))
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL]
[COMS (* STORAGE)
(FNS STORAGE STORAGE.LEFT \STORAGE.TYPE \STLINP \STMDSTYPE \STORAGE.HUNKTYPE)
(DECLARE: DONTCOPY (RECORDS HUNKSTAT))
(INITVARS (STORAGE.ARRAYSIZES (QUOTE (4 16 64 256 1024 4096 16384 NIL]
(DECLARE: (EXPORT (MACROS PUTBASEPTRX))
(EXPORT (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STRINGP \STACKP
\VMEMPAGEP \STREAM))
DONTCOPY
(EXPORT (RECORDS DTD)
(MACROS \GETDTD \TYPEMASK.UFN)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
(GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage
\MDSFREELISTPAGE \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL
\INTERRUPTSTATE \PENDINGINTERRUPT))
(CONSTANTS * STORAGEFULLSTATES)
(VARS DTDECLS))
[COMS (* for MAKEINIT)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(DECLARE: DONTCOPY
(ADDVARS (INITVALUES (\NxtMDSPage \FirstMDSPage)
(\LeastMDSPage \FirstMDSPage)
(\SecondMDSPage \DefaultSecondMDSPage)
(\SecondArrayPage \DefaultSecondArrayPage)
(\MDSFREELISTPAGE)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE
\INITMDSPAGE \ASSIGNDATATYPE1 \TYPENUMBERFROMNAME
\CREATECELL \NEW2PAGE)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(VARS DTDECLS))
(RDCOMS (FNS NTYPX TYPENAME))
(RD.SUBFNS (\ARRAYTYPENAME LAMBDA (X)
(QUOTE ARRAYP)))
(EXPANDMACROFNS \GETDTD PUTBASEPTRX REPLACEFIELD FETCHFIELD \GETBITS
\PUTBITS \TESTBITS GETBASEBITS PUTBASEBITS
FFETCHFIELD FREPLACEFIELD FREPLACEFIELDVAL
REPLACEFIELDVAL NCREATE)
(MKI.SUBFNS (\GCDISABLED . NILL)
(CREATECELL . I.\CREATECELL)
(\CHECKFORSTORAGEFULL . NILL)))
EVAL@COMPILE
(ADDVARS (DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES]
(LOCALVARS . T)
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
DTDECLARE))))
(* Storage management)
(DEFINEQ
(NTYPX
(LAMBDA (X) (* JonL "10-Nov-84 21:51")
(* usually done in microcode -
this def used by MAKEINIT too)
(LOGAND (\GETBASE \MDSTypeTable (FOLDLO (fetch (POINTER PAGE#) of X)
(CONSTANT (IQUOTIENT \MDSIncrement WORDSPERPAGE))))
\TT.TYPEMASK)))
(\TYPEMASK.UFN
(LAMBDA (X N) (* lmm "22-Mar-85 16:37") (if (NEQ 0 (LOGAND N (LRSH (\GETBASE \MDSTypeTable (FOLDLO (
fetch (POINTER PAGE#) of X) (CONSTANT (IQUOTIENT \MDSIncrement WORDSPERPAGE)))) 10Q))) then X)))
(\TYPEP.UFN
(LAMBDA (X N) (* lmm "22-Mar-85 10:07") (if (EQ (NTYPX X) N) then X)))
(\ALLOCMDSPAGE
[LAMBDA (TYP) (* lmm "27-Mar-85 09:16")
(PROG (VP VPTR)
BEG [COND
[(SETQ VP \MDSFREELISTPAGE)
(SETQ VPTR (create POINTER
PAGE# ← VP))
(PROG ((NXT (\GETBASEPTR VPTR 0)))
(COND
((AND NXT (NOT (SMALLP NXT)))
(\MP.ERROR \MP.BADMDSFREELIST "MDS Free Page link bad. ↑N to continue"
(PROG1 \MDSFREELISTPAGE (SETQ \MDSFREELISTPAGE)))
(GO BEG))
(T (SETQ \MDSFREELISTPAGE NXT]
(T (\CHECKFORSTORAGEFULL)
(SETQ VP \NxtMDSPage)
(SETQ \NxtMDSPage (IDIFFERENCE VP (FOLDLO \MDSIncrement PAGESPERSEGMENT)))
(* Allocates 2 MDS pages)
(SETQ VPTR (create POINTER
PAGE# ← VP))
(\NEWPAGE (\ADDBASE (\NEWPAGE VPTR)
WORDSPERPAGE]
(\MAKEMDSENTRY VP TYP)
(RETURN VPTR])
(\ALLOCPAGEBLOCK
(LAMBDA (NPAGES) (* ejs: "11-Aug-85 15:02")
(UNINTERRUPTABLY
(* * Allocates a continguous chunk of NPAGES pages. Currently there is no provision for giving them back.)
(LET ((RESULT (\ALLOCVIRTUALPAGEBLOCK NPAGES)))
(COND
(RESULT (to NPAGES as (BASE ← RESULT) by (\ADDBASE BASE WORDSPERPAGE)
do (* Allocate the new pages. Leave them having the
default type, namely type 0, don't refcnt)
(\NEWPAGE BASE))
RESULT))))))
(\ALLOCVIRTUALPAGEBLOCK
(LAMBDA (NPAGES) (* ejs: "11-Aug-85 13:49")
(UNINTERRUPTABLY
(* * Allocates a continguous chunk of NPAGES virtual pages. Does not actually allocate the memory, just removes them
from the set of pages that the allocator will use)
(PROG (FIRSTPAGE)
(COND
((ILEQ (IPLUS \NxtArrayPage \GUARDSTORAGEFULL)
(SETQ FIRSTPAGE (IDIFFERENCE (IPLUS \NxtMDSPage \PagesPerMDSUnit)
(SETQ NPAGES (CEIL NPAGES \PagesPerMDSUnit)))))
(* Plenty of space)
(SETQ \NxtMDSPage (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit)))
((NEQ (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
\SFS.SWITCHABLE)
(COND
((AND (EQ \STORAGEFULLSTATE \SFS.ARRAYSWITCHED)
(ILESSP (IPLUS \SecondArrayPage \GUARDSTORAGEFULL)
(SETQ FIRSTPAGE (IDIFFERENCE (IPLUS \SecondMDSPage \PagesPerMDSUnit)
NPAGES))))
(* Arrays have been switched, but we're still allocating MDS in low space. Just bump the variable that says where
MDS in high space will start)
(SETQ \SecondMDSPage (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit)))
(T (* Can't switch to the higher area)
(RETURN NIL))))
((ILESSP \NxtArrayPage FIRSTPAGE) (* Safe to go ahead anyway. We'll be pretty short of
space in the first 8mb, but it's switchable)
(SETQ \NxtMDSPage (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit)))
((ILESSP (IPLUS (SETQ FIRSTPAGE \SecondArrayPage)
NPAGES)
\SecondMDSPage) (* There is space in upper area.
So advance the pointer that says where array space will
start when we switch later on)
(SETQ \SecondArrayPage (IPLUS FIRSTPAGE NPAGES))
(replace (IFPAGE FullSpaceUsed) of \InterfacePage with 65535))
(T (RETURN NIL)))
(RETURN (create POINTER
PAGE# ← FIRSTPAGE))))))
(\MAPMDS
[LAMBDA (TYPE FN) (* bvm: "24-Apr-85 14:29")
(* * Applies FN to each virtual page number that is of type TYPE, or to all MDS pages if TYPE is NIL)
(OR (NULL TYPE)
(FIXP TYPE)
(SETQ TYPE (\TYPENUMBERFROMNAME TYPE)))
(CHECK (EQ (FOLDLO \MDSIncrement PAGESPERSEGMENT)
2)) (* I'd put this FOLDLO as the increment in the FOR
below, but the translation is atrocious)
(for I from 0 to (COND
((EQ \STORAGEFULLSTATE \SFS.FULLYSWITCHED)
1)
(T 0))
bind TYP
do
(* This is pretty grody because of the two different regions MDS can live in. Could just do everything from
(IMIN \NxtMDSPage \LeastMDSPage) to \MaxMDSPage but waste time on the stuff in between)
(for VP from (COND
((EQ I 0)
(IMIN \NxtMDSPage \LeastMDSPage))
(T \NxtMDSPage))
by 2 to (COND
((EQ I 0)
\DefaultSecondArrayPage)
(T \MaxMDSPage))
do
(* * We could just access \MDSTypeTable directly here, but since NTYPX should be ucoded, we benefit by
"modularizing" this access.)
(COND
((OR (EQ (SETQ TYP (NTYPX (create POINTER
PAGE# ← VP)))
TYPE)
(AND (NULL TYPE)
(NEQ TYP 0)
(NEQ TYP \SMALLP)))
(SPREADAPPLY* FN VP])
(\CHECKFORSTORAGEFULL
[LAMBDA (NPAGES) (* bvm: "24-Apr-85 15:00")
(DECLARE (GLOBALVARS \INTERRUPTSTATE \PENDINGINTERRUPT))
(* * Take appropriate action if storage is getting full. NPAGES is size of attempted allocation or NIL for MDS
requests. Complications here because array space and MDS grow toward each other in two separate areas: the first 8MB
of vmem and the remaining 24MB. Some machines cannot use the latter, so have to signal storage full when the first
fills up. Other machines have to know when to switch over. Array space usually gets switched to the high segment
before MDS, since MDS can eat the lo space in small increments all the way to the end -
Returns T if storage is ok, 0 if storage is ok but \NxtArrayPage changed, and NIL if storage is nearly full)
(UNINTERRUPTABLY
[PROG (PAGESLEFT)
(RETURN (COND
((OR (ILESSP (SETQ PAGESLEFT (IPLUS (IDIFFERENCE \NxtMDSPage \NxtArrayPage)
\PagesPerMDSUnit))
\GUARDSTORAGEFULL)
NPAGES)
(SELECTC (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
((LIST \SFS.NOTSWITCHABLE \SFS.FULLYSWITCHED)
(COND
((ILESSP PAGESLEFT 0)
(while T do (\MP.ERROR \MP.MDSFULL "Storage completely full")
))
((AND (ILEQ PAGESLEFT \GUARD1STORAGEFULL)
(NEQ \STORAGEFULL 0))
(SETQ \STORAGEFULL 0)
(\MP.ERROR \MP.MDSFULLWARNING
"Space getting VERY full. Please save and reload a.s.a.p. Type control-N to continue now."))
((NOT \STORAGEFULL)
(SETQ \STORAGEFULL T)
(* Note this is uninterruptable)
(replace STORAGEFULL of \INTERRUPTSTATE with T)
(SETQ \PENDINGINTERRUPT T)))
(\DORECLAIM)
NIL)
(\SFS.SWITCHABLE (* We have verified that we can use the full 32MB, but
haven't switched there yet)
(OR [COND
[(NULL NPAGES)
(* Want MDS)
(COND
((ILEQ PAGESLEFT 0)
(SETQ \LeastMDSPage \NxtArrayPage)
(SETQ \NxtMDSPage \SecondMDSPage)
(\ADVANCE.STORAGE.STATE
\SFS.FULLYSWITCHED)
(\ADVANCE.ARRAY.SEGMENTS
\SecondArrayPage]
(T
(* Want array space)
(COND
((IGREATERP NPAGES PAGESLEFT)
(* Have to switch array space over, but leave MDS to
fill the rest of the low pages)
(SETQ \LeastMDSPage \NxtArrayPage)
(\ADVANCE.STORAGE.STATE
\SFS.ARRAYSWITCHED)
(\ADVANCE.ARRAY.SEGMENTS
\SecondArrayPage]
T))
(\SFS.ARRAYSWITCHED (COND
((ILESSP \NxtMDSPage \LeastMDSPage)
(* Finally used up lo MDS, so switch over to hi)
(SETQ \NxtMDSPage \SecondMDSPage)
(\ADVANCE.STORAGE.STATE \SFS.FULLYSWITCHED)
T)
((AND NPAGES (IGEQ (IPLUS NPAGES
\GUARDSTORAGEFULL)
(IDIFFERENCE
\SecondMDSPage
\NxtArrayPage)))
(* MDS still in lo area, arrays in hi area, and we're asking for too big an array! Unlikely, but handle it as a
storage full case)
NIL)
(T T)))
(SHOULDNT])])
(\DOSTORAGEFULLINTERRUPT
[LAMBDA NIL (* bvm: "13-Feb-85 16:28")
(replace STORAGEFULL of \INTERRUPTSTATE with NIL)
(PROG ((HELPFLAG (QUOTE BREAK!)))
(LISPERROR "STORAGE FULL" (QUOTE "save your work & reload a.s.a.p.")
T])
(\SET.STORAGE.STATE
[LAMBDA NIL (* bvm: "12-Aug-85 14:46")
(PROG1 (SETQ \STORAGEFULLSTATE (COND
((SELECTC \MACHINETYPE
(\DOLPHIN NIL)
(\DANDELION (NEQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage)))
T) (* we can use high addresses)
\SFS.SWITCHABLE)
(T \SFS.NOTSWITCHABLE)))
(push \SYSTEMCACHEVARS (QUOTE \STORAGEFULLSTATE))
(* Want to recompute this if we come back from logout)
])
(\SETTYPEMASK
[LAMBDA (NTYPX BITS)
(PROG ((DTD (\GETDTD NTYPX)))
(change (fetch DTDTYPEENTRY of DTD)
(LOGOR DATUM BITS))
(\MAPMDS NTYPX (FUNCTION (LAMBDA (PAGE)
(\PUTBASE \MDSTypeTable (SETQ PAGE (FOLDLO PAGE (IQUOTIENT \MDSIncrement
WORDSPERPAGE)))
(LOGOR (\GETBASE \MDSTypeTable PAGE)
BITS])
(\ADVANCE.STORAGE.STATE
[LAMBDA (FLG) (* bvm: " 9-Jan-85 15:30")
(* Bump the flag that tells what state storage allocation is in with respect to the 8MB -- 32MB distinction.
Also remove flag from \SYSTEMCACHEVARS since it can no longer get recomputed)
(SETQ \STORAGEFULLSTATE FLG)
(replace (IFPAGE FullSpaceUsed) of \InterfacePage with 65535)
(SETQ \SYSTEMCACHEVARS (DREMOVE (QUOTE \STORAGEFULLSTATE)
\SYSTEMCACHEVARS])
(\NEW2PAGE
[LAMBDA (BASE) (* edited: " 6-SEP-83 16:05")
(\NEWPAGE (\ADDBASE (\NEWPAGE BASE)
WORDSPERPAGE])
(\MAKEMDSENTRY
[LAMBDA (VP V) (* lmm "30-DEC-81 17:39")
(\PUTBASE \MDSTypeTable (LRSH VP 1)
V])
(\GCTYPE
[LAMBDA (TYPENUM DTD) (* lmm "27-Mar-85 09:19")
(if (OR (EQ CDRCODING 0)
(NEQ TYPENUM \LISTP))
then
(* Note: it is possible, albeit unlikely, that \ALLOCMDSPAGE will eventually cause a CREATECELL to occur.
Hence, DTD:DTDFREE might possibly be non-NIL by the time we get back here, which is why it is included below)
(replace DTDFREE of DTD with (\INITMDSPAGE (\ALLOCMDSPAGE (fetch DTDTYPEENTRY
of DTD))
(fetch DTDSIZE of DTD)
(fetch DTDFREE of DTD])
(\INITMDSPAGE
[LAMBDA (BASE SIZE PREV) (* bvm: " 6-Jan-85 22:24")
(* * chain free list thru page at BASE of items SIZE long -
return last element)
(PROG ((SLOP (IREMAINDER WORDSPERPAGE SIZE))
NPAGES LIMIT)
(* * Refinement, mostly for benefit of hunking: try to keep objects from straddling page boundaries.
SLOP is how much is left over on a page after you have filled it with objects. If this SLOP is less than half the
size of an object, then you can start your next allocation at the beginning of the next page without any loss.
Thus, the algorithm here either allocates several pages individually, or treats the entire expanse as one big block
to slice up. Computation here assumes \MDSIncrement is 2 pages. Might want to have the AND test actually be a flag
in the DTD once and for all)
(COND
((AND (NEQ SLOP 0)
(ILESSP SLOP (LRSH SIZE 1))
(ILESSP SIZE WORDSPERPAGE)) (* Make everyone start at page boundaries.
Third condition needed for datatypes bigger than a
page)
(SETQ NPAGES (IQUOTIENT \MDSIncrement WORDSPERPAGE))
(SETQ LIMIT WORDSPERPAGE))
(T (SETQ NPAGES 1)
(SETQ LIMIT \MDSIncrement)))
(to NPAGES
do (for (DISP ← 0) while (ILEQ (add DISP SIZE)
LIMIT)
do (\PUTBASEPTR BASE 0 PREV)
(SETQ PREV BASE)
(SETQ BASE (\ADDBASE BASE SIZE)))
(SETQ BASE (\ADDBASE BASE SLOP)))
(RETURN PREV])
(\ASSIGNDATATYPE1
[LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS) (* jds "17-Apr-85 06:12")
(PROG ((NTYPX (\TYPENUMBERFROMNAME NAME))
DTD)
[COND
(NTYPX (* a datatype of this name already allocated)
(SETQ DTD (\GETDTD NTYPX))
(COND
((AND (EQUAL PTRFIELDS (fetch DTDPTRS of DTD))
(EQUAL SIZE (fetch DTDSIZE of DTD)))
(* has same shape, can reuse DTD)
(replace DTDDESCRS of DTD with DESCRIPTORS)
(replace DTDTYPESPECS of DTD with SPECS)
(RETURN NTYPX))
([OR (EQ CROSSCOMPILING T)
(AND CROSSCOMPILING (NEQ (QUOTE Y)
(ASKUSER 30 (SELECTQ CROSSCOMPILING
(Y (QUOTE Y))
(QUOTE N))
(LIST (COND
(SIZE "OK TO REDECLARE DATATYPE ")
(T "OK to deallocate DATATYPE "))
NAME]
(* don't do it if cross compiling)
(RETURN NTYPX))
((IGREATERP NTYPX \MaxSysTypeNum) (* If it isn't a system datatype, mark it deallocated.)
(UNINTERRUPTABLY
(replace DTDNAME of DTD with (\ATOMPNAMEINDEX (QUOTE **DEALLOC**)))
(replace DTDDESCRS of DTD with NIL)
(replace DTDTYPESPECS of DTD with NIL)))
(T (* can't mess with sys types)
(ERROR "ILLEGAL DATA TYPE" NAME]
(* If we get this far, we're about to create a for-real new datatype (we may have deallocated the old version of
this one...))
(COND
((NOT SIZE) (* only called to deallocate old datatype)
)
(T (COND
((EQ \MaxTypeNumber \EndTypeNumber)
(LISPERROR "DATA TYPES FULL" NAME)))
(UNINTERRUPTABLY
(SETQ NTYPX (add \MaxTypeNumber 1)) (* Bump the global count of types assigned, and grab
the latest.)
(* Thus assuring a NEW type number when we redeclare an
existing type.)
(SETQ DTD (\GETDTD NTYPX)) (* Build a new DTD for it.)
(COND
((IGREATERP (IPLUS (fetch WORDINPAGE of DTD)
\DTDSize)
(CONSTANT (SUB1 WORDSPERPAGE)))
(* if this is the last one which would fit on a page,
create a new page)
(\NEWPAGE (\ADDBASE DTD \DTDSize)
T)))
(replace DTDNAME of DTD with (\ATOMPNAMEINDEX NAME))
(* Remember the type name)
(COND
((NEQ SIZE 0) (* If the datum takes up any space, remember what it
looks like inside)
(replace DTDSIZE of DTD with SIZE)
(replace DTDDESCRS of DTD with (COPY DESCRIPTORS))
(replace DTDTYPESPECS of DTD with (COPY SPECS))
(replace DTDPTRS of DTD with PTRFIELDS)
(replace DTDTYPEENTRY of DTD with NTYPX)
(* The type-masked type#, for fast type checking)
(\GCTYPE NTYPX DTD) (* Create a couple of empty pages worth of the
datatype)
)))
(RETURN NTYPX])
(\ASSIGN.DATATYPE
[LAMBDA (TYPENAME DLIST FIELDSPECS OFFSET) (* lmm "13-Mar-85 16:27")
(COND
(TYPENAME (SETTOPVAL (\TYPEGLOBALVARIABLE TYPENAME)
(ASSIGNDATATYPE TYPENAME DLIST OFFSET FIELDSPECS
(for P in DLIST when (SELECTQ (fetch fdType of P)
((POINTER FULLPOINTER)
T)
NIL)
collect (fetch fdOffset of P])
(\TYPENUMBERFROMNAME
[LAMBDA (TYPE) (* lmm "13-FEB-83 14:09")
(AND TYPE (NEQ TYPE (QUOTE **DEALLOC**))
(for I from 1 to \MaxTypeNumber do (COND
((EQ (\ATOMPNAMEINDEX TYPE)
(fetch DTDNAME of (\GETDTD I)))
(RETURN I])
(CREATECELL
[LAMBDA (TYP) (* lmm "10-DEC-82 15:49")
(\CREATECELL TYP])
(\CREATECELL
[LAMBDA (TYP) (* edited: "16-Dec-84 19:55")
(if (AND (NEQ CDRCODING 0)
(EQ TYP \LISTP))
then (RAID "CREATECELL \LISTP"))
(UNINTERRUPTABLY
(PROG ((DTD (\GETDTD TYP))
NEWCELL)
(SETQ NEWCELL (OR (fetch DTDFREE of DTD)
(\GCTYPE TYP DTD)))
(CHECK (EQ TYP (NTYPX NEWCELL)))
(PROG NIL (* This circumlocution is because replace sometimes
returns a value which can't be NIL-tested in MAKEINIT
mode)
[replace DTDFREE of DTD with (OR (\GETBASEPTR NEWCELL 0)
(PROGN (replace DTDFREE of DTD with NIL)
(RETURN (\GCTYPE TYP DTD]
(* Remember that \GCTYPE will smash the DTDFREE field
with the new page created)
)
(\StatsAdd1 (fetch DTDCNTLOC of DTD))
(PROG ((CNT (fetch DTDSIZE of DTD))
(PTR NEWCELL)) (* Clear object)
(PROGN (\PUTBASE NEWCELL (add CNT -1)
0)
(\BLT NEWCELL (\ADDBASE NEWCELL 1)
CNT)))
(\CREATEREF NEWCELL)
(RETURN NEWCELL)))])
)
(RPAQ? CROSSCOMPILING )
(RPAQ? ASSIGNDATATYPE.ASKUSERWAIT 300)
(RPAQ? \STORAGEFULLSTATE )
(RPAQ? \STORAGEFULL )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CROSSCOMPILING \STORAGEFULLSTATE \STORAGEFULL \SYSTEMCACHEVARS \NxtArrayPage)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS ASSIGNDATATYPE.ASKUSERWAIT)
)
(* fetch and replace)
(DEFINEQ
(FETCHFIELD
[LAMBDA (DESCRIPTOR DATUM) (* edited: " 7-JUN-83 10:23")
(* retrieves a data field from a user data structure.)
(PROG ((TN (fetch fdTypeName of DESCRIPTOR))
(OFFSET (fetch fdOffset of DESCRIPTOR)))
(AND TN (SETQ DATUM (\DTEST DATUM TN)))
(RETURN (SELECTQ (fetch fdType of DESCRIPTOR)
((POINTER XPOINTER FULLPOINTER FULLXPOINTER)
(\GETBASEPTR DATUM OFFSET))
(FLOATP (MAKEFLOATNUMBER (\GETBASE DATUM OFFSET)
(\GETBASE (\ADDBASE DATUM 1)
OFFSET)))
(FIXP (\MAKENUMBER (\GETBASE DATUM OFFSET)
(\GETBASE (ADDBASE DATUM 1)
OFFSET)))
(SWAPPEDFIXP (\MAKENUMBER (\GETBASE (\ADDBASE DATUM 1)
OFFSET)
(\GETBASE DATUM OFFSET)))
(PROG ((FT (fetch fdType of DESCRIPTOR))
(OFF OFFSET))
(RETURN (SELECTQ (CAR FT)
[BITS (LOGAND (LRSH (\GETBASE DATUM OFF)
(BitFieldShift (CDR FT)))
(BitFieldMask (CDR FT]
[SIGNEDBITS
([LAMBDA (N WIDTH)
(COND
[[IGREATERP N (SUB1 (LLSH 1 (SUB1 WIDTH]
(SUB1 (IDIFFERENCE N
(SUB1 (LLSH 1 WIDTH]
(T N]
(LOGAND (LRSH (\GETBASE DATUM OFF)
(BitFieldShift (CDR FT)))
(BitFieldMask (CDR FT)))
(BitFieldWidth (CDR FT]
(LONGBITS (\MAKENUMBER
(LOGAND (LRSH (\GETBASE DATUM OFF)
(BitFieldShift
(CDR FT)))
(BitFieldMask (CDR FT)))
(\GETBASE (ADDBASE DATUM 1)
OFF)))
(FLAGBITS (NEQ (LOGAND (\GETBASE DATUM OFF)
(BitFieldShiftedMask
(CDR FT)))
0))
(LISPERROR "ILLEGAL ARG" DESCRIPTOR])
(REPLACEFIELD
[LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* lmm " 1-Jan-85 23:09")
(* replace a field in a user data structure.
return coerced value.)
(PROG ((OFFSET (fetch fdOffset of DESCRIPTOR))
(FT (fetch fdType of DESCRIPTOR))
(TN (fetch fdTypeName of DESCRIPTOR))
SHIFT MASK)
(AND TN (SETQ DATUM (\DTEST DATUM TN)))
(RETURN
(SELECTQ
FT
((POINTER FULLPOINTER)
(\RPLPTR DATUM OFFSET NEWVALUE))
(XPOINTER (* no ref count, hi bits used)
(PUTBASEPTRX DATUM OFFSET NEWVALUE))
(FULLXPOINTER (\PUTBASEPTR DATUM OFFSET NEWVALUE))
(FLOATP (\PUTBASEFLOATP DATUM OFFSET NEWVALUE))
(FIXP (\PUTFIXP (\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(SWAPPEDFIXP (\PUTSWAPPEDFIXP (\ADDBASE DATUM OFFSET)
NEWVALUE)
NEWVALUE)
(SELECTQ
(CAR FT)
(BITS (LOGAND (LRSH (\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND NEWVALUE MASK)
SHIFT)))
SHIFT)
MASK))
(SIGNEDBITS
([LAMBDA (X)
(COND
[[IGREATERP X (SUB1 (LLSH 1 (SUB1 (BitFieldWidth (CDR FT]
(SUB1 (IDIFFERENCE X (SUB1 (LLSH 1 (BitFieldWidth (CDR FT]
(T X]
(LOGAND
(LRSH (\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535 (LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND [LOGAND NEWVALUE
(SUB1 (LLSH 1 (BitFieldWidth
(CDR FT]
MASK)
SHIFT)))
SHIFT)
MASK)))
(FLAGBITS (\PUTBASE DATUM OFFSET (LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND (COND
(NEWVALUE 65535)
(T 0))
MASK)
SHIFT)))
(AND NEWVALUE T))
(LONGBITS (PROG (LO HI)
(.UNBOX. NEWVALUE HI LO)
(UNINTERRUPTABLY
(\PUTBASE DATUM OFFSET
(LOGOR [LOGAND (\GETBASE DATUM OFFSET)
(LOGXOR 65535
(LLSH (SETQ MASK
(BitFieldMask
(CDR FT)))
(SETQ SHIFT
(BitFieldShift
(CDR FT]
(LLSH (LOGAND HI MASK)
SHIFT)))
(\PUTBASE DATUM (ADD1 OFFSET)
LO)))
NEWVALUE)
(LISPERROR "ILLEGAL ARG" DESCRIPTOR])
(BOXCOUNT
[LAMBDA (TYPE N) (* lmm "20-OCT-81 20:27")
(PROG [(DTD (\GETDTD (OR (SMALLP TYPE)
(COND
((NULL TYPE)
\FIXP)
(T (\TYPENUMBERFROMNAME TYPE]
(RETURN (PROG1 (fetch DTDCNT of DTD)
(AND (NUMBERP N)
(replace DTDCNT of DTD with N])
(CONSCOUNT
[LAMBDA (N) (* lmm "13-MAY-80 23:02")
(BOXCOUNT \LISTP N])
(\DTEST
(LAMBDA (OBJ TYPE) (* lmm "22-Mar-85 12:29") (\DTEST.UFN OBJ (\ATOMPNAMEINDEX TYPE))))
(\TYPECHECK
(LAMBDA (OBJ TYPE) (* lmm "22-Mar-85 12:29") (\DTEST.UFN OBJ (\ATOMPNAMEINDEX TYPE))))
(\DTEST.UFN
(LAMBDA (OBJ TYPEN) (* lmm "22-Mar-85 12:31") (* ufn for DTEST opcode - coerce into desired type) (
COND ((EQ (fetch DTDNAME of (\GETDTD (NTYPX OBJ))) TYPEN) (* should not happen) OBJ) (T (SELECTQ (
\INDEXATOMPNAME TYPEN) (FLOATP (\FLOAT OBJ)) (STREAM (* Should be able to get at the INPUT/OUTPUT
flg--a second arg to \DTEST ?) (\GETSTREAM OBJ (SELECTQ (STKNTHNAME -1 (QUOTE \DTEST.UFN)) ((\BINS
\BIN BIN) (QUOTE INPUT)) ((\BOUTS \BOUT BOUT) (QUOTE OUTPUT)) NIL))) (HARRAYP (DECLARE (GLOBALVARS
SYSHASHARRAY)) (COND ((NULL OBJ) (COND (SYSHASHARRAY (\DTEST SYSHASHARRAY (QUOTE HARRAYP))) (T (
LISPERROR "ARG NOT HARRAY" OBJ T)))) ((AND (LISTP OBJ) (TYPENAMEP (CAR OBJ) (QUOTE HARRAYP))) (CAR OBJ
)) (T (LISPERROR "ARG NOT HARRAY" OBJ T)))) (FONTDESCRIPTOR (\COERCEFONTDESC OBJ)) (SMALLP (PROG (HI
LO) (.UNBOX. OBJ HI LO) (RETURN (OR (SMALLP (\MAKENUMBER HI LO)) (LISPERROR "ILLEGAL ARG" OBJ T))))) (
LISTP (LISPERROR "ARG NOT LIST" OBJ T)) (LITATOM (LISPERROR "ARG NOT LITATOM" OBJ T)) (STACKP (
LISPERROR "ILLEGAL STACK ARG" OBJ T)) (READTABLEP (LISPERROR "ILLEGAL READTABLE" OBJ T)) (TERMTABLEP (
LISPERROR "ILLEGAL TERMINAL TABLE" OBJ T)) (ARRAYP (LISPERROR "ARG NOT ARRAY" OBJ T)) (\DISPLAYDATA (*
Should be able to get at the stream--a second arg to \DTEST ?) (ERROR "ARG NOT DISPLAY STREAM" NIL))
(\LISPERROR OBJ (CONCAT "ARG NOT " (\INDEXATOMPNAME TYPEN)) T))))))
(\TYPECHECK.UFN
(LAMBDA (OBJ TYPEN) (* lmm "22-Mar-85 12:32") (* ufn for TYPECHECK opcode - cause error if not of
right type) (COND ((EQ (fetch DTDNAME of (\GETDTD (NTYPX OBJ))) TYPEN) (* should not happen) OBJ) (T (
\LISPERROR OBJ (CONCAT "ARG NOT " (\INDEXATOMPNAME TYPEN)) T)))))
(GETDESCRIPTORS
[LAMBDA (TYPENAME) (* lmm "21-Apr-85 15:10")
(PROG NIL
(RETURN (fetch DTDDESCRS of (\GETDTD (COND
((LITATOM TYPENAME)
(OR (\TYPENUMBERFROMNAME TYPENAME)
(RETURN)))
(T (NTYPX TYPENAME])
(GETFIELDSPECS
[LAMBDA (TYPENAME) (* rmk: "28-OCT-81 17:42")
(PROG NIL
(RETURN (COPY (fetch DTDTYPESPECS of (\GETDTD (COND
((LITATOM TYPENAME)
(OR (\TYPENUMBERFROMNAME TYPENAME)
(RETURN)))
(T (NTYPX TYPENAME])
(NCREATE
[LAMBDA (TYPE OLDOBJ) (* lmm "14-MAY-80 08:33")
(NCREATE2 (\TYPENUMBERFROMNAME TYPE)
OLDOBJ])
(NCREATE2
[LAMBDA (NTYPX OLDOBJ) (* bvm: " 5-Feb-85 16:43")
(* a version of NCREATE which has is compiled from calls to NCREATE which have a quoted first arg and an old object.
These can use the TYPE number variable in stead of having to look it up.)
(PROG ((DTD (\GETDTD NTYPX))
(NEW (CREATECELL NTYPX)))
[COND
((EQ (NTYPX OLDOBJ)
NTYPX)
(UNINTERRUPTABLY
(\BLT NEW OLDOBJ (fetch DTDSIZE of DTD))
(for P in (fetch DTDPTRS of DTD) do (\ADDREF (\GETBASEPTR NEW P))))]
(RETURN NEW])
(REPLACEFIELDVAL
[LAMBDA (DESCRIPTOR DATUM NEWVALUE)
(* lmm: "22-AUG-76 04:18:20")
(* used by the record package-- compiles open better than saving datum)
(REPLACEFIELD DESCRIPTOR DATUM NEWVALUE)
DATUM])
(PUTBASEPTRX
[LAMBDA (DATUM OFFSET NEWVALUE)
(* lmm "15-MAY-80 22:20")
(UNINTERRUPTABLY (PUTBASE DATUM OFFSET (LOGOR (LOGAND 177400Q (GETBASE DATUM OFFSET))
(HILOC NEWVALUE)))
(PUTBASE DATUM (ADD1 OFFSET)
(LOLOC NEWVALUE))
NEWVALUE])
(/REPLACEFIELD
[LAMBDA (DESCRIPTOR DATUM NEWVALUE)
(* lmm: "23-AUG-76 00:01:53")
[AND LISPXHIST (UNDOSAVE (LIST (QUOTE /REPLACEFIELD)
DESCRIPTOR DATUM (FETCHFIELD DESCRIPTOR DATUM]
(REPLACEFIELD DESCRIPTOR DATUM NEWVALUE])
(TYPENAME
[LAMBDA (DATUM) (* lmm "13-FEB-83 14:13")
(PROG ((N (NTYPX DATUM)))
(RETURN (SELECTC N
(\ARRAYP (\ARRAYTYPENAME DATUM))
(\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD N])
(\TYPENAMEFROMNUMBER
[LAMBDA (N) (* lmm "13-FEB-83 14:13")
(COND
((ILESSP N (ADD1 \MaxTypeNumber))
(\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD N])
(\BLOCKDATAP
(LAMBDA (X) (* JonL "22-Sep-84 23:15")
(PROG ((TYPENO (NTYPX X)))
(RETURN (if (EQ 0 TYPENO)
then (type? ARRAYBLOCK X)
else (fetch DTDHUNKP of (\GETDTD TYPENO)))))))
(USERDATATYPES
[LAMBDA NIL (* rrb "16-JUL-80 13:17")
(DATATYPES T])
(DATATYPEP
[LAMBDA (DATATYPESPEC) (* bvm: "12-Feb-85 17:29")
(* returns the type name of a data type spec if it is a
datatype.)
(COND
[(SMALLP DATATYPESPEC)
(PROG ((DTD (\GETDTD DATATYPESPEC))
NAME)
(RETURN (AND (NOT (fetch DTDHUNKP of DTD))
(SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of DTD)))
(NEQ NAME (QUOTE **DEALLOC**))
NAME]
((NOT (LITATOM DATATYPESPEC))
NIL)
((FMEMB DATATYPESPEC (QUOTE (CCODEP HARRAYP))) (* handle subtypes of arrayp specially.)
DATATYPESPEC)
((for I from 1 to \MaxTypeNumber thereis (EQ (\INDEXATOMPNAME (fetch DTDNAME
of (\GETDTD I)))
DATATYPESPEC))
DATATYPESPEC])
(DATATYPES
[LAMBDA (USERSFLG) (* rrb "16-JUL-80 13:20")
(bind N for I from (COND
(USERSFLG (ADD1 \MaxSysTypeNum))
(T 1))
to \MaxTypeNumber when (SETQ N (DATATYPEP I)) collect N])
)
(MOVD? (QUOTE FETCHFIELD)
(QUOTE FFETCHFIELD))
(MOVD? (QUOTE REPLACEFIELD)
(QUOTE FREPLACEFIELD))
(MOVD? (QUOTE REPLACEFIELDVAL)
(QUOTE FREPLACEFIELDVAL))
(* STORAGE)
(DEFINEQ
(STORAGE
[LAMBDA (TYPES PAGETHRESHOLD) (* bvm: "12-Feb-85 17:22")
(PROG ((TOTALALLOCMDS (CREATECELL \FIXP))
(TOTALHUNKS (CREATECELL \FIXP))
(FREE (CREATECELL \FIXP))
(HUNKSTATS (from 0 to 2 collect (create HUNKSTAT)))
TYPE TYPENAME DOBLOCKSFLG)
(DECLARE (SPECVARS HUNKSTATS))
(printout NIL "Type" 15 "Assigned" 30 "Free items" 45 "In use" 55 "Total alloc" T 15
"pages [items]"
T)
(COND
[(AND TYPES (NEQ TYPES T))
(for TYPE HFLG inside TYPES when [COND
((FIXP TYPE)
(COND
((OR (ILESSP TYPE 0)
(IGREATERP TYPE \MaxTypeNumber))
(* An explicit type number ought to be "right")
(ERROR "Not a type number" TYPE))
((EQ TYPE 0)
(SETQ DOBLOCKSFLG T)
NIL)
(T T)))
(T (SETQ TYPE (\TYPENUMBERFROMNAME TYPE]
do (COND
((fetch DTDHUNKP of (\GETDTD TYPE))
(SETQ HFLG T)))
(\STORAGE.TYPE TYPE FREE TOTALALLOCMDS PAGETHRESHOLD)
finally (COND
(HFLG (\STORAGE.HUNKTYPE TOTALALLOCMDS PAGETHRESHOLD]
(T (for I from 1 to \MaxTypeNumber do (\STORAGE.TYPE I FREE TOTALALLOCMDS PAGETHRESHOLD))
(\STORAGE.HUNKTYPE TOTALHUNKS PAGETHRESHOLD)
(printout NIL T "TOTAL" 15 .I5 (IPLUS TOTALALLOCMDS TOTALHUNKS)
T T)
(printout NIL "Data Spaces Summary" T)
(printout NIL 30 "Allocated" 50 "Remaining" T)
(printout NIL 32 "Pages" 52 "Pages" T)
(printout NIL "Datatypes (incl. LISTP etc.)" 30 .I8 TOTALALLOCMDS 50 "\" T)
(* Arrayspace and MDS come out of the same pot, so lump
their "remaining" pages together)
(printout NIL "ArrayBlocks" (COND
((NOT (IEQP TOTALHUNKS 0))
" (variable)")
(T ""))
30 .I8 (SELECTC \STORAGEFULLSTATE
((LIST \SFS.FULLYSWITCHED \SFS.ARRAYSWITCHED)
(IPLUS (IDIFFERENCE \LeastMDSPage \FirstArrayPage)
(IDIFFERENCE \NxtArrayPage \SecondArrayPage)))
(IDIFFERENCE \NxtArrayPage \FirstArrayPage))
50 "--" .I6 (CAR (STORAGE.LEFT))
T)
(COND
((NOT (IEQP TOTALHUNKS 0))
(printout NIL "ArrayBlocks (chunked)" 30 .I8 TOTALHUNKS 50 "/" T)))
(* \LastATOMpage marks off atom indexes as if they were word addresses; but the space behind a litatom is one cell
in each of the four spaces: DEFSPACE, VALSPACE, PNAMESPACE, and PROPSPACE)
(\STLINP "Litatoms" (ITIMES (FOLDHI \AtomFrLst CELLSPERPAGE)
4)
(ITIMES (UNFOLD (ADD1 \LastAtomPage)
WORDSPERCELL)
4))
(COND
(\PNAMES.IN.BLOCKS? (\STLINP "Litatom Pnames (from bootstrap)" (ADD1 \CurPnPage)
(ADD1 \CurPnPage)))
(T (\STLINP "Litatom Pnames" (ADD1 \CurPnPage)
\LastPnPage)))
(SETQ DOBLOCKSFLG T)))
(COND
(DOBLOCKSFLG (\SHOW.ARRAY.FREELISTS])
(STORAGE.LEFT
[LAMBDA NIL (* bvm: "24-Apr-85 15:02")
(* * Return a list MDS+Arrays left in 8mb, in 24mb, litatoms left, pnames left and the same as fractions)
(PROG ((MDSFREE (IPLUS (IDIFFERENCE (SELECTC (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE))
(\SFS.ARRAYSWITCHED
(* There's free space in two places: some leftover MDS
in the lo region, and the space beyond allocated arrays
in the hi)
\SecondMDSPage)
\NxtMDSPage)
\NxtArrayPage)
\PagesPerMDSUnit
(SELECTC \STORAGEFULLSTATE
(\SFS.SWITCHABLE (* We have another 24MB to work with)
(IPLUS (IDIFFERENCE \SecondMDSPage
\SecondArrayPage)
\PagesPerMDSUnit))
(\SFS.ARRAYSWITCHED (* Account for the space left behind after array
allocation moved)
(IPLUS (IDIFFERENCE \NxtMDSPage \LeastMDSPage)
\PagesPerMDSUnit))
0)
(for (FREE ← \MDSFREELISTPAGE)
by (SMALLP (\GETBASEPTR (create POINTER
PAGE# ← FREE)
0))
while FREE sum 1)))
(ATOMTOTAL (ITIMES (UNFOLD (ADD1 \LastAtomPage)
WORDSPERCELL)
4))
ATOMSLEFT MDSFRAC)
[SETQ MDSFRAC (FQUOTIENT MDSFREE (IPLUS (IDIFFERENCE (IPLUS \FirstMDSPage \PagesPerMDSUnit)
\FirstArrayPage)
(COND
((EQ \STORAGEFULLSTATE \SFS.NOTSWITCHABLE)
0)
(T (IDIFFERENCE (IPLUS \SecondMDSPage
\PagesPerMDSUnit)
\SecondArrayPage]
(RETURN (LIST MDSFREE MDSFRAC (SELECTC \STORAGEFULLSTATE
(\SFS.NOTSWITCHABLE MDSFRAC)
(\SFS.SWITCHABLE (FQUOTIENT (IDIFFERENCE
(IPLUS \NxtMDSPage
\PagesPerMDSUnit)
\NxtArrayPage)
(IDIFFERENCE
(IPLUS \FirstMDSPage
\PagesPerMDSUnit)
\FirstArrayPage)))
0)
(SETQ ATOMSLEFT (IDIFFERENCE ATOMTOTAL (ITIMES (FOLDHI \AtomFrLst
CELLSPERPAGE)
4)))
(FQUOTIENT ATOMSLEFT ATOMTOTAL])
(\STORAGE.TYPE
(LAMBDA (TYPE FREE TOTALALLOCMDS PAGETHRESHOLD) (* lmm " 5-Aug-85 09:27") (DECLARE (USEDFREE HUNKSTATS
)) (PROG ((ALLOCMDS 0) SIZE NAME ALLOC INUSE ITEMSPERMDS INUSEPAGES NPAGESALLOCATED HUNKP DTD STAT) (
DECLARE (SPECVARS ALLOCMDS)) (SETQ DTD (\GETDTD TYPE)) (OR (SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME
of DTD))) (RETURN)) (SETQ HUNKP (fetch DTDHUNKP of DTD)) (SETQ SIZE (fetch DTDSIZE of DTD)) (CHECK (
EVENP SIZE WORDSPERCELL)) (SETQ ITEMSPERMDS (SELECTQ NAME ((LITATOM SMALLP) (RETURN)) (LISTP (COND ((
EQ CDRCODING 0) (IQUOTIENT \MDSIncrement SIZE)) (T (CONSTANT (FIX (FQUOTIENT \MDSIncrement 2.2)))))) (
if (EQ SIZE 0) then (RETURN) else (IQUOTIENT \MDSIncrement SIZE)))) (\MAPMDS TYPE (FUNCTION (LAMBDA
NIL (add ALLOCMDS 1)))) (SETQ NPAGESALLOCATED (ITIMES ALLOCMDS (IQUOTIENT \MDSIncrement WORDSPERPAGE))
) (COND ((SETQ HUNKP (fetch DTDHUNKP of DTD)) (add (fetch (HUNKSTAT NPAGES) of (SETQ STAT (CAR (NTH
HUNKSTATS (ADD1 (fetch DTDGCTYPE of DTD)))))) NPAGESALLOCATED)) (T (\BOXIPLUS TOTALALLOCMDS
NPAGESALLOCATED))) (COND ((AND PAGETHRESHOLD (ILESSP NPAGESALLOCATED PAGETHRESHOLD)) (RETURN))) (
\PUTBASEFIXP (\DTEST FREE (QUOTE FIXP)) 0 0) (COND ((AND (NEQ CDRCODING 0) (EQ TYPE \LISTP)) (for (
LSTPAG ← (create POINTER PAGE# ← (fetch DTDNEXTPAGE of \LISTPDTD))) by (create POINTER PAGE# ← (fetch
(CONSPAGE NEXTPAGE) of LSTPAG)) while LSTPAG do (\BOXIPLUS FREE (fetch (CONSPAGE CNT) of LSTPAG)))) (T
(for (PTR ← (fetch DTDFREE of DTD)) by (\GETBASEPTR PTR 0) while PTR do (CHECK (EQ (NTYPX PTR) TYPE))
(\BOXIPLUS FREE 1)))) (SETQ INUSE (IDIFFERENCE (SETQ ALLOC (ITIMES ALLOCMDS ITEMSPERMDS)) FREE)) (
COND ((fetch DTDHUNKP of DTD) (* Keep a cumulative table to be printed out at the end of this all by
\STORAGE.HUNKTYPE) (add (fetch (HUNKSTAT NITEMS) of STAT) ALLOC) (add (fetch (HUNKSTAT NFREE) of STAT)
FREE) (add (fetch (HUNKSTAT NINUSE) of STAT) INUSE) (add (fetch (HUNKSTAT NALLOCATED) of STAT) (
BOXCOUNT TYPE))) (T (\STMDSTYPE (SELECTQ NAME (LISTP "LISTP ~") NAME) NPAGESALLOCATED ALLOC FREE
INUSE (BOXCOUNT TYPE)))))))
(\STLINP
[LAMBDA (STR ALLOC TOT) (* bvm: " 9-Feb-85 15:23")
(printout NIL STR 30 .I8 ALLOC 50 .I8 (IDIFFERENCE TOT ALLOC)
T])
(\STMDSTYPE
(LAMBDA (NAME NPAGESALLOCATED ALLOC FREE INUSE BOXCOUNT) (* JonL "22-Sep-84 22:41")
(printout NIL NAME 15 .I5 NPAGESALLOCATED .I8 ALLOC 30 .I8 FREE 43 .I8 INUSE 56 .I10 BOXCOUNT T)))
(\STORAGE.HUNKTYPE
[LAMBDA (TOTAL PAGETHRESHOLD) (* bvm: "12-Feb-85 17:03")
(DECLARE (USEDFREE HUNKSTATS))
(PROG (NPAGESALLOCATED STAT)
(for GCTYPE.NAME in [CONSTANT (LIST (LIST UNBOXEDBLOCK.GCT (QUOTE UNBOXEDHUNK))
(LIST PTRBLOCK.GCT (QUOTE PTRHUNK))
(LIST CODEBLOCK.GCT (QUOTE CODEHUNK]
do [SETQ STAT (CAR (NTH HUNKSTATS (ADD1 (CAR GCTYPE.NAME]
(SETQ NPAGESALLOCATED (fetch (HUNKSTAT NPAGES) of STAT))
(\BOXIPLUS TOTAL NPAGESALLOCATED)
(COND
((AND (NEQ NPAGESALLOCATED 0)
(OR (NOT PAGETHRESHOLD)
(IGEQ NPAGESALLOCATED PAGETHRESHOLD)))
(\STMDSTYPE (CADR GCTYPE.NAME)
NPAGESALLOCATED
(fetch (HUNKSTAT NITEMS) of STAT)
(fetch (HUNKSTAT NFREE) of STAT)
(fetch (HUNKSTAT NINUSE) of STAT)
(fetch (HUNKSTAT NALLOCATED) of STAT])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD HUNKSTAT (NPAGES NITEMS NFREE NINUSE NALLOCATED)
NPAGES ← 0 NITEMS ← 0 NFREE ← 0 NINUSE ← 0 NALLOCATED ← 0)
]
)
(RPAQ? STORAGE.ARRAYSIZES (QUOTE (4 16 64 256 1024 4096 16384 NIL)))
(DECLARE:
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS PUTBASEPTRX MACRO (OPENLAMBDA (DATUM OFFSET NEWVALUE)
(UNINTERRUPTABLY
(\PUTBASEBYTE DATUM (ADD1 (LLSH OFFSET 1))
(LOGAND (\HILOC NEWVALUE)
255))
(\PUTBASE DATUM (ADD1 OFFSET)
(\LOLOC NEWVALUE))
NEWVALUE)))
)
(* END EXPORTED DEFINITIONS)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(RPAQQ \SMALLP 1)
(RPAQQ \FIXP 2)
(RPAQQ \FLOATP 3)
(RPAQQ \LITATOM 4)
(RPAQQ \LISTP 5)
(RPAQQ \ARRAYP 6)
(RPAQQ \STRINGP 7)
(RPAQQ \STACKP 8)
(RPAQQ \VMEMPAGEP 10)
(RPAQQ \STREAM 11)
(CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STRINGP \STACKP \VMEMPAGEP \STREAM)
)
(* END EXPORTED DEFINITIONS)
DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD DTD ((DTDNAME WORD)
(DTDSIZE WORD)
(DTDFREE FULLXPOINTER)
(NIL BITS 4)
(DTDLOCKEDP FLAG)
(DTDHUNKP FLAG)
(DTDGCTYPE BITS 2) (* Only for hunk datatypes -- like arrayblock's GCTYPE)
(DTDDESCRS POINTER)
(DTDTYPESPECS POINTER)
(DTDPTRS POINTER)
(DTDOLDCNT FIXP)
(DTDCNT0 WORD)
(DTDNEXTPAGE WORD)
(DTDTYPEENTRY WORD))
[ACCESSFNS DTD ((DTDCNTLOC (\ADDBASE DATUM 10))
(DTDCNT (IPLUS (fetch DTDOLDCNT DATUM)
(fetch DTDCNT0 DATUM))
(UNINTERRUPTABLY
(replace DTDCNT0 of DATUM with 0)
(replace DTDOLDCNT of DATUM with NEWVALUE))])
]
(DECLARE: EVAL@COMPILE
[PUTPROPS \GETDTD MACRO ((typeNum)
(ADDBASE \DTDSpaceBase (LLSH typeNum 4]
[PUTPROPS \TYPEMASK.UFN DMACRO (X (LET [(CE (CONSTANTEXPRESSIONP (CADR X]
(if CE then (BQUOTE ((OPCODES TYPEMASK.N , (CAR CE))
,
(CAR X)))
else
(QUOTE IGNOREMACRO]
)
(DECLARE: EVAL@COMPILE
(RPAQQ \GUARDSTORAGEFULL 128)
(RPAQQ \GUARD1STORAGEFULL 64)
(CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage \MDSFREELISTPAGE \MaxSysTypeNum
\MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE \PENDINGINTERRUPT)
)
(* END EXPORTED DEFINITIONS)
(RPAQQ STORAGEFULLSTATES ((\SFS.NORMAL NIL)
(\SFS.NOTSWITCHABLE 1)
(\SFS.SWITCHABLE 2)
(\SFS.ARRAYSWITCHED 3)
(\SFS.FULLYSWITCHED 4)))
(DECLARE: EVAL@COMPILE
(RPAQQ \SFS.NORMAL NIL)
(RPAQQ \SFS.NOTSWITCHABLE 1)
(RPAQQ \SFS.SWITCHABLE 2)
(RPAQQ \SFS.ARRAYSWITCHED 3)
(RPAQQ \SFS.FULLYSWITCHED 4)
(CONSTANTS (\SFS.NORMAL NIL)
(\SFS.NOTSWITCHABLE 1)
(\SFS.SWITCHABLE 2)
(\SFS.ARRAYSWITCHED 3)
(\SFS.FULLYSWITCHED 4))
)
(RPAQQ DTDECLS ((SMALLP)
(FIXP 2)
(FLOATP 2)
(LITATOM)
(LISTP 4 0 2)
(ARRAYP 4 0)
(STRINGP 4 0)
(STACKP 2)
(CHARACTER)
(VMEMPAGEP 256)))
)
(* for MAKEINIT)
(DEFINEQ
(CREATEMDSTYPETABLE
[LAMBDA NIL (* lmm "10-Jul-85 14:36")
(* called only under MAKEINIT to initialize the main
data space type table)
(CREATEPAGES \MDSTypeTable \MDSTTsize NIL T)
[PROG (VP)
(* * FIRST SET ALL TO NOREF)
(SETQ VP 0)
(FRPTQ (UNFOLD \MDSTTsize WORDSPERPAGE)
(\PUTBASE \MDSTypeTable VP \TT.NOREF)
(add VP 1))
(* * NOW SET UP SMALLPS)
[for SEGMENT in (LIST \SmallPosHi \SmallNegHi)
do (for PAGE from 0 to (SUB1 PAGESPERSEGMENT) by (FOLDLO \MDSIncrement WORDSPERPAGE)
do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD SEGMENT PAGESPERSEGMENT))
(LOGOR \TT.NOREF \TT.FIXP \TT.NUMBERP \TT.ATOM \SMALLP]
(for PAGE from 0 to (SUB1 PAGESPERSEGMENT) by (FOLDLO \MDSIncrement WORDSPERPAGE)
do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD \CHARHI PAGESPERSEGMENT))
(LOGOR \TT.NOREF \CHARACTERP]
(CREATEPAGES \MISCSTATS (FOLDLO \MDSIncrement WORDSPERPAGE)
NIL T)
(\MAKEMDSENTRY (PAGELOC \MISCSTATS)
(LOGOR \TT.NOREF \TT.FIXP \TT.NUMBERP \TT.ATOM \FIXP])
(INITDATATYPES
[LAMBDA NIL (* jds "17-Apr-85 04:46")
(* called only under MAKEINIT;
called before it is possible to make new atoms)
(SETQ \MaxTypeNumber 0)
(CREATEPAGES \DTDSpaceBase 1 NIL T)
[for D in (LOCAL DTDECLS) bind DTD as old \MaxTypeNumber from 1
do (* Run thru the initial data type decls
(the gut-level system datatypes), and declare them in
the INIT.DLINIT.)
(* \MaxTypeNumber must start at 1 for the type numbers to work out right, but remember that it gets stepped 1 too
far by this looping construct.)
(SETQ DTD (\GETDTD \MaxTypeNumber)) (* Create a Data-Type-Descriptor for the new type)
[replace DTDTYPEENTRY of DTD with (LOGOR \MaxTypeNumber
(COND
([ALLOCAL (FMEMB (CAR D)
(QUOTE (SMALLP FIXP FLOATP]
\TT.NUMBERP)
(T 0))
(COND
([ALLOCAL (FMEMB (CAR D)
(QUOTE (SMALLP FIXP FLOATP
LITATOM]
\TT.ATOM)
(T 0))
(COND
([ALLOCAL (FMEMB (CAR D)
(QUOTE (SMALLP FIXP]
\TT.FIXP)
(T 0))
(COND
((ALLOCAL (NOT (CADR D)))
(* no size, no ref)
\TT.NOREF)
(T 0] (* Set up the type-mask field with the appropriate
meta-type bits)
(COND
((ALLOCAL (AND (CAR D)
(CADR D)))
(replace DTDSIZE of DTD with (LOCAL (CADR D)))
(* Set the data type's size)
(\GCTYPE \MaxTypeNumber DTD) (* And create 2 pages worth of empty datums.)
]
[COND
((NEQ CDRCODING 0)
(SETQ.NOREF \LISTPDTD (\GETDTD \LISTP]
NIL])
(INITDATATYPENAMES
[LAMBDA NIL (* jds "17-Apr-85 04:47")
(* called in MAKEINIT after it is ok to create new
atoms to REALLY initialize the data type tables -
\MaxSysTypeNum is in INITVALUES)
(for D in (LOCAL DTDECLS) as NTYPX from 1
do (* redeclare with atoms in right places)
(PROG ((DTD (\GETDTD NTYPX)))
[replace DTDNAME of DTD with (\ATOMPNAMEINDEX (LOCAL (CAR D]
(* Smash the name from our world into his)
[replace DTDPTRS of DTD with (COPY (LOCAL (CDDR D]
(* And the list of pointer offsets)
)) (* Because \MaxTypeNumber gets stepped one too far in
INITDATATYPES, we back it down here.)
(SETQ \MaxSysTypeNum (add \MaxTypeNumber -1])
)
(DECLARE: DONTCOPY
(ADDTOVAR INITVALUES (\NxtMDSPage \FirstMDSPage)
(\LeastMDSPage \FirstMDSPage)
(\SecondMDSPage \DefaultSecondMDSPage)
(\SecondArrayPage \DefaultSecondArrayPage)
(\MDSFREELISTPAGE)
(\MaxSysTypeNum 0)
(\MaxTypeNumber))
(ADDTOVAR INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \GCTYPE \INITMDSPAGE \ASSIGNDATATYPE1
\TYPENUMBERFROMNAME \CREATECELL \NEW2PAGE)
(FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
(VARS DTDECLS))
(ADDTOVAR RDCOMS (FNS NTYPX TYPENAME))
(ADDTOVAR RD.SUBFNS (\ARRAYTYPENAME LAMBDA (X)
(QUOTE ARRAYP)))
(ADDTOVAR EXPANDMACROFNS \GETDTD PUTBASEPTRX REPLACEFIELD FETCHFIELD \GETBITS \PUTBITS \TESTBITS
GETBASEBITS PUTBASEBITS FFETCHFIELD FREPLACEFIELD FREPLACEFIELDVAL
REPLACEFIELDVAL NCREATE)
(ADDTOVAR MKI.SUBFNS (\GCDISABLED . NILL)
(CREATECELL . I.\CREATECELL)
(\CHECKFORSTORAGEFULL . NILL))
EVAL@COMPILE
(ADDTOVAR DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
DTDECLARE)
)
(PUTPROPS LLDATATYPE COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3583 24156 (NTYPX 3593 . 4017) (\TYPEMASK.UFN 4019 . 4235) (\TYPEP.UFN 4237 . 4323) (
\ALLOCMDSPAGE 4325 . 5351) (\ALLOCPAGEBLOCK 5353 . 5981) (\ALLOCVIRTUALPAGEBLOCK 5983 . 8176) (\MAPMDS
8178 . 9723) (\CHECKFORSTORAGEFULL 9725 . 13527) (\DOSTORAGEFULLINTERRUPT 13529 . 13859) (
\SET.STORAGE.STATE 13861 . 14490) (\SETTYPEMASK 14492 . 14903) (\ADVANCE.STORAGE.STATE 14905 . 15451)
(\NEW2PAGE 15453 . 15620) (\MAKEMDSENTRY 15622 . 15756) (\GCTYPE 15758 . 16393) (\INITMDSPAGE 16395 .
18088) (\ASSIGNDATATYPE1 18090 . 21880) (\ASSIGN.DATATYPE 21882 . 22340) (\TYPENUMBERFROMNAME 22342 .
22641) (CREATECELL 22643 . 22776) (\CREATECELL 22778 . 24154)) (24521 36513 (FETCHFIELD 24531 . 26400)
(REPLACEFIELD 26402 . 29752) (BOXCOUNT 29754 . 30097) (CONSCOUNT 30099 . 30205) (\DTEST 30207 . 30305
) (\TYPECHECK 30307 . 30409) (\DTEST.UFN 30411 . 31802) (\TYPECHECK.UFN 31804 . 32091) (GETDESCRIPTORS
32093 . 32437) (GETFIELDSPECS 32439 . 32768) (NCREATE 32770 . 32906) (NCREATE2 32908 . 33586) (
REPLACEFIELDVAL 33588 . 33885) (PUTBASEPTRX 33887 . 34198) (/REPLACEFIELD 34200 . 34488) (TYPENAME
34490 . 34732) (\TYPENAMEFROMNUMBER 34734 . 34930) (\BLOCKDATAP 34932 . 35234) (USERDATATYPES 35236 .
35340) (DATATYPEP 35342 . 36262) (DATATYPES 36264 . 36511)) (36710 45927 (STORAGE 36720 . 40036) (
STORAGE.LEFT 40038 . 42435) (\STORAGE.TYPE 42437 . 44506) (\STLINP 44508 . 44697) (\STMDSTYPE 44699 .
44913) (\STORAGE.HUNKTYPE 44915 . 45925)) (49240 53949 (CREATEMDSTYPETABLE 49250 . 50576) (
INITDATATYPES 50578 . 52791) (INITDATATYPENAMES 52793 . 53947)))))
STOP