suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

generalize #%variable-reference' and add variable-reference-constant?'

Browse Source 
Use the new functions to make the expansion of keyword applications
to known procedure work  with mutation.
This commit is contained in:
Matthew Flatt 2011-08-08 08:58:30 -06:00
parent 39a96dd699
commit 5352d670c4
22 changed files with 433 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/decompile.rkt
View File

@ -259,7 +259,9 @@
[(struct toplevel (depth pos const? ready?)) [(struct toplevel (depth pos const? ready?))
(decompile-tl expr globs stack closed #f)] (decompile-tl expr globs stack closed #f)]
[(struct varref (tl dummy)) [(struct varref (tl dummy))
`(#%variable-reference ,(decompile-tl tl globs stack closed #t))] `(#%variable-reference ,(if (eq? tl #t)
'<constant-local>
(decompile-tl tl globs stack closed #t)))]
[(struct topsyntax (depth pos midpt)) [(struct topsyntax (depth pos midpt))
(list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)] (list-ref/protect (glob-desc-vars globs) (+ midpt pos) 'topsyntax)]
[(struct primval (id)) [(struct primval (id))

2
collects/compiler/zo-structs.rkt
View File

@ -156,7 +156,7 @@
[body (or/c expr? seq? any/c)])) ; `with-continuation-mark' [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 (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 (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 (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 (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 (define-form-struct (primval expr) ([id exact-nonnegative-integer?])) ; direct preference to a kernel primitive

255
collects/racket/private/kw.rkt
View File

@ -231,6 +231,7 @@
"keyword list: ~e; does not match the length of the value list: " "keyword list: ~e; does not match the length of the value list: "
kws) kws)
kw-vals)) kw-vals))
(let ([normal-args (let ([normal-args
(let loop ([normal-argss (cons normal-args normal-argss)][pos 3]) (let loop ([normal-argss (cons normal-args normal-argss)][pos 3])
(if (null? (cdr normal-argss)) (if (null? (cdr normal-argss))
@ -786,7 +787,8 @@
(syntax-case rhs () (syntax-case rhs ()
[(lam-id . _) [(lam-id . _)
(and (let ([ctx (syntax-local-context)]) (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) (and (list? ctx)
(andmap liberal-define-context? ctx)))) (andmap liberal-define-context? ctx))))
(identifier? #'lam-id) (identifier? #'lam-id)
@ -808,7 +810,7 @@
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(define unpack #,kwimpl)) (define unpack #,kwimpl))
#,(quasisyntax/loc stx #,(quasisyntax/loc stx
(define proc (let ([#,id #,wrap]) #,id))))))))] (define proc #,wrap)))))))]
[_ (plain rhs)])))) [_ (plain rhs)]))))
;; ---------------------------------------- ;; ----------------------------------------
@ -837,9 +839,10 @@
(check-arity (- (length l) 2)) (check-arity (- (length l) 2))
(let ([args (cdr (syntax-e stx))]) (let ([args (cdr (syntax-e stx))])
(syntax-protect (syntax-protect
(or (generate-direct (cdr (if (pair? args) args (syntax-e args))) null) (generate-direct
(quasisyntax/loc stx (cdr (if (pair? args) args (syntax-e args))) null
(#%app . #,args)))))))) (quasisyntax/loc stx
(#%app . #,args))))))))
;; keyword app (maybe) ;; keyword app (maybe)
(let ([exprs (let ([exprs
(let ([kw-ht (make-hasheq)]) (let ([kw-ht (make-hasheq)])
@ -892,16 +895,17 @@
(syntax-protect (syntax-protect
(quasisyntax/loc stx (quasisyntax/loc stx
(let #,(reverse bind-accum) (let #,(reverse bind-accum)
#,(or (generate-direct (cdr args) sorted-kws) #,(generate-direct
(quasisyntax/loc stx (cdr args) sorted-kws
((checked-procedure-check-and-extract struct:keyword-procedure (quasisyntax/loc stx
#,(car args) ((checked-procedure-check-and-extract struct:keyword-procedure
keyword-procedure-extract #,(car args)
'#,(map car sorted-kws) keyword-procedure-extract
#,cnt) '#,(map car sorted-kws)
'#,(map car sorted-kws) #,cnt)
(list #,@(map cdr sorted-kws)) '#,(map car sorted-kws)
. #,(cdr args))))))))] (list #,@(map cdr sorted-kws))
. #,(cdr args))))))))]
[(keyword? (syntax-e (car l))) [(keyword? (syntax-e (car l)))
(loop (cddr l) (loop (cddr l)
(cdr ids) (cdr ids)
@ -920,115 +924,122 @@
kw-pairs)]))))))) kw-pairs)])))))))
(define-syntax (new-app stx) (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) (define-for-syntax (make-keyword-syntax impl-id wrap-id n-req n-opt rest? req-kws all-kws)
(lambda (stx) (make-set!-transformer
(syntax-case stx () (lambda (stx)
[(self arg ...) (syntax-case stx (set!)
(let ([warning [(set! self rhs)
(lambda (msg) (quasisyntax/loc stx (set! #,wrap-id rhs))]
(let ([l (current-logger)]) [(self arg ...)
(when (log-level? l 'warning) (let ([warning
(log-message (lambda (msg)
l (let ([l (current-logger)])
'warning (when (log-level? l 'warning)
(format "~aexpanson detects ~a for: ~a" (log-message
(let ([s (syntax-source stx)] l
[l (syntax-line stx)] 'warning
[c (syntax-column stx)] (format "~aexpanson detects ~a for: ~a"
[p (syntax-position stx)]) (let ([s (syntax-source stx)]
(if s [l (syntax-line stx)]
(if l [c (syntax-column stx)]
(format "~a:~a:~a: " s l c) [p (syntax-position stx)])
(format "~a:::~a: " s l p)) (if s
"")) (if l
msg (format "~a:~a:~a: " s l c)
(syntax-e #'self)) (format "~a:::~a: " s l p))
(current-continuation-marks)))))]) ""))
(if (free-identifier=? #'new-app (datum->syntax stx '#%app)) msg
(parse-app (datum->syntax #f (cons #'new-app stx) stx) (syntax-e #'self))
(lambda (n) (current-continuation-marks)))))])
(when (or (n . < . n-req) (if (free-identifier=? #'new-app (datum->syntax stx '#%app))
(and (not rest?) (parse-app (datum->syntax #f (cons #'new-app stx) stx)
(n . > . (+ n-req n-opt)))) (lambda (n)
(printf "~s\n" (list n n-req n-opt)) (when (or (n . < . n-req)
(warning "wrong number of by-position arguments"))) (and (not rest?)
(lambda (args kw-args) (n . > . (+ n-req n-opt))))
(let* ([args (syntax->list (datum->syntax #f args))] (printf "~s\n" (list n n-req n-opt))
[n (length args)]) (warning "wrong number of by-position arguments")))
(and (not (or (n . < . n-req) (lambda (args kw-args orig)
(and (not rest?) (let* ([args (syntax->list (datum->syntax #f args))]
(n . > . (+ n-req n-opt))))) [n (length args)])
(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws]) (or
(cond (and (not (or (n . < . n-req)
[(null? kw-args) (and (not rest?)
(or (null? req-kws) (n . > . (+ n-req n-opt)))))
(and (let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws])
(warning (cond
(format "missing required keyword ~a" (car req-kws))) [(null? kw-args)
#f))] (or (null? req-kws)
[else (let* ([kw (syntax-e (caar kw-args))] (and
[all-kws (let loop ([all-kws all-kws]) (warning
(cond (format "missing required keyword ~a" (car req-kws)))
[(null? all-kws) null] #f))]
[(keyword<? (car all-kws) kw) [else (let* ([kw (syntax-e (caar kw-args))]
(loop (cdr all-kws))] [all-kws (let loop ([all-kws all-kws])
[else all-kws]))]) (cond
(cond [(null? all-kws) null]
[(or (null? all-kws) [(keyword<? (car all-kws) kw)
(not (eq? kw (car all-kws)))) (loop (cdr all-kws))]
(warning [else all-kws]))])
(format "keyword ~a that is not accepted" kw)) (cond
#f] [(or (null? all-kws)
[(and (pair? req-kws) (not (eq? kw (car all-kws))))
(eq? kw (car req-kws))) (warning
(loop (cdr kw-args) (cdr req-kws) (cdr all-kws))] (format "keyword ~a that is not accepted" kw))
[(and (pair? req-kws) #f]
(keyword<? (car req-kws) (car all-kws))) [(and (pair? req-kws)
(warning (eq? kw (car req-kws)))
(format "missing required keyword ~a" (car req-kws))) (loop (cdr kw-args) (cdr req-kws) (cdr all-kws))]
#f] [(and (pair? req-kws)
[else (keyword<? (car req-kws) (car all-kws)))
(loop (cdr kw-args) req-kws (cdr all-kws))]))])) (warning
(quasisyntax/loc stx (format "missing required keyword ~a" (car req-kws)))
(#,impl-id #f]
;; keyword arguments: [else
#,@(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws]) (loop (cdr kw-args) req-kws (cdr all-kws))]))]))
(cond (quasisyntax/loc stx
[(null? all-kws) null] (if (variable-reference-constant? (#%variable-reference #,wrap-id))
[(and (pair? kw-args) (#,impl-id
(eq? (syntax-e (caar kw-args)) (car all-kws))) ;; keyword arguments:
(if (and (pair? req-kws) #,@(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws])
(eq? (car req-kws) (car all-kws))) (cond
(cons (cdar kw-args) [(null? all-kws) null]
(loop (cdr kw-args) (cdr req-kws) (cdr all-kws))) [(and (pair? kw-args)
(list* (cdar kw-args) (eq? (syntax-e (caar kw-args)) (car all-kws)))
#'#t (if (and (pair? req-kws)
(loop (cdr kw-args) req-kws (cdr all-kws))))] (eq? (car req-kws) (car all-kws)))
[else (cons (cdar kw-args)
(list* #'#f (loop (cdr kw-args) (cdr req-kws) (cdr all-kws)))
#'#f (list* (cdar kw-args)
(loop kw-args req-kws (cdr all-kws)))])) #'#t
;; required arguments: (loop (cdr kw-args) req-kws (cdr all-kws))))]
#,@(let loop ([i n-req] [args args]) [else
(if (zero? i) (list* #'#f
null #'#f
(cons (car args) (loop kw-args req-kws (cdr all-kws)))]))
(loop (sub1 i) (cdr args))))) ;; required arguments:
;; optional arguments: #,@(let loop ([i n-req] [args args])
#,@(let loop ([i n-opt] [args (list-tail args n-req)]) (if (zero? i)
(cond null
[(zero? i) null] (cons (car args)
[(null? args) (list* #'#f #'#f (loop (sub1 i) null))] (loop (sub1 i) (cdr args)))))
[else ;; optional arguments:
(list* (car args) #'#t (loop (sub1 i) (cdr args)))])) #,@(let loop ([i n-opt] [args (list-tail args n-req)])
;; rest args: (cond
#,@(if rest? [(zero? i) null]
#`((list #,@(list-tail args (min (length args) (+ n-req n-opt))))) [(null? args) (list* #'#f #'#f (loop (sub1 i) null))]
null))))))) [else
(datum->syntax stx (cons wrap-id #'(arg ...)) stx stx)))] (list* (car args) #'#t (loop (sub1 i) (cdr args)))]))
[_ wrap-id]))) ;; rest args:
#,@(if rest?
#`((list #,@(list-tail args (min (length args) (+ n-req n-opt)))))
null))
#,orig)))
orig))))
(datum->syntax stx (cons wrap-id #'(arg ...)) stx stx)))]
[_ wrap-id]))))
;; Checks given kws against expected. Result is ;; Checks given kws against expected. Result is
;; (values missing-kw extra-kw), where both are #f if ;; (values missing-kw extra-kw), where both are #f if

9
collects/scribblings/raco/zo-struct.scrbl
View File

@ -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 After each expression in @racket[seq] is evaluated, the stack is
restored to its depth from before evaluating the expression.} restored to its depth from before evaluating the expression.}
@defstruct+[(varref expr) ([toplevel toplevel?] [dummy toplevel?])]{ @defstruct+[(varref expr) ([toplevel (or/c toplevel? #t)]
Represents a @racket[#%variable-reference] form. The @racket[dummy] field [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 accesses a variable bucket that strongly references its namespace (as
opposed to a normal variable bucket, which only weakly references its opposed to a normal variable bucket, which only weakly references its
namespace).} namespace); it can be @racket[#f].}
@defstruct+[(assign expr) @defstruct+[(assign expr)
([id toplevel?] ([id toplevel?]

11
collects/scribblings/reference/namespaces.scrbl
View File

@ -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} Return @racket[#t] if @racket[v] is a @tech{variable reference}
produced by @racket[#%variable-reference], @racket[#f] otherwise.} 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?]) @defproc[(variable-reference->empty-namespace [varref variable-reference?])
namespace?]{ namespace?]{
@ -402,3 +411,5 @@ result is @racket[#f].}
exact-nonnegative-integer?]{ exact-nonnegative-integer?]{
Returns the @tech{phase} of the variable referenced by @racket[varref].} Returns the @tech{phase} of the variable referenced by @racket[varref].}

10
collects/scribblings/reference/stx-trans.scrbl
View File

@ -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 @tech{liberal expansion} of @racket[define] forms, the generated value
should be an instance of a structure with a true value for should be an instance of a structure with a true value for
@racket[prop:liberal-define-context]. If the internal-definition @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 should contain only the generated value; if the internal-definition
context is meant to splice into an immediately enclosing context, then context is meant to splice into an immediately enclosing context, then
when @racket[syntax-local-context] produces a list, @racket[cons] the 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 An instance of a structure type with a true value for the
@racket[prop:liberal-define-context] property can be used as an @racket[prop:liberal-define-context] property can be used as an
element of an @tech{internal-definition context} representation in the 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 @racket[local-expand]. Such a value indicates that the context
supports @deftech{liberal expansion} of @racket[define] forms into supports @deftech{liberal expansion} of @racket[define] forms into
potentially multiple @racket[define-values] and 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 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.} @racket[prop:liberal-define-context] property, @racket[#f] otherwise.}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------

15
collects/scribblings/reference/syntax.scrbl
View File

@ -1334,11 +1334,11 @@ introduces @racketidfont{#%top} identifiers.
(#%variable-reference)]]{ (#%variable-reference)]]{
Produces an opaque @deftech{variable reference} value representing the Produces an opaque @deftech{variable reference} value representing the
@tech{location} of @racket[id], which must be bound as a @tech{top-level @tech{location} of @racket[id], which must be bound as a variable. If
variable} or @tech{module-level variable}. If no @racket[id] is no @racket[id] is supplied, the resulting value refers to an
supplied, the resulting value refers to an ``anonymous'' variable ``anonymous'' variable defined within the enclosing context (i.e.,
defined within the enclosing context (i.e., within the enclosing within the enclosing module, or at the top level if the form is not
module, or at the top level if the form is not inside a module). inside a module).
A @tech{variable reference} can be used with A @tech{variable reference} can be used with
@racket[variable-reference->empty-namespace], @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 top-level mapping of @racket[id] (in the @techlink{namespace} linked
with the compiled definition) is set to the binding at the same time. 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[ @defexamples[
(define x 10) (define x 10)
x x

25
collects/tests/scriblib/bibtex.rkt
View File

@ -9,15 +9,16 @@
(let () (let ()
(define-bibtex-cite example.bib (define-bibtex-cite example.bib
~cite-id citet-id generate-bibliography-id) ~cite-id citet-id generate-bibliography-id)
(test
(~cite-id "cryptoeprint:2000:067") (~cite-id "cryptoeprint:2000:067")
(~cite-id "Tobin-Hochstadt:2011fk") (~cite-id "Tobin-Hochstadt:2011fk")
(~cite-id "cryptoeprint:2000:067" "Tobin-Hochstadt:2011fk") (~cite-id "cryptoeprint:2000:067" "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 "cryptoeprint:2000:067")
(citet-id "Tobin-Hochstadt:2011fk") (citet-id "Tobin-Hochstadt:2011fk")
(citet-id "Tobin-Hochstadt:2011fk" "Tobin-Hochstadt:2011fk") (citet-id "Tobin-Hochstadt:2011fk" "Tobin-Hochstadt:2011fk")
(citet-id "Tobin-Hochstadt:2011fk Tobin-Hochstadt:2011fk") (citet-id "Tobin-Hochstadt:2011fk Tobin-Hochstadt:2011fk")
(generate-bibliography-id)))) (generate-bibliography-id)))

7
src/racket/src/compenv.c
View File

@ -125,6 +125,7 @@ void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec,
/* should be always NULL */ /* should be always NULL */
dest[i].observer = src[drec].observer; dest[i].observer = src[drec].observer;
dest[i].pre_unwrapped = 0; dest[i].pre_unwrapped = 0;
dest[i].testing_constantness = 0;
dest[i].env_already = 0; dest[i].env_already = 0;
dest[i].comp_flags = src[drec].comp_flags; 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].value_name = scheme_false;
dest[i].observer = src[drec].observer; dest[i].observer = src[drec].observer;
dest[i].pre_unwrapped = 0; dest[i].pre_unwrapped = 0;
dest[i].testing_constantness = 0;
dest[i].env_already = 0; dest[i].env_already = 0;
dest[i].comp_flags = src[drec].comp_flags; 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].value_name = scheme_false;
lam[dlrec].observer = src[drec].observer; lam[dlrec].observer = src[drec].observer;
lam[dlrec].pre_unwrapped = 0; lam[dlrec].pre_unwrapped = 0;
lam[dlrec].testing_constantness = 0;
lam[dlrec].env_already = 0; lam[dlrec].env_already = 0;
lam[dlrec].comp_flags = src[drec].comp_flags; 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 = COMPILE_DATA(frame)->use[i];
u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING)) u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING))
? CONSTRAINED_USE ? CONSTRAINED_USE
: ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_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 ? WAS_SET_BANGED
: 0)); : 0));

13
src/racket/src/compile.c
View File

@ -1397,11 +1397,13 @@ ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec,
if (rec[drec].comp) { if (rec[drec].comp) {
var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0); 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; SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED;
} }
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) {
/* ok */
} else { } 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) if (rec[drec].comp)
@ -3259,6 +3261,7 @@ do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env,
rec1.value_name = NULL; rec1.value_name = NULL;
rec1.observer = NULL; rec1.observer = NULL;
rec1.pre_unwrapped = 0; rec1.pre_unwrapped = 0;
rec1.testing_constantness = 0;
rec1.env_already = 0; rec1.env_already = 0;
rec1.comp_flags = rec[drec].comp_flags; 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.value_name = NULL;
mrec.observer = NULL; mrec.observer = NULL;
mrec.pre_unwrapped = 0; mrec.pre_unwrapped = 0;
mrec.testing_constantness = 0;
mrec.env_already = 0; mrec.env_already = 0;
mrec.comp_flags = rec[drec].comp_flags; mrec.comp_flags = rec[drec].comp_flags;
@ -4087,6 +4091,11 @@ scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env,
else else
comp_first = p; comp_first = p;
comp_last = 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); scheme_merge_compile_recs(rec, drec, recs, len);

