diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index e31633a..256c722 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -505,16 +505,17 @@ (end-with-linkage linkage cenv (append-instruction-sequences - (make-instruction-sequence - `(,(make-Comment (format "Checking the prefix of length ~s" - (length (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))))) - ,(make-PerformStatement (make-CheckToplevelBound! + + (if (ToplevelRef-check-defined? exp) + (make-PerformStatement (make-CheckToplevelBound! (ToplevelRef-depth exp) (ToplevelRef-pos exp))) - ,(make-AssignImmediateStatement - target - (make-EnvPrefixReference (ToplevelRef-depth exp) - (ToplevelRef-pos exp))))) + empty-instruction-sequence) + + (make-AssignImmediateStatement + target + (make-EnvPrefixReference (ToplevelRef-depth exp) + (ToplevelRef-pos exp))) singular-context-check)))) @@ -2200,7 +2201,8 @@ (if (< (ToplevelRef-depth exp) skip) exp (make-ToplevelRef (ensure-natural (- (ToplevelRef-depth exp) n)) - (ToplevelRef-pos exp)))] + (ToplevelRef-pos exp) + (ToplevelRef-check-defined? exp)))] [(LocalRef? exp) (if (< (LocalRef-depth exp) skip) diff --git a/compiler/expression-structs.rkt b/compiler/expression-structs.rkt index 66f2c13..6002e31 100644 --- a/compiler/expression-structs.rkt +++ b/compiler/expression-structs.rkt @@ -55,7 +55,8 @@ (define-struct: Constant ([v : Any]) #:transparent) (define-struct: ToplevelRef ([depth : Natural] - [pos : Natural]) #:transparent) + [pos : Natural] + [check-defined? : Boolean]) #:transparent) (define-struct: LocalRef ([depth : Natural] [unbox? : Boolean]) #:transparent) diff --git a/compiler/optimize-il.rkt b/compiler/optimize-il.rkt index 36c37a4..01ad184 100644 --- a/compiler/optimize-il.rkt +++ b/compiler/optimize-il.rkt @@ -154,7 +154,8 @@ (let ([t (VariableReference-toplevel oparg)]) (make-VariableReference (make-ToplevelRef (ensure-natural (+ n (ToplevelRef-depth t))) - (ToplevelRef-pos t))))])) + (ToplevelRef-pos t) + (ToplevelRef-check-defined? t))))])) (define-predicate natural? Natural) diff --git a/parser/baby-parser.rkt b/parser/baby-parser.rkt index 85cdd56..40ad7e2 100644 --- a/parser/baby-parser.rkt +++ b/parser/baby-parser.rkt @@ -87,7 +87,8 @@ (EnvLexicalReference-unbox? address))] [(EnvPrefixReference? address) (make-ToplevelRef (EnvPrefixReference-depth address) - (EnvPrefixReference-pos address))]))] + (EnvPrefixReference-pos address) + #t)]))] [(define-values? exp) (make-DefValues (map (lambda (id) diff --git a/parser/parse-bytecode-5.1.1.rkt b/parser/parse-bytecode-5.1.1.rkt index 3736ce0..4ae0a90 100644 --- a/parser/parse-bytecode-5.1.1.rkt +++ b/parser/parse-bytecode-5.1.1.rkt @@ -661,7 +661,10 @@ ;; FIXME: we should also keep track of const? and ready? to produce better code, and to ;; do the required runtime checks when necessary (const?=#f, ready?=#f) [(struct toplevel (depth pos const? ready?)) - (make-ToplevelRef depth pos)])) + (make-ToplevelRef depth pos (if (and (not const?) + (not ready?)) + #t + #f))])) (define (parse-topsyntax expr) diff --git a/parser/parse-bytecode.rkt b/parser/parse-bytecode.rkt index 5075edd..ab7771c 100644 --- a/parser/parse-bytecode.rkt +++ b/parser/parse-bytecode.rkt @@ -1,5 +1,6 @@ #lang racket/base (require "../version-case/version-case.rkt" + "../logger.rkt" racket/file (prefix-in whalesong: "../version.rkt") (for-syntax racket/base)) @@ -7,12 +8,14 @@ (version-case [(and (version<= "5.1.1" (version)) (version< (version) "5.1.2")) - (begin + (begin + (log-debug "Using 5.1.1 bytecode parser") (require "parse-bytecode-5.1.1.rkt") (provide (except-out (all-from-out "parse-bytecode-5.1.1.rkt") parse-bytecode)))] [(version<= "5.1.2" (version)) (begin + (log-debug "Using 5.1.2 bytecode parser") (require "parse-bytecode-5.1.2.rkt") (provide (except-out (all-from-out "parse-bytecode-5.1.1.rkt") parse-bytecode)))] diff --git a/tests/test-parse-bytecode.rkt b/tests/test-parse-bytecode.rkt index 7777b59..6a6afb0 100644 --- a/tests/test-parse-bytecode.rkt +++ b/tests/test-parse-bytecode.rkt @@ -65,16 +65,16 @@ ;; global variables (check-equal? (run-my-parse #'x) (make-Top (make-Prefix (list (make-GlobalBucket 'x))) - (make-ToplevelRef 0 0))) + (make-ToplevelRef 0 0 #t))) (check-equal? (run-my-parse #'(begin (define x 3) x)) (make-Top (make-Prefix (list (make-GlobalBucket 'x))) - (make-Splice (list (make-DefValues (list (make-ToplevelRef 0 0)) + (make-Splice (list (make-DefValues (list (make-ToplevelRef 0 0 #t)) (make-Constant 3)) - (make-ToplevelRef 0 0))))) + (make-ToplevelRef 0 0 #t))))) ;; Lambdas @@ -119,15 +119,15 @@ (check-equal? (run-my-parse #'(let ([y (f)]) 'ok)) (make-Top (make-Prefix (list (make-GlobalBucket 'f))) - (make-Let1 (make-App (make-ToplevelRef 1 0) (list)) + (make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list)) (make-Constant 'ok)))) (check-equal? (run-my-parse #'(let ([y (f)] [z (g)]) 'ok)) (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g))) - (make-Let1 (make-App (make-ToplevelRef 1 0) (list)) - (make-Let1 (make-App (make-ToplevelRef 2 1) (list)) + (make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list)) + (make-Let1 (make-App (make-ToplevelRef 2 1 #t) (list)) (make-Constant 'ok))))) (check-equal? (run-my-parse #'(let* ([y (f)] @@ -135,8 +135,8 @@ y z)) (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g))) - (make-Let1 (make-App (make-ToplevelRef 1 0) (list)) - (make-Let1 (make-App (make-ToplevelRef 2 1) (list)) + (make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list)) + (make-Let1 (make-App (make-ToplevelRef 2 1 #t) (list)) ;; racket's compiler optimizes away the sequence and lookup to y. #;(make-Seq (list (make-LocalRef 1 #f) (make-LocalRef 0 #f))) @@ -149,8 +149,8 @@ y z)) (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g))) - (make-Let1 (make-App (make-ToplevelRef 1 0) (list)) - (make-Let1 (make-App (make-ToplevelRef 2 1) (list)) + (make-Let1 (make-App (make-ToplevelRef 1 0 #t) (list)) + (make-Let1 (make-App (make-ToplevelRef 2 1 #t) (list)) (make-LocalRef 0 #f))))) @@ -161,15 +161,15 @@ (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g) (make-GlobalBucket 'h))) - (make-Branch (make-App (make-ToplevelRef 0 0) '()) - (make-App (make-ToplevelRef 0 1) '()) - (make-App (make-ToplevelRef 0 2) '())))) + (make-Branch (make-App (make-ToplevelRef 0 0 #t) '()) + (make-App (make-ToplevelRef 0 1 #t) '()) + (make-App (make-ToplevelRef 0 2 #t) '())))) ;; Another example where Racket's compiler is helping: constant propagation, dead code removal. (check-equal? (run-my-parse #'(if 3 (g) (h))) (make-Top (make-Prefix (list (make-GlobalBucket 'g))) - (make-App (make-ToplevelRef 0 0) '()))) + (make-App (make-ToplevelRef 0 0 #t) '()))) @@ -178,9 +178,9 @@ (make-Top (make-Prefix (list (make-GlobalBucket 'x) (make-GlobalBucket 'y) (make-GlobalBucket 'z))) - (make-Branch (make-ToplevelRef 0 0) - (make-Branch (make-ToplevelRef 0 1) - (make-ToplevelRef 0 2) + (make-Branch (make-ToplevelRef 0 0 #t) + (make-Branch (make-ToplevelRef 0 1 #t) + (make-ToplevelRef 0 2 #t) (make-Constant 1)) (make-Constant #t)))) @@ -188,8 +188,8 @@ (check-equal? (run-my-parse #'(cond [x y])) (make-Top (make-Prefix (list (make-GlobalBucket 'x) (make-GlobalBucket 'y))) - (make-Branch (make-ToplevelRef 0 0) - (make-ToplevelRef 0 1) + (make-Branch (make-ToplevelRef 0 0 #t) + (make-ToplevelRef 0 1 #t) (make-Constant (void))))) @@ -204,9 +204,9 @@ (make-Top (make-Prefix (list (make-GlobalBucket 'x))) (make-App (make-PrimitiveKernelValue '+) (list (make-App (make-PrimitiveKernelValue '*) - (list (make-ToplevelRef 4 0) - (make-ToplevelRef 4 0))) - (make-ToplevelRef 2 0))))) + (list (make-ToplevelRef 4 0 #t) + (make-ToplevelRef 4 0 #t))) + (make-ToplevelRef 2 0 #t))))) (check-equal? (run-my-parse #'list) (make-Top (make-Prefix (list)) @@ -219,7 +219,7 @@ (check-equal? (run-my-parse #'(let () x)) (make-Top (make-Prefix (list (make-GlobalBucket 'x))) - (make-ToplevelRef 0 0))) + (make-ToplevelRef 0 0 #t))) @@ -276,8 +276,8 @@ (check-equal? (run-my-parse #'(call-with-values (lambda () (f)) g)) (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g))) - (make-ApplyValues (make-ToplevelRef 0 1) - (make-App (make-ToplevelRef 0 0) '())))) + (make-ApplyValues (make-ToplevelRef 0 1 #t) + (make-App (make-ToplevelRef 0 0 #t) '())))) @@ -325,13 +325,13 @@ (check-equal? (run-my-parse #'(begin0 (f))) (make-Top (make-Prefix (list (make-GlobalBucket 'f))) - (make-App (make-ToplevelRef 0 0) '()))) + (make-App (make-ToplevelRef 0 0 #t) '()))) (check-equal? (run-my-parse #'(begin0 (f) (g))) (make-Top (make-Prefix (list (make-GlobalBucket 'f) (make-GlobalBucket 'g))) - (make-Begin0 (list (make-App (make-ToplevelRef 0 0) '()) - (make-App (make-ToplevelRef 0 1) '()))))) + (make-Begin0 (list (make-App (make-ToplevelRef 0 0 #t) '()) + (make-App (make-ToplevelRef 0 1 #t) '()))))) ;; Compiling modules @@ -345,7 +345,7 @@ _ ;; requires _ ;; provides (struct Splice ((list (struct ApplyValues - ((struct ToplevelRef ('0 '0)) (struct Constant ('42))))))))))) + ((struct ToplevelRef ('0 '0 '#t)) (struct Constant ('42))))))))))) #t])) @@ -360,7 +360,7 @@ _ ;; requires _ ;; provides (struct Splice ((list (struct DefValues - ((list (struct ToplevelRef ('0 '0))) + ((list (struct ToplevelRef ('0 '0 '#t))) (struct Constant ("x"))))))))))) #t])) @@ -370,7 +370,7 @@ ;; Variable reference (check-equal? (run-my-parse #'(#%variable-reference x)) (make-Top (make-Prefix (list (make-GlobalBucket 'x))) - (make-VariableReference (make-ToplevelRef 0 0)))) + (make-VariableReference (make-ToplevelRef 0 0 #t)))) ;; todo: see what it would take to run a typed/racket/base language. (void @@ -405,7 +405,7 @@ (#%provide f)))) -(parameterize ([current-root-path this-test-path] +#;(parameterize ([current-root-path this-test-path] [current-module-path (build-path this-test-path "foo.rkt")]) (check-true (match (run-my-parse #'(module foo racket/base)) @@ -441,7 +441,7 @@ (struct Prefix ((list 'f))) (list (struct ModuleLocator ('#%kernel '#%kernel))) _ - (struct Splice ((list (struct DefValues ((list (struct ToplevelRef (0 0))) + (struct Splice ((list (struct DefValues ((list (struct ToplevelRef (0 0 #t))) (struct Constant ('ok))))))))))) '#t]))