Skip to content
Browse files ir2tran: Correctly set up d-x closure values for tail-loca…


  * Tail-local-call re-uses the current frame.  It therefore needs to
use the old-fp value from the current frame in EMIT-PSETQ-MOVES.

  * "implicit" value cells need to use the /current/ frame pointer in
EMIT-PSETQ-MOVES to correctly initialize the closure.

  * Therefore: Add a new &optional argument to EMIT-PSETQ-MOVES for
the frame-pointer to be used in closure initialization.

  * This fixes the obvious part of lp#681092, but unless there is a
guarantee that the stack slots used for the "implicit" value cells
remain unused in the tail-called function then all this does is drive
the bug to become more subtle.
  • Loading branch information...
1 parent c4776b3 commit 818b7d2a5f74a4fd379b269c345f8301fbeb1b36 Alastair Bridgewater committed Nov 27, 2010
Showing with 19 additions and 6 deletions.
  1. +18 −5 src/compiler/ir2tran.lisp
  2. +1 −1 version.lisp-expr
23 src/compiler/ir2tran.lisp
@@ -783,9 +783,15 @@
;;; 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)
+;;; CLOSURE-FP is for calling a closure that has "implicit" value
+;;; cells (stored in the allocating stack frame), and is the frame
+;;; pointer TN to use for values allocated in the outbound stack
+;;; frame. This is distinct from OLD-FP for the specific case of a
+;;; tail-local-call.
+(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp))
(declare (type combination node) (type ir2-block block) (type clambda fun)
- (type (or tn null) old-fp))
+ (type (or tn null) old-fp closure-fp))
(let ((actuals (mapcar (lambda (x)
(when x
(lvar-tn node block x)))
@@ -815,7 +821,7 @@
(let ((this-1env (node-physenv node))
(called-env (physenv-info (lambda-physenv fun))))
(dolist (thing (ir2-physenv-closure called-env))
- (temps (closure-initial-value (car thing) this-1env old-fp))
+ (temps (closure-initial-value (car thing) this-1env closure-fp))
(locs (cdr thing)))
(temps old-fp)
(locs (ir2-physenv-old-fp called-env))))
@@ -828,9 +834,16 @@
;;; 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 (physenv-info (node-physenv node))))
+ (let ((this-env (physenv-info (node-physenv node)))
+ (current-fp (make-stack-pointer-tn)))
(multiple-value-bind (temps locs)
- (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
+ (emit-psetq-moves node block fun
+ (ir2-physenv-old-fp this-env) current-fp)
+ ;; If we're about to emit a move from CURRENT-FP then we need to
+ ;; initialize it.
+ (when (find current-fp temps)
+ (vop current-fp node block current-fp))
(mapc (lambda (temp loc)
(emit-move node block temp loc))
2 version.lisp-expr
@@ -20,4 +20,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

0 comments on commit 818b7d2

Please sign in to comment.
Something went wrong with that request. Please try again.