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

fix cert bug, JIT-inline unbox

Browse Source 
svn: r5159
This commit is contained in:
Matthew Flatt 2006-12-22 01:18:17 +00:00
parent 41675aa2ec
commit 343e226df1
3 changed files with 87 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
src/mzscheme/src/jit.c
View File

@ -107,6 +107,7 @@ static void *call_original_binary_arith_for_branch_code;
static void *call_original_binary_rev_arith_for_branch_code;
static void *bad_car_code, *bad_cdr_code;
static void *bad_caar_code, *bad_cdar_code, *bad_cadr_code, *bad_cddr_code;
static void *bad_unbox_code;
static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
@ -2773,6 +2774,9 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "vector?")) {
generate_inlined_type_test(jitter, app, scheme_vector_type, scheme_vector_type, for_branch, branch_short);
return 1;
} else if (IS_NAMED_PRIM(rator, "box?")) {
generate_inlined_type_test(jitter, app, scheme_box_type, scheme_box_type, for_branch, branch_short);
return 1;
} else if (IS_NAMED_PRIM(rator, "string?")) {
generate_inlined_type_test(jitter, app, scheme_char_string_type, scheme_char_string_type, for_branch, branch_short);
return 1;
@ -2862,6 +2866,34 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
}
__END_SHORT_JUMPS__(1);
return 1;
} else if (IS_NAMED_PRIM(rator, "unbox")) {
GC_CAN_IGNORE jit_insn *reffail, *ref;
LOG_IT(("inlined unbox\n"));
mz_runstack_skipped(jitter, 1);
generate_non_tail(app->rand, jitter, 0, 1);
CHECK_LIMIT();
mz_runstack_unskipped(jitter, 1);
__START_SHORT_JUMPS__(1);
ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1);
__END_SHORT_JUMPS__(1);
reffail = _jit.x.pc;
(void)jit_jmpi(bad_unbox_code);
__START_SHORT_JUMPS__(1);
mz_patch_branch(ref);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
(void)jit_bnei_i(reffail, JIT_R1, scheme_box_type);
__END_SHORT_JUMPS__(1);
(void)jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_BOX_VAL(0x0));
return 1;
} else if (IS_NAMED_PRIM(rator, "syntax-e")) {
LOG_IT(("inlined syntax-e\n"));
@ -4888,6 +4920,14 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
}
/* *** bad_unbox_code *** */
/* R0 is argument */
bad_unbox_code = jit_get_ip().ptr;
jit_prepare(1);
jit_pusharg_i(JIT_R0);
(void)mz_finish(scheme_unbox);
CHECK_LIMIT();
/* *** call_original_unary_arith_code *** */
/* R0 is arg, R2 is code pointer, V1 is return address */
for (i = 0; i < 3; i++) {

19
src/mzscheme/src/list.c
View File

@ -402,16 +402,15 @@ scheme_init_list (Scheme_Env *env)
"box-immutable",
1, 1),
env);
scheme_add_global_constant(BOXP,
scheme_make_folding_prim(box_p,
BOXP,
1, 1, 1),
env);
scheme_add_global_constant(UNBOX,
scheme_make_noncm_prim(unbox,
UNBOX,
1, 1),
env);
p = scheme_make_folding_prim(box_p, BOXP, 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant(BOXP, p, env);
p = scheme_make_noncm_prim(unbox, UNBOX, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant(UNBOX, p, env);
scheme_add_global_constant(SETBOX,
scheme_make_noncm_prim(set_box,
SETBOX,

59
src/mzscheme/src/stxobj.c
View File

@ -72,6 +72,8 @@ static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv);
static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv);
static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active);
static Scheme_Object *source_symbol; /* uninterned! */
static Scheme_Object *share_symbol; /* uninterned! */
static Scheme_Object *origin_symbol;
@ -1514,7 +1516,10 @@ static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int
icerts = first;
}
if (icerts) {
/* Even if icerts is NULL, preserve the pair in ->certs,
to indicate no nested inactive certs. */
if (icerts || SCHEME_RPAIRP(((Scheme_Stx *)o)->certs)) {
nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts);
} else
nc = (Scheme_Object *)acerts;
@ -1911,6 +1916,7 @@ static int cert_in_chain(Scheme_Object *mark, Scheme_Object *key, Scheme_Cert *c
}
static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active)
/* If !active, then inactive certs must have been lifted already. */
{
Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs;
Scheme_Stx *stx = (Scheme_Stx *)o, *res;
@ -1995,10 +2001,8 @@ static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Obj
Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs)
/* Also lifts existing inactive certs to the top. */
{
if (!INACTIVE_CERTS((Scheme_Stx *)o)) {
/* Lift inactive certs*/
o = scheme_stx_activate_certs(o);
}
/* Lift inactive certs*/
o = lift_inactive_certs(o, 0);
return add_certs(o, (Scheme_Cert *)certs, NULL, 0);
}
@ -2024,8 +2028,9 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
Also copy any certifications from plus_stx.
If active and mark is non-NULL, make inactive certificates active. */
{
if (mark && active)
if (mark && active) {
o = scheme_stx_activate_certs(o);
}
if (plus_stx_or_certs) {
Scheme_Cert *certs;
@ -2033,11 +2038,16 @@ Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env
certs = ACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs);
else
certs = (Scheme_Cert *)plus_stx_or_certs;
if (certs)
if (certs) {
if (!active)
o = lift_inactive_certs(o, 0);
o = add_certs(o, certs, key, active);
}
/* Also copy over inactive certs, if any */
if (SCHEME_STXP(plus_stx_or_certs))
if (SCHEME_STXP(plus_stx_or_certs)) {
o = lift_inactive_certs(o, 0);
o = add_certs(o, INACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs), key, 0);
}
}
if (menv && !menv->module->no_cert) {
@ -2334,6 +2344,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
Scheme_Object *np;
Scheme_Stx *res;
Scheme_Cert *certs, *cc;
res = (Scheme_Stx *)scheme_make_stx(stx->val,
stx->srcloc,
stx->props);
@ -2388,9 +2399,10 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
}
o = stx_activate_certs(stx->val, cp, ht);
if (!SAME_OBJ(o, stx->val)) {
Scheme_Stx *res;
res = (Scheme_Stx *)scheme_make_stx(stx->val,
res = (Scheme_Stx *)scheme_make_stx(o,
stx->srcloc,
stx->props);
res->wraps = stx->wraps;
@ -2433,7 +2445,7 @@ static Scheme_Object *stx_activate_certs(Scheme_Object *o, Scheme_Cert **cp, Sch
return o;
}
Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
{
Scheme_Cert *certs = NULL;
Scheme_Hash_Table *ht = NULL;
@ -2442,7 +2454,7 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
if (!certs)
return o;
o = add_certs(o, certs, NULL, 1);
o = add_certs(o, certs, NULL, as_active);
if (ht)
o = scheme_resolve_placeholders(o, 0);
@ -2450,6 +2462,11 @@ Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
return o;
}
Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o)
{
return lift_inactive_certs(o, 1);
}
/*========================================================================*/
/* stx comparison */
/*========================================================================*/
@ -5178,14 +5195,12 @@ Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o,
((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props;
if (copy_props && (copy_props != 1)) {
Scheme_Object *certs;
certs = ((Scheme_Stx *)stx_src)->certs;
/* To be on the safe side, drop a "definitely no inactive certs"
indication, if any: */
if (certs && SCHEME_PAIRP(certs) && !SCHEME_CDR(certs)) {
certs = SCHEME_CAR(certs);
if (ACTIVE_CERTS(((Scheme_Stx *)stx_src)))
v = add_certs(v, ACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 1);
if (INACTIVE_CERTS((Scheme_Stx *)stx_src)) {
v = lift_inactive_certs(v, 0);
v = add_certs(v, INACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 0);
}
((Scheme_Stx *)v)->certs = certs;
}
return v;
@ -5396,7 +5411,6 @@ static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv)
return scheme_syntax_to_datum(argv[0], 1, scheme_make_hash_table(SCHEME_hash_ptr));
#endif
return scheme_syntax_to_datum(argv[0], 0, NULL);
}
@ -5494,8 +5508,8 @@ static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv)
}
if (certs) {
certs = scheme_make_raw_pair(NULL, certs);
((Scheme_Stx *)src)->certs = certs;
src = lift_inactive_certs(src, 0);
src = add_certs(src, (Scheme_Cert *)certs, NULL, 0);
}
return src;
@ -5978,6 +5992,9 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv)
}
if (!SAME_OBJ(orig_certs, new_certs)) {
if (i && !orig_certs)
stx = (Scheme_Stx *)lift_inactive_certs((Scheme_Object *)stx, 0);
res = (Scheme_Stx *)scheme_make_stx(stx->val,
stx->srcloc,
stx->props);