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

track information about `struct' bindings during compilation

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2012-10-26 19:41:34 -06:00
parent e698be778b
commit 5f30cc87ea
17 changed files with 859 additions and 296 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/racket/private/define-struct.rkt
View File

@ -516,7 +516,10 @@
stx stx
super-id)) super-id))
(and super-expr (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 [prune (lambda (stx) (identifier-prune-lexical-context stx
(list (syntax-e stx) '#%top)))] (list (syntax-e stx) '#%top)))]
[reflect-name-expr (if reflect-name-expr [reflect-name-expr (if reflect-name-expr

148
collects/tests/racket/optimize.rktl
View File

@ -1682,6 +1682,154 @@
(hash-ref '#hash((x . y)) x add1)) (hash-ref '#hash((x . y)) x add1))
#f) #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 ;; Check bytecode verification of lifted functions

6
src/racket/src/compenv.c
View File

@ -2000,7 +2000,11 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
is_constant = 2; is_constant = 2;
else if (SAME_OBJ(mod_constant, scheme_fixed_key)) else if (SAME_OBJ(mod_constant, scheme_fixed_key))
is_constant = 1; 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) if (_inline_variant)
*_inline_variant = mod_constant; *_inline_variant = mod_constant;
is_constant = 2; is_constant = 2;

8
src/racket/src/compile.c
View File

@ -2923,7 +2923,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
total++; total++;
} else if (opt } else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first)) && (((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. */ /* A value that is not the result. We'll drop it. */
total++; total++;
} else { } 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 /* can't optimize away a begin0 at read time; it's too late, since the
return is combined with EXPD_BEGIN0 */ return is combined with EXPD_BEGIN0 */
addconst = 1; 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 /* We can't optimize (begin0 expr cont) to expr because
exp is not in tail position in the original (so we'd mess exp is not in tail position in the original (so we'd mess
up continuation marks). */ up continuation marks). */
@ -2983,7 +2983,7 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
} else if (opt } else if (opt
&& (((opt > 0) && (k < total)) && (((opt > 0) && (k < total))
|| ((opt < 0) && k)) || ((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. */ /* Value not the result. Do nothing. */
} else } else
o->array[i++] = v; 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); 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 */ /* short cut */
a = _scheme_eval_linked_expr_multi(a); a = _scheme_eval_linked_expr_multi(a);
} else { } else {

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

@ -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)) if (SAME_OBJ(values, scheme_current_thread->values_buffer))
scheme_current_thread->values_buffer = NULL; 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++) { for (i = 0; i < g; i++) {
var = SCHEME_VEC_ELS(vec)[i+delta]; var = SCHEME_VEC_ELS(vec)[i+delta];

5
src/racket/src/jitcommon.c
View File

@ -1520,8 +1520,13 @@ int scheme_generate_struct_op(mz_jit_state *jitter, int kind, int for_branch,
} }
} else { } else {
if (type_pos != 0) { if (type_pos != 0) {
if (kind == 1) {
bref3 = jit_blti_i(jit_forward(), JIT_R2, type_pos);
} else {
(void)jit_blti_i(refslow2, JIT_R2, type_pos); (void)jit_blti_i(refslow2, JIT_R2, type_pos);
bref3 = NULL;
} }
} else
bref3 = NULL; bref3 = NULL;
} }
CHECK_LIMIT(); CHECK_LIMIT();

14
src/racket/src/module.c
View File

@ -4121,7 +4121,7 @@ static void setup_accessible_table(Scheme_Module *m)
for (i = 0; i < cnt; i++) { for (i = 0; i < cnt; i++) {
form = SCHEME_VEC_ELS(m->bodies[0])[i]; form = SCHEME_VEC_ELS(m->bodies[0])[i];
if (SAME_TYPE(SCHEME_TYPE(form), scheme_define_values_type)) { 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; ) { for (k = SCHEME_VEC_SIZE(form); k-- > 1; ) {
tl = SCHEME_VEC_ELS(form)[k]; tl = SCHEME_VEC_ELS(form)[k];
if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) { if (SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_SEAL) {
@ -4154,13 +4154,17 @@ static void setup_accessible_table(Scheme_Module *m)
} }
} else { } else {
if (!checked_st) { if (!checked_st) {
is_st = scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0], is_st = !!scheme_is_simple_make_struct_type(SCHEME_VEC_ELS(form)[0],
SCHEME_VEC_SIZE(form)-1, SCHEME_VEC_SIZE(form)-1,
1, 1); 1, 1, NULL, &st_count, &st_icount,
NULL,
NULL, NULL, NULL, 0,
m->prefix->toplevels, ht,
5);
checked_st = 1; checked_st = 1;
} }
if (is_st) 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); 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; Scheme_Object *prev = NULL, *next;
for (p = first; !SCHEME_NULLP(p); p = next) { for (p = first; !SCHEME_NULLP(p); p = next) {
next = SCHEME_CDR(p); 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) if (prev)
SCHEME_CDR(prev) = next; SCHEME_CDR(prev) = next;
else else

38
src/racket/src/mzmark_type.inc
View File

@ -248,6 +248,25 @@ static int small_object_FIXUP(void *p, struct NewGC *gc) {
#define small_object_IS_CONST_SIZE 1 #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) { static int app_rec_SIZE(void *p, struct NewGC *gc) {
Scheme_App_Rec *r = (Scheme_App_Rec *)p; 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 #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) { static int bignum_obj_SIZE(void *p, struct NewGC *gc) {
Scheme_Bignum *b = (Scheme_Bignum *)p; Scheme_Bignum *b = (Scheme_Bignum *)p;

12
src/racket/src/mzmarksrc.c
View File

@ -89,6 +89,12 @@ small_object {
gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object)); gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object));
} }
small_atomic_obj {
mark:
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object));
}
app_rec { app_rec {
Scheme_App_Rec *r = (Scheme_App_Rec *)p; Scheme_App_Rec *r = (Scheme_App_Rec *)p;
@ -467,12 +473,6 @@ escaping_cont_proc {
gcBYTES_TO_WORDS(sizeof(Scheme_Escaping_Cont)); gcBYTES_TO_WORDS(sizeof(Scheme_Escaping_Cont));
} }
char_obj {
mark:
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Small_Object));
}
bignum_obj { bignum_obj {
Scheme_Bignum *b = (Scheme_Bignum *)p; Scheme_Bignum *b = (Scheme_Bignum *)p;

511
src/racket/src/optimize.c
View File

@ -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); 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 { typedef struct Scheme_Once_Used {
Scheme_Object so; Scheme_Object so;
Scheme_Object *expr; Scheme_Object *expr;
@ -143,6 +145,9 @@ void scheme_init_optimize()
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
register_traversers(); register_traversers();
#endif #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; 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) static void note_match(int actual, int expected, Optimize_Info *warn_info)
{ {
if (!warn_info || (expected == -1)) 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, 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 /* Checks whether the bytecode `o' returns `vals' values with no
side-effects and without pushing and using continuation marks. side-effects and without pushing and using continuation marks.
-1 for vals means that any return count is ok. -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) { if (vtype == scheme_branch_type) {
Scheme_Branch_Rec *b; Scheme_Branch_Rec *b;
b = (Scheme_Branch_Rec *)o; b = (Scheme_Branch_Rec *)o;
return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info, deeper_than, 0) 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, warn_info, deeper_than, no_id) && 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, 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 #if 0
@ -268,15 +314,15 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
a let_value_type! */ a let_value_type! */
if (vtype == scheme_let_value_type) { if (vtype == scheme_let_value_type) {
Scheme_Let_Value *lv = (Scheme_Let_Value *)o; 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) 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, warn_info, deeper_than, no_id)); && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than, no_id));
} }
#endif #endif
if (vtype == scheme_let_one_type) { if (vtype == scheme_let_one_type) {
Scheme_Let_One *lo = (Scheme_Let_One *)o; Scheme_Let_One *lo = (Scheme_Let_One *)o;
return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1, 0) 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, warn_info, deeper_than + 1, no_id)); && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, opt_info, warn_info, deeper_than + 1, no_id));
} }
if (vtype == scheme_let_void_type) { 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; Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body;
if ((lv2->count == 1) if ((lv2->count == 1)
&& (lv2->position == 0) && (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, deeper_than + 1 + lv->count,
0)) { 0)) {
o = lv2->body; 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 ((lh->count == 1) && (lh->num_clauses == 1)) {
if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; 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; o = lv->body;
deeper_than++; deeper_than++;
goto try_again; 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) if ((app->num_args >= 4) && (app->num_args <= 11)
&& SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) {
note_match(5, vals, warn_info); 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)
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; int i;
for (i = app->num_args; i--; ) { for (i = app->num_args; i--; ) {
if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, opt_info, warn_info,
deeper_than + (resolved ? app->num_args : 0), 0)) deeper_than + (resolved ? app->num_args : 0), 0))
return 0; return 0;
} }
return 1; return 1;
} else if (!(SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_MULTI_RESULT)) { } 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); note_match(1, vals, warn_info);
} else if (SAME_OBJ(scheme_values_func, app->args[0])) { } else if (SAME_OBJ(scheme_values_func, app->args[0])) {
note_match(app->num_args, vals, warn_info); note_match(app->num_args, vals, warn_info);
@ -356,12 +395,13 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
if (vtype == scheme_application2_type) { if (vtype == scheme_application2_type) {
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
if (SCHEME_PRIMP(app->rator)) { if (scheme_is_functional_primitive(app->rator, 1, vals)
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, warn_info, if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, opt_info, warn_info,
deeper_than + (resolved ? 1 : 0), 0)) deeper_than + (resolved ? 1 : 0), 0))
return 1; return 1;
} else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT) } 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)) { || SAME_OBJ(scheme_values_func, app->rator)) {
note_match(1, vals, warn_info); 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) { if (vtype == scheme_application3_type) {
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
if (SCHEME_PRIMP(app->rator)) { if (scheme_is_functional_primitive(app->rator, 2, vals)
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, warn_info, if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, opt_info, warn_info,
deeper_than + (resolved ? 2 : 0), 0) deeper_than + (resolved ? 2 : 0), 0)
&& scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, opt_info, warn_info,
deeper_than + (resolved ? 2 : 0), 0)) deeper_than + (resolved ? 2 : 0), 0))
return 1; return 1;
} else if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) { } else if (SCHEME_PRIMP(app->rator)) {
if (!(SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_MULTI_RESULT)) {
note_match(1, vals, warn_info); note_match(1, vals, warn_info);
} else if (SAME_OBJ(scheme_values_func, app->rator)) { } else if (SAME_OBJ(scheme_values_func, app->rator)) {
note_match(2, vals, warn_info); 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; 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; return 0;
} }
@ -460,33 +517,58 @@ static int is_int_list(Scheme_Object *o, int up_to)
return SCHEME_NULLP(o); 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)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e; Scheme_App_Rec *app = (Scheme_App_Rec *)e;
int delta = (resolved ? app->num_args : 0); int delta = (resolved ? app->num_args : 0);
if (SAME_OBJ(app->args[0], scheme_values_func) 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; int i;
for (i = app->num_args; i > 0; i--) { for (i = app->num_args; i > 3; i--) {
if (is_local_ref(app->args[1], delta, 5)) { if (is_local_ref(app->args[i], delta, 5)) {
/* ok */ /* ok */
} 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)) { } else if (SAME_TYPE(SCHEME_TYPE(app->args[i]), scheme_application3_type)) {
Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i]; Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)app->args[i];
int delta2 = delta + (resolved ? 2 : 0); int delta2 = delta + (resolved ? 2 : 0);
if (SAME_OBJ(app3->rator, scheme_make_struct_field_accessor_proc)) { if (!ok_proc_creator_args(app3->rator, app3->rand1, app3->rand2, NULL,
if (!is_local_ref(app3->rand1, delta2+3, 1) delta2, field_count))
&& 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))
break; break;
} else } else
break; break;
} }
} if (i <= 3)
if (i <= 0)
return 1; return 1;
} }
} }
@ -509,18 +591,112 @@ static Scheme_Object *skip_clears(Scheme_Object *body)
return body; return body;
} }
int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved, int check_auto) static int is_constant_super(Scheme_Object *arg,
/* Checks whether it's a `make-struct-type' call that certainly succeeds Scheme_Hash_Table *top_level_consts,
(i.e., no exception) --- pending a check of argument 5 if !check_auto */ 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 (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) {
if ((vals == 5) || (vals < 0)) { if ((vals == 5) || (vals < 0)) {
Scheme_App_Rec *app = (Scheme_App_Rec *)e; Scheme_App_Rec *app = (Scheme_App_Rec *)e;
if ((app->num_args >= 4) && (app->num_args <= 11) if ((app->num_args >= 4) && (app->num_args <= 11)
&& SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { && 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]) 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_INTP(app->args[3])
&& (SCHEME_INT_VAL(app->args[3]) >= 0) && (SCHEME_INT_VAL(app->args[3]) >= 0)
&& SCHEME_INTP(app->args[4]) && 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) && ((app->num_args < 5)
/* auto-field value: */ /* auto-field value: */
|| !check_auto || !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) && ((app->num_args < 6)
/* no properties: */ /* no properties: */
|| SCHEME_NULLP(app->args[6])) || SCHEME_NULLP(app->args[6]))
&& ((app->num_args < 7) && ((app->num_args < 7)
/* inspector: */ /* inspector: */
|| SCHEME_FALSEP(app->args[7]) || 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])) || is_current_inspector_call(app->args[7]))
&& ((app->num_args < 8) && ((app->num_args < 8)
/* propcedure property: */ /* propcedure property: */
@ -551,7 +730,20 @@ int scheme_is_simple_make_struct_type(Scheme_Object *e, int vals, int resolved,
/* constructor name: */ /* constructor name: */
|| SCHEME_FALSEP(app->args[11]) || SCHEME_FALSEP(app->args[11])
|| SCHEME_SYMBOLP(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 ((lh->count == 5) && (lh->num_clauses == 1)) {
if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type) if (SAME_TYPE(SCHEME_TYPE(lv->value), scheme_application_type)) {
&& scheme_is_simple_make_struct_type(lv->value, 5, resolved, check_auto)) { 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 /* We have (let-values ([... (make-struct-type)]) ....), so make sure body
just uses `make-struct-field-{accessor,mutator}'. */ just uses `make-struct-field-{accessor,mutator}'. */
if (is_values_with_accessors_and_mutators(lv->body, vals, resolved)) if (is_values_with_accessors_and_mutators(lv->body, vals, resolved, ifc)) {
return 1; 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)) { if ((lv->position == 0) && (lv->count == 5)) {
Scheme_Object *e2; Scheme_Object *e2;
e2 = skip_clears(lv->value); e2 = skip_clears(lv->value);
if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type) if (SAME_TYPE(SCHEME_TYPE(e2), scheme_application_type)) {
&& scheme_is_simple_make_struct_type(e2, 5, resolved, check_auto)) { 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 /* We have (let-values ([... (make-struct-type)]) ....), so make sure body
just uses `make-struct-field-{accessor,mutator}'. */ just uses `make-struct-field-{accessor,mutator}'. */
e2 = skip_clears(lv->body); e2 = skip_clears(lv->body);
if (is_values_with_accessors_and_mutators(e2, vals, resolved)) if (is_values_with_accessors_and_mutators(e2, vals, resolved, ifc)) {
return 1; 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) 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) if ((SAME_OBJ(scheme_values_func, app->rator)
|| SAME_OBJ(scheme_list_star_proc, 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))) { || single_valued_noncm_expression(app->rand, 5))) {
info->preserves_marks = 1; info->preserves_marks = 1;
info->single_result = 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 (SAME_OBJ(scheme_list_proc, app2->rator)) {
if (IS_NAMED_PRIM(app->rator, "car")) { if (IS_NAMED_PRIM(app->rator, "car")) {
/* (car (list X)) */ /* (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)) { || single_valued_noncm_expression(app2->rand, 5)) {
alt = app2->rand; alt = app2->rand;
} }
} else if (IS_NAMED_PRIM(app->rator, "cdr")) { } else if (IS_NAMED_PRIM(app->rator, "cdr")) {
/* (cdr (list X)) */ /* (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; 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_proc, app3->rator)
|| SAME_OBJ(scheme_list_star_proc, app3->rator)) { || SAME_OBJ(scheme_list_star_proc, app3->rator)) {
/* (car ({cons|list|list*} X Y)) */ /* (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)) || 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; alt = app3->rand1;
} }
} }
} else if (IS_NAMED_PRIM(app->rator, "cdr")) { } else if (IS_NAMED_PRIM(app->rator, "cdr")) {
/* (cdr (cons X Y)) */ /* (cdr (cons X Y)) */
if (SAME_OBJ(scheme_cons_proc, app3->rator)) { 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)) || 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; alt = app3->rand2;
} }
} }
} else if (IS_NAMED_PRIM(app->rator, "cadr")) { } else if (IS_NAMED_PRIM(app->rator, "cadr")) {
if (SAME_OBJ(scheme_list_proc, app3->rator)) { if (SAME_OBJ(scheme_list_proc, app3->rator)) {
/* (cadr (list X Y)) */ /* (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)) || 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; 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 /* Inlining and constant propagation can expose
omittable expressions. */ omittable expressions. */
if ((i + 1 != count) 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++; drop++;
info->size = prev_size; info->size = prev_size;
s->array[i] = NULL; s->array[i] = NULL;
@ -2655,7 +2915,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
} }
/* Try optimize: (if <omitable-expr> v v) => v */ /* Try optimize: (if <omitable-expr> 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)) { && equivalent_exprs(tb, fb)) {
info->size -= 2; /* could be more precise */ info->size -= 2; /* could be more precise */
return tb; 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 /* 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': */ 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) 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)); b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context));
if (omittable_key(k, info) if (omittable_key(k, info)
&& scheme_omittable_expr(v, 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, -1, 0)) && scheme_omittable_expr(b, -1, 20, 0, info, info, -1, 0))
return b; return b;
/* info->single_result is already set */ /* info->single_result is already set */
@ -3030,17 +3290,53 @@ case_lambda_shift(Scheme_Object *data, int delta, int after_depth)
static Scheme_Object * static Scheme_Object *
begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) 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++) { for (i = 0; i < count; i++) {
Scheme_Object *le; prev_size = info->size;
le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info,
le = scheme_optimize_expr(s->array[i],
info,
(!i (!i
? scheme_optimize_result_context(context) ? scheme_optimize_result_context(context)
: 0)); : 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 */ /* 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); pos = SCHEME_TOPLEVEL_POS(value);
value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos));
value = no_potential_size(value); 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) if (value)
return 1; 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; Scheme_Let_Header *lh = (Scheme_Let_Header *)value;
if (lh->num_clauses == 1) { if (lh->num_clauses == 1) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; 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; value = lv->body;
info = NULL; info = NULL;
} else } else
@ -3819,7 +4118,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
if ((pre_body->count != 1) if ((pre_body->count != 1)
&& is_values_apply(value, pre_body->count) && is_values_apply(value, pre_body->count)
&& ((!is_rec && no_mutable_bindings(pre_body)) && ((!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 (is_rec
? (pre_body->position + pre_body->count) ? (pre_body->position + pre_body->count)
: -1), : -1),
@ -4202,7 +4501,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i
} }
if (!used 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) || ((pre_body->count == 1)
&& first_once_used && first_once_used
&& (first_once_used->pos == pos) && (first_once_used->pos == pos)
@ -4630,7 +4929,7 @@ static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimi
return NULL; 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 <omitable>* <proc>) */ /* recognize (begin <omitable>* <proc>) */
if (SCHEME_TYPE(e) == scheme_sequence_type) { if (SCHEME_TYPE(e) == scheme_sequence_type) {
@ -4638,7 +4937,7 @@ static int is_general_compiled_proc(Scheme_Object *e)
if (seq->count > 0) { if (seq->count > 0) {
int i; int i;
for (i = seq->count - 1; 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; 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)) { if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
Scheme_Object *e2; Scheme_Object *e2;
e2 = SCHEME_VEC_ELS(e)[1]; e2 = SCHEME_VEC_ELS(e)[1];
if (is_general_compiled_proc(e2)) if (is_general_compiled_proc(e2, info))
is_proc_def = 1; 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 (including raising an exception), then continue the group of
simultaneous definitions: */ simultaneous definitions: */
if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { 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]; vars = SCHEME_VEC_ELS(e)[0];
e = SCHEME_VEC_ELS(e)[1]; e = SCHEME_VEC_ELS(e)[1];
n = scheme_list_length(vars); 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 (n == 1) {
if (scheme_compiled_propagate_ok(e, info)) if (scheme_compiled_propagate_ok(e, info))
@ -4778,20 +5083,28 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
cnst = 1; cnst = 1;
sproc = 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; cnst = 1;
} }
if (cnst) { if (cnst) {
Scheme_Toplevel *tl; Scheme_Toplevel *tl;
while (n--) { int i;
for (i = 0; i < n; i++) {
tl = (Scheme_Toplevel *)SCHEME_CAR(vars); tl = (Scheme_Toplevel *)SCHEME_CAR(vars);
vars = SCHEME_CDR(vars); vars = SCHEME_CDR(vars);
if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) {
Scheme_Object *e2; 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); e2 = scheme_make_noninline_proc(e);
} else if (IS_COMPILED_PROC(e)) { } else if (IS_COMPILED_PROC(e)) {
e2 = optimize_clone(1, e, info, 0, 0); e2 = optimize_clone(1, e, info, 0, 0);
@ -4811,17 +5124,27 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
if (e2) { if (e2) {
int pos; int pos;
pos = tl->position;
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) if (!consts)
consts = scheme_make_hash_table(SCHEME_hash_ptr); consts = scheme_make_hash_table(SCHEME_hash_ptr);
pos = tl->position;
scheme_hash_set(consts, scheme_make_integer(pos), e2); scheme_hash_set(consts, scheme_make_integer(pos), e2);
if (!re_consts) if (!re_consts)
re_consts = scheme_make_hash_table(SCHEME_hash_ptr); re_consts = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(re_consts, scheme_make_integer(i_m), scheme_hash_set(re_consts, scheme_make_integer(i_m),
scheme_make_integer(pos)); scheme_make_integer(pos));
}
} else { } else {
/* At least mark it as fixed */ /* At least mark it as fixed */
if (!fixed_table) { if (!fixed_table) {
fixed_table = scheme_make_hash_table(SCHEME_hash_ptr); fixed_table = scheme_make_hash_table(SCHEME_hash_ptr);
if (!consts) if (!consts)
@ -4851,7 +5174,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
} }
} }
} else { } 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) if (i_m + 1 == cnt)
cont = 0; 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++) { for (i_m = 0; i_m < cnt; i_m++) {
/* Optimize this expression: */ /* Optimize this expression: */
e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; 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++; 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++) { for (i_m = 0; i_m < cnt; i_m++) {
/* Optimize this expression: */ /* Optimize this expression: */
e = SCHEME_VEC_ELS(m->bodies[0])[i_m]; 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; SCHEME_VEC_ELS(vec)[j++] = e;
} }
} }

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

@ -508,7 +508,7 @@ static Scheme_Object *look_for_letv_change(Scheme_Sequence *s)
v = s->array[i]; v = s->array[i];
if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) {
Scheme_Let_Value *lv = (Scheme_Let_Value *)v; 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 esize = s->count - (i + 1);
int nsize = i + 1; int nsize = i + 1;
Scheme_Object *nv, *ev; Scheme_Object *nv, *ev;
@ -1240,7 +1240,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
} }
if (j >= 0) if (j >= 0)
break; 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; break;
} }
if (i < 0) { if (i < 0) {

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

@ -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_type_proc;
extern Scheme_Object *scheme_make_struct_field_accessor_proc; extern Scheme_Object *scheme_make_struct_field_accessor_proc;
extern Scheme_Object *scheme_make_struct_field_mutator_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_current_inspector_proc;
extern Scheme_Object *scheme_varref_const_p_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_used_ever(Scheme_Comp_Env *env, int which);
int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, 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_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_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_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); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which);

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

