;;; -*- Mode:LISP; Package:COMPILER; Readtable:ZL; Base:8 -*- ;;; This is SYS: SYS; QCLAP ;;; ** (c) Copyright 1980, 1984 Massachusetts Institute of Technology ** ;;; ;;; LAP FOR FEFS (Cool for Cats) #| Available info on variables in function being lapped: At the moment, to avoid having to change the compiler at the same time, SPECVARS is generated by LAP out of *ALLVARS* and *FREEVARS*. This is the interface from the compiler to LAP: The format of *ALLVARS* is described in QCDEFS. *FREEVARS* is just a list of all free variables. *ALLVARS* and *FREEVARS* are contained in the first element of a list which contains the full description of the code. The list describing the code, called QCMP-OUTPUT in the compiler, contains these things: (MFEF functionname specialflag allvars freevars &OPTIONAL name-to-put-in-function) (CONSTRUCT-MACRO) ;This, if present, means that lap should cons MACRO ;onto the fef before outputting the definition. (QTAG S-V-BASE) ;This defines a symbol usable for referring to value cell ptrs (S-V-BLOCK) ;This outputs the value cell pointers. (SELF-FLAVOR flavor-name) ;This, if present, outputs the self flavor name. (QTAG DESC-LIST-ORG) ;This defines a symbol pointing at the start of the ADL. (A-D-L) ;This outputs the ADL. (A-D-L) ;For historic reasons, there can be extra of these. ... ;They do nothing. (ENDLIST) ;This puts CDR-NIL in the last Q of the ADL. ;It is not actually necessary, now. (PARAM LLOCBLOCK n) ;This specifies the length of the function's local block (QTAG QUOTE-BASE) ;This defines a symbol usable for referring to quoted constants ;pointers to which live in the FEF starting here. Lap pass 1 inserts things to define the quoted constants in the list here. (ENDLIST) ;Put CDR-NIL in last constant pointer. (BREAKOFFS ('(:INTERNAL fnname 0) '(:INTERNAL fnname 1) ...)) ;List quoted constants that ought to be ;replaced by pointers to FEFs somehow. ;On pass 2, each '(:internal ...) is rplaca'd ;with the fef index of where the internal fef ptr will go. ;The list structure is shared with the debugging-info ;entry INTERNAL-FEF-OFFSETS; this is how that entry ;gets the data it is supposed to have. (VARIABLES-USED-IN-LEXICAL-CLOSURES coden ... code1 code0) ;Codes describing variables of this function ;that are used in lexical closures of the function. ;A code is either the number of an argument ;or the sign bit plus an index in the local block. ;The microcode requires the codes to be in reverse order! (DEBUG-INFO debugging info) ;Optionally, specify the debugging information ALIST. ;The defined entry type now is (ARGLIST ), as in ;(DEBUG-INFO (ARGLIST (X &OPTIONAL Y))) ;Sets %%FEFHI-MS-DEBUG-INFO-PRESENT bit in the fef misc wd. PROGSA ;This identifies the start of the unboxed part of the FEF. macro instructions follow. (PARAM MXPDL n) ;This specifies the maximum stack frame size function needs. A macro instruction has one of these formats: (BRANCH condition state pop-flag tag) condition is ALWAYS, NILIND or ATOMIND. state is which way the branch should go. For ALWAYS, state should be NIL. NILIND T means branch if NIL, whereas NILIND NIL means branch if not NIL. pop-flag is T to mean pop one object off the pdl if the branch is not taken. (MOVE destination source) destination is D-IGNORE (or 0), D-PDL, D-INDS, D-NEXT, D-LAST, D-NEXT-LIST, D-RETURN. source is an operand address. This format applies to all 2-operand instructions. (+ source) This format applies to all non-destination instructions. (MISC destination name) name is the name of the miscellaneous instruction, such as CADDDR. A source operand has one of these formats: (LOCAL n) address n relative to the local block on the stack. (ARG n) address n relative to the argument block on the stack. PDL-POP pop the stack and use the value popped. EXTEND next instruction is an EXTENDED-ADDRESS and specifies our source. (SPECIAL sym) the value cell of sym, actually relative to the invisible pointer stored in the FEF. (SPECIAL n) similar, except that the index in the list of special variables is specified instead of the symbol name. This number is the offset of the invisible pointer in the FEF with respect to the first such invisible pointer. (QUOTE-VECTOR ) s-exp placed in quote vector of FEF, and operand ref's it. s-exp should have one of these forms: (QUOTE object) The object is stored in the FEF (FUNCTION symbol) A fwding ptr to the fn cell is stored (BREAKOFF-FUNCTION name) The name is stored, but the offset of this q is put into the INTERNAL-FEF-OFFSETS debugging info item. When (:INTERNAL thisfn n) is defined, its definition replaces the name. (SELF-REF flavor varname) Stores a DTP-SELF-REF-POINTER to that variable in that flavor. It is the compiler's responsibility to generate an EXTENDED-ADDRESS when the parameter n is too big to fit the available field in a simple source address. The maximum is 77 for LOCAL and ARG sources. An EXTENDED-ADDRESS is treated as an instruction by lap. It follows an instruction with EXTEND as a source address. It looks like (EXTENDED-ADDRESS dest source). The dest must match that or the previous instruction, if that has a dest. The source looks like an ordinary source but indices of up to 10. bits are allowed. |# (DEFVAR LAP-ADR) (DEFVAR SYMPTR) (DEFVAR SYMTAB) (DEFVAR QLP-A-D-L-DONE) (DEFVAR ADL-LENGTH) (DEFVAR A-D-L-NEEDED-P) (DEFVAR LOW-HALF-Q) (DEFVAR MAX-ARGS) (DEFVAR MIN-ARGS) (DEFVAR SM-ARGS-NOT-EVALD) (DEFVAR REST-ARG) (DEFVAR HAIRY-INIT-FLAG) (DEFVAR S-V-BITMAP-ACTIVE) (DEFVAR LENGTH-OF-PROG) (DEFVAR PROG-ORG) (DEFVAR FCTN-NAME) (DEFVAR LAP-OUTPUT-AREA) (DEFVAR LAP-MODE) (DEFVAR FASD-GROUP-LENGTH) (DEFVAR LAP-NO-ADL) (DEFVAR LAP-LASTQ-MODIFIER) (defvar lap-lastq-cdr-code) ;cdr code as keyword symbol (DEFVAR LAP-FASD-NIBBLE-COUNT) (DEFVAR QUOTE-LIST) (DEFVAR CONSTANTS-PAGE) (DEFVAR QFEFHI-FAST-ARG-OPT-OPERATIVE) (DEFVAR LAP-OUTPUT-BLOCK) (DEFVAR LAP-OUTPUT-BLOCK-LENGTH) (DEFVAR LAP-STORE-POINTER) (DEFVAR LAP-MACRO-FLAG) (DEFVAR *SPECVARS* :UNBOUND "The list of names of all special variables, bound or free. These are in the order that their value cell pointers should go in the fef. Vars bound at function entry must come first, and duplicates among them must not be eliminated.") (DEFVAR *SPECVARS-BIND-COUNT* :UNBOUND "The number of special variables (from *SPECVARS*) which are bound at function entry.") (DEFVAR QLP-DEBUG-INFO) (defvar qlp-debug-info-present) (DEFVAR QLP-SELF-FLAVOR NIL) (DEFVAR *BREAKOFF-FUNCTION-OFFSETS* :UNBOUND "Alist of (offset-in-function . internal-function-number) accumulated about breakoff-functions as the pointers to them are seen, and then stored into the debugging info :INTERNAL-FEF-OFFSETS item.") (DEFUN LIST-SUM (LIST &AUX (TOTAL 0)) (DOLIST (ELT LIST TOTAL) (INCF TOTAL (IF (NUMBERP ELT) ELT (SYMBOL-VALUE ELT))))) ;;; SI:CHANGE-INDIRECT-ARRAY calls this. WHY ???? (DEFUN LIST-PRODUCT (LIST &AUX (RESULT 1)) (DOLIST (ELT LIST RESULT) (SETQ RESULT (* RESULT (IF (NUMBERP ELT) ELT (SYMBOL-VALUE ELT)))))) ;(DEFCONST HEADER-TYPE-FEF #o2000000) (defconstant header-type-fef (%logdpb %header-type-fef %%header-type-field 0)) ;;; LAP-MODE may be QFASL, QFASL-NO-FDEFINE, REL, or COMPILE-TO-CORE. ;;; For QFASL-NO-FDEFINE, returns fasl-table index of fef (DEFUN QLAPP (FCTN LAP-MODE) (LET ((LAP-OUTPUT-AREA 'MACRO-COMPILED-PROGRAM) (MAX-ARGS 0) (MIN-ARGS 0) (SYMTAB (LIST ())) (LAP-ADR 0) (*ALLVARS* (CADDDR (CAR FCTN))) (*FREEVARS* (CADDDR (CDAR FCTN))) NBR SYMPTR QLP-A-D-L-DONE *SPECVARS* *SPECVARS-BIND-COUNT* LOW-HALF-Q SM-ARGS-NOT-EVALD REST-ARG HAIRY-INIT-FLAG LENGTH-OF-PROG PROG-ORG FCTN-NAME TEM LAP-NO-ADL LAP-LASTQ-MODIFIER lap-lastq-cdr-code ADL-LENGTH A-D-L-NEEDED-P QUOTE-LIST S-V-BITMAP-ACTIVE QLP-DEBUG-INFO qlp-debug-info-present LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER LAP-MACRO-FLAG *BREAKOFF-FUNCTION-OFFSETS* QLP-SELF-FLAVOR LAP-FASD-NIBBLE-COUNT FASD-GROUP-LENGTH) (SETQ *SPECVARS* (EXTRACT-SPECVARS)) (SCAN-ARGS) (COMPUTE-A-D-L-NEEDED-P) (QLAP-PASS1 FCTN) (SETF (CDR SYMTAB) (NREVERSE (CDR SYMTAB))) (SETQ QUOTE-LIST (NREVERSE QUOTE-LIST)) ;Just so first ones will be first (SETQ TEM (LAP-SYMTAB-PLACE 'QUOTE-BASE)) (LAP-SYMTAB-RELOC (CADDAR TEM) ;Value of QUOTE-BASE (* 2 (LENGTH QUOTE-LIST)) (CDR TEM)) (SETQ NBR (QLAP-ADJUST-SYMTAB)) ;Number branches taking extra wd (SETQ LENGTH-OF-PROG (+ LAP-ADR (+ NBR (* 2 (LENGTH QUOTE-LIST))))) (SETQ SYMPTR SYMTAB) (SETQ LAP-ADR 0) (SETQ ADL-LENGTH (OR QLP-A-D-L-DONE 0)) (SETQ QLP-A-D-L-DONE NIL) (QLAP-PASS2 FCTN) ;; Don't call FASD with the temporary area in effect (LET () #|-IF QC-FILE-IN-PROGRESS ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA))|# (COND ((OR LOW-HALF-Q (AND (OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (NOT (= 0 (LOGAND LAP-ADR 1))))) (LAP-OUTPUT-WORD 0))) (ECASE LAP-MODE (QFASL (SETQ TEM (FASD-TABLE-ADD (NCONS NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT) (BARF LAP-FASD-NIBBLE-COUNT "LAP-FASD-NIBBLE-COUNT Error")) ;; If this function is supposed to be a macro, ;; dump directions to cons MACRO onto the fef. (WHEN LAP-MACRO-FLAG (FASD-START-GROUP T 1 FASL-OP-LIST) (FASD-NIBBLE 2) (FASD-CONSTANT 'MACRO) (FASD-START-GROUP NIL 1 FASL-OP-INDEX) (FASD-NIBBLE TEM) (SETQ TEM (FASD-TABLE-ADD (NCONS NIL)))) (FASD-STOREIN-FUNCTION-CELL FCTN-NAME TEM) ;(FASD-FUNCTION-END) (RETURN-FROM QLAPP NIL)) (QFASL-NO-FDEFINE (SETQ TEM (FASD-TABLE-ADD (NCONS NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT) (BARF LAP-FASD-NIBBLE-COUNT "LAP-FASD-NIBBLE-COUNT Error")) ;; If this function is supposed to be a macro, ;; dump directions to cons MACRO onto the fef. (WHEN LAP-MACRO-FLAG (FASD-START-GROUP T 1 FASL-OP-LIST) (FASD-NIBBLE 2) (FASD-CONSTANT 'MACRO) (FASD-START-GROUP NIL 1 FASL-OP-INDEX) (FASD-NIBBLE TEM) (SETQ TEM (FASD-TABLE-ADD (NCONS NIL)))) (RETURN-FROM QLAPP TEM)) (COMPILE-TO-CORE ; (SI:FEF-CONVERT-DESTINATIONS LAP-OUTPUT-BLOCK) (if (typep lap-output-block 'compiled-function) (si:maybe-change-fef-type lap-output-block)) ;get rid of old MCLAP, if any. Do this first so as to not clobber back on top of ; new thing. (if (fboundp 'ma-deinstall-mclap) (ma-deinstall-mclap fctn-name)) ;(FDEFINE FCTN-NAME (IF LAP-MACRO-FLAG (CONS-IN-AREA 'MACRO LAP-OUTPUT-BLOCK BACKGROUND-CONS-AREA) LAP-OUTPUT-BLOCK) #|T)|#) (REL ; (SI:FEF-CONVERT-DESTINATIONS LAP-OUTPUT-BLOCK) (QFASL-REL:DUMP-LAP-FSET FCTN-NAME LAP-OUTPUT-BLOCK)))))) (DEFUN QLAP-PASS1 (PNTR) (PROG () P1 (WHEN (NULL PNTR) (RETURN NIL)) ;Pass 1 (QLP1 (CAR PNTR)) (SETQ PNTR (CDR PNTR)) (GO P1))) (DEFUN QLAP-ADJUST-SYMTAB NIL (PROG (T1 NBR) (SETQ NBR 0) (SETQ T1 SYMTAB) P2A (COND ((NULL (CDR T1)) (RETURN NBR)) ;Finalize sym defs ((EQ (CADADR T1) 'BRANCH) (GO P2B)) ((EQ (CADADR T1) 'TDEF) (GO P2C))) P2A1 (SETQ T1 (CDR T1)) (GO P2A) P2B (QLRLC (CADR T1) NBR) ;This is only adr at which to hack this. (INCF NBR) ;Doesn't affect value of eventual branch (GO P2A1) P2C (QLRLC (CADR T1) NBR) (GO P2A1))) (DEFUN QLAP-PASS2 (PNTR &AUX (%INHIBIT-READ-ONLY T)) ;For storing into the FEF. (PROG () P3A (COND ((NULL PNTR) (RETURN NIL)) ;Pass 2 ((QLP2-Q (CAR PNTR)) (GO P3C))) ;Xfer on advance to unboxed area (SETQ PNTR (CDR PNTR)) (GO P3A) P3C (IF LAP-LASTQ-MODIFIER (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER lap-lastq-cdr-code)) (DO ((P PNTR (CDR P))) ((NULL P)) (QLP2-U (CAR P))))) (DEFUN LAP-D-OUT (S-EXP) (LAP-Q-OUT NIL NIL NIL S-EXP)) ;;; On pass 2, output a Q, specified by components. ;;; S-EXP is the contents of the Q. ;;; INVZ-P is non-NIL to modify the data type of the Q: ;;; QZEVCP for an external value cell pointer, or ;;; QZLOC for a locative. ;;; QZSRP for an instance var pointer. ;;; OFFSET is added to the Q. It is useful for making pointers to ;;; value cells or function cells of symbols. (DEFUN LAP-Q-OUT (IGNORE INVZ-P OFFSET S-EXP) (IF LAP-LASTQ-MODIFIER (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER lap-lastq-cdr-code)) (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) ;; Don't call FASD with the temporary area in effect (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (FASD-CONSTANT S-EXP))) ((OR (EQ LAP-MODE 'COMPILE-TO-CORE) (EQ LAP-MODE 'REL)) (WHEN ( LAP-STORE-POINTER LAP-OUTPUT-BLOCK-LENGTH) (BARF S-EXP "Doesn't fit in allocated block")) ;; QC-TRANSLATE-FUNCTION may have consed some lists which end up here, ;; such as the function's debug info, in the temporary area even though ;; QC-FILE-LOAD-FLAG is set, so copy them out. ; (IF (EQ (%AREA-NUMBER S-EXP) QCOMPILE-TEMPORARY-AREA) ; (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ; (SETQ S-EXP (SI:COPY-OBJECT-TREE S-EXP)))) ;;if this will be in read-only area if fasloaded, then copy it ;;to a read only area now (cond ((consp s-exp) ;;>> should be copytree-share, since circlarity in constants should be ok. (setq s-exp (copy-tree s-exp macro-compiled-program)))) (%P-STORE-CONTENTS-OFFSET S-EXP LAP-OUTPUT-BLOCK LAP-STORE-POINTER) (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER)))) (SETQ LAP-LASTQ-MODIFIER (+ ; (COND (FLAG #o40) (T 0)) (COND ((NULL INVZ-P) 0) ((EQ INVZ-P 'QZEVCP) #o20) ((EQ INVZ-P 'QZLOC) #o400) ((EQ INVZ-P 'QZSRP) #o1000) (T (BARF INVZ-P "LAP-Q-OUT"))) (OR OFFSET 0))) (setq lap-lastq-cdr-code 'cdr-next)) ;*** does this create a LOCATIVE pointer to randomness, then change ; its type to SELF-REF-POINTER? (DEFUN LAP-MODIFY-LASTQ (CODE cdr-code) (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (LAP-FASD-NIBBLE (+ (ash (selectq cdr-code ;QFASL files haven't changed cdr-codes (cdr-normal 0) (cdr-error 1) (cdr-nil 2) (cdr-next 3) (t (BARF cdr-code "Must be symbol for cdr-code"))) 6) CODE))) (T (LET ((OFFSET (LOGAND CODE #o17)) (IDX (1- LAP-STORE-POINTER))) (%P-DPB-OFFSET (symbol-value cdr-code) %%Q-CDR-CODE LAP-OUTPUT-BLOCK IDX) (COND ((NOT (ZEROP OFFSET)) (%P-STORE-CONTENTS-OFFSET (%MAKE-POINTER-OFFSET DTP-LOCATIVE (%P-CONTENTS-OFFSET LAP-OUTPUT-BLOCK IDX) OFFSET) LAP-OUTPUT-BLOCK IDX))) (COND ((BIT-TEST #o20 CODE) (%P-DPB-OFFSET DTP-ONE-Q-FORWARD %%Q-DATA-TYPE LAP-OUTPUT-BLOCK IDX)) ; ((BIT-TEST #o20 CODE) ; (%P-DPB-OFFSET DTP-EXTERNAL-VALUE-CELL-POINTER %%Q-DATA-TYPE ; LAP-OUTPUT-BLOCK IDX)) ((BIT-TEST #o400 CODE) (%P-DPB-OFFSET DTP-LOCATIVE %%Q-DATA-TYPE LAP-OUTPUT-BLOCK IDX)) ((BIT-TEST #o1000 CODE) (%P-DPB-OFFSET DTP-SELF-REF-POINTER %%Q-DATA-TYPE LAP-OUTPUT-BLOCK IDX))) )))) (DEFUN LAP-OUTPUT-WORD (WD) (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (LAP-FASD-NIBBLE WD)) ((NULL LOW-HALF-Q) (SETQ LOW-HALF-Q WD)) (T (WHEN ( LAP-STORE-POINTER LAP-OUTPUT-BLOCK-LENGTH) (BARF WD "Doesn't fit in allocated block")) (LET ((%INHIBIT-READ-ONLY T)) (%P-DPB-OFFSET WD %%Q-HIGH-HALF LAP-OUTPUT-BLOCK LAP-STORE-POINTER) (%P-DPB-OFFSET LOW-HALF-Q %%Q-LOW-HALF LAP-OUTPUT-BLOCK LAP-STORE-POINTER)) (SETQ LOW-HALF-Q NIL) (INCF LAP-STORE-POINTER)))) (DEFUN LAP-STORE-NXTNIL-CDR-CODE () ; (SETQ LAP-LASTQ-MODIFIER (+ #o200 (BOOLE 4 LAP-LASTQ-MODIFIER 300))) ; (setq lap-lastq-modifier (dpb cdr-nil (byte 2 6) lap-lastq-modifier)) (setq lap-lastq-cdr-code 'cdr-nil)) (DEFUN LAP-HEADER (Q-LENGTH UNBOXED-LENGTH) (WHEN (> Q-LENGTH #o400) (BARF (- Q-LENGTH #o400) "Constants area of FEF is excessively long by")) (IF (MEMQ LAP-MODE '(QFASL QFASL-NO-FDEFINE)) ;; Don't call FASD with the temporary area in effect (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;(IF (EQ LAP-MODE 'QFASL) (FASD-FUNCTION-HEADER FCTN-NAME)) (FASD-START-GROUP NIL 3 FASL-OP-FRAME) (FASD-NIBBLE Q-LENGTH) (FASD-NIBBLE UNBOXED-LENGTH) (SETQ LAP-FASD-NIBBLE-COUNT (+ Q-LENGTH (* 2 UNBOXED-LENGTH))) (FASD-NIBBLE LAP-FASD-NIBBLE-COUNT) (SETQ FASD-GROUP-LENGTH LAP-FASD-NIBBLE-COUNT)) (SETQ LAP-OUTPUT-BLOCK ;Create the FEF (%make-structure DTP-FEF-POINTER ;Data type of returned pointer DTP-HEADER ;Header (1st word of FEF) (%LOGDPB %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD 0) (SETQ LAP-OUTPUT-BLOCK-LENGTH ;Total size Q (2nd word of FEF) (+ Q-LENGTH UNBOXED-LENGTH)) (IF (EQ LAP-MODE 'COMPILE-TO-CORE) ;Area to allocate in MACRO-COMPILED-PROGRAM working-storage-area ;QFASL-REL:DUMP-TEMP-AREA ) LAP-OUTPUT-BLOCK-LENGTH ;Total size. q-length)) ;Boxed size. ;; 1st two wds done except rest of header. Q will be filled in later. (SETQ LAP-STORE-POINTER 2))) (DEFUN LAP-FASD-NIBBLE (N) ;; Don't call FASD with the temporary area in effect (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (DECF LAP-FASD-NIBBLE-COUNT) (FASD-NIBBLE N))) (DEFUN LAP-ARGP (VARHOME) (MEMQ (VAR-KIND VARHOME) '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-REST FEF-ARG-AUX))) ;;; This function is called before pass 1 and duplicates some of the work done in ;;; pass 2 by LAP-MFEF, in order to determine whether the A-D-L will be required. ;;; This organization is somewhat poor... (DEFUN COMPUTE-A-D-L-NEEDED-P () (LET (QFEFHI-FAST-ARG-OPT-OPERATIVE S-V-BITMAP-ACTIVE FA) (COMPUTE-S-V-MAP) ;Compute S-V-BITMAP-ACTIVE (SETQ FA (COMPUTE-FAST-OPT-Q)) ;Compute QFEFHI-FAST-ARG-OPT-OPERATIVE (SETQ A-D-L-NEEDED-P (OR (BIT-TEST %ARG-DESC-FEF-QUOTE-HAIR FA) ;Needed by interpreter (NOT QFEFHI-FAST-ARG-OPT-OPERATIVE) ;Needed by microcode (DOLIST (V *ALLVARS*) ;Needed for extra info on args (OR (LAP-ARGP V) (RETURN NIL)) ;(such as &functional) (AND (NOT (ZEROP (LIST-SUM (VAR-MISC V)))) (RETURN T)))))) NIL) ;;; At the start of pass 2, when the MFEF pseudo is encountered, ;;; output the fixed header Qs of the fef. (DEFUN LAP-MFEF (WD) (LET (HEADER QFEFHI-FCTN-NAME QFEFHI-FAST-ARG-OPT QFEFHI-SV-BITMAP QFEFHI-MISC QFEFHI-STORAGE-LENGTH UNBOXED-ORG QFEFHI-FAST-ARG-OPT-OPERATIVE LOCAL-BLOCK-LENGTH) ;; Compute the header. (SETQ HEADER (LIST-SUM (LIST 'HEADER-TYPE-FEF (SETQ UNBOXED-ORG (QLEVAL 'PROGSA 'T))))) (IF (SPECIAL-BIND-NEEDED-P) (SETQ HEADER (DPB 1 %%FEFH-SV-BIND HEADER))) (SETQ QFEFHI-FCTN-NAME (OR (SIXTH WD) (SECOND WD)) FCTN-NAME (SECOND WD)) (SETQ QFEFHI-SV-BITMAP (COMPUTE-S-V-MAP)) ;Do this first, so S-V-BITMAP-ACTIVE (SETQ QFEFHI-FAST-ARG-OPT (COMPUTE-FAST-OPT-Q)) ; is set for COMPUTE-FAST-OPT-Q (IF QFEFHI-FAST-ARG-OPT-OPERATIVE (SETQ HEADER (DPB 1 %%FEFH-FAST-ARG HEADER))) (UNLESS A-D-L-NEEDED-P (SETQ HEADER (DPB 1 %%FEFH-NO-ADL HEADER))) (IF QLP-SELF-FLAVOR (SETQ HEADER (DPB 1 %%FEFH-GET-SELF-MAPPING-TABLE HEADER))) ;; Compute the MISC word. (when (null qlp-debug-info-present) (barf nil "Functions must have debug-info")) (SETQ QFEFHI-MISC (%LOGDPB 1 %%FEFHI-MS-DEBUG-INFO-PRESENT (DPB ADL-LENGTH %%FEFHI-MS-BIND-DESC-LENGTH (DPB (QLEVAL 'DESC-LIST-ORG 'T) %%FEFHI-MS-ARG-DESC-ORG (SETQ LOCAL-BLOCK-LENGTH (QLEVAL 'LLOCBLOCK 'NIL)))))) (WHEN (> LOCAL-BLOCK-LENGTH #o100) (BARF (- LOCAL-BLOCK-LENGTH #o100) "Sorry, software architectual limitations do not allow a local-variables block of this size. Local-variables block exceeds maximum length by")) ; (SETQ QFEFHI-MISC1 (+ (LSH (QLEVAL 'MXPDL 'NIL) 15.) ; 0 ; 0)) (SETQ QFEFHI-STORAGE-LENGTH (LSH (1+ LENGTH-OF-PROG) -1)) (SETQ LAP-ADR (+ LAP-ADR (* 2 %FEF-HEADER-LENGTH))) (without-interrupts (LAP-HEADER (TRUNCATE UNBOXED-ORG 2) ;Q part length (- QFEFHI-STORAGE-LENGTH (TRUNCATE UNBOXED-ORG 2))) ;; Unboxed part length (COND ((MEMQ LAP-MODE '(QFASL QFASL-NO-FDEFINE)) (SETQ PROG-ORG (LAP-D-OUT (DPB %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD HEADER))) (LAP-D-OUT QFEFHI-STORAGE-LENGTH)) (T (%P-DPB HEADER %%HEADER-REST-FIELD LAP-OUTPUT-BLOCK))) (LAP-D-OUT QFEFHI-FCTN-NAME) (LAP-D-OUT QFEFHI-FAST-ARG-OPT) (LAP-D-OUT QFEFHI-SV-BITMAP) (LAP-D-OUT QFEFHI-MISC) (LAP-STORE-NXTNIL-CDR-CODE))) NIL) ;;; Looking at *ALLVARS*, compute these quantities: ;;; MIN-ARGS, the minimum number of args required by the function. ;;; MAX-ARGS, the maximum number of args accepted by the function, not including a rest arg. ;;; HAIRY-INIT-FLAG, T if any variable is initialized at function entry other than to NIL. ;;; SM-VARS-NOT-EVALD, T if any arguments are not evaluated. (DEFUN SCAN-ARGS () (DO ((VS *ALLVARS* (CDR VS))) ((NULL VS)) (CASE (VAR-KIND (CAR VS)) (FEF-ARG-REQ (INCF MAX-ARGS) (INCF MIN-ARGS)) (FEF-ARG-OPT (INCF MAX-ARGS)) (FEF-ARG-REST (SETQ REST-ARG (CAR VS)))) (CASE (CAR (VAR-INIT (CAR VS))) ((FEF-INI-NONE FEF-INI-NIL)) (FEF-INI-COMP-C (OR (EQ (VAR-KIND (CAR VS)) 'FEF-ARG-INTERNAL-AUX) (SETQ HAIRY-INIT-FLAG T))) (OTHERWISE (SETQ HAIRY-INIT-FLAG T))) (IF (EQ (VAR-EVAL (CAR VS)) 'FEF-QT-QT) (SETQ SM-ARGS-NOT-EVALD T)))) (DEFUN COMPUTE-FAST-OPT-Q () ;Sets spec var QFEFHI-FAST-ARG-OPT-OPERATIVE (SETQ QFEFHI-FAST-ARG-OPT-OPERATIVE NIL) ;Assume inoperative (OR HAIRY-INIT-FLAG ;Check reasons not to have fast opt operative (NULL S-V-BITMAP-ACTIVE) ;Ucode doesn't feel like handling this case.. ; (going to have to grubble through A-D-L ; anyway, so might as do slow enter). (SETQ QFEFHI-FAST-ARG-OPT-OPERATIVE T)) (+ (COND ((NULL REST-ARG) 0) ((EQ (VAR-EVAL REST-ARG) 'FEF-QT-QT) %ARG-DESC-QUOTED-REST) (T %ARG-DESC-EVALED-REST)) (+ (COND ((AND SM-ARGS-NOT-EVALD (> MAX-ARGS 0)) ;If quoted reg args, %ARG-DESC-FEF-QUOTE-HAIR) ; fast arg not operative for caller (T 0)) (+ (COND (QFEFHI-FAST-ARG-OPT-OPERATIVE 0) (T %ARG-DESC-FEF-BIND-HAIR)) (+ (LSH MIN-ARGS 6) MAX-ARGS))))) ;;; Return T if any special variables must be bound at entry to this function. (DEFUN SPECIAL-BIND-NEEDED-P () (DO ((VS *ALLVARS* (CDR VS))) ((NULL VS) NIL) (AND (LAP-ARGP (CAR VS)) (NEQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (RETURN T)))) ;;; Compute and return the special-variable bitmap for the function. ;;; The bit saying whether the map is active is correctly set in the value returned. ;;; In addition, S-V-BITMAP-ACTIVE is left T if the bitmap is active. ;;; The map is active if the AP-relative addresses of all the values ;;; to be bound to specials are constant, and if the addresses are not ;;; too large to be expressed in a 1-word bit map. (DEFUN COMPUTE-S-V-MAP (&AUX S-MAP) (COND ((NOT (SPECIAL-BIND-NEEDED-P)) (SETQ S-V-BITMAP-ACTIVE T) %FEFHI-SVM-ACTIVE) ;Null bitmap, no specials (REST-ARG 0) ;Can't predict addresses (T (SETQ S-MAP 0 S-V-BITMAP-ACTIVE T) ;Assume will use bitmap unless too many to fit (DO ((BIT (LSH %FEFHI-SVM-ACTIVE -1) (LSH BIT -1)) (ENDARG) (VS *ALLVARS* (CDR VS))) ((NULL VS)) (COND ((LAP-ARGP (CAR VS)) (AND ENDARG (BARF NIL "Arg-types out of order")) (OR (EQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (COND ((ZEROP BIT) ;Special past the end of the bit map (SETQ S-V-BITMAP-ACTIVE NIL) ;so give up on using bit map (RETURN NIL)) (T (SETQ S-MAP (+ S-MAP BIT)))))) (T (SETQ ENDARG T)))) (IF S-V-BITMAP-ACTIVE (+ S-MAP %FEFHI-SVM-ACTIVE) 0)))) ;Couldn't use bit map after all ;;; Get a list of all special variables referred to by the function, ;;; either free or bound, suitable for constructing the indirect pointers ;;; to their value cells. ;;; Specials bound at entry to the function must come first, one for one, ;;; even if there are duplicates. *SPECVARS-BIND-COUNT* is the number of such. ;;; Specials bound internally or used free can have duplicates removed. (DEFUN EXTRACT-SPECVARS (&AUX SVS) (SETQ *SPECVARS-BIND-COUNT* 0) (DO ((VS *ALLVARS* (CDR VS))) ((NULL VS)) (AND (NEQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (OR (IF (LAP-ARGP (CAR VS)) (INCF *SPECVARS-BIND-COUNT*)) (NOT (MEMQ (VAR-NAME (CAR VS)) SVS))) (PUSH (VAR-NAME (CAR VS)) SVS))) (DO ((VS *FREEVARS* (CDR VS))) ((NULL VS)) (PUSHNEW (CAR VS) SVS :TEST #'EQ)) (NREVERSE SVS)) (DEFUN QLP2-DEFSYM (SYM VAL) (PROG () S1 (COND ((NULL (CDR SYMPTR)) (GO S1E)) ;Symbol ((NOT (EQ (CADADR SYMPTR) 'TDEF)) (SETQ SYMPTR (CDR SYMPTR)) (GO S1)) ((OR (NEQ SYM (CAADR SYMPTR)) ;Should be in same order as pass 1 ( VAL (CADDR (CADR SYMPTR)))) (GO S1E)) (T (RETURN (SETQ SYMPTR (CDR SYMPTR))))) S1E (RETURN (BARF (LIST (CAR SYMPTR) SYM VAL) "SYMPTR loses")))) (DEFUN QLP2-U (WD) ;Pass 2 for unboxed area (PROG (TEM) (COND ((NULL WD) (RETURN NIL)) ((ATOM WD)(GO S1)) ((EQ (CAR WD) 'RESTART-TAG) (SETQ WD (CADR WD)) (GO S1)) ((EQ (CAR WD) 'BRANCH) (GO B1)) ((MEMQ (CAR WD) '(COMMENT NO-DROP-THROUGH PARAM)) (RETURN NIL)) ((EQ (CAR WD) 'ADI-CALL) (LAP-P2-ADI (CDR WD)) (RETURN NIL)) ((EQ (CAR WD) 'MISC) ;(MISC destination function) (AND (SETQ TEM (ASSQ (CADDR WD) MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST)) (NOT (MEMQ (CADR WD) (CDR TEM))) (BARF WD "Illegal destination for this misc instruction")) (LAP-OUTPUT-WORD (LAP-WORD-EVAL WD)) (GO X1)) (T (LAP-OUTPUT-WORD (LAP-WORD-EVAL WD)) (GO X1))) B1 (QB2 (LIST (CADR WD) (CADDR WD) (CADDDR WD)) ;Branch (CAR (LAST WD))) X1 (SETQ LAP-ADR (1+ LAP-ADR)) (RETURN NIL) S1 (QLP2-DEFSYM WD LAP-ADR) (RETURN NIL))) (DEFUN QLP2-Q (WD) ;Pass 2 for Q area (IF (ATOM WD) (IF (EQ WD 'PROGSA) T ;Advance to unboxed area (BARF WD "Tag in q-area") NIL) (CASE (CAR WD) (QTAG (QLP2-DEFSYM (CADR WD) (TRUNCATE LAP-ADR 2)) (IF (EQ (CADR WD) 'QUOTE-BASE) (MAPC 'QLP2-Q QUOTE-LIST))) ;Dump quote table (PARAM) (ENDLIST ;Terminate list that has just been assembled (LAP-STORE-NXTNIL-CDR-CODE)) (MFEF (LAP-MFEF WD)) (S-V-BLOCK (SETQ LAP-ADR (QLP2-S-V-BLOCK LAP-ADR))) (CONSTRUCT-MACRO (SETQ LAP-MACRO-FLAG T)) (A-D-L (SETQ LAP-ADR (QLP-A-D-L LAP-ADR T))) (DEBUG-INFO (LAP-D-OUT (CDR WD)) (LAP-STORE-NXTNIL-CDR-CODE) (INCF LAP-ADR 2)) (VARIABLES-USED-IN-LEXICAL-CLOSURES (LAP-D-OUT (CDR WD)) (LAP-STORE-NXTNIL-CDR-CODE) (INCF LAP-ADR 2)) (SELF-FLAVOR (LAP-D-OUT (CADR WD)) (LAP-STORE-NXTNIL-CDR-CODE) (INCF LAP-ADR 2)) (BREAKOFFS ;; When we see the BREAKOFFS command, ;; we copy the fef offsets of where the ptrs to broken-off fns should go ;; into the cars of the list which is the cadr of the breakoffs command. ;; That list is shared with a debug-info item ;; which is supposed to contain a list of those offsets. (DOLIST (OFFSET *BREAKOFF-FUNCTION-OFFSETS*) (SETF (NTH (CDR OFFSET) (CADR WD)) (CAR OFFSET))) (WHEN (MEMQ NIL (CADR WD)) (BARF (FIND-POSITION-IN-LIST NIL (CADR WD)) "Missing breakoff-function, position"))) (QUOTE (LAP-D-OUT (CADR WD)) (INCF LAP-ADR 2)) (LOCATIVE-TO-S-V-CELL (LAP-Q-OUT NIL 'QZLOC '1 (CADR WD)) (INCF LAP-ADR 2)) (FUNCTION (IF (SYMBOLP (CADR WD)) (LAP-Q-OUT NIL 'QZEVCP '2 (CADR WD)) (LAP-Q-OUT NIL 'QZEVCP NIL (IF (EQ LAP-MODE 'COMPILE-TO-CORE) (FDEFINITION-LOCATION (CADR WD)) (CONS EVAL-AT-LOAD-TIME-MARKER `(FDEFINITION-LOCATION ',(CADR WD)))))) (FUNCTION-REFERENCED (CADR WD) FCTN-NAME) (INCF LAP-ADR 2)) (SELF-REF (LAP-Q-OUT NIL 'QZSRP NIL (IF (EQ LAP-MODE 'COMPILE-TO-CORE) (SI:FLAVOR-VAR-SELF-REF-INDEX (CDR WD)) (CONS EVAL-AT-LOAD-TIME-MARKER `(SI:FLAVOR-VAR-SELF-REF-INDEX ',(CDR WD))))) (INCF LAP-ADR 2)) (BREAKOFF-FUNCTION (PUSH (CONS (TRUNCATE LAP-ADR 2) (CADDR (CADR WD))) *BREAKOFF-FUNCTION-OFFSETS*) (LAP-D-OUT (CADR WD)) (INCF LAP-ADR 2)) (TAG (LAP-D-OUT (QLEVAL (CADR WD) T)) (INCF LAP-ADR 2)) (FIXE (LAP-D-OUT (LAP-WORD-EVAL `(EXTENDED-ADDRESS 0 ,(CADR WD)))) (INCF LAP-ADR 2)) (T (BARF WD "Unknown op in q-area lap"))) NIL)) (DEFUN FUNCTION-REFERENCED (WHAT BY) ;; Collect functions referenced (OR (FUNCTION-P WHAT) ;defined in QCP1 (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) (ENTRY (ASSOC-EQUAL WHAT FUNCTIONS-REFERENCED))) (SETQ BY (COPYTREE BY)) ;Could be (:METHOD ...) (IF ENTRY (PUSH BY (CDR ENTRY)) (PUSH (LIST (COPYTREE WHAT) BY) FUNCTIONS-REFERENCED))))) ;;; Output the block of forwarding pointers to value cells of special variables. ;;; The flag bit is set in each one which is not bound at function entry. ;;; We make one forwarding pointer for each entry in *SPECVARS*, ;;; and assume that the first *SPECVARS-BIND-COUNT* of them are bound at function entry. ;;; The argument of this function is the location counter (in half-Qs) in the fef, ;;; and the updated location counter is returned. (DEFUN QLP2-S-V-BLOCK (LAP-ADR) (DO ((SVS *SPECVARS* (CDR SVS)) (NUMARGS *SPECVARS-BIND-COUNT* (1- NUMARGS))) ((NULL SVS) (LAP-STORE-NXTNIL-CDR-CODE)) (LAP-Q-OUT NIL 'QZEVCP 1 (CAR SVS)) (INCF LAP-ADR 2)) LAP-ADR) ;;; Output the argument descriptor list, based entirely on *ALLVARS*. ;;; Only bound variables go in the ADL. ;;; On pass 1, PASS2-FLAG is NIL and all we do is advance LAP-ADR. ;;; Since, at the moment, there are many A-D-L lists output in the lap code, ;;; QLP-A-D-L-DONE is used to make sure that QLP-A-D-L does its work only once. ;;; It starts out as NIL, and is set to the number of variables in the ADL. (DEFUN QLP-A-D-L (LAP-ADR PASS2-FLAG) (WHEN (AND A-D-L-NEEDED-P (NOT QLP-A-D-L-DONE)) (SETQ QLP-A-D-L-DONE 0) (LET ((ADL-MAX-LOCAL-SLOT -1)) (DO ((VS *ALLVARS* (CDR VS)) V KIND INTL) ((NULL VS)) (SETQ V (CAR VS)) (SETQ KIND (VAR-KIND V)) (SETQ QLP-A-D-L-DONE (1+ QLP-A-D-L-DONE)) (AND (CONSP (VAR-LAP-ADDRESS V)) (EQ (CAR (VAR-LAP-ADDRESS V)) 'LOCAL) (SETQ ADL-MAX-LOCAL-SLOT (MAX ADL-MAX-LOCAL-SLOT (CADR (VAR-LAP-ADDRESS V))))) ;; First, output the word of bits. (IF PASS2-FLAG (LAP-D-OUT (+ (SYMBOL-VALUE KIND) (SYMBOL-VALUE (VAR-TYPE V)) (SYMBOL-VALUE (VAR-EVAL V)) (SYMBOL-VALUE (CAR (VAR-INIT V))) (LIST-SUM (VAR-MISC V))))) (INCF LAP-ADR 2) ;; Now output the initialization data, if any. (SETQ INTL (VAR-INIT V)) (COND ((NOT (LAP-ARGP V))) ((EQ (CAR INTL) 'FEF-INI-COMP-C)) ((EQ (CAR INTL) 'FEF-INI-OPT-SA) ;; optional arg with alternate starting address: output tag to jump to. (IF PASS2-FLAG (QLP2-Q `(TAG ,(CADR INTL))) (INCF LAP-ADR 2))) ((CADR INTL) (IF PASS2-FLAG (QLP2-Q (CADR INTL)) (INCF LAP-ADR 2))))) ;; Deal with any local slots the function wants to have ;; but which don't correspond to variables in *ALLVARS.* ;; We must make ADL entries for them so the microcode will push the slots. (DOTIMES (I (- (QLEVAL 'LLOCBLOCK 'NIL) (1+ ADL-MAX-LOCAL-SLOT))) (SETQ QLP-A-D-L-DONE (1+ QLP-A-D-L-DONE)) (IF PASS2-FLAG (LAP-D-OUT (+ FEF-INI-COMP-C FEF-ARG-INTERNAL-AUX))) (INCF LAP-ADR 2))) (AND PASS2-FLAG (LAP-STORE-NXTNIL-CDR-CODE))) LAP-ADR) (DEFUN QLP1 (WD) (COND ((NULL WD) NIL) ((ATOM WD) (DEFLAPSYM WD LAP-ADR 'TDEF)) (T (CASE (CAR WD) (RESTART-TAG (SETQ WD (CADR WD)) (DEFLAPSYM WD LAP-ADR 'TDEF)) (QTAG (DEFLAPSYM (CADR WD) (TRUNCATE LAP-ADR 2) 'TDEF)) (BRANCH (DEFLAPSYM (CAR (LAST WD)) LAP-ADR 'BRANCH) (INCF LAP-ADR 1)) (PARAM (PUTPROP (CADR WD) (QLEVAL (CADDR WD) T) 'QLVAL)) ((ENDLIST COMMENT NO-DROP-THROUGH) NIL) (MFEF (INCF LAP-ADR (* 2 %FEF-HEADER-LENGTH)) NIL) (S-V-BLOCK (INCF LAP-ADR (* 2 (LENGTH *SPECVARS*))) NIL) (CONSTRUCT-MACRO NIL) (A-D-L (SETQ LAP-ADR (QLP-A-D-L LAP-ADR NIL)) NIL) (DEBUG-INFO (SETQ QLP-DEBUG-INFO (CDR WD)) (setq qlp-debug-info-present t) (INCF LAP-ADR 2)) (VARIABLES-USED-IN-LEXICAL-CLOSURES (INCF LAP-ADR 2)) (SELF-FLAVOR (SETQ QLP-SELF-FLAVOR (CADR WD)) (INCF LAP-ADR 2)) ((QUOTE LOCATIVE-TO-S-V-CELL FIXE TAG) (INCF LAP-ADR 2)) (BREAKOFFS NIL) (ADI-CALL (LAP-P1-ADI (CDR WD)) NIL) ;this doesn't work now that 1{+,-}-to-pdl are around ;I don't know if this is the best way to fix it, but it will do for now. ; (T ; (LAP-ADR-P1 (CADDR WD)) ; (INCF LAP-ADR 1)) ((1--to-pdl 1+-to-pdl) (lap-adr-p1 (cadr wd)) (incf LAP-adr 1)) (single-address-zerop (lap-adr-p1 (second wd)) (incf LAP-adr 1)) (t (lap-adr-p1 (caddr wd)) (incf LAP-adr 1)) )))) (DEFUN LAP-P1-ADI (X &AUX L ADI) (SETQ ADI (CADDDR X)) (MAPC-ALTERNATE #'LAP-ADR-P1 (CDR ADI)) ;Odd positions of ADI list (SETQ L 1) ;A misc (of some sort) (UNLESS (EQUAL (CADDR X) '(QUOTE-VECTOR (FUNCTION *CATCH))) (LAP-ADR-P1 (CADDR X)) ;Fctn to call (INCF L)) ;MOVE D-PDL (WHEN (MEMQ-ALTERNATE 'RESTART-PC ADI) (INCF L)) ;MOVE D-PDL (WHEN (MEMQ-ALTERNATE 'MULTIPLE-VALUE ADI) (INCF L)) (INCF LAP-ADR L) L) (DEFUN LAP-P2-ADI (X) (LET ((MISC-TYPE (CAR X)) ;Type CALL inst would have used (ADI (CADDDR X)) TM) (IF (EQUAL (CADDR X) '(QUOTE-VECTOR (FUNCTION *CATCH))) (SETQ MISC-TYPE '%CATCH-OPEN) (QLP2-U `(MOVE D-PDL ,(CADDR X)))) (WHEN (SETQ TM (MEMQ-ALTERNATE 'RESTART-PC ADI)) (QLP2-U `(MOVE D-PDL ,(CADR TM))) (UNLESS (EQ MISC-TYPE '%CATCH-OPEN) (BARF TM "Bad ADI call with restart pc"))) (WHEN (MEMQ-ALTERNATE 'FEXPR-CALL ADI) (UNLESS (EQ MISC-TYPE 'CALL) (BARF MISC-TYPE "Bad fexpr ADI")) (SETQ MISC-TYPE '%FEXPR-CALL)) (WHEN (MEMQ-ALTERNATE 'LEXPR-CALL ADI) (UNLESS (EQ MISC-TYPE 'CALL) (BARF MISC-TYPE "Bad lexpr ADI")) (SETQ MISC-TYPE '%LEXPR-CALL)) (WHEN (SETQ TM (MEMQ-ALTERNATE 'MULTIPLE-VALUE ADI)) (QLP2-U `(MOVE D-PDL ,(CADR TM))) (SETQ MISC-TYPE (CDR (ASSQ MISC-TYPE '((CALL . %CALL-MULT-VALUE) (CALL0 . %CALL0-MULT-VALUE) (%FEXPR-CALL . %FEXPR-CALL-MV) (%CATCH-OPEN . %CATCH-OPEN-MV)))))) (WHEN (MEMQ-ALTERNATE 'MULTIPLE-VALUE-LIST ADI) (SETQ MISC-TYPE (CDR (ASSQ MISC-TYPE '((CALL . %CALL-MULT-VALUE-LIST) (CALL0 . %CALL0-MULT-VALUE-LIST) (%FEXPR-CALL . %FEXPR-CALL-MV-LIST) (%CATCH-OPEN . %CATCH-OPEN-MV-LIST)))))) (WHEN (MEMQ MISC-TYPE '(NIL CALL CALL0)) (BARF X "Bad ADI")) (QLP2-U `(MISC ,(CADR X) ,MISC-TYPE)) NIL)) (DEFUN MAPC-ALTERNATE (FN LST) (PROG () L (COND ((NULL LST) (RETURN NIL))) (FUNCALL FN (CAR LST)) (COND ((NULL (SETQ LST (CDR LST))) (RETURN NIL))) (SETQ LST (CDR LST)) (GO L))) (DEFUN LAP-ADR-P1 (LAP-ADR) (COND ((ATOM LAP-ADR) NIL) ((EQ (CAR LAP-ADR) 'QUOTE-VECTOR) (QADD (CADR LAP-ADR))))) ;;; On pass 1, add an entry for the constant X to the quote vector if necessary. ;;; It is necessary if X is not in the constants page, and not already in the ;;; quote vector, ;;; or if X is a load-time eval. ;;; (DEFUN QADD (X) (cond ((QFIND-CONSTANTS-PAGE X)) ((or (CONTAINS-LOAD-TIME-EVAL X) (null (CL:member X QUOTE-LIST ;; EQUALP is such as dog :TEST (LAMBDA (X Y) (TREE-EQUAL X Y :TEST (LAMBDA (X Y) (IF (STRINGP X) (EQUAL X Y) (EQL X Y)))))))) (PUSH X QUOTE-LIST))) X) ;;; Return position of ITEM in constants page, or NIL if it doesn't appear there. (DEFUN QFIND-CONSTANTS-PAGE (ITEM) (cond ((null item) 0) ((EQ (CAR ITEM) 'QUOTE) (FIND-POSITION-IN-LIST (CADR ITEM) CONSTANTS-PAGE)))) ;;; Return T if FORM contains a load-time eval (#,) or other special ;;; marker that means it should not be made EQ to things that look equal. (DEFUN CONTAINS-LOAD-TIME-EVAL (FORM) (DO ((F FORM (CDR F))) ((ATOM F) NIL) (WHEN (OR (AND FASD-MAGIC-AREAS-ALIST (ASSQ (%AREA-NUMBER F) FASD-MAGIC-AREAS-ALIST)) (IF (ATOM (CAR F)) (ASSQ (CAR F) FASD-MARKERS-ALIST) (CONTAINS-LOAD-TIME-EVAL (CAR F)))) (RETURN T)))) (DEFUN LAP-QUOTE-ADR (ITEM &AUX TM) (COND ((SETQ TM (QFIND-CONSTANTS-PAGE ITEM)) (+ TM (GET 'CONST-PAGE 'QLVAL))) ((DO ((IDX 0 (1+ IDX)) (QUOTE-LIST QUOTE-LIST (CDR QUOTE-LIST)) (contains-load-time-eval (CONTAINS-LOAD-TIME-EVAL ITEM))) ((NULL QUOTE-LIST) (SETQ TM NIL)) (cond ((TREE-EQUAL ITEM (CAR QUOTE-LIST) :TEST ;;>> EQUALP is such a complete dog. (LAMBDA (X Y) (IF (STRINGP X) (EQUAL X Y) (EQL X Y)))) (if contains-load-time-eval (rplaca quote-list (list '**used-load-time-eval**))) (RETURN (SETQ TM IDX))))) (+ TM (QLEVAL 'QUOTE-BASE T))) (T (BARF ITEM "not on quote-list") 0))) ;;; Var is either the name or the index of a special variable. (DEFUN LAP-SPECIAL-ADR (VAR &AUX TM) (COND ((NUMBERP VAR) (+ VAR (QLEVAL 'S-V-BASE T))) ((SETQ TM (FIND-POSITION-IN-LIST VAR *SPECVARS*)) (+ TM (QLEVAL 'S-V-BASE T))) (T (BARF VAR "Not on special var list") 0))) ;;;; QLAP SYMBOL TABLE ;;; This is a list, starting from (CDR SYMTAB) Order is important. ;;; On pass 1 it is in reverse order from that in which ;;; entires where made. It is nreversed prior to pass2. ;;; Entries are of two types: ;;; definitions of symbols ;;; notations that a branch which might take two "words" occurred. ;;; The latter are removed as soon as it can be determined that the branch can definitely ;;; "make it" in one word (ie magnitude of delta is  377). ;;; Each entry is a 3 list, (SYM TYPE VAL). ;;; TYPE is either TDEF or BRANCH. ;;; VAL is value if TYPE is SYM, or the LAP-adr of the branch if TYPE is BRANCH. (DEFUN LAP-SYMTAB-PLACE (SYM) (PROG (STP) (SETQ STP (CDR SYMTAB)) L (COND ((NULL STP) (BARF SYM "Can't find place")) ((EQ (CAAR STP) SYM) (RETURN STP))) (SETQ STP (CDR STP)) (GO L))) ;;; Relocate SYMTAB items in SYMTAB segment pointed to by STP by amount AMT ;;; If they are  BOTTOM (DEFUN LAP-SYMTAB-RELOC (BOTTOM AMT STP) (PROG ((TEM STP)) A (COND ((NULL TEM) (RETURN NIL)) ((NOT (< (CADDAR TEM) BOTTOM)) (RPLACA (CDDAR TEM) (+ AMT (CADDAR TEM))))) (SETQ TEM (CDR TEM)) (GO A))) (DEFUN DEFLAPSYM (SYM VAL TYPE) (PROG ((STP SYMTAB) (NBR 0) TM) L (COND ((NULL (CDR STP)) (GO L1)) ((EQ (CAADR STP) SYM) (GO L2)) ((EQ (CADADR STP) 'BRANCH) (INCF NBR))) L3 (SETQ STP (CDR STP)) (GO L) L1 (RETURN (RPLACD SYMTAB (CONS (LIST SYM TYPE VAL) (CDR SYMTAB)))) L2 (COND ((EQ TYPE 'BRANCH) (GO L2C)) ((EQ (CADADR STP) 'BRANCH) (GO L2A)) ;Now defining sym branched to then ; ((AND (EQ (CADADR STP) 'TDEF) ; (EQ TYPE 'TDEF)) ; (RETURN (RPLACA (CDDADR STP) VAL))) ;Redefining (T (BARF (LIST SYM VAL TYPE) "Mult def"))) L2A (UNLESS (EQ TYPE 'TDEF) (BARF TYPE "Bad type")) (SETQ TM (+ VAL NBR)) ;Highest possible value L2B (IF (>= (- TM (CADDR (CADR STP))) #o377) (GO L3) ;Maybe that branch won't make it (SETF (CDR STP) (CDDR STP)) ;This one will (GO L)) L2C (COND ((EQ (CADADR STP) 'BRANCH) (GO L1)) ;That branch didn't make it ; so this one wont ((= VAL (CADDR (CADR STP))) (GO L1)) ;Either jmp . loses! ((< (- (+ VAL NBR) (CADDR (CADR STP))) #o377) (RETURN NIL))) ;This one definitely makes it (GO L1))) ;Might or might not... Hmmm... (DEFUN LAP-WORD-EVAL (WD) (PROG (VL TM disgust) (SETQ VL 0) (COND ((EQ (CAR WD) 'SETE) (SETQ VL (+ #o112000 (CDR (ASSQ (CADR WD) '((CDR . #o00000) (CDDR . #o20000) (1+ . #o40000) (1- . #o60000)))))) (SETQ WD (CDDR WD))) ;; Handle (EXTENDED-ADDRESS dest (SELF-REF index)) ;; Index must be split into two parts, and put into VL. ;; Leave WD set to (dest SELF-REF) so that those are added in. ((EQ (CAR WD) 'EXTENDED-ADDRESS) (LET ((INDEX (CADR (CADDR WD)))) (SETQ VL (+ (LSH (LOAD-BYTE INDEX 6 4) 9) (LOAD-BYTE INDEX 0 6))) (SETQ WD (LIST (CADR WD) (CAR (CADDR WD)))))) ;; You honestly will barf if you think about this. ;; Do you now doubt that this compiler is one of the poorest ;; possible pieces of code in the universe? ((and (list-match-p wd `(move d-pdl (quote-vector ,disgust))) (cond ((fixnump disgust)) ((eq (car disgust) 'quote) (setq disgust (cadr disgust))) ((and (eq (car disgust) 'tag) ;; this is qleval stuff (setq disgust (assq (cadr disgust) symtab)) (neq (cadr disgust) 'branch) (setq disgust (caddr disgust)))) (t nil)) (typep disgust '(integer 0 #o777))) (setq wd `(push-number ,disgust)))) L (COND ((NULL WD) (RETURN VL)) ((NUMBERP (SETQ TM (CAR WD)))) ((ATOM (CAR WD) ) (COND ((NULL (SETQ TM (GET (CAR WD) 'QLVAL))) (BARF WD "Undefined in word") (SETQ TM 0)))) ((EQ (CAAR WD) 'QUOTE-VECTOR) (SETQ TM (LAP-QUOTE-ADR (CADAR WD)))) ((EQ (CAAR WD) 'SPECIAL) (SETQ TM (LAP-SPECIAL-ADR (CADAR WD)))) (T (SETQ TM (QLEVAL (CAR WD) NIL )))) (INCF VL TM) (SETQ WD (CDR WD)) (GO L))) (DEFUN QLEVAL (X FLAG) ;Flag: T=> Use SYMTAB; NIL=> QLVAL props (PROG (VL) (SETQ VL 0) (COND ((NUMBERP X) (RETURN X)) ((ATOM X) (GO S1))) L1 (INCF VL (QLEVAL (CAR X) FLAG)) (IF (NULL (SETQ X (CDR X))) (RETURN VL)) (GO L1) S1 (COND (FLAG (GO S1A)) ((NULL (SETQ VL (GET X 'QLVAL))) (GO S1A)) (T (RETURN VL))) S1A (SETQ VL SYMTAB) S2 (COND ((NULL (CDR VL)) (GO E1)) ((AND (EQ (CAADR VL) X) (NOT (EQ (CADADR VL) 'BRANCH))) (RETURN (CADDR (CADR VL))))) (SETQ VL (CDR VL)) (GO S2) E1 (BARF X "undefined"))) (DEFUN QLRLC (ENTRY AMT) (UNLESS (= 0 AMT) (RPLACA (CDDR ENTRY) (+ AMT (CADDR ENTRY))))) ;(DEFUN QB2 (CONDITION TAG) ; (PROG (TM TM2) ; (COND ; ((NULL (SETQ TM ; (ASSOC-EQUAL CONDITION ; '(((ALWAYS NIL NIL) . 0) ; ((NILIND TRUE NIL) . #o20000) ; ((NILIND FALSE NIL) . #o40000) ; ((NILIND TRUE T) . #o60000) ; ((NILIND FALSE T) . #o100000) ; ((ATOMIND TRUE NIL) . #o120000) ; ((ATOMIND FALSE NIL) . #o140000))))) ; (BARF CONDITION "Non-existent condition"))) ; (SETQ TM2 (- (QLEVAL TAG T) LAP-ADR)) ; L1 (COND ((NULL (CDR SYMPTR)) (GO L2)) ; ; ((EQ (CADADR SYMPTR) 'TDEF) ; ; (SETQ SYMPTR (CDR SYMPTR)) ; ; (GO L1)) ; ((AND (EQ (CAADR SYMPTR) TAG) ; (EQ (CADADR SYMPTR) 'BRANCH) ; (= LAP-ADR (CADDR (CADR SYMPTR)))) ; (SETQ SYMPTR (CDR SYMPTR)) ;COMMITTED TO 2 WD BRANCH ; (LAP-OUTPUT-WORD (+ #o14777 (CDR TM))) ; (SETQ LAP-ADR (1+ LAP-ADR)) ; (LAP-OUTPUT-WORD (BOOLE 1 #o177777 (- TM2 2))) ;- Numbers don't win! ; (RETURN NIL)) ;-1 because pc is incremented ; ((OR (= 0 TM2) (> (ABS TM2) 376)) ; another -1 because LAP-ADR is 1 more now ; (BARF (LIST TAG TM2) "Not in range"))) ; L2 (RETURN (LAP-OUTPUT-WORD (+ #o14000 ; (+ (CDR TM) (BOOLE 1 #o777 (1- TM2)))))))) (DEFUN QB2 (CONDITION TAG) (LET ((TM (OR (ASSOC-EQUAL CONDITION '(((ALWAYS NIL NIL) . 0) ;br ((NILIND TRUE NIL) . #o20000) ;br-nil ((NILIND FALSE NIL) . #o40000) ;br-not-nil ((NILIND TRUE T) . #o60000) ;br-nil-pop ((NILIND FALSE T) . #o100000) ;br-not-nil-pop ((ATOMIND TRUE NIL) . #o120000) ;br-atom ((ATOMIND FALSE NIL) . #o140000) ;br-not-atom )) (BARF CONDITION "Non-existent condition"))) (TM2 (- (QLEVAL TAG T) LAP-ADR))) (COND ((AND (EQ (CAADR SYMPTR) TAG) (EQ (CADADR SYMPTR) 'BRANCH) (= LAP-ADR (CADDR (CADR SYMPTR)))) (SETQ SYMPTR (CDR SYMPTR)) ;COMMITTED TO 2 WD BRANCH (LAP-OUTPUT-WORD (+ #o14777 (CDR TM))) (SETQ LAP-ADR (1+ LAP-ADR)) (LAP-OUTPUT-WORD (BOOLE 1 #o177777 (- TM2 2))) NIL) ((OR (= 0 TM2) (> (ABS TM2) #o376)) (BARF (LIST TAG TM2) "Not in range")) (T (LAP-OUTPUT-WORD (+ #o14000 (+ (CDR TM) (BOOLE 1 #o777 (1- TM2))))))))) (DEFUN MEMQ-ALTERNATE (X Y) (LOOP FOR TAIL ON Y BY 'CDDR WHEN (EQ (CAR TAIL) X) RETURN TAIL))