;;;; -*- Mode:Common-lisp; Package:Compiler; Base:10. -*- ;;;; LAP FOR FEFS ;;; ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1984-1989 Texas Instruments Incorporated. All rights reserved. ;;; Copyright (C) 1980, Massachusetts Institute of Technology ; ;;;; *-----------------------------------------------------------* ;;;; | -- TI Explorer Lisp Compiler -- | ;;;; | This file defines the QLAPP routine, which creates FEFs | ;;;; | from the code array created by pass 2. | ;;;; *-----------------------------------------------------------* ;;; Feb. 1984 - Version 98 from MIT via LMI. ;;; 12/06/84 DNG - Support new FEF header format for Explorer; ;;; clean up a couple of error messages. ;;; 12/13/84 DNG - Fix LAP-HEADER to use FASL-OP-FEF for Explorer. ;;; 4/26/85 DNG - Declare FASL-OP-FEF special. ;;; 6/27/85 DNG - Some minor modifications to make compiler faster. ;;; 7/10/85 DNG - Began making modifications for release 3. ;;; 8/21/85 DNG - ;;; 9/30/85 DNG - New FEF header format for release 3. ;;; 10/07/86 DNG - Minor adjustments to compile without warnings under VM2. ;;; 12/16/86 DNG - Update LAP-MODIFY-LASTQ for TGC. ;;; 12/24/86 DNG - Improve message for too many constants. ;;; 1/15/87 DNG - Change order of arguments for %P-STORE-DATA-TYPE-OFFSET etc. ;;; 1/22/87 DNG - Fix QLAPP for :INTERNAL functions in macros. ;;;------------------ The following done after Explorer release 3.0 ------ ;;; 8/10/87 DNG - Fix for SPECIAL address with displacement > 191. [SPR 6224] ;;;------------------ The following done for Explorer release 5.0 ------ ;;; 8/02/88 DNG - Update COMPUTE-BREAKOFF-OFFSETS . ;;; 8/25/88 clm - Fixed problem in QADD occurring if long-fef instruction was already modified, ;;; the ADR wasn't being incremented [spr 8670]. ;;;------------------ The following done for Explorer release 6.0 ------ ;;; 3/15/89 DNG - Add support for CLOS. ;;; 4/10/89 DNG - Deleted obsolete functions COMPUTE-A-D-L-NEEDED-P, ;;; COMPUTE-FAST-OPT-Q, QLP-A-D-L, LAP-P1-ADI, LAP-P2-ADI, LIST-SUM, ;;; LAP-QUOTE-ADR, QFIND-CONSTANTS-PAGE, and COMPUTE-S-V-MAP . ;;; 4/26/89 DNG - Deleted binding of obsolete-variables A-D-L-NEEDED-P, ;;; ADL-LENGTH, LAP-NO-ADL, S-V-BITMAP-ACTIVE . ;Available info on variables in function being lapped: ;ALLVARS is the list, reversed from what it was in the compiler, ; so that arguments come first, in order, and so that the order of appearance ; of the bound special variables matches their order in SPECVARS ; (except that a special may appear more than once in ALLVARS). ;SPECVARS is 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. SPECVARS-BIND-COUNT is the number of them ; which are bound at function entry. ;FREEVARS is the list of all free variables. ;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 LISPM;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 this function needs. ;A macro instruction has one of these formats: ;(BRANCH condition state pop-flag tag) ; condition is ALWAYS, NULL or ATOM. ; state is which way the branch should go. For ALWAYS, state should be NIL. ; NULL T means branch if NIL, whereas NULL 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: ;(LOCBLOCK 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 LOCBLOCK 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. (PROCLAIM '(SPECIAL ADR SYMPTR SYMTAB SPECVARS SPECVARS-BIND-COUNT LOW-HALF-Q BREAKOFF-FUNCTION-OFFSETS ;N-SVS MAX-ARGS MIN-ARGS SM-ARGS-NOT-EVALD REST-ARG DATA-TYPE-CHECKING-FLAG LENGTH-OF-PROG PROG-ORG FCTN-NAME LAP-OUTPUT-AREA BIND-CONS-AREA FEF-NAME-PRESENT FEF-SV-BIT FEF-DES-DT FEF-DES-EVALAGE FEF-ARG-SYNTAX FEF-INIT-OPTION LAP-MODE FASD-GROUP-LENGTH %FEFH-NO-ADL %FEFH-FAST-ARG %FEFH-SV-BIND LAP-ADL-NOSTORE %FEFHI-SVM-ACTIVE LAP-LASTQ-MODIFIER FASL-OP-FRAME FASL-OP-STOREIN-FUNCTION-CELL FASL-OP-FEF LAP-FASD-NIBBLE-COUNT QUOTE-LIST QUOTE-COUNT CONSTANTS-PAGE QFEFHI-FAST-ARG-OPT-OPERATIVE LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER LAP-MACRO-FLAG %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD %FEF-NAME-PRESENT DISPATCH-LIST DISPATCH-OFFSET-LIST)) (DEFSTRUCT (FEF-HEADER ; data for FEF header; not necessarily in final order. (:COPIER NIL) (:PREDICATE NIL) (:TYPE VECTOR)) HEADER ; header word at the beginning of the FEF LENGTH ; length of the FEF DEBUG-INFO ; debugging information list LONG-ARGS ; long-args word -- see %FEF-LONG-ARGS-WORD-FIELDS LOCAL-LENGTH ; number of local variables SELF-FLAVOR ; flavor of method ) (DEFVAR QLP-FEF-HEADER) ; information for FEF header -- an instance of FEF-HEADER (DEFVAR BREAKOFF-FUNCTION-OFFSETS) ;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. (DEFVAR QUOTE-LIST-LENGTH) ;;Length of the quote-vector, reflecting the ;;actual number of constants in the vector (DEFVAR QB) ;;This variable is used to record the fef offset of the quote-base (DEFCONSTANT MAX-SHORT-FEF-DISP #o277) ; Maximum FEF displacement for main-op with register. (DEFVAR SHORT-FEF-MAX-QUOTE-LENGTH) ;;The maximum number of words available ;;for constants in the quote vector. This ;;is calculated after the length of the fef header, ;;the number of optional header words, and the number ;;of special variables are known. (DEFPARAMETER HEADER-TYPE-FEF 524288) ;LAP-MODE may be QFASL, QFASL-NO-FDEFINE, REL, COMPILE-TO-CORE, DISASSEMBLE, or :JUST-COUNT. ;FOR QFASL-NO-FDEFINE, RETURNS FASL-TABLE INDEX OF FEF (DEFUN QLAPP (FCTN LAP-MODE) ;; 8/26/85 - Add binding of LOCAL-BLOCK-LENGTH. [SPR 558] ;; 9/30/85 - Include LOCAL-BLOCK-LENGTH with new structure QLP-FEF-HEADER. ;; 12/19/85 - Move setting of ALLVARS, FREEVARS, and SPECVARS to QLP1. ;; 1/05/86 - CLM When lap-mode is disassemble, LAP-OUTPUT-BLOCK will be called. ;; 3/05/86 - CLM Modify for FEF offsets greater than 191. ;; 7/29/86 DNG - When LAP-MODE is COMPILE-TO-CORE and the name is NIL, return the FEF. ;; 8/04/86 DNG - In COMPILE-TO-CORE mode, if the FDEFINE fails, then don't ;; try to define its :INTERNAL functions either. [SPR 1730 and 2632] ;; 9/24/86 DNG - Fix definition of :INTERNAL functions in encapsulations. [SPR 3 and 1167] ;; 1/22/87 DNG - Fix installation of :INTERNAL functions in parent that is a macro. ;; 1/08/88 CLM - Fix to not try to do handle :INTERNAL functions that have ;; been optimized out before QLAPP [SPR 7058]. ;; 3/16/89 DNG - Use new function FASD-INDEX. (PROG (SYMTAB ADR NBR SYMPTR SPECVARS SPECVARS-BIND-COUNT LOW-HALF-Q MAX-ARGS MIN-ARGS SM-ARGS-NOT-EVALD REST-ARG DATA-TYPE-CHECKING-FLAG LENGTH-OF-PROG PROG-ORG FCTN-NAME LAP-OUTPUT-AREA TEM LAP-LASTQ-MODIFIER QUOTE-LIST QUOTE-COUNT ALLVARS FREEVARS LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER LAP-MACRO-FLAG BREAKOFF-FUNCTION-OFFSETS DISPATCH-LIST DISPATCH-OFFSET-LIST QUOTE-LIST-LENGTH SHORT-FEF-MAX-QUOTE-LENGTH (QLP-FEF-HEADER (MAKE-FEF-HEADER))) ;;if this is an internal function that has been optimized out, do nothing and ;;return (LET ((FCTN-NAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) PARENT) (WHEN (AND (EQ (CAR-SAFE FCTN-NAME) ':INTERNAL) (SETQ PARENT (COMPILAND-PARENT *CURRENT-COMPILAND*)) (DEBUG-ASSERT (EQUAL (SECOND FCTN-NAME) (COMPILAND-FUNCTION-SPEC PARENT))) ) (LET* ((DEBUG-INFO (COMPILAND-DEBUG-INFO PARENT)) (INDEX (IF (FIXNUMP (THIRD FCTN-NAME)) (THIRD FCTN-NAME) (POSITION (THIRD FCTN-NAME) (THE LIST (GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-NAMES)) :TEST #'EQ)))) ;;the reference to the :internal function has ;;been optimized out (WHEN (NULL (NTH INDEX (GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-OFFSETS))) (RETURN) ) ))) (SETQ LAP-OUTPUT-AREA 'MACRO-COMPILED-PROGRAM) (SETQ MIN-ARGS 0) (SETQ MAX-ARGS 0) (SETQ SYMTAB (LIST NIL)) (SETQ QUOTE-COUNT 0) (SETQ QUOTE-LIST-LENGTH 0) (SETQ ADR 0) (QLAP-PASS1 FCTN) (RPLACD 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 (+ ADR (+ NBR (* 2 (LENGTH QUOTE-LIST))))) (SETQ SYMPTR SYMTAB) (SETQ QUOTE-COUNT 0) (SETQ ADR 0) (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)) (WHEN (OR LOW-HALF-Q (AND (OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (NOT (= 0 (LOGAND ADR 1))))) (LAP-OUTPUT-WORD 0 #+compiler:debug T)) #+compiler:debug (LET (OLD-FEF-LEN NEW-FEF-LEN) (WHEN (AND (NOT '#.SI:FILE-IN-COLD-LOAD) (SETQ OLD-FEF-LEN (FEF-LEN FCTN-NAME)) (SETQ NEW-FEF-LEN LAP-OUTPUT-BLOCK-LENGTH) (STRING-EQUAL USER-ID "GRAY")) ; no one else is interested ;; check that not generating worse code than previous version (COND ((< OLD-FEF-LEN NEW-FEF-LEN) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;Stream may cons (FORMAT T "~%Warning: the new FEF for ~S is ~D words longer than the old one." FCTN-NAME (- NEW-FEF-LEN OLD-FEF-LEN)))) ((AND (> OLD-FEF-LEN NEW-FEF-LEN) COMPILER-VERBOSE) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;Stream may cons (FORMAT T " ~D words shorter" (- OLD-FEF-LEN NEW-FEF-LEN))))))) (COND ((EQ LAP-MODE 'QFASL) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT) (BARF LAP-FASD-NIBBLE-COUNT 'LAP-FASD-NIBBLE-COUNT 'BARF)) ;; 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-INDEX TEM) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL)))) (FASD-STOREIN-FUNCTION-CELL FCTN-NAME TEM) (FASD-FUNCTION-END) (RETURN NIL)) ((EQ LAP-MODE 'QFASL-NO-FDEFINE) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT) (BARF LAP-FASD-NIBBLE-COUNT 'LAP-FASD-NIBBLE-COUNT 'BARF)) ;; 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-INDEX TEM) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL)))) (RETURN TEM)) ((EQ LAP-MODE 'COMPILE-TO-CORE) (LET (( DEF (IF LAP-MACRO-FLAG (CONS-IN-AREA 'MACRO LAP-OUTPUT-BLOCK BACKGROUND-CONS-AREA) LAP-OUTPUT-BLOCK) ) PARENT) (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'FEF) DEF) (IF (NULL FCTN-NAME) (RETURN DEF) (UNLESS (IF (AND (EQ (CAR-SAFE FCTN-NAME) ':INTERNAL) (SETQ PARENT (COMPILAND-PARENT *CURRENT-COMPILAND*)) (DEBUG-ASSERT (EQUAL (SECOND FCTN-NAME) (COMPILAND-FUNCTION-SPEC PARENT)))) ;; Refer directly to the parent FEF instead of its ;; name so that if we are compiling an encapsulation, ;; we don't try to store into the function being ;; encapsulated. [SPR 3 and 1167] (LET ((PARENT-FEF (GETF (COMPILAND-PLIST PARENT) 'FEF))) (WHEN (EQ (CAR-SAFE PARENT-FEF) 'MACRO) (SETQ PARENT-FEF (CDR PARENT-FEF))) (FDEFINE `(:INTERNAL ,PARENT-FEF . ,(CDDR FCTN-NAME)) DEF NIL)) ;; Else normal definition of unencapsulated function. (FDEFINE FCTN-NAME DEF T)) ;; If the function definition fails, then don't try to define ;; its :INTERNAL functions either. [SPR 1730 and 2632] (SETQ COMPILER-QUEUE NIL) (WHEN (< *RETURN-STATUS* FATAL) (SETQ *RETURN-STATUS* FATAL)))))) #+compiler:debug ((EQ LAP-MODE :JUST-COUNT)) #+compiler:debug ((EQ LAP-MODE 'DISASSEMBLE) (LOCALLY (DECLARE (SPECIAL *DISASSEMBLE-OPTIONS*)) (APPLY #'DISASSEMBLE LAP-OUTPUT-BLOCK *DISASSEMBLE-OPTIONS*))) #+compiler:debug ((EQ LAP-MODE :DUMP) (DUMP-FEF LAP-OUTPUT-BLOCK)) (T (FERROR NIL "~S is a bad lap mode" LAP-MODE)))) )) #+compiler:debug (DEFUN FEF-LEN (F) (COND ((EQL (%DATA-TYPE F) DTP-FEF-POINTER) (FEF-LENGTH F)) ((AND (VALIDATE-FUNCTION-SPEC F) (OR (NOT (EQ (CAR-SAFE F) :INTERNAL)) (AND (NEQ (CAR-SAFE (SECOND F)) :INTERNAL) (TYPEP (SI:FDEFINITION-SAFE (SECOND F)) 'COMPILED-FUNCTION))) (NOT (EQ (CAR-SAFE F) :SELECT-METHOD)) ; FDEFINEDP doesn't work right for these (FDEFINEDP F)) (FEF-LEN (FDEFINITION F))) (T NIL))) (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 () ;; 1/30/86 CLM - Modified for LONG-PUSHJ long branches. (PROG (T1 NBR) (SETQ NBR 0) (SETQ T1 SYMTAB) P2A (COND ((NULL (CDR T1)) (RETURN NBR)) ;FINALIZE SYM DEFS ((MEMBER (CADADR T1) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (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. (SETQ NBR (1+ NBR)) ;DOESNT AFFECT VALUE OF EVENTUAL BRANCH (GO P2A1) P2C (QLRLC (CADR T1) NBR) (GO P2A1))) (DEFUN QLAP-PASS2 (PNTR) (PROG ((%INHIBIT-READ-ONLY T)) ;For storing into the FEF. 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 (WHEN LAP-LASTQ-MODIFIER (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER)) (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) ;; 5/08/86 DNG - Give second arg of T to COPY-OBJECT-TREE so copying will ;; stop on sub-object that is not in the temporary area. (WHEN LAP-LASTQ-MODIFIER (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER)) (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))) ((MEMBER LAP-MODE '(COMPILE-TO-CORE #+compiler:debug DISASSEMBLE #+compiler:debug :DUMP) :TEST #'EQ) #+compiler:debug (WHEN (>= LAP-STORE-POINTER LAP-OUTPUT-BLOCK-LENGTH) (BARF S-EXP 'DOESNT-FIT-IN-ALLOCATED-BLOCK 'BARF)) ;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. (WHEN (AND #+compiler:debug (NEQ LAP-MODE 'DISASSEMBLE) (EQ (%AREA-NUMBER S-EXP) QCOMPILE-TEMPORARY-AREA)) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (SETQ S-EXP (SI:COPY-OBJECT-TREE S-EXP T)))) (%P-STORE-CONTENTS-OFFSET S-EXP LAP-OUTPUT-BLOCK LAP-STORE-POINTER) (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER))) #+compiler:debug ((EQ LAP-MODE :JUST-COUNT) (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER)))) (SETQ LAP-LASTQ-MODIFIER (+ 192 ;NXTCDR (COND ((NULL INVZ-P) 0) ((EQ INVZ-P 'QZEVCP) 16) ((EQ INVZ-P 'QZLOC) 256) ((EQ INVZ-P 'QZSRP) 512) (T (BARF INVZ-P 'LAP-Q-OUT 'BARF))) (IF OFFSET OFFSET 0)))) (DEFUN LAP-MODIFY-LASTQ (CODE) ;; 12/16/86 DNG - Update for TGC. ;; 1/15/87 DNG - Rel3 has different arg order for %P-STORE-DATA-TYPE-OFFSET etc. (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (LAP-FASD-NIBBLE CODE)) #+compiler:debug ((EQ LAP-MODE :JUST-COUNT)) (T (LET ((OFFSET (LOGAND CODE 15)) (IDX (1- LAP-STORE-POINTER))) (SI:%P-STORE-CDR-CODE-OFFSET (LSH CODE -6) LAP-OUTPUT-BLOCK IDX) (UNLESS (ZEROP OFFSET) (%P-STORE-CONTENTS-OFFSET (%MAKE-POINTER-OFFSET DTP-LOCATIVE (%P-CONTENTS-OFFSET LAP-OUTPUT-BLOCK IDX) OFFSET) LAP-OUTPUT-BLOCK IDX)) (COND ((LOGTEST 16 CODE) (SI:%P-STORE-DATA-TYPE-OFFSET DTP-EXTERNAL-VALUE-CELL-POINTER LAP-OUTPUT-BLOCK IDX)) ((LOGTEST 256 CODE) (SI:%P-STORE-DATA-TYPE-OFFSET DTP-LOCATIVE LAP-OUTPUT-BLOCK IDX)) ((LOGTEST 512 CODE) (SI:%P-STORE-DATA-TYPE-OFFSET DTP-SELF-REF-POINTER LAP-OUTPUT-BLOCK IDX)) ))))) (DEFUN LAP-OUTPUT-WORD #-compiler:debug (WD) #+compiler:debug (wd &OPTIONAL NOT-INSTRUCTION) ;; 09/07/85 DNG - Fix to not count non-instructions such as the second ;; half of a long branch. ;; 1/05/86 CLM - Commented out the code for lap-mode = disassemble. This ;; is now done in LAP-OUTPUT-BLOCK. (IF (OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (LAP-FASD-NIBBLE WD) (PROGN #+compiler:debug (UNLESS NOT-INSTRUCTION (WHEN (EQ LAP-MODE :JUST-COUNT) ;; Just count how many times each instruction is used. (UNLESS (= WD 0) ; 0 is used for filler at end (LET ((INSTR-USE-ARRAY (GET 'INST-USE-ARRAY TARGET-PROCESSOR))) (UNLESS (NULL INSTR-USE-ARRAY) (INCF (AREF INSTR-USE-ARRAY WD)))))) ;;this is now done by lap-output-block #|(WHEN (EQ LAP-MODE 'DISASSEMBLE) (LET (( PC (* LAP-STORE-POINTER 2) )) (UNLESS (NULL LOW-HALF-Q) (INCF PC 1)) (FORMAT T "~&~4@A " PC) (DISASSEMBLE-ONE-INSTRUCTION WD NIL LAP-OUTPUT-BLOCK PC) ) )|# ) (IF (NULL LOW-HALF-Q) (SETQ LOW-HALF-Q WD) (PROGN #+compiler:debug (WHEN (>= LAP-STORE-POINTER LAP-OUTPUT-BLOCK-LENGTH) (BARF WD 'DOESNT-FIT-IN-ALLOCATED-BLOCK 'BARF)) (OR #+compiler:debug (NULL LAP-OUTPUT-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) (SETQ LAP-STORE-POINTER (1+ LAP-STORE-POINTER))))))) (DEFUN LAP-STORE-NXTNIL-CDR-CODE () (SETQ LAP-LASTQ-MODIFIER (+ 128 (BOOLE 4 LAP-LASTQ-MODIFIER 192)))) (DEFUN LAP-HEADER (Q-LENGTH UNBOXED-LENGTH) ;; 3/05/86 CLM - Can now handle FEF offsets greater than 191 but less than ;; 512. ;; 5/08/86 DNG - Remove obsolete %HEADER-TYPE-FEF. ;; 12/24/86 DNG - Improve message for too many constants. ;; 4/07/88 CLM - Don't check for overlarge q-length if there are dispatches; ;; QLP2-U will check for dispatch/select fef addresses greater ;; than the limit. (WHEN (AND (> Q-LENGTH 512) (NULL DISPATCH-LIST)) (WARN 'Q-LENGTH :IMPLEMENTATION-LIMIT "This function is too big! The total number of distinct special variables, functions, and constants referenced is ~D, which is more than the maximum of 512 currently allowed in one FEF." Q-LENGTH)) (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)) (WHEN (EQ LAP-MODE 'QFASL) (FASD-FUNCTION-HEADER FCTN-NAME)) (FASD-START-GROUP NIL 3 (IF (COMPILING-FOR-EXPLORER-P) ;; new FEF header for Explorer FASL-OP-FEF ;; else old Cadr and Lambda format 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))) #+compiler:debug ((EQ LAP-MODE :JUST-COUNT) (SETQ LAP-OUTPUT-BLOCK-LENGTH ;TOTAL SIZE Q (2ND WORD OF FEF) (+ Q-LENGTH UNBOXED-LENGTH)) (SETQ LAP-STORE-POINTER 2)) (T (SETQ LAP-OUTPUT-BLOCK ;CREATE THE FEF (%ALLOCATE-AND-INITIALIZE DTP-FEF-POINTER ;DATA TYPE OF RETURNED POINTER #-Explorer DTP-HEADER #+Explorer DTP-FEF-HEADER ;HEADER (1ST WORD OF FEF) #-Explorer (%LOGDPB %HEADER-TYPE-FEF %%HEADER-TYPE-FIELD 0) #+Explorer 0 (SETQ LAP-OUTPUT-BLOCK-LENGTH ;TOTAL SIZE Q (2ND WORD OF FEF) (+ Q-LENGTH UNBOXED-LENGTH)) (WHEN (EQ LAP-MODE 'COMPILE-TO-CORE) MACRO-COMPILED-PROGRAM) LAP-OUTPUT-BLOCK-LENGTH)) ;AMOUNT TO ALLOCATE (SETQ LAP-STORE-POINTER 2)))) ;1ST TWO WDS DONE EXCEPT REST OF HEADER ;Q WILL BE FILLED IN LATER. (DEFUN LAP-FASD-NIBBLE (N) ;Don't call FASD with the temporary area in effect (DECLARE (INLINE FASD-NIBBLE)) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (SETQ LAP-FASD-NIBBLE-COUNT (1- LAP-FASD-NIBBLE-COUNT)) (FASD-NIBBLE N))) (DEFUN LAP-ARGP (VARHOME) (MEMBER (VAR-KIND VARHOME) '(FEF-ARG-REQ FEF-ARG-OPT FEF-ARG-KEY FEF-ARG-REST FEF-ARG-AUX) :TEST #'EQ)) ;; At the start of pass 2, when the MFEF pseudo is encountered, ;; output the fixed header Qs of the fef. (DEFUN LAP-MFEF (WD) ;; 1/25/85 DNG - Move old FEF symbols to SI package. ;; 10/02/85 DNG - Modified for Explorer release 3. ;; 12/19/85 DNG - Added call to new function COMPUTE-BREAKOFF-OFFSETS. ;; 1/08/86 DNG - Set the two flag bits in the CDR-CODE field of the header word. ;; 4/07/88 CLM - Added check to make sure pc-offset not larger than offset field ;; in header word. Also, removed pre-Release 3 code. ;; 11/08/88 DNG - Add setting of generic function flag. ;; 11/14/88 DNG - Add methods of local generic function to COMPILER-QUEUE. (LET* (HEADER QFEFHI-FCTN-NAME QFEFHI-STORAGE-LENGTH (UNBOXED-ORG (truncate (QLEVAL 'PROGSA 'T) 2)) ; PC word offset (LOCAL-BLOCK-LENGTH ; actual size of local variable block (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER)) (LOCAL-LIMIT 63) ; maximum allowed size of local variable block ) (SETQ FCTN-NAME (SECOND WD)) (SETQ QFEFHI-FCTN-NAME (OR (SIXTH WD) FCTN-NAME)) ;; Compute the header. (when (> UNBOXED-ORG (ldb (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-LOCATION-COUNTER-OFFSET) (lognot 0))) (barf UNBOXED-ORG "The location counter offset is greater than can be held in the FEF-header field" 'BARF)) (SETQ HEADER (DPB UNBOXED-ORG (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-LOCATION-COUNTER-OFFSET) (FEF-HEADER-HEADER QLP-FEF-HEADER)) LOCAL-LIMIT (LDB (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-NUMBER-OF-LOCALS) (LOGNOT 0))) (WHEN (> LOCAL-BLOCK-LENGTH LOCAL-LIMIT) (BARF (- LOCAL-BLOCK-LENGTH LOCAL-LIMIT) "more local block slots than maximum allowed." 'DATA)) (SETQ QFEFHI-STORAGE-LENGTH (LSH (1+ LENGTH-OF-PROG) -1)) (SETQ ADR (+ ADR (* 2 (SYMEVAL-FOR-TARGET '%FEF-HEADER-LENGTH)))) (WHEN (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER) (INCF ADR 2)) (LAP-HEADER UNBOXED-ORG ;Q PART LENGTH (- QFEFHI-STORAGE-LENGTH UNBOXED-ORG)) ;UNBOXED PART LENGTH (LET* ((TEM 0) (HEADER-CDR-CODE (progn (WHEN (OR SM-ARGS-NOT-EVALD (MEMBER '&FUNCTIONAL (EIGHTH WD) :TEST #'EQ)) ;; Will need to look at the argument list when compiling ;; calls to this function. (SETQ TEM (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SPECIAL-FORM) TEM))) (WHEN (SEVENTH WD) ; SUBST-FLAG ;; This is a DEFSUBST -- mark it for inline expansion. (SETQ TEM (DPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SUBST) TEM))) (LDB %%Q-CDR-CODE TEM))) (DEBUG-INFO (FEF-HEADER-DEBUG-INFO QLP-FEF-HEADER)) (GENERIC-FUNCTION (GET-DEBUG-INFO-FIELD DEBUG-INFO ':GENERIC-FUNCTION)) ) (WHEN GENERIC-FUNCTION (DOLIST (METHOD (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'INITIAL-METHODS)) (PUSH METHOD (CDR COMPILER-QUEUE)))) (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (SETQ PROG-ORG (LAP-D-OUT HEADER)) (SETQ LAP-LASTQ-MODIFIER (LSH HEADER-CDR-CODE 6)) (LAP-D-OUT QFEFHI-STORAGE-LENGTH) (WHEN GENERIC-FUNCTION (SETQ LAP-LASTQ-MODIFIER (LOGDIF LAP-LASTQ-MODIFIER '#.(LSH (LDB %%Q-CDR-CODE (DPB 1 sys:%%FEF-Storage-Length-Generic-Function-Flag 0)) 6)))) ) #+compiler:debug ((EQ LAP-MODE :JUST-COUNT)) ((COMPILING-FOR-EXPLORER-P) (%P-DPB DTP-FEF-HEADER %%Q-DATA-TYPE LAP-OUTPUT-BLOCK) (%P-DPB HEADER %%Q-POINTER LAP-OUTPUT-BLOCK) (%P-DPB HEADER-CDR-CODE %%Q-CDR-CODE LAP-OUTPUT-BLOCK) (WHEN GENERIC-FUNCTION (SETF (TICLOS:GENERIC-FUNCTION-DISCRIMINATOR-CODE GENERIC-FUNCTION) LAP-OUTPUT-BLOCK) (%P-DPB-OFFSET 0 sys:%%FEF-Storage-Length-Generic-Function-Flag LAP-OUTPUT-BLOCK 1) )) (T #+compiler:debug (UNLESS (EQ TARGET-PROCESSOR HOST-PROCESSOR) (FERROR NIL "Can't compile in memory for a ~A." TARGET-PROCESSOR)) (%P-DPB HEADER (SYMEVAL-FOR-TARGET '%%HEADER-REST-FIELD) LAP-OUTPUT-BLOCK))) (COMPUTE-BREAKOFF-OFFSETS DEBUG-INFO) (LAP-D-OUT (IF (LISTP DEBUG-INFO) (CONS `(:NAME ,QFEFHI-FCTN-NAME) DEBUG-INFO) DEBUG-INFO))) (LET ((ARGS-INFO (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER))) (UNLESS (NULL ARGS-INFO) (LAP-D-OUT ARGS-INFO))) (LAP-STORE-NXTNIL-CDR-CODE))) (DEFUN COMPUTE-BREAKOFF-OFFSETS (DEBUG-INFO) ;; If this function contains any internal functions, then update ;; the :INTERNAL-FEF-OFFSETS entry in the debug info with the actual ;; offsets in the FEF where the pointers to the internal FEFs are ;; stored. ;; ;; 12/19/85 DNG - Original version. ;; 7/23/86 CLM - Changed to handle the new format of the quote-list. For Rel. 3 only. ;; 8/08/86 DNG - Remove error on missing breakoff function. ;; 4/13/88 CLM - Added support for %GENERIC-FUNCTION-HASH-TABLE, and removed ;; compiling-for-v2 conditionals. ;; 8/04/88 DNG - Remove the DBI properties if no internal FEFs are found. ;; 4/29/89 DNG - Also remove :VARIABLES-USED-IN-LEXICAL-CLOSURES property when no internal FEFs. (LET (OFFSETS NAMES) (IF (LISTP DEBUG-INFO) (WHEN (SETQ OFFSETS (CDR (ASSOC :INTERNAL-FEF-OFFSETS DEBUG-INFO :TEST #'EQ))) (SETQ NAMES (CDR (ASSOC :INTERNAL-FEF-NAMES DEBUG-INFO :TEST #'EQ)))) (WHEN (SETQ OFFSETS (SI:GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-OFFSETS)) (SETQ NAMES (SI:GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-NAMES)))) ; if there are any internal functions or if this is a generic function ; look for references in the quote vector (when (or OFFSETS (getf (compiland-plist *current-compiland*) 'generic-function)) (DO ((QL QUOTE-LIST (CDR QL)) (OFFSET (+ (TRUNCATE ADR 2) ; FEF offset in words (LENGTH SPECVARS) (IF (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER) 1 0)) (+ OFFSET 1)) gfht) ((or (NULL QL) (and (null offsets) gfht))) (LET ((WD (FIRST QL))) (if (EQ (FIRST WD) 'BREAKOFF-FUNCTION) ;; WD = (BREAKOFF-FUNCTION (:INTERNAL parent child)) (LET ((F (THIRD (SECOND WD)))) (PUSH (CONS OFFSET F) BREAKOFF-FUNCTION-OFFSETS) ; for verification in QLP2-Q. (UNLESS (FIXNUMP F) ; map name to number. (SETQ F (POSITION F (THE LIST NAMES) :TEST #'EQ))) ;; Store the offset into the debug info. (SETF (NTH F OFFSETS) OFFSET)) (when (and (eq (first wd) '%GENERIC-FUNCTION-HASH-TABLE) (null gfht)) ;; wd = (%GENERIC-FUNCTION-HASH-TABLE) ;; store the offset into the debug info ;;using PUT-DEBUG-INFO-FIELD (dbi field value) (si:PUT-DEBUG-INFO-FIELD debug-info :GENERIC-FUNCTION-HASH-TABLE-OFFSET offset) (setq gfht t) ) ) ) ) (WHEN (EVERY #'NULL OFFSETS) (REMF (DBIS-PLIST DEBUG-INFO) :INTERNAL-FEF-OFFSETS) (REMF (DBIS-PLIST DEBUG-INFO) :INTERNAL-FEF-NAMES) (REMF (DBIS-PLIST DEBUG-INFO) :VARIABLES-USED-IN-LEXICAL-CLOSURES))) )) ;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. ;SM-VARS-NOT-EVALD, T if any arguments are not evaluated. (DEFUN SCAN-ARGS () ;; 1/08/86 DNG - Use DOLIST instead of DO. ;; 4/25/89 DNG - Eliminate use of VAR-EVAL and HAIRY-INIT-FLAG. (DOLIST (V ALLVARS) (CASE (VAR-KIND V) (FEF-ARG-REQ (SETQ MAX-ARGS (1+ MAX-ARGS)) (SETQ MIN-ARGS (1+ MIN-ARGS))) (FEF-ARG-OPT (SETQ MAX-ARGS (1+ MAX-ARGS))) (FEF-ARG-REST (SETQ REST-ARG V))) ) (WHEN (MEMBER '"E (COMPILAND-ARGLIST *CURRENT-COMPILAND*) :TEST #'EQ) (SETQ SM-ARGS-NOT-EVALD T)) (VALUES)) (DEFUN COMPUTE-FEF-HEADER () ;; Compute the FEF header word (except for the starting PC, which will ;; be filled in later) and the long-args word, if needed. ;; 9/30/85 - Original version. ;; 5/08/86 - Use %%FEF-HEADER-NUMBER-OPTIONAL-ARGS instead of %%FEFHI-HD-NUMBER-OPTIONAL-ARGS. (LET (CALL-TYPE (HEADER 0) (OPT-ARGS (- MAX-ARGS MIN-ARGS)) ; number of optional arguments (LONG-ARGS-WORD NIL) (LOCAL-BLOCK-LENGTH (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER))) (WHEN (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER) (SETQ HEADER (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SELF-MAPPING-TABLE) HEADER))) (SETQ CALL-TYPE (COND ((> OPT-ARGS 0) ;; There are some optional arguments. (COND (REST-ARG (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-OPTIONALS-AND-REST)) ((NOT (ZEROP LOCAL-BLOCK-LENGTH)) ; also some locals (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-OPTIONALS-AND-LOCALS)) (T (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-OPTIONALS)))) (REST-ARG (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-REST)) ((ZEROP LOCAL-BLOCK-LENGTH) (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-SIMPLE)) (T (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-LOCALS)))) (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-NUMBER-LOCALS))) (IF (<= LOCAL-BLOCK-LENGTH (LDB BYTE-DESC (LOGNOT 0))) ;; Few enough locals for count to fit in header word (SETQ HEADER (%LOGDPB LOCAL-BLOCK-LENGTH BYTE-DESC HEADER)) ;; Else "long call", need to look at long-args word for length. (SETQ LONG-ARGS-WORD T))) (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-NUMBER-ARGS))) (IF (<= MIN-ARGS (LDB BYTE-DESC (LOGNOT 0))) ;; Few enough required args for count to fit in header word (SETQ HEADER (%LOGDPB MIN-ARGS BYTE-DESC HEADER)) ;; Else "long call", need to look at long-args word. (SETQ LONG-ARGS-WORD T))) (LET ((BYTE-DESC (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-NUMBER-OPTIONAL-ARGS))) (IF (<= OPT-ARGS (LDB BYTE-DESC (LOGNOT 0))) ;; Few enough optional args for count to fit in header word (SETQ HEADER (%LOGDPB OPT-ARGS BYTE-DESC HEADER)) ;; Else "long call", need to look at Numeric Arg Descriptor (SETQ LONG-ARGS-WORD T))) (WHEN LONG-ARGS-WORD (SETQ CALL-TYPE (SYMEVAL-FOR-TARGET 'SI:%FEF-CALL-LONG)) (SETQ LONG-ARGS-WORD (%LOGDPB LOCAL-BLOCK-LENGTH (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-NUMBER-OF-LOCALS) (%LOGDPB MIN-ARGS (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-MIN-ARGS) (%LOGDPB MAX-ARGS (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-MAX-ARGS) 0)))) (UNLESS (ZEROP LOCAL-BLOCK-LENGTH) (SETQ LONG-ARGS-WORD (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-LOCALS) LONG-ARGS-WORD))) (WHEN (> OPT-ARGS 0) (SETQ LONG-ARGS-WORD (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-OPTIONALS) LONG-ARGS-WORD))) (WHEN REST-ARG (SETQ LONG-ARGS-WORD (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-LONG-ARGS-REST-ARG) LONG-ARGS-WORD)))) (SETQ HEADER (%LOGDPB CALL-TYPE (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-CALL-TYPE) HEADER)) (SETF (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER) LONG-ARGS-WORD) (SETF (FEF-HEADER-HEADER QLP-FEF-HEADER) HEADER))) ;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)))) ;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 () (PROG (SVS) (SETQ SPECVARS-BIND-COUNT 0) (DO ((VS ALLVARS (CDR VS))) ((NULL VS)) (AND (NEQ (VAR-TYPE (CAR VS)) 'FEF-LOCAL) (OR (WHEN (LAP-ARGP (CAR VS)) (SETQ SPECVARS-BIND-COUNT (1+ SPECVARS-BIND-COUNT)) T) (NOT (MEMBER (VAR-NAME (CAR VS)) SVS :TEST #'EQ))) (PUSH (VAR-NAME (CAR VS)) SVS))) (DO ((VS FREEVARS (CDR VS))) ((NULL VS)) (OR (MEMBER (CAR VS) SVS :TEST #'EQ) (PUSH (CAR VS) SVS))) (RETURN (REVERSE 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 (NOT (EQ SYM (CAADR SYMPTR))) ;SHOULD BE IN SAME ORDER AS PASS 1 (NOT (= VAL (CADDR (CADR SYMPTR))))) (GO S1E))) (RETURN (SETQ SYMPTR (CDR SYMPTR))) S1E (RETURN (BARF (LIST (CAR SYMPTR) SYM VAL) 'SYMPTR-LOSES 'BARF)))) (DEFUN QLP2-U (WD) ;PASS2 FOR UNBOXED AREA ;; 12/17/85 CLM - For release 3, added code for the DISPATCH instruction. ;; 5/15/86 DNG - MISC-INSTRUCTION-REQUIRED-DESTINATION-ALIST goes away in rel 3. ;; 9/08/86 CLM - Added code for SELECT instruction. ;; 4/07/88 CLM - Changed the BARF message for dispatch-offsets greater than the ;; maximum to match the warning given in LAP-HEADER. (DECLARE (OPTIMIZE SPEED)) (PROG () (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)) ((MEMBER (CAR WD) '(COMMENT NO-DROP-THROUGH PARAM) :TEST #'EQ) (RETURN NIL)) ((EQ (CAR WD) 'MISC) ;(MISC destination function) (LAP-OUTPUT-WORD (LAP-WORD-EVAL WD)) (GO X1)) ((MEMBER (CAR WD) '(DISPATCH SELECT) :TEST #'EQ) (LET ((OFFSET (TRUNCATE (CAR DISPATCH-OFFSET-LIST) 2))) (IF (> OFFSET 511) (BARF OFFSET "This function is too big! The total number of distinct special variables, functions, and constants referenced is ~D, which is more than the maximum of 512 currently allowed in one FEF." 'BARF) (PROGN (LAP-OUTPUT-WORD (+ (LAP-VALUE (CAR WD)) (TRUNCATE (CAR DISPATCH-OFFSET-LIST) 2))) (POP DISPATCH-OFFSET-LIST) (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 ADR (1+ ADR)) (RETURN NIL) S1 (QLP2-DEFSYM WD ADR) (RETURN NIL))) (DEFUN LAP-P2-DISPATCH (D-LIST) ;; 12/17/85 CLM - For release 3, code to emit dispatch tables. FEF offsets ;; for each table are recorded in dispatch-offset-list. ;; 12/20/85 DNG - Deleted call to LAP-MODIFY-LASTQ since it will be done ;; by QLAP-PASS2 and we get in trouble if we do it twice ;; when writing an XFASL file. ;; 4/03/86 CLM - Fixed a problem in calculating the FEF offset for a dispatch table. ;; 9/08/86 CLM - Added code for SELECT instruction. (DOLIST (ITEM D-LIST) (let ((pc-array (cadr item))) (PUSH ADR DISPATCH-OFFSET-LIST) ;;if this is a select, do the value-array first (when (cddr item) (let ((value-list (caddr item))) (lap-d-out (length value-list)) ;number of values (dolist (val value-list) (lap-d-out val)) (incf adr (* 2 (+ (length value-list) 1)))) ) (LAP-D-OUT (1- (LENGTH PC-ARRAY))) ;the max index (LAP-D-OUT (QLEVAL (CAR ITEM) 'T)) ;the otherwise-pc (DO ((I 0 (1+ I))) ((= I (LENGTH PC-ARRAY))) (LAP-D-OUT (QLEVAL (AREF PC-ARRAY I) 'T))) (LAP-STORE-NXTNIL-CDR-CODE) (INCF ADR (* 2 (+ (LENGTH PC-ARRAY) 2))))) (SETQ DISPATCH-OFFSET-LIST (NREVERSE DISPATCH-OFFSET-LIST))) (DEFUN QLP2-Q (WD);PASS2 FOR Q AREA ;; 7/24/85 - Allow :INTERNAL function specs with names in place of numbers. ;; 9/28/85 - For release 3, DEBUG-INFO is output LAP-MFEF instead of here. ;; 12/17/85 - For release 3, code added for the DISPATCH instruction. ;; 12/19/85 - Modify BREAKOFF-FUNCTION handling for release 3. ;; 6/14/86 DNG - Fix handling of method functions and self-ref for LAP-MODE of DISASSEMBLE. ;; 7/23/86 CLM - Changed the dumping of the quote-list to handle the new format of the list ;; for rel.3 only. ;; 8/08/86 DNG - Remove error on missing breakoff function. ;; 9/08/86 CLM - Added code for SELECT instruction. ;; 4/12/88 CLM - Support %GENERIC-FUNCTION-HASH-TABLE for CLOS. ;; 5/05/88 DNG - Added handling for TICLOS:CLOS-VAR-POINTER . ;; 5/06/88 DNG - Add handling for EVAL-AT-LOAD-TIME-MARKER . ;; 8/12/88 DNG - Watch out for CLOS-VAR-POINTER returning NIL. ;; 12/16/88 DNG - Don't call FUNCTION-REFERENCED for conditional calls from WITH-ADDED-METHODS. ;; 1/23/88 DNG - Add support for LOAD-TIME-VALUE . ;; 1/30/88 DNG - Add check for non-symbol function specs in cold load. ;; 2/28/89 DNG - Fix cold load function spec check to accept methods. (PROG () (COND ((ATOM WD) (IF (NOT (EQ WD 'PROGSA)) ;TAG HAD BETTER BE PROGSA (PROGN (BARF WD 'TAG-IN-Q-AREA 'BARF) (RETURN NIL)) (RETURN T))) ;ADVANCE TO UNBOXED AREA) ((EQ (CAR WD) 'QTAG) (QLP2-DEFSYM (CADR WD) (TRUNCATE ADR 2)) (WHEN (EQ (CADR WD) 'QUOTE-BASE) (MAPC #'QLP2-Q QUOTE-LIST)) ;DUMP QUOTE TABLE (RETURN NIL)) ((EQ (CAR WD) 'PARAM) (RETURN NIL)) ((EQ (CAR WD) 'ENDLIST) ;TERMINATE LIST THAT HAS JUST (LAP-STORE-NXTNIL-CDR-CODE) ;BEEN ASSEMBLED ;;code added 12/17/85 by CLM for dispatch tables (WHEN DISPATCH-LIST (SETQ DISPATCH-LIST (NREVERSE DISPATCH-LIST)) (LAP-P2-DISPATCH DISPATCH-LIST)) (RETURN NIL)) ((EQ (CAR WD) 'MFEF) (LAP-MFEF WD) (RETURN NIL)) ((EQ (CAR WD) 'S-V-BLOCK) (SETQ ADR (QLP2-S-V-BLOCK ADR)) (RETURN NIL)) ((EQ (CAR WD) 'CONSTRUCT-MACRO) (SETQ LAP-MACRO-FLAG T) (RETURN NIL)) ((EQ (CAR WD) 'DEBUG-INFO) ;; Already output by LAP-MFEF. (RETURN NIL)) ((EQ (CAR WD) 'VARIABLES-USED-IN-LEXICAL-CLOSURES) (LAP-D-OUT (CDR WD)) (LAP-STORE-NXTNIL-CDR-CODE) (GO X2)) ((EQ (CAR WD) 'SELF-FLAVOR) (LAP-D-OUT (CADR WD)) (LAP-STORE-NXTNIL-CDR-CODE) (GO X2)) ((EQ (CAR WD) 'BREAKOFFS) (RETURN NIL)) ((EQ (CAR WD) 'QUOTE) (LET ((VALUE (SECOND WD))) (LAP-D-OUT (IF (AND (CONSP VALUE) (EQ (CAR VALUE) EVAL-AT-LOAD-TIME-MARKER) (EQ LAP-MODE 'COMPILE-TO-CORE)) (COMPILE-TIME-EVAL (CDR VALUE) 'DECLARE) VALUE))) (GO X2)) ((EQ (CAR WD) 'LOCATIVE-TO-S-V-CELL) (LAP-Q-OUT NIL 'QZLOC '1 (CADR WD)) (GO X2)) ((EQ (CAR WD) 'FUNCTION) (IF (SYMBOLP (CADR WD)) (LAP-Q-OUT NIL 'QZEVCP '2 (CADR WD)) (PROGN (WHEN (AND FILE-IN-COLD-LOAD ;; Only those function specs understood by GENASYS::QFDEFINITION ;; can be used in cold load files. (NOT (MEMBER (CAR-SAFE (CADR WD)) '( :METHOD :INTERNAL ;; :PROPERTY ; this can be included if SPR 9458 is fixed. ) :TEST #'EQ))) ;; Will get an error in GENASYS:Q-FASL-OP-FRAME or ;; (:PROPERTY SYM:FDEFINITION-LOCATION :V*EVAL-FUNCTION) (WARN 'QZEVCP ':PROBABLE-ERROR "Reference to #'~S won't work in the cold load." (CADR WD))) (LAP-Q-OUT NIL 'QZEVCP NIL (IF (MEMBER LAP-MODE '(COMPILE-TO-CORE #+compiler:debug DISASSEMBLE #+compiler:debug :DUMP) :TEST #'EQ) (FDEFINITION-LOCATION (CADR WD)) (CONS EVAL-AT-LOAD-TIME-MARKER `(FDEFINITION-LOCATION ',(CADR WD))))))) (UNLESS (EQ (THIRD WD) 'DONT-RECORD) ; flag set by the handler for WITH-ADDED-METHODS (FUNCTION-REFERENCED (CADR WD) FCTN-NAME)) (GO X2)) ((EQ (CAR WD) 'SELF-REF) ; flavors instance variable or map (LAP-Q-OUT NIL 'QZSRP NIL (IF (MEMBER LAP-MODE '(COMPILE-TO-CORE #+compiler:debug DISASSEMBLE #+compiler:debug :DUMP) :TEST #'EQ) (SI:FLAVOR-VAR-SELF-REF-INDEX (CDR WD)) (CONS EVAL-AT-LOAD-TIME-MARKER `(SI:FLAVOR-VAR-SELF-REF-INDEX ',(CDR WD))))) (GO X2)) ((EQ (CAR WD) 'TICLOS:CLOS-VAR-POINTER) ; CLOS instance variable or map (IF (MEMBER LAP-MODE '(COMPILE-TO-CORE #+compiler:debug DISASSEMBLE #+compiler:debug :DUMP) :TEST #'EQ) (LET ((VALUE (EVAL WD))) (LAP-Q-OUT NIL (AND VALUE 'QZSRP) NIL VALUE)) (LAP-Q-OUT NIL 'QZSRP NIL (CONS EVAL-AT-LOAD-TIME-MARKER WD))) (GO X2)) ((EQ (CAR WD) 'BREAKOFF-FUNCTION) (LET ((F (CADDR (CADR WD)))) (UNLESS (EQ (TRUNCATE ADR 2) (CAR (RASSOC F BREAKOFF-FUNCTION-OFFSETS :TEST #'EQ))) (BARF WD "offset discrepency" 'BARF))) (LAP-D-OUT (CADR WD)) (GO X2)) ;;;clm 4/12/88 ;;;new for clos ((eq (car wd) '%GENERIC-FUNCTION-HASH-TABLE) (lap-d-out nil) (go x2)) ((EQ (CAR WD) 'TAG) (LAP-D-OUT (QLEVAL (CADR WD) T)) (GO X2)) ((EQ (CAR WD) 'LOAD-TIME-VALUE) (LET ((FORM (SECOND WD)) (DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (COND ((OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (WHEN LAP-LASTQ-MODIFIER (LAP-MODIFY-LASTQ LAP-LASTQ-MODIFIER)) (FASD-EVAL1 FORM NIL (NOT (THIRD WD))) (SETQ LAP-LASTQ-MODIFIER 192) ; NXTCDR ) ((MEMBER LAP-MODE '(COMPILE-TO-CORE #+compiler:debug DISASSEMBLE #+compiler:debug :DUMP) :TEST #'EQ) (LAP-D-OUT (EVAL-FOR-TARGET FORM)) ))) (GO X2)) ;; not used anymore -- DNG 1/23/89 ;;((EQ (CAR WD) 'FIXE) ;; (LAP-D-OUT (LAP-WORD-EVAL `(EXTENDED-ADDRESS 0 ,(CADR WD)))) ;; (GO X2)) (T (BARF WD 'UNKNOWN-OP-IN-Q-AREA-LAP 'BARF) (RETURN NIL))) X2 (SETQ ADR (+ 2 ADR)))) (DEFUN FUNCTION-REFERENCED (WHAT BY) ;; Collect functions referenced ;; 3/14/86 DNG - Don't use FUNCTION-P when cross-compiling without defaulting. ;; 10/02/87 DNG - Updated to give more meaningful function names when compiling Scheme. ;; 1/30/89 DNG - Include above change in this file because it helps CLOS methods also. (UNLESS (AND (OR *DEFAULT-DEFS-FROM-HOST* (EQ TARGET-PROCESSOR HOST-PROCESSOR)) (FUNCTION-P WHAT)) ;defined in QCP1 (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA) (ENTRY (ASSOC WHAT FUNCTIONS-REFERENCED :TEST #'EQUAL))) ;; maybe the following changes to BY should be done somewhere higher up instead? (WHEN (OR (NULL BY) (AND (CONSP BY) (EQ (FIRST BY) ':INTERNAL) (LISTP (SECOND BY)))) (SETQ BY (COMPILAND-FUNCTION-NAME *CURRENT-COMPILAND*))) (WHEN (AND (CONSP BY) (EQ (FIRST BY) ':INTERNAL) (SYMBOLP (SECOND BY)) (SYMBOLP (THIRD BY)) (OR (NULL (SECOND BY)) (NULL (SYMBOL-PACKAGE (SECOND BY))))) ;; Replace (:INTERNAL #:G0000 FOO) with FOO since the rest is not useful. (SETQ BY (THIRD BY))) (SETQ BY (COPY-TREE BY)) ;Could be (:METHOD ...) (IF ENTRY (RPLACD ENTRY (CONS BY (CDR ENTRY))) (PUSH (LIST (COPY-TREE WHAT) BY) FUNCTIONS-REFERENCED))))) ;Output the block of forwarding pointers to value cells of special variables. ;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 (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 ADR 2)) ADR) (PROCLAIM '(INLINE LAP-ADR-P1)) (DEFUN LAP-ADR-P1 (ADDRESS &OPTIONAL WD) ;; 9/30/85 - Change name of argument so it is not a special variable. ;; 3/05/86 - CLM Pass WD to QADD in order to check for certain instructions. ;; 3/07/86 - CLM Change WD to an optional argument to prevent breakage by ;; old style adi-call's. ;; 8/10/87 DNG - Add special handling for SPECIAL address with displacement > 191. [SPR 6224] (COND ((ATOM ADDRESS) NIL) ((EQ (CAR ADDRESS) 'QUOTE-VECTOR) (QADD (CADR ADDRESS) WD)) ((EQ (CAR ADDRESS) 'SPECIAL) (WHEN (> (LAP-SPECIAL-ADR (SECOND ADDRESS)) MAX-SHORT-FEF-DISP) ;; will need to use PUSH-LONG-FEF (UNLESS (AND (EQ (CAR WD) 'MOVE) (EQ (CADR WD) 'D-PDL)) (INCF ADR) )) ))) (DEFUN QLP1 (WD) ;; 8/26/85 - Set variable LOCAL-BLOCK-LENGTH directly here. [SPR 558] ;; 9/30/85 - For release 3, don't increment ADR for DEBUG-INFO; ;; make %FEF-HEADER-LENGTH target-dependent; move ;; LOCAL-BLOCK-LENGTH into QLP-FEF-HEADER. ;; 12/17/85 - For release 3, added code for the DISPATCH instruction. ;; 12/19/85 - Moved setting of ALLVARS, FREEVARS, and SPECVARS here from QLAPP. ;; 1/30/86 CLM - Modified so that a branch to UNWIND-PROTECT cleanup-forms ;; will be handled as a LONG-PUSHJ long-branch. ;; 3/05/86 CLM - Modified to keep track of short-fef-max-quote-length. Done to ;; handle fef offsets greater than 191. ;; 3/07/86 CLM - Only use the above patch if compiling for vm2. ;; 3/25/86 DNG - Set mapping table flag in the FEF header when the SELF-FLAVOR ;; declaration is encountered because the header has already been computed. ;; 4/03/86 CLM - Fixed a problem in calculating the FEF offset of a dispatch table. ;; 7/23/86 CLM - Record the position of QUOTE-BASE in the var QB; will be used in QADD ;; to determine positions of constants in the quote-list. For rel.3 only. ;; 9/08/86 CLM - Added code for SELECT instruction. ;; 01/16/87 CLM - When calculating SHORT-FEF-MAX-QUOTE-LENGTH, use 192 (not 191). The value ;; should indicate length not an offset. ;; 4/10/89 DNG - Deleted call to COMPUTE-A-D-L-NEEDED-P. (PROG NIL (COND ((NULL WD) (RETURN NIL)) ((ATOM WD) (GO S1)) ((EQ (CAR WD) 'RESTART-TAG) (SETQ WD (CADR WD)) (GO S1)) ((EQ (CAR WD) 'QTAG) (WHEN (EQ (CADR WD) 'QUOTE-BASE) (SETQ SHORT-FEF-MAX-QUOTE-LENGTH (- 192 (TRUNCATE ADR 2)))) (DEFLAPSYM (CADR WD) (TRUNCATE ADR 2) 'TDEF) (WHEN (EQ (CADR WD) 'QUOTE-BASE) (SETF QB (QLEVAL 'QUOTE-BASE T))) (RETURN ADR)) ((EQ (CAR WD) 'BRANCH) ;;the following clause added 1/30/86 by CLM ;;'pushj was an arbitrary choice, it may change (IF (EQ (CADR WD) 'PUSHJ) (DEFLAPSYM (CAR (LAST WD)) ADR 'BRANCH-PUSHJ) (DEFLAPSYM (CAR (LAST WD)) ADR 'BRANCH)) (GO X1)) ((EQ (CAR WD) 'PARAM) (IF (EQ (CADR WD) 'LLOCBLOCK) (PROGN (SETF (FEF-HEADER-LOCAL-LENGTH QLP-FEF-HEADER) (CADDR WD)) (COMPUTE-FEF-HEADER) (UNLESS (NULL (FEF-HEADER-LONG-ARGS QLP-FEF-HEADER)) ;; The long-args word will be present. (INCF ADR 2)) (RETURN NIL)) (RETURN (SETF (LAP-VALUE (CADR WD)) (QLEVAL (CADDR WD) T))))) ((MEMBER (CAR WD) '(ENDLIST COMMENT NO-DROP-THROUGH) :TEST #'EQ) (RETURN NIL)) ((EQ (CAR WD) 'MFEF) (SETQ ALLVARS (FOURTH WD) FREEVARS (FIFTH WD)) (SETQ SPECVARS (EXTRACT-SPECVARS)) (SCAN-ARGS) (INCF ADR (* 2 (SYMEVAL-FOR-TARGET '%FEF-HEADER-LENGTH))) (RETURN NIL)) ((EQ (CAR WD) 'S-V-BLOCK) (SETQ ADR (+ ADR (* 2 (LENGTH SPECVARS)))) (RETURN NIL)) ((EQ (CAR WD) 'CONSTRUCT-MACRO) (RETURN NIL)) ((EQ (CAR WD) 'DEBUG-INFO) (SETF (FEF-HEADER-DEBUG-INFO QLP-FEF-HEADER) (CDR WD)) (RETURN ADR)) ((EQ (CAR WD) 'VARIABLES-USED-IN-LEXICAL-CLOSURES) (RETURN (SETQ ADR (+ 2 ADR)))) ((EQ (CAR WD) 'SELF-FLAVOR) (SETF (FEF-HEADER-SELF-FLAVOR QLP-FEF-HEADER) (CADR WD)) (SETF (FEF-HEADER-HEADER QLP-FEF-HEADER) (%LOGDPB 1 (SYMEVAL-FOR-TARGET 'SI:%%FEF-HEADER-SELF-MAPPING-TABLE) (FEF-HEADER-HEADER QLP-FEF-HEADER))) (RETURN (SETQ ADR (+ 2 ADR)))) ((MEMBER (CAR WD) '(QUOTE LOCATIVE-TO-S-V-CELL FIXE TAG) :TEST #'EQ) (RETURN (SETQ ADR (+ 2 ADR)))) ((EQ (CAR WD) 'BREAKOFFS) (RETURN NIL)) ;;added 12/17/85 by CLM for rel.3 to adjust the current adr ;;and the symtab adrs for a dispatch table. ((EQ (CAR WD) 'DISPATCH) (LET ((TEM (LAP-SYMTAB-PLACE 'PROGSA))) (LAP-SYMTAB-RELOC (CADDAR TEM) (* 2 (+ (LENGTH (CADDR WD)) 2)) (CDR SYMTAB)) (PUSH (CDR WD) DISPATCH-LIST) (INCF ADR (* 2 (+ (LENGTH (CADDR WD)) 2)))) (GO X1)) ((eq (car wd) 'select) (let ((tem (lap-symtab-place 'progsa))) (lap-symtab-reloc (caddar tem) ;;the length of the pc-array should equal the length of ;;the value-array ;;the other 3 words are for the length of the select table ;;the max dispatch index and the otherwise pc (* 2 (+ (* 2 (length (caddr wd))) 3)) (cdr symtab)) (push (cdr wd) dispatch-list) (incf adr (* 2 (+ (* 2 (length (caddr wd))) 3))) ) (go x1)) (T (LAP-ADR-P1 (CADDR WD) WD) (GO X1))) X1 (RETURN (SETQ ADR (1+ ADR))) S1 (RETURN (DEFLAPSYM WD ADR 'TDEF)))) ;; 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 &OPTIONAL WD) ;; 3/05/86 CLM - If number of constants is greater than max allowed in a "short" ;; fef, must use the PUSH-LONG-FEF instruction perhaps in conjunction ;; with the original instruction. If two instructions are needed, ;; incf the adr to account for the second instruction. ;; 3/07/86 CLM - Change WD to an optional argument to prevent breakage by old ;; style adi-call's. ;; 6/20/86 CLM - If the constant is already in the quote-list, check to see if the ;; instruction will require the use of PUSH-LONG-FEF; i.e., the ;; constant occurs in the quote-list at a point beyond SHORT-FEF-MAX- ;; QUOTE-LENGTH. ;; 7/23/86 CLM - Changed the handling of instructions containing constants. Now the ;; fef offset of the constant is placed into the instruction itself ;; during pass 1. This makes the pass 2 function LAP-QUOTE-ADR no ;; longer necessary. The format of the quote-list has also changed ;; - consing the quote-count onto an entry is no longer necessary. ;; QB holds the offset of the quote-base. This is for Rel. 3 only. ;; 8/25/88 clm - Problem occurred if long-fef instruction was already modified, ;; the ADR wasn't being incremented [spr 8670]. ;; 1/23/89 DNG - Don't merge LOAD-TIME-VALUE forms. (DECLARE (INLINE ASSOC)) (LET ( #-Common-Lisp (ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON T) TM) (OR (NULL X) (OR (AND (NUMBERP X) ;to prevent problems from an istruction already modified (PROG1 T (WHEN (> X SHORT-FEF-MAX-QUOTE-LENGTH) (UNLESS (AND (EQ (CAR WD) 'MOVE) (EQ (CADR WD) 'D-PDL)) (INCF ADR) )))) (PROGN (AND (NOT (OR (EQ (CAR X) 'LOAD-TIME-VALUE) (CONTAINS-LOAD-TIME-EVAL X))) (SETQ TM (POSITION X (THE LIST QUOTE-LIST) :TEST #'EQUAL)) ;it's already on the list (SETF (CADR (THIRD WD)) (+ QB (- QUOTE-LIST-LENGTH TM 1)) ) (PROG1 T (WHEN (> (- QUOTE-LIST-LENGTH TM) SHORT-FEF-MAX-QUOTE-LENGTH) (UNLESS (AND (EQ (CAR WD) 'MOVE) (EQ (CADR WD) 'D-PDL)) (INCF ADR) ) )))) (PROGN (PUSH X QUOTE-LIST) (INCF QUOTE-LIST-LENGTH) (SETF (CADR (THIRD WD)) (+ QUOTE-COUNT QB)) (WHEN (> QUOTE-LIST-LENGTH SHORT-FEF-MAX-QUOTE-LENGTH) (UNLESS (AND (EQ (CAR WD) 'MOVE) (EQ (CADR WD) 'D-PDL)) (INCF ADR) )) (SETQ QUOTE-COUNT (1+ QUOTE-COUNT))) ) ;or ))) ;; 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) (DECLARE (OPTIMIZE SPEED) (INLINE CONTAINS-LOAD-TIME-EVAL)) (DO ((F FORM (CDR F))) ((ATOM F) NIL) (AND (OR (AND FASD-MAGIC-AREAS-ALIST (ASSOC (%AREA-NUMBER F) FASD-MAGIC-AREAS-ALIST :TEST #'EQ)) (IF (ATOM (CAR F)) (ASSOC (CAR F) FASD-MARKERS-ALIST :TEST #'EQ) (CONTAINS-LOAD-TIME-EVAL (CAR F)))) (RETURN T)))) ;Var is either the name or the index of a special variable. (DEFUN LAP-SPECIAL-ADR (VAR) (PROG (TM) (COND ((NUMBERP VAR) (RETURN (+ VAR (QLEVAL 'S-V-BASE T)))) ((SETQ TM (POSITION VAR (THE LIST SPECVARS) :TEST #'EQ)) (RETURN (+ TM (QLEVAL 'S-V-BASE T)))) (T (BARF VAR 'NOT-ON-SPECIAL-VAR-LIST 'BARF) (RETURN 0))))) ;QLAP SYMBOL TABLE.. ; 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 NREVERSE D PRIOR TO PASS2. ;ENTRIES ARE OF TWO TYPES, DEFINITIONS OF SYMBOLS AND NOTATIONS THAT A ; BRANCH WHICH MIGHT TAKE TWO "WORDS" OCCURRED. THESE LATER ARE REMOVED AS ; SOON AS IT CAN BE DETERMINED THAT THE BRANCH CAN DEFINITELY "MAKE IT" IN ; ONE WORD (IE MAGNITUDE OF DELTA IS < OR = 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 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 'CANT-FIND-PLACE 'BARF)) ((EQ (CAAR STP) SYM) (RETURN STP))) (SETQ STP (CDR STP)) (GO L))) (DEFUN LAP-SYMTAB-RELOC (BOTTOM AMT STP) ;RELOCATE SYMTAB ITEMS IN SYMTAB SEGMENT POINTED ;TO BY STP BY AMOUNT AMT (PROG (TEM) ;IF THEY ARE .GE. BOTTOM (SETQ 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) ;; 1/30/86 CLM - Modified to handle LONG-PUSHJ long branches ;; 4/04/86 CLM - Prevent a branch instruction to itself from ;; being compiled into a long-branch instruction. ;; Also emit a warning for such cases that an infinite ;; loop has been created. (PROG (STP NBR TM) (SETQ STP SYMTAB) (SETQ NBR 0) L (COND ((NULL (CDR STP)) (GO L1)) ((EQ (CAADR STP) SYM) (GO L2)) ((MEMBER (CADADR STP) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (SETQ NBR (1+ NBR)))) L3 (SETQ STP (CDR STP)) (GO L) L1 (RETURN (RPLACD SYMTAB (CONS (LIST SYM TYPE VAL) (CDR SYMTAB)))) L2 (COND ((MEMBER TYPE '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (GO L2C)) ((MEMBER (CADADR STP) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (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 'DATA))) L2A (UNLESS (EQ TYPE 'TDEF) (BARF TYPE 'BAD-TYPE 'BARF)) (SETQ TM (+ VAL NBR)) ;HIGHEST POSSIBLE VALUE L2B (COND ((EQ (CADADR STP) 'BRANCH-PUSHJ)) ((< (- TM (CADDR (CADR STP))) 255) (RPLACD STP (CDDR STP)) ;short branches removed here (GO L))) ;THAT BRANCH WILL MAKE IT (GO L3) ;MAYBE IT WONT L2C (COND ((MEMBER (CADADR STP) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (GO L1)) ;THAT BRANCH DIDNT MAKE IT ;SO THIS ONE WONT ((= VAL (CADDR (CADR STP))) (WARN 'DEFLAPSYM :IMPLAUSIBLE "An infinite loop has been created.") (RETURN NIL)) ;EITHER JMP . LOSES! ((EQ TYPE 'BRANCH-PUSHJ)) ;force a long branch ((< (- (+ VAL NBR) (CADDR (CADR STP))) 255) (RETURN NIL))) ;THIS ONE DEFINITELY MAKES IT (GO L1))) (DEFUN LAP-WORD-EVAL (WORD) ;; 7/10/85 - Modified for release 3 instruction set. ;; 7/20/85 - Keep MISC-op values separate from main opcodes. ;; 8/10/85 - Add case for AUX-op. ;; 8/21/85 - Re-instate EXTENDED-ADDRESS; eliminate use of PROG; ;; add debug calls to WARN. ;; 9/26/85 - Add special handling for AREFI and MODULE-GROUP; ;; modify destination handling for CALL. ;; 3/05/86 - CLM Add special handling for fef offsets greater than ;; 191. ;; 7/23/86 CLM - No longer call LAP-QUOTE-ADR to get offset of constants. This ;; is now handled in pass 1. For Rel. 3 only. ;; 10/11/86 DNG - Permit misc-op numbers instead of names. ;; 8/10/87 DNG - Fix handling of SPECIAL address with displacement > 191. [SPR 6224] ;; 01/20/89 clm - Fix handling of SELF-REF address with displacement > 191. [SPR 9167]; ;; also removed code for pre-Release 3 versions. (DECLARE (INLINE GET-FOR-TARGET #-compiler:debug LAP-VALUE) (OPTIMIZE (SPEED 2) (SPACE 1))) (LET ((WD WORD) (VL 0) TM) (IF (EQ (FIRST WD) 'EXTENDED-ADDRESS) ; used for FIXE in ADL ;; 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. (LET ((INDEX (CADR (CADDR WD)))) (SETQ VL (+ (LSH (LDB (BYTE 4 6) INDEX) 9) (LDB (BYTE 6 0) INDEX))) (SETQ WD (LIST (CADR WD) (CAR (CADDR WD))))) (CASE (FIRST WD) (MOVE (SETQ VL (LAP-VALUE (CASE (SECOND WD) ((D-INDS D-IGNORE 0) 'TEST) (D-PDL 'PUSH) (D-RETURN 'RETURN) #+compiler:debug ((D-LAST D-NEXT) 'PUSH) ; temporary until *CATCH is updated (OTHERWISE (BARF (SECOND WD) "invalid destination" 'BARF))))) (SETQ WD (CDDR WD))) (MISC (SETQ VL (LAP-VALUE (CASE (SECOND WD) (D-PDL 'PUSH-MISC-GROUP) ((D-INDS D-IGNORE 0) 'TEST-MISC-GROUP) #+compiler:debug ((D-RETURN D-NEXT D-LAST) (WARN 'LAP-WORD-EVAL :BUG "Invalid destination: ~A" WORD) (RETURN-FROM LAP-WORD-EVAL 0)) (OTHERWISE (BARF WD "invalid destination" 'BARF))))) (LET ((MISCVAL (THIRD WD))) (UNLESS (FIXNUMP MISCVAL) (SETQ MISCVAL (MISC-OP-EVAL MISCVAL)) #+compiler:debug (WHEN (NULL MISCVAL) (WARN 'LAP-WORD-EVAL :BUG "Undefined Misc-op: ~A" WORD) (RETURN-FROM LAP-WORD-EVAL 0))) (SETQ VL (+ VL MISCVAL))) (SETQ WD (CDDDR WD))) ;; (CALL dest function count) (CALL (SETQ VL (DPB (LAP-VALUE (SECOND WD)) (SYMEVAL-FOR-TARGET '%%QMI-CALL-DEST) (DPB (FOURTH WD) ; number of arguments (SYMEVAL-FOR-TARGET '%%QMI-CALL-NUMARGS) (LAP-VALUE 'CALL-0)))) (SETQ WD (LIST (THIRD WD)))) ;; (CALL-N dest function) (CALL-N (SETQ VL (DPB (LAP-VALUE (SECOND WD)) (SYMEVAL-FOR-TARGET '%%QMI-CALL-DEST) (LAP-VALUE 'CALL-N))) (SETQ WD (CDDR WD))) (BRANCH NIL) (AUX (SETQ WD (CDR WD))) ;; (AREFI dest operation index) (AREFI (SETQ VL (LOGIOR (LAP-VALUE (CASE (SECOND WD) (D-PDL 'PUSH-AREFI) ((D-INDS D-IGNORE 0) 'TEST-AREFI) #+compiler:debug ((D-RETURN D-NEXT D-LAST) (WARN 'LAP-WORD-EVAL :BUG "Invalid destination: ~A" WORD) (RETURN-FROM LAP-WORD-EVAL 0)) (OTHERWISE (BARF WD "invalid destination" 'BARF)))) (GET (THIRD WD) 'AREFI))) (SETQ WD (CDDDR WD))) (MODULE-GROUP (SETQ VL (LAP-VALUE (CASE (SECOND WD) (D-PDL 'PUSH-MODULE-GROUP) ((D-INDS D-IGNORE 0) 'TEST-MODULE-GROUP) #+compiler:debug ((D-RETURN D-NEXT D-LAST) (WARN 'LAP-WORD-EVAL :BUG "Invalid destination: ~A" WORD) (RETURN-FROM LAP-WORD-EVAL 0)) (OTHERWISE (BARF WD "invalid destination" 'BARF))))) (SETQ WD (CDDR WD))) ((SELECT DISPATCH) (WARN 'LAP-WORD-EVAL :IMPLEMENTATION-LIMIT "QLAPP does not yet support the ~S instruction." (FIRST WD)) (SETQ VL (LAP-VALUE (FIRST WD))) (SETQ WD NIL)) (OTHERWISE (SETQ VL (IF (SYMBOLP (FIRST WD)) (LAP-VALUE (FIRST WD)) (FIRST WD))) #+compiler:debug (UNLESS (FIXNUMP VL) (WARN 'LAP-WORD-EVAL :BUG "Undefined instruction: ~A" WORD) (RETURN-FROM LAP-WORD-EVAL 0)) (SETQ WD (CDR WD)))) ) ; end of IF (LOOP (COND ((NULL WD) (RETURN-FROM LAP-WORD-EVAL VL)) ((NUMBERP (SETQ TM (CAR WD)))) ((ATOM (CAR WD)) (WHEN (NULL (SETQ TM (LAP-VALUE (CAR WD)))) (BARF WD 'UNDEFINED-IN-WORD 'BARF) (SETQ TM 0))) ((EQ (CAAR WD) 'QUOTE-VECTOR) (SETQ TM (CADAR WD)) ;;if tm > #o277 then need to do long-fef ;;addressing. (WHEN (> TM MAX-SHORT-FEF-DISP) (WHEN (EQ (GET (CAR WORD) 'DEST) 'D-STORE) ;; clm 01/20/89 ;; If this is a store instead of a load, then we are stuck. ;; Store instructions cannot handle long-fef addresses in their ;; offset field (WARN 'LAP-WORD-EVAL :IMPLEMENTATION-LIMIT "Can't generate ~A to ~S because there are too many special and/or instance variables referenced in this function." (CAR WORD) (caddr (nth (- tm qb) quote-list)))) (LET ((VL2 (LAP-VALUE 'PUSH-LONG-FEF))) (SETQ VL2 (+ VL2 TM)) (IF (= VL (LAP-VALUE 'PUSH)) ;;don't need the extra push inst (RETURN-FROM LAP-WORD-EVAL VL2) (PROGN (LAP-OUTPUT-WORD VL2) (SETQ ADR (1+ ADR)) (SETQ TM (LAP-VALUE 'PDL-POP))))))) ((EQ (CAAR WD) 'SPECIAL) (SETQ TM (LAP-SPECIAL-ADR (CADAR WD))) (WHEN (> TM MAX-SHORT-FEF-DISP) (WHEN (EQ (GET (CAR WORD) 'DEST) 'D-STORE) ;; If this is a store instead of a load, then we are stuck. ;; This won't happen very often since bound variables go on SPECVARS before ;; free variables, so this is only likely when SETQing a free variable. (WARN 'LAP-WORD-EVAL :IMPLEMENTATION-LIMIT "Can't generate ~A to ~S because there are too many special variables referenced in this function." (CAR WORD) (CADAR WD))) (LET ((VL2 (LAP-VALUE 'PUSH-LONG-FEF))) (SETQ VL2 (+ VL2 TM)) (IF (= VL (LAP-VALUE 'PUSH)) ;;don't need the extra push inst (RETURN-FROM LAP-WORD-EVAL VL2) (PROGN (LAP-OUTPUT-WORD VL2) (SETQ ADR (1+ ADR)) (SETQ TM (LAP-VALUE 'PDL-POP))))))) (T (SETQ TM (QLEVAL (CAR WD) NIL)))) (SETQ VL (+ VL TM)) (SETQ WD (CDR WD))) ; end of DO-FOREVER )) ; end of LAP-WORD-EVAL (DEFUN QLEVAL (X FLAG);FLAG ->T, USE SYMTAB, NIL-> QLVAL PROPS ;; 1/30/86 CLM - Modified for LONG-PUSHJ long branches. (DECLARE (OPTIMIZE SPEED) (INLINE GET-FOR-TARGET #-compiler:debug LAP-VALUE)) (PROG (VL) (SETQ VL 0) (COND ((NUMBERP X) (RETURN X)) ((ATOM X) (GO S1))) L1 (SETQ VL (+ (QLEVAL (CAR X) FLAG) VL)) (WHEN (NULL (SETQ X (CDR X))) (RETURN VL)) (GO L1) S1 (COND (FLAG (GO S1A)) ((NULL (SETQ VL (LAP-VALUE X))) (GO S1A)) (T (RETURN VL))) S1A (SETQ VL SYMTAB) S2 (COND ((NULL (CDR VL)) (GO E1)) ((AND (EQ (CAADR VL) X) (NOT (MEMBER (CADADR VL) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ))) (RETURN (CADDR (CADR VL))))) (SETQ VL (CDR VL)) (GO S2) E1 (BARF X 'UNDEFINED 'DATA))) (DEFUN QLRLC (ENTRY AMT) (UNLESS (= 0 AMT) (RPLACA (CDDR ENTRY) (+ AMT (CADDR ENTRY))))) (DEFUN QB2 (CONDITION TAG) ;; 7/23/85 - Modifed for Explorer release 3. ;; 12/05/85 CLM - Modified for Rel.3 to output the correct ;; long-branch instructions. ;; 1/20/86 CLM - Corrected for long branches to use absolute ;; addressing instead of relative. ;; 1/30/86 CLM - Modified for LONG-PUSHJ long branches. ;; 1/16/87 CLM - Fixed to not barf on infinite loops in Rel3. (LET (VL TM2) (IF (EQL (CAR CONDITION) 'PUSHJ) (SETQ VL (LSH (LAP-VALUE 'LONG-PUSHJ) 9)) (SETQ VL (CDR (ASSOC CONDITION (GET-FOR-TARGET (FIRST CONDITION) 'DEF-BRANCH-OP) :TEST #'EQUAL)))) (WHEN (NULL VL) (BARF CONDITION 'NON-EXISTANT-CONDITION 'BARF)) (SETQ TM2 (- (QLEVAL TAG T) ADR)) (COND ((NULL (CDR SYMPTR))) ((AND (EQ (CAADR SYMPTR) TAG) (MEMBER (CADADR SYMPTR) '(BRANCH BRANCH-PUSHJ) :TEST #'EQ) (= ADR (CADDR (CADR SYMPTR)))) (SETQ SYMPTR (CDR SYMPTR)) ;COMMITTED TO 2 WD BRANCH (LAP-OUTPUT-WORD (LSH VL -9)) (SETQ ADR (1+ ADR)) (LAP-OUTPUT-WORD (LOGAND 65535 (QLEVAL TAG T)) #+compiler:debug T) ;- NUMBERS DONT WIN! (RETURN-FROM QB2 NIL)) ;-1 BECAUSE PC IS INCREMENTED ; ANOTHER -1 BECAUSE ADR IS 1 MORE NOW ((> (ABS TM2) 254) (BARF (LIST TAG TM2) 'NOT-IN-RANGE 'BARF))) (LAP-OUTPUT-WORD (+ VL (LOGAND 511 (1- TM2)))))) (DEFUN MEMQ-ALTERNATE (X Y) (PROG () L (COND ((NULL Y) (RETURN NIL)) ((EQ X (CAR Y)) (RETURN Y))) (SETQ Y (CDDR Y)) (GO L)))