diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index 70590b84bf22e969da5137c8899c21c7cb188129..4f601fb5d0d2c76c0b4661b88c74f4f9aa34ab40 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -7,14 +7,17 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.18 1990/07/23 14:51:33 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.19 1990/08/16 16:16:50 ram Exp $ ;;; ;;; This file contains the virtual machine independent parts of the code ;;; which does the actual translation of nodes to VOPs. ;;; ;;; Written by Rob MacLachlan ;;; -(in-package 'c) +(in-package "C") +(in-package "KERNEL") +(export '(%caller-frame-and-pc)) +(in-package "C") ;;;; Moves and type checks: @@ -684,33 +687,79 @@ (undefined-value)) -;;; IR2-Convert-Tail-Local-Call -- Internal +;;; EMIT-PSETQ-MOVES -- 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-fp into the called function's passing -;;; locations. +;;; Emit any necessary moves into assignment temps for a local call to Fun. +;;; OLD-FP is the TN currently holding the value we want to pass as OLD-FP. +;;; We return two lists of TNs: TNs holding the actual argument values, and +;;; (possibly EQ) TNs that are the actual destination of the arguments. When +;;; necessary, we allocate temporaries for arguments to preserve paralell +;;; assignment semantics. These lists exclude unused arguments and include +;;; implicit environment arguments, i.e. they exactly correspond to the +;;; arguments passed. ;;; -(defun ir2-convert-tail-local-call (node block fun) - (declare (type combination node) (type ir2-block block) (type clambda fun)) +(defun emit-psetq-moves (node block fun old-fp) + (declare (type combination node) (type ir2-block block) (type clambda fun) + (type tn old-fp)) (let* ((called-env (environment-info (lambda-environment fun))) - (arg-locs (ir2-environment-arg-locs called-env)) (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)))) + (actuals (mapcar #'(lambda (x) + (when x + (continuation-tn node block x))) + (combination-args node)))) + (collect ((temps) + (locs)) + (dolist (var (lambda-vars fun)) + (let ((actual (pop actuals)) + (loc (leaf-info var))) + (when actual + (cond + ((lambda-var-indirect var) + (let ((temp (make-normal-tn *any-primitive-type*))) + (vop make-value-cell node block actual temp) + (temps temp))) + ((member actual (locs)) + (let ((temp (make-normal-tn (tn-primitive-type loc)))) + (emit-move node block actual temp) + (temps temp))) + (t + (temps actual))) + (locs loc)))) - (dolist (thing (ir2-environment-environment called-env)) - (emit-move node block (find-in-environment (car thing) this-1env) - (pop arg-locs))) + (dolist (thing (ir2-environment-environment called-env)) + (temps (find-in-environment (car thing) this-1env)) + (locs (cdr thing))) + + (temps old-fp) + (locs (ir2-environment-old-fp called-env)) - (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))) + (values (temps) (locs))))) + +;;; IR2-Convert-Tail-Local-Call -- 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 into the called function's passing +;;; location. +;;; +(defun ir2-convert-tail-local-call (node block fun) + (declare (type combination node) (type ir2-block block) (type clambda fun)) + (let ((this-env (environment-info (node-environment node)))) + (multiple-value-bind + (temps locs) + (emit-psetq-moves node block fun (ir2-environment-old-fp this-env)) + + (mapc #'(lambda (temp loc) + (emit-move node block temp loc)) + temps locs)) + + (emit-move node block + (ir2-environment-return-pc this-env) + (ir2-environment-return-pc-pass + (environment-info + (lambda-environment fun))))) + (undefined-value)) @@ -719,37 +768,20 @@ ;;; 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. +;;; of passing location TNs. ;;; -(defun ir2-convert-local-call-args (node block env) - (declare (type combination node) (type ir2-block block) - (type ir2-environment env)) +(defun ir2-convert-local-call-args (node block fun) + (declare (type combination node) (type ir2-block block) (type clambda fun)) (let ((fp (make-stack-pointer-tn)) (nfp (make-number-stack-pointer-tn)) - (old-fp (make-stack-pointer-tn)) - (this-1env (node-environment node))) - - (vop current-fp node block old-fp) - (vop allocate-frame node block env 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)))))) + (old-fp (make-stack-pointer-tn))) + (multiple-value-bind (temps locs) + (emit-psetq-moves node block fun old-fp) + (vop current-fp node block old-fp) + (vop allocate-frame node block + (environment-info (lambda-environment fun)) + fp nfp) + (values fp nfp temps (mapcar #'make-alias-tn locs))))) ;;; IR2-Convert-Local-Known-Call -- Internal @@ -757,17 +789,17 @@ ;;; Handle a non-TR known-values local call. We Emit the call, then move ;;; the results to the continuation's destination. ;;; -(defun ir2-convert-local-known-call (node block env returns cont start) - (declare (type node node) (type ir2-block block) (type ir2-environment env) +(defun ir2-convert-local-known-call (node block fun returns cont start) + (declare (type node node) (type ir2-block block) (type clambda fun) (type return-info returns) (type continuation cont) (type label start)) - (multiple-value-bind (fp nfp args arg-locs) - (ir2-convert-local-call-args node block env) + (multiple-value-bind (fp nfp temps arg-locs) + (ir2-convert-local-call-args node block fun) (let ((locs (return-info-locations returns))) (vop* known-call-local node block - (fp nfp args) + (fp nfp (reference-tn-list temps nil)) ((reference-tn-list locs t)) - arg-locs env start) + arg-locs (environment-info (lambda-environment fun)) start) (move-continuation-result node block locs cont))) (undefined-value)) @@ -785,22 +817,24 @@ ;;; then call Move-Continuation-Result to do any necessary type checks or ;;; coercions. ;;; -(defun ir2-convert-local-unknown-call (node block env cont start) - (declare (type node node) (type ir2-block block) (type ir2-environment env) +(defun ir2-convert-local-unknown-call (node block fun cont start) + (declare (type node node) (type ir2-block block) (type clambda fun) (type continuation cont) (type label start)) - (multiple-value-bind (fp nfp args arg-locs) - (ir2-convert-local-call-args node block env) - (let ((2cont (continuation-info cont))) + (multiple-value-bind (fp nfp temps arg-locs) + (ir2-convert-local-call-args node block fun) + (let ((2cont (continuation-info cont)) + (env (environment-info (lambda-environment fun))) + (temp-refs (reference-tn-list temps nil))) (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown)) - (vop* multiple-call-local node block (fp nfp args) + (vop* multiple-call-local node block (fp nfp temp-refs) ((reference-tn-list (ir2-continuation-locs 2cont) t)) arg-locs env start) - (let ((temps (standard-result-tns cont))) + (let ((locs (standard-result-tns cont))) (vop* call-local node block - (fp nfp args) - ((reference-tn-list temps t)) - arg-locs env start (length temps)) - (move-continuation-result node block temps cont))))) + (fp nfp temp-refs) + ((reference-tn-list locs t)) + arg-locs env start (length locs)) + (move-continuation-result node block locs cont))))) (undefined-value)) @@ -817,15 +851,14 @@ ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (let* ((env (environment-info (lambda-environment fun))) - (start (block-label (node-block (lambda-bind fun)))) + (let* ((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)) + (ir2-convert-local-unknown-call node block fun cont start)) (:fixed - (ir2-convert-local-known-call node block env returns + (ir2-convert-local-known-call node block fun returns cont start))))))) (undefined-value)) @@ -1034,6 +1067,8 @@ ;;; -- Create frame ;;; -- Copy any more arg ;;; -- Set up the environment, accessing any closure variables +;;; -- Move args from the standard passing locations to their internal +;;; locations. ;;; (defun init-xep-environment (node block fun) (declare (type bind node) (type ir2-block block) (type clambda fun)) @@ -1042,7 +1077,7 @@ (when (and (optional-dispatch-p ef) (optional-dispatch-more-entry ef)) (vop copy-more-arg node block (optional-dispatch-max-args ef)))) - + (let ((env (environment-info (node-environment node)))) (if (ir2-environment-environment env) (let ((closure (make-normal-tn *any-primitive-type*))) @@ -1050,53 +1085,51 @@ (let ((n (1- system:%function-closure-variables-offset))) (dolist (loc (ir2-environment-environment env)) (vop closure-ref node block closure (incf n) (cdr loc))))) - (vop setup-environment node block))) + (vop setup-environment node block)) + + (unless (eq (functional-kind fun) :top-level) + (let ((vars (lambda-vars fun)) + (n 0)) + (when (leaf-refs (first vars)) + (emit-move node block (make-argument-count-location) + (leaf-info (first vars)))) + (dolist (arg (rest vars)) + (when (leaf-refs arg) + (let ((pass (standard-argument-location n)) + (home (leaf-info arg))) + (if (lambda-var-indirect arg) + (vop make-value-cell node block pass home) + (emit-move node block pass home)))) + (incf n)))) + + (emit-move node block (make-old-fp-passing-location t) + (ir2-environment-old-fp env))) (undefined-value)) ;;; IR2-Convert-Bind -- Internal ;;; -;;; Emit moves from the passing locations to the internal locations. This -;;; is only called on bind nodes for functions that allocate environments. All -;;; semantics of let calls are handled by IR2-Convert-Let. +;;; Emit function prolog code. This is only called on bind nodes for +;;; functions that allocate environments. All semantics of let calls are +;;; handled by IR2-Convert-Let. ;;; -;;; We special-case XEPs by calling Init-XEP-Environment before moving the -;;; arguments. Init-XEP-Environment accesses any environment values from the -;;; closure, so initialization of the environment from implicit arguments is -;;; suppressed. +;;; If not an XEP, all we do is move the return PC from its passing +;;; location, since in a local call, the caller allocates the frame and sets up +;;; the arguments. ;;; (defun ir2-convert-bind (node block) (declare (type bind node) (type ir2-block block)) (let* ((fun (bind-lambda node)) - (xep-p (external-entry-point-p fun)) - (env (environment-info (lambda-environment fun))) - (args (ir2-environment-arg-locs env))) + (env (environment-info (lambda-environment fun)))) (assert (member (functional-kind fun) '(nil :external :optional :top-level :cleanup))) - (when xep-p + (when (external-entry-point-p fun) (init-xep-environment node block fun)) - (dolist (arg (lambda-vars fun)) - (when (leaf-refs arg) - (let ((pass (pop args)) - (home (leaf-info arg))) - (if (lambda-var-indirect arg) - (vop make-value-cell node block pass home) - (emit-move node block pass home))))) - - (unless xep-p - (dolist (loc (ir2-environment-environment env)) - (emit-move node block (pop args) (cdr loc)))) - - (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) - (emit-move node block (ir2-environment-return-pc-pass env) - (ir2-environment-return-pc env))) + (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) @@ -1157,6 +1190,20 @@ (undefined-value)) + +;;;; Debugger hooks: + +;;; This is used by the debugger to find the top function on the stack. It +;;; returns the OLD-FP and RETURN-PC for the current function as multiple +;;; values. +;;; +(defoptimizer (kernel:%caller-frame-and-pc ir2-convert) (() node block) + (let ((env (environment-info (node-environment node)))) + (move-continuation-result node block + (list (ir2-environment-old-fp env) + (ir2-environment-return-pc env)) + (node-cont node)))) + ;;;; Multiple values: