diff --git a/collects/compiler/decompile.rkt b/collects/compiler/decompile.rkt index f6831c0900..ca9b60c7a5 100644 --- a/collects/compiler/decompile.rkt +++ b/collects/compiler/decompile.rkt @@ -259,7 +259,9 @@ [(struct toplevel (depth pos const? ready?)) (decompile-tl expr globs stack closed #f)] [(struct varref (tl dummy)) - `(#%variable-reference ,(decompile-tl tl globs stack closed #t))] + `(#%variable-reference ,(if (eq? tl #t) + ' + (decompile-tl tl globs stack closed #t)))] [(struct topsyntax (depth pos midpt)) (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] [(struct primval (id)) diff --git a/collects/compiler/zo-structs.rkt b/collects/compiler/zo-structs.rkt index e7223113ff..86c8052a15 100644 --- a/collects/compiler/zo-structs.rkt +++ b/collects/compiler/zo-structs.rkt @@ -156,7 +156,7 @@ [body (or/c expr? seq? any/c)])) ; `with-continuation-mark' (define-form-struct (beg0 expr) ([seq (listof (or/c expr? seq? any/c))])) ; `begin0' (define-form-struct (splice form) ([forms (listof (or/c form? any/c))])) ; top-level `begin' -(define-form-struct (varref expr) ([toplevel toplevel?] [dummy toplevel?])) ; `#%variable-reference' +(define-form-struct (varref expr) ([toplevel (or/c toplevel? #t)] [dummy (or/c toplevel? #f)])) ; `#%variable-reference' (define-form-struct (assign expr) ([id toplevel?] [rhs (or/c expr? seq? any/c)] [undef-ok? boolean?])) ; top-level or module-level set! (define-form-struct (apply-values expr) ([proc (or/c expr? seq? any/c)] [args-expr (or/c expr? seq? any/c)])) ; `(call-with-values (lambda () ,args-expr) ,proc) (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive diff --git a/collects/racket/private/kw.rkt b/collects/racket/private/kw.rkt index 4709f742f7..dab3e273d0 100644 --- a/collects/racket/private/kw.rkt +++ b/collects/racket/private/kw.rkt @@ -231,6 +231,7 @@ "keyword list: ~e; does not match the length of the value list: " kws) kw-vals)) + (let ([normal-args (let loop ([normal-argss (cons normal-args normal-argss)][pos 3]) (if (null? (cdr normal-argss)) @@ -786,7 +787,8 @@ (syntax-case rhs () [(lam-id . _) (and (let ([ctx (syntax-local-context)]) - (or (memq ctx '(top-level module module-begin)) + (or (and (memq ctx '(module module-begin)) + (compile-enforce-module-constants)) (and (list? ctx) (andmap liberal-define-context? ctx)))) (identifier? #'lam-id) @@ -808,7 +810,7 @@ #,(quasisyntax/loc stx (define unpack #,kwimpl)) #,(quasisyntax/loc stx - (define proc (let ([#,id #,wrap]) #,id))))))))] + (define proc #,wrap)))))))] [_ (plain rhs)])))) ;; ---------------------------------------- @@ -837,9 +839,10 @@ (check-arity (- (length l) 2)) (let ([args (cdr (syntax-e stx))]) (syntax-protect - (or (generate-direct (cdr (if (pair? args) args (syntax-e args))) null) - (quasisyntax/loc stx - (#%app . #,args)))))))) + (generate-direct + (cdr (if (pair? args) args (syntax-e args))) null + (quasisyntax/loc stx + (#%app . #,args)))))))) ;; keyword app (maybe) (let ([exprs (let ([kw-ht (make-hasheq)]) @@ -892,16 +895,17 @@ (syntax-protect (quasisyntax/loc stx (let #,(reverse bind-accum) - #,(or (generate-direct (cdr args) sorted-kws) - (quasisyntax/loc stx - ((checked-procedure-check-and-extract struct:keyword-procedure - #,(car args) - keyword-procedure-extract - '#,(map car sorted-kws) - #,cnt) - '#,(map car sorted-kws) - (list #,@(map cdr sorted-kws)) - . #,(cdr args))))))))] + #,(generate-direct + (cdr args) sorted-kws + (quasisyntax/loc stx + ((checked-procedure-check-and-extract struct:keyword-procedure + #,(car args) + keyword-procedure-extract + '#,(map car sorted-kws) + #,cnt) + '#,(map car sorted-kws) + (list #,@(map cdr sorted-kws)) + . #,(cdr args))))))))] [(keyword? (syntax-e (car l))) (loop (cddr l) (cdr ids) @@ -920,115 +924,122 @@ kw-pairs)]))))))) (define-syntax (new-app stx) - (parse-app stx void (lambda (args kw-args) #f))) + (parse-app stx void (lambda (args kw-args orig) orig))) (define-for-syntax (make-keyword-syntax impl-id wrap-id n-req n-opt rest? req-kws all-kws) - (lambda (stx) - (syntax-case stx () - [(self arg ...) - (let ([warning - (lambda (msg) - (let ([l (current-logger)]) - (when (log-level? l 'warning) - (log-message - l - 'warning - (format "~aexpanson detects ~a for: ~a" - (let ([s (syntax-source stx)] - [l (syntax-line stx)] - [c (syntax-column stx)] - [p (syntax-position stx)]) - (if s - (if l - (format "~a:~a:~a: " s l c) - (format "~a:::~a: " s l p)) - "")) - msg - (syntax-e #'self)) - (current-continuation-marks)))))]) - (if (free-identifier=? #'new-app (datum->syntax stx '#%app)) - (parse-app (datum->syntax #f (cons #'new-app stx) stx) - (lambda (n) - (when (or (n . < . n-req) - (and (not rest?) - (n . > . (+ n-req n-opt)))) - (printf "~s\n" (list n n-req n-opt)) - (warning "wrong number of by-position arguments"))) - (lambda (args kw-args) - (let* ([args (syntax->list (datum->syntax #f args))] - [n (length args)]) - (and (not (or (n . < . n-req) - (and (not rest?) - (n . > . (+ n-req n-opt))))) - (let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws]) - (cond - [(null? kw-args) - (or (null? req-kws) - (and - (warning - (format "missing required keyword ~a" (car req-kws))) - #f))] - [else (let* ([kw (syntax-e (caar kw-args))] - [all-kws (let loop ([all-kws all-kws]) - (cond - [(null? all-kws) null] - [(keywordsyntax stx (cons wrap-id #'(arg ...)) stx stx)))] - [_ wrap-id]))) + (make-set!-transformer + (lambda (stx) + (syntax-case stx (set!) + [(set! self rhs) + (quasisyntax/loc stx (set! #,wrap-id rhs))] + [(self arg ...) + (let ([warning + (lambda (msg) + (let ([l (current-logger)]) + (when (log-level? l 'warning) + (log-message + l + 'warning + (format "~aexpanson detects ~a for: ~a" + (let ([s (syntax-source stx)] + [l (syntax-line stx)] + [c (syntax-column stx)] + [p (syntax-position stx)]) + (if s + (if l + (format "~a:~a:~a: " s l c) + (format "~a:::~a: " s l p)) + "")) + msg + (syntax-e #'self)) + (current-continuation-marks)))))]) + (if (free-identifier=? #'new-app (datum->syntax stx '#%app)) + (parse-app (datum->syntax #f (cons #'new-app stx) stx) + (lambda (n) + (when (or (n . < . n-req) + (and (not rest?) + (n . > . (+ n-req n-opt)))) + (printf "~s\n" (list n n-req n-opt)) + (warning "wrong number of by-position arguments"))) + (lambda (args kw-args orig) + (let* ([args (syntax->list (datum->syntax #f args))] + [n (length args)]) + (or + (and (not (or (n . < . n-req) + (and (not rest?) + (n . > . (+ n-req n-opt))))) + (let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws]) + (cond + [(null? kw-args) + (or (null? req-kws) + (and + (warning + (format "missing required keyword ~a" (car req-kws))) + #f))] + [else (let* ([kw (syntax-e (caar kw-args))] + [all-kws (let loop ([all-kws all-kws]) + (cond + [(null? all-kws) null] + [(keywordsyntax stx (cons wrap-id #'(arg ...)) stx stx)))] + [_ wrap-id])))) ;; Checks given kws against expected. Result is ;; (values missing-kw extra-kw), where both are #f if diff --git a/collects/scribblings/raco/zo-struct.scrbl b/collects/scribblings/raco/zo-struct.scrbl index 4308dd774e..23236a9a02 100644 --- a/collects/scribblings/raco/zo-struct.scrbl +++ b/collects/scribblings/raco/zo-struct.scrbl @@ -426,11 +426,14 @@ structures that are produced by @racket[zo-parse] and consumed by After each expression in @racket[seq] is evaluated, the stack is restored to its depth from before evaluating the expression.} -@defstruct+[(varref expr) ([toplevel toplevel?] [dummy toplevel?])]{ - Represents a @racket[#%variable-reference] form. The @racket[dummy] field +@defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)] + [dummy (or/c toplevel? #f)])]{ + Represents a @racket[#%variable-reference] form. The @racket[toplevel] + field is @racket[#t] if the original reference was to a constant local + binding. The @racket[dummy] field accesses a variable bucket that strongly references its namespace (as opposed to a normal variable bucket, which only weakly references its - namespace).} + namespace); it can be @racket[#f].} @defstruct+[(assign expr) ([id toplevel?] diff --git a/collects/scribblings/reference/namespaces.scrbl b/collects/scribblings/reference/namespaces.scrbl index 400bd57d7e..2556a2240f 100644 --- a/collects/scribblings/reference/namespaces.scrbl +++ b/collects/scribblings/reference/namespaces.scrbl @@ -359,6 +359,15 @@ correspond to the first two elements of a list produced by Return @racket[#t] if @racket[v] is a @tech{variable reference} produced by @racket[#%variable-reference], @racket[#f] otherwise.} + +@defproc[(variable-reference-constant? [varref variable-reference?]) boolean?]{ + +Returns @racket[#t] if the variable represented by @racket[varref] +will retain its current value (i.e., @racket[varref] refers to a +variable that cannot be further modified by @racket[set!] or +@racket[define]), @racket[#f] otherwise.} + + @defproc[(variable-reference->empty-namespace [varref variable-reference?]) namespace?]{ @@ -402,3 +411,5 @@ result is @racket[#f].} exact-nonnegative-integer?]{ Returns the @tech{phase} of the variable referenced by @racket[varref].} + + diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index a94a3fa884..71059b4780 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -230,7 +230,7 @@ value and put it into a list for @racket[context-v]. To allow @tech{liberal expansion} of @racket[define] forms, the generated value should be an instance of a structure with a true value for @racket[prop:liberal-define-context]. If the internal-definition -context is meant to be self-contained, the list for @racket[context-c] +context is meant to be self-contained, the list for @racket[context-v] should contain only the generated value; if the internal-definition context is meant to splice into an immediately enclosing context, then when @racket[syntax-local-context] produces a list, @racket[cons] the @@ -795,14 +795,16 @@ identifier.} An instance of a structure type with a true value for the @racket[prop:liberal-define-context] property can be used as an element of an @tech{internal-definition context} representation in the -result of @racket[syntax-local-context] for the second argument of +result of @racket[syntax-local-context] or the second argument of @racket[local-expand]. Such a value indicates that the context supports @deftech{liberal expansion} of @racket[define] forms into potentially multiple @racket[define-values] and -@racket[define-syntaxes] forms. +@racket[define-syntaxes] forms. The @racket['module] and +@racket['module-body] contexts implicitly allow @tech{liberal +expansion}. The @racket[liberal-define-context?] predicate returns @racket[#t] if -@arcket[v] is an instance of a structure with a true value for the +@racket[v] is an instance of a structure with a true value for the @racket[prop:liberal-define-context] property, @racket[#f] otherwise.} @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index b27f6daf03..9d1adcf568 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -1334,11 +1334,11 @@ introduces @racketidfont{#%top} identifiers. (#%variable-reference)]]{ Produces an opaque @deftech{variable reference} value representing the -@tech{location} of @racket[id], which must be bound as a @tech{top-level -variable} or @tech{module-level variable}. If no @racket[id] is -supplied, the resulting value refers to an ``anonymous'' variable -defined within the enclosing context (i.e., within the enclosing -module, or at the top level if the form is not inside a module). +@tech{location} of @racket[id], which must be bound as a variable. If +no @racket[id] is supplied, the resulting value refers to an +``anonymous'' variable defined within the enclosing context (i.e., +within the enclosing module, or at the top level if the form is not +inside a module). A @tech{variable reference} can be used with @racket[variable-reference->empty-namespace], @@ -2010,6 +2010,11 @@ evaluating @racket[expr], if it does not exist already, and the top-level mapping of @racket[id] (in the @techlink{namespace} linked with the compiled definition) is set to the binding at the same time. +In a context that allows @tech{liberal expansion} of @racket[define], +@racket[id] is bound as syntax if @racket[expr] is an immediate +@racket[lambda] form with keyword arguments or @racket[args] include +keyword arguments. + @defexamples[ (define x 10) x diff --git a/collects/tests/scriblib/bibtex.rkt b/collects/tests/scriblib/bibtex.rkt index 5cdcde3489..2df35c2231 100644 --- a/collects/tests/scriblib/bibtex.rkt +++ b/collects/tests/scriblib/bibtex.rkt @@ -9,15 +9,16 @@ (let () (define-bibtex-cite example.bib ~cite-id citet-id generate-bibliography-id) - (test - (~cite-id "cryptoeprint:2000:067") - (~cite-id "Tobin-Hochstadt:2011fk") - (~cite-id "cryptoeprint:2000:067" "Tobin-Hochstadt:2011fk") - (~cite-id "cryptoeprint:2000:067 Tobin-Hochstadt:2011fk") - - (citet-id "cryptoeprint:2000:067") - (citet-id "Tobin-Hochstadt:2011fk") - (citet-id "Tobin-Hochstadt:2011fk" "Tobin-Hochstadt:2011fk") - (citet-id "Tobin-Hochstadt:2011fk Tobin-Hochstadt:2011fk") - - (generate-bibliography-id)))) + + (~cite-id "cryptoeprint:2000:067") + (~cite-id "Tobin-Hochstadt:2011fk") + (~cite-id "cryptoeprint:2000:067" "Tobin-Hochstadt:2011fk") + (~cite-id "cryptoeprint:2000:067 Tobin-Hochstadt:2011fk") + + (citet-id "cryptoeprint:2000:067") + (citet-id "Tobin-Hochstadt:2011fk") + (citet-id "Tobin-Hochstadt:2011fk" "Tobin-Hochstadt:2011fk") + (citet-id "Tobin-Hochstadt:2011fk Tobin-Hochstadt:2011fk") + + (generate-bibliography-id))) + diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index c1159d1ebf..7bb2349372 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -125,6 +125,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, /* should be always NULL */ dest[i].observer = src[drec].observer; dest[i].pre_unwrapped = 0; + dest[i].testing_constantness = 0; dest[i].env_already = 0; dest[i].comp_flags = src[drec].comp_flags; } @@ -144,6 +145,7 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, dest[i].value_name = scheme_false; dest[i].observer = src[drec].observer; dest[i].pre_unwrapped = 0; + dest[i].testing_constantness = 0; dest[i].env_already = 0; dest[i].comp_flags = src[drec].comp_flags; } @@ -167,6 +169,7 @@ void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, lam[dlrec].value_name = scheme_false; lam[dlrec].observer = src[drec].observer; lam[dlrec].pre_unwrapped = 0; + lam[dlrec].testing_constantness = 0; lam[dlrec].env_already = 0; lam[dlrec].comp_flags = src[drec].comp_flags; } @@ -851,10 +854,10 @@ static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, u = COMPILE_DATA(frame)->use[i]; - u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING)) + u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING)) ? CONSTRAINED_USE : ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE)) - | ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF)) + | ((flags & (SCHEME_SETTING | SCHEME_LINKING_REF)) ? WAS_SET_BANGED : 0)); diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 913c245c70..c7ce4f2dbc 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -1397,11 +1397,13 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, if (rec[drec].comp) { var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0); - if (!imported && env->genv->module) + if (!imported && env->genv->module && !rec[drec].testing_constantness) SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; } + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { + /* ok */ } else { - scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a top-level or module variable"); + scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a variable"); } if (rec[drec].comp) @@ -3259,6 +3261,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, rec1.value_name = NULL; rec1.observer = NULL; rec1.pre_unwrapped = 0; + rec1.testing_constantness = 0; rec1.env_already = 0; rec1.comp_flags = rec[drec].comp_flags; @@ -3451,6 +3454,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object mrec.value_name = NULL; mrec.observer = NULL; mrec.pre_unwrapped = 0; + mrec.testing_constantness = 0; mrec.env_already = 0; mrec.comp_flags = rec[drec].comp_flags; @@ -4087,6 +4091,11 @@ scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, else comp_first = p; comp_last = p; + + if (!i && start_app_position && (len == 2) + && SAME_OBJ(c, scheme_varref_const_p_proc)) { + recs[1].testing_constantness = 1; + } } scheme_merge_compile_recs(rec, drec, recs, len); diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 5f909c6d3d..8fd155c375 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -15,12 +15,12 @@ 116,120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,108,101,116, 114,101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1,20,112,97, 114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,61,118,73, -100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,148,75,0, +100,101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,124,75,0, 0,95,159,2,17,36,36,159,2,16,36,36,159,2,16,36,36,16,20,2,4, 2,2,2,6,2,2,2,7,2,2,2,8,2,2,2,9,2,2,2,10,2, 2,2,11,2,2,2,5,2,2,2,12,2,2,2,13,2,2,97,37,11,8, -240,148,75,0,0,93,159,2,16,36,37,16,2,2,3,161,2,2,37,2,3, -2,2,2,3,96,38,11,8,240,148,75,0,0,16,0,96,11,11,8,240,148, +240,124,75,0,0,93,159,2,16,36,37,16,2,2,3,161,2,2,37,2,3, +2,2,2,3,96,38,11,8,240,124,75,0,0,16,0,96,11,11,8,240,124, 75,0,0,16,0,18,98,64,104,101,114,101,13,16,5,36,2,14,2,2,11, 11,8,32,8,31,8,30,8,29,27,248,22,155,4,195,249,22,148,4,80,158, 39,36,251,22,83,2,18,248,22,98,199,12,249,22,73,2,19,248,22,100,201, @@ -958,7 +958,7 @@ 107,11,29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,74, 35,37,112,108,97,99,101,45,115,116,114,117,99,116,11,29,94,2,2,66,35, 37,98,111,111,116,11,29,94,2,2,68,35,37,101,120,112,111,98,115,11,29, -94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,24,77,0, +94,2,2,68,35,37,107,101,114,110,101,108,11,97,36,11,8,240,0,77,0, 0,100,159,2,3,36,36,159,2,4,36,36,159,2,5,36,36,159,2,6,36, 36,159,2,7,36,36,159,2,8,36,36,159,2,9,36,36,159,2,9,36,36, 16,0,159,36,20,112,159,36,16,1,11,16,0,20,26,142,2,1,2,1,29, diff --git a/src/racket/src/env.c b/src/racket/src/env.c index c6c136b0d3..df8df06b01 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -46,6 +46,7 @@ int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; } SHARED_OK int scheme_starting_up; /* globals READ-ONLY SHARED */ +Scheme_Object *scheme_varref_const_p_proc; READ_ONLY static Scheme_Object *kernel_symbol; READ_ONLY static Scheme_Env *kernel_env; READ_ONLY static Scheme_Env *unsafe_env; @@ -76,6 +77,7 @@ static Scheme_Object *variable_module_source(int, Scheme_Object *[]); static Scheme_Object *variable_namespace(int, Scheme_Object *[]); static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]); static Scheme_Object *variable_phase(int, Scheme_Object *[]); +static Scheme_Object *variable_const_p(int, Scheme_Object *[]); static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); @@ -639,6 +641,12 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("variable-reference->namespace", variable_top_level_namespace, 1, 1, env); GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 1, 1, env); + REGISTER_SO(scheme_varref_const_p_proc); + scheme_varref_const_p_proc = scheme_make_prim_w_arity(variable_const_p, + "variable-reference-constant?", + 1, 1); + scheme_add_global_constant("variable-reference-constant?", scheme_varref_const_p_proc, env); + GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); @@ -1680,6 +1688,25 @@ static Scheme_Object *variable_phase(int argc, Scheme_Object *argv[]) return do_variable_namespace("variable-reference->phase", 2, argc, argv); } +static Scheme_Object *variable_const_p(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *v; + + v = argv[0]; + + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_global_ref_type)) + scheme_wrong_type("variable-reference-constant?", "variable-reference", 0, argc, argv); + + if (SCHEME_PAIR_FLAGS(v) & 0x1) + return scheme_true; + + v = SCHEME_PTR1_VAL(v); + if (((Scheme_Bucket_With_Flags *)v)->flags & GLOB_IS_IMMUTATED) + return scheme_true; + + return scheme_false; +} + static Scheme_Object *variable_p(int argc, Scheme_Object *argv[]) { Scheme_Env *env; diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index c0735edfd5..d9906c1047 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1832,18 +1832,24 @@ ref_execute (Scheme_Object *data) { Scheme_Prefix *toplevels; Scheme_Object *o; - Scheme_Bucket *var; + Scheme_Object *var; Scheme_Object *tl = SCHEME_PTR1_VAL(data); Scheme_Env *env; toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; - var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; - env = scheme_environment_from_dummy(SCHEME_CDR(data)); + var = toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; + if (SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) + env = NULL; + else + env = scheme_environment_from_dummy(SCHEME_PTR2_VAL(data)); o = scheme_alloc_object(); o->type = scheme_global_ref_type; - SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; - SCHEME_PTR2_VAL(o) = (Scheme_Object *)env; + SCHEME_PTR1_VAL(o) = var; + SCHEME_PTR2_VAL(o) = (env ? (Scheme_Object *)env : scheme_false); + + if (SCHEME_PAIR_FLAGS(data) & 0x1) + SCHEME_PAIR_FLAGS(o) |= 0x1; return o; } diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 48dc0ee25e..a8e40322e1 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -59,6 +59,16 @@ static Scheme_Object *make_global_ref(Scheme_Object *var, Scheme_Object *dummy) return o; } +static Scheme_Object *make_global_const_ref(Scheme_Object *var, Scheme_Object *dummy) +{ + GC_CAN_IGNORE Scheme_Object *o; + + o = make_global_ref(var, dummy); + SCHEME_PAIR_FLAGS(o) |= 0x1; + + return o; +} + /*========================================================================*/ /* run time */ /*========================================================================*/ @@ -2298,10 +2308,12 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w finish_branch_with_true(jitter, for_branch); else { Scheme_Object *dummy; - int pos; + int pos, is_const; mz_rs_sync(); + is_const = (SCHEME_PAIR_FLAGS(obj) & 0x1); + dummy = SCHEME_PTR2_VAL(obj); obj = SCHEME_PTR1_VAL(obj); @@ -2314,9 +2326,13 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w CHECK_LIMIT(); /* Load dummy bucket: */ - pos = SCHEME_TOPLEVEL_POS(dummy); - jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); - CHECK_LIMIT(); + if (SCHEME_FALSEP(dummy)) { + (void)jit_movi_p(JIT_R2, scheme_false); + } else { + pos = SCHEME_TOPLEVEL_POS(dummy); + jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + CHECK_LIMIT(); + } JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(2); @@ -2324,7 +2340,11 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w jit_pusharg_p(JIT_R1); { GC_CAN_IGNORE jit_insn *refr; - (void)mz_finish_lwe(ts_make_global_ref, refr); + if (is_const) { + (void)mz_finish_lwe(ts_make_global_const_ref, refr); + } else { + (void)mz_finish_lwe(ts_make_global_ref, refr); + } } CHECK_LIMIT(); jit_retval(target); diff --git a/src/racket/src/jit_ts.c b/src/racket/src/jit_ts.c index 4e645faad9..53557c3f77 100644 --- a/src/racket/src/jit_ts.c +++ b/src/racket/src/jit_ts.c @@ -17,6 +17,7 @@ #ifdef JIT_TS_PROCS define_ts_bsi_v(call_set_global_bucket, FSRC_MARKS) define_ts_ss_s(make_global_ref, FSRC_OTHER) +define_ts_ss_s(make_global_const_ref, FSRC_OTHER) define_ts_iiS_v(lexical_binding_wrong_return_arity, FSRC_MARKS) define_ts_siS_v(wrong_argument_count, FSRC_MARKS) # ifdef JIT_PRECISE_GC @@ -150,6 +151,7 @@ define_ts_s_s(scheme_box, FSRC_OTHER) # define ts_call_set_global_bucket call_set_global_bucket # define ts_scheme_make_envunbox scheme_make_envunbox # define ts_make_global_ref make_global_ref +# define ts_make_global_const_ref make_global_const_ref # define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity # define ts_call_wrong_return_arity call_wrong_return_arity # define ts_scheme_unbound_global scheme_unbound_global diff --git a/src/racket/src/jitinline.c b/src/racket/src/jitinline.c index f9d9f5db48..dfc1d2fa61 100644 --- a/src/racket/src/jitinline.c +++ b/src/racket/src/jitinline.c @@ -425,6 +425,63 @@ static int is_cXr_prim(const char *name) return !name[i+1]; } +static int generate_inlined_constant_varref_test(mz_jit_state *jitter, Scheme_Object *obj, + Branch_Info *for_branch, int branch_short, int need_sync) +{ + GC_CAN_IGNORE jit_insn *ref1, *ref2; + int pos; + + if (SCHEME_PAIR_FLAGS(obj) & 0x1) { + jit_movi_p(JIT_R0, scheme_true); + return 1; + } + + mz_runstack_skipped(jitter, 1); + + obj = SCHEME_PTR1_VAL(obj); + + /* Load global array: */ + pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); + jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + /* Load bucket: */ + pos = SCHEME_TOPLEVEL_POS(obj); + jit_ldxi_p(JIT_R1, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); + CHECK_LIMIT(); + + mz_runstack_unskipped(jitter, 1); + + if (need_sync) mz_rs_sync(); + + __START_SHORT_JUMPS__(branch_short); + + if (for_branch) { + scheme_prepare_branch_jump(jitter, for_branch); + CHECK_LIMIT(); + } + + jit_ldxi_s(JIT_R1, JIT_R1, &((Scheme_Bucket_With_Flags *)0x0)->flags); + ref1 = jit_bmci_ul(jit_forward(), JIT_R1, GLOB_IS_IMMUTATED); + CHECK_LIMIT(); + + if (for_branch) { + scheme_add_branch_false(for_branch, ref1); + scheme_branch_for_true(jitter, for_branch); + } else { + (void)jit_movi_p(JIT_R0, scheme_true); + ref2 = jit_jmpi(jit_forward()); + + mz_patch_branch(ref1); + (void)jit_movi_p(JIT_R0, scheme_false); + + mz_patch_ucbranch(ref2); + } + CHECK_LIMIT(); + + __END_SHORT_JUMPS__(branch_short); + + return 1; +} + static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3); @@ -448,6 +505,12 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } } + if (SAME_OBJ(rator, scheme_varref_const_p_proc) + && SAME_TYPE(SCHEME_TYPE(app->rand), scheme_varref_form_type)) { + generate_inlined_constant_varref_test(jitter, app->rand, for_branch, branch_short, need_sync); + return 1; + } + if (!SCHEME_PRIMP(rator)) return 0; @@ -1659,7 +1722,6 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } } - if (!SCHEME_PRIMP(rator)) return 0; diff --git a/src/racket/src/marshal.c b/src/racket/src/marshal.c index 725ab5dfd8..7fd59f9295 100644 --- a/src/racket/src/marshal.c +++ b/src/racket/src/marshal.c @@ -450,7 +450,15 @@ static Scheme_Object *write_set_bang(Scheme_Object *obj) Scheme_Object *write_varref(Scheme_Object *o) { - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); + int is_const = (SCHEME_PAIR_FLAGS(o) & 0x1); + + if (is_const) { + if (SCHEME_PTR1_VAL(o) != SCHEME_PTR2_VAL(o)) + scheme_signal_error("internal error: expected varref halves to be the same"); + } + + return scheme_make_pair((is_const ? scheme_true : SCHEME_PTR1_VAL(o)), + SCHEME_PTR2_VAL(o)); } Scheme_Object *read_varref(Scheme_Object *o) @@ -461,8 +469,11 @@ Scheme_Object *read_varref(Scheme_Object *o) data = scheme_alloc_object(); data->type = scheme_varref_form_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); + if (SAME_OBJ(SCHEME_CAR(o), scheme_true)) + SCHEME_PTR1_VAL(data) = SCHEME_CDR(o); + else + SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); return data; } diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 7adaf4cccd..27acbc5839 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -84,6 +84,7 @@ static int optimize_info_is_ready(Optimize_Info *info, int pos); static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use); static Scheme_Object *optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, int once_used_ok, int context, int *potential_size, int *_mutated); +static Scheme_Object *optimize_info_mutated_lookup(Optimize_Info *info, int pos, int *is_mutated); static void optimize_info_used_top(Optimize_Info *info); static void optimize_mutated(Optimize_Info *info, int pos); @@ -1994,6 +1995,20 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } + if (SAME_OBJ(scheme_varref_const_p_proc, app->rator)) { + if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_varref_form_type)) { + Scheme_Object *var = SCHEME_PTR1_VAL(app->rand); + if (SAME_OBJ(var, scheme_true)) { + return scheme_true; + } else if (SAME_OBJ(var, scheme_false)) { + return scheme_false; + } else if (scheme_compiled_propagate_ok(var, info)) { + /* can propagate => is a constant */ + return scheme_true; + } + } + } + if ((SAME_OBJ(scheme_values_func, app->rator) || SAME_OBJ(scheme_list_star_proc, app->rator)) && (scheme_omittable_expr(app->rand, 1, -1, 0, info, -1) @@ -2753,7 +2768,16 @@ static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth) static Scheme_Object * ref_optimize(Scheme_Object *data, Optimize_Info *info, int context) { - optimize_info_used_top(info); + Scheme_Object *v; + + optimize_info_used_top(info); + + v = SCHEME_PTR1_VAL(data); + if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)) { + int is_mutated = 0; + optimize_info_mutated_lookup(info, SCHEME_LOCAL_POS(v), &is_mutated); + SCHEME_PTR1_VAL(data) = (is_mutated ? scheme_false : scheme_true); + } info->preserves_marks = 1; info->single_result = 1; @@ -2776,6 +2800,28 @@ ref_shift(Scheme_Object *data, int delta, int after_depth) return data; } +static Scheme_Object * +ref_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) +{ + Scheme_Object *naya; + Scheme_Object *a, *b; + + a = SCHEME_PTR1_VAL(data); + a = scheme_optimize_clone(dup_ok, a, info, delta, closure_depth); + if (!a) return NULL; + + b = SCHEME_PTR2_VAL(data); + b = scheme_optimize_clone(dup_ok, a, info, delta, closure_depth); + if (!b) return NULL; + + naya = scheme_alloc_object(); + naya->type = scheme_varref_form_type; + SCHEME_PTR1_VAL(naya) = a; + SCHEME_PTR2_VAL(naya) = b; + + return naya; +} + static Scheme_Object * apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) { @@ -5182,7 +5228,7 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I case scheme_require_form_type: return NULL; case scheme_varref_form_type: - return NULL; + return ref_clone(dup_ok, expr, info, delta, closure_depth); case scheme_set_bang_type: return set_clone(dup_ok, expr, info, delta, closure_depth); case scheme_apply_values_type: @@ -5744,7 +5790,7 @@ static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos) static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, int *not_ready, int once_used_ok, int context, int *potential_size, - int disrupt_single_use, int *is_mutated) + int disrupt_single_use, int *is_mutated, int just_test) { Scheme_Object *p, *n; int delta = 0; @@ -5766,6 +5812,8 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int if (info->use && (info->use[pos] & 0x1)) *is_mutated = 1; + if (just_test) return NULL; + p = info->consts; while (p) { n = SCHEME_VEC_ELS(p)[1]; @@ -5844,7 +5892,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, once_used_ok && !disrupt_single_use, context, - potential_size, disrupt_single_use, NULL); + potential_size, disrupt_single_use, NULL, 0); if (!n) { /* Return shifted reference to other local: */ @@ -5871,18 +5919,23 @@ static Scheme_Object *optimize_info_lookup(Optimize_Info *info, int pos, int *cl int once_used_ok, int context, int *potential_size, int *is_mutated) { return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok, context, - potential_size, 0, is_mutated); + potential_size, 0, is_mutated, 0); } static int optimize_info_is_ready(Optimize_Info *info, int pos) { int closure_offset, single_use, ready = 1; - do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0, 0, NULL, 0, NULL); + do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0, 0, NULL, 0, NULL, 0); return ready; } +static Scheme_Object *optimize_info_mutated_lookup(Optimize_Info *info, int pos, int *is_mutated) +{ + return do_optimize_info_lookup(info, pos, 0, NULL, NULL, NULL, 0, 0, NULL, 0, is_mutated, 1); +} + static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags) { Optimize_Info *naya; diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 39ceb82dd5..2656a3ba9c 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -324,7 +324,14 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_ merge_resolve_tl_map(orig_info, info); set_app2_eval_type(app); - + + if (SAME_OBJ(app->rator, scheme_varref_const_p_proc)) { + if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_varref_form_type)) { + /* drop reference to namespace: */ + SCHEME_PTR2_VAL(app->rand) = scheme_false; + } + } + return (Scheme_Object *)app; } @@ -661,10 +668,23 @@ ref_resolve(Scheme_Object *data, Resolve_Info *rslv) { Scheme_Object *v; - v = scheme_resolve_expr(SCHEME_PTR1_VAL(data), rslv); - SCHEME_PTR1_VAL(data) = v; v = scheme_resolve_expr(SCHEME_PTR2_VAL(data), rslv); SCHEME_PTR2_VAL(data) = v; + + v = SCHEME_PTR1_VAL(data); + if (SAME_OBJ(v, scheme_true) + || SAME_OBJ(v, scheme_false)) { + if (SCHEME_TRUEP(v)) + SCHEME_PAIR_FLAGS(data) |= 0x1; /* => constant */ + v = SCHEME_PTR2_VAL(data); + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)) { + v = scheme_resolve_expr(v, rslv); + if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)) + SCHEME_PAIR_FLAGS(data) |= 0x1; /* because mutable would be unbox */ + v = SCHEME_PTR2_VAL(data); + } else + v = scheme_resolve_expr(v, rslv); + SCHEME_PTR1_VAL(data) = v; return data; } diff --git a/src/racket/src/schminc.h b/src/racket/src/schminc.h index aa5555dec5..78dfc77d6e 100644 --- a/src/racket/src/schminc.h +++ b/src/racket/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 1029 +#define EXPECTED_PRIM_COUNT 1030 #define EXPECTED_UNSAFE_COUNT 78 #define EXPECTED_FLFXNUM_COUNT 68 #define EXPECTED_FUTURES_COUNT 11 diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 9b94e5758b..10a57f8830 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -362,6 +362,7 @@ extern Scheme_Object *scheme_box_proc; extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_current_inspector_proc; +extern Scheme_Object *scheme_varref_const_p_proc; extern Scheme_Object *scheme_define_values_syntax, *scheme_define_syntaxes_syntax; extern Scheme_Object *scheme_lambda_syntax; @@ -2173,6 +2174,7 @@ typedef struct Scheme_Compile_Expand_Info char dont_mark_local_use; char resolve_module_ids; char pre_unwrapped; + char testing_constantness; int depth; int env_already; } Scheme_Compile_Expand_Info; diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 94595ebde1..0c162d7dcb 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -317,9 +317,10 @@ static void ref_validate(Scheme_Object *data, Mz_CPort *port, validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, 0); - validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - 0); + if (!SCHEME_FALSEP(SCHEME_PTR2_VAL(data))) + validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + 0); } static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,