(FILECREATED " 7-Feb-85 18:45:33" {ERIS}<LISPCORE>32MB>LLHUNK.;1 16638
changes to: (VARS LLHUNKCOMS)
(FNS \SETUPHUNKING \SETUP.TYPENUM.TABLE)
previous date: "15-Jan-85 00:48:54" {ERIS}<LISPCORE>SOURCES>LLHUNK.;2)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLHUNKCOMS)
(RPAQQ LLHUNKCOMS ([COMS (* "Basic hunking")
(FNS \ALLOCHUNK)
(*
"Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage"
)
(VARS (\HUNKREJECTS))
(GLOBALVARS \HUNKREJECTS)
(DECLARE: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER]
[COMS (* Initialization)
(FNS \SETUPHUNKING \SETUP.TYPENUM.TABLE)
(DECLARE: EVAL@COMPILE DONTCOPY (CONSTANTS \MAX.CELLSPERHUNK)
(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES))
(INITVARS (\HUNKING?)
(\PNAMES.IN.BLOCKS?)
(\MDSFREELISTCOUNT 0))
(GLOBALVARS \HUNKING? \PNAMES.IN.BLOCKS?)
(INITVARS (\UNBOXEDHUNK.TYPENUM.TABLE)
(\CODEHUNK.TYPENUM.TABLE)
(\PTRHUNK.TYPENUM.TABLE))
(GLOBALVARS \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE
\PTRHUNK.TYPENUM.TABLE)
(* "Turn it all on, during the BOOTEXPRS phase")
(DECLARE: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY (P (\SETUPHUNKING]
(COMS (* "Debugging aids")
(DECLARE: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst)
(CONSTANTS \ArrayBlockPassword))
(FNS \HUNKFIT? \AB.NEXT \AB.BACK))))
(* "Basic hunking")
(DEFINEQ
(\ALLOCHUNK
(LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (* JonL "18-Sep-84 00:14")
(OR (NULL ALIGN)
(AND (ILEQ ALIGN \MAX.CELLSPERHUNK)
(FMEMB ALIGN (SELECTC GCTYPE
(UNBOXEDBLOCK.GCT (CONSTANT (for X in \HUNK.UNBOXEDSIZES
when (AND (IGREATERP X 1)
(ILEQ X \MAX.CELLSPERHUNK)
)
collect X)))
(PTRBLOCK.GCT (for X in \HUNK.PTRSIZES
when (AND (IGREATERP X 1)
(ILEQ X \MAX.CELLSPERHUNK))
collect X))
(CODEBLOCK.GCT (CONSTANT (LIST CELLSPERQUAD)))
NIL)))
(ERROR "Oddball alignment request" ALIGN)) (* Certify that the alignment request is legitimate.)
(PROG ((TYPENUM.TABLE (SELECTC GCTYPE
(UNBOXEDBLOCK.GCT \UNBOXEDHUNK.TYPENUM.TABLE)
(CODEBLOCK.GCT \CODEHUNK.TYPENUM.TABLE)
(PTRBLOCK.GCT \PTRHUNK.TYPENUM.TABLE)
(SHOULDNT)))
(FAILCNT 0)
DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS)
BEG (do (SETQ DTNUMBER (\GETBASEBYTE TYPENUM.TABLE NCELLS))
(SETQ HUNKSIZE (HUNKSIZEFROMNUMBER DTNUMBER))
repeatuntil (OR (NOT ALIGN)
(EQ 0 (IREMAINDER (FOLDLO (fetch DTDSIZE of (\GETDTD DTNUMBER))
WORDSPERCELL)
ALIGN))
(if (IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE))
\MAX.CELLSPERHUNK)
then (GO LOSE)
else (* We're allowed to chunk up the size of the request in
order to meet the alignment;
ultimately we should top off at \MAX.CELLSPERHUNK)
NIL)))
LP (SETQ HUNK (CREATECELL DTNUMBER))
(if (OR (NULL INITONPAGE)
(ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE CELLSPERPAGE (fetch (POINTER
CELLINPAGE)
of HUNK)))))
then (* Ah, happy case -- all constraints satisfied)
(RETURN HUNK))
(* * Sigh, gotta try to get one with more of the initial "run" of cells on the same page.)
(if (AND (EQ GCTYPE CODEBLOCK.GCT)
(ILEQ (IQUOTIENT (ITIMES 10 ONPAGE)
HUNKSIZE)
(if (ILEQ HUNKSIZE 24)
then 60
elseif (ILEQ HUNKSIZE 50)
then 50
else 30)))
then
(* If the percentage of the page-straddling codehunk that is on the first page is too small, then just toss this
loser into the "black hole" This heuristic is based on empirical data taken about Sep 1984 which observed the ratio
of "on-page" requirements to code length.)
(\ADDREF HUNK)
else (* So that a GC doesn't sneak in and put it back on the
freelist too soon.)
(push STRADDLERS HUNK))
(if (ILESSP 16 (add FAILCNT 1))
then (* Put a limit to this nonsense of trying to find a
non-page-straddling hunk!)
(GO LOSE)
elseif (EQ FAILCNT 8)
then (* After too many failures with this size of hunk, try
the next container size up.)
(SETQ NCELLS (ADD1 HUNKSIZE))
(AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS)))
(GO BEG)
else)
(GO LP)
LOSE(AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS)))
(RETURN))))
)
(*
"Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage"
)
(RPAQQ \HUNKREJECTS NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \HUNKREJECTS)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX)
(FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX))
WORDSPERCELL)))
)
(* END EXPORTED DEFINITIONS)
)
(* Initialization)
(DEFINEQ
(\SETUPHUNKING
[LAMBDA NIL (* bvm: " 7-Feb-85 17:32")
(* * First, create all the datatypes, and the tables used to calculate a hunk datatype number from the allocation
size request.)
(SETQ \UNBOXEDHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT
(QUOTE \UNBOXEDHUNK)))
(SETQ \CODEHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.CODESIZES CODEBLOCK.GCT (QUOTE
\CODEHUNK)))
(SETQ \PTRHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.PTRSIZES PTRBLOCK.GCT (QUOTE \PTRHUNK)))
(SETQ \HUNKING? T)
(* * String up the remaining PNAME pages for MDS usage. Note that we *CANNOT* go back to non-hunking when the PNAME
space switch is accomplished.)
(COND
((NULL \PNAMES.IN.BLOCKS?) (* This can only be done once)
(UNINTERRUPTABLY
(SETQ \PNAMES.IN.BLOCKS? T)
(PROG ((PREV \MDSFREELISTPAGE)
(NEXTPNPAGE (IPLUS (UNFOLD \PnCharsFirstSegment PAGESPERSEGMENT)
(CEIL (ADD1 \CurPnPage)
2)))
(LASTPNPAGE (IPLUS (UNFOLD \PnCharsFirstSegment PAGESPERSEGMENT)
\LastPnPage)))
(for (BASE ←(create POINTER
PAGE# ← NEXTPNPAGE))
by (\ADDBASE BASE \MDSIncrement) until (IGREATERP NEXTPNPAGE LASTPNPAGE)
do (\NEW2PAGE BASE)
(\PUTBASEPTR BASE 0 PREV)
(SETQ PREV NEXTPNPAGE)
(add NEXTPNPAGE 2))
(SETQ \MDSFREELISTPAGE PREV)))])
(\SETUP.TYPENUM.TABLE
[LAMBDA (SIZELST GCTYPE PREFIX) (* bvm: " 7-Feb-85 18:24")
(bind TNAME DESCL DTD DTNUMBER [SLOTDESC ←(SELECTC GCTYPE
(PTRBLOCK.GCT (QUOTE POINTER))
(QUOTE (BITS 32]
(HUNKSIZE ← -1)
(SIZEL ← SIZELST)
(TABLE ←(\ALLOCBLOCK (FOLDHI (IPLUS 4 \MAX.CELLSPERHUNK)
BYTESPERCELL)
UNBOXEDBLOCK.GCT))
for I from 0 to \MAX.CELLSPERHUNK
do (COND
((IGREATERP I HUNKSIZE) (* Advance to next quantum range in the SIZELST)
(SETQ HUNKSIZE (OR (FIXP (pop SIZEL))
\MAX.CELLSPERHUNK))
(SETQ TNAME (PACK* PREFIX HUNKSIZE))
(SETQ DESCL (to HUNKSIZE collect SLOTDESC))
[COND
([AND (SETQ DTNUMBER (\TYPENUMBERFROMNAME TNAME))
(EQUAL DESCL (fetch DTDTYPESPECS of (SETQ DTD (\GETDTD DTNUMBER]
(* Perhaps we are setting up for the second time?)
)
(T (DECLAREDATATYPE TNAME DESCL)
[SETQ DTD (\GETDTD (SETQ DTNUMBER (\TYPENUMBERFROMNAME TNAME]
(* This is utterly useless: (push SYSTEMRECLST (LIST (QUOTE DATATYPE) TNAME (MAPCAR DESCL (FUNCTION
(LAMBDA (D) (CONS NIL (MKLIST SLOTDESC))))))))
]
(replace DTDGCTYPE of DTD with GCTYPE)
(replace DTDHUNKP of DTD with T)))
(\PUTBASEBYTE TABLE I DTNUMBER)
finally (RETURN TABLE])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \MAX.CELLSPERHUNK 64)
(CONSTANTS \MAX.CELLSPERHUNK)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \HUNK.UNBOXEDSIZES (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64 84 128))
(RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64 84 128))
(RPAQQ \HUNK.PTRSIZES (4 5 6 7 8 10 12 16 24 32 42 64 84 128))
(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES)
)
)
(RPAQ? \HUNKING? )
(RPAQ? \PNAMES.IN.BLOCKS? )
(RPAQ? \MDSFREELISTCOUNT 0)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \HUNKING? \PNAMES.IN.BLOCKS?)
)
(RPAQ? \UNBOXEDHUNK.TYPENUM.TABLE )
(RPAQ? \CODEHUNK.TYPENUM.TABLE )
(RPAQ? \PTRHUNK.TYPENUM.TABLE )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE \PTRHUNK.TYPENUM.TABLE)
)
(* "Turn it all on, during the BOOTEXPRS phase")
(DECLARE: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY
(\SETUPHUNKING)
)
(* "Debugging aids")
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \ArrayFrLst)
)
(DECLARE: EVAL@COMPILE
(RPAQQ \ArrayBlockPassword 5461)
(CONSTANTS \ArrayBlockPassword)
)
)
(DEFINEQ
(\HUNKFIT?
(LAMBDA (N) (* JonL "15-Jan-85 00:48")
(* Show how an MDS unit of 2 pages would accomodate
chunks of size N cells.)
(printout NIL T "Hunk size = " N " cells, " (IQUOTIENT (FOLDLO \MDSIncrement WORDSPERCELL)
N)
" fit in a MDS unit with "
(IREMAINDER (FOLDLO \MDSIncrement WORDSPERCELL)
N)
" cells left over." T .TAB 8 "('unit' is split with " (IREMAINDER CELLSPERPAGE N)
" cells kept on first page)" T)
T))
(\AB.NEXT
(LAMBDA (ABHI ABLO) (* JonL "10-Sep-84 05:04")
(* ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to "go" to the predecessor of;
alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.)
(* Returns a 4-list; size of the next block, whether or
not it is free, and the \HILOC and the \LOLOC of that
block)
(if (AND (LISTP ABHI)
(NULL ABLO))
then (if (AND (EQ 4 (LENGTH ABHI))
(FIXP (CAR ABHI))
(SELECTQ (CADR ABHI)
((INUSE FREE)
T)
NIL))
then (* Result is output of \AB.NEXT itself)
(SETQ ABHI (CDDR ABHI)))
(if (EQ 2 (LENGTH ABHI))
then (* A 2-list of \HILOC and \LOLOC)
(SETQ ABLO (CADR ABHI))
(SETQ ABHI (CAR ABHI)))
elseif (OR (EQ ABHI \ArrayFrLst)
(type? ARRAYBLOCK ABHI))
then (SETQ ABLO (\LOLOC ABHI))
(SETQ ABHI (\HILOC ABHI)))
(OR (IGEQ ABHI 0)
(ERROR "Negative segment number?" ABHI))
(AND (IGREATERP ABHI (\HILOC \ArrayFrLst))
(ERROR "Segment number too high?" ABHI))
(OR (IGEQ ABLO 0)
(ERROR "Negative offset number?" ABLO))
(PROG (PW SIZE SIZE.WORDS (ABADDR (\VAG2 ABHI ABLO)))
(PROGN (* Checking on current block)
(SETQ PW (\GETBASE ABADDR 0))
(if (NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
then (SETQ ABADDR)
(ERROR "Array Password not found at this loc" (LIST ABHI ABLO)))
(SETQ SIZE.WORDS (UNFOLD (SETQ SIZE (\GETBASE ABADDR 1))
WORDSPERCELL))
(if (NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 2))
3 13))
then (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO)
(SETQ ABADDR)))
elseif (NEQ SIZE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 1)))
then (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO)
(SETQ ABADDR)))))
(SETQ ABADDR (\ADDBASE ABADDR SIZE.WORDS))
(SETQ PW (\GETBASE ABADDR 0))
(if (NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
then (SETQ ABADDR)
(ERROR "Array Password not found at this loc" (LIST ABHI ABLO)))
(RETURN (LIST (\GETBASE ABADDR 1)
(if (ODDP PW)
then (QUOTE INUSE)
else (QUOTE FREE))
(\HILOC ABADDR)
(\LOLOC ABADDR))))))
(\AB.BACK
(LAMBDA (ABHI ABLO) (* JonL " 9-Sep-84 16:28")
(* ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to "go" to the predecessor of;
alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.)
(* Returns a 4-list; size of the block we are starting from, whether or not it is free, and the \HILOC and the
\LOLOC of the predecessor block)
(if (AND (LISTP ABHI)
(NULL ABLO))
then (if (AND (EQ 4 (LENGTH ABHI))
(FIXP (CAR ABHI))
(SELECTQ (CADR ABHI)
((INUSE FREE)
T)
NIL))
then (* Result is output of \AB.BACK itself)
(SETQ ABHI (CDDR ABHI)))
(if (EQ 2 (LENGTH ABHI))
then (* A 2-list of \HILOC and \LOLOC)
(SETQ ABLO (CADR ABHI))
(SETQ ABHI (CAR ABHI)))
elseif (OR (EQ ABHI \ArrayFrLst)
(type? ARRAYBLOCK ABHI))
then (SETQ ABLO (\LOLOC ABHI))
(SETQ ABHI (\HILOC ABHI)))
(OR (IGEQ ABHI 0)
(ERROR "Negative segment number?" ABHI))
(AND (IGREATERP ABHI (\HILOC \ArrayFrLst))
(ERROR "Segment number too high?" ABHI))
(OR (IGEQ ABLO 0)
(ERROR "Negative offset number?" ABLO))
(PROG (PW SIZE (ABADDR (\ADDBASE (\VAG2 ABHI ABLO)
-2)))
(SETQ PW (\GETBASE ABADDR 0))
(if (NEQ \ArrayBlockPassword (LOADBYTE PW 3 13))
then (SETQ ABADDR)
(ERROR "Array Password not found just below this" (LIST ABHI ABLO)))
(SETQ SIZE (\GETBASE ABADDR 1))
(SETQ ABADDR (\ADDBASE ABADDR (IMINUS (UNFOLD (SUB1 SIZE)
WORDSPERCELL))))
(if (NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR 0)
3 13))
then (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO)
(SETQ ABADDR)))
elseif (NEQ SIZE (\GETBASE ABADDR 1))
then (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO)
(SETQ ABADDR))))
(RETURN (LIST SIZE (if (ODDP PW)
then (QUOTE INUSE)
else (QUOTE FREE))
(\HILOC ABADDR)
(\LOLOC ABADDR))))))
)
(PUTPROPS LLHUNK COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1563 5347 (\ALLOCHUNK 1573 . 5345)) (5875 9123 (\SETUPHUNKING 5885 . 7520) (
\SETUP.TYPENUM.TABLE 7522 . 9121)) (10325 16556 (\HUNKFIT? 10335 . 10959) (\AB.NEXT 10961 . 13961) (
\AB.BACK 13963 . 16554)))))
STOP