From fd7b4fe4c83e5e4be265cdcc1d1042f57c09ffad Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Wed, 2 Jan 2019 23:44:09 +0000 Subject: [PATCH] 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. --- src/compiler/rtlgen/opncod.scm | 107 ++++++++++++++++---------------- src/compiler/rtlgen/rgproc.scm | 1 + src/compiler/rtlgen/rgrval.scm | 42 +++++++------ src/compiler/rtlgen/rgstmt.scm | 39 +++++++----- src/compiler/rtlgen/rtlgen.scm | 9 +-- tests/compiler/test-vartrap.scm | 21 +++---- 6 files changed, 116 insertions(+), 103 deletions(-) diff --git a/src/compiler/rtlgen/opncod.scm b/src/compiler/rtlgen/opncod.scm index c589948a5..6c937e0aa 100644 --- 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 4490875c5..923c3b69f 100644 --- 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 a144656f8..5e9b314fd 100644 --- 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 4c8910bbe..7b40656ba 100644 --- 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 d5a4dc5f6..8989a82ed 100644 --- 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 05cfe3253..139c6c757 100644 --- 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))))) -- 2.25.1