;;; -*- Mode:LISP; Package:COMPILER; Base:8; Patch-File:T; Readtable:ZL -*- (defvar *new-open-frame*) ;Frame about to be opened. Used for communication between OUTI-FOR-K ;and higher levels which want to specify the completion action. (defvar *gensymbol-counter* 0) (defun gensymbol (string) (make-symbol (string-append string "-" (write-to-string (incf *gensymbol-counter*) :radix nil :base 10.)))) (defstruct (open-frame :conc-name) (open-instruction) ;For debugging. (tail-p) ;For error checking. (cleanup-generator) ;Function of three arguments. ;The first argument is the OPEN-FRAME object ;The second argument is one of: ;NIL -- Normal completion of the frame. ;:DISCARD -- Discard the frame, no value. ;:RETURN -- Discard the frame, return a value. ;The third argument is the destination, or where ;the return value may be found (in the case of :RETURN). ) ;;; Use this macro when we do something which creates an open frame. ;;; The cleanup-body is queued up to be run when we're finished with ;;; the open frame. It may be run many times, in the presence of ;;; conditional branching or returning. (defmacro with-open-frame (open-instruction ((&optional open-frame discardp destination) &body cleanup-body) &body body) (let ((cleanup-fun (gensymbol "CLEANUP-FUN")) (open-i (gensymbol "OPEN-INSTRUCTION")) (nopen-frame open-frame) (ndestination destination) (ndiscardp discardp)) (unless nopen-frame (setq nopen-frame (gensymbol "OPEN-FRAME"))) (unless ndiscardp (setq ndiscardp (gensymbol "DISCARDP"))) (unless ndestination (setq ndestination (gensymbol "DESTINATION"))) `(flet ((,cleanup-fun (,nopen-frame ,ndiscardp ,ndestination) ,@(unless discardp ;; Only burn up symbols we created. We want to get the "unused" warning iff ;; he supplied the arg. `(,ndiscardp)) ,@(unless open-frame `(,nopen-frame)) ,@(unless destination `(,ndestination)) ,@cleanup-body)) (let* ((,open-i ,open-instruction)) (opening-frames (,destination :new-frame (make-open-frame :open-instruction ,open-i :tail-p (tail-open-p ,open-i) :cleanup-generator #'cleanup-fun)) (outi-for-k ,open-i) ,@body))))) ;;; This is used both as a subroutine of the above, and for P2ARGC-for-K ;;; In the P2ARGC-for-K case, the caller wraps the following macro around ;;; the entire generation of the call, and P2ARGC-for-K does the missing pieces ;;; by calling OUTI-OPEN-FOR-K. (defmacro opening-frames ((dest &key new-frame) &body body) (let ((original-open (gensymbol "ORIGINAL-OPEN-FRAMES")) (dest-symbol (gensymbol "DESTINATION"))) `(let ((,original-open *open-frames*) (,dest-symbol ,dest)) (multiple-value-prog1 (progn ,@(when new-frame `((push ,new-frame *open-frames*))) ,@body) (clean-up-open-frames ,original-open nil ,dest-symbol))))) ;;; Call this when doing a "temporary" discard of excess stack. ;;; For example, when generating a branch or return. (defmacro discarding-open-frames ((level destination) &body body) `(let* ((*open-frames* *open-frames*)) (clean-up-open-frames ,level nil ,destination) ,@body)) (DEFUN QCOMPILE0 (EXP FUNCTION-TO-BE-DEFINED GENERATING-MICRO-COMPILER-INPUT-P &OPTIONAL (NAME-TO-GIVE-FUNCTION FUNCTION-TO-BE-DEFINED)) (LET ((EXP1 EXP) (DEF-TO-BE-SXHASHED) (LVCNT) (MAXPDLLVL 0) ;deepest lvl reached by local pdl (PDLLVL 0) ;Runtine local pdllvl ;; p2 things (*CALL-BLOCK-PDL-LEVELS*) ;used only in lambda mode. (*open-frames* nil) ;used in cross compile mode. (*new-open-frame* nil) ;Used in cross compile mode. (*WITHIN-CATCH*) (*WITHIN-POSSIBLE-LOOP*) (*DROPTHRU* T) ;Can drop in if false, flush stuff till tag or (*TAGOUT*) (ALLGOTAGS) (*TLEVEL* T) (*P1VALUE* T) ;Compiling for all values (*BINDP* NIL) ;%BIND not yet used in this frame (*VARS* ()) (*ALLVARS* ()) (*FREEVARS* ()) (*LOCAL-FUNCTIONS* *OUTER-CONTEXT-LOCAL-FUNCTIONS*) (*FUNCTION-ENVIRONMENT* *OUTER-CONTEXT-FUNCTION-ENVIRONMENT*) (*PROGDESC-ENVIRONMENT* *OUTER-CONTEXT-PROGDESC-ENVIRONMENT*) (*GOTAG-ENVIRONMENT* *OUTER-CONTEXT-GOTAG-ENVIRONMENT*) (LL) (TLFUNINIT (not (eq *target-computer* 'lambda-interface))) ;crosscompiling, use FEF-INI-COMP-C not fef initialization. (*SPECIALFLAG*) (MACROFLAG) (*LOCAL-MAP* ()) ;names of local variables (*ARG-MAP* ()) ;names of arguments (*BASE-STACK-SLOTS* ()) ;aux-slots in cross-compile mode. (*STACK-SLOTS* ()) ;currently existing stack-slots in cross-compile mode. (*entry-sequence-specbinds* ()) ;used in cross-compile mode only. (*LOCAL-FUNCTION-MAP* ()) ;names of local functions (EXPR-DEBUG-INFO) (*FAST-ARGS-POSSIBLE* T) (*BREAKOFF-COUNT* 0) ;no internal functions yet (*LEXICAL-CLOSURE-COUNT* 0) (*lexical-ref-code-name-alist* ()) (MACROS-EXPANDED) ;List of all macros found in this function, ; for the debugging info. (SELF-FLAVOR-DECLARATION (cdr (assq :self-flavor local-declarations))) (*SELF-REFERENCES-PRESENT* NIL) ;Bound to T if any SELF-REFs are present (LOCAL-DECLARATIONS LOCAL-DECLARATIONS) ;Don't mung ouside value (SUBST-FLAG) ;T if this is a SUBST being compiled. ; Always put interpreted defn in debug info. (INHIBIT-SPECIAL-WARNINGS INHIBIT-SPECIAL-WARNINGS) (*CLOBBER-NONSPECIAL-VARS-LISTS* ()) wrapped-block-name (*placeholder-function-number* 0) (*placeholder-alist* nil) ) (BEGIN-PROCESSING-FUNCTION FUNCTION-TO-BE-DEFINED) (WHEN (LIST-MATCH-P FUNCTION-TO-BE-DEFINED `(:PROPERTY ,IGNORE :NAMED-STRUCTURE-INVOKE)) (WARN 'OBSOLETE-PROPERTY :IMPLAUSIBLE "NAMED-STRUCTURE-INVOKE, the property name, should not be a keyword.")) ;; If compiling a macro, compile its expansion function ;; and direct lap to construct a macro later. (WHEN (EQ (CAR EXP1) 'MACRO) (SETQ MACROFLAG T) (SETQ EXP1 (CDR EXP1)) (SETQ DEF-TO-BE-SXHASHED EXP1)) (UNLESS (MEMQ (CAR EXP1) '(LAMBDA ZL:SUBST CL:SUBST NAMED-LAMBDA NAMED-SUBST)) (WARN 'FUNCTION-NOT-VALID :FATAL "The definition is not a function at all.") (RETURN-FROM QCOMPILE0 NIL)) (IF (MEMQ (CAR EXP1) '(ZL:SUBST NAMED-SUBST CL:SUBST)) ;;>> This is pretty bogous (SETQ SUBST-FLAG T INHIBIT-SPECIAL-WARNINGS T)) ;; If a NAMED-LAMBDA, discard the name and save debug-info in special place. (WHEN (MEMQ (CAR EXP1) '(NAMED-LAMBDA NAMED-SUBST)) (SETQ EXPR-DEBUG-INFO (CDR-SAFE (CADR EXP1)) WRAPPED-BLOCK-NAME (CADR EXP1) EXP1 `(,(IF (EQ (CAR EXP1) 'NAMED-LAMBDA) 'LAMBDA 'ZL:SUBST) . ,(CDDR EXP1))) ;; Debug info that is equivalent to declarations ;; should be turned back into declarations, coming before ;; declarations made outside of compilation ;; but after anything coming from a DECLARE in the body. ;>> Does not barf at bogoid declarations. (DOLIST (ELT (REVERSE EXPR-DEBUG-INFO)) (LET ((TEM (GET (CAR ELT) 'SI::DEBUG-INFO))) (WHEN TEM (IF (AND (SYMBOLP TEM) (GET TEM 'SI::DEBUG-INFO)) (SETQ ELT (CONS TEM (CDR ELT)))) (PUSH ELT LOCAL-DECLARATIONS))))) (SETQ LL (CADR EXP1)) ;lambda list. (unless (cl:listp ll) (warn 'invalid-lambda-list :impossible "~S is supposed to be a lambda-list" ll) (setq ll () exp1 `(,(car exp1) () . ,(cddr exp1)))) ;; Record the function's arglist for warnings about recursive calls. (OR THIS-FUNCTION-ARGLIST-FUNCTION-NAME (SETQ THIS-FUNCTION-ARGLIST-FUNCTION-NAME NAME-TO-GIVE-FUNCTION THIS-FUNCTION-ARGLIST LL)) ;; Extract documentation string and declarations from the front of the body. (MULTIPLE-VALUE-BIND (BODY LOCAL-DECLARATIONS DOCUMENTATION) (WITH-LIST (ENV *FUNCTION-ENVIRONMENT*) (EXTRACT-DECLARATIONS (CDDR EXP1) LOCAL-DECLARATIONS T ENV)) (IF WRAPPED-BLOCK-NAME (SETQ BODY `((BLOCK ,WRAPPED-BLOCK-NAME . ,BODY)))) (SETQ SELF-FLAVOR-DECLARATION (CDR (ASSQ ':SELF-FLAVOR LOCAL-DECLARATIONS))) ;; If the user just did (declare (:self-flavor flname)), ;; compute the full declaration for that flavor. (WHEN (AND SELF-FLAVOR-DECLARATION (NULL (CDR SELF-FLAVOR-DECLARATION))) (SETQ SELF-FLAVOR-DECLARATION (CDR (SI::FLAVOR-DECLARATION (CAR SELF-FLAVOR-DECLARATION))))) ;; Actual DEFMETHODs must always have SELF-FLAVOR (WHEN (EQ (CAR-SAFE FUNCTION-TO-BE-DEFINED) ':METHOD) (SETQ *SELF-REFERENCES-PRESENT* T)) ;; Process &KEY and &AUX vars, if there are any. (WHEN (OR (MEMQ '&KEY LL) (MEMQ '&AUX LL)) ;; Put arglist together with body again. (LET ((LAMEXP `(LAMBDA ,LL (DECLARE . ,LOCAL-DECLARATIONS) . ,BODY))) ;; If there are keyword arguments, expand them. (AND (MEMQ '&KEY LL) (SETQ LAMEXP (EXPAND-KEYED-LAMBDA LAMEXP))) ;; Now turn any &AUX variables in the LAMBDA into a LET* in the body. (SETQ LAMEXP (P1AUX LAMEXP)) ;; Separate lambda list and body again. (SETQ LL (CADR LAMEXP) BODY (CDDR LAMEXP))) ;; Can just pop off the declarations as we have them already from above (DO () ((NEQ (CAR-SAFE (CAR BODY)) 'DECLARE)) (POP BODY))) ;; Create the arglist accessable through (arglist foo 'compile) (LET ((L ())) (DOLIST (X (CADR EXP1)) (PUSH (COND ((EQ X '&AUX) (RETURN)) ((ATOM X) X) ;foo, &optional, etc ((CONSP (CAR X)) ;((:foo bar)), ((:foo bar) baz foop), etc (IF (CADR X) (LIST (CAAR X) (CADR X)) (CAAR X))) (T ;(foo), (foo bar), (foo bar foop) (IF (CADR X) (LIST (CAR X) (CADR X)) (CAR X)))) L)) (SETQ L (NREVERSE L)) (UNLESS (EQUAL L LL) (PUSH `(COMPILER-ARGLIST . ,L) LOCAL-DECLARATIONS))) ;; Now process the variables in the lambda list, after the local declarations. (SETQ LL (P1SBIND LL 'FEF-ARG-REQ NIL NIL LOCAL-DECLARATIONS)) (COND ((NOT (NULL (CDR BODY))) (SETQ EXP1 `(PROGN . ,BODY))) ((SETQ EXP1 (CAR BODY)))) (SETQ EXP1 (P1 EXP1)) ;Do pass 1 to single-expression body (push (cons 'placeholder-to-micro-function-table *placeholder-alist*) local-declarations) (SETQ LVCNT (compiler-target-switch (ASSIGN-LAP-ADDRESSES))) ;in cross-compile mode, number of aux-stack slots. ;; Now that we know all the variables needed by lexical closures, ;; make a list of them and put them into the entries in COMPILER-QUEUE ;; for each of those lexical closures. (let ((*variables-used-in-lexical-closures* (IF (ZEROP *LEXICAL-CLOSURE-COUNT*) () (RECORD-VARIABLES-USED-IN-LEXICAL-CLOSURES)))) (OUTF `(MFEF ,FUNCTION-TO-BE-DEFINED ,*SPECIALFLAG* ,(ELIMINATE-DUPLICATES-AND-REVERSE *ALLVARS*) ,*FREEVARS* ,NAME-TO-GIVE-FUNCTION)) (IF MACROFLAG (OUTF `(CONSTRUCT-MACRO))) (OUTF `(QTAG S-V-BASE)) (OUTF `(S-V-BLOCK)) (IF (AND SELF-FLAVOR-DECLARATION *SELF-REFERENCES-PRESENT*) (OUTF `(SELF-FLAVOR . ,SELF-FLAVOR-DECLARATION))) (OUTF `(QTAG DESC-LIST-ORG)) (OUTF `(PARAM LLOCBLOCK ,(IF (or (ZEROP *LEXICAL-CLOSURE-COUNT*) (neq *target-computer* 'lambda-interface)) ;cross compiling, this is number of stack slots. LVCNT ;; One extra for the lexical frame pointer. ;; One extra for the unshared frame list. (+ lvcnt *lexical-closure-count* 2) ; (+ LVCNT (* 4 *LEXICAL-CLOSURE-COUNT*) 3 ; (LENGTH *VARIABLES-USED-IN-LEXICAL-CLOSURES*)) ))) (OUTF `(A-D-L)) (OUTF `(QTAG QUOTE-BASE)) (OUTF `(ENDLIST)) ;Lap will insert quote vector here (WHEN (NOT (ZEROP *LEXICAL-CLOSURE-COUNT*)) (OUTF `(VARIABLES-USED-IN-LEXICAL-CLOSURES . ,(REVERSE (MAPCAR (LAMBDA (HOME) (LET ((TEM (VAR-LAP-ADDRESS HOME))) (CASE (CAR TEM) (ARG (CADR TEM)) (T (%LOGDPB 1 %%Q-BOXED-SIGN-BIT (CADR TEM)))))) *VARIABLES-USED-IN-LEXICAL-CLOSURES*))))) ;; Set up the debug info from the local declarations and other things (LET ((DEBUG-INFO ()) TEM) (AND DOCUMENTATION (PUSH `(DOCUMENTATION ,DOCUMENTATION) DEBUG-INFO)) (DOLIST (DCL LOCAL-DECLARATIONS) (WHEN (SYMBOLP (CAR DCL)) (SETQ TEM (GET (CAR DCL) 'SI::DEBUG-INFO)) (IF (AND (SYMBOLP TEM) (GET TEM 'SI::DEBUG-INFO)) (SETQ DCL (CONS TEM (CDR DCL)))) (UNLESS (ASSQ (CAR DCL) DEBUG-INFO) (PUSH DCL DEBUG-INFO)))) ;; Propagate any other kinds of debug info from the expr definition. (DOLIST (DCL EXPR-DEBUG-INFO) (UNLESS (ASSQ (CAR DCL) DEBUG-INFO) (PUSH DCL DEBUG-INFO))) (WHEN (PLUSP *BREAKOFF-COUNT*) ; local functions (LET ((INTERNAL-OFFSETS (MAKE-LIST *BREAKOFF-COUNT*))) (OUTF `(BREAKOFFS ,INTERNAL-OFFSETS)) (PUSH `(:INTERNAL-FEF-OFFSETS . ,INTERNAL-OFFSETS) DEBUG-INFO))) ;; Include the local and arg maps if we have them. ;; They were built by ASSIGN-LAP-ADDRESSES. (WHEN *LOCAL-MAP* (PUSH `(LOCAL-MAP ,*LOCAL-MAP*) DEBUG-INFO)) (WHEN *ARG-MAP* (PUSH `(ARG-MAP ,*ARG-MAP*) DEBUG-INFO)) (WHEN *LOCAL-FUNCTION-MAP* (PUSH `(LOCAL-FUNCTION-MAP ,(NREVERSE *LOCAL-FUNCTION-MAP*)) DEBUG-INFO)) (when *lexical-ref-code-name-alist* (push `(lexical-ref-map . , *lexical-ref-code-name-alist*) debug-info)) ;; Include list of macros used, if any. (WHEN MACROS-EXPANDED (LET ((MACROS-AND-SXHASHES (MAPCAR (LAMBDA (MACRONAME) (LET ((HASH (EXPR-SXHASH MACRONAME))) (IF (OR HASH (CONSP MACRONAME)) (LIST MACRONAME HASH) MACRONAME))) MACROS-EXPANDED))) (IF QC-FILE-RECORD-MACROS-EXPANDED (PROGN ;; If in QC-FILE, put just macro names in the function ;; but put the names and sxhashes into the file's list. (PUSH `(:MACROS-EXPANDED ,MACROS-EXPANDED) DEBUG-INFO) (DOLIST (M MACROS-AND-SXHASHES) (OR (SI:MEMBER-EQUAL M QC-FILE-MACROS-EXPANDED) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (PUSH (COPY-TREE M) QC-FILE-MACROS-EXPANDED))))) (PUSH `(:MACROS-EXPANDED ,MACROS-AND-SXHASHES) DEBUG-INFO)))) (AND (OR (EQ QC-TF-OUTPUT-MODE 'COMPILE-TO-CORE) SUBST-FLAG) (PUSH `(INTERPRETED-DEFINITION ,EXP) DEBUG-INFO)) (WHEN SUBST-FLAG (LET* ((ARGS-INFO (ARGS-INFO EXP)) (DUMMY-FORM (CONS 'FOO (MAKE-LIST (+ (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO) (IF (LDB-TEST %ARG-DESC-EVALED-REST ARGS-INFO) 1 0)) :INITIAL-ELEMENT '(GENSYM))))) ;>> this somewhat bogous. The environment should be much hairier. Or should it? (UNLESS (WITH-LIST (ENV *FUNCTION-ENVIRONMENT*) ;>> BULLSHIT. this cannot hope to work. sigh. (EQUAL (SI::SUBST-EXPAND EXP DUMMY-FORM ENV NIL) (SI::SUBST-EXPAND EXP DUMMY-FORM ENV T))) ;; If simple and thoughtful substitution give the same result ;; even with the most intractable arguments, ;; we need not use thoughtful substitution for this defsubst. ;; Otherwise, mark it as requiring thoughtful substitution. (PUSH '(:NO-SIMPLE-SUBSTITUTION T) DEBUG-INFO)))) ;; Compute the sxhash now, after all displacing macros have been displaced (AND MACROFLAG (PUSH `(:EXPR-SXHASH ,(FUNCTION-EXPR-SXHASH DEF-TO-BE-SXHASHED)) DEBUG-INFO)) ;; If we aren't going to mark this function as requiring a mapping ;; table, provide anyway some info that the user declared it wanted one. (AND SELF-FLAVOR-DECLARATION (NOT *SELF-REFERENCES-PRESENT*) (PUSH `(:SELF-FLAVOR ,(CAR SELF-FLAVOR-DECLARATION)) DEBUG-INFO)) (OUTF `(DEBUG-INFO . ,DEBUG-INFO))) (OUTF `PROGSA) (compiler-target-switch ;for LAMBDA, just goes to P2SBIND. (P2SBIND-FOR-TOPLEVEL LL *VARS* NIL)) ;Can compile initializing code (LET ((*LEXICAL-CLOSURE-COUNT* 0) (*highest-lexical-closure-disconnected* 0)) (compiler-target-switch (P2 EXP1 'D-RETURN))) ;Do pass 2 (LET* ((MXPDL (1+ MAXPDLLVL)) (APPARENT-MAXIMUM-TOTAL-PDL-FRAME-SIZE (+ MXPDL (LENGTH *LOCAL-MAP*) (LENGTH *ARG-MAP*)))) (OUTF `(PARAM MXPDL ,MXPDL)) (WHEN (> APPARENT-MAXIMUM-TOTAL-PDL-FRAME-SIZE 225.) (WARN 'PDL-FRAME-TOO-LARGE :fatal "PDL frame at runtime limited to 256. (225. for safety)")))) *ALLVARS*)))