8
src/racket/src/cstartup.inc
View File

@ -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, 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,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, 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, 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,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, 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, 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,148,75,0,0,16,0,96,11,11,8,240,148, 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, 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, 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, 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, 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, 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, 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, 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, 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, 16,0,159,36,20,112,159,36,16,1,11,16,0,20,26,142,2,1,2,1,29,

27
src/racket/src/env.c
View File

@ -46,6 +46,7 @@ int scheme_get_allow_set_undefined() { return scheme_allow_set_undefined; }
SHARED_OK int scheme_starting_up; SHARED_OK int scheme_starting_up;
/* globals READ-ONLY SHARED */ /* globals READ-ONLY SHARED */
Scheme_Object *scheme_varref_const_p_proc;
READ_ONLY static Scheme_Object *kernel_symbol; READ_ONLY static Scheme_Object *kernel_symbol;
READ_ONLY static Scheme_Env *kernel_env; READ_ONLY static Scheme_Env *kernel_env;
READ_ONLY static Scheme_Env *unsafe_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_namespace(int, Scheme_Object *[]);
static Scheme_Object *variable_top_level_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_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 *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(int argc, Scheme_Object *argv[]);
static Scheme_Object *local_exp_time_value_one(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->namespace", variable_top_level_namespace, 1, 1, env);
GLOBAL_PRIM_W_ARITY("variable-reference->phase", variable_phase, 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-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", local_exp_time_value, 1, 3, env);
GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 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); 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[]) static Scheme_Object *variable_p(int argc, Scheme_Object *argv[])
{ {
Scheme_Env *env; Scheme_Env *env;

16
src/racket/src/eval.c
View File

@ -1832,18 +1832,24 @@ ref_execute (Scheme_Object *data)
{ {
Scheme_Prefix *toplevels; Scheme_Prefix *toplevels;
Scheme_Object *o; Scheme_Object *o;
Scheme_Bucket *var; Scheme_Object *var;
Scheme_Object *tl = SCHEME_PTR1_VAL(data); Scheme_Object *tl = SCHEME_PTR1_VAL(data);
Scheme_Env *env; Scheme_Env *env;
toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)];
var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; var = toplevels->a[SCHEME_TOPLEVEL_POS(tl)];
env = scheme_environment_from_dummy(SCHEME_CDR(data)); if (SCHEME_FALSEP(SCHEME_PTR2_VAL(data)))
env = NULL;
else
env = scheme_environment_from_dummy(SCHEME_PTR2_VAL(data));
o = scheme_alloc_object(); o = scheme_alloc_object();
o->type = scheme_global_ref_type; o->type = scheme_global_ref_type;
SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; SCHEME_PTR1_VAL(o) = var;
SCHEME_PTR2_VAL(o) = (Scheme_Object *)env; SCHEME_PTR2_VAL(o) = (env ? (Scheme_Object *)env : scheme_false);
if (SCHEME_PAIR_FLAGS(data) & 0x1)
SCHEME_PAIR_FLAGS(o) |= 0x1;
return o; return o;
} }

30
src/racket/src/jit.c
View File

@ -59,6 +59,16 @@ static Scheme_Object *make_global_ref(Scheme_Object *var, Scheme_Object *dummy)
return o; 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 */ /* 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); finish_branch_with_true(jitter, for_branch);
else { else {
Scheme_Object *dummy; Scheme_Object *dummy;
int pos; int pos, is_const;
mz_rs_sync(); mz_rs_sync();
is_const = (SCHEME_PAIR_FLAGS(obj) & 0x1);
dummy = SCHEME_PTR2_VAL(obj); dummy = SCHEME_PTR2_VAL(obj);
obj = SCHEME_PTR1_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(); CHECK_LIMIT();
/* Load dummy bucket: */ /* Load dummy bucket: */
pos = SCHEME_TOPLEVEL_POS(dummy); if (SCHEME_FALSEP(dummy)) {
jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos])); (void)jit_movi_p(JIT_R2, scheme_false);
CHECK_LIMIT(); } 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(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
mz_prepare(2); 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); jit_pusharg_p(JIT_R1);
{ {
GC_CAN_IGNORE jit_insn *refr; 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(); CHECK_LIMIT();
jit_retval(target); jit_retval(target);

2
src/racket/src/jit_ts.c
View File

@ -17,6 +17,7 @@
#ifdef JIT_TS_PROCS #ifdef JIT_TS_PROCS
define_ts_bsi_v(call_set_global_bucket, FSRC_MARKS) 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_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_iiS_v(lexical_binding_wrong_return_arity, FSRC_MARKS)
define_ts_siS_v(wrong_argument_count, FSRC_MARKS) define_ts_siS_v(wrong_argument_count, FSRC_MARKS)
# ifdef JIT_PRECISE_GC # 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_call_set_global_bucket call_set_global_bucket
# define ts_scheme_make_envunbox scheme_make_envunbox # define ts_scheme_make_envunbox scheme_make_envunbox
# define ts_make_global_ref make_global_ref # 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_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity
# define ts_call_wrong_return_arity call_wrong_return_arity # define ts_call_wrong_return_arity call_wrong_return_arity
# define ts_scheme_unbound_global scheme_unbound_global # define ts_scheme_unbound_global scheme_unbound_global

64
src/racket/src/jitinline.c
View File

@ -425,6 +425,63 @@ static int is_cXr_prim(const char *name)
return !name[i+1]; 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, static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator,
Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3); 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)) if (!SCHEME_PRIMP(rator))
return 0; return 0;
@ -1659,7 +1722,6 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
} }
} }
if (!SCHEME_PRIMP(rator)) if (!SCHEME_PRIMP(rator))
return 0; return 0;

15
src/racket/src/marshal.c
View File

@ -450,7 +450,15 @@ static Scheme_Object *write_set_bang(Scheme_Object *obj)
Scheme_Object *write_varref(Scheme_Object *o) 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) Scheme_Object *read_varref(Scheme_Object *o)
@ -461,8 +469,11 @@ Scheme_Object *read_varref(Scheme_Object *o)
data = scheme_alloc_object(); data = scheme_alloc_object();
data->type = scheme_varref_form_type; data->type = scheme_varref_form_type;
SCHEME_PTR1_VAL(data) = SCHEME_CAR(o);
SCHEME_PTR2_VAL(data) = SCHEME_CDR(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; return data;
} }

65
src/racket/src/optimize.c
View File

@ -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 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, 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); 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_info_used_top(Optimize_Info *info);
static void optimize_mutated(Optimize_Info *info, int pos); 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) if ((SAME_OBJ(scheme_values_func, app->rator)
|| SAME_OBJ(scheme_list_star_proc, app->rator)) || SAME_OBJ(scheme_list_star_proc, app->rator))
&& (scheme_omittable_expr(app->rand, 1, -1, 0, info, -1) && (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 * static Scheme_Object *
ref_optimize(Scheme_Object *data, Optimize_Info *info, int context) 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->preserves_marks = 1;
info->single_result = 1; info->single_result = 1;
@ -2776,6 +2800,28 @@ ref_shift(Scheme_Object *data, int delta, int after_depth)
return data; 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 * static Scheme_Object *
apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) 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: case scheme_require_form_type:
return NULL; return NULL;
case scheme_varref_form_type: case scheme_varref_form_type:
return NULL; return ref_clone(dup_ok, expr, info, delta, closure_depth);
case scheme_set_bang_type: case scheme_set_bang_type:
return set_clone(dup_ok, expr, info, delta, closure_depth); return set_clone(dup_ok, expr, info, delta, closure_depth);
case scheme_apply_values_type: 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, 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 *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; Scheme_Object *p, *n;
int delta = 0; 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)) if (info->use && (info->use[pos] & 0x1))
*is_mutated = 1; *is_mutated = 1;
if (just_test) return NULL;
p = info->consts; p = info->consts;
while (p) { while (p) {
n = SCHEME_VEC_ELS(p)[1]; 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, n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL,
once_used_ok && !disrupt_single_use, context, once_used_ok && !disrupt_single_use, context,
potential_size, disrupt_single_use, NULL); potential_size, disrupt_single_use, NULL, 0);
if (!n) { if (!n) {
/* Return shifted reference to other local: */ /* 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) 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, 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) static int optimize_info_is_ready(Optimize_Info *info, int pos)
{ {
int closure_offset, single_use, ready = 1; 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; 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) static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags)
{ {
Optimize_Info *naya; Optimize_Info *naya;

26
src/racket/src/resolve.c
View File

@ -324,7 +324,14 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_
merge_resolve_tl_map(orig_info, info); merge_resolve_tl_map(orig_info, info);
set_app2_eval_type(app); 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; return (Scheme_Object *)app;
} }
@ -661,10 +668,23 @@ ref_resolve(Scheme_Object *data, Resolve_Info *rslv)
{ {
Scheme_Object *v; 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); v = scheme_resolve_expr(SCHEME_PTR2_VAL(data), rslv);
SCHEME_PTR2_VAL(data) = v; 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; return data;
} }

2
src/racket/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1 #define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1029 #define EXPECTED_PRIM_COUNT 1030
#define EXPECTED_UNSAFE_COUNT 78 #define EXPECTED_UNSAFE_COUNT 78
#define EXPECTED_FLFXNUM_COUNT 68 #define EXPECTED_FLFXNUM_COUNT 68
#define EXPECTED_FUTURES_COUNT 11 #define EXPECTED_FUTURES_COUNT 11

2
src/racket/src/schpriv.h
View File

@ -362,6 +362,7 @@ extern Scheme_Object *scheme_box_proc;
extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_call_with_values_proc;
extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_make_struct_type_proc;
extern Scheme_Object *scheme_current_inspector_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_define_values_syntax, *scheme_define_syntaxes_syntax;
extern Scheme_Object *scheme_lambda_syntax; extern Scheme_Object *scheme_lambda_syntax;
@ -2173,6 +2174,7 @@ typedef struct Scheme_Compile_Expand_Info
char dont_mark_local_use; char dont_mark_local_use;
char resolve_module_ids; char resolve_module_ids;
char pre_unwrapped; char pre_unwrapped;
char testing_constantness;
int depth; int depth;
int env_already; int env_already;
} Scheme_Compile_Expand_Info; } Scheme_Compile_Expand_Info;

7
src/racket/src/validate.c
View File

@ -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, validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
0); 0);
validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, if (!SCHEME_FALSEP(SCHEME_PTR2_VAL(data)))
num_toplevels, num_stxes, num_lifts, tl_use_map, validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta,
0); num_toplevels, num_stxes, num_lifts, tl_use_map,
0);
} }
static void apply_values_validate(Scheme_Object *data, Mz_CPort *port, static void apply_values_validate(Scheme_Object *data, Mz_CPort *port,