@ -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, it might not because (1) it was introduced late by inlining,
or (2) the rhs expression doesn't always produce a single or (2) the rhs expression doesn't always produce a single
value. */ 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; rhs = scheme_false;
} else if ((ip < info->max_calls[pos]) } else if ((ip < info->max_calls[pos])
&& SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {

11
src/racket/src/struct.c
View File

@ -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_type_proc;
READ_ONLY Scheme_Object *scheme_make_struct_field_accessor_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_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_current_inspector_proc;
READ_ONLY Scheme_Object *scheme_recur_symbol; READ_ONLY Scheme_Object *scheme_recur_symbol;
READ_ONLY Scheme_Object *scheme_display_symbol; READ_ONLY Scheme_Object *scheme_display_symbol;
@ -607,11 +608,13 @@ scheme_init_struct (Scheme_Env *env)
"struct?", "struct?",
1, 1, 1), 1, 1, 1),
env); env);
scheme_add_global_constant("struct-type?",
scheme_make_folding_prim(struct_type_p, REGISTER_SO(scheme_struct_type_p_proc);
scheme_struct_type_p_proc = scheme_make_folding_prim(struct_type_p,
"struct-type?", "struct-type?",
1, 1, 1), 1, 1, 1);
env); scheme_add_global_constant("struct-type?", scheme_struct_type_p_proc, env);
scheme_add_global_constant("struct-type-property?", scheme_add_global_constant("struct-type-property?",
scheme_make_folding_prim(struct_type_property_p, scheme_make_folding_prim(struct_type_property_p,
"struct-type-property?", "struct-type-property?",

147
src/racket/src/stypes.h
View File

@ -198,83 +198,84 @@ enum {
scheme_serialized_tcp_fd_type, /* 178 */ scheme_serialized_tcp_fd_type, /* 178 */
scheme_serialized_file_fd_type, /* 179 */ scheme_serialized_file_fd_type, /* 179 */
scheme_port_closed_evt_type, /* 180 */ scheme_port_closed_evt_type, /* 180 */
scheme_struct_proc_shape_type, /* 181 */
#ifdef MZTAG_REQUIRED #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_comp_env, /* 184 */
scheme_rt_constant_binding, /* 184 */ scheme_rt_constant_binding, /* 185 */
scheme_rt_resolve_info, /* 185 */ scheme_rt_resolve_info, /* 186 */
scheme_rt_unresolve_info, /* 186 */ scheme_rt_unresolve_info, /* 187 */
scheme_rt_optimize_info, /* 187 */ scheme_rt_optimize_info, /* 188 */
scheme_rt_compile_info, /* 188 */ scheme_rt_compile_info, /* 189 */
scheme_rt_cont_mark, /* 189 */ scheme_rt_cont_mark, /* 190 */
scheme_rt_saved_stack, /* 190 */ scheme_rt_saved_stack, /* 191 */
scheme_rt_reply_item, /* 191 */ scheme_rt_reply_item, /* 192 */
scheme_rt_closure_info, /* 192 */ scheme_rt_closure_info, /* 193 */
scheme_rt_overflow, /* 193 */ scheme_rt_overflow, /* 194 */
scheme_rt_overflow_jmp, /* 194 */ scheme_rt_overflow_jmp, /* 195 */
scheme_rt_meta_cont, /* 195 */ scheme_rt_meta_cont, /* 196 */
scheme_rt_dyn_wind_cell, /* 196 */ scheme_rt_dyn_wind_cell, /* 197 */
scheme_rt_dyn_wind_info, /* 197 */ scheme_rt_dyn_wind_info, /* 198 */
scheme_rt_dyn_wind, /* 198 */ scheme_rt_dyn_wind, /* 199 */
scheme_rt_dup_check, /* 199 */ scheme_rt_dup_check, /* 200 */
scheme_rt_thread_memory, /* 200 */ scheme_rt_thread_memory, /* 201 */
scheme_rt_input_file, /* 201 */ scheme_rt_input_file, /* 202 */
scheme_rt_input_fd, /* 202 */ scheme_rt_input_fd, /* 203 */
scheme_rt_oskit_console_input, /* 203 */ scheme_rt_oskit_console_input, /* 204 */
scheme_rt_tested_input_file, /* 204 */ scheme_rt_tested_input_file, /* 205 */
scheme_rt_tested_output_file, /* 205 */ scheme_rt_tested_output_file, /* 206 */
scheme_rt_indexed_string, /* 206 */ scheme_rt_indexed_string, /* 207 */
scheme_rt_output_file, /* 207 */ scheme_rt_output_file, /* 208 */
scheme_rt_load_handler_data, /* 208 */ scheme_rt_load_handler_data, /* 209 */
scheme_rt_pipe, /* 209 */ scheme_rt_pipe, /* 210 */
scheme_rt_beos_process, /* 210 */ scheme_rt_beos_process, /* 211 */
scheme_rt_system_child, /* 211 */ scheme_rt_system_child, /* 212 */
scheme_rt_tcp, /* 212 */ scheme_rt_tcp, /* 213 */
scheme_rt_write_data, /* 213 */ scheme_rt_write_data, /* 214 */
scheme_rt_tcp_select_info, /* 214 */ scheme_rt_tcp_select_info, /* 215 */
scheme_rt_param_data, /* 215 */ scheme_rt_param_data, /* 216 */
scheme_rt_will, /* 216 */ scheme_rt_will, /* 217 */
scheme_rt_linker_name, /* 217 */ scheme_rt_linker_name, /* 218 */
scheme_rt_param_map, /* 218 */ scheme_rt_param_map, /* 219 */
scheme_rt_finalization, /* 219 */ scheme_rt_finalization, /* 220 */
scheme_rt_finalizations, /* 220 */ scheme_rt_finalizations, /* 221 */
scheme_rt_cpp_object, /* 221 */ scheme_rt_cpp_object, /* 222 */
scheme_rt_cpp_array_object, /* 222 */ scheme_rt_cpp_array_object, /* 223 */
scheme_rt_stack_object, /* 223 */ scheme_rt_stack_object, /* 224 */
scheme_rt_preallocated_object, /* 224 */ scheme_rt_preallocated_object, /* 225 */
scheme_thread_hop_type, /* 225 */ scheme_thread_hop_type, /* 226 */
scheme_rt_srcloc, /* 226 */ scheme_rt_srcloc, /* 227 */
scheme_rt_evt, /* 227 */ scheme_rt_evt, /* 228 */
scheme_rt_syncing, /* 228 */ scheme_rt_syncing, /* 229 */
scheme_rt_comp_prefix, /* 229 */ scheme_rt_comp_prefix, /* 230 */
scheme_rt_user_input, /* 230 */ scheme_rt_user_input, /* 231 */
scheme_rt_user_output, /* 231 */ scheme_rt_user_output, /* 232 */
scheme_rt_compact_port, /* 232 */ scheme_rt_compact_port, /* 233 */
scheme_rt_read_special_dw, /* 233 */ scheme_rt_read_special_dw, /* 234 */
scheme_rt_regwork, /* 234 */ scheme_rt_regwork, /* 235 */
scheme_rt_rx_lazy_string, /* 235 */ scheme_rt_rx_lazy_string, /* 236 */
scheme_rt_buf_holder, /* 236 */ scheme_rt_buf_holder, /* 237 */
scheme_rt_parameterization, /* 237 */ scheme_rt_parameterization, /* 238 */
scheme_rt_print_params, /* 238 */ scheme_rt_print_params, /* 239 */
scheme_rt_read_params, /* 239 */ scheme_rt_read_params, /* 240 */
scheme_rt_native_code, /* 240 */ scheme_rt_native_code, /* 241 */
scheme_rt_native_code_plus_case, /* 241 */ scheme_rt_native_code_plus_case, /* 242 */
scheme_rt_jitter_data, /* 242 */ scheme_rt_jitter_data, /* 243 */
scheme_rt_module_exports, /* 243 */ scheme_rt_module_exports, /* 244 */
scheme_rt_delay_load_info, /* 244 */ scheme_rt_delay_load_info, /* 245 */
scheme_rt_marshal_info, /* 245 */ scheme_rt_marshal_info, /* 246 */
scheme_rt_unmarshal_info, /* 246 */ scheme_rt_unmarshal_info, /* 247 */
scheme_rt_runstack, /* 247 */ scheme_rt_runstack, /* 248 */
scheme_rt_sfs_info, /* 248 */ scheme_rt_sfs_info, /* 249 */
scheme_rt_validate_clearing, /* 249 */ scheme_rt_validate_clearing, /* 250 */
scheme_rt_avl_node, /* 250 */ scheme_rt_avl_node, /* 251 */
scheme_rt_lightweight_cont, /* 251 */ scheme_rt_lightweight_cont, /* 252 */
scheme_rt_export_info, /* 252 */ scheme_rt_export_info, /* 253 */
scheme_rt_cont_jmp, /* 253 */ scheme_rt_cont_jmp, /* 254 */
#endif #endif
_scheme_last_type_ _scheme_last_type_

22
src/racket/src/type.c
View File

@ -594,7 +594,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc); GC_REG_TRAV(scheme_escaping_cont_type, escaping_cont_proc);
GC_REG_TRAV(scheme_rt_cont_jmp, cont_jmp_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_integer_type, bad_trav);
GC_REG_TRAV(scheme_bignum_type, bignum_obj); GC_REG_TRAV(scheme_bignum_type, bignum_obj);
GC_REG_TRAV(scheme_rational_type, rational_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); GC_REG_TRAV(scheme_place_dead_type, small_object);
#endif #endif
GC_REG_TRAV(scheme_keyword_type, symbol_obj); 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_pair_type, cons_cell);
GC_REG_TRAV(scheme_mutable_pair_type, cons_cell); GC_REG_TRAV(scheme_mutable_pair_type, cons_cell);
GC_REG_TRAV(scheme_raw_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_input_port_type, input_port);
GC_REG_TRAV(scheme_output_port_type, output_port); GC_REG_TRAV(scheme_output_port_type, output_port);
GC_REG_TRAV(scheme_eof_type, char_obj); /* small */ GC_REG_TRAV(scheme_eof_type, small_atomic_obj);
GC_REG_TRAV(scheme_true_type, char_obj); /* small */ GC_REG_TRAV(scheme_true_type, small_atomic_obj);
GC_REG_TRAV(scheme_false_type, char_obj); /* small */ GC_REG_TRAV(scheme_false_type, small_atomic_obj);
GC_REG_TRAV(scheme_void_type, char_obj); /* small */ GC_REG_TRAV(scheme_void_type, small_atomic_obj);
GC_REG_TRAV(scheme_syntax_compiler_type, syntax_compiler); GC_REG_TRAV(scheme_syntax_compiler_type, syntax_compiler);
GC_REG_TRAV(scheme_macro_type, small_object); GC_REG_TRAV(scheme_macro_type, small_object);
GC_REG_TRAV(scheme_box_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_eval_waiting_type, bad_trav);
GC_REG_TRAV(scheme_tail_call_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_placeholder_type, small_object);
GC_REG_TRAV(scheme_table_placeholder_type, iptr_obj); 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_security_guard_type, guard_val);
GC_REG_TRAV(scheme_nack_evt_type, twoptr_obj); GC_REG_TRAV(scheme_nack_evt_type, twoptr_obj);
GC_REG_TRAV(scheme_always_evt_type, char_obj); GC_REG_TRAV(scheme_always_evt_type, small_atomic_obj);
GC_REG_TRAV(scheme_never_evt_type, char_obj); GC_REG_TRAV(scheme_never_evt_type, small_atomic_obj);
GC_REG_TRAV(scheme_thread_recv_evt_type, char_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_port_closed_evt_type, small_object);
GC_REG_TRAV(scheme_inspector_type, mark_inspector); 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_rib_delimiter_type, small_object);
GC_REG_TRAV(scheme_noninline_proc_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_prune_context_type, small_object);
GC_REG_TRAV(scheme_struct_proc_shape_type, small_atomic_obj);
} }
END_XFORM_SKIP; END_XFORM_SKIP;

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

