diff --git a/racket/src/racket/include/scheme.h b/racket/src/racket/include/scheme.h index fd7f94d08b..3519cb2524 100644 --- a/racket/src/racket/include/scheme.h +++ b/racket/src/racket/include/scheme.h @@ -755,7 +755,7 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_PRIM_TYPE_PARAMETER 64 #define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128) #define SCHEME_PRIM_SOMETIMES_INLINED (64 | 256) -#define SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED (64 | 128 | 256) +#define SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED (64 | 128 | 256) #define SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER 32 #define SCHEME_PRIM_STRUCT_TYPE_PRED (32 | 64) diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 04b8ea99cd..0f46ac27f6 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -7296,7 +7296,7 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p, cache = NULL; if (cache) { if (SCHEME_HASHTP(cache)) - cache = scheme_hash_get((Scheme_Hash_Table *)cache, prompt_tag ? prompt_tag : scheme_false); + cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, prompt_tag ? prompt_tag : scheme_false); else if (prompt_tag != scheme_default_prompt_tag) cache = NULL; } @@ -7347,7 +7347,7 @@ static Scheme_Object *continuation_marks(Scheme_Thread *p, if (cache && !SCHEME_FALSEP(cache)) { if (SCHEME_HASHTP(cache)) { Scheme_Hash_Table *ht = (Scheme_Hash_Table *)cache; - cache = scheme_hash_get(ht, prompt_tag ? prompt_tag : scheme_false); + cache = scheme_eq_hash_get(ht, prompt_tag ? prompt_tag : scheme_false); if (!cache) { scheme_hash_set(ht, prompt_tag ? prompt_tag : scheme_false, (Scheme_Object *)pr); } else { @@ -7882,6 +7882,7 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key MZ_MARK_POS_TYPE *_vpos) { Scheme_Object *key = key_arg; + if (SCHEME_NP_CHAPERONEP(key) && SCHEME_CONTINUATION_MARK_KEYP(SCHEME_CHAPERONE_VAL(key))) { key = SCHEME_CHAPERONE_VAL(key); @@ -7948,7 +7949,7 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key } else { cache = seg[pos].cache; if (cache && SCHEME_HASHTP(cache)) - cache = scheme_hash_get((Scheme_Hash_Table *)cache, + cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, prompt_tag ? prompt_tag : scheme_false); else if (prompt_tag) cache = NULL; @@ -7964,7 +7965,7 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key } else { Scheme_Hash_Table *ht; ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2]; - val = scheme_hash_get(ht, key); + val = scheme_eq_hash_get(ht, key); if (val) { vpos = (MZ_MARK_POS_TYPE)SCHEME_CDR(val); val = SCHEME_CAR(val); @@ -7997,7 +7998,7 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key Scheme_Hash_Table *cht; if (cache && SCHEME_HASHTP(cache)) { cht = (Scheme_Hash_Table *)cache; - cache = scheme_hash_get(cht, prompt_tag ? prompt_tag : scheme_false); + cache = scheme_eq_hash_get(cht, prompt_tag ? prompt_tag : scheme_false); } else if (prompt_tag) { cht = scheme_make_hash_table(SCHEME_hash_ptr); if (cache) { @@ -8079,6 +8080,61 @@ scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key return NULL; } +XFORM_NONGCING static Scheme_Object * +extract_one_cc_mark_fast(Scheme_Object *key) +/* A non-GCing fast path for scheme_extract_one_cc_mark_with_meta() + where there are no complications. */ +{ + intptr_t findpos, bottom, startpos, minbottom; + intptr_t pos; + Scheme_Object *val = NULL; + Scheme_Object *cache; + Scheme_Cont_Mark *seg; + Scheme_Thread *p = scheme_current_thread; + + startpos = (intptr_t)MZ_CONT_MARK_STACK; + if (!p->cont_mark_stack_segments) + findpos = 0; + + bottom = p->cont_mark_stack_bottom; + minbottom = findpos - 32; + if (bottom < minbottom) + bottom = minbottom; + + findpos = startpos; + + /* Search mark stack, checking caches along the way: */ + while (findpos-- > bottom) { + seg = p->cont_mark_stack_segments[findpos >> SCHEME_LOG_MARK_SEGMENT_SIZE]; + pos = findpos & SCHEME_MARK_SEGMENT_MASK; + + if (SAME_OBJ(seg[pos].key, key)) + return seg[pos].val; + else { + cache = seg[pos].cache; + if (cache && SCHEME_HASHTP(cache)) + cache = scheme_eq_hash_get((Scheme_Hash_Table *)cache, scheme_false); + if (cache && SCHEME_VECTORP(cache)) { + /* If slot 1 has a key, this cache has just one key--value + pair. Otherwise, slot 2 is a hash table. */ + if (SCHEME_VEC_ELS(cache)[1]) { + if (SAME_OBJ(SCHEME_VEC_ELS(cache)[1], key)) + return SCHEME_VEC_ELS(cache)[2]; + } else { + Scheme_Hash_Table *ht; + ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(cache)[2]; + val = scheme_eq_hash_get(ht, key); + if (val) { + return SCHEME_CAR(val); + } + } + } + } + } + + return NULL; +} + static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key, Scheme_Thread *p, Scheme_Meta_Continuation *mc, @@ -8145,6 +8201,13 @@ static Scheme_Object *get_set_cont_mark_by_pos(Scheme_Object *key, Scheme_Object * scheme_extract_one_cc_mark(Scheme_Object *mark_set, Scheme_Object *key) { + Scheme_Object *v; + + if (!mark_set) { + v = extract_one_cc_mark_fast(key); + if (v) return v; + } + return scheme_extract_one_cc_mark_with_meta(mark_set, key, NULL, NULL, NULL); } diff --git a/racket/src/racket/src/jitinline.c b/racket/src/racket/src/jitinline.c index 16fb121a28..9361fff9b4 100644 --- a/racket/src/racket/src/jitinline.c +++ b/racket/src/racket/src/jitinline.c @@ -76,9 +76,10 @@ static Scheme_Object *cont_mark_set_first_try_fast(Scheme_Object *cms, Scheme_Ob Scheme_Object *nullableCms; Scheme_Object *prompt_tag; - prompt_tag = SCHEME_PTR_VAL(scheme_default_prompt_tag); if (key == scheme_parameterization_key || key == scheme_break_enabled_key) prompt_tag = NULL; + else + prompt_tag = SCHEME_PTR_VAL(scheme_default_prompt_tag); nullableCms = SCHEME_FALSEP(cms) ? NULL : cms; diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 4ba4550138..2a46412e50 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -6869,7 +6869,7 @@ Scheme_Object *scheme_make_thread_cell(Scheme_Object *def_val, int inherited) return (Scheme_Object *)c; } -Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells) +static Scheme_Object *do_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells) { Scheme_Object *v; @@ -6882,6 +6882,14 @@ Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Ta return ((Thread_Cell *)cell)->def_val; } +Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells) +{ + if (!((Thread_Cell *)cell)->assigned) + return ((Thread_Cell *)cell)->def_val; + else + return do_thread_cell_get(cell, cells); +} + void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v) { if (!((Thread_Cell *)cell)->assigned) @@ -6997,11 +7005,18 @@ static Scheme_Object *thread_cell_set(int argc, Scheme_Object *argv[]) /*========================================================================*/ SHARED_OK static int max_configs = __MZCONFIG_BUILTIN_COUNT__; -static Scheme_Object *do_param(void *data, int argc, Scheme_Object *argv[]); +static Scheme_Object *do_param(int argc, Scheme_Object *argv[], Scheme_Object *self); + +static Scheme_Config *config_fail() +{ + /* in a separate function to help xform */ + scheme_longjmp(scheme_error_buf, 1); + return NULL; +} Scheme_Config *scheme_current_config() { - Scheme_Object *v; + GC_CAN_IGNORE Scheme_Object *v; v = scheme_extract_one_cc_mark(NULL, scheme_parameterization_key); @@ -7010,7 +7025,7 @@ Scheme_Config *scheme_current_config() and misused it. Printing an error message requires consulting parameters, so just escape. */ - scheme_longjmp(scheme_error_buf, 1); + return config_fail(); } return (Scheme_Config *)v; @@ -7050,7 +7065,7 @@ Scheme_Object *find_param_cell(Scheme_Config *c, Scheme_Object *k, int force_cel Scheme_Object *v; Scheme_Parameterization *p; - v = scheme_hash_tree_get(c->ht, k); + v = scheme_eq_hash_tree_get(c->ht, k); if (v) return v; @@ -7141,14 +7156,14 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[]) a[0] = key; a[1] = scheme_false; while (1) { - if (SCHEME_PRIMP(param)) { + if (!(((Scheme_Primitive_Proc *)param)->pp.flags & SCHEME_PRIM_IS_CLOSURE)) { Scheme_Prim *proc; proc = (Scheme_Prim *)((Scheme_Primitive_Proc *)param)->prim_val; key = proc(2, a); /* leads to scheme_param_config to set a[1] */ break; } else { /* sets a[1] */ - key = do_param(((Scheme_Closed_Primitive_Proc *)param)->data, 2, a); + key = do_param(2, a, param); if (SCHEME_PARAMETERP(key)) { param = key; a[0] = a[1]; @@ -7210,10 +7225,10 @@ static Scheme_Object *parameter_p(int argc, Scheme_Object **argv) : scheme_false); } -static Scheme_Object *do_param(void *_data, int argc, Scheme_Object *argv[]) +static Scheme_Object *do_param(int argc, Scheme_Object *argv[], Scheme_Object *self) { Scheme_Object *guard, **argv2, *pos[2]; - ParamData *data = (ParamData *)_data; + ParamData *data = (ParamData *)SCHEME_PRIM_CLOSURE_ELS(self)[0]; if (argc && argv[0]) { guard = data->guard; @@ -7260,9 +7275,33 @@ static Scheme_Object *do_param(void *_data, int argc, Scheme_Object *argv[]) -2, NULL, NULL, 0); } +static Scheme_Object *extract_param(Scheme_Config *config, Scheme_Object *key, Scheme_Object *defcell) +{ + Scheme_Object *cell; + + cell = find_param_cell(config, key, 0); + if (!cell) + cell = defcell; + + if (SCHEME_THREAD_CELLP(cell)) + return scheme_thread_cell_get(cell, scheme_current_thread->cell_values); + else + return cell; /* it's really the value, instead of a cell */ +} + +static Scheme_Object *do_param_fast(int argc, Scheme_Object *argv[], Scheme_Object *self) +{ + ParamData *data = (ParamData *)SCHEME_PRIM_CLOSURE_ELS(self)[0]; + + if (!argc && !data->is_derived) + return extract_param(scheme_current_config(), data->key, data->defcell); + + return do_param(argc, argv, self); +} + static Scheme_Object *make_parameter(int argc, Scheme_Object **argv) { - Scheme_Object *p, *cell; + Scheme_Object *p, *cell, *a[1]; ParamData *data; void *k; @@ -7280,8 +7319,9 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv) data->defcell = cell; data->guard = ((argc > 1) ? argv[1] : NULL); - p = scheme_make_closed_prim_w_arity(do_param, (void *)data, - "parameter-procedure", 0, 1); + a[0] = (Scheme_Object *)data; + p = scheme_make_prim_closure_w_arity(do_param_fast, 1, a, + "parameter-procedure", 0, 1); ((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER; return p; @@ -7289,7 +7329,7 @@ static Scheme_Object *make_parameter(int argc, Scheme_Object **argv) static Scheme_Object *make_derived_parameter(int argc, Scheme_Object **argv) { - Scheme_Object *p; + Scheme_Object *p, *a[1]; ParamData *data; if (!SCHEME_PARAMETERP(argv[0])) @@ -7307,8 +7347,9 @@ static Scheme_Object *make_derived_parameter(int argc, Scheme_Object **argv) data->guard = argv[1]; data->extract_guard = argv[2]; - p = scheme_make_closed_prim_w_arity(do_param, (void *)data, - "parameter-procedure", 0, 1); + a[0] = (Scheme_Object *)data; + p = scheme_make_prim_closure_w_arity(do_param, 1, a, + "parameter-procedure", 0, 1); ((Scheme_Primitive_Proc *)p)->pp.flags |= SCHEME_PRIM_TYPE_PARAMETER; return p; @@ -7640,16 +7681,7 @@ static Scheme_Object *do_param_config(char *name, Scheme_Object *pos, if (argc == 0) { if (arity == -2) { - Scheme_Object *cell; - - cell = find_param_cell(config, ((Scheme_Object **)pos)[0], 0); - if (!cell) - cell = ((Scheme_Object **)pos)[1]; - - if (SCHEME_THREAD_CELLP(cell)) - return scheme_thread_cell_get(cell, scheme_current_thread->cell_values); - else - return cell; /* it's really the value, instead of a cell */ + return extract_param(config, ((Scheme_Object **)pos)[0], ((Scheme_Object **)pos)[1]); } else { Scheme_Object *s; s = scheme_get_param(config, SCHEME_INT_VAL(pos));