;;; -*- Mode:LISP; Package:COMPILER; Base:8; Readtable:ZL -*- #| NO WAY STATIONS.. code is to be generated the "right way" at the extreme bottom of the tree, as opposed to compiled into a temp, the futz with multiple-values or frame-flushing, then return the temp, etc. the primary mechanism use to achieve this is "the closure", on *open-frames*, which is passed messages telling it what we want to do. The Closure is required to preserve the hardware m.v. flag. messages to the closure: :EXIST sent when instruction which causes frame to exist at runtime is emitted. :DISCARD used when thru with temporary-storage-frames (ie p2values-for-k) also when doing a GO out from under evaluated args. :RETURN Used when passing a value through a frame, yielding a value to a destination. However, the frame is discarded, not completed as for the NIL message. Hairy; see below: NIL normal completion. (open-frame operation dest) Hairy, see below: NIL and :RETURN receive the following arguments: Frame The frame-entry on *open-frames*; like SELF. Operation :RETURN, that is, this operation. Dest Where to put the result. Except for the last one to be removed, this will be a temporary global register. Source Where to get the value. A given frame can leave the value in the source, iff that source will be unaffected by discarding this frame. SType A source-type flag. Some frame types will look at this (i.e. THROW), and others will pass on to the recursive call to OUTI-FOR-K. The value from the NIL or :RETURN operation is left either in Dest or Source. Which one is indicated by the return value -- it will be the source for the next step. Source-type flags passed to OUTI-FOR-K when the instruction yielding a final value for some destination is output. The Source-type flag will be one of the following: NIL -- Some unknown number of values is computed, and the hardware m.v. flag is not set up. :SINGLE-VALUE -- A single value is computed, and the hardware m.v. flag is not set up. :SINGLE-VALUE-FLAG -- A single value is computed, and the hardware m.v. flag is cleared. I'm not sure this is usefully distinct from :SINGLE-VALUE. :SUBR-VALUE -- A function was called, which will set up the hardware m.v. flag to indicate whether multiple values were returned. :MULTIPLE-VALUES -- A VALUES form (or other open-compiled m.v. producing form) produced values, but the hardware m.v. flag is not set up. :MULTIPLE-VALUES-FLAG -- Like :MULTIPLE-VALUES, but the m.v. flag is set up. :LAST-VALUE -- Multiple values were prepared, distributed by a higher level, and Now this one (the first one) is passed along to activate the open frames and other hair, and eventually be placed where it belongs. OUTI-CLOSE-FOR-K takes optionally takes a Source and a Source-Type, passes them to the closure in question. OUTI-FOR-K optionally takes a Source-Type. This will be supplied when generating the instruction which produces the final result. OUTI-FOR-K will pass this on if it recurses, and will pass it on to CLEAN-UP-OPEN-FRAMES. (The default will be :SINGLE-VALUE). When OUTI-FOR-K gets a compound destination, it simplifies it: If it's a PROGDESC: If the PROGDEST-OPEN-FRAMES is the same as *OPEN-FRAMES*, the PROGDEST-IDEST is substituted in the instruction, and we're done. If the PROGDEST-OPEN-FRAMES is not in *OPEN-FRAMES*, we have an error situation. Otherwise: It substitutes the PROGDEST-IDEST, or K:R0 if the PROGDEST-IDEST is not an A register or D-IGNORE, and outputs the instruction. It calls CLEAN-UP-OPEN-FRAMES with the source being either K:R0 or the destination, depending on which was used above. The Source-Type is passed on. CLEAN-UP-OPEN-FRAMES will have moved it into the destination. If it's a MULTIPLE-VALUES, it will: Case Source-type: (:SINGLE-VALUE :SINGLE-VALUE-FLAG): Output the instruction to store into the first destination. Output instructions to store NIL's into the additional destinations. (:SUBR-VALUE): Output the instruction, to store into the first destination. Output code to test the hardware bit, and store the values or NIL's into the additional destinations. (:VALUES): Output the instruction, to store into the first destination. The hardware bit is not set, but there are multiple values. Copy from the global return registers into the additional destinations. If it's an OPEN-FRAME: Output the instruction, with a destination from the IDEST of the OPEN-FRAME. Call OUTI-CLOSE-FOR-K, with the IDEST as source as passing on the Source-type. CLEAN-UP-OPEN-FRAME takes the Source given, and: For each open frame to be popped, except the last, it calls the closure with Source = SOURCE and Dest = the global return-temp register. The return value becomes the new SOURCE. For the last open frame to be popped, the Dest = the Dest passed into CLEAN-UP-OPEN-FRAMES. If the return value is Dest, we're all done. If it isn't, a move must is done. (multiple-value-setq (a b c) (cond ((foo)))) would work as follows: * MULTIPLE-VALUE-SETQ's P2 would create a multiple-value destination, and call P2-FOR-K on (cond ((foo))) * (:PROPERTY COND P2-FOR-K) would call P2 on (FOO) and K:R0. * After braching, it would do a MOVE from K:R0 to the destination. The Source-type would be :SINGLE-VALUE, (throw 'foo (foo)) would work as follows: * P2THROW-FOR-K would create an open frame with its own closure. * 'FOO would be compiled to K:O0. * The PDEST of the open frame would be set to K:O1. * The IDEST of the open frame would be set to D-IGNORE, since we don't return. (Normally it would be the destination given P2THROW-FOR-K). * P2THROW-FOR-K would call P2-FOR-K with (FOO) and a destination of the open frame. * (Eventually, inside P2ARGC-FOR-K) OUTI-CLOSE-FOR-K will be called with Operation = NIL, Destination = open-frame, Source-type = :SUBR-VALUES. * OUTI-CLOSE-FOR-K will invoke P2ARGC-FOR-K's closure for FOO. It will pass on Source-type. * P2ARGC-FOR-K's closure will do OUTI-FOR-K of a call with a destination of the THROW open frame. It will pass on Source-type. * OUTI-FOR-K will see that it has a compound, and simplify it. In the case of an OPEN-FRAME, this means: * OUTI-FOR-K will output the call instruction for FOO, with a destination of K:O1 (from the PDEST of the OPEN-FRAME). * OUTI-FOR-K will call OUTI-CLOSE-FOR-K with a source of K:O1, a destination of D-IGNORE (from the IDEST of the open frame), and a Source-type passed on. * OUTI-CLOSE-FOR-K will pass those on to P2THROW-FOR-K's closure. * P2THROW-FOR-K's closure will output the appropriate code based on the Source-type. |# #| Logical Destinations. Valid arguments to everything from P2-FOR-K to OUTI-FOR-K. (OUTI-FOR-K also allows the use of all valid K: destinations). Symbols: D-IGNORE -- Value is to be ignored. D-RETURN -- Value is to be returned from the function. K:NOP -- Value is discarded, but the indicators are set. K:O0-K:O15 -- Place the result in this K register. Used for compiler temporaries and arguments to functions being called. K:A0-K:A15 -- Same. Used for local variables and arguments to this function. K:R0-K:R15 -- Same. Also, K:R0 is used to set the indicators for conditionals, and as an intermediate. GR:xxx -- General Register, by name. Otherwise -- A special variable. I would rather this were a structure, but P1 would have to create that. Lists: (K:REGISTER name block index) -- Same as GR:name. (K:NEW-OPEN n) -- Put the result of this into a new OPEN frame, in (O-N n). (K:NEW-TAIL-OPEN n) -- Put the result of this into a new TAIL-OPEN frame, in (O-N n). Structures: PROGDESC: Has the following relevant slots: IDEST -- Destination for this block. OPEN-FRAMES -- Tail of *OPEN-FRAMES*, indication how far to discard to. MULTIPLE-VALUES: Has the following slots: VALUES -- A list of destinations. OPEN-FRAME -- NIL, or an open frame to be activated when this is output. OPEN-FRAME: Has the following relevant slots: PDEST -- Where to put the value this frame needs. (New) IDEST -- Where to put the value when this frame is done. (New) CLEANUP-GENERATOR -- Function to generate the appropriate cleanup code. This is the part that does the interesting work. It will be called with an operation of NIL, and it can make decisions about what function to call depending on the Source-type argument. This is useful for THROW, MULTIPLE-VALUE-LIST, MULTIPLE-VALUE-BIND, MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-SETQ, and any other multiple value receivers. (This open frame should also live on *OPEN-FRAMES*, if it involves a O-frame, as THROW does. They may as well ALL live on *OPEN-FRAMES*). VAR: Has the following relevant slots: LAP-ADDRESS -- Where to store it. NEW-VAR: Has the following relevant slots: VAR -- The VAR struct that this storing will create & initialize the home for. OPEN-FRAME -- NIL, or an open frame to be activated when this is output. |# ;This file has modifications to P2 of the compiler for cross compiling on K. ;cross compilation switches and conditionalization. ; *target-computer* can be 'lambda or 'k ; this is the main switch which indicates we are in fact cross compiling. ; the macro COMPILER-TARGET-SWITCH makes conditional calls based on this switch. It ; is also looked at directly. ; *fasd-interface* can be 'lambda-fasd-interface or nlisp-fasd-interface ; the macro COMPILER-FASD-SWITCH makes conditional calls based on this switch. ;the P2-FOR-K property. ; when cross compiling, P2F will look for this before looking for P2 or QINTCMP properties. ; When found, property is treated identically to how P2 property would be treated. ;general: ; MISC instructions have no meaning on the K. Therefore, P2MISC-for-k just calls P2ARGC-for-k (which ; compiles calls to ordinary functions) rather compiling a different sort of call. ; Since the K is (more or less) a register based machine, all references to D-PDL (etc) have to ; go away, more or less. ; Destinations: ; the destinations D-NEXT, D-LAST, and D-PDL basically do not apply to the K. They ;may be OK if the code will be converted by the cross compiler, however. ; D-LAST is completely gone now. --RWK ; D-INDS is equivalent to K:R0, and therefore is flushed. ;optimizations for the future: ; Introduce "h" pseudo-registers. These really address the hardware "A" registers, but ;in addition, guarantee the peep-hole optimizer the value will be "used" exactly once. ;Thus, (move h1 foo), (move bar h1) can be optimized, if possible, into (move bar foo) ;without worrying there might be another (move ble h1) comming along later. ;; These are K-only things moved from QCDEFS. -smh 12sep88 ;open frames, buffering intermediate values, and multiple values in cross-compile mode: ; (1) We dont have a stack to buffer things, so we use call frames allocated specifically for the purpose ; to hold things. That works pretty well, but we actually have to call a function (usually prog1-internal) ; to eventually get rid of it (them). ; (2) thus, open frames are used for the following purposes: ; (a) The "main" one, to hold evaluated args while prepareing a function call (P2ARGC-FOR-K) ; (b) P2PROG12N-FOR-K (open this out just to sop up any number of args). ;the mechanism for keeping track of things is *open-frames*, which is a list of open-frame structures. ;*open-frames* works stack-wise, ie, it should always be at the same level when entering as when leaving ;functions like P2-for-K, P2ARGC-FOR-K, etc. ;the timing is: ; the entry gets put on when the "logical" open is about to be output. This is just before K:CH-OPEN, etc, ; in usual case, but can be substantually before in case of k:new-open, etc. This is necessary ; to assure the stackwise property. ; when the code which creates the frame is recognized at OUTI-FOR-K, (either the K:CH-OPEN or K:NEW-OPEN) ; the frame is marked as THERE-P. ; At P2ARGC-FOR-K, when all args are "loaded", it does a OUTI-CLOSE-FOR-K, when "sends" a NIL message to the ; frame, which outputs the activating code (K:CALL or K:TAIL-CALL). ; when the code which activates the frame is recognized (K:CALL OR K:TAIL-CALL), FINISH-OPEN-FRAME is called, ; which pops *open-frames*. Then, if a return is involved, the value is generated to k:o0 and a clean-up-open-frames ; in mode :RETURN is invoked, followed by OUTPUT-FULL-EXIT-SEQUENCE, followed by returnning k:o0. ; This latter also happens if a K:MOVE to a *return-destination* is encountered. ;K:OPEN operations should always be output as separate instructions. K:OPEN-CALL, K:CH-OPEN, etc, should never ; be directly output. This simplifies OUTI-FOR-K, and POSTPROCESS optimizes them well. ;Calling p2-for-k and p2-mv-for-k. ; if you want multiple-values, *m-v-target* gets bound to the "instruction" for the lower guys. ; For the lambda, if *m-v-target* is non-null, DEST was always D-PDL. It is then possible that ; the lower guy either "sees" the instruction or not. If so, *m-v-target* is set to NIL. Otherwise, ; if it was left alone, the lower level really didnt do anything at all special vis-a-vis multiple-values. ; ;keeping the actual code and *open-frames* in sync: ; outi-for-k (DEFVAR *OPEN-FRAMES*) ;In cross compile mode list of open frames. The elements are ;structures of type OPEN-FRAME (see below). ;;; Destinations: (defstruct (multiple-values :conc-name :named :copier (:alterant nil) (:print-function print-multiple-values)) (values nil :documentation "A list of destinations.") ;List of destinations. (open-frame nil :documentation "An OPEN-FRAME that this destination activates.")) (defun print-multiple-values (multiple-values stream level) (ignore level) (printing-random-object (multiple-values stream) (format stream "Multiple-values: ~:[None~*~;~{~S~^, ~}~]~:[~;; Frame: ~S~]" (multiple-values-values multiple-values) (multiple-values-values multiple-values) (multiple-values-open-frame multiple-values) (when (multiple-values-open-frame multiple-values) (open-frame-open-instruction (multiple-values-open-frame multiple-values)))))) (defstruct (open-frame :conc-name :named :copier (:print-function print-open-frame)) (open-instruction) ;For debugging. [No! This is used. -smh] (tail-p) ;For error checking. (there-p) ;If NIL, frame does not exist at runtime yet at all. ; this is set T by OUTI-FOR-K when instruction which creates ; frame is processed. In case of destination k:NEW-OPEN, etc, ; that can be quite a while after frame is logically generated. (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). (pdest) ;Where to put the value this frame needs. (idest) ;Where to put the value when this frame is done. ) (defun print-open-frame (open-frame stream level) (ignore level) (printing-random-object (open-frame stream :type) (format stream "~A~:[ (Unfinished)~]~:[~; (Tail-called)~]~:[~; ~A~A~]" (open-frame-open-instruction open-frame) (open-frame-there-p open-frame) (open-frame-tail-p open-frame) (or (open-frame-pdest open-frame) (open-frame-idest open-frame)) (or (open-frame-pdest open-frame) "??") (or (open-frame-idest open-frame) "??")))) ;;; 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. ;; This appears unused as of 30aug88 -smh #+ignore (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 new-frame) &body body) (let ((original-open (gensymbol "ORIGINAL-OPEN-FRAMES")) #+ignore (original-dest (gensymbol "ORIGINAL-DESTINATION")) (new-frame-symbol (gensymbol "NEW-FRAME"))) `(let* ((,original-open *open-frames*) #+ignore (,original-dest ,dest) (,new-frame-symbol ,new-frame) (,dest (or ,new-frame-symbol ,dest))) (multiple-value-prog1 (progn ;; This must be done by frame creator `at the right time' to make p2sbind work. - smh 8sep88 #+ignore (when ,new-frame-symbol (setf (open-frame-idest ,new-frame-symbol) ,original-dest) (add-frame ,new-frame-symbol)) ,@body) (when ,new-frame-symbol (unless (or (not *dropthru*) ;Why this exclusion? Is it safe? (eq *open-frames* ,original-open) (do ((x *open-frames* (cdr x))) ;smh 12sep88 ((null x) 't) (when (eq *open-frames* x) (return nil)))) ;; This is actually a normal occurence if no form is in position to return ;; a value for the new frame. Check out this winner: -smh 30aug88 ;;(defun strange () ;; (LET ((foo T)) ; No form returns a value to this frame! ;; (declare (special foo)) ;; (block gnarg ;; (let () ;; ))) ;; 3) #+ignore (fsignal "Internal error: frame botch in OPENING-FRAMES: ~s ~s" *open-frames* ,original-open) (clean-up-open-frames ,original-open nil ,dest))))))) ;;; Call this when doing a "temporary" discard of excess stack. ;;; For example, when generating a branch or return. ;;; Note that this adjusts the frame level *before* running the body. ;;; Do not call P2 from within! (defmacro discarding-open-frames ((level destination) &body body) `(let ((*stack-slots* *stack-slots*)) (with-frames (clean-up-open-frames ,level :discard ,destination) ,@body))) (defmacro with-frames (&body body) (let ((old-frames (gensymbol "OLD-FRAMES"))) `(let* ((,old-frames *open-frames*) (*open-frames* *open-frames*)) (multiple-value-prog1 (progn ,@body) ;; Let the person debugging the compiler notice that ;; the frames list is being modified. (restore-frame ,old-frames))))) ;; Internals that tell the compiler what it is trying to do. (defconst *internal-return-destinations* '(d-return d-return-single d-return-multiple-value d-return-tail)) ;; These can actually appear in the destination of a K:MOVE instruction, etc. (defconst *return-destinations* '(k:return k:return-tail k:return-mv k:return-i k:return-i-mv k:return-i-tail )) (defconst *frame-registers-used-for-argument-passing* 16.) ;will be less when lexical env problem addressed. ;(defconst *k-constant-registers* '( (0 . gr:*zero) (1 . gr:*one*) (-1 . gr:*minus-one*) ; (2 . gr:*two*) (nil . gr:*nil*) (t . gr:*t*) ; (3 . gr:*three*) (4 . gr:*four*) (5 . gr:*five*) ; (6 . gr:*six*) (7 . gr:*seven*) (8 . gr:*eight*) ; (9 . gr:*nine*) (10. . gr:*ten*))) ;(defun k-ref-constant-frame (const) ; (let ((tem (assq const *k-constant-registers*))) ; (if tem `(register )))) (deftype functional-dest () `(satisfies functional-dest-p)) (deftype register-dest () `(satisfies register-dest-p)) (deftype return-dest () `(satisfies return-dest-p)) (deftype constant-register () `(satisfies constant-register)) (deftype quoted-object () `(satisfies quoted-object-p)) (deftype var-reference () `(satisfies var-reference-p)) (deftype new-frame-dest () `(satisfies new-frame-dest-p)) (defvar *reg-error-enable* t) ; Debugging switch. (defun reg-error (&rest args) (declare (eh:error-reporter)) (when *reg-error-enable* (apply #'fsignal args))) ;;; Some functions we just don't like to do tail calls on. Provide a way to not ;;; do them, so people can debug. (defvar *no-tail-call* nil) (defun initialize-no-tail-call () (unless *no-tail-call* (setq *no-tail-call* (make-hash-table :test #'eq)) (setf (gethash 'li::error *no-tail-call*) t) (setf (gethash 'lisp:error *no-tail-call*) t))) ;;; I think this is how you arrange to be initialized after the system is loaded. ;;; In this case, we have to wait for the flavor system and hash tables to be loaded. ;;; If the once-only initialization list isn't run at the right point, we'll just ;;; have to find or create a list which is. (add-initialization "Initialize no-tail-call table." '(initialize-no-tail-call) '(:once)) (defmacro tail-call-open (function tail-p cleanup-generator &optional source-type) `(outi-open-for-k (if ,tail-p `(k:tail-open) `(k:open)) ,tail-p ,cleanup-generator ,source-type (if ,tail-p `(k:tail-open ,,function) `(k:open ,,function)))) (defmacro compiling-to-destination ((dest source source-type) &body body) (let ((original-dest (gensymbol "ORIGINAL-DEST")) (source-var (gensymbol "SOURCE")) (source-type-var (gensymbol "SOURCE-TYPE"))) `(let ((,original-dest ,dest) (,source-var ,source) (,source-type-var ,source-type)) (multiple-value-bind (,dest ,source-var) (compute-temporary-destination ,original-dest ,source-var) ;; DEST is now the intermediate destination. ;; SOURCE-VAR is how you back get to that value. (Usually ;; it's the same, but it can be a quoted constant or constant ;; register.) (multiple-value-prog1 (progn ,@body) ;; Now move from the intermediate to the final value, if needed. (move-to-final-destination ,original-dest ,source-var ,source-type-var)))))) (defun functional-dest-p (dest) (case dest (k:nop t) ;As far as we're concerned. (otherwise (nc::functional-dest-p dest)))) (defun register-dest-p (dest) (typecase dest (list (case (first dest) (k:register t))) (symbol (or (find dest #(k:a0 k:a1 k:a2 k:a3 k:a4 k:a5 k:a6 k:a7 k:a8 k:a9 k:a10 k:a11 k:a12 k:a13 k:a14 k:a15 k:o0 k:o1 k:o2 k:o3 k:o4 k:o5 k:o6 k:o7 k:o8 k:o9 k:o10 k:o11 k:o12 k:o13 k:o14 k:o15 k:r0 k:r1 k:r2 k:r3 k:r4 k:r5 k:r6 k:r7 k:r8 k:r9 k:r10 k:r11 k:r12 k:r13 k:r14 k:r15)) ;; @#$@#$ This should be NC::REGISTER or COMPILER::REGISTER (get dest :register))) (otherwise nil))) (defun return-dest-p (dest) (typecase dest (symbol (or (memq dest *return-destinations*) (memq dest *internal-return-destinations*))) (otherwise nil))) (defun constant-register (reg) (typecase reg (list (third (find reg nc:*global-constants* :key #'cdr :test #'equal))) (symbol (third (find reg nc:*global-constants* :key #'third))) (otherwise nil))) (defun quoted-object-p (ref) (typecase ref (list (case (first ref) ((quote function breakoff-function) t) (otherwise nil))) (otherwise nil))) (defun var-reference-p (ref) (typecase ref (list (case (first ref) ((local-ref special-ref lexical-ref) t) (otherwise nil))) (otherwise nil))) (defun new-frame-dest-p (reg) (typecase reg (list (case (first reg) ((k:new-open k:new-tail-open) t) (otherwise nil))) (otherwise nil))) ;;; Answers the important question: Is this a source that can be moved ;;; arbitrarily later in the computation? (defun constant-source-p (source) (and source (etypecase source ((member k:trap-pc+) nil) ;Can't move this! (functional-dest nil) (quoted-object t) (var-reference nil) (constant-register t) (register-dest nil)))) ;;; This also works on sources (i.e. QUOTE frobs.) (defun register-static-across-opens-p (source) (etypecase source (register-dest ;; Exclude O-frames. (not (find source #(k:o0 k:o1 k:o2 k:o3 k:o4 k:o5 k:o6 k:o7 k:o8 k:o9 k:o10 k:o11 k:o12 k:o13 k:o14 k:o15)))) ;; Exclude k:new-open, etc. (new-frame-dest nil) (functional-dest nil) (quoted-object t) (var-reference t) (var-reference t)))