(FILECREATED "10-Oct-86 00:42:21" {ERIS}<LISPCORE>SOURCES>D-ASSEM.;3 93034
changes to: (FUNCTIONS REF-VAR STORE-VAR INTERN-VAR STACK-ANALYZE STACK-ANALYZE-CODE)
previous date: " 6-Oct-86 23:50:05" {ERIS}<LISPCORE>SOURCES>D-ASSEM.;2)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT D-ASSEMCOMS)
(RPAQQ D-ASSEMCOMS ((COMS (* ;; "Data structures and utilities")
(STRUCTURES DCODE DJUMP DLAMBDA DTAG DVAR)
(P (DEFPRINT (QUOTE DTAG)
NIL))
(FUNCTIONS CREATE-HUNK TYPE-NAME-FROM-SIZE)
(FUNCTIONS RELEASE-CIRCULARITIES))
(COMS (* ;; "Handy constants")
(VARIABLES +IVAR-CODE+ +PVAR-CODE+ +FVAR-CODE+)
(VARIABLES +LAMBDA-SPREAD+ +NLAMBDA-SPREAD+ +LAMBDA-NO-SPREAD+
+NLAMBDA-NO-SPREAD+)
(VARIABLES +CONSTANT-OPCODES+))
(COMS (* ;; "Opcode generation")
(VARIABLES *BYTES* *BYTE-COUNT*)
(FUNCTIONS START-BYTES EMIT-BYTE EMIT-BYTE-LIST END-BYTES)
(FUNCTIONS CHOOSE-OP REF-VAR STORE-VAR MAX-ARG PUSH-INTEGER))
(COMS (* ;; "Main driving")
(VARIABLES *DTAG-ENV* *DVAR-ENV* *HUNK-MAP* *DCODE* *LEVEL*)
(FUNCTIONS ASSEMBLE-FUNCTION DCODE-FROM-DLAMBDA DLAMBDA-FROM-LAMBDA))
(COMS (* ;; "Digesting the function")
(VARIABLES *HUNK-SIZE* *PVAR-COUNT* *FREE-VARS* *BOUND-SPECIALS*)
(FUNCTIONS DIGEST-FUNCTION DIGEST-CODE STORE-DIGEST-INFO)
(FUNCTIONS DVAR-FROM-LAP-VAR LAP-VAR-ID INSTALL-LOCAL INSTALL-VAR
INTERN-VAR INTERN-TAG))
(COMS (* ;; "Function entry code")
(FUNCTIONS EASY-ENTRY-P GENERATE-EASY-ENTRY)
(FUNCTIONS GENERATE-HARD-ENTRY GENERATE-ARG-CHECK GENERATE-KEY
GENERATE-OPT-AND-REST))
(COMS (* ;; "Stack analysis")
(VARIABLES *ENDING-DEPTH* *STACK-NOTES*)
(FUNCTIONS STACK-ANALYZE STACK-ANALYZE-CODE))
(COMS (* ;; "The guts of assembly")
(FUNCTIONS ASSEMBLE ASSEMBLE-CODE))
(COMS (* ;; "Jump resolution")
(VARIABLES *JUMP-LIST*)
(VARIABLES +JUMP-CHOICES+ +JUMP-RANGE-SIZE-MAP+ +JUMP-SIZES+)
(FUNCTIONS RESOLVE-JUMPS REDUCE-UNCERTAINTY SPLICE-IN-JUMPS
COMPUTE-JUMP-SIZE)
(COMS (* ; "Debugging jump resolution")
(FUNCTIONS PRETTY-JUMPS)))
(COMS (* ;; "Conversion to binary")
(FUNCTIONS CONVERT-TO-BINARY))
(COMS (* ;; "Setting up the debugging information")
(FUNCTIONS COMPUTE-DEBUGGING-INFO))
(COMS (* ;; "Fixup resolution and DCODE interning")
(FUNCTIONS ALLOCATE-CODE-BLOCK FIXUP-PTR FIXUP-WORD INTERN-DCODE))
(PROP FILETYPE D-ASSEM)
(DECLARE: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
LLBASIC LLCODE LLGC MODARITH))))
(* ;; "Data structures and utilities")
(DEFSTRUCT DCODE (FRAME-NAME "No name") (NLOCALS 0)
(NFREEVARS 0)
ARG-TYPE
(NUM-ARGS 0)
(NAME-TABLE NIL)
DEBUGGING-INFO CODE-ARRAY (FN-FIXUPS NIL)
(SYM-FIXUPS NIL)
(LIT-FIXUPS NIL)
(TYPE-FIXUPS NIL)
(CLOSURE-P NIL))
(DEFSTRUCT DJUMP KIND TAG PTR MIN-PC MIN-SIZE FORWARD-P SIZE-UNCERTAINTY)
(DEFSTRUCT (DLAMBDA (:CONSTRUCTOR MAKE-DLAMBDA
(REQUIRED OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME BLIP CLOSED-OVER
NON-LOCAL BODY))) REQUIRED OPTIONAL REST KEY ALLOW-OTHER-KEYS
OTHERS NAME BLIP CLOSED-OVER NON-LOCAL BODY)
(DEFSTRUCT DTAG "LEVEL is the lexical level of this tag, for use by the stack analyzer.
STACK-DEPTH is a pair <binding-depth . depth> representing the state of the stack analyzer last time it was here.
PTR is the tail of the code list starting with this tag, used by the stack analyzer.
PC is the final location of this tag, after jump resolution.
MIN-PC is the least location at which this tag could end up, used during jump resolution.
PC-UNCERTAINTY is the amount of slack there is in the final location of this tag, used during jump resolution."
LEVEL STACK-DEPTH PTR PC MIN-PC PC-UNCERTAINTY)
(DEFSTRUCT DVAR KIND LEVEL SLOT NAME)
(DEFPRINT (QUOTE DTAG)
NIL)
(DEFUN CREATE-HUNK (HUNK-SIZE MY-SLOT PREV-SLOT POP-P) "Emit code to create a hunk of the given size and store it into PVAR my-slot. If prev-slot is non-NIL, also emit code to link the new hunk to the one in that slot. If pop-p is non-NIL then don't leave the hunk on the stack."
(EMIT-BYTE-LIST (BQUOTE (SICX (TYPE (\, (TYPE-NAME-FROM-SIZE HUNK-SIZE)))
CREATECELL
(\,@ (AND PREV-SLOT (BQUOTE ((\,@ (CHOOSE-OP (QUOTE (PVAR . PVARX))
PREV-SLOT))
RPLPTR.N 0))))
(\,@ (STORE-VAR MY-SLOT POP-P))))))
(DEFUN TYPE-NAME-FROM-SIZE (LEN) (PACK* (QUOTE \PTRHUNK)
(for HUNK-SIZE in \HUNK.PTRSIZES
do (CL:WHEN (<= LEN HUNK-SIZE)
(RETURN HUNK-SIZE))
finally (CL:ERROR "Can't make a hunk that big: ~S" LEN))))
(DEFUN RELEASE-CIRCULARITIES (CODE) "NIL out any circularities in the LAP code given."
(FOR INST IN CODE DO (CASE (CAR INST)
((TAG)
(SETF (DTAG-PTR (SECOND INST))
NIL)))))
(* ;; "Handy constants")
(DEFCONSTANT +IVAR-CODE+ 0 "Code in name-table for IVARs")
(DEFCONSTANT +PVAR-CODE+ 2 "Code in name-table for PVARs")
(DEFCONSTANT +FVAR-CODE+ 3 "Code in name-table for FVARs")
(DEFCONSTANT +LAMBDA-SPREAD+ 0 "ARGTYPE value for lambda spread functions")
(DEFCONSTANT +NLAMBDA-SPREAD+ 1 "ARGTYPE value for nlambda spread functions")
(DEFCONSTANT +LAMBDA-NO-SPREAD+ 2 "ARGTYPE value for lambda no-spread functions")
(DEFCONSTANT +NLAMBDA-NO-SPREAD+ 3 "ARGTYPE value for nlambda no-spread functions")
(DEFCONSTANT +CONSTANT-OPCODES+ (QUOTE ((0 . '0)
(1 . '1)
(NIL . 'NIL)
(T . 'T)))
"An AList of all constants with dedicated opcodes."
)
(* ;; "Opcode generation")
(DEFVAR *BYTES* NIL "The data-structure holding the bytes of the current function. Use (start-bytes) to create an empty one, (emit-byte) or (emit-op) to add more bytes on the end, and (end-bytes) to close it off and get an array of the bytes."
)
(DEFVAR *BYTE-COUNT* 0 "The number of bytes put on *bytes* so far.")
(DEFUN START-BYTES NIL NIL)
(DEFUN EMIT-BYTE (BYTE) (CL:IF (CONSP BYTE)
(CASE (CL:FIRST BYTE)
((TAG)
(SETF (DTAG-MIN-PC (SECOND BYTE))
*BYTE-COUNT*)
(CL:PUSH (SECOND BYTE)
*JUMP-LIST*))
((JUMP FJUMP TJUMP NFJUMP NTJUMP)
(CL:PUSH BYTE *BYTES*)
(CL:PUSH (MAKE-DJUMP :KIND (CL:FIRST BYTE)
:TAG
(SECOND BYTE)
:PTR *BYTES* :MIN-PC *BYTE-COUNT*)
*JUMP-LIST*) (*
"Increase the byte-count by the minimum size of this kind of jump.")
(INCF *BYTE-COUNT* (SECOND (CL:ASSOC (CL:FIRST BYTE)
+JUMP-SIZES+))))
((SYM FN TYPE)
(CL:PUSH BYTE *BYTES*)
(CL:PUSH 0 *BYTES*)
(INCF *BYTE-COUNT* 2))
((LAMBDA LIT)
(CL:PUSH BYTE *BYTES*)
(CL:PUSH 0 *BYTES*)
(CL:PUSH 0 *BYTES*)
(INCF *BYTE-COUNT* 3))
((ATOM) (* "ByteCompiler-style fixup, here because of a DOPVAL. The ByteCompiler put its fixup bytes AFTER the padding bytes, so we have to rearrange things in the byte list.")
(CL:POP *BYTES*)
(CL:PUSH (LIST (QUOTE SYM)
(CDR BYTE))
*BYTES*)
(CL:PUSH 0 *BYTES*)
(INCF *BYTE-COUNT*))
((PTR) (* "ByteCompiler-style fixup, here because of a DOPVAL. The ByteCompiler put its fixup bytes AFTER the padding bytes, so we have to rearrange things in the byte list.")
(CL:POP *BYTES*)
(CL:POP *BYTES*)
(CL:PUSH (LIST (QUOTE LIT)
(CDR BYTE))
*BYTES*)
(CL:PUSH 0 *BYTES*)
(CL:PUSH 0 *BYTES*)
(INCF *BYTE-COUNT*))
(OTHERWISE (CL:PUSH BYTE *BYTES*)
(INCF *BYTE-COUNT*)))
(PROGN (CL:PUSH BYTE *BYTES*)
(INCF *BYTE-COUNT*))))
(DEFUN EMIT-BYTE-LIST (L) (for BYTE in L do (EMIT-BYTE BYTE)))
(DEFUN END-BYTES NIL (CL:NREVERSE *BYTES*))
(DEFUN CHOOSE-OP (CHOICES ARG) (CL:IF (<= ARG (MAX-ARG (CAR CHOICES)))
(BQUOTE (((\, (CAR CHOICES))
(\, ARG))))
(BQUOTE ((\, (CDR CHOICES))
(\, (LLSH ARG 1))))))
(DEFUN REF-VAR (VAR)
"Return a list of instructions to push the given variable's value onto the stack."
(CL:IF (DVAR-P VAR)
(ECASE (DVAR-KIND VAR)
((:LOCAL)
(CHOOSE-OP (QUOTE (PVAR . PVARX))
(DVAR-SLOT VAR)))
((:ARGUMENT)
(CHOOSE-OP (QUOTE (IVAR . IVARX))
(DVAR-SLOT VAR)))
((:FREE)
(CHOOSE-OP (QUOTE (FVAR . FVARX))
(DVAR-SLOT VAR)))
((:CLOSED)
(LET* ((LEVEL (DVAR-LEVEL VAR))
(MAP-ENTRY (FIND ENTRY IN (CL:REVERSE *HUNK-MAP*)
SUCHTHAT (<= LEVEL (CAR ENTRY))))
(HUNK-LEVEL (CAR MAP-ENTRY))
(HUNK-SLOT (CDR MAP-ENTRY)))
(BQUOTE ((\,@ (CHOOSE-OP (QUOTE (PVAR . PVARX))
HUNK-SLOT))
(\,@ (FOR I FROM 1 TO (- HUNK-LEVEL LEVEL)
JOIN (LIST (QUOTE GETBASEPTR.N)
0)))
GETBASEPTR.N
(\, (LLSH (DVAR-SLOT VAR)
1)))))))
(CL:IF (AND (CONSP VAR)
(EQ (CL:FIRST VAR)
(QUOTE G)))
(BQUOTE (GVAR (SYM (\, (SECOND VAR)))))
(CL:ERROR "BUG: This variable is neither global nor a DVAR: ~S" VAR))))
(DEFUN STORE-VAR (VAR-OR-SLOT POP-P) "Return a list of instructions to store the value on the top of stack into the given variable. If a slot number is given instead, it is assumed to refer to a PVAR. If POP-P is non-NIL, don't leave the value on the stack."
(LET (KIND SLOT)
(ETYPECASE VAR-OR-SLOT (FIXNUM (CL:SETQ SLOT VAR-OR-SLOT)
(CL:SETQ KIND :LOCAL))
(CONS (CL:UNLESS (EQ (CL:FIRST VAR-OR-SLOT)
(QUOTE G))
(CL:ERROR "BUG: This variable is neither a global nor a DVAR: ~S"
VAR-OR-SLOT))
(CL:SETQ KIND :GLOBAL)
(CL:SETQ SLOT (SECOND VAR-OR-SLOT)))
(DVAR (CL:SETQ SLOT (DVAR-SLOT VAR-OR-SLOT))
(CL:SETQ KIND (DVAR-KIND VAR-OR-SLOT))))
(ECASE KIND ((:LOCAL)
(CL:IF POP-P (CL:IF (<= SLOT (MAX-ARG (QUOTE PVAR←↑)))
(BQUOTE ((PVAR←↑
(\, SLOT))))
(BQUOTE ((\,@ (CHOOSE-OP (QUOTE (PVAR← . PVARX←))
SLOT))
POP)))
(CHOOSE-OP (QUOTE (PVAR← . PVARX←))
SLOT)))
((:ARGUMENT)
(BQUOTE (IVARX← (\, (LLSH SLOT 1))
(\,@ (AND POP-P (QUOTE (POP)))))))
((:FREE)
(BQUOTE (FVARX← (\, (LLSH SLOT 1))
(\,@ (AND POP-P (QUOTE (POP)))))))
((:CLOSED)
(LET* ((LEVEL (DVAR-LEVEL VAR-OR-SLOT))
(MAP-ENTRY (FIND ENTRY IN (CL:REVERSE *HUNK-MAP*)
SUCHTHAT (<= LEVEL (CAR ENTRY))))
(HUNK-LEVEL (CAR MAP-ENTRY))
(HUNK-SLOT (CDR MAP-ENTRY)))
(BQUOTE ((\,@ (AND (NOT POP-P)
(QUOTE COPY)))
(\,@ (CHOOSE-OP (QUOTE (PVAR . PVARX))
HUNK-SLOT))
(\,@ (FOR I FROM 1 TO (- HUNK-LEVEL LEVEL)
JOIN (LIST (QUOTE GETBASEPTR.N)
0)))
SWAP RPLPTR.N (\, (LLSH SLOT 1))
POP))))
((:GLOBAL)
(BQUOTE (GVAR← (SYM (\, SLOT))))))))
(DEFUN MAX-ARG (OPCODE) (LET ((RANGE (fetch OP# OF (\FINDOP OPCODE))))
(- (SECOND RANGE)
(CL:FIRST RANGE))))
(DEFUN PUSH-INTEGER (N) (COND
((CL:ZEROP N)
(QUOTE ('0)))
((= N 1)
(QUOTE ('1)))
((<= -256 N -1)
(BQUOTE (SNIC (\, (+ N 256)))))
((<= 0 N 255)
(BQUOTE (SIC (\, N))))
((<= 255 N 65535)
(BQUOTE (SICX (\, (LRSH N 8))
(\, (LOGAND N 255)))))
(T (BQUOTE (GCONST (LIT (\, N)))))))
(* ;; "Main driving")
(DEFVAR *DTAG-ENV* NIL
"A hash-table mapping the EQL-unique ID of a LAP tag into the DTAG structure used by D-ASSEM.")
(DEFVAR *DVAR-ENV* NIL
"A hash-table mapping the EQL-unique ID of a LAP variable into the DVAR structure used by D-ASSEM.")
(DEFVAR *HUNK-MAP* NIL "An AList mapping lexical level numbers into the PVAR number of a slot in the current frame holding the hunk for that level."
)
(DEFVAR *DCODE* 0 "The currently-under-construction DCODE structure.")
(DEFVAR *LEVEL* 0 "The current lexical nesting level.")
(DEFUN ASSEMBLE-FUNCTION (LAP-FN) "LAP-FN is a LAP-format function description (a LAMBDA). Return the DCODE structure that results from assembling it into D-machine bytecodes."
(LET ((*DVAR-ENV* (MAKE-HASH-TABLE :TEST (QUOTE EQL)))
(*DTAG-ENV* (MAKE-HASH-TABLE :TEST (QUOTE EQL))))
(DCODE-FROM-DLAMBDA (DLAMBDA-FROM-LAMBDA (COPY-TREE LAP-FN))
0)))
(DEFUN DCODE-FROM-DLAMBDA (DLAMBDA LEVEL) "LEVEL is the length of the chain of hunks that will be passed to the result of assembling DLAMBDA at runtime."
(LET ((*DCODE* (MAKE-DCODE :FRAME-NAME (DLAMBDA-NAME DLAMBDA)))
(*HUNK-MAP* (AND (> LEVEL 0)
(BQUOTE (((\, LEVEL) . 0)))))
(*HUNK-SIZE* (CL:IF (> LEVEL 0)
1 0))
(*BYTES* (START-BYTES))
(*BYTE-COUNT* 0)
(*JUMP-LIST* NIL)
(*PVAR-COUNT* (CL:IF (> LEVEL 0)
1 0))
(*LEVEL* LEVEL)
(EASY-ENTRY (EASY-ENTRY-P DLAMBDA))) (* ;;
"Pass 0: Intern all of the variables and tags")
(DIGEST-FUNCTION DLAMBDA EASY-ENTRY) (* ;;
"Pass 1: Translate LAP code into opcodes and bytes.")
(CL:IF EASY-ENTRY (GENERATE-EASY-ENTRY DLAMBDA)
(GENERATE-HARD-ENTRY DLAMBDA))
(STACK-ANALYZE (DLAMBDA-BODY DLAMBDA))
(ASSEMBLE (DLAMBDA-BODY DLAMBDA))
(RELEASE-CIRCULARITIES (DLAMBDA-BODY DLAMBDA))
(EMIT-BYTE (QUOTE -X-))
(CL:SETQ *BYTES* (END-BYTES)) (* ;;
"Pass 1-1/2: Resolve the uncertainty in jump sizes and distances.")
(CL:UNLESS (NULL *JUMP-LIST*)
(RESOLVE-JUMPS (CL:REVERSE *JUMP-LIST*)))
(* ;; "Pass 2: Convert the byte-list into its final binary form and create the fixup lists. This pass also performs the recursion necessary to compile nested lambdas.")
(CONVERT-TO-BINARY *BYTES*) (* ;;
"Fill in the last few bits of the DCODE and quit.")
(COMPUTE-DEBUGGING-INFO DLAMBDA)
(SETF (DCODE-CLOSURE-P *DCODE*)
(CL:IF (NULL (DLAMBDA-NON-LOCAL DLAMBDA))
:FUNCTION :CLOSURE))
*DCODE*))
(DEFUN DLAMBDA-FROM-LAMBDA (LAP-FN)
"Break out the fields of a LAP lambda and return them in the form of a DLAMBDA structure."
(DESTRUCTURING-BIND ((REQUIRED &KEY OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME BLIP
CLOSED-OVER NON-LOCAL)
&REST BODY)
(CDR LAP-FN)
(MAKE-DLAMBDA REQUIRED OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME BLIP CLOSED-OVER
(CL:MAPCAR (CL:FUNCTION LAP-VAR-ID)
NON-LOCAL)
BODY)))
(* ;; "Digesting the function")
(DEFVAR *HUNK-SIZE* 0 "The number of hunk slots allocated so far.")
(DEFVAR *PVAR-COUNT* 0 "The number of PVAR allocated so far.")
(DEFVAR *FREE-VARS* NIL "An AList mapping DVARs for the free variables in a function into the number of times they're referenced in the function."
)
(DEFVAR *BOUND-SPECIALS* NIL "A list of the special variables bound in this frame.")
(DEFUN DIGEST-FUNCTION (DLAMBDA EASY-ENTRY)
(LET* ((CLOSED-OVER (DLAMBDA-CLOSED-OVER DLAMBDA))
(IVAR-COUNT 0)
(*FREE-VARS* NIL)
(*BOUND-SPECIALS* NIL)) (* ;;
"Allocate slots for the top-level hunk and the blip slot variable, if they're needed.")
(CL:WHEN (NOT (NULL (DLAMBDA-BLIP DLAMBDA)))
(* ;
"This can lead to a wasted PVAR0, but I'm not losing sleep over it.")
(INSTALL-VAR (DLAMBDA-BLIP DLAMBDA)
NIL :LOCAL 1)
(CL:SETQ *PVAR-COUNT* 2))
(CL:WHEN (NOT (NULL CLOSED-OVER))
(INCF *LEVEL*) (* ; "The lexical level just changed.")
(CL:PUSH (CONS *LEVEL* *PVAR-COUNT*)
*HUNK-MAP*)
(INCF *PVAR-COUNT*)) (* ;; "Intern the required parameters.")
(FOR TAIL ON (DLAMBDA-REQUIRED DLAMBDA) DO (SETF (CAR TAIL)
(INSTALL-VAR (CAR TAIL)
CLOSED-OVER :ARGUMENT IVAR-COUNT))
(INCF IVAR-COUNT))
(* ;;
"And then the optional parameters and their supplied-p colleagues.")
(FOR OPT-VAR IN (DLAMBDA-OPTIONAL DLAMBDA)
DO (COND
(EASY-ENTRY (SETF (CL:FIRST OPT-VAR)
(INSTALL-VAR (CL:FIRST OPT-VAR)
CLOSED-OVER :ARGUMENT IVAR-COUNT))
(INCF IVAR-COUNT))
(T (SETF (CL:FIRST OPT-VAR)
(INSTALL-LOCAL (CL:FIRST OPT-VAR)
CLOSED-OVER))
(DIGEST-CODE (SECOND OPT-VAR))
(SETF (THIRD OPT-VAR)
(INSTALL-LOCAL (THIRD OPT-VAR)
CLOSED-OVER)))))
(CL:WHEN EASY-ENTRY (SETF (DCODE-NUM-ARGS *DCODE*)
IVAR-COUNT)) (* ;; "Next comes the rest and keyword parameters.")
(CL:WHEN (NOT EASY-ENTRY)
(CL:WHEN (AND (NOT (NULL (DLAMBDA-REST DLAMBDA)))
(NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA))))
(SETF (DLAMBDA-REST DLAMBDA)
(INSTALL-LOCAL (DLAMBDA-REST DLAMBDA)
CLOSED-OVER)))
(FOR KEY-VAR IN (DLAMBDA-KEY DLAMBDA) DO (SETF (SECOND KEY-VAR)
(INSTALL-LOCAL (SECOND KEY-VAR)
CLOSED-OVER))
(DIGEST-CODE (THIRD KEY-VAR))
(SETF (FOURTH KEY-VAR)
(INSTALL-LOCAL (FOURTH KEY-VAR)
CLOSED-OVER))))
(* ;;
"Then intern any stragglers on the closed-over list.")
(FOR VAR IN CLOSED-OVER DO (CL:WHEN (AND (CONSP VAR)
(NULL (GETHASH (THIRD VAR)
*DVAR-ENV*)))
(SETF (GETHASH (THIRD VAR)
*DVAR-ENV*)
(MAKE-DVAR :KIND :CLOSED :SLOT *HUNK-SIZE* :LEVEL
*LEVEL* :NAME (SECOND VAR)))
(INCF *HUNK-SIZE*)))
(* ;;
"And, at long last, digest the body of the function.")
(DIGEST-CODE (DLAMBDA-BODY DLAMBDA)) (* ;;
"Record the results of this digestion (yecch...).")
(STORE-DIGEST-INFO)))
(DEFUN DIGEST-CODE (LAP-CODE)
(for TAIL on LAP-CODE
do (LET ((INST (CAR TAIL)))
(CASE (CL:FIRST INST)
((VAR VAR←)
(SETF (SECOND INST)
(INTERN-VAR (SECOND INST))))
((LAMBDA)
(SETF (CDR INST)
(CONS (DLAMBDA-FROM-LAMBDA INST)
NIL)))
((BIND) (* (CL:IF (AND (CONSP VAR)
(NULL (GETHASH (THIRD VAR) *DVAR-ENV*)))
(INSTALL-LOCAL VAR NIL)
(CL:ERROR
"Variable in BIND appeared earlier: ~S"
VAR)))
(FLET ((INSTALL-NEW (VAR)
(CL:IF (AND (CONSP VAR)
(NULL (GETHASH (THIRD VAR)
*DVAR-ENV*)))
(INSTALL-LOCAL VAR NIL)
(GETHASH (THIRD VAR)
*DVAR-ENV*))))
(SETF (SECOND INST)
(CL:MAPCAR (CL:FUNCTION INSTALL-NEW)
(SECOND INST)))
(SETF (THIRD INST)
(CL:MAPCAR (CL:FUNCTION INSTALL-NEW)
(THIRD INST)))))
((UNBIND DUNBIND)
(SETF (SECOND INST)
(CL:LENGTH (SECOND INST))
(THIRD INST)
(CL:LENGTH (THIRD INST))))
((TAG)
(SETF (SECOND INST)
(INTERN-TAG (SECOND INST)))
(SETF (DTAG-PTR (SECOND INST))
TAIL)
(SETF (DTAG-LEVEL (SECOND INST))
*LEVEL*))
((JUMP FJUMP TJUMP NFJUMP NTJUMP)
(SETF (SECOND INST)
(INTERN-TAG (SECOND INST))))
((CLOSE)
(LET ((*LEVEL* (1+ *LEVEL*))
(*HUNK-SIZE* (CL:IF (> *LEVEL* 0)
1 0))) (* "In setting up the new lexical environment, don't forget to leave a slot for linking the hunks together, if necessary.")
(LET ((DVARS (FOR VAR IN (SECOND INST)
COLLECT (SETF (GETHASH (THIRD VAR)
*DVAR-ENV*)
(MAKE-DVAR :KIND :CLOSED :SLOT *HUNK-SIZE*
:LEVEL *LEVEL* :NAME (SECOND VAR)))
(INCF *HUNK-SIZE*))))
(SETF (REST INST)
(LIST* DVARS *PVAR-COUNT* (CDDR INST))))
(INCF *PVAR-COUNT*) (* "Allocate a slot for the new hunk.")
(DIGEST-CODE (CDDR INST))))))))
(DEFUN STORE-DIGEST-INFO NIL (* ;; "This first bit gets the entries on the name-table in the right order by building the table backwards. The final order is PVARs, IVARs, FVARs with the PVARs and IVARs in reverse order. This lets the free variable lookup find the correct variable first.")
(LET ((FREE-VAR-ALIST (CL:SORT *FREE-VARS* (CL:FUNCTION <)
:KEY
(CL:FUNCTION CDR))))
(FOR PAIR IN FREE-VAR-ALIST AS SLOT
FROM (1- (+ (CL:LENGTH FREE-VAR-ALIST)
*PVAR-COUNT*)) BY -1
DO (CL:PUSH (LIST +FVAR-CODE+ SLOT (DVAR-NAME (CAR PAIR)))
(DCODE-NAME-TABLE *DCODE*))
(SETF (DVAR-SLOT (CAR PAIR))
SLOT)
(* ;
"While we're at this, assign slots to the free variables.")
))
(FOR DVAR IN (CL:NREVERSE *BOUND-SPECIALS*)
DO (CL:PUSH (LIST (ECASE (DVAR-KIND DVAR)
((:LOCAL)
+PVAR-CODE+)
((:ARGUMENT)
+IVAR-CODE+))
(DVAR-SLOT DVAR)
(DVAR-NAME DVAR))
(DCODE-NAME-TABLE *DCODE*)))
(* ;;
"Now to fill in some of the more mundane fields of the DCODE.")
(SETF (DCODE-NLOCALS *DCODE*)
*PVAR-COUNT*)
(SETF (DCODE-NFREEVARS *DCODE*)
(CL:LENGTH *FREE-VARS*)))
(DEFUN DVAR-FROM-LAP-VAR (LAP-VAR) (OR (GETHASH (LAP-VAR-ID LAP-VAR)
*DVAR-ENV*)
(CL:ERROR "The LAP var ~S should have been interned by now."
LAP-VAR)))
(DEFUN LAP-VAR-ID (VAR) (CL:IF (CONSP VAR)
(THIRD VAR)
VAR))
(DEFUN INSTALL-LOCAL (VAR CLOSED-OVER) (AND VAR (LET ((DVAR (INSTALL-VAR VAR CLOSED-OVER :LOCAL
*PVAR-COUNT*)))
(CL:WHEN (EQ :LOCAL (DVAR-KIND DVAR))
(INCF *PVAR-COUNT*))
DVAR)))
(DEFUN INSTALL-VAR (VAR CLOSED-OVER KIND SLOT)
(AND VAR (DESTRUCTURING-BIND (SCOPE NAME ID)
VAR
(COND
((CL:MEMBER ID CLOSED-OVER :KEY (CL:FUNCTION LAP-VAR-ID))
(PROG1 (SETF (GETHASH ID *DVAR-ENV*)
(MAKE-DVAR :KIND :CLOSED :SLOT *HUNK-SIZE* :LEVEL *LEVEL* :NAME
NAME))
(INCF *HUNK-SIZE*)))
(T (LET ((DVAR (SETF (GETHASH ID *DVAR-ENV*)
(MAKE-DVAR :KIND (CL:IF (EQ SCOPE (QUOTE F))
:FREE KIND)
:SLOT SLOT :NAME NAME))))
(CASE SCOPE ((S)
(CL:PUSH DVAR *BOUND-SPECIALS*))
((F)
(CL:PUSH (CONS DVAR 1)
*FREE-VARS*)))
DVAR))))))
(DEFUN INTERN-VAR (VAR) (CL:IF (CONSP VAR)
(CL:IF (EQ (CL:FIRST VAR)
(QUOTE G)) (* ; "Global vars don't get interned.")
VAR
(LET ((DVAR (GETHASH (THIRD VAR)
*DVAR-ENV*)))
(COND
((NOT (NULL DVAR))
(CL:WHEN (EQ :FREE (DVAR-KIND DVAR))
(INCF (CDR (CL:ASSOC DVAR *FREE-VARS*))))
DVAR)
(T (INSTALL-LOCAL VAR NIL)))))
(OR (GETHASH VAR *DVAR-ENV*)
(CL:ERROR "Unknown LAP variable ID: ~S" VAR))))
(DEFUN INTERN-TAG (ID) (OR (GETHASH ID *DTAG-ENV*)
(SETF (GETHASH ID *DTAG-ENV*)
(MAKE-DTAG))))
(* ;; "Function entry code")
(DEFUN EASY-ENTRY-P (DLAMBDA) (AND (OR (NULL (DLAMBDA-REST DLAMBDA))
(EQ :IGNORED (DLAMBDA-REST DLAMBDA)))
(NULL (DLAMBDA-KEY DLAMBDA))
(FOR OPT-VAR IN (DLAMBDA-OPTIONAL DLAMBDA)
ALWAYS (AND (CL:EQUAL (QUOTE ((CONST NIL)))
(SECOND OPT-VAR))
(NULL (THIRD OPT-VAR))))))
(DEFUN GENERATE-EASY-ENTRY (DLAMBDA)
(* * "Emit code to create the hunk for this level and leave it on top of stack. We'll use it in the processing of the arguments.")
(CL:WHEN (NOT (NULL (DLAMBDA-CLOSED-OVER DLAMBDA)))
(CREATE-HUNK *HUNK-SIZE* (CDAR *HUNK-MAP*)
(AND (> *LEVEL* 1)
0)
NIL))
(* * "The required and optional parameters are treated alike in the easy entry. If any of them are closed over, copy them into the hunk.")
(FOR DVAR IN (APPEND (DLAMBDA-REQUIRED DLAMBDA)
(CL:MAPCAR (CL:FUNCTION CL:FIRST)
(DLAMBDA-OPTIONAL DLAMBDA))) AS IVAR-COUNT FROM 0
DO (CL:WHEN (EQ :CLOSED (DVAR-KIND DVAR))
(EMIT-BYTE-LIST (BQUOTE ((\,@ (CHOOSE-OP (QUOTE (IVAR . IVARX))
IVAR-COUNT))
RPLPTR.N
(\, (LLSH (DVAR-SLOT DVAR)
1)))))))
(SETF (DCODE-ARG-TYPE *DCODE*)
+LAMBDA-SPREAD+))
(DEFUN GENERATE-HARD-ENTRY (DLAMBDA)
(LET ((NUM-REQUIRED (CL:LENGTH (DLAMBDA-REQUIRED DLAMBDA)))
(NUM-OPTIONAL (CL:LENGTH (DLAMBDA-OPTIONAL DLAMBDA))))
(* ;;
"Emit code to create the hunk for this level and store it away.")
(CL:WHEN (NOT (NULL (DLAMBDA-CLOSED-OVER DLAMBDA)))
(CREATE-HUNK *HUNK-SIZE* (CDAR *HUNK-MAP*)
(AND (> *LEVEL* 1)
0)
T)) (* ;;
"Generate a check for a bad number of arguments, unless there are no illegal values.")
(CL:UNLESS (AND (CL:ZEROP NUM-REQUIRED)
(OR (AND (DLAMBDA-REST DLAMBDA)
(NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA))))
(DLAMBDA-KEY DLAMBDA)))
(GENERATE-ARG-CHECK DLAMBDA)) (* ;; "Copy the closed required args to the hunk.")
(FOR DVAR IN (DLAMBDA-REQUIRED DLAMBDA) AS IVAR-COUNT FROM 0
DO (CL:WHEN (EQ :CLOSED (DVAR-KIND DVAR))
(EMIT-BYTE-LIST (BQUOTE ((\,@ (CHOOSE-OP (QUOTE (PVAR . PVARX))
(CDAR *HUNK-MAP*)))
(\,@ (CHOOSE-OP (QUOTE (IVAR . IVARX))
IVAR-COUNT))
RPLPTR.N
(\, (LLSH *HUNK-SIZE* 1))
POP)))))
(* ;;
"Generate code for the optional and rest arguments.")
(GENERATE-OPT-AND-REST DLAMBDA NUM-REQUIRED NUM-OPTIONAL)
(* ;; "Generate code for the keyword arguments.")
(GENERATE-KEY DLAMBDA NUM-REQUIRED NUM-OPTIONAL)
(* ;;
"Fill in some information in the DCODE structure.")
(SETF (DCODE-ARG-TYPE *DCODE*)
+LAMBDA-NO-SPREAD+
(DCODE-NUM-ARGS *DCODE*)
-1)))
(DEFUN GENERATE-ARG-CHECK (DLAMBDA) (* ;;;
"Generate code that signals an error if too few or too many arguments are given.")
(LET* ((MIN-ARGS (CL:LENGTH (DLAMBDA-REQUIRED DLAMBDA)))
(MAX-ARGS (AND (NULL (DLAMBDA-REST DLAMBDA))
(NULL (DLAMBDA-KEY DLAMBDA))
(+ MIN-ARGS (CL:LENGTH (DLAMBDA-OPTIONAL DLAMBDA)))))
(OK-TAG (MAKE-DTAG))
(BAD-TAG (MAKE-DTAG)))
(CL:IF (NULL MAX-ARGS)
(EMIT-BYTE-LIST (BQUOTE (MYARGCOUNT (\,@ (PUSH-INTEGER (1- MIN-ARGS)))
GREATERP
(TJUMP (\, OK-TAG))
(\,@ (PUSH-INTEGER MIN-ARGS))
'NIL FN2 (FN SI::ARGUMENT-ERROR)
POP
(TAG (\, OK-TAG)))))
(EMIT-BYTE-LIST (BQUOTE (MYARGCOUNT (\,@ (PUSH-INTEGER (1- MIN-ARGS)))
GREATERP
(FJUMP (\, BAD-TAG))
MYARGCOUNT
(\,@ (PUSH-INTEGER MAX-ARGS))
GREATERP
(FJUMP (\, OK-TAG))
(TAG (\, BAD-TAG))
(\,@ (PUSH-INTEGER MIN-ARGS))
(\,@ (PUSH-INTEGER MAX-ARGS))
FN2
(FN SI::ARGUMENT-ERROR)
POP
(TAG (\, OK-TAG))))))))
(DEFUN GENERATE-KEY (DLAMBDA NUM-REQUIRED NUM-OPTIONAL)
"Generate code to check for and default the keyword arguments."
(LET ((START (+ 1 NUM-REQUIRED NUM-OPTIONAL)))
(FOR TAIL ON (DLAMBDA-KEY DLAMBDA)
DO (DESTRUCTURING-BIND
(KEYWORD VAR CODE SVAR)
(CAR TAIL)
(LET ((FOUND-TAG (MAKE-DTAG))
(NEXT-TAG (MAKE-DTAG)))
(EMIT-BYTE-LIST (BQUOTE (ACONST (SYM (\, KEYWORD))
FINDKEY
(\, START)
(NTJUMP (\, FOUND-TAG)))))
(STACK-ANALYZE CODE 1)
(ASSEMBLE CODE) (* "Not there; compute the init-form.")
(EMIT-BYTE-LIST (BQUOTE ((\,@ (STORE-VAR VAR T))
(\,@ (AND SVAR (BQUOTE ('NIL (\,@ (STORE-VAR SVAR T)))))
)
(JUMP (\, NEXT-TAG))
(TAG (\, FOUND-TAG))
ARG0
(\,@ (STORE-VAR VAR T))
(\,@ (AND SVAR (BQUOTE ('T (\,@ (STORE-VAR SVAR T))))))
(TAG (\, NEXT-TAG))))))))))
(DEFUN GENERATE-OPT-AND-REST (DLAMBDA NUM-REQUIRED NUM-OPTIONAL)
(LET
((OPT-INIT-VALUES NIL)
(AFTER-OPTS-TAG (MAKE-DTAG))) (* ;; "OPT-INIT-VALUES will hold a list of lists (var svar tag . lap-code), one for each opt-var. These will be generated in order after we take care of the rest argument.")
(CL:UNLESS
(CL:ZEROP NUM-OPTIONAL) (* ;;
"Convert the arg-count into a count of remaining arguments.")
(EMIT-BYTE-LIST (BQUOTE (MYARGCOUNT (\,@ (AND (NOT (CL:ZEROP NUM-REQUIRED))
(BQUOTE ((\,@ (PUSH-INTEGER NUM-REQUIRED))
IDIFFERENCE)))))))
(* ;; "Generate the code for testing for each optional variable. If it's there, copy it to its slot and set the svar, if one exists. Otherwise, jump into the middle of the stream of init-form computations.")
(FOR TAIL ON (DLAMBDA-OPTIONAL DLAMBDA) AS IVAR-COUNT FROM (1+ NUM-REQUIRED)
DO (LET ((TAG (MAKE-DTAG)))
(DESTRUCTURING-BIND (VAR CODE SVAR)
(CAR TAIL)
(EMIT-BYTE-LIST (BQUOTE ((\,@ (AND (CDR TAIL)
(QUOTE (COPY))))
'0 EQ (TJUMP (\, TAG))
(\,@ (PUSH-INTEGER IVAR-COUNT))
ARG0
(\,@ (STORE-VAR VAR T))
(\,@ (AND SVAR (BQUOTE ('T (\,@ (STORE-VAR SVAR T))))
))
(\,@ (AND (CDR TAIL)
(QUOTE ('1 IDIFFERENCE)))))))
(CL:PUSH (LIST* VAR SVAR TAG CODE)
OPT-INIT-VALUES)))))(* ;;
"All of the &optionals were provided. Handle the &rest argument.")
(CL:WHEN (AND (DLAMBDA-REST DLAMBDA)
(NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA))))
(EMIT-BYTE-LIST (BQUOTE ('NIL MYARGCOUNT RESTLIST (\, (+ 1 NUM-REQUIRED NUM-OPTIONAL))
(\,@ (STORE-VAR (DLAMBDA-REST DLAMBDA)
T))))))
(* ;; "Compute the default values for the various optional parameters one after another. The testing code above jumps into the middle of this.")
(CL:UNLESS (CL:ZEROP NUM-OPTIONAL)
(EMIT-BYTE (BQUOTE (JUMP (\, AFTER-OPTS-TAG))))
(* ; "If we fall into this code, all of the optionals were provided, so jump around the default-value calculations.")
(FOR VARS-TAG-CODE IN (CL:NREVERSE OPT-INIT-VALUES)
DO (EMIT-BYTE (BQUOTE (TAG (\, (CADDR VARS-TAG-CODE)))))
(STACK-ANALYZE (CDDDR VARS-TAG-CODE)
1)
(ASSEMBLE (CDDDR VARS-TAG-CODE))
(EMIT-BYTE-LIST (STORE-VAR (CAR VARS-TAG-CODE)
T))
(CL:WHEN (CADR VARS-TAG-CODE) (* ; "There's an svar")
(EMIT-BYTE-LIST (BQUOTE ('NIL (\,@ (STORE-VAR (CADR VARS-TAG-CODE)
T)))))))
(CL:WHEN (AND (DLAMBDA-REST DLAMBDA)
(NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA))))
(* ;
"If not all of the optionals were there, then there can't be any &rest arguments.")
(EMIT-BYTE-LIST (BQUOTE ('NIL (\,@ (STORE-VAR (DLAMBDA-REST DLAMBDA)
T))))))
(EMIT-BYTE (BQUOTE (TAG (\, AFTER-OPTS-TAG)))))))
(* ;; "Stack analysis")
(DEFVAR *ENDING-DEPTH* NIL
"An AList mapping lexical level to the stack depth at exit from that level.")
(DEFVAR *STACK-NOTES* NIL "An AList mapping the IDs of NOTE-STACK directives into the absolute stack depth at that point in the code."
)
(DEFUN STACK-ANALYZE (CODE &OPTIONAL (EXPECTED-ENDING-DEPTH 0)) "Walk the given code annotating the tags in it with information about the stack and binding depth of control at that point."
(LET ((*LEVEL* *LEVEL*)
(*STACK-NOTES* NIL)
(*ENDING-DEPTH* (LIST (CONS *LEVEL* NIL))))
(STACK-ANALYZE-CODE CODE 0 NIL)
(LET ((ENDING-DEPTH (CDR (CL:FIRST *ENDING-DEPTH*))))
(CL:ASSERT (OR (NULL ENDING-DEPTH)
(= ENDING-DEPTH EXPECTED-ENDING-DEPTH))
NIL "Code doesn't leave stack empty!"))))
(DEFUN STACK-ANALYZE-CODE (CODE INIT-DEPTH INIT-BINDING-DEPTH) "Annotate the tags in CODE with the stack and binding depth at those points in execution, assuming that the stack depth is INIT-DEPTH and the binding depth is as in INIT-BINDING-DEPTH on entry to the code."
(LET ((DEPTH INIT-DEPTH)
(BINDING-DEPTH INIT-BINDING-DEPTH))
(FOR INST IN CODE DO (ECASE (CAR INST)
((TAG)
(COND
((NULL (DTAG-STACK-DEPTH (SECOND INST)))
(SETF (DTAG-STACK-DEPTH (SECOND INST))
(CONS BINDING-DEPTH DEPTH))
(CL:ASSERT (= *LEVEL* (DTAG-LEVEL (SECOND INST)))
NIL "Inconsistent level at tag ~S" (SECOND INST)))
(T (CL:ASSERT (CL:EQUAL (CONS BINDING-DEPTH DEPTH)
(DTAG-STACK-DEPTH (SECOND INST)))
NIL "Inconsistent stack depths at tag ~S"
(SECOND INST))
(RETURN-FROM STACK-ANALYZE-CODE))))
((JUMP)
(STACK-ANALYZE-CODE (DTAG-PTR (SECOND INST))
DEPTH BINDING-DEPTH)
(RETURN-FROM STACK-ANALYZE-CODE))
((FJUMP TJUMP)
(DECF DEPTH)
(STACK-ANALYZE-CODE (DTAG-PTR (SECOND INST))
DEPTH BINDING-DEPTH))
((NFJUMP NTJUMP)
(STACK-ANALYZE-CODE (DTAG-PTR (SECOND INST))
DEPTH BINDING-DEPTH)
(DECF DEPTH))
((VAR COPY CONST LAMBDA PUSH-TAG)
(INCF DEPTH))
((VAR← SWAP) (* ; "Net stack effect is zero.")
)
((POP)
(DECF DEPTH))
((NOTE-STACK)
(CL:PUSH (CONS (SECOND INST)
DEPTH)
*STACK-NOTES*))
((SET-STACK DSET-STACK)
(LET ((LOOKUP (CL:ASSOC (SECOND INST)
*STACK-NOTES*)))
(CL:WHEN (NULL LOOKUP)
(CL:ERROR "NOTE-STACK not seen before SET-STACK"))
(CL:SETQ DEPTH (SETF (SECOND INST)
(CDR LOOKUP)))
(WHILE (AND BINDING-DEPTH (>= (CDR (CL:FIRST BINDING-DEPTH)
)
DEPTH))
DO (CL:POP BINDING-DEPTH))
(CL:IF (EQ (QUOTE SET-STACK)
(CL:FIRST INST))
(INCF DEPTH))))
((BIND) (* "This takes into account the popping of some number of values into the variables and then the pushing of the binding mark(s).")
(DECF DEPTH (CL:LENGTH (SECOND INST)))
(CL:PUSH (CONS (FOURTH INST)
DEPTH)
BINDING-DEPTH)
(INCF DEPTH (MAX 1 (CL:FLOOR (+ (CL:LENGTH (THIRD INST))
14)
15))))
((UNBIND DUNBIND)
(CL:UNLESS (EQL (FOURTH INST)
(CAR (CL:FIRST BINDING-DEPTH)))
(CL:ERROR "Mismatched BIND and UNBIND."))
(CL:SETQ DEPTH (CDR (CL:POP BINDING-DEPTH)))
(CL:WHEN (EQ (QUOTE UNBIND)
(CL:FIRST INST))
(INCF DEPTH)))
((FN)
(DECF DEPTH (1- (THIRD INST))))
((RETURN)
(RETURN-FROM STACK-ANALYZE-CODE))
((CLOSE)
(LET* ((*LEVEL* (1+ *LEVEL*))
(*ENDING-DEPTH* (CONS (CONS *LEVEL* NIL)
*ENDING-DEPTH*)))
(STACK-ANALYZE-CODE (CDDDR INST)
DEPTH BINDING-DEPTH)
(CL:SETQ DEPTH (CDR (CL:FIRST *ENDING-DEPTH*)))
(CL:WHEN (NULL DEPTH)
(RETURN-FROM STACK-ANALYZE-CODE))))))
(LET ((LOOKUP (CL:ASSOC *LEVEL* *ENDING-DEPTH*)))
(CL:ASSERT (NOT (CDR LOOKUP))
NIL "Ran off end twice")
(CL:WHEN (NULL (CDR LOOKUP))
(SETF (CDR LOOKUP)
DEPTH)))))
(* ;; "The guts of assembly")
(DEFUN ASSEMBLE (LAP-CODE) (* ;;;
"Translate LAP code into D-machine bytecodes.")
(ASSEMBLE-CODE LAP-CODE 0 NIL))
(DEFUN ASSEMBLE-CODE (LAP-CODE DEPTH BINDING-DEPTH)
(* ;;;
"Translate LAP code into D-machine bytecodes.")
(CL:DO
((TAIL LAP-CODE (CDR TAIL))
INST)
((ENDP TAIL))
(CL:SETQ INST (CL:FIRST TAIL))
(MACROLET
((INCR (VAR &OPTIONAL (DELTA 1))
(BQUOTE (AND (\, VAR)
(CL:SETQ (\, VAR)
(+ (\, VAR)
(\, DELTA))))))
(DECR (VAR &OPTIONAL (DELTA 1))
(BQUOTE (AND (\, VAR)
(CL:SETQ (\, VAR)
(- (\, VAR)
(\, DELTA)))))))
(ECASE
(CAR INST)
((VAR)
(EMIT-BYTE-LIST (REF-VAR (SECOND INST)))
(INCR DEPTH))
((VAR←)
(EMIT-BYTE-LIST (STORE-VAR (SECOND INST)
(COND
((EQ (QUOTE POP)
(CL:FIRST (SECOND TAIL)))
(CL:SETQ TAIL (CDR TAIL))
(DECR DEPTH)
T)
(T NIL)))))
((COPY)
(EMIT-BYTE (QUOTE COPY))
(INCR DEPTH))
((SWAP)
(EMIT-BYTE (QUOTE SWAP)))
((CONST)
(LET* ((VALUE (SECOND INST))
(LOOKUP (CL:ASSOC VALUE +CONSTANT-OPCODES+)))
(COND
((NOT (NULL LOOKUP))
(EMIT-BYTE (CDR LOOKUP)))
((SYMBOLP VALUE)
(EMIT-BYTE-LIST (BQUOTE (ACONST (SYM (\, VALUE))))))
((INTEGERP VALUE)
(EMIT-BYTE-LIST (PUSH-INTEGER VALUE)))
(T (EMIT-BYTE-LIST (BQUOTE (GCONST (LIT (\, VALUE))))))))
(INCR DEPTH))
((LAMBDA)
(LET* ((DLAMBDA (SECOND INST))
(NON-LOCALS (DLAMBDA-NON-LOCAL DLAMBDA)))
(COND
((NULL NON-LOCALS)
(EMIT-BYTE-LIST (BQUOTE (GCONST (LAMBDA 1
(\, DLAMBDA))))))
(T (* "This will need to be a closure. Find our best hunk for it and construct a closure object around it and the lambda.")
(LET* ((LAMBDA-LEVEL (FIND VAR IN NON-LOCALS LARGEST (DVAR-LEVEL (
DVAR-FROM-LAP-VAR
VAR))
FINALLY (RETURN $$EXTREME)))
(MAP-ENTRY (FIND ENTRY IN (CL:REVERSE *HUNK-MAP*)
SUCHTHAT (>= (CAR ENTRY)
LAMBDA-LEVEL)))
(HUNK-LEVEL (CAR MAP-ENTRY))
(HUNK-SLOT (CDR MAP-ENTRY)))
(EMIT-BYTE-LIST (BQUOTE (SICX (TYPE COMPILED-CLOSURE)
CREATECELL GCONST (LAMBDA (\, HUNK-LEVEL)
(\, DLAMBDA))
RPLPTR.N 0 (\,@ (CHOOSE-OP (QUOTE (PVAR . PVARX
))
HUNK-SLOT))
RPLPTR.N 2))))))
(INCR DEPTH)))
((POP)
(EMIT-BYTE (QUOTE POP))
(DECR DEPTH))
((NOTE-STACK) (*
"Now a no-op; used during stack analysis.")
)
((SET-STACK DSET-STACK)
(LET ((DESIRED-DEPTH (SECOND INST)))
(COND
((NULL DEPTH) (*
"We don't know where the stack is now, so use the spanking new UNWIND opcode.")
(EMIT-BYTE-LIST (BQUOTE (UNWIND (UNWIND (\, (SECOND INST)))
(\, (CL:IF (EQ (QUOTE SET-STACK)
(CL:FIRST INST))
1 0)))))
(WHILE (AND BINDING-DEPTH (>= (CAR BINDING-DEPTH)
DESIRED-DEPTH)) DO (CL:POP BINDING-DEPTH)))
(T (LET ((UNBIND-OP (CL:IF (EQ (QUOTE SET-STACK)
(CL:FIRST INST))
(QUOTE UNBIND)
(QUOTE DUNBIND))))
(WHILE (AND BINDING-DEPTH (>= (CAR BINDING-DEPTH)
DESIRED-DEPTH)) DO (EMIT-BYTE UNBIND-OP)
(CL:SETQ DEPTH (CL:POP
BINDING-DEPTH
)))
(LET ((POPS (- DEPTH DESIRED-DEPTH)))
(CASE POPS ((0) (* "Already there. Done.")
)
((1)
(CL:IF (EQ UNBIND-OP (QUOTE UNBIND))
(EMIT-BYTE-LIST (QUOTE (SWAP POP)))
(EMIT-BYTE (QUOTE POP))))
(OTHERWISE (CL:IF (EQ UNBIND-OP (QUOTE UNBIND))
(EMIT-BYTE-LIST (BQUOTE
(STORE.N (\, (1- POPS))
POP.N
(\, (1- POPS)))))
(EMIT-BYTE-LIST (BQUOTE (POP.N (\, POPS))))))))
(CL:IF (EQ UNBIND-OP (QUOTE UNBIND))
(INCR DEPTH)))))))
((BIND)
(LABELS ((DO-BIND (NUM-VALUES NUM-NILS STARTING-SLOT)
(COND
((> NUM-VALUES 15)
(CL:ERROR "Too many values bound in a BIND: ~S" NUM-VALUES))
((> NUM-NILS 15)
(DO-BIND NUM-VALUES 15 STARTING-SLOT)
(DO-BIND 0 (- NUM-NILS 15)
(+ STARTING-SLOT NUM-VALUES 15)))
(T (EMIT-BYTE-LIST (BQUOTE (BIND (\, (+ (LLSH NUM-NILS 4)
NUM-VALUES))
(\, (1- (+ STARTING-SLOT NUM-VALUES
NUM-NILS))))))
(INCR DEPTH)))))
(LET* ((VALUES (SECOND INST))
(NUM-VALUES (CL:LENGTH VALUES))
(NILS (THIRD INST))
(NUM-NILS (CL:LENGTH NILS)))
(DECR DEPTH (+ NUM-VALUES NUM-NILS))
(CL:PUSH DEPTH BINDING-DEPTH)
(DO-BIND NUM-VALUES NUM-NILS (COND
(VALUES (DVAR-SLOT (CAR VALUES)))
(NILS (DVAR-SLOT (CAR NILS)))
(T 1))))))
((UNBIND DUNBIND)
(DOTIMES (I (CL:FLOOR (+ (SECOND INST)
(THIRD INST)
14)
15))
(EMIT-BYTE (CL:FIRST INST)))
(CL:SETQ DEPTH (CL:POP BINDING-DEPTH))
(CL:IF (EQ (CL:FIRST INST)
(QUOTE UNBIND))
(INCR DEPTH)))
((TAG)
(EMIT-BYTE (BQUOTE (TAG (\, (SECOND INST)))))
(LET ((STACK-DEPTH (DTAG-STACK-DEPTH (SECOND INST))))
(CL:SETQ DEPTH (CDR STACK-DEPTH))
(CL:SETQ BINDING-DEPTH (CL:MAPCAR (CL:FUNCTION CDR)
(CAR STACK-DEPTH)))))
((PUSH-TAG)
(EMIT-BYTE-LIST (PUSH-INTEGER (DTAG-PC (SECOND INST))))
(INCR DEPTH))
((JUMP TJUMP FJUMP NTJUMP NFJUMP)
(EMIT-BYTE INST)
(DECR DEPTH))
((FN)
(LET ((NAME (SECOND INST))
(NUM-ARGS (THIRD INST)))
(COND
((SYMBOLP NAME)
(LET ((DOPVAL (GET NAME (QUOTE DOPVAL))))
(COND
((NOT (NULL DOPVAL))
(CL:ASSERT (CONSP DOPVAL)
NIL "DOPVAL for ~S is not a list: ~S" NAME DOPVAL)
(FOR ITEM INSIDE (CL:IF (CL:ATOM (CAR DOPVAL))
(LIST DOPVAL)
DOPVAL) DO (COND
((CL:ATOM ITEM)
(FUNCALL ITEM)
(RETURN))
((OR (NULL (CAR ITEM))
(= (CAR ITEM)
NUM-ARGS))
(CL:MAPCAR (CL:FUNCTION EMIT-BYTE)
(CDR ITEM))
(RETURN)))
FINALLY (CL:ERROR "Illegal number of arguments to ~S: ~S" NAME NUM-ARGS))
)
(T (EMIT-BYTE-LIST (CASE NUM-ARGS ((0)
(QUOTE (FN0)))
((1)
(QUOTE (FN1)))
((2)
(QUOTE (FN2)))
((3)
(QUOTE (FN3)))
((4)
(QUOTE (FN4)))
(OTHERWISE (BQUOTE (FNX (\, NUM-ARGS))))))
(EMIT-BYTE (BQUOTE (FN (\, NAME))))))))
((AND (CONSP NAME)
(EQ :OPCODES (CAR NAME)))
(EMIT-BYTE-LIST (CDR NAME)))
(T (CL:ERROR "BUG: Weird argument to FN: ~S" NAME)))
(DECR DEPTH (1- NUM-ARGS))))
((RETURN)
(EMIT-BYTE (QUOTE RETURN)))
((CLOSE) (* ;
"After digestion, this looks like this:")
(* ; "(CLOSE dvars hunk-slot . code).")
(CREATE-HUNK (CL:LENGTH (SECOND INST))
(THIRD INST)
(CDAR *HUNK-MAP*)
T)
(LET* ((*LEVEL* (1+ *LEVEL*))
(*HUNK-MAP* (CONS (CONS *LEVEL* (THIRD INST))
*HUNK-MAP*)))
(ASSEMBLE-CODE (CDDDR INST)
DEPTH BINDING-DEPTH)))))))
(* ;; "Jump resolution")
(DEFVAR *JUMP-LIST* NIL "A list of DJUMP and DTAG structures for use by jump resolution.")
(DEFCONSTANT +JUMP-CHOICES+ (QUOTE ((JUMP JUMPX JUMPXX)
(FJUMP FJUMPX (TJUMP 2))
(TJUMP TJUMPX (FJUMP 2))
(NFJUMP NFJUMPX)
(NTJUMP NTJUMPX))) "AList from kinds of jumps to lists of choices for implementation of that kind of jump. See SPLICE-IN-JUMPS for details."
)
(DEFCONSTANT +JUMP-RANGE-SIZE-MAP+ (QUOTE ((JUMP (-128 . 3)
(2 . 2)
(18 . 1)
(128 . 2)
(32768 . 3))
(FJUMP (-128 . 4)
(2 . 2)
(18 . 1)
(128 . 2)
(32768 . 4))
(TJUMP (-128 . 4)
(2 . 2)
(18 . 1)
(128 . 2)
(32768 . 4))
(NFJUMP (-128 . 6)
(128 . 2)
(32768 . 6))
(NTJUMP (-128 . 6)
(128 . 2)
(32768 . 6)))) "An AList mapping kinds of jumps into an range-to-size table. The table is a list of pairs, sorted on the CAR. The shortest jump for a given distance is the CDR of the first pair whose CAR is strictly greater than the distance."
)
(DEFCONSTANT +JUMP-SIZES+ (QUOTE ((JUMP 1 3)
(FJUMP 1 4)
(TJUMP 1 4)
(NFJUMP 2 6)
(NTJUMP 2 6)))
"AList mapping kinds of jumps into the range of sizes for that kind, in bytes."
)
(DEFUN RESOLVE-JUMPS (JUMP-LIST) (bind (CUMULATIVE-UNCERTAINTY ← 0) for JUMP-OR-TAG in JUMP-LIST
do (ETYPECASE JUMP-OR-TAG (DTAG (SETF (DTAG-PC-UNCERTAINTY
JUMP-OR-TAG)
CUMULATIVE-UNCERTAINTY))
(DJUMP (LET ((RANGE (CL:ASSOC (DJUMP-KIND JUMP-OR-TAG)
+JUMP-SIZES+)))
(SETF (DJUMP-FORWARD-P JUMP-OR-TAG)
(> (DTAG-MIN-PC (DJUMP-TAG
JUMP-OR-TAG))
(DJUMP-MIN-PC JUMP-OR-TAG)))
(SETF (DJUMP-MIN-SIZE JUMP-OR-TAG)
(SECOND RANGE))
(INCF CUMULATIVE-UNCERTAINTY
(SETF (DJUMP-SIZE-UNCERTAINTY
JUMP-OR-TAG)
(- (THIRD RANGE)
(SECOND RANGE))))))))
(WHILE (REDUCE-UNCERTAINTY JUMP-LIST))
(SPLICE-IN-JUMPS JUMP-LIST))
(DEFUN REDUCE-UNCERTAINTY (JUMP-LIST)
(LET ((DECREASE-IN-UNCERTAINTY 0)
(INCREASE-IN-MIN-PC 0)
(CUMULATIVE-UNCERTAINTY 0))
(FOR JUMP-OR-TAG IN JUMP-LIST
DO (ETYPECASE JUMP-OR-TAG (DTAG (*
"Just record the current uncertainty at this tag.")
(SETF (DTAG-PC-UNCERTAINTY JUMP-OR-TAG)
CUMULATIVE-UNCERTAINTY)
(INCF (DTAG-MIN-PC JUMP-OR-TAG)
INCREASE-IN-MIN-PC))
(DJUMP (INCF (DJUMP-MIN-PC JUMP-OR-TAG)
INCREASE-IN-MIN-PC)
(CL:WHEN (> (DJUMP-SIZE-UNCERTAINTY JUMP-OR-TAG)
0) (*
"This is a jump we can hope to improve.")
(LET ((TAG (DJUMP-TAG JUMP-OR-TAG))
(KIND (DJUMP-KIND JUMP-OR-TAG))
(JUMP JUMP-OR-TAG)
MIN-DISTANCE MAX-DISTANCE MIN-SIZE MAX-SIZE)
(COND
((DJUMP-FORWARD-P JUMP)
(* "In computing the min and max distance between a forward jump and its tag, we must adjust for the changes we've made so far this pass.")
(CL:SETQ MIN-DISTANCE (+ (- (DTAG-MIN-PC TAG)
(DJUMP-MIN-PC JUMP))
INCREASE-IN-MIN-PC))
(CL:SETQ MAX-DISTANCE (+ (- (DTAG-PC-UNCERTAINTY TAG)
(+ DECREASE-IN-UNCERTAINTY
CUMULATIVE-UNCERTAINTY))
MIN-DISTANCE)))
(T (*
"This situation is much simpler with backward jumps since both tag and jump are in the same units.")
(CL:SETQ MIN-DISTANCE (- (DTAG-MIN-PC TAG)
(DJUMP-MIN-PC JUMP)))
(CL:SETQ MAX-DISTANCE (+ (- (DTAG-PC-UNCERTAINTY TAG)
CUMULATIVE-UNCERTAINTY)
MIN-DISTANCE))))
(CL:SETQ MIN-SIZE (COMPUTE-JUMP-SIZE KIND MIN-DISTANCE))
(CL:SETQ MAX-SIZE (COMPUTE-JUMP-SIZE KIND MAX-DISTANCE))
(CL:WHEN (> MIN-SIZE (DJUMP-MIN-SIZE JUMP))
(INCF INCREASE-IN-MIN-PC (- MIN-SIZE (DJUMP-MIN-SIZE
JUMP)))
(SETF (DJUMP-MIN-SIZE JUMP)
MIN-SIZE))
(LET ((NEW-SIZE-UNCERTAINTY (- MAX-SIZE MIN-SIZE)))
(CL:WHEN (/= (DJUMP-SIZE-UNCERTAINTY JUMP)
NEW-SIZE-UNCERTAINTY)
(CL:ASSERT (>= NEW-SIZE-UNCERTAINTY 0)
NIL "The size uncertainty went negative")
(INCF DECREASE-IN-UNCERTAINTY (- (
DJUMP-SIZE-UNCERTAINTY
JUMP)
NEW-SIZE-UNCERTAINTY
))
(SETF (DJUMP-SIZE-UNCERTAINTY JUMP)
NEW-SIZE-UNCERTAINTY))
(INCF CUMULATIVE-UNCERTAINTY NEW-SIZE-UNCERTAINTY)))))))
(* * "If we've either got no uncertainty left in the system or didn't manage to achieve anything this pass, give it up; we're done.")
(NOT (OR (CL:ZEROP CUMULATIVE-UNCERTAINTY)
(CL:ZEROP DECREASE-IN-UNCERTAINTY)))))
(DEFUN SPLICE-IN-JUMPS (JUMP-LIST)
(for JUMP in JUMP-LIST
do (CL:IF (DTAG-P JUMP)
(SETF (DTAG-PC JUMP)
(DTAG-MIN-PC JUMP))
(LET* ((PTR (DJUMP-PTR JUMP))
(TAG (DJUMP-TAG JUMP))
(DISTANCE (- (DTAG-MIN-PC TAG)
(DJUMP-MIN-PC JUMP)))
(KIND (DJUMP-KIND JUMP))
(SIZE (COMPUTE-JUMP-SIZE KIND DISTANCE))
(CHOICES (CL:ASSOC KIND +JUMP-CHOICES+)))
(ECASE SIZE ((1) (*
"One-byte jumps: JUMP, TJUMP, and FJUMP")
(RPLACA PTR (LIST KIND (- DISTANCE 2))))
((2) (*
"Two-byte-jumps: JUMPX, FJUMPX, TJUMPX, NTJUMPX, and NFJUMPX")
(RPLNODE PTR (SECOND CHOICES)
(CONS (CL:IF (< DISTANCE 0)
(+ DISTANCE 256)
DISTANCE)
(CDR PTR))))
((3 4) (*
"The three-byte jump is JUMPXX. Four-byte jumps are like (FJUMP 4) JUMPXX to implement TJUMPXX.")
(CL:IF (= SIZE 3)
(RPLACA PTR (THIRD CHOICES))
(RPLNODE PTR (THIRD CHOICES)
(CL:SETQ PTR (CONS (QUOTE JUMPXX)
(CDR PTR)))))
(RPLACD PTR (CONS (LOGAND (LRSH DISTANCE 8)
255)
(CONS (LOGAND DISTANCE 255)
(CDR PTR)))))
((6) (*
"Six-byte jumps are long NCJUMPXX's implemented by NCJUMPX 3 (JUMP 4) JUMPXX")
(RPLNODE PTR (SECOND CHOICES)
(BQUOTE (3 (JUMP 4)
JUMPXX
(\, (LRSH (- DISTANCE 3)
8))
(\, (LOGAND (- DISTANCE 3)
255))
(\,@ (CDR PTR)))))))))))
(DEFUN COMPUTE-JUMP-SIZE (KIND DISTANCE) (LET ((PAIRS (CL:ASSOC KIND +JUMP-RANGE-SIZE-MAP+)))
(FIND PAIR IN (CDR PAIRS)
SUCHTHAT (< DISTANCE (CAR PAIR))
FINALLY (RETURN (CDR PAIR)))))
(* ; "Debugging jump resolution")
(DEFUN PRETTY-JUMPS NIL (for JUMP-OR-TAG in (CL:REVERSE *JUMP-LIST*)
collect (ETYPECASE JUMP-OR-TAG (DTAG (BQUOTE (TAG :MIN-PC
(\, (DTAG-MIN-PC
JUMP-OR-TAG))
:PC-UNCERTAINTY
(\, (DTAG-PC-UNCERTAINTY
JUMP-OR-TAG)))))
(DJUMP (BQUOTE ((\, (DJUMP-KIND JUMP-OR-TAG))
:MIN-PC
(\, (DJUMP-MIN-PC JUMP-OR-TAG))
:MIN-SIZE
(\, (DJUMP-MIN-SIZE JUMP-OR-TAG))
:FORWARD-P
(\, (DJUMP-FORWARD-P JUMP-OR-TAG))
:SIZE-UNCERTAINTY
(\, (DJUMP-SIZE-UNCERTAINTY JUMP-OR-TAG))
:TAG
(:MIN-PC (\, (DTAG-MIN-PC (DJUMP-TAG
JUMP-OR-TAG
))))))))))
(* ;; "Conversion to binary")
(DEFUN CONVERT-TO-BINARY (BYTE-LIST)
(LET* ((CODELEN (CL:LENGTH BYTE-LIST))
(CODE-ARRAY (MAKE-ARRAY CODELEN :ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 8))))
(UNWIND-OFFSET (+ (CEIL (+ (DCODE-NLOCALS *DCODE*)
(DCODE-NFREEVARS *DCODE*))
CELLSPERQUAD)
CELLSPERQUAD)))
(FOR BYTE IN BYTE-LIST AS CODE-INDEX FROM 0
DO (SETF (AREF CODE-ARRAY CODE-INDEX)
(ETYPECASE BYTE (FIXNUM BYTE)
(SYMBOL (FETCH OP# OF (\FINDOP BYTE)))
(CONS (CASE (CL:FIRST BYTE)
((SYM)
(CL:PUSH (LIST CODE-INDEX (SECOND BYTE))
(DCODE-SYM-FIXUPS *DCODE*))
0)
((LIT)
(CL:PUSH (LIST CODE-INDEX (SECOND BYTE))
(DCODE-LIT-FIXUPS *DCODE*))
0)
((FN)
(CL:PUSH (LIST CODE-INDEX (SECOND BYTE))
(DCODE-FN-FIXUPS *DCODE*))
0)
((TYPE)
(CL:PUSH (LIST CODE-INDEX (SECOND BYTE))
(DCODE-TYPE-FIXUPS *DCODE*))
0)
((LAMBDA)
(CL:PUSH (LIST CODE-INDEX (DCODE-FROM-DLAMBDA (THIRD BYTE)
(SECOND BYTE)))
(DCODE-LIT-FIXUPS *DCODE*))
0)
((UNWIND)
(+ UNWIND-OFFSET (SECOND BYTE)))
(OTHERWISE (+ (CAR (FETCH OP# OF (\FINDOP (CL:FIRST BYTE))))
(SECOND BYTE))))))))
(SETF (DCODE-CODE-ARRAY *DCODE*)
CODE-ARRAY)))
(* ;; "Setting up the debugging information")
(DEFUN COMPUTE-DEBUGGING-INFO (DLAMBDA)
(SETF (DCODE-DEBUGGING-INFO *DCODE*)
(BQUOTE (((\,@ (CL:MAPCAR (CL:FUNCTION DVAR-NAME)
(DLAMBDA-REQUIRED DLAMBDA)))
(\,@ (AND (DLAMBDA-OPTIONAL DLAMBDA)
(CONS (QUOTE &OPTIONAL)
(CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (OPT-VAR)
(DVAR-NAME (CL:FIRST OPT-VAR))))
(DLAMBDA-OPTIONAL DLAMBDA)))))
(\,@ (AND (DLAMBDA-REST DLAMBDA)
(NEQ :IGNORED (DLAMBDA-REST DLAMBDA))
(LIST (QUOTE &REST)
(DVAR-NAME (DLAMBDA-REST DLAMBDA)))))
(\,@ (AND (DLAMBDA-KEY DLAMBDA)
(CONS (QUOTE &KEY)
(CL:MAPCAR (CL:FUNCTION CL:FIRST)
(DLAMBDA-KEY DLAMBDA)))))
(\,@ (AND (DLAMBDA-ALLOW-OTHER-KEYS DLAMBDA)
(QUOTE (&ALLOW-OTHER-KEYS)))))))))
(* ;; "Fixup resolution and DCODE interning")
(DEFUN ALLOCATE-CODE-BLOCK (NT-COUNT CODE-LEN) "Return a code-array that is large enough to hold a compiled function with a name-table NT-COUNT entries long and with CODE-LEN bytecodes. Also return, as a second value, the index in that code-array of the place to put the first bytecode."
(* (START-PC (CL:* (+
(FETCH (CODEARRAY OVERHEADWORDS) OF T)
NT-WORDS WORDSPERCELL) BYTESPERWORD)))
(LET* ((NT-SIZE (CEIL (1+ NT-COUNT)
WORDSPERQUAD))
(NT-WORDS (CL:IF (CL:ZEROP NT-COUNT)
WORDSPERQUAD
(+ NT-SIZE NT-SIZE)))
(START-PC (CL:* (+ (FETCH (CODEARRAY OVERHEADWORDS) OF T)
NT-WORDS WORDSPERCELL)
BYTESPERWORD))
(TOTAL-SIZE (CEIL (+ START-PC CODE-LEN)
BYTESPERQUAD))
(CODE-BASE (\ALLOC.CODE.BLOCK TOTAL-SIZE (CEIL (1+ (CEILING START-PC BYTESPERCELL))
CELLSPERQUAD))))
(VALUES CODE-BASE START-PC)))
(DEFUN FIXUP-PTR (BASE OFFSET PTR) (LET ((LOW (\LOLOC PTR)))
(UNINTERRUPTABLY
(\ADDREF PTR)
(\PUTBASEBYTE BASE OFFSET (\HILOC PTR))
(\PUTBASEBYTE BASE (+ 1 OFFSET)
(LRSH LOW 8))
(\PUTBASEBYTE BASE (+ 2 OFFSET)
(LOGAND LOW 255)))
PTR))
(DEFUN FIXUP-WORD (BASE OFFSET WORD) (\PUTBASEBYTE BASE OFFSET (LRSH WORD 8))
(\PUTBASEBYTE BASE (1+ OFFSET)
(LOGAND WORD 255))
WORD)
(DEFUN INTERN-DCODE (DCODE &OPTIONAL (COPY-P (CL:ARRAYP (DCODE-CODE-ARRAY DCODE))))
(* ;;; "NOTE: For unfortunately unavoidable performance reasons, this code is essentially duplicated in the FASL loader. If you change something here, change it there as well. And don't change anything unless you've got a pointy hat with a lot of stars on it.")
(* ;; "NTSIZE and NTBYTESIZE are the length of one-half of the name table in words and bytes, respectively. NTWORDS is the length of the whole name table in words.")
(LET* ((NAME-TABLE (DCODE-NAME-TABLE DCODE))
(NTSIZE (CEIL (1+ (CL:LENGTH NAME-TABLE))
WORDSPERQUAD))
(NTBYTESIZE (CL:* NTSIZE BYTESPERWORD))
(NTWORDS (CL:IF (CL:ZEROP (CL:LENGTH NAME-TABLE))
WORDSPERQUAD
(+ NTSIZE NTSIZE)))
(OVERHEADBYTES (CL:* (fetch (FNHEADER OVERHEADWORDS) of T)
BYTESPERWORD))
RAW-CODE FVAROFFSET) (* ;;
"Copy the bytes into a raw code block if necessary.")
(CL:IF (NULL COPY-P)
(CL:SETQ RAW-CODE (DCODE-CODE-ARRAY DCODE))
(LET ((CODE-ARRAY (DCODE-CODE-ARRAY DCODE)))
(MULTIPLE-VALUE-BIND (CODE-BLOCK START-INDEX)
(ALLOCATE-CODE-BLOCK (CL:LENGTH NAME-TABLE)
(CL:LENGTH CODE-ARRAY))
(for CA-INDEX from 0 to (1- (CL:LENGTH CODE-ARRAY)) as CB-INDEX
from START-INDEX do (\PUTBASEBYTE CODE-BLOCK CB-INDEX (AREF CODE-ARRAY
CA-INDEX))
)
(CL:SETQ RAW-CODE CODE-BLOCK))))
(* ;; "Set up the free-variable lookup name table.")
(CL:DO ((END (CL:LENGTH NAME-TABLE))
(I 0 (1+ I))
(INDEX OVERHEADBYTES (+ INDEX BYTESPERWORD)))
((>= I END))
(LET ((ENTRY (CL:ELT NAME-TABLE I)))
(FIXUP-WORD RAW-CODE INDEX (\LOLOC (THIRD ENTRY)))
(FIXUP-WORD RAW-CODE (+ INDEX NTBYTESIZE)
(+ (LLSH (CL:FIRST ENTRY)
14)
(SECOND ENTRY)))
(CL:WHEN (AND (NULL FVAROFFSET)
(= (CL:FIRST ENTRY)
+FVAR-CODE+))
(CL:SETQ FVAROFFSET (CL:FLOOR INDEX BYTESPERWORD)))))
(* ;;
"Fill in the fixed-size fields at the front of the block.")
(replace (FNHEADER NA) of RAW-CODE with (DCODE-NUM-ARGS DCODE))
(replace (FNHEADER PV) of RAW-CODE with (1- (CEILING (+ (DCODE-NLOCALS DCODE)
(DCODE-NFREEVARS DCODE))
CELLSPERQUAD)))
(* ;; "The start-pc is after the fixed-size stuff, the name-table, and a cell in which to store the debugging info.")
(replace (FNHEADER STARTPC) of RAW-CODE with (+ OVERHEADBYTES (CL:* NTWORDS BYTESPERWORD)
BYTESPERCELL))
(replace (FNHEADER ARGTYPE) of RAW-CODE with (DCODE-ARG-TYPE DCODE))
(LET ((FRAME-NAME (DCODE-FRAME-NAME DCODE)))
(UNINTERRUPTABLY
(\ADDREF FRAME-NAME)
(replace (FNHEADER #FRAMENAME) of RAW-CODE with FRAME-NAME)))
(replace (FNHEADER NTSIZE) of RAW-CODE with NTSIZE)
(replace (FNHEADER NLOCALS) of RAW-CODE with (DCODE-NLOCALS DCODE))
(replace (FNHEADER FVAROFFSET) of RAW-CODE with (OR FVAROFFSET 0))
(replace (FNHEADER CLOSUREP) of RAW-CODE with (EQ :CLOSURE (DCODE-CLOSURE-P DCODE)))
(replace (FNHEADER FIXED) of RAW-CODE with T)
(* ;; "Fill in the debugging information and perform the fixups. The + 1 here is to allow for the fact that four bytes are allocated for the debugging information, but pointers are only three bytes long, so we right-justify the pointer in the cell.")
(FIXUP-PTR RAW-CODE (+ 1 OVERHEADBYTES (CL:* NTWORDS BYTESPERWORD))
(DCODE-DEBUGGING-INFO DCODE))
(LET ((START-PC (fetch (FNHEADER STARTPC) of RAW-CODE)))
(CL:DO ((END (CL:LENGTH (DCODE-FN-FIXUPS DCODE)))
(I 0 (1+ I)))
((>= I END))
(DESTRUCTURING-BIND (OFFSET ITEM)
(CL:ELT (DCODE-FN-FIXUPS DCODE)
I)
(FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
(\LOLOC ITEM))))
(CL:DO ((END (CL:LENGTH (DCODE-SYM-FIXUPS DCODE)))
(I 0 (1+ I)))
((>= I END))
(DESTRUCTURING-BIND (OFFSET ITEM)
(CL:ELT (DCODE-SYM-FIXUPS DCODE)
I)
(FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
(\LOLOC ITEM))))
(CL:DO ((END (CL:LENGTH (DCODE-LIT-FIXUPS DCODE)))
(I 0 (1+ I)))
((>= I END))
(DESTRUCTURING-BIND (OFFSET ITEM)
(CL:ELT (DCODE-LIT-FIXUPS DCODE)
I)
(FIXUP-PTR RAW-CODE (+ START-PC OFFSET)
(CL:IF (DCODE-P ITEM)
(INTERN-DCODE ITEM)
ITEM))))
(CL:DO ((END (CL:LENGTH (DCODE-TYPE-FIXUPS DCODE)))
(I 0 (1+ I)))
((>= I END))
(DESTRUCTURING-BIND (OFFSET ITEM)
(CL:ELT (DCODE-TYPE-FIXUPS DCODE)
I)
(FIXUP-WORD RAW-CODE (+ START-PC OFFSET)
(\RESOLVE.TYPENUMBER ITEM)))))
(* ;;
"Finally, wrap this up in a closure-object if desired.")
(CL:IF (EQ :FUNCTION (DCODE-CLOSURE-P DCODE))
(MAKE-COMPILED-CLOSURE RAW-CODE NIL)
RAW-CODE)))
(PUTPROPS D-ASSEM FILETYPE COMPILE-FILE)
(DECLARE: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
LLBASIC LLCODE LLGC MODARITH)
)
(PUTPROPS D-ASSEM COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP