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?))
(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)
'<constant-local>
(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))

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

@ -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

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

@ -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,7 +839,8 @@
(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)
(generate-direct
(cdr (if (pair? args) args (syntax-e args))) null
(quasisyntax/loc stx
(#%app . #,args))))))))
;; keyword app (maybe)
@ -892,7 +895,8 @@
(syntax-protect
(quasisyntax/loc stx
(let #,(reverse bind-accum)
#,(or (generate-direct (cdr args) sorted-kws)
#,(generate-direct
(cdr args) sorted-kws
(quasisyntax/loc stx
((checked-procedure-check-and-extract struct:keyword-procedure
#,(car args)
@ -920,11 +924,14 @@
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)
(make-set!-transformer
(lambda (stx)
(syntax-case stx ()
(syntax-case stx (set!)
[(set! self rhs)
(quasisyntax/loc stx (set! #,wrap-id rhs))]
[(self arg ...)
(let ([warning
(lambda (msg)
@ -954,9 +961,10 @@
(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)
(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)))))
@ -992,6 +1000,7 @@
[else
(loop (cdr kw-args) req-kws (cdr all-kws))]))]))
(quasisyntax/loc stx
(if (variable-reference-constant? (#%variable-reference #,wrap-id))
(#,impl-id
;; keyword arguments:
#,@(let loop ([kw-args kw-args] [req-kws req-kws] [all-kws all-kws])
@ -1026,9 +1035,11 @@
;; rest args:
#,@(if rest?
#`((list #,@(list-tail args (min (length args) (+ n-req n-opt)))))
null)))))))
null))
#,orig)))
orig))))
(datum->syntax stx (cons wrap-id #'(arg ...)) stx stx)))]
[_ wrap-id])))
[_ wrap-id]))))
;; Checks given kws against expected. Result is
;; (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
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?]

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}
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].}

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
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.}
@; ----------------------------------------------------------------------

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

@ -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

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

@ -9,7 +9,7 @@
(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")
@ -20,4 +20,5 @@
(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 */
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));

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) {
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);

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,
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,

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;
/* 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;

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

@ -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;
}

22
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;
}
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: */
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,8 +2340,12 @@ 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;
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);
VALIDATE_RESULT(target);

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

@ -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

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

@ -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;

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)
{
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;
}

63
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 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,8 +2768,17 @@ 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)
{
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;
info->size++;
@ -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;

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

@ -325,6 +325,13 @@ static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_
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,11 +668,24 @@ 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;
}

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

@ -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

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_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;

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

@ -317,6 +317,7 @@ 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);
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);