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

add procedure-specialize

Browse Source 
The `procedure-specialize` function is the identity function, but it
provides a hint to the JIT to compile the body of a closure
specifically for the values in the closure (as opposed to compiling
the body generically for all closure instances).

This hint is useful to the contract system, where a predicate
is coerced to a projection with

 (lambda (p?)
   (procedure-specialize
    (lambda (v)
      (if (p? v)
          v
          ....))))

Specializing the projection to a given `p?` allows primitive
predicates to be JIT-inlined in the projection's body.
This commit is contained in:
Matthew Flatt 2015-12-23 15:41:46 -07:00
parent 592ae853e3
commit db0a6de1d2
14 changed files with 1805 additions and 1643 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/base/info.rkt
View File

@ -12,7 +12,7 @@
(define collection 'multi)
(define version "6.3.0.9")
(define version "6.3.0.10")
(define deps `("racket-lib"
["racket" #:version ,version]))

15
pkgs/racket-doc/scribblings/reference/procedures.scrbl
View File

@ -487,6 +487,21 @@ field of @racket[v] applied to @racket[v1] and @racket[v2] produces
and @racket[v2], and its result is returned by
@racket[checked-procedure-check-and-extract].}
@defproc[(procedure-specialize [proc procedure?])
procedure?]{
Returns @racket[proc] or its equivalent, but provides a hint to the
run-time system that it should spend extra time and memory to
specialize the implementation of @racket[proc].
The hint is currently used when @racket[proc] is the value of a
@racket[lambda] or @racket[case-lambda] form that references variables
bound outside of the @racket[lambda] or @racket[case-lambda], and when
@racket[proc] has not been previously applied.
@history[#:added "6.3.0.10"]}
@; ----------------------------------------------------------------------
@section{Reflecting on Primitives}

3
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -314,7 +314,8 @@
#,(if post post #'#f)
#,(if rngs #'(list rb ...) #'#f))]))
#`(λ (blame f regb ... optb ... kb ... okb ... rb ... #,@(if rest (list #'restb) '()))
#,body-proc)))))
(procedure-specialize
#,body-proc))))))
(define (make-checking-proc f blame pre
original-mandatory-kwds kbs

15
racket/collects/racket/contract/private/guts.rkt
View File

@ -613,13 +613,14 @@
(define p? (predicate-contract-pred ctc))
(define name (predicate-contract-name ctc))
(λ (blame)
(λ (v neg-party)
(if (p? v)
v
(raise-blame-error blame v #:missing-party neg-party
'(expected: "~s" given: "~e")
name
v)))))
(procedure-specialize
(λ (v neg-party)
(if (p? v)
v
(raise-blame-error blame v #:missing-party neg-party
'(expected: "~s" given: "~e")
name
v))))))
#:generate (λ (ctc)
(let ([generate (predicate-contract-generate ctc)])
(cond

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

File diff suppressed because it is too large Load Diff

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

@ -179,6 +179,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_rename(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_to_method(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *impersonate_procedure(int argc, Scheme_Object *argv[]);
static Scheme_Object *chaperone_procedure_star(int argc, Scheme_Object *argv[]);
@ -593,6 +594,11 @@ scheme_init_fun (Scheme_Env *env)
"procedure-closure-contents-eq?",
2, 2, 1),
env);
scheme_add_global_constant("procedure-specialize",
scheme_make_prim_w_arity(procedure_specialize,
"procedure-specialize",
1, 1),
env);
scheme_add_global_constant("chaperone-procedure",
scheme_make_prim_w_arity(chaperone_procedure,
"chaperone-procedure",
@ -3425,6 +3431,26 @@ static Scheme_Object *procedure_equal_closure_p(int argc, Scheme_Object *argv[])
return scheme_false;
}
static Scheme_Object *procedure_specialize(int argc, Scheme_Object *argv[])
{
if (!SCHEME_PROCP(argv[0]))
scheme_wrong_contract("procedure-specialize", "procedure?", 0, argc, argv);
if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_native_closure_type)) {
Scheme_Native_Closure *nc = (Scheme_Native_Closure *)argv[0];
if ((nc->code->start_code == scheme_on_demand_jit_code)
&& !(SCHEME_NATIVE_CLOSURE_DATA_FLAGS(nc->code) & NATIVE_SPECIALIZED)) {
Scheme_Native_Closure_Data *data;
data = MALLOC_ONE_TAGGED(Scheme_Native_Closure_Data);
memcpy(data, nc->code, sizeof(Scheme_Native_Closure_Data));
SCHEME_NATIVE_CLOSURE_DATA_FLAGS(data) |= NATIVE_SPECIALIZED;
nc->code = data;
}
}
return argv[0];
}
static Scheme_Object *do_chaperone_procedure(const char *name, const char *whating,
int is_impersonator, int pass_self,
int argc, Scheme_Object *argv[])

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

@ -453,18 +453,16 @@ Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc
return globs->a[pos];
}
Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, int extra_push)
static Scheme_Object *extract_closure_local(int pos, mz_jit_state *jitter, int get_constant)
{
int pos;
pos = SCHEME_LOCAL_POS(obj);
pos -= extra_push;
if (pos >= jitter->self_pos - jitter->self_to_closure_delta) {
pos -= (jitter->self_pos - jitter->self_to_closure_delta);
if (pos < jitter->nc->code->u2.orig_code->closure_size) {
/* in the closure */
return jitter->nc->vals[pos];
} else {
if (!get_constant
|| (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED))
return jitter->nc->vals[pos];
} else if (!get_constant) {
/* maybe an example argument... which is useful when
the enclosing function has been lifted, converting
a closure element into an argument */
@ -477,6 +475,43 @@ Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *ji
return NULL;
}
Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter,
int extra_push, int get_constant)
{
int pos;
pos = SCHEME_LOCAL_POS(obj);
pos -= extra_push;
return extract_closure_local(pos, jitter, get_constant);
}
Scheme_Object *scheme_specialize_to_constant(Scheme_Object *obj, mz_jit_state *jitter, int extra_push)
{
Scheme_Object *c;
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) {
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)) {
c = scheme_extract_closure_local(obj, jitter, extra_push, 1);
if (c) {
MZ_ASSERT(SCHEME_TYPE(c) != scheme_prefix_type);
return c;
}
}
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_toplevel_type)) {
c = scheme_extract_global(obj, jitter->nc, 0);
if (c) {
c = ((Scheme_Bucket *)c)->val;
if (c)
return c;
}
}
}
return obj;
}
int scheme_native_closure_preserves_marks(Scheme_Object *p)
{
Scheme_Native_Closure_Data *ndata = ((Scheme_Native_Closure *)p)->code;
@ -496,6 +531,8 @@ int scheme_native_closure_preserves_marks(Scheme_Object *p)
int scheme_is_noncm(Scheme_Object *a, mz_jit_state *jitter, int depth, int stack_start)
{
a = scheme_specialize_to_constant(a, jitter, stack_start);
if (SCHEME_PRIMP(a)) {
int opts;
opts = ((Scheme_Prim_Proc_Header *)a)->flags & SCHEME_PRIM_OPT_MASK;
@ -601,27 +638,40 @@ int scheme_is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st
break;
case scheme_application_type:
if (scheme_inlined_nary_prim(((Scheme_App_Rec *)obj)->args[0], obj, jitter)
&& !SAME_OBJ(((Scheme_App_Rec *)obj)->args[0], scheme_values_func))
return 1;
if (just_markless) {
return scheme_is_noncm(((Scheme_App_Rec *)obj)->args[0], jitter, depth,
stack_start + ((Scheme_App_Rec *)obj)->num_args);
{
Scheme_Object *rator;
rator = scheme_specialize_to_constant(((Scheme_App_Rec *)obj)->args[0], jitter,
stack_start + ((Scheme_App_Rec *)obj)->num_args);
if (scheme_inlined_nary_prim(rator, obj, jitter)
&& !SAME_OBJ(rator, scheme_values_func))
return 1;
if (just_markless) {
return scheme_is_noncm(rator, jitter, depth,
stack_start + ((Scheme_App_Rec *)obj)->num_args);
}
}
break;
case scheme_application2_type:
if (scheme_inlined_unary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter))
return 1;
else if (just_markless) {
return scheme_is_noncm(((Scheme_App2_Rec *)obj)->rator, jitter, depth, stack_start + 1);
{
Scheme_Object *rator;
rator = scheme_specialize_to_constant(((Scheme_App2_Rec *)obj)->rator, jitter, stack_start + 1);
if (scheme_inlined_unary_prim(rator, obj, jitter))
return 1;
else if (just_markless) {
return scheme_is_noncm(rator, jitter, depth, stack_start + 1);
}
}
break;
case scheme_application3_type:
if (scheme_inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter)
&& !SAME_OBJ(((Scheme_App2_Rec *)obj)->rator, scheme_values_func))
return 1;
else if (just_markless) {
return scheme_is_noncm(((Scheme_App3_Rec *)obj)->rator, jitter, depth, stack_start + 2);
{
Scheme_Object *rator;
rator = scheme_specialize_to_constant(((Scheme_App3_Rec *)obj)->rator, jitter, stack_start + 2);
if (scheme_inlined_binary_prim(rator, obj, jitter)
&& !SAME_OBJ(rator, scheme_values_func))
return 1;
else if (just_markless) {
return scheme_is_noncm(rator, jitter, depth, stack_start + 2);
}
}
break;
@ -1177,7 +1227,7 @@ static int generate_closure(Scheme_Closure_Data *data,
jit_movi_l(JIT_R1, init_word);
jit_str_l(JIT_R0, JIT_R1);
}
scheme_mz_load_retained(jitter, JIT_R1, code);
scheme_mz_load_retained(jitter, JIT_R1, code, 0);
jit_stxi_p((intptr_t)&((Scheme_Native_Closure *)0x0)->code, JIT_R0, JIT_R1);
return 1;
@ -1187,7 +1237,7 @@ static int generate_closure(Scheme_Closure_Data *data,
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
mz_prepare(1);
scheme_mz_load_retained(jitter, JIT_R0, code);
scheme_mz_load_retained(jitter, JIT_R0, code, 0);
jit_pusharg_p(JIT_R0);
{
GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES;
@ -1337,7 +1387,7 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
mz_prepare(1);
scheme_mz_load_retained(jitter, JIT_R0, ndata);
scheme_mz_load_retained(jitter, JIT_R0, ndata, 0);
jit_pusharg_p(JIT_R0);
{
GC_CAN_IGNORE jit_insn *refr USED_ONLY_FOR_FUTURES;
@ -1686,6 +1736,9 @@ static int generate_branch(Scheme_Object *obj, mz_jit_state *jitter, int is_tail
}
CHECK_LIMIT();
if (old_self_pos != jitter->self_pos)
scheme_signal_error("internal error: self position moved across test");
save_ubd = jitter->unbox_depth;
scheme_mz_unbox_restore(jitter, &ubs);
@ -1923,6 +1976,8 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
}
#endif
obj = scheme_specialize_to_constant(obj, jitter, 0);
orig_target = target;
result_ignored = (target < 0);
if (target < 0) target = JIT_R0;
@ -1948,12 +2003,20 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
START_JIT_DATA();
LOG_IT(("top-level\n"));
mz_rs_sync_fail_branch();
/* Load global array: */
pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj));
mz_rs_ldxi(JIT_R2, pos);
/* Load bucket: */
pos = SCHEME_TOPLEVEL_POS(obj);
jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos]));
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED) {
/* Must be a top-level that is not yet defined. */
Scheme_Object *b;
mz_rs_sync_fail_branch();
b = scheme_extract_global(obj, jitter->nc, 0);
scheme_mz_load_retained(jitter, JIT_R2, b, 1);
} else {
/* Load global array: */
pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj));
mz_rs_ldxi(JIT_R2, pos);
/* Load bucket: */
pos = SCHEME_TOPLEVEL_POS(obj);
jit_ldxi_p(JIT_R2, JIT_R2, &(((Scheme_Prefix *)0x0)->a[pos]));
}
/* Extract bucket value */
jit_ldxi_p(target, JIT_R2, &(SCHEME_VAR_BUCKET(0x0)->val));
CHECK_LIMIT();
@ -2054,15 +2117,23 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
case scheme_local_unbox_type:
{
int pos;
Scheme_Object *specialized = NULL;
START_JIT_DATA();
LOG_IT(("unbox local\n"));
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED)
specialized = scheme_extract_closure_local(obj, jitter, 0, 1);
pos = mz_remap(SCHEME_LOCAL_POS(obj));
if (!result_ignored) {
mz_rs_ldxi(JIT_R0, pos);
if (specialized)
scheme_mz_load_retained(jitter, JIT_R0, specialized, 1);
else
mz_rs_ldxi(JIT_R0, pos);
jit_ldr_p(target, JIT_R0);
}
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ) {
if ((SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ)
&& !specialized) {
LOG_IT(("clear-on-read\n"));
mz_rs_stxi(pos, JIT_RUNSTACK);
}
@ -2256,6 +2327,9 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
v = SCHEME_PTR1_VAL(obj);
p = SCHEME_PTR2_VAL(obj);
v = scheme_specialize_to_constant(v, jitter, 0);
p = scheme_specialize_to_constant(p, jitter, 0);
scheme_generate_non_tail(v, jitter, 0, 1, 0);
CHECK_LIMIT();
@ -2727,13 +2801,20 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
if (lv->count == 1) {
/* Expect one result: */
Scheme_Object *specialized = NULL;
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED)
specialized = extract_closure_local(lv->position, jitter, 1);
scheme_generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */
CHECK_LIMIT();
if (ab) {
pos = mz_remap(lv->position);
mz_rs_ldxi(JIT_R2, pos);
if (specialized)
scheme_mz_load_retained(jitter, JIT_R2, specialized, 1);
else
mz_rs_ldxi(JIT_R2, pos);
jit_str_p(JIT_R2, JIT_R0);
} else {
MZ_ASSERT(!specialized);
pos = mz_remap(lv->position);
mz_rs_stxi(pos, JIT_R0);
}
@ -3206,7 +3287,7 @@ int scheme_generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int w
}
}
scheme_mz_load_retained(jitter, target, obj);
scheme_mz_load_retained(jitter, target, obj, 0);
END_JIT_DATA(19);
return 1;
@ -3347,6 +3428,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
void *retain_code = NULL;
#endif
int i, r, cnt, has_rest, is_method, num_params, to_args, argc, argv_delta;
int specialized;
Scheme_Object **argv;
start_code = jit_get_ip();
@ -3549,26 +3631,32 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
to_args = 0;
#endif
specialized = SCHEME_NATIVE_CLOSURE_DATA_FLAGS(jitter->nc->code) & NATIVE_SPECIALIZED;
/* Extract closure to runstack: */
cnt = data->closure_size;
to_args += cnt;
if (cnt) {
mz_rs_dec(cnt);
CHECK_RUNSTACK_OVERFLOW();
if (specialized) {
/* References to closure data will be replaced with values */
} else {
mz_rs_dec(cnt);
CHECK_RUNSTACK_OVERFLOW();
for (i = cnt; i--; ) {
int pos;
pos = WORDS_TO_BYTES(i) + (intptr_t)&((Scheme_Native_Closure *)0x0)->vals;
jit_ldxi_p(JIT_R1, JIT_R0, pos);
mz_rs_stxi(i, JIT_R1);
CHECK_LIMIT();
for (i = cnt; i--; ) {
int pos;
pos = WORDS_TO_BYTES(i) + (intptr_t)&((Scheme_Native_Closure *)0x0)->vals;
jit_ldxi_p(JIT_R1, JIT_R0, pos);
mz_rs_stxi(i, JIT_R1);
CHECK_LIMIT();
}
}
}
mz_rs_sync();
/* If we have a letrec context, record arities */
if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type)) {
if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type) && !specialized) {
Scheme_Letrec *lr = (Scheme_Letrec *)data->context;
int pos, self_pos = -1;
for (i = data->closure_size; i--; ) {
@ -3614,7 +3702,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
} else {
#ifdef USE_FLONUM_UNBOXING
/* Unpack flonum closure data */
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) {
if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) && !specialized) {
for (i = data->closure_size; i--; ) {
if (CLOSURE_CONTENT_IS_FLONUM(data, i)
|| CLOSURE_CONTENT_IS_EXTFLONUM(data, i)) {
@ -3632,7 +3720,12 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
}
} else
#endif
mz_runstack_pushed(jitter, cnt);
{
if (specialized)
mz_runstack_skipped(jitter, cnt);
else
mz_runstack_pushed(jitter, cnt);
}
/* A define-values context? */
if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_toplevel_type)) {
@ -3738,6 +3831,9 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Schem
abort();
}
if (SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) & NATIVE_SPECIALIZED)
SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) -= NATIVE_SPECIALIZED;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS)
SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_PRESERVES_MARKS;
if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT)

