From ea580a2ed8f7f74a0483356302c16ed8b4ac176e Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 11 Dec 1991 17:12:33 +0000 Subject: [PATCH] Added conversion of :ASSIGNMENT lambdas. Updated stuff to know that NODE-TAIL-P is no longer a tail set. --- compiler/ir2tran.lisp | 57 +++++++++++++++++++++++++++++++------------ 1 file changed, 41 insertions(+), 16 deletions(-) diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp index 741a21549..c76307608 100644 --- a/compiler/ir2tran.lisp +++ b/compiler/ir2tran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.36 1991/11/27 19:24:58 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.37 1991/12/11 17:12:33 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -720,7 +720,6 @@ ;;; EMIT-PSETQ-MOVES -- Internal ;;; ;;; 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 @@ -728,9 +727,13 @@ ;;; implicit environment arguments, i.e. they exactly correspond to the ;;; arguments passed. ;;; +;;; OLD-FP is the TN currently holding the value we want to pass as OLD-FP. If +;;; null, then the call is to the same environment (an :ASSIGNMENT), so we +;;; only move the arguments, and leave the environment alone. +;;; (defun emit-psetq-moves (node block fun old-fp) (declare (type combination node) (type ir2-block block) (type clambda fun) - (type tn old-fp)) + (type (or tn null) old-fp)) (let* ((called-env (environment-info (lambda-environment fun))) (this-1env (node-environment node)) (actuals (mapcar #'(lambda (x) @@ -756,13 +759,14 @@ (t (temps actual))) (locs loc)))) - - (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)) + (when old-fp + (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))) (values (temps) (locs))))) @@ -794,6 +798,24 @@ (undefined-value)) +;;; IR2-CONVERT-ASSIGNMENT -- Internal +;;; +;;; Convert an :ASSIGNMENT call. This is just like a tail local call, +;;; except that the caller and callee environment are the same, so we don't +;;; need to mess with the environment locations, return PC, etc. +;;; +(defun ir2-convert-assignment (node block fun) + (declare (type combination node) (type ir2-block block) (type clambda fun)) + (multiple-value-bind + (temps locs) + (emit-psetq-moves node block fun nil) + + (mapc #'(lambda (temp loc) + (emit-move node block temp loc)) + temps locs)) + (undefined-value)) + + ;;; IR2-CONVERT-LOCAL-CALL-ARGS -- Internal ;;; ;;; Do stuff to set up the arguments to a non-tail local call (including @@ -878,16 +900,18 @@ ;;; (defun ir2-convert-local-call (node block) (declare (type combination node) (type ir2-block block)) - (let ((fun (ref-leaf (continuation-use (basic-combination-fun node))))) - (cond ((eq (functional-kind fun) :let) + (let* ((fun (ref-leaf (continuation-use (basic-combination-fun node)))) + (kind (functional-kind fun))) + (cond ((eq kind :let) (ir2-convert-let node block fun)) + ((eq kind :assignment) + (ir2-convert-assignment node block fun)) ((node-tail-p node) (ir2-convert-tail-local-call node block fun)) (t - (let* ((start (block-label (node-block (lambda-bind fun)))) - (tails (lambda-tail-set fun)) - (returns (when tails (tail-set-info tails))) - (cont (node-cont node))) + (let ((start (block-label (node-block (lambda-bind fun)))) + (returns (tail-set-info (lambda-tail-set fun))) + (cont (node-cont node))) (ecase (if returns (return-info-kind returns) :unknown) @@ -1288,7 +1312,8 @@ (assert (basic-combination-args node)) (let* ((start-cont (continuation-info (first (basic-combination-args node)))) (start (first (ir2-continuation-locs start-cont))) - (tails (node-tail-p node)) + (tails (and (node-tail-p node) + (lambda-tail-set (node-home-lambda node)))) (cont (node-cont node)) (2cont (continuation-info cont))) (multiple-value-bind -- GitLab