diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index d698f280bab1d40e1f62d356afd4d7741cbe4e3d..25d6225cd4139dab1b5fa2048fccca7403ff4bd5 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.5 1990/03/10 16:58:03 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.6 1990/04/16 10:38:52 ram Exp $ ;;; ;;; This file contains the virtual machine independent parts of the code ;;; which does the actual translation of nodes to VOPs. @@ -16,208 +16,17 @@ ;;; (in-package 'c) - -;;;; Random utilities: - - -;;; Block-Label -- Interface -;;; -;;; Return the label marking the start of Block, assigning one if necessary. -;;; -(defun block-label (block) - (declare (type cblock block)) - (let ((2block (block-info block))) - (or (ir2-block-%label 2block) - (setf (ir2-block-%label 2block) (gen-label))))) - - -;;; Drop-Thru-P -- Interface -;;; -;;; Return true if Block is emitted immediately after the block ended by -;;; Node. -;;; -(defun drop-thru-p (node block) - (declare (type node node) (type cblock block)) - (let ((next-block (ir2-block-next (block-info (node-block node))))) - (assert (eq node (block-last (node-block node)))) - (eq next-block (block-info block)))) - - -;;; Flush-Tail-Transfer -- Interface -;;; -;;; Annotate Node and Block to indicate that the Node is being -;;; compiled in a way that exploits its tail-recursive position: Block ends -;;; with a return or TR call, and will never transfer to the block containing -;;; the return node. -;;; -;;; For now, we just flush the link between the IR1 blocks, but we might -;;; want to do something else someday. If the return is is the same block as -;;; Node, then we don't do any anything. This works, since this can only -;;; happen when there node is the sole use of the return continuation. Since -;;; Node is TR, LTN will annotate Cont as :Unused, and no return code will be -;;; emitted. -;;; -(defun flush-tail-transfer (node block) - (declare (type node node) (type ir2-block block) (ignore block)) - (let* ((cont (node-cont node)) - (ret (continuation-dest cont)) - (b1 (node-block node)) - (b2 (node-block ret))) - (assert (return-p ret)) - (if (eq b1 b2) - (assert (eq (ir2-continuation-kind (continuation-info cont)) :unused)) - (unlink-blocks b1 b2))) - (undefined-value)) - - -;;; Insert-VOP-Sequence -- Interface -;;; -;;; Link a list of VOPs from First to Last into Block, Before the specified -;;; VOP. If Before is NIL, insert at the end. -;;; -(defun insert-vop-sequence (first last block before) - (declare (type vop first last) (type ir2-block block) - (type (or vop null) before)) - (if before - (let ((prev (vop-prev before))) - (setf (vop-prev first) prev) - (if prev - (setf (vop-next prev) first) - (setf (ir2-block-start-vop block) first)) - (setf (vop-next last) before) - (setf (vop-prev before) last)) - (let ((current (ir2-block-last-vop block))) - (setf (vop-prev first) current) - (setf (ir2-block-last-vop block) last) - (if current - (setf (vop-next current) first) - (setf (ir2-block-start-vop block) first)))) - (undefined-value)) - ;;;; Moves and type checks: -;;; Emit-Move-Template -- Internal -;;; -;;; Emit a move-like template determined at run-time, with X as the argument -;;; and Y as the result. If Template is null, then just use the Move VOP. -;;; Useful for move, coerce and type-check templates. If supplied, then insert -;;; before VOP, otherwise insert at then end of the block. -;;; -(defun emit-move-template (node block template x y &optional before) - (declare (type node node) (type ir2-block block) - (type (or template null) template) (type tn x y)) - (let ((template (or template (template-or-lose 'move))) - (arg (reference-tn x nil)) - (result (reference-tn y t))) - (multiple-value-bind - (first last) - (funcall (template-emit-function template) node block template arg - result) - (insert-vop-sequence first last block before))) - (undefined-value)) - - ;;; Emit-Move -- Internal ;;; -;;; Move X to Y, emitting the appropriate move/coerce VOP. If the primitive -;;; types don't overlap, there there must be a type error. In this case, we -;;; coerce the source object to T, then emit ILLEGAL-MOVE to make properly -;;; start the destination's lifetime. +;;; Move X to Y unless they are EQ. ;;; (defun emit-move (node block x y) (declare (type node node) (type ir2-block block) (type tn x y)) - (let ((x-type (tn-primitive-type x)) - (y-type (tn-primitive-type y))) - (cond ((eq x-type y-type) - (emit-move-template node block (primitive-type-move x-type) x y)) - ((eq y-type *any-primitive-type*) - (emit-move-template node block (primitive-type-coerce-to-t x-type) - x y)) - ((eq x-type *any-primitive-type*) - (emit-move-template node block (primitive-type-coerce-from-t y-type) - x y)) - (t - (let* ((c-to-t (primitive-type-coerce-to-t x-type)) - (src (if c-to-t - (make-normal-tn *any-primitive-type*) - x)) - (y-type (emit-constant - (type-specifier - (primitive-type-type - (tn-primitive-type y)))))) - (when c-to-t - (emit-move-template node block c-to-t x src)) - (vop illegal-move node block src y-type y))))) - - (undefined-value)) - - -;;; Maybe-Coerce -- Internal -;;; -;;; If TN is of the specified type, or doesn't require a coercion to be of -;;; that type, then return TN, otherwise convert the value into a temporary and -;;; return the temporary. -;;; -(defun maybe-coerce (node block tn ptype) - (declare (type node node) (type ir2-block block) - (type tn tn) (type primitive-type ptype)) - (let ((tn-ptype (tn-primitive-type tn))) - (if (or (eq tn-ptype ptype) - (not (or (primitive-type-coerce-to-t tn-ptype) - (primitive-type-coerce-from-t ptype)))) - tn - (let ((temp (make-normal-tn ptype))) - (emit-move node block tn temp) - temp)))) - - -;;; Get-Result-TN -- Internal -;;; -;;; Used together with Move-Result to handle any coercion necessary to -;;; compute a value of the primitive-type PType in TN. This is called before -;;; computation of the result to get a TN to compute the result in. If a -;;; coercion is necessary, then we create a temporary and return it, otherwise -;;; we return TN. -;;; -(defun get-result-tn (tn ptype) - (declare (type tn tn) (type primitive-type ptype)) - (if (ok-result-tn tn ptype) - tn - (make-normal-tn ptype))) - - -;;; OK-Result-TN -- Internal -;;; -;;; Return true if TN is an ok location to compute a result of the specified -;;; primitive type in, i.e. no implicit coercion is needed. This is true when -;;; either the primitive types are the same or when no coercion is needed -;;; to/from T. If there is a manifest type error, then we always return T so -;;; that EMIT-MOVE gets to do its thing. -;;; -(defun ok-result-tn (tn ptype) - (declare (type tn tn) (type primitive-type ptype)) - (let ((tn-ptype (tn-primitive-type tn))) - (cond ((eq tn-ptype ptype)) - ((eq tn-ptype *any-primitive-type*) - (not (primitive-type-coerce-to-t ptype))) - ((eq ptype *any-primitive-type*) - (not (primitive-type-coerce-from-t tn-ptype))) - (t - nil)))) - - -;;; Move-Result -- Internal -;;; -;;; Used with Get-Result-TN to handle result type coercions. This is called -;;; after the result is actually computed in order actually do the coercion. -;;; If TN isn't EQ to Dest, then have Emit-Move figure out what to do. -;;; -(proclaim '(inline move-result)) -(defun move-result (node block tn dest) - (declare (type node node) (type ir2-block block) (type tn tn dest)) - (unless (eq tn dest) - (emit-move node block tn dest)) + (unless (eq x y) + (vop move node block x y)) (undefined-value)) @@ -248,46 +57,7 @@ (defun emit-type-check (node block value result type) (declare (type tn value result) (type node node) (type ir2-block block) (type ctype type)) - (let ((check (type-check-template type))) - (assert check) - (let ((src (maybe-coerce node block value *any-primitive-type*)) - (dest (get-result-tn result *any-primitive-type*))) - (emit-move-template node block check src dest) - (move-result node block dest result))) - (undefined-value)) - - -;;; Move-From-Frame, Move-To-Frame -- Internal -;;; -;;; Move a value out of or into a different frame. This is used during -;;; function call/return to move an argument or return value into the -;;; appropriate passing location. -;;; -;;; [### For now, we always use the same VOPs, and passing locations are always -;;; in a descriptor representation. To allow passing of non-descriptor -;;; arguments or results, we will have to have type-specific argument/value -;;; moving VOPs.] -;;; -(defun move-from-frame (node block src dest frame) - (declare (type node node) (type ir2-block block) (type tn src dest frame)) - (let* ((dtype (tn-primitive-type dest)) - (temp (if (primitive-type-coerce-from-t dtype) - (make-normal-tn *any-primitive-type*) - dest))) - (vop move-argument node block src frame temp) - (unless (eq temp dest) - (emit-move node block temp dest))) - (undefined-value)) -;;; -(defun move-to-frame (node block src dest frame) - (declare (type node node) (type ir2-block block) (type tn src dest frame)) - (let* ((stype (tn-primitive-type src)) - (temp (if (primitive-type-coerce-to-t stype) - (make-normal-tn *any-primitive-type*) - src))) - (unless (eq src temp) - (emit-move node block src temp)) - (vop move-value node block temp frame dest)) + (emit-move-template node block (type-check-template type) value result) (undefined-value)) @@ -498,31 +268,11 @@ (emit-type-check node block tn temp (continuation-asserted-type cont)) temp) - (maybe-coerce node block tn ptype)))) + tn))) (:fixed (assert (= (length (ir2-continuation-locs 2cont)) 1)) (first (ir2-continuation-locs 2cont)))))) - -;;; Reference-Arguments -- Internal -;;; -;;; Build a TN-Refs list that represents access to the values of the -;;; specified list of continuations Args. Node and Block provide the context -;;; for emitting any necessary coercion or type-checking code. -;;; -(defun reference-arguments (node block args) - (declare (type node node) (type ir2-block block) (list args)) - (let ((last nil) - (first nil)) - (dolist (arg args) - (let ((ref (reference-tn (continuation-tn node block arg) - nil))) - (if last - (setf (tn-ref-across last) ref) - (setf first ref)) - (setq last ref))) - (the (or tn-ref null) first))) - ;;;; Utilities for delivering values to continuations: @@ -538,53 +288,43 @@ ;;; This provides a place to compute the result until we figure out what (if ;;; anything) to do with it. ;;; -;;; If the continuation is fixed-values, wants the same number of values as -;;; the user wants to deliver, and requires no implicit coercion, then we just -;;; return the IR2-Continuation-Locs. If coercions are required, then we make -;;; any necessary temporaries and return them. +;;; If the continuation is fixed-values, and wants the same number of values +;;; as the user wants to deliver, then we just return the +;;; IR2-Continuation-Locs. Otherwise we make a new list padded as necessary by +;;; discarded TNs. ;;; ;;; If the continuation is unknown-values, then we make a boxed TN to ;;; compute each desired result in. ;;; -;;; If the continuation is :Unused (a tail-recursive result), then we look -;;; at the return-info for the function being returned from. If the return -;;; convention is fixed, then we make result temporaries as specified by -;;; rtypes, otherwise we make the same number of boxed temporaries. +;;; Currently, we totally ignore the types, always allocating TNs of type T +;;; when we can't use a continuation's TN. This affects unused values and +;;; values needing to be checked. But representation selection cleverly +;;; replaces dummy result TNs with ones in a good representation, so the first +;;; isn't a problem. It seems important to allow non-standard representations +;;; in type checking for numeric subranges, but these checks are hairy, so the +;;; right thing happens. ;;; (defun continuation-result-tns (cont rtypes) (declare (type continuation cont) (list rtypes)) (let ((2cont (continuation-info cont))) (if (or (not 2cont) (eq (continuation-type-check cont) t)) - (mapcar #'make-normal-tn rtypes) + (make-n-tns (length rtypes) *any-primitive-type*) (ecase (ir2-continuation-kind 2cont) (:fixed (let ((locs (ir2-continuation-locs 2cont))) - (if (and (= (length locs) (length rtypes)) - (every #'ok-result-tn locs rtypes)) + (if (= (length locs) (length rtypes)) locs (collect ((res)) (do ((loc locs (cdr loc)) (rtype rtypes (cdr rtype))) ((null rtype)) (if loc - (res (get-result-tn (car loc) (car rtype))) - (res (make-normal-tn (car rtype))))) + (res (car loc)) + (res (make-normal-tn *any-primitive-type*)))) (res))))) - ((:unknown :unused) - (mapcar #'make-normal-tn rtypes)))))) - -#| (:unknown - (make-n-tns (length rtypes) *any-primitive-type*)) - (:unused - (let ((returns (tail-set-info - (lambda-tail-set - (return-lambda - (continuation-dest cont)))))) - (if (eq (return-info-kind returns) :fixed) - (mapcar #'make-normal-tn rtypes) - (make-n-tns (length rtypes) *any-primitive-type*)))) -|# + (make-n-tns (length rtypes) *any-primitive-type*)))))) + ;;; Make-Standard-Value-Tns -- Internal ;;; @@ -608,8 +348,7 @@ ;;; If the continuation isn't annotated, then we treat as 0-values, ;;; returning an empty list of temporaries. ;;; -;;; If the continuation is annotated, then it must either be :Fixed or be -;;; :Unused with the Return-Info-Kind being :Fixed. +;;; If the continuation is annotated, then it must be :Fixed. ;;; (defun standard-result-tns (cont) (declare (type continuation cont)) @@ -617,15 +356,7 @@ (if 2cont (ecase (ir2-continuation-kind 2cont) (:fixed - (make-standard-value-tns (length (ir2-continuation-locs 2cont)))) - (:unused - (let ((returns (tail-set-info - (lambda-tail-set - (return-lambda - (continuation-dest cont)))))) - (assert (eq (return-info-kind returns) :fixed)) - (make-standard-value-tns - (length (return-info-types returns)))))) + (make-standard-value-tns (length (ir2-continuation-locs 2cont))))) ()))) @@ -707,12 +438,6 @@ ;;; standard value locations, and use Push-Values to put the values on the ;;; stack. ;;; -;;; If the continuation is :Unused, then this use is tail-recursive. We -;;; emit code that returns the values out of the current function. Type -;;; checking is done in-place in the Results, since we don't know where -;;; Emit-Return-For-Locs is going to want to pass the values. In this case, we -;;; also flush the control transfer to the tail return. -;;; (defun move-continuation-result (node block results cont) (declare (type node node) (type ir2-block block) (list results) (type continuation cont)) @@ -736,37 +461,63 @@ (vop* push-values node block ((reference-tn-list locs nil)) ((reference-tn-list (ir2-continuation-locs 2cont) t)) - nvals))) - (:unused - (when check - (move-results-checked node block results results cont)) - (emit-return-for-locs (continuation-dest cont) block :fixed results) - (flush-tail-transfer node block))))) + nvals)))))) (undefined-value)) ;;;; Template conversion: +;;; Reference-Arguments -- Internal +;;; +;;; Build a TN-Refs list that represents access to the values of the +;;; specified list of continuations Args for Template. Any :CONSTANT arguments +;;; are returned in the second value as a list rather than being accessed as a +;;; normal argument. Node and Block provide the context for emitting any +;;; necessary type-checking code. +;;; +(defun reference-arguments (node block args template) + (declare (type node node) (type ir2-block block) (list args) + (type template template)) + (collect ((info-args)) + (let ((last nil) + (first nil)) + (do ((args args (cdr args)) + (types (template-arg-types template) (cdr types))) + ((null args)) + (let ((type (first types)) + (arg (first args))) + (if (and (consp type) (eq (car type) ':constant)) + (info-args (continuation-value arg)) + (let ((ref (reference-tn (continuation-tn node block arg) nil))) + (if last + (setf (tn-ref-across last) ref) + (setf first ref)) + (setq last ref))))) + + (values (the (or tn-ref null) first) (info-args))))) + + ;;; IR2-Convert-Conditional -- Internal ;;; ;;; Convert a conditional template. We try to exploit any drop-through, but ;;; emit an unconditional branch afterward if we fail. Not-P is true if the ;;; sense of the Template's test should be negated. ;;; -(defun ir2-convert-conditional (node block template args if not-p) +(defun ir2-convert-conditional (node block template args info-args if not-p) (declare (type node node) (type ir2-block block) (type template template) (type (or tn-ref null) args) - (type cif if) (type boolean not-p)) - (assert (= (template-info-arg-count template) 2)) + (list info-args) (type cif if) (type boolean not-p)) + (assert (= (template-info-arg-count template) (+ (length info-args) 2))) (let ((consequent (if-consequent if)) (alternative (if-alternative if))) (cond ((drop-thru-p if consequent) (emit-template node block template args nil - (list (block-label alternative) (not not-p)))) + (list* (block-label alternative) (not not-p) + info-args))) (t (emit-template node block template args nil - (list (block-label consequent) not-p)) + (list* (block-label consequent) not-p info-args)) (unless (drop-thru-p if alternative) (vop branch node block (block-label alternative))))))) @@ -782,7 +533,7 @@ (nil-ref (reference-tn (emit-constant nil) nil))) (setf (tn-ref-across test-ref) nil-ref) (ir2-convert-conditional node block (template-or-lose 'if-eq) - test-ref node t))) + test-ref () node t))) ;;; IR2-Convert-Template -- Internal @@ -794,17 +545,22 @@ (declare (type combination call) (type ir2-block block)) (let* ((template (combination-info call)) (cont (node-cont call)) - (args (reference-arguments call block (combination-args call))) (rtypes (template-result-types template))) - (assert (not (template-more-results-type template))) - (if (eq rtypes :conditional) - (ir2-convert-conditional call block template args - (continuation-dest cont) nil) - (let ((results (continuation-result-tns cont rtypes))) - (assert (zerop (template-info-arg-count template))) - (emit-template call block template args - (reference-tn-list results t)) - (move-continuation-result call block results cont)))) + (multiple-value-bind + (args info-args) + (reference-arguments call block (combination-args call) template) + (assert (not (template-more-results-type template))) + (if (eq rtypes :conditional) + (ir2-convert-conditional call block template args info-args + (continuation-dest cont) nil) + (let* ((results (continuation-result-tns cont rtypes)) + (r-refs (reference-tn-list results t))) + (assert (= (length info-args) + (template-info-arg-count template))) + (if info-args + (emit-template call block template args r-refs info-args) + (emit-template call block template args r-refs)) + (move-continuation-result call block results cont))))) (undefined-value)) @@ -818,18 +574,22 @@ (let* ((template (continuation-value template)) (info (continuation-value info)) (cont (node-cont call)) - (args (reference-arguments call block (cddr (combination-args call)))) (rtypes (template-result-types template)) (results (continuation-result-tns cont rtypes)) (r-refs (reference-tn-list results t))) - (assert (not (template-more-results-type template))) - (assert (not (eq rtypes :conditional))) - - (if info - (emit-template call block template args r-refs info) - (emit-template call block template args r-refs)) - - (move-continuation-result call block results cont)) + (multiple-value-bind + (args info-args) + (reference-arguments call block (cddr (combination-args call)) + template) + (assert (not (template-more-results-type template))) + (assert (not (eq rtypes :conditional))) + (assert (null info-args)) + + (if info + (emit-template call block template args r-refs info) + (emit-template call block template args r-refs)) + + (move-continuation-result call block results cont))) (undefined-value)) @@ -855,66 +615,72 @@ (undefined-value)) -;;; Move-Local-Call-Args -- Internal +;;; IR2-Convert-Tail-Local-Call -- Internal ;;; -;;; Set up the arguments for a local call. This involves moving the actual -;;; arguments into the passing locations (doing any type checking) and -;;; computing the environment arguments for the called function. +;;; A tail-recursive local call is done by emitting moves of stuff into the +;;; appropriate passing locations. After setting up the args and environment, +;;; we just move our return-pc and old-fp into the called function's passing +;;; locations. ;;; -(defun move-local-call-args (node block fun) +(defun ir2-convert-tail-local-call (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) (let* ((called-env (environment-info (lambda-environment fun))) (arg-locs (ir2-environment-arg-locs called-env)) - (1env (node-environment node))) + (this-1env (node-environment node)) + (this-env (environment-info this-1env))) (dolist (arg (basic-combination-args node)) (when arg (emit-move node block (continuation-tn node block arg) (pop arg-locs)))) (dolist (thing (ir2-environment-environment called-env)) - (emit-move node block (find-in-environment (car thing) 1env) - (pop arg-locs)))) + (emit-move node block (find-in-environment (car thing) this-1env) + (pop arg-locs))) + + (emit-move node block (ir2-environment-old-fp this-env) + (ir2-environment-old-fp-pass called-env)) + (emit-move node block (ir2-environment-return-pc this-env) + (ir2-environment-return-pc-pass called-env))) (undefined-value)) -;;; IR2-Convert-Tail-Local-Call -- Internal +;;; IR2-CONVERT-LOCAL-CALL-ARGS -- Internal ;;; -;;; A tail-recursive local call is done by emitting moves of stuff into the -;;; appropriate passing locations. After setting up the args and environment, -;;; we just move our return-pc and old-cont into the called function's passing -;;; locations. The Current-Cont VOP is used to set the arg pointer to point -;;; to the current frame. +;;; Do stuff to set up the arguments to a non-tail local call (including +;;; implicit environment args.) We allocate a frame (returning the FP and +;;; NFP), and also compute the TN-Refs list for the values to pass and the list +;;; of passingt location TNs. ;;; -;;; The Tail-Call-Local VOP's only purpose is to get the argument lifetimes -;;; right. We flush the tail control transfer for similar reasons. -;;; -(defun ir2-convert-tail-local-call (node block fun) - (declare (type combination node) (type ir2-block block) (type clambda fun)) - (move-local-call-args node block fun) - - (let* ((this-env (environment-info (node-environment node))) - (call-env (environment-info (lambda-environment fun))) - (old-cont (ir2-environment-old-cont-pass call-env)) - (return-pc (ir2-environment-return-pc-pass call-env)) - (args (ir2-environment-argument-pointer call-env)) - (target (node-block (lambda-bind fun)))) - - (emit-move node block (ir2-environment-old-cont this-env) old-cont) - (emit-move node block (ir2-environment-return-pc this-env) return-pc) - (vop current-cont node block args) - - (vop* tail-call-local node block - (old-cont return-pc args - (reference-tn-list (ir2-environment-arg-locs call-env) - nil)) - (nil) - (unless (drop-thru-p (block-last (node-block node)) target) - (block-label target)))) - - (flush-tail-transfer node block) +(defun ir2-convert-local-call-args (node block env) + (declare (type combination node) (type ir2-block block) + (type ir2-environment env)) + (let ((fp (make-normal-tn *any-primitive-type*)) + (nfp (make-normal-tn *any-primitive-type*)) + (old-fp (make-normal-tn *any-primitive-type*)) + (this-1env (node-environment node))) - (undefined-value)) + (vop current-fp node block old-fp) + (vop allocate-frame node block fp nfp) + + (let* ((args (reference-tn old-fp nil)) + (tail args)) + (dolist (arg (basic-combination-args node)) + (when arg + (let ((arg-ref (reference-tn (continuation-tn node block arg) nil))) + (setf (tn-ref-across tail) arg-ref) + (setf tail arg-ref)))) + + (dolist (thing (ir2-environment-environment env)) + (let ((arg-ref (reference-tn + (find-in-environment (car thing) this-1env) + nil))) + (setf (tn-ref-across tail) arg-ref) + (setf tail arg-ref))) + + (values fp nfp args + (cons (ir2-environment-old-fp-pass env) + (ir2-environment-arg-locs env)))))) ;;; IR2-Convert-Local-Known-Call -- Internal @@ -926,22 +692,16 @@ (declare (type node node) (type ir2-block block) (type ir2-environment env) (type return-info returns) (type continuation cont) (type label start)) - (let* ((locs (return-info-locations returns)) - (temps (continuation-result-tns - cont (mapcar #'tn-primitive-type locs)))) - (vop* known-call-local node block - ((ir2-environment-old-cont-pass env) - (ir2-environment-argument-pointer env) - (reference-tn-list (ir2-environment-arg-locs env) nil)) - ((reference-tn-list locs t)) - "<save info>" - (ir2-environment-return-pc-pass env) - start) - (mapc #'(lambda (from to) - (unless (eq from to) - (emit-move node block from to))) - locs temps) - (move-continuation-result node block temps cont)) + (multiple-value-bind (fp nfp args arg-locs) + (ir2-convert-local-call-args node block env) + (let ((locs (return-info-locations returns))) + (vop* known-call-local node block + (fp nfp args) + ((reference-tn-list locs t)) + arg-locs + (ir2-environment-return-pc-pass env) + start) + (move-continuation-result node block locs cont))) (undefined-value)) @@ -950,7 +710,7 @@ ;;; Handle a non-TR unknown-values local call. We do different things ;;; depending on what kind of values the continuation wants. ;;; -;;; If Cont is :Unkown, then we use the "Multiple-" variant, directly +;;; If Cont is :Unknown, then we use the "Multiple-" variant, directly ;;; specifying the continuation's Locs as the VOP results so that we don't have ;;; to do anything after the call. ;;; @@ -961,43 +721,20 @@ (defun ir2-convert-local-unknown-call (node block env cont start) (declare (type node node) (type ir2-block block) (type ir2-environment env) (type continuation cont) (type label start)) - (let ((2cont (continuation-info cont)) - (old-cont (ir2-environment-old-cont-pass env)) - (argp (ir2-environment-argument-pointer env)) - (return-pc (ir2-environment-return-pc-pass env)) - (arg-locs (reference-tn-list (ir2-environment-arg-locs env) nil))) - (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* multiple-call-local node block (old-cont argp arg-locs) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) - "<save info>" return-pc start) - (let ((temps (standard-result-tns cont))) - (vop* call-local node block - (old-cont argp arg-locs) - ((reference-tn-list temps t)) - "<save info>" return-pc start (length temps)) - (move-continuation-result node block temps cont)))) - (undefined-value)) - - -;;; IR2-Convert-Local-Normal-Call -- Internal -;;; -;;; This function handles non-tail-recursive local call. We move the -;;; arguments into the passing locations and then look at return conventions -;;; and think about how we are going to get the values back. -;;; -(defun ir2-convert-local-normal-call (node block fun) - (let* ((env (environment-info (lambda-environment fun))) - (start (block-label (node-block (lambda-bind fun)))) - (returns (tail-set-info (lambda-tail-set fun))) - (cont (node-cont node))) - (move-local-call-args node block fun) - (vop current-cont node block (ir2-environment-old-cont-pass env)) - (vop current-cont node block (ir2-environment-argument-pointer env)) - (ecase (return-info-kind returns) - (:unknown - (ir2-convert-local-unknown-call node block env cont start)) - (:fixed - (ir2-convert-local-known-call node block env returns cont start)))) + (multiple-value-bind (fp nfp args arg-locs) + (ir2-convert-local-call-args node block env) + (let ((2cont (continuation-info cont)) + (return-pc (ir2-environment-return-pc-pass env))) + (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) + (vop* multiple-call-local node block (fp nfp args) + ((reference-tn-list (ir2-continuation-locs 2cont) t)) + arg-locs return-pc start) + (let ((temps (standard-result-tns cont))) + (vop* call-local node block + (fp nfp args) + ((reference-tn-list temps t)) + arg-locs return-pc start (length temps)) + (move-continuation-result node block temps cont))))) (undefined-value)) @@ -1014,7 +751,16 @@ ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (ir2-convert-local-normal-call node block fun)))) + (let* ((env (environment-info (lambda-environment fun))) + (start (block-label (node-block (lambda-bind fun)))) + (returns (tail-set-info (lambda-tail-set fun))) + (cont (node-cont node))) + (ecase (return-info-kind returns) + (:unknown + (ir2-convert-local-unknown-call node block env cont start)) + (:fixed + (ir2-convert-local-known-call node block env returns + cont start))))))) (undefined-value)) @@ -1052,12 +798,12 @@ (values temp nil))))))) -;;; Move-Full-Call-Args -- Internal +;;; MOVE-TAIL-FULL-CALL-ARGS -- Internal ;;; -;;; Set up the arguments to a full call in the appropriate passing -;;; locations. Returns the head of a TN-Ref list to the passing locations. +;;; Set up the args to Node in the current frame, and return a tn-ref list +;;; for the passing locations. ;;; -(defun move-full-call-args (node block) +(defun move-tail-full-call-args (node block) (declare (type combination node) (type ir2-block block)) (let ((args (basic-combination-args node)) (last nil) @@ -1076,32 +822,58 @@ ;;; IR2-Convert-Tail-Full-Call -- Internal ;;; ;;; Move the arguments into the passing locations and do a (possibly named) -;;; tail call. We flush the tail control transfer so that nobody thinks that -;;; we return. +;;; tail call. ;;; (defun ir2-convert-tail-full-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((pass-refs (move-full-call-args node block)) - (env (environment-info (node-environment node))) - (old-cont (ir2-environment-old-cont env)) - (return-pc (ir2-environment-return-pc env)) - (nargs (length (basic-combination-args node)))) + (let* ((env (environment-info (node-environment node))) + (args (basic-combination-args node)) + (nargs (length args)) + (pass-refs (move-tail-full-call-args node block)) + (old-fp (ir2-environment-old-fp env)) + (return-pc (ir2-environment-return-pc env))) + (multiple-value-bind (fun-tn named) (function-continuation-tn node block (basic-combination-fun node)) (if named (vop* tail-call-named node block - (fun-tn old-cont return-pc pass-refs) + (fun-tn old-fp return-pc pass-refs) (nil) nargs) (vop* tail-call node block - (fun-tn old-cont return-pc pass-refs) + (fun-tn old-fp return-pc pass-refs) (nil) nargs)))) - (flush-tail-transfer node block) + (undefined-value)) +;;; IR2-CONVERT-FULL-CALL-ARGS -- Internal +;;; +;;; Like IR2-CONVERT-LOCAL-CALL-ARGS, only different. +;;; +(defun ir2-convert-full-call-args (node block) + (declare (type combination node) (type ir2-block block)) + (let* ((args (basic-combination-args node)) + (fp (make-normal-tn *any-primitive-type*)) + (nargs (length args))) + (vop allocate-full-call-frame node block nargs fp) + (collect ((locs)) + (let ((last nil) + (first nil)) + (dotimes (num nargs) + (locs (standard-argument-location num)) + (let ((ref (reference-tn (continuation-tn node block (elt args num)) + nil))) + (if last + (setf (tn-ref-across last) ref) + (setf first ref)) + (setq last ref))) + + (values fp first (locs) nargs))))) + + ;;; IR2-Convert-Fixed-Full-Call -- Internal ;;; ;;; Do full call when a fixed number of values are desired. We make @@ -1110,21 +882,21 @@ ;;; (defun ir2-convert-fixed-full-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((nargs (length (basic-combination-args node))) - (pass-refs (move-full-call-args node block)) - (cont (node-cont node)) - (locs (standard-result-tns cont)) - (loc-refs (reference-tn-list locs t)) - (nvals (length locs))) - (multiple-value-bind - (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) - (if named - (vop* call-named node block (fun-tn pass-refs) (loc-refs) - "<save info>" nargs nvals) - (vop* call node block (fun-tn pass-refs) (loc-refs) - "<save info>" nargs nvals)) - (move-continuation-result node block locs cont))) + (multiple-value-bind (fp args arg-locs nargs) + (ir2-convert-full-call-args node block) + (let* ((cont (node-cont node)) + (locs (standard-result-tns cont)) + (loc-refs (reference-tn-list locs t)) + (nvals (length locs))) + (multiple-value-bind + (fun-tn named) + (function-continuation-tn node block (basic-combination-fun node)) + (if named + (vop* call-named node block (fp fun-tn args) (loc-refs) + arg-locs nargs nvals) + (vop* call node block (fp fun-tn args) (loc-refs) + arg-locs nargs nvals)) + (move-continuation-result node block locs cont)))) (undefined-value)) @@ -1134,34 +906,32 @@ ;;; (defun ir2-convert-multiple-full-call (node block) (declare (type combination node) (type ir2-block block)) - (let* ((nargs (length (basic-combination-args node))) - (pass-refs (move-full-call-args node block)) - (cont (node-cont node)) - (locs (ir2-continuation-locs (continuation-info cont))) - (loc-refs (reference-tn-list locs t))) - (multiple-value-bind - (fun-tn named) - (function-continuation-tn node block (basic-combination-fun node)) - (if named - (vop* multiple-call-named node block (fun-tn pass-refs) (loc-refs) - "<save info>" nargs) - (vop* multiple-call node block (fun-tn pass-refs) (loc-refs) - "<save info>" nargs)))) + (multiple-value-bind (fp args arg-locs nargs) + (ir2-convert-full-call-args node block) + (let* ((cont (node-cont node)) + (locs (ir2-continuation-locs (continuation-info cont))) + (loc-refs (reference-tn-list locs t))) + (multiple-value-bind + (fun-tn named) + (function-continuation-tn node block (basic-combination-fun node)) + (if named + (vop* multiple-call-named node block (fp fun-tn args) (loc-refs) + arg-locs nargs) + (vop* multiple-call node block (fp fun-tn args) (loc-refs) + arg-locs nargs))))) (undefined-value)) ;;; IR2-Convert-Full-Call -- Internal ;;; ;;; If the call is in a TR position and the return convention is standard, -;;; then do a full call. If one or fewer values are desired, then use a +;;; then do a tail full call. If one or fewer values are desired, then use a ;;; single-value call, otherwise use a multiple-values call. ;;; (defun ir2-convert-full-call (node block) (declare (type combination node) (type ir2-block block)) (let ((2cont (continuation-info (node-cont node)))) - (cond ((let ((tails (node-tail-p node))) - (and tails - (eq (return-info-kind (tail-set-info tails)) :unknown))) + (cond ((node-tail-p node) (ir2-convert-tail-full-call node block)) ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) @@ -1182,7 +952,7 @@ ;;; (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) - (vop allocate-frame node block (entry-info-offset (leaf-info fun))) + (vop xep-allocate-frame node block (entry-info-offset (leaf-info fun))) (let ((ef (functional-entry-function fun))) (when (and (optional-dispatch-p ef) (optional-dispatch-more-entry ef)) @@ -1216,7 +986,6 @@ (let* ((fun (bind-lambda node)) (xep-p (external-entry-point-p fun)) (env (environment-info (lambda-environment fun))) - (argp (ir2-environment-argument-pointer env)) (args (ir2-environment-arg-locs env))) (assert (member (functional-kind fun) '(nil :external :optional :top-level :cleanup))) @@ -1229,22 +998,20 @@ (let ((pass (pop args)) (home (leaf-info arg))) (if (lambda-var-indirect arg) - (let ((temp (make-normal-tn *any-primitive-type*))) - (move-from-frame node block pass temp argp) - (vop make-value-cell node block temp home)) - (move-from-frame node block pass home argp))))) + (vop make-value-cell node block pass home) + (emit-move node block pass home))))) (unless xep-p (dolist (loc (ir2-environment-environment env)) - (move-from-frame node block (pop args) (cdr loc) argp))) + (emit-move node block (pop args) (cdr loc)))) - (when (ir2-environment-old-cont env) - (move-from-frame node block (ir2-environment-old-cont-pass env) - (ir2-environment-old-cont env) argp)) + (when (ir2-environment-old-fp env) + (emit-move node block (ir2-environment-old-fp-pass env) + (ir2-environment-old-fp env))) (when (ir2-environment-return-pc env) - (move-from-frame node block (ir2-environment-return-pc-pass env) - (ir2-environment-return-pc env) argp)) + (emit-move node block (ir2-environment-return-pc-pass env) + (ir2-environment-return-pc env))) (let ((lab (gen-label))) (setf (ir2-environment-environment-start env) lab) @@ -1257,48 +1024,30 @@ ;;; IR2-Convert-Return -- Internal ;;; -(defun ir2-convert-return (node block) - (let ((cont (continuation-info (return-result node)))) - (unless (eq (ir2-continuation-kind cont) :unused) - (emit-return-for-locs node block - (ir2-continuation-kind cont) - (ir2-continuation-locs cont)))) - (undefined-value)) - - -;;; Emit-Return-For-Locs -- Internal -;;; ;;; Do stuff to return from a function with the specified values and -;;; convention. Node must the Return node that we are doing a return for. -;;; The reason that this is broken off from IR2-Convert-Return in this curious -;;; way is that when all uses of the result are tail-recursive, we annotate the -;;; result continuation as :Unused and then emit a return at each use of the -;;; result. -;;; -;;; If the return convention is :Fixed and we aren't returning from an XEP, -;;; then we move the return values to the passing locs and do a Known-Return. -;;; Otherwise, we use the unknown-values convention. If there is a fixed -;;; number of return values, then use Return, otherwise use Return-Multiple. -;;; -(defun emit-return-for-locs (node block cont-kind cont-locs) - (declare (type creturn node) (type ir2-block block) - (type (member :fixed :unknown) cont-kind) - (list cont-locs)) - (let* ((fun (return-lambda node)) +;;; convention. If the return convention is :Fixed and we aren't returning +;;; from an XEP, then we move the return values to the passing locs and do a +;;; Known-Return. Otherwise, we use the unknown-values convention. If there +;;; is a fixed number of return values, then use Return, otherwise use +;;; Return-Multiple. +;;; +(defun ir2-convert-return (node block) + (declare (type creturn node) (type ir2-block block)) + (let* ((cont (continuation-info (return-result node))) + (cont-kind (ir2-continuation-kind cont)) + (cont-locs (ir2-continuation-locs cont)) + (fun (return-lambda node)) (env (environment-info (lambda-environment fun))) - (old-cont (ir2-environment-old-cont env)) + (old-fp (ir2-environment-old-fp env)) (return-pc (ir2-environment-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) (cond ((and (eq (return-info-kind returns) :fixed) (not (external-entry-point-p fun))) - (let ((locs (return-info-locations returns))) - (mapc #'(lambda (from to) - (move-to-frame node block from to old-cont)) - cont-locs locs) - (vop* known-return node block - (old-cont return-pc (reference-tn-list locs nil)) - (nil)))) + (vop* known-return node block + (old-fp return-pc (reference-tn-list cont-locs nil)) + (nil) + (return-info-locations returns))) ((eq cont-kind :fixed) (let* ((nvals (length cont-locs)) (locs (make-standard-value-tns nvals))) @@ -1307,13 +1056,13 @@ cont-locs locs) (vop* return node block - (old-cont return-pc (reference-tn-list locs nil)) + (old-fp return-pc (reference-tn-list locs nil)) (nil) nvals))) (t (assert (eq cont-kind :unknown)) (vop* return-multiple node block - (old-cont return-pc (reference-tn-list cont-locs nil)) + (old-fp return-pc (reference-tn-list cont-locs nil)) (nil))))) (undefined-value)) @@ -1365,24 +1114,19 @@ (assert (and (not named) (eq (ir2-continuation-kind start-cont) :unknown))) (cond - ((and tails - (eq (return-info-kind (tail-set-info tails)) :unknown)) + (tails (let ((env (environment-info (node-environment node)))) - (vop tail-call-variable node block fun - (ir2-environment-old-cont env) - (ir2-environment-return-pc env) - start)) - (flush-tail-transfer node block)) + (vop tail-call-variable node block start fun + (ir2-environment-old-fp env) + (ir2-environment-return-pc env)))) ((and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* multiple-call-variable node block (fun start nil) - ((reference-tn-list (ir2-continuation-locs 2cont) t)) - "<save info>")) + (vop* multiple-call-variable node block (start fun nil) + ((reference-tn-list (ir2-continuation-locs 2cont) t)))) (t (let ((locs (standard-result-tns cont))) - (vop* call-variable node block (fun start nil) - ((reference-tn-list locs t)) - "<save info>" (length locs)) + (vop* call-variable node block (start fun nil) + ((reference-tn-list locs t)) (length locs)) (move-continuation-result node block locs cont))))))) @@ -1412,32 +1156,22 @@ ;;; Values-List IR2 convert -- Internal ;;; ;;; In the normal case where unknown values are desired, we use the -;;; Values-List VOP. If the continuation is :Unused (a TR result -;;; continuation), then we must compute the values into temporaries and then do -;;; an Emit-Return-For-Locs and flush the tail control transfer. -;;; -;;; In the relatively unimportant case of Values-List for a fixed number of -;;; values, we punt by doing a full call to the Values-List function. This -;;; gets the full call VOP to deal with defaulting any unsupplied values. It -;;; seems unworthwhile to optimize this case. +;;; Values-List VOP. In the relatively unimportant case of Values-List for a +;;; fixed number of values, we punt by doing a full call to the Values-List +;;; function. This gets the full call VOP to deal with defaulting any +;;; unsupplied values. It seems unworthwhile to optimize this case. ;;; (defoptimizer (values-list ir2-convert) ((list) node block) (let* ((cont (node-cont node)) (2cont (continuation-info cont))) (when 2cont - (let ((kind (ir2-continuation-kind 2cont))) - (if (eq kind :fixed) - (ir2-convert-full-call node block) - (let ((locs (ecase kind - (:unknown (ir2-continuation-locs 2cont)) - (:unused (make-unknown-values-locations))))) - (vop* values-list node block - ((continuation-tn node block list) nil) - ((reference-tn-list locs t))) - (when (eq kind :unused) - (emit-return-for-locs (continuation-dest cont) block :unknown - locs) - (flush-tail-transfer node block)))))))) + (ecase (ir2-continuation-kind 2cont) + (:fixed (ir2-convert-full-call node block)) + (:unknown + (let ((locs (ir2-continuation-locs 2cont))) + (vop* values-list node block + ((continuation-tn node block list) nil) + ((reference-tn-list locs t))))))))) ;;;; Special binding: @@ -1548,8 +1282,9 @@ (type (or continuation null) tag)) (let* ((2info (nlx-info-info info)) (kind (cleanup-kind (nlx-info-cleanup info))) - (block-tn (make-environment-tn (primitive-type-or-lose 'catch-block) - (node-environment node))) + (block-tn (environment-live-tn + (make-representation-tn (sc-number-or-lose 'catch-block)) + (node-environment node))) (res (make-normal-tn *any-primitive-type*)) (target-tn (make-load-time-constant-tn @@ -1615,8 +1350,8 @@ ;;; use the other variant, delivering the temps to the continuation using ;;; Move-Continuation-Result. ;;; -;;; In the Unwind-Protect case, we deliver move the first register argument, -;;; the argument count and the argument pointer to our continuation as multiple +;;; In the Unwind-Protect case, we deliver the first register argument, the +;;; argument count and the argument pointer to our continuation as multiple ;;; values. These values are the block exited to and the values start and ;;; count. ;;; @@ -1631,7 +1366,7 @@ (2cont (continuation-info cont)) (2info (nlx-info-info info)) (top-loc (ir2-nlx-info-save-sp 2info)) - (start-loc (make-argument-pointer-location t)) + (start-loc (make-old-fp-passing-location t)) (count-loc (make-argument-count-location))) (ecase (cleanup-kind (nlx-info-cleanup info)) @@ -1663,14 +1398,12 @@ (macrolet ((frob (name) `(defoptimizer (,name ir2-convert) ((&rest args) node block) - (let* ((refs (move-full-call-args node block)) + (let* ((refs (move-tail-full-call-args node block)) (cont (node-cont node)) (res (continuation-result-tns cont (list (primitive-type (specifier-type 'list)))))) - (vop* ,name node block - (refs) - ((first res) nil) + (vop* ,name node block (refs) ((first res) nil) (length args)) (move-continuation-result node block res cont))))) (frob list) @@ -1767,10 +1500,10 @@ (let ((fun (function-info-ir2-convert kind))) (cond (fun (funcall fun node 2block)) - ((basic-combination-info node) - (ir2-convert-template node 2block)) + ((eq (basic-combination-info node) :full) + (ir2-convert-full-call node 2block)) (t - (ir2-convert-full-call node 2block)))))))) + (ir2-convert-template node 2block)))))))) (cif (when (continuation-info (if-test node)) (ir2-convert-if node 2block)))