From: Stephen Adams Date: Tue, 30 Jul 1996 19:29:57 +0000 (+0000) Subject: Typerew uses checking operations (e.g. CAR with type checks enabled, X-Git-Tag: 20090517-FFI~5408 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fe422a513bd2597a3f26b95df422c757b679df92;p=mit-scheme.git Typerew uses checking operations (e.g. CAR with type checks enabled, or explicit calls to ERROR:WRONG-TYPE-ARGUMENT, etc) to deduce type information about values in the program. The assumption is that the error signalling code never returns. This set of changes makes these operations bulletproof by arranging that the continuations of the error signalling procedures cannot resume the code that was compiled under the types deduced from the assumption. The error continuations now `trap' by jumping to an appropriate handler. fakeprim.scm New operator %halt. New operator %reference. errcont.scm Edits a program to replace continuations to error procedures (which typically merge back with the non-error case) with continuations that just call %halt. laterew.scm Eliminate %reference. rtlgen.scm Recognise continuations containing %halt and produce terse code to `trap' to the appropriate support procedure. simplify.scm Tweak to LETREC case for recognizing dead procedures earlier. This allows `diamond' code to be linearized in one pass rather than two. typerew.scm Changed to generate code to signal errors calling global procedure %COMPILED-CODE-SUPPORT:SIGNAL-ERROR-IN-PRIMITIVE --- diff --git a/v8/src/compiler/machines/spectrum/compiler.pkg b/v8/src/compiler/machines/spectrum/compiler.pkg index 2b5536c21..46d667975 100644 --- a/v8/src/compiler/machines/spectrum/compiler.pkg +++ b/v8/src/compiler/machines/spectrum/compiler.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: compiler.pkg,v 1.17 1996/07/23 14:57:24 adams Exp $ +$Id: compiler.pkg,v 1.18 1996/07/30 19:29:48 adams Exp $ Copyright (c) 1988-1995 Massachusetts Institute of Technology @@ -560,6 +560,7 @@ MIT in each case. |# "midend/typerew" "midend/lamlift" "midend/closconv" + "midend/errcont" ;; "midend/staticfy" ; broken, for now "midend/applicat" "midend/simplify" diff --git a/v8/src/compiler/machines/spectrum/decls.scm b/v8/src/compiler/machines/spectrum/decls.scm index 9407ef577..6e85ef9d8 100644 --- a/v8/src/compiler/machines/spectrum/decls.scm +++ b/v8/src/compiler/machines/spectrum/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: decls.scm,v 1.8 1996/03/14 18:51:17 adams Exp $ +$Id: decls.scm,v 1.9 1996/07/30 19:29:57 adams Exp $ Copyright (c) 1988-1994 Massachusetts Institute of Technology @@ -350,7 +350,8 @@ MIT in each case. |# (filename/append "midend" "alpha" "applicat" "assconv" "cleanup" "closconv" "compat" "copier" "cpsconv" - "coerce" "types" "typedb" "effects" "typerew" + "coerce" "types" "typedb" "effects" "errcont" + "typerew" "dataflow" "dbgstr" "dbgred" "debug" "earlyrew" "envconv" "expand" "fakeprim" "graph" "inlate" "kmp" "lamlift" "laterew" @@ -501,7 +502,7 @@ MIT in each case. |# ;; "alpha" "applicat" "assconv" "cleanup" ;; "closconv" "compat" "copier" "cpsconv" ;; "dataflow" "dbgstr" "debug" "earlyrew" - ;; "envconv" "expand" "graph" + ;; "envconv" "expand" "errcont" "graph" ;; "inlate" "lamlift" "laterew" ;; "load" "midend" "rtlgen" "simplify" ;; "split" "stackopt" "staticfy" "synutl" diff --git a/v8/src/compiler/midend/closconv.scm b/v8/src/compiler/midend/closconv.scm index 2407841fd..4799434a2 100644 --- a/v8/src/compiler/midend/closconv.scm +++ b/v8/src/compiler/midend/closconv.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: closconv.scm,v 1.10 1995/08/06 19:50:08 adams Exp $ +$Id: closconv.scm,v 1.11 1996/07/30 19:25:51 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -46,7 +46,10 @@ MIT in each case. |# (lambda () (let* ((env (closconv/env/%make 'STATIC false)) (program* (closconv/expr env (lifter/letrecify program)))) - (closconv/analyze! env program*))))) + (closconv/analyze! env program*) + (if after-cps? + (errcont/rewrite program*)) + program*)))) (define-macro (define-closure-converter keyword bindings . body) (let ((proc-name (symbol-append 'CLOSCONV/ keyword))) diff --git a/v8/src/compiler/midend/errcont.scm b/v8/src/compiler/midend/errcont.scm index ccea2f836..99a268494 100644 --- a/v8/src/compiler/midend/errcont.scm +++ b/v8/src/compiler/midend/errcont.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: errcont.scm,v 1.1 1996/07/30 19:00:42 adams Exp $ +$Id: errcont.scm,v 1.2 1996/07/30 19:24:42 adams Exp $ Copyright (c) 1996 Massachusetts Institute of Technology @@ -125,9 +125,11 @@ MIT in each case. |# 'ok) ((call/%stack-closure-ref? cont) ;; we could generate a new continuation with the same stack frame - ;; format as the extand frame. This would give us better dbg info. - ;; Another way to do this is to explicitly code the error case as - ;; a sequence. + ;; format as the extant frame. This would give us better + ;; dbg info, at the cost of a continuation and the call + ;; it contains. (Another way to achieve this + ;; continuation is to explicitly code the error case as a + ;; sequence. (sample/1 '(errcont/%stack-closure-ref count) 1) 'ok) ((form/match pattern cont) diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm index 0a922864d..4de06f0c3 100644 --- a/v8/src/compiler/midend/fakeprim.scm +++ b/v8/src/compiler/midend/fakeprim.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fakeprim.scm,v 1.27 1996/07/20 22:57:13 adams Exp $ +$Id: fakeprim.scm,v 1.28 1996/07/30 19:25:25 adams Exp $ Copyright (c) 1994-96 Massachusetts Institute of Technology @@ -39,8 +39,7 @@ MIT in each case. |# ;;;; Pseudo primitives -(define *operator-properties* - (make-eq-hash-table)) +(define *operator-properties* (make-eq-hash-table)) (define (define-operator-properties rator properties) (hash-table/put! *operator-properties* rator properties)) @@ -80,7 +79,31 @@ MIT in each case. |# (define (make-operator/simple* name . more) (apply make-operator name '(SIMPLE) more)) + +(define (make-operator/out-of-line name . more) + (apply make-operator name + '(SIDE-EFFECT-INSENSITIVE) + '(SIDE-EFFECT-FREE) + '(OUT-OF-LINE-HOOK) + more)) + +;; By using DEFINE-OPERATOR rather than DEFINE, we get integration of the +;; operator tokens: +(define-macro (define-operator op spec) + (if (and (list? spec) + (>= (length spec) 2) + (memq (first spec) + '(MAKE-OPERATOR ; all variants above + MAKE-OPERATOR/SIMPLE MAKE-OPERATOR/EFFECT-SENSITIVE + MAKE-OPERATOR/SIMPLE* MAKE-OPERATOR/OUT-OF-LINE)) + (string? (second spec))) + `(BEGIN + ,spec + (DEFINE-INTEGRABLE ,op ',(string->symbol (second spec)))) + `(DEFINE ,op ,spec))) +;; COOKIE-CALL generates a predicate and accessors to a CALL +;; expression based on a pattern matching the call expression (define-macro (cookie-call name . parts) (define (->string x) (if (symbol? x) (symbol-name x) x)) @@ -136,7 +159,7 @@ MIT in each case. |# `(BEGIN ,(make-predicate) ,@(reverse (loop parts `(CDDR FORM) '())))) -(define %*lookup +(define-operator %*lookup ;; (CALL ',%*lookup ;; 'VARIABLE-NAME 'DEPTH 'OFFSET) ;; Note: @@ -148,7 +171,7 @@ MIT in each case. |# ;;(cookie-call %*lookup cont environment 'variable-name 'depth 'offset) -(define %*set! +(define-operator %*set! ;; (CALL ',%*set! ;; 'VARIABLE-NAME 'DEPTH 'OFFSET) ;; Note: @@ -159,7 +182,7 @@ MIT in each case. |# ;;(cookie-call %*set! cont environment 'VARIABLE-NAME value 'DEPTH 'OFFSET) -(define %*unassigned? +(define-operator %*unassigned? ;; (CALL ',%*unassigned? ;; 'VARIABLE-NAME 'DEPTH 'OFFSET) ;; Note: @@ -172,7 +195,7 @@ MIT in each case. |# ;;(cookie-call %*unassigned? cont environment 'variable-name 'depth 'offset) -(define %*define +(define-operator %*define ;; (CALL ',%*define ;; 'VARIABLE-NAME ) ;; Note: @@ -183,7 +206,7 @@ MIT in each case. |# (cookie-call %*define cont environment 'VARIABLE-NAME value) -(define %*define* +(define-operator %*define* ;; (CALL ',%*define* ;; ) ;; Note: @@ -194,7 +217,7 @@ MIT in each case. |# (cookie-call %*define* cont environment 'names-vector 'values-vector) -(define %*make-environment +(define-operator %*make-environment ;; (CALL ',%*make-environment ;; *) ;; Note: @@ -214,7 +237,7 @@ MIT in each case. |# ;; substituted or reordered, hence they are not defined as ;; effect-insensitive or effect-free -(define %fetch-environment +(define-operator %fetch-environment ;; (CALL ',%fetch-environment '#F) ;; Note: ;; Introduced by envconv.scm, open coded by RTL generator. @@ -224,7 +247,7 @@ MIT in each case. |# (cookie-call %fetch-environment '#F) -(define %make-operator-variable-cache +(define-operator %make-operator-variable-cache ;; (CALL ',%make-operator-variable-cache '#F ;; 'NAME 'NARGS) ;; Note: @@ -237,7 +260,7 @@ MIT in each case. |# (cookie-call %make-operator-variable-cache '#F environment 'NAME 'NARGS) -(define %make-remote-operator-variable-cache +(define-operator %make-remote-operator-variable-cache ;; (CALL ',%make-remote-operator-variable-cache '#F ;; 'PACKAGE-DESCRIPTOR 'NAME 'NARGS) ;; Note: @@ -254,7 +277,7 @@ MIT in each case. |# (cookie-call %make-remote-operator-variable-cache '#F 'PACKAGE-DESCRIPTOR 'NAME 'NARGS) -(define %make-read-variable-cache +(define-operator %make-read-variable-cache ;; (CALL ',%make-read-variable-cache '#F 'NAME) ;; Note: ;; Introduced by envconv.scm, ignored by RTL generator. @@ -266,7 +289,7 @@ MIT in each case. |# (cookie-call %make-read-variable-cache '#F environment 'NAME) -(define %make-write-variable-cache +(define-operator %make-write-variable-cache ;; (CALL ',%make-write-variable-cache '#F 'NAME) ;; Note: ;; Introduced by envconv.scm, ignored by RTL generator. @@ -279,7 +302,7 @@ MIT in each case. |# (cookie-call %make-write-variable-cache '#F environment 'NAME) -(define %invoke-operator-cache +(define-operator %invoke-operator-cache ;; (CALL ',%invoke-operator-cache ;; '(NAME NARGS) *) ;; Note: @@ -293,7 +316,7 @@ MIT in each case. |# (cookie-call %invoke-operator-cache cont 'descriptor operator-cache #!rest values) -(define %invoke-remote-cache +(define-operator %invoke-remote-cache ;; (CALL ',%invoke-remote-cache ;; '(NAME NARGS) *) ;; Note: @@ -309,7 +332,7 @@ MIT in each case. |# (cookie-call %invoke-remote-cache cont 'descriptor operator-cache #!rest values) -(define %variable-cache-ref +(define-operator %variable-cache-ref ;; (CALL %variable-cache-ref '#F 'ignore-traps? 'NAME) ;; Note: ;; Introduced by envconv.scm, removed by compat.scm (replaced by a @@ -321,7 +344,7 @@ MIT in each case. |# (cookie-call %variable-cache-ref '#F read-variable-cache 'IGNORE-TRAPS? 'NAME) -(define %variable-cache-set! +(define-operator %variable-cache-set! ;; (CALL ',%variable-cache-set! '#F ;; 'IGNORE-TRAPS? 'NAME) ;; Note: @@ -333,7 +356,7 @@ MIT in each case. |# (cookie-call %variable-cache-set! '#F write-variable-cache value 'IGNORE-TRAPS? 'NAME) -(define %safe-variable-cache-ref +(define-operator %safe-variable-cache-ref ;; (CALL ',%safe-variable-cache-ref '#F ;; 'IGNORE-TRAPS? 'NAME) ;; Note: @@ -348,7 +371,7 @@ MIT in each case. |# (cookie-call %safe-variable-cache-ref '#F read-variable-cache 'IGNORE-TRAPS? 'NAME) -(define %variable-read-cache +(define-operator %variable-read-cache ;; (CALL ',%variable-read-cache '#F 'NAME) ;; Note: ;; Introduced by compat.scm as part of rewriting @@ -359,7 +382,7 @@ MIT in each case. |# (cookie-call %variable-read-cache '#F read-variable-cache 'NAME) -(define %variable-write-cache +(define-operator %variable-write-cache ;; (CALL ',%variable-write-cache '#F 'NAME) ;; Note: ;; Introduced by compat.scm as part of rewriting @@ -370,7 +393,7 @@ MIT in each case. |# (cookie-call %variable-write-cache '#F write-variable-cache 'NAME) -(define %variable-cell-ref +(define-operator %variable-cell-ref ;; (CALL ',%variable-cell-ref '#F ) ;; Note: ;; Introduced by compat.scm as part of rewriting @@ -381,7 +404,7 @@ MIT in each case. |# (cookie-call %variable-cell-ref '#F read-variable-cache) -(define %variable-cell-set! +(define-operator %variable-cell-set! ;; (CALL ',%variable-cell-ref '#F ) ;; Note: ;; Introduced by compat.scm as part of rewriting @@ -391,7 +414,7 @@ MIT in each case. |# (cookie-call %variable-cell-set! '#F write-variable-cache value) -(define %hook-variable-cell-ref +(define-operator %hook-variable-cell-ref ;; (CALL ',%hook-variable-cell-ref ;; ) ;; Note: @@ -409,7 +432,7 @@ MIT in each case. |# (cookie-call %hook-variable-cell-ref cont read-variable-cache) -(define %hook-safe-variable-cell-ref +(define-operator %hook-safe-variable-cell-ref ;; (CALL ',%hook-safe-variable-cell-ref ;; ) ;; Note: @@ -426,7 +449,7 @@ MIT in each case. |# (cookie-call %hook-safe-variable-cell-ref cont read-variable-cache) -(define %hook-variable-cell-set! +(define-operator %hook-variable-cell-set! ;; (CALL ',%hook-safe-variable-cell-set! '#F ;; ) ;; Note: @@ -441,7 +464,7 @@ MIT in each case. |# (cookie-call %hook-variable-cell-set! '#F write-variable-cache value) -(define %copy-program +(define-operator %copy-program ;; (CALL ',%copy-program ) ;; Note: ;; Introduced by envconv.scm and removed by compat.scm (replaced @@ -462,7 +485,7 @@ MIT in each case. |# (cookie-call %copy-program cont program) -(define %execute +(define-operator %execute ;; (CALL ',%execute ) ;; Note: ;; Introduced by envconv.scm and removed by compat.scm (replaced @@ -475,7 +498,7 @@ MIT in each case. |# (cookie-call %execute cont program environment) -(define %internal-apply +(define-operator %internal-apply ;; (CALL ',%internal-apply 'NARGS *) ;; Note: ;; NARGS = number of expressions @@ -484,7 +507,7 @@ MIT in each case. |# (cookie-call %internal-apply cont 'NARGS procedure #!REST values) -(define %internal-apply-unchecked +(define-operator %internal-apply-unchecked ;; (CALL ',%internal-apply-unchecked 'NARGS ;; *) ;; Note: @@ -494,7 +517,7 @@ MIT in each case. |# (make-operator "#[internal-apply-unchecked]")) (cookie-call %internal-apply-unchecked cont 'NARGS procedure #!REST values) -(define %primitive-apply +(define-operator %primitive-apply ;; (CALL ',%primitive-apply ;; 'NARGS ' *) ;; Note: @@ -502,21 +525,30 @@ MIT in each case. |# ;; Introduced by applicat.scm and removed by compat.scm (replaced ;; by %PRIMITIVE-APPLY/COMPATIBLE). (make-operator "#[primitive-apply]")) - (cookie-call %primitive-apply cont 'NARGS 'primitive-object #!rest values) + + +(define %primitive-apply/compatible + ;; (CALL ',%primitive-apply/compatible '#F 'NARGS + ;; ') + ;; Call a primitive with arguments on the stack + ;; Note: + ;; Introduced by compat.scm from %primitive-apply + (make-operator "#[primitive-apply 2]")) +(cookie-call %primitive-apply/compatible '#F 'NARG primitive-object) -(define %arity-dispatcher-tag +(define-operator %arity-dispatcher-tag (make-constant "#[(microcode)arity-dispatcher-tag]")) -(define %unspecific +(define-operator %unspecific ;; Magic cookie representing an ignorable value (make-constant "#[unspecific]")) -(define %unassigned +(define-operator %unassigned ;; The value of variables that do not yet have values ... (make-constant "#[unassigned]")) -(define %unassigned? +(define-operator %unassigned? ;; (CALL ',%unassigned? '#F ) ;; Note: ;; Introduced by envconv.scm and expand.scm from the MIT Scheme @@ -526,7 +558,7 @@ MIT in each case. |# (cookie-call %unassigned? '#F value) -(define %reference-trap? +(define-operator %reference-trap? ;; (CALL ',%reference-trap? '#F ) ;; Note: ;; Introduced by compat.scm as part of the rewrite of @@ -536,44 +568,29 @@ MIT in each case. |# (cookie-call %reference-trap? '#F value) -(define %primitive-error - ;; (CALL ',%primitive-error '#F ' .. - ;; ... - ;; Call with ... to signal an error. +(define-operator %halt + ;; (CALL ',%halt 'code) + ;; This marks a piece of code that should never be executed. Valid + ;; only as the body of a continuations. + ;; Note: + ;; . Introduced by errcont (called from closconv/2) + ;; . RTLGEN should recognize this expression and generate either + ;; - a continuation to which the runtime system will refuse to return + ;; - a continuation which traps or signals an error if invoked. + (make-operator "#[halt]")) + +(define-operator %reference + ;; (CALL ',%reference '#F ...) + ;; For control over debugging info. + ;; This is a dummy statement which causes references to be kept through + ;; optimizations, for example, lambda-lifting. ;; Note: - ;; Introduced at any stage that we know that will fail, for - ;; example, when replacing a primitive by a checked - ;; (if ) - ;; diamond. The are the arguments to the primitive (N is - ;; determined from the primitive's arity) that cause it to fail. - ;; - ;; The additional expressions are inserted to keep data live to enhance - ;; debugging information (at the cost of keeping it live, both in - ;; compile time, compiled code performance, and GC opportunities). - ;; For example, we may choose to introduce this code and/or insert - ;; the expressions as follows: - ;; . Add the containing procedure's full set of parameters before - ;; lambda-lifting/1. This may force procedures to be - ;; implemented as closures. - ;; . After lambda-lifting/1. This gives us everything that can be made - ;; available without creating extra closures. The cost is - ;; keeping extra values in the stack. - ;; . After lambda-lifting/2 (same as not at all). This gives us - ;; everything that would be available in fully optimized code. - ;; - ;; This operation may be implemented in two ways: restartable and - ;; non-restartable (perhaps we will introduce another operator to - ;; distinguish the two). If restartable, we need a hook to call - ;; arbitrary primitives with preservation. If non-restartable we - ;; need a space-efficient method of constructing a continuation - ;; and passing the arguments, and some work on rtlgen to make it - ;; understand expressions that never terminate (i.e. to construct - ;; a non-diamond rgraph), and some work on conpar and dbg-info to - ;; understand the continuation, and some work on uerror to - ;; understand that restarts are not an option. - (make-operator "#[primitive-error]")) - -(define %cons + ;; Introduced anywhere (nowhere at present) + ;; Removed by laterew. + (make-operator "#[reference]")) + + +(define-operator %cons ;; (CALL ',%cons '#F ) ;; Open-coded CONS operation. ;; Note: @@ -586,29 +603,29 @@ MIT in each case. |# ;; Unchecked operations on pairs. Result is unspecified if the pair ;; argument is not a pair. -(define %car +(define-operator %car ;; (CALL ',%car '#F ) (make-operator/effect-sensitive "#[car]")) -(define %cdr +(define-operator %cdr ;; (CALL ',%cdr '#F ) (make-operator/effect-sensitive "#[cdr]")) -(define %set-car! +(define-operator %set-car! ;; (CALL ',%set-car '#F ) (make-operator/simple* "#[set-car!]" '(UNSPECIFIC-RESULT))) -(define %set-cdr! +(define-operator %set-cdr! ;; (CALL ',%set-cdr '#F ) (make-operator/simple* "#[set-cdr!]" '(UNSPECIFIC-RESULT))) -(define %make-entity +(define-operator %make-entity ;; (CALL ',%make-entity '#F ) (make-operator/simple "#[make-entity]")) -(define %vector +(define-operator %vector ;; (CALL ',%vector '#F *) ;; Open-coded version of VECTOR primitive. ;; Note: @@ -617,23 +634,23 @@ MIT in each case. |# (cookie-call %vector '#F #!rest values) -(define %vector-length +(define-operator %vector-length ;; (CALL ',%vector-length '#F ) ;; Unchecked. (make-operator/simple "#[vector-length]")) -(define %vector-ref +(define-operator %vector-ref ;; (CALL ',%vector-ref '#F ) ;; Unchecked. (make-operator/effect-sensitive "#[vector-ref]")) -(define %vector-set! +(define-operator %vector-set! ;; (CALL ',%vector-set! '#F ) ;; Unchecked. (make-operator/simple* "#[vector-set!]" '(UNSPECIFIC-RESULT))) -(define %generic-index-check/ref +(define-operator %generic-index-check/ref ;; (CALL ',%generic-index-check '#F ;; '#( )) ;; Generic type & range check. @@ -641,7 +658,7 @@ MIT in each case. |# ;; and 0 <= < ( ) (make-operator/simple "#[generic-index-check/ref]" '(PROPER-PREDICATE))) -(define %generic-index-check/set! +(define-operator %generic-index-check/set! ;; (CALL ',%generic-index-check '#F ;; '#( )) ;; Generic type & range check. @@ -651,27 +668,27 @@ MIT in each case. |# (make-operator/simple "#[generic-index-check/set!]" '(PROPER-PREDICATE))) -(define %%record-length (make-operator/simple "#[%record-length]")) -(define %%record-ref (make-operator/effect-sensitive "#[%record-ref]")) -(define %%record-set! +(define-operator %%record-length (make-operator/simple "#[%record-length]")) +(define-operator %%record-ref (make-operator/effect-sensitive "#[%record-ref]")) +(define-operator %%record-set! (make-operator/simple* "#[%record-set!]" '(UNSPECIFIC-RESULT))) -(define %string-length (make-operator/effect-sensitive "#[string-length]")) -(define %string-ref (make-operator/effect-sensitive "#[string-ref]")) -(define %string-set! +(define-operator %string-length (make-operator/effect-sensitive "#[string-length]")) +(define-operator %string-ref (make-operator/effect-sensitive "#[string-ref]")) +(define-operator %string-set! (make-operator/simple* "#[string-set!]" '(UNSPECIFIC-RESULT))) -(define %vector-8b-ref (make-operator/effect-sensitive "#[vector-8b-ref]")) -(define %vector-8b-set! +(define-operator %vector-8b-ref (make-operator/effect-sensitive "#[vector-8b-ref]")) +(define-operator %vector-8b-set! (make-operator/simple* "#[vector-8b-set!]" '(UNSPECIFIC-RESULT))) -(define %floating-vector-length +(define-operator %floating-vector-length (make-operator/simple "#[floating-vector-length]")) -(define %floating-vector-ref +(define-operator %floating-vector-ref (make-operator/effect-sensitive "#[floating-vector-ref]")) -(define %floating-vector-set! +(define-operator %floating-vector-set! (make-operator/simple* "#[floating-vector-set!]" '(UNSPECIFIC-RESULT))) -(define %bit-string-length (make-operator/simple "#[bit-string-length]")) +(define-operator %bit-string-length (make-operator/simple "#[bit-string-length]")) ;;(define %vector-ref/check ;; ;; (CALL ',%vector-ref/check '#F ) @@ -691,24 +708,24 @@ MIT in each case. |# ;; (make-operator/simple* "#[vector-set/check!]" '(UNSPECIFIC-RESULT))) -(define %make-promise +(define-operator %make-promise ;; (CALL ',%make-promise '#F ) ;; Note: ;; Introduced by expand.scm for DELAY (make-operator/simple "#[make-promise]")) (cookie-call %make-promise '#F thunk) -(define %make-cell +(define-operator %make-cell ;; (CALL ',%make-cell '#F 'NAME) (make-operator/simple "#[make-cell]")) (cookie-call %make-cell '#F value 'NAME) -(define %cell-ref +(define-operator %cell-ref ;; (CALL ',%cell-ref '#F 'NAME) (make-operator/effect-sensitive "#[cell-ref]")) (cookie-call %cell-ref '#F cell 'NAME) -(define %cell-set! +(define-operator %cell-set! ;; (CALL ',%cell-set '#F 'NAME) ;; Note: ;; Returns no value, because the rewrite is to something like @@ -724,40 +741,40 @@ MIT in each case. |# ;; Multicells are introduced by assconv.scm for references to local ;; mutable variables. -(define %make-multicell +(define-operator %make-multicell ;; (CALL ',%make-multicell '#F 'LAYOUT ...) (make-operator/simple "#[make-multicell]")) ;;(cookie-call %make-multicell '#F 'LAYOUT #!rest values) -(define %multicell-ref +(define-operator %multicell-ref ;; (CALL ',%multicell-ref '#F cell 'LAYOUT 'NAME) (make-operator/effect-sensitive "#[multicell-ref]")) (cookie-call %multicell-ref '#F cell 'LAYOUT 'NAME) -(define %multicell-set! +(define-operator %multicell-set! ;; (CALL ',%multicell-set! '#F cell value 'LAYOUT 'NAME) ;; Note: ;; Always used in statement position - has no value. (make-operator/simple* "#[multicell-set!]" '(UNSPECIFIC-RESULT))) ;;(cookie-call %multicell-set! '#F cell value 'LAYOUT 'NAME) -(define %flo:make-multicell +(define-operator %flo:make-multicell ;; (CALL ',%flo:make-multicell '#F 'LAYOUT ...) (make-operator/simple "#[flo:make-multicell]")) -(define %flo:multicell-ref +(define-operator %flo:multicell-ref ;; (CALL ',%flo:multicell-ref '#F cell 'LAYOUT 'NAME) (make-operator/effect-sensitive "#[flo:multicell-ref]" '(RESULT-TYPE FLONUM))) (cookie-call %flo:multicell-ref '#F cell 'LAYOUT 'NAME) -(define %flo:multicell-set! +(define-operator %flo:multicell-set! ;; (CALL ',%flo:multicell-set! '#F cell value 'LAYOUT 'NAME) ;; Note: ;; Always used in statement position - has no value. (make-operator/simple* "#[flo:multicell-set!]" '(UNSPECIFIC-RESULT))) -(define %fixnum->flonum +(define-operator %fixnum->flonum ;; (CALL ',%fixnum->flonum '#F fixnum) ;; Convert a fixnum into a flonum. (make-operator/simple "#[fixnum->flonum]" '(RESULT-TYPE FLONUM))) @@ -768,12 +785,12 @@ MIT in each case. |# ;; that they can be introduced to collect values together without ;; committing to a representation. -(define %make-tuple +(define-operator %make-tuple ;; (CALL ',%make-tuple '#F 'LAYOUT ...) (make-operator/simple "#[make-tuple]")) ;;(cookie-call %make-tuple '#F 'LAYOUT #!rest values) -(define %tuple-ref +(define-operator %tuple-ref ;; (CALL ',%tuple-ref '#F cell 'LAYOUT 'NAME) (make-operator/simple "#[tuple-ref]")) ;;(cookie-call %tuple-ref '#F tuple 'LAYOUT 'NAME) @@ -794,7 +811,7 @@ MIT in each case. |# ;; properly simple, but they can be considered such because %heap-closure-set!, ;; %make-stack-closure, and %static-binding-set! are used only in limited ways. -(define %make-heap-closure +(define-operator %make-heap-closure ;; (CALL ',%make-heap-closure '#F 'VECTOR ;; *) ;; Note: @@ -805,19 +822,19 @@ MIT in each case. |# (cookie-call %make-heap-closure '#F lambda-expression 'VECTOR #!rest values) -(define %heap-closure-ref +(define-operator %heap-closure-ref ;; (CALL ',%heap-closure-ref '#F 'NAME) ;; Note: ;; Introduced by closconv.scm (first time it is invoked) (make-operator/simple "#[heap-closure-ref]")) (cookie-call %heap-closure-ref '#F closure offset 'NAME) -(define %heap-closure-set! +(define-operator %heap-closure-set! ;; (CALL ',%heap-closure-set! '#F 'NAME) (make-operator/simple* "#[heap-closure-set!]" '(UNSPECIFIC-RESULT))) (cookie-call %heap-closure-set! '#F closure offset value 'NAME) -(define %make-trivial-closure +(define-operator %make-trivial-closure ;; (CALL ',%make-trivial-closure '#F ) ;; Note: ;; Introduced by closconv.scm (first time it is invoked). @@ -831,7 +848,7 @@ MIT in each case. |# (make-operator/simple "#[make-trivial-closure]")) (cookie-call %make-trivial-closure '#F procedure) -(define %make-static-binding +(define-operator %make-static-binding ;; (CALL ',%make-static-binding '#F 'NAME) ;; Note: ;; Generate a static binding cell for NAME, containing . @@ -839,21 +856,21 @@ MIT in each case. |# (make-operator/simple "#[make-static-binding]")) (cookie-call %make-static-binding '#F value 'NAME) -(define %static-binding-ref +(define-operator %static-binding-ref ;; (CALL ',%static-binding-ref '#F 'NAME) ;; Note: ;; Introduced by staticfy.scm (not currently working). (make-operator/simple "#[static-binding-ref]")) (cookie-call %static-binding-ref '#F static-cell 'NAME) -(define %static-binding-set! +(define-operator %static-binding-set! ;; (CALL ',%static-binding-set! '#F 'NAME) ;; Note: ;; Introduced by staticfy.scm (not currently working). (make-operator/simple* "#[static-binding-set!]" '(UNSPECIFIC-RESULT))) (cookie-call %static-binding-set! '#F static-cell value 'NAME) -(define %make-return-address +(define-operator %make-return-address ;; (CALL ',%make-return-address '#F ) ;; Note: ;; Used internally in rtlgen.scm when performing trivial rewrites @@ -864,7 +881,7 @@ MIT in each case. |# ;; %fetch-continuation is not static, but things get confused otherwise ;; It is handled specially by lamlift and closconv -(define %fetch-continuation +(define-operator %fetch-continuation ;; (CALL ',%fetch-continuation '#F) ;; Note: ;; Grab return address, for use in top-level expressions since they @@ -873,14 +890,14 @@ MIT in each case. |# (make-operator/simple* "#[fetch-continuation]" '(STATIC))) (cookie-call %fetch-continuation '#F) -(define %invoke-continuation +(define-operator %invoke-continuation ;; (CALL ',%invoke-continuation *) ;; Note: ;; Introduced by cpsconv.scm (make-operator "#[invoke-continuation]")) (cookie-call %invoke-continuation cont #!rest values) -(define %fetch-stack-closure +(define-operator %fetch-stack-closure ;; (CALL ',%fetch-stack-closure '#F 'VECTOR) ;; Note: ;; VECTOR contains symbols only. @@ -891,7 +908,7 @@ MIT in each case. |# (make-operator/simple* "#[fetch-stack-closure]")) (cookie-call %fetch-stack-closure '#F 'VECTOR) -(define %make-stack-closure +(define-operator %make-stack-closure ;; (CALL ',%make-stack-closure '#F ;; 'VECTOR *) ;; Note: @@ -907,7 +924,7 @@ MIT in each case. |# (make-operator/simple "#[make-stack-closure]")) (cookie-call %make-stack-closure '#F lambda-expression 'VECTOR #!rest values) -(define %stack-closure-ref +(define-operator %stack-closure-ref ;; (CALL ',%stack-closure-ref '#F 'NAME) ;; Note: ;; Introduced by closconv.scm. @@ -915,7 +932,7 @@ MIT in each case. |# (make-operator/simple "#[stack-closure-ref]")) (cookie-call %stack-closure-ref '#F closure offset 'NAME) -(define %small-fixnum? +(define-operator %small-fixnum? ;; (CALL ',%small-fixnum? '#F 'FIXNUM) ;; Note: ;; #T iff is a fixnum on the target machine and all of top @@ -930,16 +947,16 @@ MIT in each case. |# (cookie-call %small-fixnum? '#F value 'precision-bits) -(define %word-less-than-unsigned? +(define-operator %word-less-than-unsigned? ;; (CALL ', %word-less-than-unsigned? '#F (make-operator/simple "#[word-less-than-unsigned?]" '(PROPER-PREDICATE))) -(define %compiled-entry? +(define-operator %compiled-entry? (make-operator/simple "#[compiled-entry?]" '(PROPER-PREDICATE))) (cookie-call %compiled-entry? '#F object) -(define %compiled-entry-maximum-arity? +(define-operator %compiled-entry-maximum-arity? ;; (call ',%compiled-entry-maximum-arity? '#F 'count value) ;; Tests if the compiled entry has the specified maximum arity. (make-operator/simple "#[compiled-entry-maximum-arity?]" @@ -947,20 +964,13 @@ MIT in each case. |# (cookie-call %compiled-entry-maximum-arity? '#F 'n entry) -(define %profile-data +(define-operator %profile-data ;; (CALL ',%profile-data '#F ') (make-operator/simple* "#[profile-data]" '(UNSPECIFIC-RESULT))) (cookie-call %profile-data '#F 'data) -(define (make-operator/out-of-line name . more) - (apply make-operator name - '(SIDE-EFFECT-INSENSITIVE) - '(SIDE-EFFECT-FREE) - '(OUT-OF-LINE-HOOK) - more)) - ;; The following operations are used as: ;; (CALL ', ) ;; Note: @@ -970,19 +980,19 @@ MIT in each case. |# ;; need to save state, but the operation should tail call into the ;; continuation. -(define %+ (make-operator/out-of-line "#[+]")) -(define %- (make-operator/out-of-line "#[-]")) -(define %* (make-operator/out-of-line "#[*]")) -(define %/ (make-operator/out-of-line "#[/]")) -(define %quotient (make-operator/out-of-line "#[quotient]")) -(define %remainder (make-operator/out-of-line "#[remainder]")) -(define %= (make-operator/out-of-line "#[=]" '(PROPER-PREDICATE))) -(define %< (make-operator/out-of-line "#[<]" '(PROPER-PREDICATE))) -(define %> (make-operator/out-of-line "#[>]" '(PROPER-PREDICATE))) +(define-operator %+ (make-operator/out-of-line "#[+]")) +(define-operator %- (make-operator/out-of-line "#[-]")) +(define-operator %* (make-operator/out-of-line "#[*]")) +(define-operator %/ (make-operator/out-of-line "#[/]")) +(define-operator %quotient (make-operator/out-of-line "#[quotient]")) +(define-operator %remainder (make-operator/out-of-line "#[remainder]")) +(define-operator %= (make-operator/out-of-line "#[=]" '(PROPER-PREDICATE))) +(define-operator %< (make-operator/out-of-line "#[<]" '(PROPER-PREDICATE))) +(define-operator %> (make-operator/out-of-line "#[>]" '(PROPER-PREDICATE))) (define *vector-cons-max-open-coded-length* 5) -(define %vector-cons +(define-operator %vector-cons ;; (CALL ',%vector-cons ) ;; Note: ;; If the continuation is #F then the code generator is responsible @@ -997,7 +1007,7 @@ MIT in each case. |# (define *string-allocate-max-open-coded-length* 4000) (define *floating-vector-cons-max-open-coded-length* 500) -(define %string-allocate +(define-operator %string-allocate ;; (CALL ',%string-allocate ) ;; Note: ;; If the continuation is #F then the code generator is responsible @@ -1007,7 +1017,7 @@ MIT in each case. |# ;; continuation. (make-operator/out-of-line "#[string-allocate]")) -(define %floating-vector-cons +(define-operator %floating-vector-cons ;; (CALL ',%floating-vector-cons ) ;; Note: ;; If the continuation is #F then the code generator is responsible @@ -1163,77 +1173,3 @@ MIT in each case. |# '(SIDE-EFFECT-FREE) '(SIDE-EFFECT-INSENSITIVE))))) '(COERCE-TO-COMPILED-PROCEDURE)) - -;;(for-each -;; (lambda (prim-name) -;; (let ((prim (make-primitive-procedure prim-name))) -;; (set! compiler:primitives-with-no-open-coding -;; (cons prim-name compiler:primitives-with-no-open-coding)))) -;; '(VECTOR-REF VECTOR-SET! CAR CDR)) - -;;;; Compatibility operators - -(define %primitive-apply/compatible - ;; (CALL ',%primitive-apply/compatible '#F 'NARGS - ;; ') - ;; Note: - ;; Introduced by compat.scm from %primitive-apply - (make-operator "#[primitive-apply 2]")) -(cookie-call %primitive-apply/compatible '#F 'NARG primitive-object) - -;;; Operators for calling procedures, with a description of the calling -;; convention. -;; -;; Note these have not been implemented but please leave them here for -;; when we come back to passing unboxed floats. - -(define %call/convention - ;; (CALL ',%call/convention ) - ;; Note: - ;; Introduced by compat.scm from CALL - (make-operator "#[call/convention]")) - -(define %invoke-operator-cache/convention - ;; (CALL ',%invoke-operator-cache/convention - ;; '(NAME NARGS) *) - ;; Note: - ;; Introduced by compat.scm from %invoke-operator-cache - (make-operator "#[invoke-operator-cache/convention]")) - -(define %invoke-remote-cache/convention - ;; (CALL ',%invoke-remote-cache/convention - ;; '(NAME NARGS) *) - ;; Note: - ;; Introduced by compat.scm from %invoke-remote-cache - (make-operator "#[invoke-remote-cache/convention]")) - -(define %internal-apply/convention - ;; (CALL ',%interna-apply/convention - ;; 'NARGS *) - ;; Note: - ;; Introduced by compat.scm from %internal-apply - (make-operator "#[internal-apply/convention]")) - -(define %primitive-apply/convention - ;; (CALL ',%primitive-apply/convention - ;; 'NARGS ' *) - ;; Note: - ;; Introduced by compat.scm from %primitive-apply - (make-operator "#[primitive-apply/convention]")) - -(define %invoke-continuation/convention - ;; (CALL ',%invoke-continuation/convention - ;; *) - ;; Note: - ;; Introduced by compat.scm from %invoke-continuation - (make-operator "#[invoke-continuation/convention]")) - -(define %fetch-parameter-frame - ;; (CALL ',%fetch-parameter-frame '#F ) - ;; Note: - ;; This is supposed to return an accessor for local parameters. - ;; In fact, rtlgen.scm knows about this special case and generates - ;; no output code. It is used to set an initial model of how - ;; parameters are passed in to a procedure, so it must appear - ;; immediately after the parameter list for a LAMBDA expression. - (make-operator "#[fetch-parameter-frame]")) diff --git a/v8/src/compiler/midend/laterew.scm b/v8/src/compiler/midend/laterew.scm index d4351436d..1fe15308b 100644 --- a/v8/src/compiler/midend/laterew.scm +++ b/v8/src/compiler/midend/laterew.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: laterew.scm,v 1.20 1996/07/24 23:42:04 adams Exp $ +$Id: laterew.scm,v 1.21 1996/07/30 19:26:06 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -32,8 +32,12 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; Late generic arithmetic rewrite +;;;; LATEREW ;;; package: (compiler midend) +;; +;; Late (post CPS and closure conversion) rewrites, including some +;; generic arithmetic. +;; (declare (usual-integrations)) @@ -391,6 +395,11 @@ MIT in each case. |# `(QUOTE ,#F))) (else (search (cdr rands))))) (default))) + +(define-rewrite/late %reference + (lambda (form rands) + rands ; ignored + `(QUOTE ,form))) (define-rewrite/late %make-multicell (lambda (form rands) diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm index f5df969b5..b3e4f53f8 100644 --- a/v8/src/compiler/midend/rtlgen.scm +++ b/v8/src/compiler/midend/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rtlgen.scm,v 1.49 1996/07/26 23:43:03 adams Exp $ +$Id: rtlgen.scm,v 1.50 1996/07/30 19:25:12 adams Exp $ Copyright (c) 1994-96 Massachusetts Institute of Technology @@ -317,6 +317,7 @@ MIT in each case. |# (lambda () (internal-error "continuation without stack frame" lam-expr)))) +#| (define (rtlgen/%body-with-stack-references label dbg-form lam-expr self-arg? wrap no-stack-refs) (sample/1 '(rtlgen/formals-per-lambda histogram vector) @@ -342,6 +343,59 @@ MIT in each case. |# (rtlgen/initial-state lambda-list self-arg? frame-vector body)))))))) (else (no-stack-refs)))) +|# + +;; This version recognizes continuation bodies containing calls to %halt. +;; This means that the continuation should never be called. +;; Currently, these continuations are compiled to calls to the global +;; 1-argument procedure named in the %halt literal operand. The +;; procedure must signal an error. This device is a platform +;; independent way of issuing a `trap' instruction. The procedure +;; receives the continuation's (first) argument. The continuation for +;; the call is the current continuation (which has already been set +;; up), which is essentially free to compute and gives good debugging +;; information by, in effect, causing an infine trapping loop. + +(define (rtlgen/%body-with-stack-references + label dbg-form lam-expr self-arg? wrap no-stack-refs) + (sample/1 '(rtlgen/formals-per-lambda histogram vector) + (lambda-list/count-names (lambda/formals lam-expr))) + + (let ((result (form/match rtlgen/continuation-pattern lam-expr))) + (if result + (let ((lambda-list (cadr (assq rtlgen/?lambda-list result))) + (frame-vector (cadr (assq rtlgen/?frame-vector result))) + (body (cadr (assq rtlgen/?continuation-body result)))) + (let* ((frame-size (vector-length frame-vector)) + (saved-size (- frame-size + (rtlgen/->number-of-args-on-stack + lambda-list frame-vector))) + (error-continuation? + (and (CALL/? body) + (QUOTE/? (call/operator body)) + (eq? %halt (quote/text (call/operator body)))))) + (sample/1 '(rtlgen/frame-size histogram) frame-size) + (fluid-let ((*rtlgen/frame-size* frame-size)) + + (if error-continuation? + + (rtlgen/with-body-state + (lambda () + (let ((trap-procedure (quote/text (call/operand1 body)))) + (rtlgen/quick&dirty/forbid-interrupt-check! dbg-form) + (wrap label dbg-form + `((INVOCATION:GLOBAL-LINK 2 ,label + ,trap-procedure)) + lambda-list saved-size)))) + + (rtlgen/body + body + (lambda (body*) + (wrap label dbg-form body* lambda-list saved-size)) + (lambda () + (rtlgen/initial-state lambda-list self-arg? + frame-vector body))))))) + (no-stack-refs)))) (define (rtlgen/initial-state params self-arg? frame-vector body) ;; . PARAMS is a lambda list @@ -597,7 +651,7 @@ MIT in each case. |# (define *rtlgen/form-calls-internal?*) (define *rtlgen/form-returns?*) -(define (rtlgen/body form wrap gen-state) +(define (rtlgen/with-body-state thunk) (fluid-let ((*rtlgen/next-rtl-pseudo-register* 0) (*rtlgen/pseudo-registers* '()) (*rtlgen/pseudo-register-values* '()) @@ -608,10 +662,17 @@ MIT in each case. |# (*rtlgen/form-calls-internal?* false) (*rtlgen/form-calls-external?* false) (*rtlgen/form-returns?* false)) - (rtlgen/stmt (gen-state) form) - (rtlgen/renumber-pseudo-registers! - (rtlgen/first-pseudo-register-number)) - (wrap (queue/contents *rtlgen/statements*)))) + (thunk))) + + +(define (rtlgen/body form wrap gen-state) + (rtlgen/with-body-state + (lambda () + (rtlgen/stmt (gen-state) form) + (rtlgen/renumber-pseudo-registers! + (rtlgen/first-pseudo-register-number)) + (wrap (queue/contents *rtlgen/statements*))))) + (define (rtlgen/wrap-with-interrupt-check/expression body desc) ;; *** For now, this does not check interrupts. @@ -727,6 +788,7 @@ MIT in each case. |# (let ((orig-depth *rtlgen/stack-depth*) (orig-heap *rtlgen/words-allocated*) (orig-values *rtlgen/pseudo-register-values*)) + orig-values (gen1) (if merge-label (rtlgen/emit!/1 `(JUMP ,merge-label))) @@ -1774,7 +1836,8 @@ MIT in each case. |# cont (cddr rands))) ; exprs ((eq? rator* %invoke-remote-cache) - (set! *rtlgen/form-calls-external?* true) + (if (not (rtlgen/global-call-not-worth-interrupt-check? (first rands))) + (set! *rtlgen/form-calls-external?* true)) (rtlgen/invoke-operator-cache state 'INVOCATION:GLOBAL-LINK (first rands) ; name+nargs @@ -4113,6 +4176,7 @@ MIT in each case. |# (define-open-coder/stmt %heap-closure-set! 4 (let ((offset (rtlgen/closure-first-offset)) (closure-tag (machine-tag 'COMPILED-ENTRY))) + closure-tag (lambda (state rands open-coder) open-coder ; ignored (let ((vector (rtlgen/vector-constant? (second rands))) @@ -4372,9 +4436,29 @@ MIT in each case. |# #| ;; Missing: -'SET-INTERRUPT-ENABLES! |# +(define (call/%stack-closure-ref/unparse expr receiver) + (let ((vector (CALL/%stack-closure-ref/offset expr)) + (name (CALL/%stack-closure-ref/name expr))) + (if (and (QUOTE/? vector) + (QUOTE/? name)) + (let ((v (quote/text vector)) + (n (quote/text name))) + (if (and (vector? v) (symbol? n)) + (receiver v n)))))) + +(define (CALL/%stack-closure-ref/index expr) + (call/%stack-closure-ref/unparse expr vector-index)) + +(define (CALL/%stack-closure-ref/index=? expr value) + (call/%stack-closure-ref/unparse + expr + (lambda (v n) + (and (vector? v) + (< -1 value (vector-length v)) + (eq? (vector-ref v value) n))))) + ;;;; Patterns (define rtlgen/?lambda-list (->pattern-variable 'LAMBDA-LIST)) @@ -4470,7 +4554,6 @@ MIT in each case. |# (QUOTE ,rtlgen/?frame-vector*) ,rtlgen/?return-address ,@rtlgen/?closure-elts*))) - ;; Kludges @@ -4485,6 +4568,18 @@ MIT in each case. |# (lambda (primitive) (memq primitive apply-like-primitives)))) +(define (rtlgen/global-call-not-worth-interrupt-check? name+arity) + ;; Some global procedures are known to the compiler and not worth an + ;; interrupt check because we know that there cannot be a loop + ;; without interrupt checks between that procedure and this one. + (memq (first (quote/text name+arity)) + '(%COMPILED-CODE-SUPPORT:SIGNAL-ERROR-IN-PRIMITIVE + %COMPILED-CODE-SUPPORT:NONRESTARTABLE-CONTINUATION + COERCE-TO-COMPILED-PROCEDURE + ERROR:BAD-RANGE-ARGUMENT + ERROR:WRONG-NUMBER-OF-ARGUMENTS + ERROR:DATUM-OUT-OF-RANGE))) + (define *rtlgen/omit-internal-interrupt-checks?* #T) (define (rtlgen/omit-interrupt-check? procedure-name) @@ -4522,27 +4617,6 @@ MIT in each case. |# (define *rtlgen/valid-remaining-declarations* '()) -(define (call/%stack-closure-ref/unparse expr receiver) - (let ((vector (CALL/%stack-closure-ref/offset expr)) - (name (CALL/%stack-closure-ref/name expr))) - (if (and (QUOTE/? vector) - (QUOTE/? name)) - (let ((v (quote/text vector)) - (n (quote/text name))) - (if (and (vector? v) (symbol? n)) - (receiver v n)))))) - -(define (CALL/%stack-closure-ref/index expr) - (call/%stack-closure-ref/unparse expr vector-index)) - -(define (CALL/%stack-closure-ref/index=? expr value) - (call/%stack-closure-ref/unparse - expr - (lambda (v n) - (and (vector? v) - (< -1 value (vector-length v)) - (eq? (vector-ref v value) n))))) - #| ;; New RTL: diff --git a/v8/src/compiler/midend/simplify.scm b/v8/src/compiler/midend/simplify.scm index 192bda6f8..489557aa1 100644 --- a/v8/src/compiler/midend/simplify.scm +++ b/v8/src/compiler/midend/simplify.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: simplify.scm,v 1.18 1996/03/06 14:22:27 adams Exp $ +$Id: simplify.scm,v 1.19 1996/07/30 19:25:02 adams Exp $ Copyright (c) 1994-1995 Massachusetts Institute of Technology @@ -161,6 +161,50 @@ MIT in each case. |# bindings))) (do-simplification env0 #T bindings* body* simplify/letrecify))) +(define-simplifier LETREC (env bindings body) + (let* ((frame (map (lambda (binding) (simplify/binding/make (car binding))) + bindings)) + (env0 (simplify/env/make env frame)) + (body* (simplify/expr env0 body))) + + (let ((bindings* '()) + (initial-queue (map cons frame bindings))) + + (define (finish unused) + (let ((bindings* + (map* bindings* + (lambda (bnd+var+exp) + (list false (second bnd+var+exp) (third bnd+var+exp))) + unused))) + (let ((x + (do-simplification env0 #T bindings* body* simplify/letrecify))) + x))) + + ;; We scan a queue of bindings to check. If a binding is referenced, add + ;; it to the set. If it is unreferenced, put it in a retry + ;; list. The note below: we don't reverse the list as this + ;; gives us a back-and-forth pattern of scanning which guards + ;; against pathological (O(n^2)) cases. + + (let loop ((queue initial-queue) ; list (binding,name,expression) + (retry '()) + (found-one? #F)) + + (if (null? queue) + (if found-one? + (loop retry '() #F) ; Note: not reversed! + (finish retry)) + (let ((head (car queue)) + (rest (cdr queue))) + (if (and (null? (simplify/binding/operator-refs (car head))) + (null? (simplify/binding/ordinary-refs (car head)))) + (loop rest (cons head retry) found-one?) + (begin + (set! bindings* + (cons (simplify/binding&value env0 (second head) (third head)) + bindings*)) + (loop (cdr queue) retry #T))))))))) + (define (simplify/binding&value env name value) (if (not (LAMBDA/? value)) (list false name (simplify/expr env value)) diff --git a/v8/src/compiler/midend/typerew.scm b/v8/src/compiler/midend/typerew.scm index a27a9106b..142356e6f 100644 --- a/v8/src/compiler/midend/typerew.scm +++ b/v8/src/compiler/midend/typerew.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: typerew.scm,v 1.22 1996/07/27 03:30:17 adams Exp $ +$Id: typerew.scm,v 1.23 1996/07/30 19:24:53 adams Exp $ Copyright (c) 1994-1996 Massachusetts Institute of Technology @@ -1070,6 +1070,18 @@ and we dont do much with that. (define typerew/->binary-combination typerew/->nary-combination) (define typerew/->ternary-combination typerew/->nary-combination) +(define (typerew/->primitive-error-combination primitive) + (if (not (primitive-procedure? primitive)) + (internal-error "Expected a primitive procedure" primitive)) + (lambda args + `(CALL (QUOTE ,%invoke-remote-cache) + '#F + '(%COMPILED-CODE-SUPPORT:SIGNAL-ERROR-IN-PRIMITIVE + ,(+ (length args) 1)) + 'bogus-cache-reference ; naughty, should insert a global cache + ',primitive + ,@args))) + (define (typerew/diamond original-form test-form form*1 form*2) (define (equivalent form*) (typerew/remember* form* original-form)) @@ -1945,7 +1957,9 @@ and we dont do much with that. ;; No effects. (let* ((rator (make-primitive-procedure name)) (checking-replacement - (typerew-operator-replacement/diamond-1-1-1 %test %operation rator)) + (typerew-operator-replacement/diamond-1-1-1 + %test %operation + (typerew/->primitive-error-combination rator))) (unchecked-replacement (typerew-simple-operator-replacement %operation))) @@ -1977,7 +1991,9 @@ and we dont do much with that. %test %operation) (let* ((rator (make-primitive-procedure name)) (checking-replacement - (typerew-operator-replacement/diamond-1-2-2 %test %operation rator)) + (typerew-operator-replacement/diamond-1-2-2 + %test %operation + (typerew/->primitive-error-combination rator))) (unchecked-replacement (typerew-simple-operator-replacement %operation))) @@ -2018,7 +2034,7 @@ and we dont do much with that. `(CALL ',%generic-index-check/ref '#F ,collection ,index (QUOTE ,checks))) (typerew/->binary-combination %selector) - (typerew/->binary-combination selector))) + (typerew/->primitive-error-combination selector))) (define-typerew-replacement-method selector 2 (lambda (form collection index) @@ -2050,7 +2066,7 @@ and we dont do much with that. `(CALL ',%generic-index-check/set! '#F ,collection ,index ,element (QUOTE ,checks))) %mutator - mutator)) + (typerew/->primitive-error-combination mutator))) (define-typerew-replacement-method mutator 3 (lambda (form collection index element)