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
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

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

@ -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

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;
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;

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

@ -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 {

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))
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];

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

@ -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: */

16
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++) {
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

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
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;

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

@ -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;

565
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);
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 <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)) {
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 <omitable>* <proc>) */
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;
}
}

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];
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) {

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_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);

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,
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)) {

13
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_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?",

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

@ -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_

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_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;

128
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,
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))