@ -42,7 +42,8 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Object *app_rator, int proc_with_refs_ok, Scheme_Object *app_rator, int proc_with_refs_ok,
int result_ignored, struct Validate_Clearing *vc, int result_ignored, struct Validate_Clearing *vc,
int tailpos, int need_flonum, Scheme_Hash_Tree *procs, 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, static int validate_rator_wants_box(Scheme_Object *app_rator, int pos,
int hope, int hope,
Validate_TLS tls, Validate_TLS tls,
@ -132,6 +133,7 @@ void scheme_validate_code(Mz_CPort *port, Scheme_Object *code,
struct Validate_Clearing *vc; struct Validate_Clearing *vc;
Validate_TLS tls; Validate_TLS tls;
mzshort *tl_state; mzshort *tl_state;
Scheme_Hash_Table *st_ht = NULL;
depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); 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, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, 0, 0, NULL, 0, 0,
vc, 1, 0, NULL, -1)) { vc, 1, 0, NULL, -1, &st_ht)) {
tl_timestamp++; tl_timestamp++;
if (0) { if (0) {
printf("increment to %d for %d %p\n", tl_timestamp, 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, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, 0, tl_state, 0,
NULL, 0, 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, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, skip_refs_check ? 1 : 0, 0, 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, 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, mzshort *tl_state, mzshort tl_timestamp,
int result_ignored, int result_ignored,
struct Validate_Clearing *vc, int tailpos, 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; Scheme_Object *val, *only_var;
val = SCHEME_VEC_ELS(data)[0]; val = SCHEME_VEC_ELS(data)[0];
@ -357,14 +360,45 @@ static int define_values_validate(Scheme_Object *data, Mz_CPort *port,
only_var = NULL; 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, result = validate_expr(port, val, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, 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, NULL, !!only_var, 0, vc, 0, 0, NULL,
size-1); size-1, NULL);
if (scheme_is_simple_make_struct_type(val, size-1, 1, 1))
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; result = 2;
}
flags = SCHEME_TOPLEVEL_READY; flags = SCHEME_TOPLEVEL_READY;
if (result == 2) { if (result == 2) {
@ -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, r1 = validate_expr(port, sb->val, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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, r2 = validate_toplevel(sb->var, port, stack, tls, depth, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
@ -472,12 +506,12 @@ static int apply_values_validate(Scheme_Object *data, Mz_CPort *port,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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, r2 = validate_expr(port, e, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); return validate_join(r1, r2);
} }
@ -501,12 +535,12 @@ static void inline_variant_validate(Scheme_Object *data, Mz_CPort *port,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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, validate_expr(port, f2, stack, tls,
depth, letlimit, delta, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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, 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, validate_expr(port, e, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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, return validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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, 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, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, 0, i > 0, vc, 0, 0, procs, 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); 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; struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4;
void *tl_use_map = (((void **)p->ku.k.p5)[4]); void *tl_use_map = (((void **)p->ku.k.p5)[4]);
mzshort *tl_state = (((void **)p->ku.k.p5)[5]); mzshort *tl_state = (((void **)p->ku.k.p5)[5]);
Scheme_Hash_Table **_st_ht = (((void **)p->ku.k.p5)[6]);
int r; int r;
p->ku.k.p1 = NULL; p->ku.k.p1 = NULL;
@ -714,7 +749,8 @@ static Scheme_Object *validate_k(void)
args[3], args[4], args[5], tl_use_map, args[3], args[4], args[5], tl_use_map,
tl_state, args[10], tl_state, args[10],
app_rator, args[6], args[7], vc, args[8], 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); 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, validate_expr(port, data->code, new_stack, tls, sz, sz, base,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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) 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, int result_ignored,
struct Validate_Clearing *vc, int tailpos, struct Validate_Clearing *vc, int tailpos,
int need_flonum, Scheme_Hash_Tree *procs, 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 /* 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 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 result is furthermore a "constant" (i.e., the same shape result for
@ -1158,6 +1195,12 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
Scheme_Object *r; Scheme_Object *r;
void **pr; void **pr;
int *args; 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); args = MALLOC_N_ATOMIC(int, 11);
@ -1179,18 +1222,23 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
args[10] = tl_timestamp; args[10] = tl_timestamp;
args[11] = expected_results; args[11] = expected_results;
pr = MALLOC_N(void*, 5); pr = MALLOC_N(void*, 6);
pr[0] = (void *)args; pr[0] = (void *)args;
pr[1] = (void *)app_rator; pr[1] = (void *)app_rator;
pr[2] = (void *)tls; pr[2] = (void *)tls;
pr[3] = (void *)procs; pr[3] = (void *)procs;
pr[4] = tl_use_map; pr[4] = tl_use_map;
pr[5] = tl_state; pr[5] = tl_state;
pr[6] = _2st_ht;
p->ku.k.p5 = (void *)pr; p->ku.k.p5 = (void *)pr;
r = scheme_handle_stack_overflow(validate_k); r = scheme_handle_stack_overflow(validate_k);
if (_st_ht) {
*_st_ht = *_2st_ht;
}
return SCHEME_INT_VAL(r); return SCHEME_INT_VAL(r);
} }
#endif #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, r = validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(result, r);
} }
@ -1414,9 +1462,6 @@ static int validate_expr(Mz_CPort *port, Scheme_Object *expr,
check_self_call_valid(app->args[0], port, vc, delta, stack); check_self_call_valid(app->args[0], port, vc, delta, stack);
if (result) { 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); 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, r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(r, result);
r = validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, r = validate_expr(port, app->rand, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(r, result);
if (tailpos) 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, r = validate_expr(port, app->rator, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(r, result);
r = validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, r = validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(r, result);
r = validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, r = validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(r, result);
if (tailpos) 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, r = validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); 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, r = validate_expr(port, b->test, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join(r, result);
/* This is where letlimit is useful. It prevents let-assignment in the /* 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, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, 0, result_ignored, vc, tailpos, 0, procs, NULL, 0, result_ignored, vc, tailpos, 0, procs,
expected_results); expected_results, NULL);
result = validate_join_seq(result, r); result = validate_join_seq(result, r);
/* since we're branchig, the result isn't constant: */ /* 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, r = validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join_seq(result, r);
r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, r = validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join_seq(result, r);
expr = wcm->body; 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, r = validate_expr(port, lv->value, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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); result = validate_join_seq(r, result);
/* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ /* 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, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs, NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs,
1); 1, NULL);
result = validate_join_seq(r, result); result = validate_join_seq(r, result);
#if !CAN_RESET_STACK_SLOT #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, define_values_validate(expr, port, stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, tl_state, tl_timestamp,
result_ignored, vc, tailpos, procs)); result_ignored, vc, tailpos, procs,
_st_ht));
break; break;
case scheme_define_syntaxes_type: case scheme_define_syntaxes_type:
no_flo(need_flonum, port); 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, validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts, tl_use_map, num_toplevels, num_stxes, num_lifts, tl_use_map,
tl_state, tl_timestamp, 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) { } else if (need_flonum) {
if (!SCHEME_FLOATP(expr)) if (!SCHEME_FLOATP(expr))