7
racket/src/racket/src/jit.h
View File

@ -152,8 +152,10 @@ END_XFORM_ARITH;
# define SCHEME_FLOAT_TYPE scheme_double_type
#endif
/* These flags are set post-JIT: */
#define NATIVE_PRESERVES_MARKS 0x1
#define NATIVE_IS_SINGLE_RESULT 0x2
/* Pre-JIT flags rae in "schpriv.h" */
#if defined(MZ_PRECISE_GC) && !defined(USE_COMPACT_3M_GC)
# define CAN_INLINE_ALLOC
@ -1367,7 +1369,7 @@ int scheme_stack_safety(mz_jit_state *jitter, int cnt, int offset);
#ifdef USE_FLONUM_UNBOXING
int scheme_mz_flostack_pos(mz_jit_state *jitter, int i);
#endif
void scheme_mz_load_retained(mz_jit_state *jitter, int rs, void *o);
void scheme_mz_load_retained(mz_jit_state *jitter, int rs, void *o, int non_obj);
void scheme_mz_runstack_skipped(mz_jit_state *jitter, int n);
void scheme_mz_runstack_unskipped(mz_jit_state *jitter, int n);
@ -1587,7 +1589,8 @@ int scheme_jit_check_closure_extflonum_bit(Scheme_Closure_Data *data, int pos, i
#endif
Scheme_Object *scheme_extract_global(Scheme_Object *o, Scheme_Native_Closure *nc, int local_only);
Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, int extra_push);
Scheme_Object *scheme_extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, int extra_push, int get_constant);
Scheme_Object *scheme_specialize_to_constant(Scheme_Object *obj, mz_jit_state *jitter, int extra_push);
void scheme_jit_register_traversers(void);
#ifdef MZ_USE_LWC

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

