From 5f30cc87eaf97bd4569c5637a1870ba79b48f88e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Oct 2012 19:41:34 -0600 Subject: [PATCH] track information about `struct' bindings during compilation This tracking allows the compiler to treat structure sub-type declarations as generating constant results, and it also allows the compiler to recognize an applications of a constructor or predicate as functional. --- collects/racket/private/define-struct.rkt | 5 +- collects/tests/racket/optimize.rktl | 148 ++++++ src/racket/src/compenv.c | 6 +- src/racket/src/compile.c | 8 +- src/racket/src/eval.c | 8 +- src/racket/src/jitcommon.c | 11 +- src/racket/src/module.c | 16 +- src/racket/src/mzmark_type.inc | 38 +- src/racket/src/mzmarksrc.c | 12 +- src/racket/src/optimize.c | 565 +++++++++++++++++----- src/racket/src/resolve.c | 4 +- src/racket/src/schpriv.h | 22 +- src/racket/src/sfs.c | 2 +- src/racket/src/struct.c | 13 +- src/racket/src/stypes.h | 147 +++--- src/racket/src/type.c | 22 +- src/racket/src/validate.c | 128 +++-- 17 files changed, 859 insertions(+), 296 deletions(-) diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index f91f1c2f2b..5c93db6d71 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -516,7 +516,10 @@ stx super-id)) (and super-expr - #`(check-struct-type 'fm #,super-expr)))] + #`(let ([the-super #,super-expr]) + (if (struct-type? the-super) + the-super + (check-struct-type 'fm the-super)))))] [prune (lambda (stx) (identifier-prune-lexical-context stx (list (syntax-e stx) '#%top)))] [reflect-name-expr (if reflect-name-expr diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 0c8168bdc4..494a505208 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1682,6 +1682,154 @@ (hash-ref '#hash((x . y)) x add1)) #f) +;; Check elimination of ignored structure predicate +;; and constructor applications: + +(test-comp '(module m racket/base + (define-values (struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)) + (begin0 + (a? (a-ref (a 1 2) 1)) + a? + a + a-ref + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (define-values (struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)) + (begin0 + (a? (a-ref (a 1 2) 1)) + 5))) + +(test-comp '(module m racket/base + (define-values (struct:a a a? a-x a-y) + (let-values ([(struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)]) + (values struct:a a a? + (make-struct-field-accessor a-ref 0) + (make-struct-field-accessor a-ref 1)))) + (begin0 + (a? (a-x (a 1 2))) + a? + a + a-x + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (define-values (struct:a a a? a-x a-y) + (let-values ([(struct:a a a? a-ref a-set!) + (make-struct-type 'a #f 2 0)]) + (values struct:a a a? + (make-struct-field-accessor a-ref 0) + (make-struct-field-accessor a-ref 1)))) + (begin0 + (a? (a-x (a 1 2))) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (begin0 + (a? (a-x (a 1 2))) + a? + a + a-x + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (begin0 + (a? (a-x (a 1 2))) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:prefab) + (begin0 + (a? (a-x (a 1 2))) + a? + a + a-x + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:prefab) + (begin0 + (a? (a-x (a 1 2))) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:mutable) + (begin0 + (a? (set-a-x! (a 1 2) 5)) + a? + a + a-x + set-a-x! + (a? 7) + (a 1 2) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes #:mutable) + (begin0 + (a? (set-a-x! (a 1 2) 5)) + 5))) + +(test-comp '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (struct b (z) #:super struct:a #:omit-define-syntaxes) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + a? + a + a-x + (a? 7) + (a 1 2) + b? + b + b-z + (b 1 2 3) + 5)) + '(module m racket/base + (struct a (x y) #:omit-define-syntaxes) + (struct b (z) #:super struct:a #:omit-define-syntaxes) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + 5))) + +(module struct-a-for-optimize racket/base + (provide (struct-out a) + (struct-out b)) + (struct a (x y)) + (struct b a (z))) + +(test-comp '(module m racket/base + (require 'struct-a-for-optimize) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + a? + a + a-x + (a? 7) + (a 1 2) + b? + b + b-z + (b 1 2 3) + 5)) + '(module m racket/base + (require 'struct-a-for-optimize) + (begin0 + (list (a? (a-x (a 1 2))) + (b? (b-z (b 1 2 3)))) + 5))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check bytecode verification of lifted functions diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c index 1fc21e42bb..fa036b7690 100644 --- a/src/racket/src/compenv.c +++ b/src/racket/src/compenv.c @@ -2000,7 +2000,11 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, is_constant = 2; else if (SAME_OBJ(mod_constant, scheme_fixed_key)) is_constant = 1; - else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { + else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_struct_proc_shape_type)) { + if (_inline_variant) + *_inline_variant = mod_constant; + is_constant = 2; + } else if (SAME_TYPE(SCHEME_TYPE(mod_constant), scheme_inline_variant_type)) { if (_inline_variant) *_inline_variant = mod_constant; is_constant = 2; diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c index 3f0d6321b4..21aa3e330d 100644 --- a/src/racket/src/compile.c +++ b/src/racket/src/compile.c @@ -2923,7 +2923,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) total++; } else if (opt && (((opt > 0) && !last) || ((opt < 0) && !first)) - && scheme_omittable_expr(v, -1, -1, 0, NULL, -1, 0)) { + && scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 0)) { /* A value that is not the result. We'll drop it. */ total++; } else { @@ -2951,7 +2951,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) /* can't optimize away a begin0 at read time; it's too late, since the return is combined with EXPD_BEGIN0 */ addconst = 1; - } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, -1, 0)) { + } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, NULL, -1, 0)) { /* We can't optimize (begin0 expr cont) to expr because exp is not in tail position in the original (so we'd mess up continuation marks). */ @@ -2983,7 +2983,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) } else if (opt && (((opt > 0) && (k < total)) || ((opt < 0) && k)) - && scheme_omittable_expr(v, -1, -1, 0, NULL, -1, 0)) { + && scheme_omittable_expr(v, -1, -1, 0, NULL, NULL, -1, 0)) { /* Value not the result. Do nothing. */ } else o->array[i++] = v; @@ -3483,7 +3483,7 @@ static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_e save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv, NULL); - if (scheme_omittable_expr(a, 1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(a, 1, -1, 0, NULL, NULL, -1, 0)) { /* short cut */ a = _scheme_eval_linked_expr_multi(a); } else { diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 0f54e2ca8b..ac047cfc4b 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -1896,7 +1896,13 @@ define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, if (SAME_OBJ(values, scheme_current_thread->values_buffer)) scheme_current_thread->values_buffer = NULL; - is_st = scheme_is_simple_make_struct_type(vals_expr, g, 1, 1); + if (dm_env) + is_st = 0; + else + is_st = !!scheme_is_simple_make_struct_type(vals_expr, g, 1, 1, + NULL, NULL, NULL, NULL, + NULL, NULL, MZ_RUNSTACK, 0, + NULL, NULL, 5); for (i = 0; i < g; i++) { var = SCHEME_VEC_ELS(vec)[i+delta]; diff --git a/src/racket/src/jitcommon.c b/src/racket/src/jitcommon.c index fd504853b1..da8c7b9731 100644 --- a/src/racket/src/jitcommon.c +++ b/src/racket/src/jitcommon.c @@ -1520,9 +1520,14 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch, } } else { if (type_pos != 0) { - (void)jit_blti_i(refslow2, JIT_R2, type_pos); - } - bref3 = NULL; + if (kind == 1) { + bref3 = jit_blti_i(jit_forward(), JIT_R2, type_pos); + } else { + (void)jit_blti_i(refslow2, JIT_R2, type_pos); + bref3 = NULL; + } + } else + bref3 = NULL; } CHECK_LIMIT(); /* Lookup argument type at target type depth, put it in R2: */ diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 3a9e466d01..69b1a5f33f 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -4121,7 +4121,7 @@ static void setup_accessible_table(Scheme_Module *m) for (i = 0; i < cnt; i++) { form = SCHEME_VEC_ELS(m->bodies[0])[i]; if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { - int checked_st = 0, is_st = 0; + int checked_st = 0, is_st = 0, st_count = 0, st_icount = 0; for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) { tl = SCHEME_VEC_ELS(form)[k]; if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { @@ -4154,13 +4154,17 @@ static void setup_accessible_table(Scheme_Module *m) } } else { if (!checked_st) { - is_st = scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], - SCHEME_VEC_SIZE(form)-1, - 1, 1); + is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], + SCHEME_VEC_SIZE(form)-1, + 1, 1, NULL, &st_count, &st_icount, + NULL, + NULL, NULL, NULL, 0, + m->prefix->toplevels, ht, + 5); checked_st = 1; } if (is_st) - v = scheme_make_pair(v, scheme_constant_key); + v = scheme_make_pair(v, scheme_make_struct_proc_shape(k-1, st_count, st_icount)); } scheme_hash_set(ht, tl, v); } @@ -9002,7 +9006,7 @@ static Scheme_Object *do_module_begin_at_phase(Scheme_Object *form, Scheme_Comp_ Scheme_Object *prev = NULL, *next; for (p = first; !SCHEME_NULLP(p); p = next) { next = SCHEME_CDR(p); - if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(SCHEME_CAR(p), -1, -1, 0, NULL, NULL, -1, 0)) { if (prev) SCHEME_CDR(prev) = next; else diff --git a/src/racket/src/mzmark_type.inc b/src/racket/src/mzmark_type.inc index c6eec5e5ad..e2a3f68f4e 100644 --- a/src/racket/src/mzmark_type.inc +++ b/src/racket/src/mzmark_type.inc @@ -248,6 +248,25 @@ static int small_object_FIXUP(void *p, struct NewGC *gc) { #define small_object_IS_CONST_SIZE 1 +static int small_atomic_obj_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + +static int small_atomic_obj_MARK(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + +static int small_atomic_obj_FIXUP(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + +#define small_atomic_obj_IS_ATOMIC 1 +#define small_atomic_obj_IS_CONST_SIZE 1 + + static int app_rec_SIZE(void *p, struct NewGC *gc) { Scheme_App_Rec *r = (Scheme_App_Rec *)p; @@ -1191,25 +1210,6 @@ static int escaping_cont_proc_FIXUP(void *p, struct NewGC *gc) { #define escaping_cont_proc_IS_CONST_SIZE 1 -static int char_obj_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - -static int char_obj_MARK(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - -static int char_obj_FIXUP(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - -#define char_obj_IS_ATOMIC 1 -#define char_obj_IS_CONST_SIZE 1 - - static int bignum_obj_SIZE(void *p, struct NewGC *gc) { Scheme_Bignum *b = (Scheme_Bignum *)p; diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 265e289d94..3def9be272 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -89,6 +89,12 @@ small_object { gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); } +small_atomic_obj { + mark: + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); +} + app_rec { Scheme_App_Rec *r = (Scheme_App_Rec *)p; @@ -467,12 +473,6 @@ escaping_cont_proc { gcBYTES_TO_WORDS(sizeof(Scheme_Escaping_Cont)); } -char_obj { - mark: - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); -} - bignum_obj { Scheme_Bignum *b = (Scheme_Bignum *)p; diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c index 6d3c11976d..7e0bfab501 100644 --- a/src/racket/src/optimize.c +++ b/src/racket/src/optimize.c @@ -118,6 +118,8 @@ static Scheme_Object *optimize_shift(Scheme_Object *obj, int delta, int after_de static int compiled_proc_body_size(Scheme_Object *o, int less_args); +READ_ONLY static Scheme_Object *struct_proc_shape_other; + typedef struct Scheme_Once_Used { Scheme_Object so; Scheme_Object *expr; @@ -143,6 +145,9 @@ void scheme_init_optimize() #ifdef MZ_PRECISE_GC register_traversers(); #endif + + REGISTER_SO(struct_proc_shape_other); + struct_proc_shape_other = scheme_make_struct_proc_shape(3, 0, 0); } /*========================================================================*/ @@ -167,6 +172,47 @@ int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expec return 0; } +static Scheme_Object *get_struct_proc_shape(Scheme_Object *rator, Optimize_Info *info) +{ + Scheme_Object *c; + + if (info + && (info->top_level_consts || info->cp->inline_variants) + && SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_toplevel_type)) { + int pos; + pos = SCHEME_TOPLEVEL_POS(rator); + c = NULL; + if (info->top_level_consts) + c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + if (!c && info->cp->inline_variants) + c = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos)); + if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_struct_proc_shape_type)) { + return c; + } + } + + return NULL; +} + +int scheme_is_struct_functional(Scheme_Object *rator, int num_args, Optimize_Info *info, int vals) +{ + Scheme_Object *c; + + if ((vals == 1) || (vals == -1)) { + c = get_struct_proc_shape(rator, info); + if (c) { + int mode = (SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(c) >> STRUCT_PROC_SHAPE_SHIFT); + if (((num_args == 1) && (mode == STRUCT_PROC_SHAPE_PRED)) + || ((num_args == field_count) && (mode == STRUCT_PROC_SHAPE_CONSTR))) { + return 1; + } + } + } + + return 0; +} + static void note_match(int actual, int expected, Optimize_Info *warn_info) { if (!warn_info || (expected == -1)) @@ -183,7 +229,7 @@ static void note_match(int actual, int expected, Optimize_Info *warn_info) } int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info, int deeper_than, int no_id) + Optimize_Info *opt_info, Optimize_Info *warn_info, int deeper_than, int no_id) /* Checks whether the bytecode `o' returns `vals' values with no side-effects and without pushing and using continuation marks. -1 for vals means that any return count is ok. @@ -258,9 +304,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (vtype == scheme_branch_type) { Scheme_Branch_Rec *b; b = (Scheme_Branch_Rec *)o; - return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info, deeper_than, 0) - && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info, deeper_than, no_id) - && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info, deeper_than, no_id)); + return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than, 0) + && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id) + && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id)); } #if 0 @@ -268,15 +314,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, a let_value_type! */ if (vtype == scheme_let_value_type) { Scheme_Let_Value *lv = (Scheme_Let_Value *)o; - return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info, deeper_than, no_id) - && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info, deeper_than, no_id)); + return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id) + && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id)); } #endif if (vtype == scheme_let_one_type) { Scheme_Let_One *lo = (Scheme_Let_One *)o; - return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1, 0) - && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info, deeper_than + 1, no_id)); + return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, 0) + && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, no_id)); } if (vtype == scheme_let_void_type) { @@ -286,7 +332,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body; if ((lv2->count == 1) && (lv2->position == 0) - && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info, + && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1 + lv->count, 0)) { o = lv2->body; @@ -305,7 +351,7 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((lh->count == 1) && (lh->num_clauses == 1)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1, 0)) { + if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, 0)) { o = lv->body; deeper_than++; goto try_again; @@ -325,26 +371,19 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { note_match(5, vals, warn_info); - if (scheme_is_simple_make_struct_type(o, vals, resolved, 0)) { - if ((app->num_args < 5) - /* auto-field value: */ - || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0), 0)) { - return 1; - } - } } - - if (SCHEME_PRIMP(app->args[0])) { - if (scheme_is_functional_primitive(app->args[0], app->num_args, vals)) { - int i; - for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0), 0)) - return 0; - } - return 1; - } else if (!(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) { + + if (scheme_is_functional_primitive(app->args[0], app->num_args, vals) + || scheme_is_struct_functional(app->args[0], app->num_args, opt_info, vals)) { + int i; + for (i = app->num_args; i--; ) { + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? app->num_args : 0), 0)) + return 0; + } + return 1; + } else if (SCHEME_PRIMP(app->args[0])) { + if (!(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) { note_match(1, vals, warn_info); } else if (SAME_OBJ(scheme_values_func, app->args[0])) { note_match(app->num_args, vals, warn_info); @@ -356,13 +395,14 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (vtype == scheme_application2_type) { Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - if (SCHEME_PRIMP(app->rator)) { - if (scheme_is_functional_primitive(app->rator, 1, vals)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 1 : 0), 0)) - return 1; - } else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) - || SAME_OBJ(scheme_values_func, app->rator)) { + if (scheme_is_functional_primitive(app->rator, 1, vals) + || scheme_is_struct_functional(app->rator, 1, opt_info, vals)) { + if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? 1 : 0), 0)) + return 1; + } else if (SCHEME_PRIMP(app->rator)) { + if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) + || SAME_OBJ(scheme_values_func, app->rator)) { note_match(1, vals, warn_info); } } @@ -371,14 +411,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, if (vtype == scheme_application3_type) { Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - if (SCHEME_PRIMP(app->rator)) { - if (scheme_is_functional_primitive(app->rator, 2, vals)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0), 0) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0), 0)) - return 1; - } else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) { + if (scheme_is_functional_primitive(app->rator, 2, vals) + || scheme_is_struct_functional(app->rator, 2, opt_info, vals)) { + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? 2 : 0), 0) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + (resolved ? 2 : 0), 0)) + return 1; + } else if (SCHEME_PRIMP(app->rator)) { + if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) { note_match(1, vals, warn_info); } else if (SAME_OBJ(scheme_values_func, app->rator)) { note_match(2, vals, warn_info); @@ -387,6 +428,22 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 0; } + /* check for struct-type declaration: */ + { + Scheme_Object *auto_e; + int auto_e_depth; + auto_e = scheme_is_simple_make_struct_type(o, vals, resolved, 0, &auto_e_depth, + NULL, NULL, NULL, + (opt_info ? opt_info->top_level_consts : NULL), + NULL, NULL, 0, NULL, NULL, + 5); + if (auto_e) { + if (scheme_omittable_expr(auto_e, 1, fuel - 1, resolved, opt_info, warn_info, + deeper_than + auto_e_depth, 0)) + return 1; + } + } + return 0; } @@ -460,33 +517,58 @@ static int is_int_list(Scheme_Object *o, int up_to) return SCHEME_NULLP(o); } -static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved) +static int ok_proc_creator_args(Scheme_Object *rator, Scheme_Object *rand1, Scheme_Object *rand2, Scheme_Object *rand3, + int delta2, int field_count) +{ + if ((SAME_OBJ(rator, scheme_make_struct_field_accessor_proc) + && is_local_ref(rand1, delta2+3, 1)) + || (SAME_OBJ(rator, scheme_make_struct_field_mutator_proc) + && is_local_ref(rand1, delta2+4, 1))) { + if (SCHEME_INTP(rand2) + && (SCHEME_INT_VAL(rand2) >= 0) + && (SCHEME_INT_VAL(rand2) < field_count) + && (!rand3 || SCHEME_SYMBOLP(rand3))) { + return 1; + } + } + + return 0; +} + +static int is_values_with_accessors_and_mutators(Scheme_Object *e, int vals, int resolved, int field_count) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { Scheme_App_Rec *app = (Scheme_App_Rec *)e; int delta = (resolved ? app->num_args : 0); if (SAME_OBJ(app->args[0], scheme_values_func) - && (app->num_args == vals)) { + && (app->num_args == vals) + && (app->num_args >= 3) + && is_local_ref(app->args[1], delta, 1) + && is_local_ref(app->args[2], delta+1, 1) + && is_local_ref(app->args[3], delta+2, 1)) { int i; - for (i = app->num_args; i > 0; i--) { - if (is_local_ref(app->args[1], delta, 5)) { + for (i = app->num_args; i > 3; i--) { + if (is_local_ref(app->args[i], delta, 5)) { /* ok */ - } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { - Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; - int delta2 = delta + (resolved ? 2 : 0); - if (SAME_OBJ(app3->rator, scheme_make_struct_field_accessor_proc)) { - if (!is_local_ref(app3->rand1, delta2+3, 1) - && SCHEME_SYMBOLP(app3->rand2)) - break; - } else if (SAME_OBJ(app3->rator, scheme_make_struct_field_mutator_proc)) { - if (!is_local_ref(app3->rand1, delta2+4, 1) - && SCHEME_SYMBOLP(app3->rand2)) + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application_type)) { + Scheme_App_Rec *app3 = (Scheme_App_Rec *)app->args[i]; + int delta2 = delta + (resolved ? app3->num_args : 0); + if (app3->num_args == 3) { + if (!ok_proc_creator_args(app3->args[0], app3->args[1], app3->args[2], app3->args[3], + delta2, field_count)) break; } else break; - } + } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) { + Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; + int delta2 = delta + (resolved ? 2 : 0); + if (!ok_proc_creator_args(app3->rator, app3->rand1, app3->rand2, NULL, + delta2, field_count)) + break; + } else + break; } - if (i <= 0) + if (i <= 3) return 1; } } @@ -509,18 +591,112 @@ static Scheme_Object *skip_clears(Scheme_Object *body) return body; } -int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, int check_auto) -/* Checks whether it's a `make-struct-type' call that certainly succeeds - (i.e., no exception) --- pending a check of argument 5 if !check_auto */ +static int is_constant_super(Scheme_Object *arg, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table) { + int pos; + Scheme_Object *v; + + if (SAME_TYPE(SCHEME_TYPE(arg), scheme_compiled_toplevel_type)) { + pos = SCHEME_TOPLEVEL_POS(arg); + if (top_level_consts) { + /* This is optimize mode */ + v = scheme_hash_get(top_level_consts, scheme_make_integer(pos)); + if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { + int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT); + if (mode == STRUCT_PROC_SHAPE_STRUCT) + return field_count + 1; + } + } + } else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_toplevel_type)) { + pos = SCHEME_TOPLEVEL_POS(arg); + if (runstack) { + /* This is eval mode; conceptually, this code belongs in + define_execute_with_dynamic_state() */ + Scheme_Bucket *b; + Scheme_Prefix *toplevels; + toplevels = (Scheme_Prefix *)runstack[SCHEME_TOPLEVEL_DEPTH(arg) - rs_delta]; + b = (Scheme_Bucket *)toplevels->a[pos]; + if (b->val) { + if (SCHEME_STRUCT_TYPEP(b->val) + && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONSISTENT)) { + Scheme_Struct_Type *st = (Scheme_Struct_Type *)b->val; + if (st->num_slots == st->num_islots) + return st->num_slots + 1; + } + } + } + if (symbols) { + /* This is module-export mode; conceptually, this code belongs in + setup_accessible_table() */ + Scheme_Object *name; + name = symbols[pos]; + if (SCHEME_SYMBOLP(name)) { + v = scheme_hash_get(symbol_table, name); + if (v && SCHEME_PAIRP(v)) { + v = SCHEME_CDR(v); + if (v && SAME_TYPE(SCHEME_TYPE(v), scheme_struct_proc_shape_type)) { + int mode = (SCHEME_PROC_SHAPE_MODE(v) & STRUCT_PROC_SHAPE_MASK); + int field_count = (SCHEME_PROC_SHAPE_MODE(v) >> STRUCT_PROC_SHAPE_SHIFT); + if (mode == STRUCT_PROC_SHAPE_STRUCT) + return field_count + 1; + } + } + } + } + if (top_level_table) { + /* This is validate mode; conceptually, this code belongs in + define_values_validate() */ + v = scheme_hash_get(top_level_table, scheme_make_integer(pos)); + if (v) + return SCHEME_INT_VAL(v) + 1; + } + } + + return 0; +} + +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, + int check_auto, + GC_CAN_IGNORE int *_auto_e_depth, + int *_field_count, int *_init_field_count, + int *_uses_super, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + int fuel) +/* Checks whether it's a `make-struct-type' call that certainly succeeds + (i.e., no exception) --- pending a check of the auto-value argument if !check_auto. + The result is the auto-value argument or scheme_true if it's simple, NULL if not. + The first result is a struct type, the second a constructor, and the thrd a predicate; + the rest are an unspecified mixture of selectors and mutators. */ +{ + if (!fuel) return NULL; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { if ((vals == 5) || (vals < 0)) { Scheme_App_Rec *app = (Scheme_App_Rec *)e; if ((app->num_args >= 4) && (app->num_args <= 11) && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { + int super_count_plus_one; + + if (!SCHEME_FALSEP(app->args[2])) + super_count_plus_one = is_constant_super(app->args[2], + top_level_consts, top_level_table, runstack, + rs_delta + app->num_args, + symbols, symbol_table); + else + super_count_plus_one = 0; + if (SCHEME_SYMBOLP(app->args[1]) - && SCHEME_FALSEP(app->args[2]) /* super = #f */ + && (SCHEME_FALSEP(app->args[2]) /* super */ + || super_count_plus_one) && SCHEME_INTP(app->args[3]) && (SCHEME_INT_VAL(app->args[3]) >= 0) && SCHEME_INTP(app->args[4]) @@ -528,13 +704,16 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, && ((app->num_args < 5) /* auto-field value: */ || !check_auto - || scheme_omittable_expr(app->args[5], 1, 3, resolved, NULL, -1, 0)) + || scheme_omittable_expr(app->args[5], 1, 3, resolved, NULL, NULL, -1, 0)) && ((app->num_args < 6) /* no properties: */ || SCHEME_NULLP(app->args[6])) && ((app->num_args < 7) /* inspector: */ || SCHEME_FALSEP(app->args[7]) + || (SCHEME_SYMBOLP(app->args[7]) + && !strcmp("prefab", SCHEME_SYM_VAL(app->args[7])) + && !SCHEME_SYM_WEIRDP(app->args[7])) || is_current_inspector_call(app->args[7])) && ((app->num_args < 8) /* propcedure property: */ @@ -551,7 +730,20 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, /* constructor name: */ || SCHEME_FALSEP(app->args[11]) || SCHEME_SYMBOLP(app->args[11]))) { - return 1; + int super_count = (super_count_plus_one + ? (super_count_plus_one - 1) + : 0); + if (_auto_e_depth) + *_auto_e_depth = (resolved ? app->num_args : 0); + if (_field_count) + *_field_count = SCHEME_INT_VAL(app->args[3]) + super_count; + if (_init_field_count) + *_init_field_count = (SCHEME_INT_VAL(app->args[3]) + + SCHEME_INT_VAL(app->args[4]) + + super_count); + if (_uses_super) + *_uses_super = (super_count_plus_one ? 1 : 0); + return ((app->num_args < 5) ? scheme_true : app->args[5]); } } } @@ -564,12 +756,29 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, if ((lh->count == 5) && (lh->num_clauses == 1)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type) - && scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto)) { - /* We have (let-values ([... (make-struct-type)]) ....), so make sure body - just uses `make-struct-field-{accessor,mutator}'. */ - if (is_values_with_accessors_and_mutators(lv->body, vals, resolved)) - return 1; + if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type)) { + Scheme_Object *auto_e; + int ifc; + int lh_delta = ((SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)) + ? lh->count + : 0); + auto_e = scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto, + _auto_e_depth, _field_count, &ifc, + _uses_super, + top_level_consts, top_level_table, + runstack, rs_delta + lh_delta, + symbols, symbol_table, + fuel-1); + if (auto_e) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + if (is_values_with_accessors_and_mutators(lv->body, vals, resolved, ifc)) { + if (_auto_e_depth && lh_delta) + *_auto_e_depth += lh_delta; + if (_init_field_count) *_init_field_count = ifc; + return auto_e; + } + } } } } @@ -584,20 +793,63 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, if ((lv->position == 0) && (lv->count == 5)) { Scheme_Object *e2; e2 = skip_clears(lv->value); - if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type) - && scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto)) { - /* We have (let-values ([... (make-struct-type)]) ....), so make sure body - just uses `make-struct-field-{accessor,mutator}'. */ - e2 = skip_clears(lv->body); - if (is_values_with_accessors_and_mutators(e2, vals, resolved)) - return 1; + if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type)) { + Scheme_Object *auto_e; + int ifc; + auto_e = scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto, + _auto_e_depth, _field_count, &ifc, + _uses_super, + top_level_consts, top_level_table, + runstack, rs_delta + lvd->count, + symbols, symbol_table, + fuel-1); + if (auto_e) { + /* We have (let-values ([... (make-struct-type)]) ....), so make sure body + just uses `make-struct-field-{accessor,mutator}'. */ + e2 = skip_clears(lv->body); + if (is_values_with_accessors_and_mutators(e2, vals, resolved, ifc)) { + if (_auto_e_depth) *_auto_e_depth += lvd->count; + if (_init_field_count) *_init_field_count = ifc; + return auto_e; + } + } } } } } } - return 0; + return NULL; +} + +Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count) +{ + Scheme_Object *ps; + + switch (k) { + case 0: + if (field_count == init_field_count) + k = STRUCT_PROC_SHAPE_STRUCT | (field_count << STRUCT_PROC_SHAPE_SHIFT); + else + k = STRUCT_PROC_SHAPE_OTHER; + break; + case 1: + k = STRUCT_PROC_SHAPE_CONSTR | (init_field_count << STRUCT_PROC_SHAPE_SHIFT); + break; + case 2: + k = STRUCT_PROC_SHAPE_PRED; + break; + default: + if (struct_proc_shape_other) + return struct_proc_shape_other; + k = STRUCT_PROC_SHAPE_OTHER; + } + + ps = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object)); + ps->type = scheme_struct_proc_shape_type; + SCHEME_PROC_SHAPE_MODE(ps) = k; + + return ps; } static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) @@ -2039,9 +2291,17 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz } } + if (SAME_OBJ(scheme_struct_type_p_proc, app->rator)) { + Scheme_Object *c; + c = get_struct_proc_shape(app->rand, info); + if (c && ((SCHEME_PROC_SHAPE_MODE(c) & STRUCT_PROC_SHAPE_MASK) + == STRUCT_PROC_SHAPE_STRUCT)) + 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, 0) + && (scheme_omittable_expr(app->rand, 1, -1, 0, info, info, -1, 0) || single_valued_noncm_expression(app->rand, 5))) { info->preserves_marks = 1; info->single_result = 1; @@ -2083,13 +2343,13 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz if (SAME_OBJ(scheme_list_proc, app2->rator)) { if (IS_NAMED_PRIM(app->rator, "car")) { /* (car (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1, 0) + if (scheme_omittable_expr(app2->rand, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app2->rand, 5)) { alt = app2->rand; } } else if (IS_NAMED_PRIM(app->rator, "cdr")) { /* (cdr (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1, 0)) + if (scheme_omittable_expr(app2->rand, 1, 5, 0, info, NULL, -1, 0)) alt = scheme_null; } } @@ -2100,27 +2360,27 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz || SAME_OBJ(scheme_list_proc, app3->rator) || SAME_OBJ(scheme_list_star_proc, app3->rator)) { /* (car ({cons|list|list*} X Y)) */ - if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1, 0) + if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app3->rand1, 5)) - && scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1, 0)) { + && scheme_omittable_expr(app3->rand2, 1, 5, 0, info, NULL, -1, 0)) { alt = app3->rand1; } } } else if (IS_NAMED_PRIM(app->rator, "cdr")) { /* (cdr (cons X Y)) */ if (SAME_OBJ(scheme_cons_proc, app3->rator)) { - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1, 0) + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1, 0)) { + && scheme_omittable_expr(app3->rand1, 1, 5, 0, info, NULL, -1, 0)) { alt = app3->rand2; } } } else if (IS_NAMED_PRIM(app->rator, "cadr")) { if (SAME_OBJ(scheme_list_proc, app3->rator)) { /* (cadr (list X Y)) */ - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1, 0) + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, info, NULL, -1, 0) || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1, 0)) { + && scheme_omittable_expr(app3->rand1, 1, 5, 0, info, NULL, -1, 0)) { alt = app3->rand2; } } @@ -2472,7 +2732,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, i /* Inlining and constant propagation can expose omittable expressions. */ if ((i + 1 != count) - && scheme_omittable_expr(le, -1, -1, 0, NULL, -1, 0)) { + && scheme_omittable_expr(le, -1, -1, 0, info, NULL, -1, 0)) { drop++; info->size = prev_size; s->array[i] = NULL; @@ -2655,7 +2915,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int } /* Try optimize: (if v v) => v */ - if (scheme_omittable_expr(t, 1, 20, 0, NULL, -1, 0) + if (scheme_omittable_expr(t, 1, 20, 0, info, NULL, -1, 0) && equivalent_exprs(tb, fb)) { info->size -= 2; /* could be more precise */ return tb; @@ -2697,7 +2957,7 @@ static int omittable_key(Scheme_Object *k, Optimize_Info *info) { /* A key is not omittable if it might refer to a chaperoned/impersonated continuation mark key, so that's why we pass 1 for `no_id': */ - return scheme_omittable_expr(k, 1, 20, 0, info, -1, 1); + return scheme_omittable_expr(k, 1, 20, 0, info, info, -1, 1); } static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int context) @@ -2712,8 +2972,8 @@ static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int co b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); if (omittable_key(k, info) - && scheme_omittable_expr(v, 1, 20, 0, info, -1, 0) - && scheme_omittable_expr(b, -1, 20, 0, info, -1, 0)) + && scheme_omittable_expr(v, 1, 20, 0, info, info, -1, 0) + && scheme_omittable_expr(b, -1, 20, 0, info, info, -1, 0)) return b; /* info->single_result is already set */ @@ -3030,17 +3290,53 @@ case_lambda_shift(Scheme_Object *data, int delta, int after_depth) static Scheme_Object * begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) { - int i, count; + int i, count, drop = 0, prev_size; + Scheme_Sequence *s = (Scheme_Sequence *)obj; + Scheme_Object *le; - count = ((Scheme_Sequence *)obj)->count; + count = s->count; for (i = 0; i < count; i++) { - Scheme_Object *le; - le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info, + prev_size = info->size; + + le = scheme_optimize_expr(s->array[i], + info, (!i ? scheme_optimize_result_context(context) : 0)); - ((Scheme_Sequence *)obj)->array[i] = le; + + /* Inlining and constant propagation can expose + omittable expressions. */ + if (i && scheme_omittable_expr(le, -1, -1, 0, info, NULL, -1, 0)) { + drop++; + info->size = prev_size; + s->array[i] = NULL; + } else { + s->array[i] = le; + } + } + + if (drop) { + Scheme_Sequence *s2; + int j = 0; + + if ((s->count - drop) == 1) { + /* can't drop down to 1 expression */ + s->array[s->count-1] = scheme_false; + --drop; + } + + s2 = scheme_malloc_sequence(s->count - drop); + s2->so.type = s->so.type; + s2->count = s->count - drop; + + for (i = 0; i < s->count; i++) { + if (s->array[i]) { + s2->array[j++] = s->array[i]; + } + } + + obj = (Scheme_Object *)s2; } /* Optimization of expression 0 has already set single_result */ @@ -3236,6 +3532,9 @@ int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info) pos = SCHEME_TOPLEVEL_POS(value); value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); value = no_potential_size(value); + if (SAME_OBJ(value, scheme_constant_key) + || (value && SAME_TYPE(SCHEME_TYPE(value), scheme_struct_proc_shape_type))) + return 0; if (value) return 1; } @@ -3256,7 +3555,7 @@ int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info) Scheme_Let_Header *lh = (Scheme_Let_Header *)value; if (lh->num_clauses == 1) { Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(lv->value, lv->count, 20, 0, info, NULL, -1, 0)) { value = lv->body; info = NULL; } else @@ -3819,7 +4118,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i if ((pre_body->count != 1) && is_values_apply(value, pre_body->count) && ((!is_rec && no_mutable_bindings(pre_body)) - || scheme_omittable_expr(value, pre_body->count, -1, 0, info, + || scheme_omittable_expr(value, pre_body->count, -1, 0, info, info, (is_rec ? (pre_body->position + pre_body->count) : -1), @@ -4202,7 +4501,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i } if (!used - && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1, 0) + && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, info, -1, 0) || ((pre_body->count == 1) && first_once_used && (first_once_used->pos == pos) @@ -4630,7 +4929,7 @@ static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimi return NULL; } -static int is_general_compiled_proc(Scheme_Object *e) +static int is_general_compiled_proc(Scheme_Object *e, Optimize_Info *info) { /* recognize (begin * ) */ if (SCHEME_TYPE(e) == scheme_sequence_type) { @@ -4638,7 +4937,7 @@ static int is_general_compiled_proc(Scheme_Object *e) if (seq->count > 0) { int i; for (i = seq->count - 1; i--; ) { - if (!scheme_omittable_expr(seq->array[i], -1, 20, 0, NULL, -1, 0)) + if (!scheme_omittable_expr(seq->array[i], -1, 20, 0, info, NULL, -1, 0)) return 0; } } @@ -4739,7 +5038,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { Scheme_Object *e2; e2 = SCHEME_VEC_ELS(e)[1]; - if (is_general_compiled_proc(e2)) + if (is_general_compiled_proc(e2, info)) is_proc_def = 1; } } @@ -4763,13 +5062,19 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) (including raising an exception), then continue the group of simultaneous definitions: */ if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - int n, cnst = 0, sproc = 0; + int n, cnst = 0, sproc = 0, sstruct = 0, field_count = 0, init_field_count = 0; vars = SCHEME_VEC_ELS(e)[0]; e = SCHEME_VEC_ELS(e)[1]; n = scheme_list_length(vars); - cont = scheme_omittable_expr(e, n, -1, 0, info, -1, 0); + cont = scheme_omittable_expr(e, n, -1, 0, + /* no `info' here, because the decision + of omittable should not depend on + information that's only available at + optimization time: */ + NULL, + info, -1, 0); if (n == 1) { if (scheme_compiled_propagate_ok(e, info)) @@ -4778,20 +5083,28 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) cnst = 1; sproc = 1; } - } else if (scheme_is_simple_make_struct_type(e, n, 0, 1)) { + } else if (scheme_is_simple_make_struct_type(e, n, 0, 1, NULL, + &field_count, &init_field_count, NULL, + info->top_level_consts, + NULL, NULL, 0, NULL, NULL, + 5)) { + sstruct = 1; cnst = 1; } if (cnst) { Scheme_Toplevel *tl; - while (n--) { + int i; + for (i = 0; i < n; i++) { tl = (Scheme_Toplevel *)SCHEME_CAR(vars); vars = SCHEME_CDR(vars); if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { Scheme_Object *e2; - if (sproc) { + if (sstruct) { + e2 = scheme_make_struct_proc_shape(i, field_count, init_field_count); + } else if (sproc) { e2 = scheme_make_noninline_proc(e); } else if (IS_COMPILED_PROC(e)) { e2 = optimize_clone(1, e, info, 0, 0); @@ -4811,17 +5124,27 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) if (e2) { int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); pos = tl->position; - scheme_hash_set(consts, scheme_make_integer(pos), e2); - if (!re_consts) - re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); + if (sstruct) { + /* Add directly to `info->top_level_consts' for use + by sub-struct declarations in the same set */ + if (!info->top_level_consts) { + Scheme_Hash_Table *tlc; + tlc = scheme_make_hash_table(SCHEME_hash_ptr); + info->top_level_consts = tlc; + } + scheme_hash_set(info->top_level_consts, scheme_make_integer(pos), e2); + } else { + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_make_integer(pos), e2); + if (!re_consts) + re_consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(re_consts, scheme_make_integer(i_m), + scheme_make_integer(pos)); + } } else { /* At least mark it as fixed */ - if (!fixed_table) { fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); if (!consts) @@ -4851,7 +5174,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) } } } else { - cont = scheme_omittable_expr(e, -1, -1, 0, NULL, -1, 0); + cont = scheme_omittable_expr(e, -1, -1, 0, NULL, NULL, -1, 0); } if (i_m + 1 == cnt) cont = 0; @@ -5025,7 +5348,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(e, -1, -1, 0, info, NULL, -1, 0)) { can_omit++; } } @@ -5036,7 +5359,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context) for (i_m = 0; i_m < cnt; i_m++) { /* Optimize this expression: */ e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; - if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1, 0)) { + if (!scheme_omittable_expr(e, -1, -1, 0, info, NULL, -1, 0)) { SCHEME_VEC_ELS(vec)[j++] = e; } } diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c index 5635b1d17c..5ce2407393 100644 --- a/src/racket/src/resolve.c +++ b/src/racket/src/resolve.c @@ -508,7 +508,7 @@ static Scheme_Object *look_for_letv_change(Scheme_Sequence *s) v = s->array[i]; if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { Scheme_Let_Value *lv = (Scheme_Let_Value *)v; - if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, -1, 0)) { + if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, NULL, -1, 0)) { int esize = s->count - (i + 1); int nsize = i + 1; Scheme_Object *nv, *ev; @@ -1240,7 +1240,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) } if (j >= 0) break; - if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, -1, 0)) + if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, NULL, -1, 0)) break; } if (i < 0) { diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index a14d86d6bb..880a8cdd55 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -373,6 +373,7 @@ extern Scheme_Object *scheme_call_with_values_proc; extern Scheme_Object *scheme_make_struct_type_proc; extern Scheme_Object *scheme_make_struct_field_accessor_proc; extern Scheme_Object *scheme_make_struct_field_mutator_proc; +extern Scheme_Object *scheme_struct_type_p_proc; extern Scheme_Object *scheme_current_inspector_proc; extern Scheme_Object *scheme_varref_const_p_proc; @@ -2860,11 +2861,28 @@ int scheme_used_app_only(Scheme_Comp_Env *env, int which); int scheme_used_ever(Scheme_Comp_Env *env, int which); int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info, int deeper_than, int no_id); + Optimize_Info *opt_info, Optimize_Info *warn_info, int deeper_than, int no_id); int scheme_might_invoke_call_cc(Scheme_Object *value); int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_functional_primitive(Scheme_Object *rator, int num_args, int expected_vals); -int scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, int check_auto); +Scheme_Object *scheme_is_simple_make_struct_type(Scheme_Object *app, int vals, int resolved, + int check_auto, int *_auto_e_depth, + int *_field_count, int *_init_field_count, + int *_uses_super, + Scheme_Hash_Table *top_level_consts, + Scheme_Hash_Table *top_level_table, + Scheme_Object **runstack, int rs_delta, + Scheme_Object **symbols, Scheme_Hash_Table *symbol_table, + int fuel); + +Scheme_Object *scheme_make_struct_proc_shape(int k, int field_count, int init_field_count); +#define STRUCT_PROC_SHAPE_STRUCT 0 +#define STRUCT_PROC_SHAPE_PRED 1 +#define STRUCT_PROC_SHAPE_OTHER 2 +#define STRUCT_PROC_SHAPE_CONSTR 3 +#define STRUCT_PROC_SHAPE_MASK 0x7 +#define STRUCT_PROC_SHAPE_SHIFT 3 +#define SCHEME_PROC_SHAPE_MODE(obj) (((Scheme_Small_Object *)(obj))->u.int_val) int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); diff --git a/src/racket/src/sfs.c b/src/racket/src/sfs.c index 0c0ec2156f..b6828cb69c 100644 --- a/src/racket/src/sfs.c +++ b/src/racket/src/sfs.c @@ -671,7 +671,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) it might not because (1) it was introduced late by inlining, or (2) the rhs expression doesn't always produce a single value. */ - if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1, 0)) { + if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, NULL, -1, 0)) { rhs = scheme_false; } else if ((ip < info->max_calls[pos]) && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 74d4c50956..44958b10a4 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -38,6 +38,7 @@ READ_ONLY Scheme_Object *scheme_impersonator_of_property; READ_ONLY Scheme_Object *scheme_make_struct_type_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_proc; READ_ONLY Scheme_Object *scheme_make_struct_field_mutator_proc; +READ_ONLY Scheme_Object *scheme_struct_type_p_proc; READ_ONLY Scheme_Object *scheme_current_inspector_proc; READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_display_symbol; @@ -607,11 +608,13 @@ scheme_init_struct (Scheme_Env *env) "struct?", 1, 1, 1), env); - scheme_add_global_constant("struct-type?", - scheme_make_folding_prim(struct_type_p, - "struct-type?", - 1, 1, 1), - env); + + REGISTER_SO(scheme_struct_type_p_proc); + scheme_struct_type_p_proc = scheme_make_folding_prim(struct_type_p, + "struct-type?", + 1, 1, 1); + scheme_add_global_constant("struct-type?", scheme_struct_type_p_proc, env); + scheme_add_global_constant("struct-type-property?", scheme_make_folding_prim(struct_type_property_p, "struct-type-property?", diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 62d0ed51ab..e69c816d31 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -198,83 +198,84 @@ enum { scheme_serialized_tcp_fd_type, /* 178 */ scheme_serialized_file_fd_type, /* 179 */ scheme_port_closed_evt_type, /* 180 */ + scheme_struct_proc_shape_type, /* 181 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 181 */ + _scheme_last_normal_type_, /* 182 */ - scheme_rt_weak_array, /* 182 */ + scheme_rt_weak_array, /* 183 */ - scheme_rt_comp_env, /* 183 */ - scheme_rt_constant_binding, /* 184 */ - scheme_rt_resolve_info, /* 185 */ - scheme_rt_unresolve_info, /* 186 */ - scheme_rt_optimize_info, /* 187 */ - scheme_rt_compile_info, /* 188 */ - scheme_rt_cont_mark, /* 189 */ - scheme_rt_saved_stack, /* 190 */ - scheme_rt_reply_item, /* 191 */ - scheme_rt_closure_info, /* 192 */ - scheme_rt_overflow, /* 193 */ - scheme_rt_overflow_jmp, /* 194 */ - scheme_rt_meta_cont, /* 195 */ - scheme_rt_dyn_wind_cell, /* 196 */ - scheme_rt_dyn_wind_info, /* 197 */ - scheme_rt_dyn_wind, /* 198 */ - scheme_rt_dup_check, /* 199 */ - scheme_rt_thread_memory, /* 200 */ - scheme_rt_input_file, /* 201 */ - scheme_rt_input_fd, /* 202 */ - scheme_rt_oskit_console_input, /* 203 */ - scheme_rt_tested_input_file, /* 204 */ - scheme_rt_tested_output_file, /* 205 */ - scheme_rt_indexed_string, /* 206 */ - scheme_rt_output_file, /* 207 */ - scheme_rt_load_handler_data, /* 208 */ - scheme_rt_pipe, /* 209 */ - scheme_rt_beos_process, /* 210 */ - scheme_rt_system_child, /* 211 */ - scheme_rt_tcp, /* 212 */ - scheme_rt_write_data, /* 213 */ - scheme_rt_tcp_select_info, /* 214 */ - scheme_rt_param_data, /* 215 */ - scheme_rt_will, /* 216 */ - scheme_rt_linker_name, /* 217 */ - scheme_rt_param_map, /* 218 */ - scheme_rt_finalization, /* 219 */ - scheme_rt_finalizations, /* 220 */ - scheme_rt_cpp_object, /* 221 */ - scheme_rt_cpp_array_object, /* 222 */ - scheme_rt_stack_object, /* 223 */ - scheme_rt_preallocated_object, /* 224 */ - scheme_thread_hop_type, /* 225 */ - scheme_rt_srcloc, /* 226 */ - scheme_rt_evt, /* 227 */ - scheme_rt_syncing, /* 228 */ - scheme_rt_comp_prefix, /* 229 */ - scheme_rt_user_input, /* 230 */ - scheme_rt_user_output, /* 231 */ - scheme_rt_compact_port, /* 232 */ - scheme_rt_read_special_dw, /* 233 */ - scheme_rt_regwork, /* 234 */ - scheme_rt_rx_lazy_string, /* 235 */ - scheme_rt_buf_holder, /* 236 */ - scheme_rt_parameterization, /* 237 */ - scheme_rt_print_params, /* 238 */ - scheme_rt_read_params, /* 239 */ - scheme_rt_native_code, /* 240 */ - scheme_rt_native_code_plus_case, /* 241 */ - scheme_rt_jitter_data, /* 242 */ - scheme_rt_module_exports, /* 243 */ - scheme_rt_delay_load_info, /* 244 */ - scheme_rt_marshal_info, /* 245 */ - scheme_rt_unmarshal_info, /* 246 */ - scheme_rt_runstack, /* 247 */ - scheme_rt_sfs_info, /* 248 */ - scheme_rt_validate_clearing, /* 249 */ - scheme_rt_avl_node, /* 250 */ - scheme_rt_lightweight_cont, /* 251 */ - scheme_rt_export_info, /* 252 */ - scheme_rt_cont_jmp, /* 253 */ + scheme_rt_comp_env, /* 184 */ + scheme_rt_constant_binding, /* 185 */ + scheme_rt_resolve_info, /* 186 */ + scheme_rt_unresolve_info, /* 187 */ + scheme_rt_optimize_info, /* 188 */ + scheme_rt_compile_info, /* 189 */ + scheme_rt_cont_mark, /* 190 */ + scheme_rt_saved_stack, /* 191 */ + scheme_rt_reply_item, /* 192 */ + scheme_rt_closure_info, /* 193 */ + scheme_rt_overflow, /* 194 */ + scheme_rt_overflow_jmp, /* 195 */ + scheme_rt_meta_cont, /* 196 */ + scheme_rt_dyn_wind_cell, /* 197 */ + scheme_rt_dyn_wind_info, /* 198 */ + scheme_rt_dyn_wind, /* 199 */ + scheme_rt_dup_check, /* 200 */ + scheme_rt_thread_memory, /* 201 */ + scheme_rt_input_file, /* 202 */ + scheme_rt_input_fd, /* 203 */ + scheme_rt_oskit_console_input, /* 204 */ + scheme_rt_tested_input_file, /* 205 */ + scheme_rt_tested_output_file, /* 206 */ + scheme_rt_indexed_string, /* 207 */ + scheme_rt_output_file, /* 208 */ + scheme_rt_load_handler_data, /* 209 */ + scheme_rt_pipe, /* 210 */ + scheme_rt_beos_process, /* 211 */ + scheme_rt_system_child, /* 212 */ + scheme_rt_tcp, /* 213 */ + scheme_rt_write_data, /* 214 */ + scheme_rt_tcp_select_info, /* 215 */ + scheme_rt_param_data, /* 216 */ + scheme_rt_will, /* 217 */ + scheme_rt_linker_name, /* 218 */ + scheme_rt_param_map, /* 219 */ + scheme_rt_finalization, /* 220 */ + scheme_rt_finalizations, /* 221 */ + scheme_rt_cpp_object, /* 222 */ + scheme_rt_cpp_array_object, /* 223 */ + scheme_rt_stack_object, /* 224 */ + scheme_rt_preallocated_object, /* 225 */ + scheme_thread_hop_type, /* 226 */ + scheme_rt_srcloc, /* 227 */ + scheme_rt_evt, /* 228 */ + scheme_rt_syncing, /* 229 */ + scheme_rt_comp_prefix, /* 230 */ + scheme_rt_user_input, /* 231 */ + scheme_rt_user_output, /* 232 */ + scheme_rt_compact_port, /* 233 */ + scheme_rt_read_special_dw, /* 234 */ + scheme_rt_regwork, /* 235 */ + scheme_rt_rx_lazy_string, /* 236 */ + scheme_rt_buf_holder, /* 237 */ + scheme_rt_parameterization, /* 238 */ + scheme_rt_print_params, /* 239 */ + scheme_rt_read_params, /* 240 */ + scheme_rt_native_code, /* 241 */ + scheme_rt_native_code_plus_case, /* 242 */ + scheme_rt_jitter_data, /* 243 */ + scheme_rt_module_exports, /* 244 */ + scheme_rt_delay_load_info, /* 245 */ + scheme_rt_marshal_info, /* 246 */ + scheme_rt_unmarshal_info, /* 247 */ + scheme_rt_runstack, /* 248 */ + scheme_rt_sfs_info, /* 249 */ + scheme_rt_validate_clearing, /* 250 */ + scheme_rt_avl_node, /* 251 */ + scheme_rt_lightweight_cont, /* 252 */ + scheme_rt_export_info, /* 253 */ + scheme_rt_cont_jmp, /* 254 */ #endif _scheme_last_type_ diff --git a/src/racket/src/type.c b/src/racket/src/type.c index 0ed1de3248..b99e135fe4 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -594,7 +594,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc); GC_REG_TRAV(scheme_rt_cont_jmp, cont_jmp_proc); - GC_REG_TRAV(scheme_char_type, char_obj); + GC_REG_TRAV(scheme_char_type, small_atomic_obj); GC_REG_TRAV(scheme_integer_type, bad_trav); GC_REG_TRAV(scheme_bignum_type, bignum_obj); GC_REG_TRAV(scheme_rational_type, rational_obj); @@ -611,7 +611,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_place_dead_type, small_object); #endif GC_REG_TRAV(scheme_keyword_type, symbol_obj); - GC_REG_TRAV(scheme_null_type, char_obj); /* small */ + GC_REG_TRAV(scheme_null_type, small_atomic_obj); GC_REG_TRAV(scheme_pair_type, cons_cell); GC_REG_TRAV(scheme_mutable_pair_type, cons_cell); GC_REG_TRAV(scheme_raw_pair_type, cons_cell); @@ -624,10 +624,10 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_input_port_type, input_port); GC_REG_TRAV(scheme_output_port_type, output_port); - GC_REG_TRAV(scheme_eof_type, char_obj); /* small */ - GC_REG_TRAV(scheme_true_type, char_obj); /* small */ - GC_REG_TRAV(scheme_false_type, char_obj); /* small */ - GC_REG_TRAV(scheme_void_type, char_obj); /* small */ + GC_REG_TRAV(scheme_eof_type, small_atomic_obj); + GC_REG_TRAV(scheme_true_type, small_atomic_obj); + GC_REG_TRAV(scheme_false_type, small_atomic_obj); + GC_REG_TRAV(scheme_void_type, small_atomic_obj); GC_REG_TRAV(scheme_syntax_compiler_type, syntax_compiler); GC_REG_TRAV(scheme_macro_type, small_object); GC_REG_TRAV(scheme_box_type, small_object); @@ -654,7 +654,7 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_eval_waiting_type, bad_trav); GC_REG_TRAV(scheme_tail_call_waiting_type, bad_trav); - GC_REG_TRAV(scheme_undefined_type, char_obj); /* small */ + GC_REG_TRAV(scheme_undefined_type, small_atomic_obj); GC_REG_TRAV(scheme_placeholder_type, small_object); GC_REG_TRAV(scheme_table_placeholder_type, iptr_obj); @@ -673,9 +673,9 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_security_guard_type, guard_val); GC_REG_TRAV(scheme_nack_evt_type, twoptr_obj); - GC_REG_TRAV(scheme_always_evt_type, char_obj); - GC_REG_TRAV(scheme_never_evt_type, char_obj); - GC_REG_TRAV(scheme_thread_recv_evt_type, char_obj); + GC_REG_TRAV(scheme_always_evt_type, small_atomic_obj); + GC_REG_TRAV(scheme_never_evt_type, small_atomic_obj); + GC_REG_TRAV(scheme_thread_recv_evt_type, small_atomic_obj); GC_REG_TRAV(scheme_port_closed_evt_type, small_object); GC_REG_TRAV(scheme_inspector_type, mark_inspector); @@ -709,6 +709,8 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_rib_delimiter_type, small_object); GC_REG_TRAV(scheme_noninline_proc_type, small_object); GC_REG_TRAV(scheme_prune_context_type, small_object); + + GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj); } END_XFORM_SKIP; diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c index 820ab6da3c..19643e26d9 100644 --- a/src/racket/src/validate.c +++ b/src/racket/src/validate.c @@ -42,7 +42,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, struct Validate_Clearing *vc, int tailpos, int need_flonum, Scheme_Hash_Tree *procs, - int expected_results); + int expected_results, + Scheme_Hash_Table **_st_ht); static int validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, Validate_TLS tls, @@ -132,6 +133,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, struct Validate_Clearing *vc; Validate_TLS tls; mzshort *tl_state; + Scheme_Hash_Table *st_ht = NULL; depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); @@ -188,7 +190,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, - vc, 1, 0, NULL, -1)) { + vc, 1, 0, NULL, -1, &st_ht)) { tl_timestamp++; if (0) { printf("increment to %d for %d %p\n", tl_timestamp, @@ -204,7 +206,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, 0, NULL, 0, 0, - vc, 1, 0, NULL, -1); + vc, 1, 0, NULL, -1, NULL); } } @@ -242,7 +244,7 @@ static int validate_toplevel(Scheme_Object *expr, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, skip_refs_check ? 1 : 0, 0, - make_clearing_stack(), 0, 0, NULL, 1); + make_clearing_stack(), 0, 0, NULL, 1, NULL); } static int define_values_validate(Scheme_Object *data, Mz_CPort *port, @@ -253,9 +255,10 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, mzshort *tl_state, mzshort tl_timestamp, int result_ignored, struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) + Scheme_Hash_Tree *procs, + Scheme_Hash_Table **_st_ht) { - int i, size, flags, result; + int i, size, flags, result, is_struct, field_count, field_icount, uses_super; Scheme_Object *val, *only_var; val = SCHEME_VEC_ELS(data)[0]; @@ -357,14 +360,45 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, only_var = NULL; } + if (scheme_is_simple_make_struct_type(val, size-1, 1, 1, NULL, + &field_count, &field_icount, + &uses_super, + NULL, (_st_ht ? *_st_ht : NULL), + NULL, 0, NULL, NULL, 5)) { + /* This set of bindings is constant across invocations, but + if `uses_super', we need to increment tl_timestamp for + subtype-defining `struct' sequences. */ + is_struct = 1; + } else { + is_struct = 0; + uses_super = 0; + field_count = 0; + field_icount = 0; + } + result = validate_expr(port, val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, - tl_state, tl_timestamp, + tl_state, tl_timestamp + (uses_super ? 1 : 0), NULL, !!only_var, 0, vc, 0, 0, NULL, - size-1); - if (scheme_is_simple_make_struct_type(val, size-1, 1, 1)) + size-1, NULL); + + if (is_struct) { + if (_st_ht && (field_count == field_icount)) { + /* record `struct:' binding as constant across invocations, + so that it can be recognized for sub-struct declarations */ + if (!*_st_ht) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table_eqv(); + *_st_ht = ht; + } + scheme_hash_set(*_st_ht, + scheme_make_integer(SCHEME_TOPLEVEL_POS(SCHEME_VEC_ELS(data)[1])), + scheme_make_integer(field_count)); + } + /* In any case, treat the bindings as constant */ result = 2; + } flags = SCHEME_TOPLEVEL_READY; if (result == 2) { @@ -373,7 +407,7 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port, that's good enough for ensuring safety. */ flags = SCHEME_TOPLEVEL_CONST; } - + for (i = 1; i < size; i++) { int ts = (tl_timestamp + (result ? 0 : 1)); if (tl_state) { @@ -422,7 +456,7 @@ static int set_validate(Scheme_Object *data, Mz_CPort *port, r1 = validate_expr(port, sb->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); r2 = validate_toplevel(sb->var, port, stack, tls, depth, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, @@ -472,12 +506,12 @@ static int apply_values_validate(Scheme_Object *data, Mz_CPort *port, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); r2 = validate_expr(port, e, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, -1); + NULL, 0, 0, vc, 0, 0, procs, -1, NULL); return validate_join(r1, r2); } @@ -501,12 +535,12 @@ static void inline_variant_validate(Scheme_Object *data, Mz_CPort *port, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); validate_expr(port, f2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, @@ -533,7 +567,7 @@ static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stac validate_expr(port, e, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } } @@ -564,7 +598,7 @@ static int bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, return validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, result_ignored, vc, tailpos, 0, procs, expected_results); + NULL, 0, result_ignored, vc, tailpos, 0, procs, expected_results, NULL); } static int begin0_validate(Scheme_Object *data, Mz_CPort *port, @@ -591,7 +625,7 @@ static int begin0_validate(Scheme_Object *data, Mz_CPort *port, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, i > 0, vc, 0, 0, procs, - (i > 0) ? -1 : expected_results); + (i > 0) ? -1 : expected_results, NULL); result = validate_join_seq(r, result); } @@ -701,6 +735,7 @@ static Scheme_Object *validate_k(void) struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4; void *tl_use_map = (((void **)p->ku.k.p5)[4]); mzshort *tl_state = (((void **)p->ku.k.p5)[5]); + Scheme_Hash_Table **_st_ht = (((void **)p->ku.k.p5)[6]); int r; p->ku.k.p1 = NULL; @@ -714,7 +749,8 @@ static Scheme_Object *validate_k(void) args[3], args[4], args[5], tl_use_map, tl_state, args[10], app_rator, args[6], args[7], vc, args[8], - args[9], procs, args[11]); + args[9], procs, args[11], + _st_ht); return scheme_make_integer(r); } @@ -903,7 +939,7 @@ void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, validate_expr(port, data->code, new_stack, tls, sz, sz, base, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 1, 0, procs, -1); + NULL, 0, 0, vc, 1, 0, procs, -1, NULL); } static Scheme_Hash_Tree *as_nonempty_procs(Scheme_Hash_Tree *procs) @@ -1142,7 +1178,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, int result_ignored, struct Validate_Clearing *vc, int tailpos, int need_flonum, Scheme_Hash_Tree *procs, - int expected_results) + int expected_results, + Scheme_Hash_Table **_st_ht) /* result is 1 if result is `expected_results' values with no exceptions and no use of any non-ready binding; it's 2 if the result is furthermore a "constant" (i.e., the same shape result for @@ -1158,7 +1195,13 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Object *r; void **pr; int *args; + Scheme_Hash_Table **_2st_ht = NULL; + if (_st_ht) { + _2st_ht = MALLOC_N(Scheme_Hash_Table*, 1); + *_2st_ht = *_st_ht; + } + args = MALLOC_N_ATOMIC(int, 11); p->ku.k.p1 = (void *)port; @@ -1179,18 +1222,23 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, args[10] = tl_timestamp; args[11] = expected_results; - pr = MALLOC_N(void*, 5); + pr = MALLOC_N(void*, 6); pr[0] = (void *)args; pr[1] = (void *)app_rator; pr[2] = (void *)tls; pr[3] = (void *)procs; pr[4] = tl_use_map; pr[5] = tl_state; + pr[6] = _2st_ht; p->ku.k.p5 = (void *)pr; r = scheme_handle_stack_overflow(validate_k); + if (_st_ht) { + *_st_ht = *_2st_ht; + } + return SCHEME_INT_VAL(r); } #endif @@ -1406,7 +1454,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs, 1); + i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(result, r); } @@ -1414,10 +1462,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, check_self_call_valid(app->args[0], port, vc, delta, stack); if (result) { - if (scheme_is_simple_make_struct_type((Scheme_Object *)app, expected_results, 1, 1)) - r = 2; - else - r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); + r = scheme_is_functional_primitive(app->args[0], app->num_args, expected_results); result = validate_join(result, r); } } @@ -1437,12 +1482,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 1, 0, vc, 0, 0, procs, 1); + NULL, 1, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); r = validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - app->rator, 2, 0, vc, 0, 0, procs, 1); + app->rator, 2, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); if (tailpos) @@ -1470,17 +1515,17 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 1, 0, vc, 0, 0, procs, 1); + NULL, 1, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); r = validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - app->rator, 2, 0, vc, 0, 0, procs, 1); + app->rator, 2, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); r = validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - app->rator, 3, 0, vc, 0, 0, procs, 1); + app->rator, 3, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); if (tailpos) @@ -1507,7 +1552,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 1, vc, 0, 0, procs, -1); + NULL, 0, 1, vc, 0, 0, procs, -1, NULL); result = validate_join_seq(result, r); } @@ -1526,7 +1571,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); result = validate_join(r, result); /* This is where letlimit is useful. It prevents let-assignment in the @@ -1539,7 +1584,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, result_ignored, vc, tailpos, 0, procs, - expected_results); + expected_results, NULL); result = validate_join_seq(result, r); /* since we're branchig, the result isn't constant: */ @@ -1583,12 +1628,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); result = validate_join_seq(result, r); r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); result = validate_join_seq(result, r); expr = wcm->body; @@ -1633,7 +1678,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, r = validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, lv->count); + NULL, 0, 0, vc, 0, 0, procs, lv->count, NULL); result = validate_join_seq(r, result); /* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ @@ -1740,7 +1785,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs, - 1); + 1, NULL); result = validate_join_seq(r, result); #if !CAN_RESET_STACK_SLOT @@ -1767,7 +1812,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, define_values_validate(expr, port, stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - result_ignored, vc, tailpos, procs)); + result_ignored, vc, tailpos, procs, + _st_ht)); break; case scheme_define_syntaxes_type: no_flo(need_flonum, port); @@ -1879,7 +1925,7 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr, validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts, tl_use_map, tl_state, tl_timestamp, - NULL, 0, 0, vc, 0, 0, procs, 1); + NULL, 0, 0, vc, 0, 0, procs, 1, NULL); } } else if (need_flonum) { if (!SCHEME_FLOATP(expr))