Save interpreter result too before anything in continuation.

On x86, the interpreter call result register is eax/rax, register 0,
which is also the first register we hand out for register allocation.
The continuation for an interpreter call result uses register 0, but
if the caller uses a dynamic link, the continuation first pops its
frame via the dynamic link...using a temporary register that is
guaranteed to be register 0 since it's the first one the register
allocator hands out.  The code sequence looks something like this:

	;; (interpreter-call:cache-reference label-10 (register #x24) #f)
	(mov q (r 2) (r 1))
	(call (@ro 6 #xd0))
	;; (continuation-entry label-10)
	(word u #xfffc)
	(block-offset label-10)
label-10:
	;; (assign (register #x25) (post-increment (register 4) 1))
	(pop q (r 0))
	;; (assign (register #x26) (object->address (register #x25)))
	(and q (r 0) (r 5))
	;; (assign (offset (register 6) (machine-constant 4)) (register #x26))
	(mov q (@ro 6 #x20) (r 0))
	;; (assign (register #x23) (register 0))
	(jmp (@pcr label-13))

On entry to the continuation, register 0 holds the value we want,
chosen as a machine alias for pseudo-register #x23 in the procedure
body, but the first thing the continuation does is pop the dynamic
link into register 0, ruining the party.

This is rather tricky to trigger because it turns out in _non-error_
cases, compiled code never asks the interpreter to evaluate a cache
reference that will return a value.  But you can trigger this by
referencing an unassigned variable and invoking a restart, which does
cause the cache reference to return a value:

;; Unassigned, so compiled code will ask interpreter for help.
(define null)

;; Recursive procedure for which the compiler uses a dynamic link.
(define (map f l)
  (let loop ((l l))
    (if (pair? l)
        (cons (f (car l)) (loop (cdr l)))
        null)))

;; Invoke the restart that will return from the cache reference with
;; a value.
(bind-condition-handler (list condition-type:unassigned-variable)
    (lambda (condition)
      condition
      (use-value '()))
  (lambda ()
    (map + '(1 2 3))))
;Value: (1 2 3 . #[false 15 #xea9c18])

Here #[false 15 #xea9c18] is the (detagged) dynamic link, a pointer
into the stack, not the result we wanted at all.

diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm
index c589948a5c507d192c69526f8e3101c496ea29ee..6c937e0aad30b0acf3e1231e9bbe33e2e5acea21 100644 (file)
--- a/src/compiler/rtlgen/opncod.scm
+++ b/src/compiler/rtlgen/opncod.scm
@@ -311,43 +311,42 @@ USA.
                                              (length expressions)
                                              '() false false)))
                     (make-scfg (cfg-entry-node scfg) '()))
-                  (with-values
-                      (lambda ()
-                        (generate-continuation-entry
-                         (combination/context combination)))
-                    (lambda (label setup cleanup)
-                      (scfg-append!
-                       (generate-primitive primitive-name
-                                           (length expressions)
-                                           expressions setup label)
-                       cleanup
-                       (if error-finish
-                           (let ((temporary (rtl:make-pseudo-register)))
-                             (scfg*scfg->scfg!
-                              (rtl:make-assignment
-                               temporary
-                               (rtl:make-fetch register:value))
-                              (error-finish (rtl:make-fetch temporary))))
-                           (make-null-cfg)))
-                      #|
-                      ;; This code is preferable to the above
-                      ;; expression in some circumstances.  It
-                      ;; creates a continuation, but the continuation
-                      ;; is left dangling instead of being hooked
-                      ;; back into the subsequent code.  This avoids
-                      ;; a merge in the RTL and allows the CSE to do
-                      ;; a better job -- but the cost is that it
-                      ;; creates a continuation that, if invoked, has
-                      ;; unpredictable behavior.
-                      (let ((scfg
-                             (scfg*scfg->scfg!
-                              (generate-primitive primitive-name
-                                                  (length expressions)
-                                                  expressions setup label)
-                              cleanup)))
-                        (make-scfg (cfg-entry-node scfg) '()))
-                      |#
-                      )))))
+                  (let ((temporary (rtl:make-pseudo-register)))
+                    (with-values
+                        (lambda ()
+                          (generate-continuation-entry
+                           (combination/context combination)
+                           (rtl:make-assignment
+                            temporary
+                            (rtl:make-fetch register:value))))
+                      (lambda (label setup cleanup)
+                        (scfg-append!
+                         (generate-primitive primitive-name
+                                             (length expressions)
+                                             expressions setup label)
+                         cleanup
+                         (if error-finish
+                             (error-finish (rtl:make-fetch temporary))
+                             (make-null-cfg)))
+                        #|
+                        ;; This code is preferable to the above
+                        ;; expression in some circumstances.  It
+                        ;; creates a continuation, but the continuation
+                        ;; is left dangling instead of being hooked
+                        ;; back into the subsequent code.  This avoids
+                        ;; a merge in the RTL and allows the CSE to do
+                        ;; a better job -- but the cost is that it
+                        ;; creates a continuation that, if invoked, has
+                        ;; unpredictable behavior.
+                        (let ((scfg
+                               (scfg*scfg->scfg!
+                                (generate-primitive primitive-name
+                                                    (length expressions)
+                                                    expressions setup label)
+                                cleanup)))
+                          (make-scfg (cfg-entry-node scfg) '()))
+                        |#
+                        ))))))
          (let loop ((checks checks))
            (if (null? checks)
                non-error-cfg
@@ -1677,22 +1676,24 @@ USA.
        (let ((scfg (generate-primitive generic-op (length expressions) '()
                                        false false)))
          (make-scfg (cfg-entry-node scfg) '()))
-       (with-values
-           (lambda ()
-             (generate-continuation-entry (combination/context combination)))
-         (lambda (label setup cleanup)
-           (scfg-append!
-            (generate-primitive generic-op (length expressions)
-                                expressions setup label)
-            cleanup
-            (let ((temporary (rtl:make-pseudo-register)))
-              (scfg*scfg->scfg!
-               (rtl:make-assignment temporary (rtl:make-fetch register:value))
-               (if predicate?
-                   (finish (rtl:make-true-test (rtl:make-fetch temporary)))
-                   (expression-simplify-for-statement
-                    (rtl:make-fetch temporary)
-                    finish))))))))))
+       (let* ((temporary (rtl:make-pseudo-register))
+              (preamble
+               (rtl:make-assignment temporary
+                                    (rtl:make-fetch register:value))))
+         (with-values
+             (lambda ()
+               (generate-continuation-entry (combination/context combination)
+                                            preamble))
+           (lambda (label setup cleanup)
+             (scfg-append!
+              (generate-primitive generic-op (length expressions)
+                                  expressions setup label)
+              cleanup
+              (if predicate?
+                  (finish (rtl:make-true-test (rtl:make-fetch temporary)))
+                  (expression-simplify-for-statement
+                   (rtl:make-fetch temporary)
+                   finish)))))))))
 
 (define (generic->fixnum-op generic-op)
   (case generic-op

diff --git a/src/compiler/rtlgen/rgproc.scm b/src/compiler/rtlgen/rgproc.scm
index 4490875c527b080562d98e6f7c450e94f67efd90..923c3b69fe59b7b800ed5862a3a58c9cc7bb33ec 100644 (file)
--- a/src/compiler/rtlgen/rgproc.scm
+++ b/src/compiler/rtlgen/rgproc.scm
@@ -102,6 +102,7 @@ USA.
                (lambda (expression)
                  (wrap-with-continuation-entry
                   context
+                  (make-null-cfg)
                   (lambda (cont-label)
                     (rtl:make-interpreter-call:set!
                      cont-label

diff --git a/src/compiler/rtlgen/rgrval.scm b/src/compiler/rtlgen/rgrval.scm
index a144656f8af5d65ac103dee3afc531c618b882ce..5e9b314fdce665d1716908be3243ef1d6415953e 100644 (file)
--- a/src/compiler/rtlgen/rgrval.scm
+++ b/src/compiler/rtlgen/rgrval.scm
@@ -71,20 +71,24 @@ USA.
               (find-variable/value context lvalue
                 expression-value/simple
                 (lambda (environment name)
-                  (expression-value/temporary
-                   (load-temporary-register scfg*scfg->scfg! environment
-                     (lambda (environment)
-                       (wrap-with-continuation-entry
-                        context
-                        (lambda (cont-label)
-                          (rtl:make-interpreter-call:lookup
-                           cont-label
-                           environment
-                           (intern-scode-variable!
-                            (reference-context/block context)
-                            name)
-                           safe?)))))
-                   (rtl:interpreter-call-result:lookup)))
+                  (let ((temporary (rtl:make-pseudo-register)))
+                    (expression-value/temporary
+                     (load-temporary-register scfg*scfg->scfg! environment
+                       (lambda (environment)
+                         (wrap-with-continuation-entry
+                          context
+                          (rtl:make-assignment
+                           temporary
+                           (rtl:interpreter-call-result:lookup))
+                          (lambda (cont-label)
+                            (rtl:make-interpreter-call:lookup
+                             cont-label
+                             environment
+                             (intern-scode-variable!
+                              (reference-context/block context)
+                              name)
+                             safe?)))))
+                     (rtl:make-fetch temporary))))
                 (lambda (name)
                   (if (memq 'IGNORE-REFERENCE-TRAPS
                             (variable-declarations lvalue))
@@ -116,20 +120,22 @@ USA.
     (values
      (load-temporary-register scfg*scfg->scfg! (rtl:make-variable-cache name)
        (lambda (cell)
-        (let ((reference (rtl:make-fetch cell)))
+        (let ((reference (rtl:make-fetch cell))
+              (temporary (rtl:make-pseudo-register)))
           (let ((n2 (rtl:make-type-test (rtl:make-object->type reference)
                                         (ucode-type reference-trap)))
                 (n3 (rtl:make-assignment result reference))
                 (n4
                  (wrap-with-continuation-entry
                   context
+                  (rtl:make-assignment
+                   temporary
+                   (rtl:interpreter-call-result:cache-reference))
                   (lambda (cont-label)
                     (rtl:make-interpreter-call:cache-reference
                      cont-label cell safe?))))
                 (n5
-                 (rtl:make-assignment
-                  result
-                  (rtl:interpreter-call-result:cache-reference))))
+                 (rtl:make-assignment result (rtl:make-fetch temporary))))
             (pcfg-alternative-connect! n2 n3)
             (scfg-next-connect! n4 n5)
             (if safe?

diff --git a/src/compiler/rtlgen/rgstmt.scm b/src/compiler/rtlgen/rgstmt.scm
index 4c8910bbebb5c96951fea69e82a3d921d09e9d44..7b40656baf84051aa4f4907a9a4e61020a9022be 100644 (file)
--- a/src/compiler/rtlgen/rgstmt.scm
+++ b/src/compiler/rtlgen/rgstmt.scm
@@ -49,6 +49,7 @@ USA.
                      (lambda (expression)
                        (wrap-with-continuation-entry
                         context
+                        (make-null-cfg)
                         (lambda (cont-label)
                           (rtl:make-interpreter-call:set!
                            cont-label
@@ -82,6 +83,7 @@ USA.
                  (n5
                   (wrap-with-continuation-entry
                    context
+                   (make-null-cfg)
                    (lambda (cont-label)
                      (rtl:make-interpreter-call:cache-assignment
                       cont-label cell value))))
@@ -111,6 +113,7 @@ USA.
                  (lambda (expression)
                    (wrap-with-continuation-entry
                     context
+                    (make-null-cfg)
                     (lambda (cont-label)
                       (rtl:make-interpreter-call:define
                        cont-label
@@ -280,18 +283,21 @@ USA.
              (find-variable/value context lvalue
               rtl:make-unassigned-test
                (lambda (environment name)
-                 (scfg*pcfg->pcfg!
-                  (load-temporary-register scfg*scfg->scfg! environment
-                    (lambda (environment)
-                      (wrap-with-continuation-entry
-                       context
-                       (lambda (cont-label)
-                         (rtl:make-interpreter-call:unassigned?
-                          cont-label
-                          environment
-                          name)))))
-                  (rtl:make-true-test
-                   (rtl:interpreter-call-result:unassigned?))))
+                 (let ((temporary (rtl:make-pseudo-register)))
+                   (scfg*pcfg->pcfg!
+                    (load-temporary-register scfg*scfg->scfg! environment
+                      (lambda (environment)
+                        (wrap-with-continuation-entry
+                         context
+                         (rtl:make-assignment
+                          temporary
+                          (rtl:interpreter-call-result:unassigned?))
+                         (lambda (cont-label)
+                           (rtl:make-interpreter-call:unassigned?
+                            cont-label
+                            environment
+                            name)))))
+                    (rtl:make-true-test (rtl:make-fetch temporary)))))
                (lambda (name)
                  (generate/cached-unassigned? context name)))
              (generate/node consequent)
@@ -306,20 +312,23 @@ USA.
   (load-temporary-register scfg*pcfg->pcfg!
                           (rtl:make-variable-cache name)
     (lambda (cell)
-      (let ((reference (rtl:make-fetch cell)))
+      (let ((reference (rtl:make-fetch cell))
+           (temporary (rtl:make-pseudo-register)))
        (let ((n2 (rtl:make-type-test (rtl:make-object->type reference)
                                      (ucode-type reference-trap)))
              (n3 (rtl:make-unassigned-test reference))
              (n4
               (wrap-with-continuation-entry
                context
+               (rtl:make-assignment
+                temporary
+                (rtl:interpreter-call-result:cache-unassigned?))
                (lambda (cont-label)
                  (rtl:make-interpreter-call:cache-unassigned?
                   cont-label
                   cell))))
              (n5
-              (rtl:make-true-test
-               (rtl:interpreter-call-result:cache-unassigned?))))
+              (rtl:make-true-test (rtl:make-fetch temporary))))
          (pcfg-consequent-connect! n2 n3)
          (pcfg-alternative-connect! n3 n4)
          (scfg-next-connect! n4 n5)

diff --git a/src/compiler/rtlgen/rtlgen.scm b/src/compiler/rtlgen/rtlgen.scm
index d5a4dc5f6af95b6c9f74736ea88ab006f8e4d97b..8989a82ed12a00b7d2f935d0604d044f45d90b72 100644 (file)
--- a/src/compiler/rtlgen/rtlgen.scm
+++ b/src/compiler/rtlgen/rtlgen.scm
@@ -213,20 +213,21 @@ USA.
         (and (primitive-procedure? obj)
              (special-primitive-handler obj)))))
 
-(define (wrap-with-continuation-entry context scfg-gen)
-  (with-values (lambda () (generate-continuation-entry context))
+(define (wrap-with-continuation-entry context prefix scfg-gen)
+  (with-values (lambda () (generate-continuation-entry context prefix))
     (lambda (label setup cleanup)
       (scfg-append! setup
                    (scfg-gen label)
                    cleanup))))
 
-(define (generate-continuation-entry context)
+(define (generate-continuation-entry context prefix)
   (let ((label (generate-label))
        (closing-block (reference-context/block context)))
     (let ((setup (push-continuation-extra closing-block))
          (cleanup
-          (scfg*scfg->scfg!
+          (scfg-append!
            (rtl:make-continuation-entry label)
+           prefix
            (pop-continuation-extra closing-block))))
       (set! *extra-continuations*
            (cons (make-rtl-continuation

diff --git a/tests/compiler/test-vartrap.scm b/tests/compiler/test-vartrap.scm
index 05cfe32532fa7ff275b1115a9a7c835ad6798bc7..139c6c757dbe054b67f3a3f1f96980d1a6b025a7 100644 (file)
--- a/tests/compiler/test-vartrap.scm
+++ b/tests/compiler/test-vartrap.scm
@@ -49,16 +49,11 @@ USA.
            (scode (syntax&integrate program '() env))
            (expr (compile-scode scode))
            (map1 (eval expr env)))
-      (with-expected-failure
-          (if (memq microcode-id/compiled-code-type '(i386 x86-64))
-              expect-failure
-              #!default)
-        (lambda ()
-          (assert-equal
-           (bind-condition-handler (list condition-type:unassigned-variable)
-               (lambda (condition)
-                 condition
-                 (use-value '()))
-             (lambda ()
-               (map1 - '(1 2 3))))
-           '(-1 -2 -3)))))))
\ No newline at end of file
+      (assert-equal
+       (bind-condition-handler (list condition-type:unassigned-variable)
+           (lambda (condition)
+             condition
+             (use-value '()))
+         (lambda ()
+           (map1 - '(1 2 3))))
+       '(-1 -2 -3)))))