@ -479,7 +479,7 @@ int scheme_generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na
if (direct_native && direct_to_code) {
__END_SHORT_JUMPS__(num_rands < 100);
/* load closure pointer into R0: */
scheme_mz_load_retained(jitter, JIT_R0, direct_to_code);
scheme_mz_load_retained(jitter, JIT_R0, direct_to_code, 0);
/* jump directly: */
(void)jit_jmpi(direct_to_code->code->u.tail_code);
/* no slow path in this mode */
@ -1762,6 +1762,8 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
rator = (alt_rands ? alt_rands[0] : app->args[0]);
rator = scheme_specialize_to_constant(rator, jitter, num_rands);
if (no_call == 2) {
direct_prim = 1;
} else if (SCHEME_PRIMP(rator)) {
@ -1828,6 +1830,9 @@ int scheme_generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
}
}
}
} else if (SAME_TYPE(t, scheme_native_closure_type)) {
direct_native = can_direct_native(rator, num_rands, &extract_case);
reorder_ok = 1;
} else if (SAME_TYPE(t, scheme_closure_type)) {
Scheme_Closure_Data *data;
data = ((Scheme_Closure *)rator)->code;

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

@ -174,7 +174,7 @@ static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int ex
return check_val_struct_prim(p, arity);
} else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) {
Scheme_Object *p;
p = scheme_extract_closure_local(o, jitter, extra_push);
p = scheme_extract_closure_local(o, jitter, extra_push, 0);
return check_val_struct_prim(p, arity);
}
}
@ -947,6 +947,8 @@ int scheme_generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
{
Scheme_Object *rator = app->rator;
rator = scheme_specialize_to_constant(rator, jitter, 1);
{
int k;
k = inlineable_struct_prim(rator, jitter, 1, 1);
@ -2088,6 +2090,9 @@ int scheme_generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_
Return is 1 if thr arguments are in order, -1 if reversed. */
{
int simple1, simple2, direction = 1;
rand1 = scheme_specialize_to_constant(rand1, jitter, skipped);
rand2 = scheme_specialize_to_constant(rand2, jitter, skipped);
simple1 = scheme_is_relatively_constant_and_avoids_r1(rand1, rand2);
simple2 = scheme_is_relatively_constant_and_avoids_r1(rand2, rand1);
@ -2480,6 +2485,8 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
{
Scheme_Object *rator = app->rator;
rator = scheme_specialize_to_constant(rator, jitter, 2);
if (SCHEME_PRIMP(rator) && IS_NAMED_PRIM(rator, "ptr-ref")) {
Scheme_App_Rec *app2;
mz_rs_sync();
@ -2550,7 +2557,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
&& !SCHEME_FALSEP(a1)
&& !SCHEME_VOIDP(a1)
&& !SAME_OBJ(a1, scheme_true)) {
scheme_mz_load_retained(jitter, JIT_R1, a1);
scheme_mz_load_retained(jitter, JIT_R1, a1, 0);
ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1);
/* In case true is a fall-through, note that the test
didn't disturb R0: */
@ -3837,7 +3844,7 @@ int scheme_generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
ref = jit_bnei_p(jit_forward(), JIT_R0, scheme_undefined);
__END_TINY_JUMPS__(1);
scheme_mz_load_retained(jitter, JIT_R1, app->rand2);
scheme_mz_load_retained(jitter, JIT_R1, app->rand2, 0);
if (IS_NAMED_PRIM(rator, "check-not-unsafe-undefined"))
(void)jit_calli(sjc.call_check_not_defined_code);
else
@ -3950,7 +3957,9 @@ int scheme_generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
/* de-sync's; for branch, sync'd before */
{
Scheme_Object *rator = app->args[0];
rator = scheme_specialize_to_constant(rator, jitter, app->num_args);
if (!for_branch) {
int k;
k = inlineable_struct_prim(rator, jitter, app->num_args, app->num_args);

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

@ -70,14 +70,15 @@ int scheme_mz_retain_it(mz_jit_state *jitter, void *v)
return jitter->retained;
}
void scheme_mz_load_retained(mz_jit_state *jitter, int rs, void *obj)
void scheme_mz_load_retained(mz_jit_state *jitter, int rs, void *obj, int non_obj)
/* obj is a pointer, but not necesarily tagged (in CGC) */
{
if (!SCHEME_INTP((Scheme_Object *)obj)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_true)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_false)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_void)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_null)) {
if (non_obj
|| (!SCHEME_INTP((Scheme_Object *)obj)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_true)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_false)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_void)
&& !SAME_OBJ((Scheme_Object *)obj, scheme_null))) {
#ifdef JIT_PRECISE_GC
int retptr;
void *p;

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

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1140
#define EXPECTED_PRIM_COUNT 1141
#define EXPECTED_UNSAFE_COUNT 106
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_EXTFL_COUNT 45

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

@ -2788,6 +2788,10 @@ typedef struct Scheme_Native_Closure_Data {
#define SCHEME_NATIVE_CLOSURE_DATA_FLAGS(obj) MZ_OPT_HASH_KEY(&(obj)->iso)
/* This flag is set pre-JIT: */
#define NATIVE_SPECIALIZED 0x1
/* Other flags are in "jit.h" */
typedef struct {
Scheme_Object so;
Scheme_Native_Closure_Data *code;

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "6.3.0.9"
#define MZSCHEME_VERSION "6.3.0.10"
#define MZSCHEME_VERSION_X 6
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 0
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)