From 9056d1de54b074c4c5b2925ff02f577cde33b13c Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 9 Feb 1990 10:59:19 +0000 Subject: [PATCH] Fixed the unwind case of %UNWIND-PROTECT to push a bogus values list on the stack to keep the MV-BIND in the UNWIND-PROTECT translation happy. Unlike in compiled code, we don't use these values to keep track of the exit being done, but we still execute the MV-BIND. Also, fixed SET-LEAF-VALUE to check for the var being indirect even when the reference is in the home env. Reordered the TYPECASE in INTERNAL-APPLY-LOOP according to my intuition of the relatively frequency of node types. --- compiler/eval.lisp | 77 +++++++++++++++++++++++++++------------------- 1 file changed, 45 insertions(+), 32 deletions(-) diff --git a/compiler/eval.lisp b/compiler/eval.lisp index 281c0d1e3..8ce02db68 100644 --- a/compiler/eval.lisp +++ b/compiler/eval.lisp @@ -521,6 +521,10 @@ ;; Fix up the interpreter's stack after having thrown here. ;; We won't need to do this in the final implementation. (eval-stack-set-top stack-top) + ;; + ;; Push some bogus values for exit context to keep the + ;; MV-BIND in the UNWIND-PROTECT translation happy. + (eval-stack-push '(nil nil 0)) (let ((node (c::continuation-next (c::block-start (car (c::block-succ @@ -747,36 +751,28 @@ (unless (eq info :unused) (value node info (leaf-value node frame-ptr closure) frame-ptr internal-apply-loop)))) + (c::combination + (maybe-trace-nodes node) + (combination-node :normal)) (c::cif (maybe-trace-nodes node) ;; IF nodes always occur at the end of a block, so pick another. (set-block (if (eval-stack-pop) (c::if-consequent node) (c::if-alternative node)))) - (c::cset - (maybe-trace-nodes node) - (let ((info (c::continuation-info cont)) - (res (set-leaf-value node frame-ptr closure - (eval-stack-pop)))) - (unless (eq info :unused) - (value node info res frame-ptr internal-apply-loop)))) - (c::mv-combination - (maybe-trace-nodes node) - (combination-node :mv-call)) - (c::combination - (maybe-trace-nodes node) - (combination-node :normal)) (c::bind (maybe-trace-nodes node) ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for ;; all of a lambda's locals, and the c::combination branch ;; handles LET binds (moving values off stack top into locals). ) - (c::creturn + (c::cset (maybe-trace-nodes node) - (let ((values (eval-stack-pop))) - (eval-stack-set-top frame-ptr) - (return-from internal-apply-loop (values-list values)))) + (let ((info (c::continuation-info cont)) + (res (set-leaf-value node frame-ptr closure + (eval-stack-pop)))) + (unless (eq info :unused) + (value node info res frame-ptr internal-apply-loop)))) (c::entry (maybe-trace-nodes node) (let ((info (cdr (assoc node (c:lambda-eval-info-entries @@ -866,7 +862,15 @@ :test #'eq)) (if incoming-values (values values (c::nlx-info-target info) nil cont) - (values :non-local-go (c::nlx-info-target info)))))))))) + (values :non-local-go (c::nlx-info-target info))))))))) + (c::creturn + (maybe-trace-nodes node) + (let ((values (eval-stack-pop))) + (eval-stack-set-top frame-ptr) + (return-from internal-apply-loop (values-list values)))) + (c::mv-combination + (maybe-trace-nodes node) + (combination-node :mv-call))) (cond ((not (eq cont last-cont)) (setf node (c::continuation-next cont))) ;; Currently only the last node in a block causes this loop to @@ -879,13 +883,15 @@ (change-blocks (car (c::block-succ block))))))) (eval-stack-set-top frame-ptr))) + ;;; SET-LEAF-VALUE -- Internal. ;;; -;;; This sets a c::cset node's var to value, returning value. -;;; When var is local, we have to compare its home environment to the current -;;; one, node's environment. If they're the same, store the value in the -;;; current stack frame. Otherwise, var is a closure variable, and since we're -;;; setting it, we know it's location contains an indirect value object. +;;; This sets a c::cset node's var to value, returning value. When var is +;;; local, we have to compare its home environment to the current one, node's +;;; environment. If they're the same, we check to see if the var is indirect, +;;; and store the value on the stack or in the value cell as appropriate. +;;; Otherwise, var is a closure variable, and since we're setting it, we know +;;; it's location contains an indirect value object. ;;; (defun set-leaf-value (node frame-ptr closure value) (let ((var (c::set-var node))) @@ -894,15 +900,22 @@ (setf (symbol-value (c::global-var-name var)) value)) (c::lambda-var (let ((env (c::node-environment node))) - (if (eq (c::lambda-environment (c::lambda-var-home var)) - env) - (setf (eval-stack-local frame-ptr (c::lambda-var-info var)) - value) - (setf (indirect-value - (svref closure - (position var (c::environment-closure env) - :test #'eq))) - value))))))) + (cond + ((not (eq (c::lambda-environment (c::lambda-var-home var)) + env)) + (setf (indirect-value + (svref closure + (position var (c::environment-closure env) + :test #'eq))) + value)) + ((c::lambda-var-indirect var) + (setf (indirect-value + (eval-stack-local frame-ptr (c::lambda-var-info var))) + value)) + (t + (setf (eval-stack-local frame-ptr (c::lambda-var-info var)) + value)))))))) + ;;; LEAF-VALUE -- Internal. ;;; -- GitLab