From e3c6e6dbeb1188e506fcc592b3115b2eb523dfb9 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 4 Nov 1988 10:28:39 +0000 Subject: [PATCH] Define new procedure `load-temporary-register' which abstracts the idea of loading a temporary with the value of some expression, and then using the temporary for something. This is important because of the timing problems associated with `rtl:make-assignment'. Most usages of the latter are now translated into usages of the new procedure. --- v7/src/compiler/rtlgen/opncod.scm | 163 +++++++++++++----------------- v7/src/compiler/rtlgen/rgcomb.scm | 59 +++++------ v7/src/compiler/rtlgen/rgretn.scm | 18 ++-- v7/src/compiler/rtlgen/rgrval.scm | 108 ++++++++++---------- v7/src/compiler/rtlgen/rgstmt.scm | 113 ++++++++++----------- 5 files changed, 218 insertions(+), 243 deletions(-) diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index da663b111..7307ea20c 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.16 1988/11/01 04:53:58 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.17 1988/11/04 10:28:18 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -144,12 +144,14 @@ MIT in each case. |# (generator expressions (lambda (pcfg) (let ((temporary (rtl:make-pseudo-register))) - (scfg*scfg->scfg! - (pcfg*scfg->scfg! - pcfg - (rtl:make-assignment temporary (rtl:make-constant true)) - (rtl:make-assignment temporary (rtl:make-constant false))) - (finish (rtl:make-fetch temporary))))))) + ;; Force assignment to be made first. + (let ((consequent + (rtl:make-assignment temporary (rtl:make-constant true))) + (alternative + (rtl:make-assignment temporary (rtl:make-constant false)))) + (scfg*scfg->scfg! + (pcfg*scfg->scfg! pcfg consequent alternative) + (finish (rtl:make-fetch temporary)))))))) (define (invoke/value->effect generator expressions) generator expressions @@ -291,30 +293,20 @@ MIT in each case. |# rtl)) (define (generate-primitive name arg-list continuation-label) - (let ((primitive (make-primitive-procedure name true))) - (let loop ((args arg-list) - (temps '() ) - (pushes '() )) - (if (null? args) - (scfg-append! - temps - (rtl:make-push-return continuation-label) - pushes - ((or (special-primitive-handler primitive) - rtl:make-invocation:primitive) - (1+ (length arg-list)) - continuation-label - primitive)) - (let ((temp (rtl:make-pseudo-register))) - (loop (cdr args) - (scfg*scfg->scfg! - (rtl:make-assignment - temp - (car args)) - temps) - (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch temp)) - pushes))))))) + (scfg*scfg->scfg! + (let loop ((args arg-list)) + (if (null? args) + (rtl:make-push-return continuation-label) + (load-temporary-register scfg*scfg->scfg! (car args) + (lambda (temporary) + (scfg*scfg->scfg! (loop (cdr args)) + (rtl:make-push temporary)))))) + (let ((primitive (make-primitive-procedure name true))) + ((or (special-primitive-handler primitive) + rtl:make-invocation:primitive) + (1+ (length arg-list)) + continuation-label + primitive)))) (define (generate-type-test type expression) (let ((mu-type (microcode-type type))) @@ -421,22 +413,20 @@ MIT in each case. |# (define/length '(STRING-LENGTH BIT-STRING-LENGTH) 1))) (define (generate-index-locative vector index finish) - (let ((temporary (rtl:make-pseudo-register))) - (scfg*scfg->scfg! - (rtl:make-assignment - temporary - (rtl:make-fixnum->address - (rtl:make-fixnum-2-args - 'PLUS-FIXNUM - (rtl:make-address->fixnum (rtl:make-object->address vector)) - (rtl:make-fixnum-2-args - 'MULTIPLY-FIXNUM - (rtl:make-object->fixnum - (rtl:make-constant - (quotient scheme-object-width - addressing-granularity))) - (rtl:make-object->fixnum index))))) - (finish (rtl:make-fetch temporary))))) + (load-temporary-register + scfg*scfg->scfg! + (rtl:make-fixnum->address + (rtl:make-fixnum-2-args + 'PLUS-FIXNUM + (rtl:make-address->fixnum (rtl:make-object->address vector)) + (rtl:make-fixnum-2-args + 'MULTIPLY-FIXNUM + (rtl:make-object->fixnum + (rtl:make-constant + (quotient scheme-object-width + addressing-granularity))) + (rtl:make-object->fixnum index)))) + finish)) (let* ((open-code/memory-ref (lambda (index) @@ -534,11 +524,10 @@ MIT in each case. |# (rtl:make-assignment locative (car (last-pair expressions))))) (if finish - (let ((temporary (rtl:make-pseudo-register))) - (scfg-append! - (rtl:make-assignment temporary (rtl:make-fetch locative)) - assignment - (finish (rtl:make-fetch temporary)))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-fetch locative) + (lambda (temporary) + (scfg*scfg->scfg! assignment (finish temporary)))) assignment))))) (open-code/vector-set (lambda (name) @@ -692,8 +681,7 @@ MIT in each case. |# (flo-op (generic->floatnum-op (rtl:generic-binary-operator expression))) (op1 (rtl:generic-binary-operand-1 expression)) - (op2 (rtl:generic-binary-operand-2 expression)) - (fix-temp (rtl:make-pseudo-register))) + (op2 (rtl:generic-binary-operand-2 expression))) (let* ((give-it-up (scfg-append! (generate-primitive @@ -757,18 +745,16 @@ MIT in each case. |# (generate-type-test 'fixnum op1) (pcfg*scfg->scfg! (generate-type-test 'fixnum op2) - (scfg*scfg->scfg! - (rtl:make-assignment - fix-temp - (rtl:make-fixnum-2-args - fix-op - (rtl:make-object->fixnum op1) - (rtl:make-object->fixnum op2))) - (pcfg*scfg->scfg! - (rtl:make-overflow-test) - give-it-up - (finish (rtl:make-fixnum->object - fix-temp)))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-fixnum-2-args + fix-op + (rtl:make-object->fixnum op1) + (rtl:make-object->fixnum op2)) + (lambda (fix-temp) + (pcfg*scfg->scfg! + (rtl:make-overflow-test) + give-it-up + (finish (rtl:make-fixnum->object fix-temp))))) generic-2) generic-1) (pcfg*scfg->scfg! @@ -791,8 +777,7 @@ MIT in each case. |# (rtl:generic-unary-operator expression))) (flo-op (generic->floatnum-op (rtl:generic-unary-operator expression))) - (op (rtl:generic-unary-operand expression)) - (fix-temp (rtl:make-pseudo-register))) + (op (rtl:generic-unary-operand expression))) (let* ((give-it-up (scfg-append! (generate-primitive @@ -820,17 +805,15 @@ MIT in each case. |# (not is-pred?)) (pcfg*scfg->scfg! (generate-type-test 'fixnum op) - (scfg*scfg->scfg! - (rtl:make-assignment - fix-temp - (rtl:make-fixnum-1-arg - fix-op - (rtl:make-object->fixnum op))) - (pcfg*scfg->scfg! - (rtl:make-overflow-test) - give-it-up - (finish (rtl:make-fixnum->object - fix-temp)))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-fixnum-1-arg + fix-op + (rtl:make-object->fixnum op)) + (lambda (fix-temp) + (pcfg*scfg->scfg! + (rtl:make-overflow-test) + give-it-up + (finish (rtl:make-fixnum->object fix-temp))))) (if compiler:open-code-flonum-checks? (pcfg*scfg->scfg! (generate-type-test 'flonum op) @@ -994,20 +977,20 @@ MIT in each case. |# (rtl:locative-byte-offset (car expressions) (+ string-header-size index))) (assignment - (rtl:make-assignment locative (rtl:make-char->ascii - (cadr expressions))))) + (rtl:make-assignment + locative + (rtl:make-char->ascii (cadr expressions))))) (if finish - (let ((temporary (rtl:make-pseudo-register))) - (scfg-append! - (rtl:make-assignment - temporary - (rtl:make-cons-pointer - (rtl:make-constant (ucode-type character)) - (rtl:make-fetch locative))) - assignment - (finish (rtl:make-fetch temporary)))) + (load-temporary-register + scfg*scfg->scfg! + (rtl:make-cons-pointer + (rtl:make-constant (ucode-type character)) + (rtl:make-fetch locative)) + (lambda (temporary) + (scfg*scfg->scfg! assignment (finish temporary)))) assignment))) '(0 2)))))) + ;;; End STRING operations, LET ) diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index f7578b25d..a4c84c706 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.7 1988/11/01 04:54:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.8 1988/11/04 10:28:27 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -201,36 +201,33 @@ MIT in each case. |# name))) (define (invocation/cache-reference offset frame-size continuation prefix name) - (let* ((temp (rtl:make-pseudo-register)) - (cell (rtl:make-fetch temp)) - (contents (rtl:make-fetch cell)) - (n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))) - ;; n1 MUST be bound before the rest. It flags temp as a - ;; register that contains an address. - (let ((n2 - (rtl:make-type-test (rtl:make-object->type contents) - (ucode-type reference-trap))) - (n3 - (scfg*scfg->scfg! - (rtl:make-push contents) - (invocation/apply* (1+ offset) - (1+ frame-size) - continuation - prefix))) - (n4 - (scfg*scfg->scfg! - (prefix offset frame-size) - (expression-simplify-for-statement cell - (lambda (cell) - (rtl:make-invocation:cache-reference (1+ frame-size) - continuation - cell)))))) - (scfg-next-connect! n1 n2) - (pcfg-consequent-connect! n2 n4) - (pcfg-alternative-connect! n2 n3) - (make-scfg (cfg-entry-node n1) - (hooks-union (scfg-next-hooks n3) - (scfg-next-hooks n4)))))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-variable-cache name) + (lambda (cell) + (let ((contents (rtl:make-fetch cell))) + (let ((n2 + (rtl:make-type-test (rtl:make-object->type contents) + (ucode-type reference-trap))) + (n3 + (scfg*scfg->scfg! + (rtl:make-push contents) + (invocation/apply* (1+ offset) + (1+ frame-size) + continuation + prefix))) + (n4 + (scfg*scfg->scfg! + (prefix offset frame-size) + (expression-simplify-for-statement cell + (lambda (cell) + (rtl:make-invocation:cache-reference (1+ frame-size) + continuation + cell)))))) + (pcfg-consequent-connect! n2 n4) + (pcfg-alternative-connect! n2 n3) + (make-scfg (cfg-entry-node n2) + (hooks-union (scfg-next-hooks n3) + (scfg-next-hooks n4)))))))) ;;; end INVOCATION/REFERENCE ) diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm index 98da40aad..a86c3487e 100644 --- a/v7/src/compiler/rtlgen/rgretn.scm +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.7 1988/08/29 23:14:17 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.8 1988/11/04 10:28:34 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -154,13 +154,15 @@ MIT in each case. |# (define (use-temporary-register operand offset prefix finish) (let ((register (rtl:make-pseudo-register))) - (scfg-append! - ((return-operand/value-generator operand) - offset - (lambda (expression) - (rtl:make-assignment register expression))) - prefix - (finish (rtl:make-fetch register))))) + (let ((setup-register + ((return-operand/value-generator operand) + offset + (lambda (expression) + (rtl:make-assignment register expression))))) + (scfg-append! + setup-register + prefix + (finish (rtl:make-fetch register)))))) (define (return-operator/pop-frames block operator offset extra) (let ((pop-extra diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index afc9bab5a..a5cae8642 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ d3 1 a4 1 -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.9 1988/11/02 21:46:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.10 1988/11/04 10:28:39 cph Exp $ #| -*-Scheme-*- Copyright (c) 1988 Massachusetts Institute of Technology -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.9 1988/11/02 21:46:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.10 1988/11/04 10:28:39 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -55,9 +55,11 @@ promotional, or sales literature without prior written consent from (return-2 (make-null-cfg) expression)) (define-integrable (expression-value/simple expression) - (let ((register (rtl:make-pseudo-register))) - (return-2 (scfg*scfg->scfg! prefix (rtl:make-assignment register result)) - (rtl:make-fetch register)))) + (values (make-null-cfg) expression)) + + (return-2 (scfg*scfg->scfg! prefix assignment) reference)) + (load-temporary-register + (lambda (assignment reference) (values (scfg*scfg->scfg! prefix assignment) reference)) #| (define-integrable (expression-value/transform expression-value transform) @@ -100,11 +102,9 @@ promotional, or sales literature without prior written consent from (lambda (name) (if (memq 'IGNORE-REFERENCE-TRAPS (variable-declarations lvalue)) - (let ((temp (rtl:make-pseudo-register))) - (return-2 - (rtl:make-assignment temp - (rtl:make-variable-cache name)) - (rtl:make-fetch (rtl:make-fetch temp)))) + (load-temporary-register return-2 + (rtl:make-variable-cache name) + rtl:make-fetch) (generate/cached-reference name safe?))))))) (cond ((not value) (perform-fetch)) lvalue)) @@ -114,42 +114,40 @@ promotional, or sales literature without prior written consent from (else (perform-fetch))))))) (define (generate/cached-reference name safe?) - (let ((temp (rtl:make-pseudo-register)) - (result (rtl:make-pseudo-register))) + (perform-fetch #| lvalue |#))))))) (return-2 - (let* ((cell (rtl:make-fetch temp)) - (reference (rtl:make-fetch cell)) - (n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))) - ;; n1 MUST be bound before the rest. It flags temp as a - ;; register that contains an address. - (let ((n2 (rtl:make-type-test (rtl:make-object->type reference) - (ucode-type reference-trap))) - (n3 (rtl:make-assignment result reference)) - (n4 (rtl:make-interpreter-call:cache-reference cell safe?)) - (n5 - (rtl:make-assignment - result - (rtl:interpreter-call-result:cache-reference)))) - (scfg-next-connect! n1 n2) - (pcfg-alternative-connect! n2 n3) - (scfg-next-connect! n4 n5) - (if safe? - (let ((n6 (rtl:make-unassigned-test reference)) - ;; Make new copy of n3 to keep CSE happy. - ;; Otherwise control merge will confuse it. - (n7 (rtl:make-assignment result reference))) - (pcfg-consequent-connect! n2 n6) - (pcfg-consequent-connect! n6 n7) - (pcfg-alternative-connect! n6 n4) - (make-scfg (cfg-entry-node n1) - (hooks-union (scfg-next-hooks n3) - (hooks-union (scfg-next-hooks n5) - (scfg-next-hooks n7))))) - (begin - (pcfg-consequent-connect! n2 n4) - (make-scfg (cfg-entry-node n1) - (hooks-union (scfg-next-hooks n3) - (scfg-next-hooks n5))))))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-variable-cache name) + (let ((result (rtl:make-pseudo-register))) + (values + (load-temporary-register scfg*scfg->scfg! (rtl:make-variable-cache name) + (lambda (cell) + (let ((reference (rtl:make-fetch cell))) + (n4 (rtl:make-interpreter-call:cache-reference cell safe?)) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:cache-reference cell safe?))) + (n5 + (rtl:make-assignment + result + (rtl:interpreter-call-result:cache-reference)))) + (pcfg-alternative-connect! n2 n3) + (scfg-next-connect! n4 n5) + (if safe? + (let ((n6 (rtl:make-unassigned-test reference)) + ;; Make new copy of n3 to keep CSE happy. + ;; Otherwise control merge will confuse it. + (n7 (rtl:make-assignment result reference))) + (pcfg-consequent-connect! n2 n6) + (pcfg-consequent-connect! n6 n7) + (pcfg-alternative-connect! n6 n4) + (make-scfg (cfg-entry-node n2) + (hooks-union + (scfg-next-hooks n3) + (hooks-union (scfg-next-hooks n5) + (scfg-next-hooks n7))))) + (begin + (pcfg-consequent-connect! n2 n4) (make-scfg (cfg-entry-node n2) (hooks-union (scfg-next-hooks n3) (scfg-next-hooks n5))))))))) @@ -159,16 +157,16 @@ promotional, or sales literature without prior written consent from (case (procedure/type procedure) (if (procedure/trivial-closure? procedure) (expression-value/simple (make-trivial-closure-cons procedure)) - (let ((register (rtl:make-pseudo-register))) - (return-2 - (scfg*scfg->scfg! - (make-non-trivial-closure-cons procedure) - (scfg*scfg->scfg! - (rtl:make-assignment register - (rtl:interpreter-call-result:enclose)) - (load-closure-environment procedure offset - (rtl:make-fetch register)))) - (rtl:make-fetch register))))) + (load-temporary-register + (lambda (assignment reference) + (return-2 + (scfg-append! + (make-non-trivial-closure-cons procedure) + assignment + (load-closure-environment procedure offset reference)) + reference)) + (rtl:interpreter-call-result:enclose) + identity-procedure))) (else (make-ic-cons procedure offset (lambda (scfg expr) (return-2 scfg expr)))) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index 6e6528749..051083c46 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.7 1988/11/02 21:45:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.8 1988/11/04 10:28:00 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -58,45 +58,32 @@ MIT in each case. |# (lambda (name) (if (memq 'IGNORE-ASSIGNMENT-TRAPS (variable-declarations lvalue)) - (let ((temp (rtl:make-pseudo-register))) - ;; This `let' forces order of evaluation. The - ;; fetch of `temp' depends on the fact that the - ;; assignment to `temp' marks it as containing a - ;; non-object, and thus prevents the generation - ;; of type stripping code here. - (let ((n1 - (rtl:make-assignment - temp - (rtl:make-assignment-cache name)))) - (scfg*scfg->scfg! - n1 - (rtl:make-assignment (rtl:make-fetch temp) - expression)))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-assignment-cache name) + (lambda (cell) + (rtl:make-assignment cell expression))) (generate/cached-assignment name expression))))))))) (define (generate/cached-assignment name value) - (let* ((temp (rtl:make-pseudo-register)) - (cell (rtl:make-fetch temp)) - (contents (rtl:make-fetch cell)) - (n1 (rtl:make-assignment temp (rtl:make-assignment-cache name)))) - ;; n1 MUST be bound before the rest. It flags temp as a - ;; register that contains an address. - (let ((n2 (rtl:make-type-test (rtl:make-object->type contents) - (ucode-type reference-trap))) - (n3 (rtl:make-unassigned-test contents)) - (n4 (rtl:make-assignment cell value)) - (n5 (rtl:make-interpreter-call:cache-assignment cell value)) - ;; Copy prevents premature control merge which confuses CSE - (n6 (rtl:make-assignment cell value))) - (scfg-next-connect! n1 n2) - (pcfg-consequent-connect! n2 n3) - (pcfg-alternative-connect! n2 n4) - (pcfg-consequent-connect! n3 n6) - (pcfg-alternative-connect! n3 n5) - (make-scfg (cfg-entry-node n1) - (hooks-union (scfg-next-hooks n4) - (hooks-union (scfg-next-hooks n5) - (scfg-next-hooks n6))))))) + (load-temporary-register scfg*scfg->scfg! + (rtl:make-assignment-cache name) + (lambda (cell) + (let ((contents (rtl:make-fetch cell))) + (let ((n2 (rtl:make-type-test (rtl:make-object->type contents) + (ucode-type reference-trap))) + (n3 (rtl:make-unassigned-test contents)) + (n4 (rtl:make-assignment cell value)) + (n5 (rtl:make-interpreter-call:cache-assignment cell value)) + ;; Copy prevents premature control merge which confuses CSE + (n6 (rtl:make-assignment cell value))) + (pcfg-consequent-connect! n2 n3) + (pcfg-alternative-connect! n2 n4) + (pcfg-consequent-connect! n3 n6) + (pcfg-alternative-connect! n3 n5) + (make-scfg (cfg-entry-node n2) + (hooks-union (scfg-next-hooks n4) + (hooks-union (scfg-next-hooks n5) + (scfg-next-hooks n6))))))))) (define (generate/definition definition) (let ((block (definition-block definition)) @@ -154,6 +141,17 @@ MIT in each case. |# (lambda (expression) (rtl:make-assignment register expression)))) +(define (load-temporary-register receiver expression generator) + (let ((temporary (rtl:make-pseudo-register))) + ;; Force assignment to be made before `generator' is called. This + ;; must be done because `rtl:make-assignment' examines + ;; `expression' and marks `temporary' with attributes that are + ;; required for proper code generation (for example, if the result + ;; of `expression' is not an object, this is recorded). Failure + ;; to obey this constraint can result in incorrect code. + (let ((setup (rtl:make-assignment temporary expression))) + (receiver setup (generator (rtl:make-fetch temporary)))))) + (define (generate/continuation-cons block continuation) block (let ((closing-block (continuation/closing-block continuation))) @@ -222,25 +220,22 @@ MIT in each case. |# (generate/node alternative)))))) (define (generate/cached-unassigned? name) - (let* ((temp (rtl:make-pseudo-register)) - (cell (rtl:make-fetch temp)) - (reference (rtl:make-fetch cell)) - (n1 (rtl:make-assignment temp (rtl:make-variable-cache name)))) - ;; n1 MUST be bound before the rest. It flags temp as a - ;; register that contains an address. - (let ((n2 (rtl:make-type-test (rtl:make-object->type reference) - (ucode-type reference-trap))) - (n3 (rtl:make-unassigned-test reference)) - (n4 (rtl:make-interpreter-call:cache-unassigned? cell)) - (n5 - (rtl:make-true-test - (rtl:interpreter-call-result:cache-unassigned?)))) - (scfg-next-connect! n1 n2) - (pcfg-consequent-connect! n2 n3) - (pcfg-alternative-connect! n3 n4) - (scfg-next-connect! n4 n5) - (make-pcfg (cfg-entry-node n1) - (hooks-union (pcfg-consequent-hooks n3) - (pcfg-consequent-hooks n5)) - (hooks-union (pcfg-alternative-hooks n2) - (pcfg-alternative-hooks n5)))))) \ No newline at end of file + (load-temporary-register scfg*pcfg->pcfg! + (rtl:make-variable-cache name) + (lambda (cell) + (let ((reference (rtl:make-fetch cell))) + (let ((n2 (rtl:make-type-test (rtl:make-object->type reference) + (ucode-type reference-trap))) + (n3 (rtl:make-unassigned-test reference)) + (n4 (rtl:make-interpreter-call:cache-unassigned? cell)) + (n5 + (rtl:make-true-test + (rtl:interpreter-call-result:cache-unassigned?)))) + (pcfg-consequent-connect! n2 n3) + (pcfg-alternative-connect! n3 n4) + (scfg-next-connect! n4 n5) + (make-pcfg (cfg-entry-node n2) + (hooks-union (pcfg-consequent-hooks n3) + (pcfg-consequent-hooks n5)) + (hooks-union (pcfg-alternative-hooks n2) + (pcfg-alternative-hooks n5)))))))) \ No newline at end of file -- 2.25.1