diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 0ebc8b28a6..bb40aaf288 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -246,11 +246,13 @@ [(struct application (rator rands)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) stack)]) - (annotate-inline - `(,(decompile-expr rator globs stack closed) - ,@(map (lambda (rand) - (decompile-expr rand globs stack closed)) - rands))))] + (annotate-unboxed + rands + (annotate-inline + `(,(decompile-expr rator globs stack closed) + ,@(map (lambda (rand) + (decompile-expr rand globs stack closed)) + rands)))))] [(struct apply-values (proc args-expr)) `(#%apply-values ,(decompile-expr proc globs stack closed) ,(decompile-expr args-expr globs stack closed))] @@ -333,6 +335,29 @@ (cons '#%in a) a)) +(define (annotate-unboxed args a) + (define (unboxable? e s) + (cond + [(localref? e) #t] + [(toplevel? e) #t] + [(eq? '#%flonum (car s)) #t] + [(not (expr? e)) #t] + [else #f])) + (if (and (symbol? (car a)) + (case (length a) + [(2) (memq (car a) '(unsafe-flabs + unsafe-fx->fl))] + [(3) (memq (car a) '(unsafe-fl+ unsafe-fl- unsafe-fl* unsafe-fl/ + unsafe-fl< unsafe-fl> + unsafe-fl= + unsafe-fl<= unsafe-fl>=))] + + [(4) (memq (car a) '(unsafe-flvector-set!))] + [else #f]) + (andmap unboxable? args (cdr a))) + (cons '#%flonum a) + a)) + ;; ---------------------------------------- #; diff --git a/collects/scribblings/guide/performance.scrbl b/collects/scribblings/guide/performance.scrbl index 0a0fc5e165..490b62adf0 100644 --- a/collects/scribblings/guide/performance.scrbl +++ b/collects/scribblings/guide/performance.scrbl @@ -269,8 +269,13 @@ operations allow the @tech{JIT} compiler to generate code that avoids boxing and unboxing intermediate results. Currently, only expressions involving a combination of unchecked flonum operations, @scheme[unsafe-fx->fl], constants, and variable references are -optimized to avoid boxing. See also @secref["unchecked-unsafe"], -especially the warnings about unsafety. +optimized to avoid boxing; the bytecode compiler attempts to move +sub-expressions into and out of enclosing @scheme[let] forms to +produce unboxing combinations. The bytecode decompiler (see +@secref[#:doc '(lib "scribblings/mzc/mzc.scrbl") "decompile"] +annotates combinations where the JIT can avoid boxes with +@scheme[#%flonum]. See also @secref["unchecked-unsafe"], especially +the warnings about unsafety. @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/mzc/decompile.scrbl b/collects/scribblings/mzc/decompile.scrbl index 10f3de91c4..15c98b470d 100644 --- a/collects/scribblings/mzc/decompile.scrbl +++ b/collects/scribblings/mzc/decompile.scrbl @@ -72,6 +72,10 @@ Many forms in the decompiled code, such as @scheme[module], it may even contain cyclic references to itself or other constant closures.} + @item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to + @scheme[(call-with-values (lambda () _expr) _proc)], but the run-time + system avoids allocating a closure for @scheme[_expr].} + @item{Some applications of core primitives are annotated with @schemeidfont{#%in}, which indicates that the JIT compiler will inline the operation. (Inlining information is not part of the @@ -80,9 +84,14 @@ Many forms in the decompiled code, such as @scheme[module], @schememodname[scheme/unsafe/ops] are always inlined, so @schemeidfont{#%in} is not shown for them.} - @item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to - @scheme[(call-with-values (lambda () _expr) _proc)], but the run-time - system avoids allocating a closure for @scheme[_expr].} + @item{Some applications of unsafe flonum operations from + @schememodname[scheme/unsafe/ops] are annotated with + @schemeidfont{#%flonum}, indicating a place where the JIT compiler + can avoid allocation for intermediate flonum results. A single + @schemeidfont{#%flonum} by itself is not useful, but a + @schemeidfont{#%flonum} operation that consumes a + @schemeidfont{#%flonum} argument indicates a potential performance + improvement.} @item{A @schemeidfont{#%decode-syntax} form corresponds to a syntax object. Future improvements to the decompiler will convert such diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss index 9b1844ba1e..425760d007 100755 --- a/collects/tests/mzscheme/benchmarks/common/auto.ss +++ b/collects/tests/mzscheme/benchmarks/common/auto.ss @@ -271,7 +271,7 @@ exec mzscheme -qu "$0" ${1+"$@"} run-larceny extract-larceny-times clean-up-fasl - '(maze maze2)) + '()) (make-impl 'ikarus mk-ikarus run-ikarus diff --git a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss index 57cfff419c..519c2a2d2a 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss @@ -28,15 +28,13 @@ ;; return element i,j of infinite matrix A (define (A i j) - (let ([n (unsafe-fx+ i (unsafe-fx+ j 1))] - [i+j (unsafe-fx+ i j)] - [i+1 (unsafe-fx+ i 1)]) - (unsafe-fl/ 1.0 - (unsafe-fl+ - (unsafe-fl* (unsafe-fx->fl i+j) - (unsafe-fl/ (unsafe-fx->fl n) - 2.0)) - (unsafe-fx->fl i+1))))) + (unsafe-fl/ 1.0 + (unsafe-fl+ + (unsafe-fl* (unsafe-fx->fl (unsafe-fx+ i j)) + (unsafe-fl/ (unsafe-fx->fl + (unsafe-fx+ i (unsafe-fx+ j 1))) + 2.0)) + (unsafe-fx->fl (unsafe-fx+ i 1))))) ;; multiply vector v by matrix A (define (MultiplyAv n v Av) @@ -49,10 +47,10 @@ ;; multiply vector v by matrix A transposed (define (MultiplyAtv n v Atv) (for ([i (in-range n)]) - (vector-set! Atv i - (for/fold ([r 0.0]) - ([j (in-range n)]) - (unsafe-fl+ r (unsafe-fl* (A j i) (unsafe-vector-ref v j))))))) + (unsafe-vector-set! Atv i + (for/fold ([r 0.0]) + ([j (in-range n)]) + (unsafe-fl+ r (unsafe-fl* (A j i) (unsafe-vector-ref v j))))))) ;; multiply vector v by matrix A and then by matrix A transposed (define (MultiplyAtAv n v AtAv) @@ -64,4 +62,3 @@ (real->decimal-string (Approximate (command-line #:args (n) (string->number n))) 9)) - diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index dc1c7cfb84..2940ce86ea 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -159,7 +159,9 @@ (collect-garbage) (t 81 'use_grabbed_callback (_fun _int -> _int) 9))]) (with-keeper #t) - (with-keeper (box #f))) + (let ([b (box #f)]) + (with-keeper b) + (set-box! b #f))) ;; --- ;; test exposing internal mzscheme functionality (test '(1 2) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 00b3e2ba15..9b01b837d5 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -629,6 +629,14 @@ (values x)) '(let ([x (random)]) x)) +(test-comp '(let ([x (+ (cons 1 2) 0)]) + (values x)) + '(let ([x (+ (cons 1 2) 0)]) + x)) + +(test-comp '(let ([x (+ (cons 1 2) 0)]) + (- x 8)) + '(- (+ (cons 1 2) 0) 8)) (test-comp '(let-values ([(x y) (values 1 2)]) (+ x y)) diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 7589873457..32dfbaf403 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -639,7 +639,7 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (128 | 256) #define SCHEME_PRIM_IS_MULTI_RESULT 512 #define SCHEME_PRIM_IS_BINARY_INLINED 1024 -#define SCHEME_PRIM_IS_USER_PARAMETER 2048 +#define SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL 2048 #define SCHEME_PRIM_IS_METHOD 4096 #define SCHEME_PRIM_IS_CLOSURE 8192 #define SCHEME_PRIM_IS_UNARY_INLINED 16384 diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index c5425e5b0e..7c9deffa40 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -3380,6 +3380,23 @@ void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *valu info->consts = p; } +Scheme_Once_Used *scheme_make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev) +{ + Scheme_Once_Used *o; + + o = MALLOC_ONE_TAGGED(Scheme_Once_Used); + o->so.type = scheme_once_used_type; + + o->expr = val; + o->pos = pos; + o->vclock = vclock; + + if (prev) + prev->next = o; + + return o; +} + void scheme_optimize_mutated(Optimize_Info *info, int pos) /* pos must be in immediate frame */ { @@ -3428,6 +3445,22 @@ int scheme_optimize_is_used(Optimize_Info *info, int pos) return 0; } +int scheme_optimize_is_mutated(Optimize_Info *info, int pos) +/* pos is in new-frame counts */ +{ + while (1) { + if (pos < info->new_frame) + break; + pos -= info->new_frame; + info = info->next; + } + + if (info->use && info->use[pos]) + return 1; + + return 0; +} + int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos) { int j, i; @@ -3456,7 +3489,8 @@ int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos) return 0; } -static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, int *not_ready) +static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, + int *not_ready, int once_used_ok) { Scheme_Object *p, *n; int delta = 0; @@ -3494,8 +3528,18 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) { /* Ok */ } else if (closure_offset) { - /* Inlining can deal procdures and top-levels, but not other things. */ + /* Inlining can deal procedures and top-levels, but not other things. */ return NULL; + } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) { + Scheme_Once_Used *o; + + if (!once_used_ok) + break; + + o = (Scheme_Once_Used *)n; + o->delta = delta; + o->info = info; + return (Scheme_Object *)o; } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) { int pos; @@ -3511,7 +3555,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int if (!*single_use) single_use = NULL; } - n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL); + n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, 0); if (!n) { /* Return shifted reference to other local: */ @@ -3530,16 +3574,17 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int return NULL; } -Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use) +Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, + int once_used_ok) { - return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL); + return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok); } int scheme_optimize_info_is_ready(Optimize_Info *info, int pos) { int closure_offset, single_use, ready = 1; - do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready); + do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0); return ready; } @@ -3558,6 +3603,7 @@ Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int naya->enforce_const = info->enforce_const; naya->top_level_consts = info->top_level_consts; naya->context = info->context; + naya->vclock = info->vclock; return naya; } @@ -3575,7 +3621,7 @@ int scheme_optimize_info_get_shift(Optimize_Info *info, int pos) } if (!info) - *(long *)0x0 = 1; + scheme_signal_error("error looking for local-variable offset"); return delta; } @@ -3583,11 +3629,9 @@ int scheme_optimize_info_get_shift(Optimize_Info *info, int pos) void scheme_optimize_info_done(Optimize_Info *info) { info->next->size += info->size; + info->next->vclock = info->vclock; } - - - /*========================================================================*/ /* compile-time env for resolve */ /*========================================================================*/ @@ -5676,6 +5720,7 @@ static void register_traversers(void) GC_REG_TRAV(scheme_rt_resolve_info, mark_resolve_info); GC_REG_TRAV(scheme_rt_optimize_info, mark_optimize_info); GC_REG_TRAV(scheme_rt_sfs_info, mark_sfs_info); + GC_REG_TRAV(scheme_once_used_type, mark_once_used); } END_XFORM_SKIP; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index a38d1db5aa..ec883c2c99 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -921,6 +921,16 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } + if (SCHEME_PRIMP(app->args[0]) + && (SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (app->num_args >= ((Scheme_Primitive_Proc *)app->args[0])->mina) + && (app->num_args <= ((Scheme_Primitive_Proc *)app->args[0])->mu.maxa)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + /* can omit an unsafe op */ + return 1; + } + } return 0; } @@ -940,6 +950,17 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (1 >= ((Scheme_Primitive_Proc *)app->rator)->mina) + && (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + /* can omit an unsafe op */ + return 1; + } + } + return 0; } if ((vtype == scheme_application3_type)) { @@ -968,11 +989,51 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, return 1; } } + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (2 >= ((Scheme_Primitive_Proc *)app->rator)->mina) + && (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + /* can omit an unsafe op */ + return 1; + } + } } return 0; } +static int single_valued_noncm_expression(Scheme_Object *expr) +/* Non-omittable but single-values expresions that are not sensitive + to being in tail position. */ +{ + Scheme_Object *rator = NULL; + + switch (SCHEME_TYPE(expr)) { + case scheme_toplevel_type: + return 1; + case scheme_application_type: + rator = ((Scheme_App_Rec *)expr)->args[0]; + break; + case scheme_application2_type: + rator = ((Scheme_App2_Rec *)expr)->rator; + break; + case scheme_application3_type: + rator = ((Scheme_App2_Rec *)expr)->rator; + break; + } + + if (rator && SCHEME_PRIMP(rator)) { + int opt; + opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; + if (opt >= SCHEME_PRIM_OPT_NONCM) + return 1; + } + + return 0; +} + int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be_liftable) { if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) { @@ -2302,7 +2363,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) { /* Check for inlining: */ - le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use); + le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use, 0); if (!le) return NULL; } @@ -2515,6 +2576,267 @@ static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rat return NULL; } +static int purely_functional_primitive(Scheme_Object *rator, int n) +{ + if (SCHEME_PRIMP(rator) + && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (n >= ((Scheme_Primitive_Proc *)rator)->mina) + && (n <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)) + return 1; + + if (SAME_OBJ(scheme_void_proc, rator) + || SAME_OBJ(scheme_list_proc, rator) + || (SAME_OBJ(scheme_cons_proc, rator) && (n == 2)) + || SAME_OBJ(scheme_list_star_proc, rator) + || SAME_OBJ(scheme_vector_proc, rator) + || SAME_OBJ(scheme_vector_immutable_proc, rator) + || (SAME_OBJ(scheme_box_proc, rator) && (n == 1))) + return 1; + + return 0; +} + +#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm)) + +int scheme_wants_unboxed_arguments(Scheme_Object *rator) +{ + if (SCHEME_PRIMP(rator) + && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) { + if (IS_NAMED_PRIM(rator, "unsafe-flabs") + || IS_NAMED_PRIM(rator, "unsafe-fl+") + || IS_NAMED_PRIM(rator, "unsafe-fl-") + || IS_NAMED_PRIM(rator, "unsafe-fl*") + || IS_NAMED_PRIM(rator, "unsafe-fl/") + || IS_NAMED_PRIM(rator, "unsafe-fl<") + || IS_NAMED_PRIM(rator, "unsafe-fl<=") + || IS_NAMED_PRIM(rator, "unsafe-fl=") + || IS_NAMED_PRIM(rator, "unsafe-fl>") + || IS_NAMED_PRIM(rator, "unsafe-fl>=") + || IS_NAMED_PRIM(rator, "unsafe-flvector-set!") + || IS_NAMED_PRIM(rator, "unsafe-flvector-ref") + || IS_NAMED_PRIM(rator, "unsafe-fx->fl")) + return 1; + } + + return 0; +} + +static int produces_unboxed(Scheme_Object *rator) +{ + if (SCHEME_PRIMP(rator) + && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) { + if (IS_NAMED_PRIM(rator, "unsafe-flabs") + || IS_NAMED_PRIM(rator, "unsafe-fl+") + || IS_NAMED_PRIM(rator, "unsafe-fl-") + || IS_NAMED_PRIM(rator, "unsafe-fl*") + || IS_NAMED_PRIM(rator, "unsafe-fl/") + || IS_NAMED_PRIM(rator, "unsafe-fl<") + || IS_NAMED_PRIM(rator, "unsafe-fl<=") + || IS_NAMED_PRIM(rator, "unsafe-fl=") + || IS_NAMED_PRIM(rator, "unsafe-fl>") + || IS_NAMED_PRIM(rator, "unsafe-fl>=") + || IS_NAMED_PRIM(rator, "unsafe-flvector-ref") + || IS_NAMED_PRIM(rator, "unsafe-fx->fl")) + return 1; + } + + return 0; +} + +static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *info, int lifted) +{ + if (fuel > 0) { + switch (SCHEME_TYPE(rand)) { + case scheme_local_type: + { + /* Ok if not mutable */ + int pos = SCHEME_LOCAL_POS(rand); + if (pos < lifted) + return 1; + else if (!scheme_optimize_is_mutated(info, pos - lifted)) + return 1; + } + break; + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)rand; + if (produces_unboxed(app->args[0])) { + int i; + for (i = app->num_args; i--; ) { + fuel--; + if (!is_unboxed_argument(app->args[i+1], fuel, info, lifted)) + return 0; + } + return 1; + } + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)rand; + if (produces_unboxed(app->rator)) { + if (is_unboxed_argument(app->rand, fuel - 1, info, lifted)) + return 1; + } + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)rand; + if (produces_unboxed(app->rator)) { + if (is_unboxed_argument(app->rand1, fuel - 1, info, lifted) + && is_unboxed_argument(app->rand2, fuel - 2, info, lifted)) + return 1; + } + } + break; + default: + if (SCHEME_TYPE(rand) > _scheme_compiled_values_types_) + return 1; + break; + } + } + + return 0; +} + +static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *rator, int count, Optimize_Info *info) +{ + Scheme_Object *result = _app, *rand, *new_rand; + Scheme_Let_Header *inner_head = NULL; + Scheme_Compiled_Let_Value *inner = NULL; + int i, lifted = 0; + + if (scheme_wants_unboxed_arguments(rator)) { + for (i = 0; i < count; i++) { + if (count == 1) + rand = ((Scheme_App2_Rec *)_app)->rand; + else if (count == 2) { + if (i == 0) + rand = ((Scheme_App3_Rec *)_app)->rand1; + else + rand = ((Scheme_App3_Rec *)_app)->rand2; + } else + rand = ((Scheme_App_Rec *)_app)->args[i + 1]; + + if (!is_unboxed_argument(rand, 32, info, lifted)) { + int delta; + + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_let_void_type)) { + /* Rotate ( (let* ([x ]...) )) + to (let* ([x ]...) ( )) */ + Scheme_Let_Header *top_head = (Scheme_Let_Header *)rand, *head; + Scheme_Compiled_Let_Value *clv, *prev; + Scheme_Object *e; + int i; + + top_head = head = (Scheme_Let_Header *)rand; + prev = NULL; + e = rand; + delta = 0; + while (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_let_void_type)) { + head = (Scheme_Let_Header *)e; + delta += head->count; + prev = NULL; + + clv = (Scheme_Compiled_Let_Value *)head->body; + prev = NULL; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + prev = clv; + } + e = (Scheme_Object *)clv; + } + + if (prev) + new_rand = prev->body; + else + new_rand = head->body; + + if (inner) + inner->body = (Scheme_Object *)top_head; + else if (inner_head) + inner_head->body = (Scheme_Object *)top_head; + else + result = (Scheme_Object *)top_head; + + inner = prev; + inner_head = head; + } else { + /* Rotate ( ) to + (let ([x ]) ( x)) */ + Scheme_Let_Header *head; + Scheme_Compiled_Let_Value *lv; + int *flags; + + head = MALLOC_ONE_TAGGED(Scheme_Let_Header); + head->iso.so.type = scheme_compiled_let_void_type; + head->count = 1; + head->num_clauses = 1; + + lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + lv->so.type = scheme_compiled_let_value_type; + lv->count = 1; + lv->position = 0; + new_rand = scheme_optimize_shift(rand, 1, 0); + lv->value = new_rand; + + flags = (int *)scheme_malloc_atomic(sizeof(int)); + flags[0] = (SCHEME_WAS_USED | (1 << SCHEME_USE_COUNT_SHIFT)); + lv->flags = flags; + + head->body = (Scheme_Object *)lv; + + new_rand = scheme_make_local(scheme_local_type, 0, 0); + + if (inner) + inner->body = (Scheme_Object *)head; + else if (inner_head) + inner_head->body = (Scheme_Object *)head; + else + result = (Scheme_Object *)head; + + inner = lv; + inner_head = head; + + delta = 1; + } + + if (delta) { + lifted += delta; + if (count == 1) + ((Scheme_App2_Rec *)_app)->rand = scheme_false; + else if (count == 2) { + if (i == 0) + ((Scheme_App3_Rec *)_app)->rand1 = scheme_false; + else + ((Scheme_App3_Rec *)_app)->rand2 = scheme_false; + } else + ((Scheme_App_Rec *)_app)->args[i + 1] = scheme_false; + + _app = scheme_optimize_shift(_app, delta, 0); + } + + if (count == 1) + ((Scheme_App2_Rec *)_app)->rand = new_rand; + else if (count == 2) { + if (i == 0) + ((Scheme_App3_Rec *)_app)->rand1 = new_rand; + else + ((Scheme_App3_Rec *)_app)->rand2 = new_rand; + } else + ((Scheme_App_Rec *)_app)->args[i + 1] = new_rand; + + if (inner) + inner->body = _app; + else + inner_head->body = _app; + } + } + } + + return result; +} + static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info) { Scheme_Object *le; @@ -2553,6 +2875,8 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info } info->size += 1; + if (!purely_functional_primitive(app->args[0], app->num_args)) + info->vclock += 1; if (all_vals) { le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info); @@ -2570,7 +2894,7 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc)) return scheme_null; - return (Scheme_Object *)app; + return check_unbox_rotation((Scheme_Object *)app, app->args[0], app->num_args, info); } static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand) @@ -2583,7 +2907,7 @@ static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *r int offset; Scheme_Object *expr; expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0); - c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL); + c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL, 0); } if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) { if (info->top_level_consts) { @@ -2647,6 +2971,9 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf le = scheme_optimize_expr(app->rand, info); app->rand = le; + + info->size += 1; + if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) { le = try_optimize_fold(app->rator, (Scheme_Object *)app, info); if (le) @@ -2663,12 +2990,16 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf 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)) { + && (scheme_omittable_expr(app->rand, 1, -1, 0, info) + || single_valued_noncm_expression(app->rand))) { info->preserves_marks = 1; info->single_result = 1; return app->rand; } + if (!purely_functional_primitive(app->rator, 1)) + info->vclock += 1; + info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); if (rator_flags & CLOS_RESULT_TENTATIVE) { @@ -2676,7 +3007,7 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf info->single_result = -info->single_result; } - return (Scheme_Object *)app; + return check_unbox_rotation((Scheme_Object *)app, app->rator, 1, info); } static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *info) @@ -2731,6 +3062,9 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf return le; } + if (!purely_functional_primitive(app->rator, 2)) + info->vclock += 1; + /* Check for (call-with-values (lambda () M) N): */ if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) { if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) { @@ -2802,7 +3136,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf info->single_result = -info->single_result; } - return (Scheme_Object *)app; + return check_unbox_rotation((Scheme_Object *)app, app->rator, 2, info); } Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, @@ -2891,10 +3225,11 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info) { Scheme_Sequence *s = (Scheme_Sequence *)o; Scheme_Object *le; - int i; + int i, count; int drop = 0, preserves_marks = 0, single_result = 0; - for (i = s->count; i--; ) { + count = s->count; + for (i = 0; i < count; i++) { le = scheme_optimize_expr(s->array[i], info); if (i == s->count - 1) { single_result = info->single_result; @@ -2903,7 +3238,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info) /* Inlining and constant propagation can expose omittable expressions. */ - if ((i + 1 != s->count) + if ((i + 1 != count) && scheme_omittable_expr(le, -1, -1, 0, NULL)) { drop++; s->array[i] = NULL; @@ -3007,6 +3342,8 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info) } else t = scheme_optimize_expr(t, info); + info->vclock += 1; /* model branch as clock increment */ + /* For test position, convert (if #t #f) to */ if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true) @@ -3044,6 +3381,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info) else if (single_result && (info->single_result < 0)) single_result = -1; + info->vclock += 1; /* model join as clock increment */ info->preserves_marks = preserves_marks; info->single_result = single_result; @@ -3152,13 +3490,28 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info) pos = SCHEME_LOCAL_POS(expr); - val = scheme_optimize_info_lookup(info, pos, NULL, NULL); + val = scheme_optimize_info_lookup(info, pos, NULL, NULL, 1); if (val) { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) { - info->size -= 1; - return scheme_optimize_expr(val, info); + if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) { + Scheme_Once_Used *o = (Scheme_Once_Used *)val; + if ((o->vclock == info->vclock) + && single_valued_noncm_expression(o->expr)) { + val = scheme_optimize_clone(1, o->expr, info, o->delta, 0); + if (val) { + info->size -= 1; + o->used = 1; + return scheme_optimize_expr(val, info); + } + } + /* Can't move expression, so lookup again to mark as used. */ + (void)scheme_optimize_info_lookup(info, pos, NULL, NULL, 0); + } else { + if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) { + info->size -= 1; + return scheme_optimize_expr(val, info); + } + return val; } - return val; } delta = scheme_optimize_info_get_shift(info, pos); @@ -3224,7 +3577,10 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info) expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY); } } + info->vclock += 1; } + } else { + info->vclock += 1; } scheme_optimize_info_used_top(info); return expr; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index da5af9f491..3bc3bcb4ad 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -981,6 +981,8 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info) info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params, SCHEME_LAMBDA_FRAME); + info->vclock += 1; /* model delayed evaluation as vclock increment */ + /* For reporting warnings: */ if (info->context && SCHEME_PAIRP(info->context)) ctx = scheme_make_pair((Scheme_Object *)data, diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index a302d65f43..ddc17fc0a4 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -2973,6 +2973,33 @@ static int mark_sfs_info_FIXUP(void *p) { #define mark_sfs_info_IS_CONST_SIZE 1 +static int mark_once_used_SIZE(void *p) { + return + gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used)); +} + +static int mark_once_used_MARK(void *p) { + Scheme_Once_Used *o = (Scheme_Once_Used *)p; + gcMARK(o->expr); + gcMARK(o->info); + gcMARK(o->next); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used)); +} + +static int mark_once_used_FIXUP(void *p) { + Scheme_Once_Used *o = (Scheme_Once_Used *)p; + gcFIXUP(o->expr); + gcFIXUP(o->info); + gcFIXUP(o->next); + return + gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used)); +} + +#define mark_once_used_IS_ATOMIC 0 +#define mark_once_used_IS_CONST_SIZE 1 + + #endif /* ENV */ /**********************************************************************/ @@ -3610,7 +3637,7 @@ static int mark_input_fd_FIXUP(void *p) { #endif -#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)) +#if defined(UNIX_PROCESSES) static int mark_system_child_SIZE(void *p) { return gcBYTES_TO_WORDS(sizeof(System_Child)); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index a16deaaff4..3b11a942d7 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -1194,6 +1194,16 @@ mark_sfs_info { gcBYTES_TO_WORDS(sizeof(SFS_Info)); } +mark_once_used { + mark: + Scheme_Once_Used *o = (Scheme_Once_Used *)p; + gcMARK(o->expr); + gcMARK(o->info); + gcMARK(o->next); + size: + gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used)); +} + END env; /**********************************************************************/ diff --git a/src/mzscheme/src/numarith.c b/src/mzscheme/src/numarith.c index 605b894782..32028c8064 100644 --- a/src/mzscheme/src/numarith.c +++ b/src/mzscheme/src/numarith.c @@ -113,54 +113,65 @@ void scheme_init_unsafe_numarith(Scheme_Env *env) Scheme_Object *p; p = scheme_make_folding_prim(fx_plus, "unsafe-fx+", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx+", p, env); p = scheme_make_folding_prim(fx_minus, "unsafe-fx-", 2, 2, 1); SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED - | SCHEME_PRIM_IS_UNARY_INLINED); + | SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx-", p, env); p = scheme_make_folding_prim(fx_mult, "unsafe-fx*", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx*", p, env); p = scheme_make_folding_prim(fx_div, "unsafe-fxquotient", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxquotient", p, env); p = scheme_make_folding_prim(fx_rem, "unsafe-fxremainder", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxremainder", p, env); p = scheme_make_folding_prim(fx_abs, "unsafe-fxabs", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxabs", p, env); p = scheme_make_folding_prim(fl_plus, "unsafe-fl+", 2, 2, 1); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl+", p, env); p = scheme_make_folding_prim(fl_minus, "unsafe-fl-", 2, 2, 1); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl-", p, env); p = scheme_make_folding_prim(fl_mult, "unsafe-fl*", 2, 2, 1); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl*", p, env); p = scheme_make_folding_prim(fl_div, "unsafe-fl/", 2, 2, 1); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl/", p, env); p = scheme_make_folding_prim(fl_abs, "unsafe-flabs", 1, 1, 1); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-flabs", p, env); } diff --git a/src/mzscheme/src/number.c b/src/mzscheme/src/number.c index 5e5f6171f4..42feaa95b8 100644 --- a/src/mzscheme/src/number.c +++ b/src/mzscheme/src/number.c @@ -545,38 +545,46 @@ void scheme_init_unsafe_number(Scheme_Env *env) Scheme_Object *p; p = scheme_make_folding_prim(fx_and, "unsafe-fxand", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxand", p, env); p = scheme_make_folding_prim(fx_or, "unsafe-fxior", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxior", p, env); p = scheme_make_folding_prim(fx_xor, "unsafe-fxxor", 0, -1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxxor", p, env); p = scheme_make_folding_prim(fx_not, "unsafe-fxnot", 1, 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxnot", p, env); p = scheme_make_folding_prim(fx_lshift, "unsafe-fxlshift", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxlshift", p, env); p = scheme_make_folding_prim(fx_rshift, "unsafe-fxrshift", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fxrshift", p, env); p = scheme_make_folding_prim(fx_to_fl, "unsafe-fx->fl", 1, 1, 1); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fx->fl", p, env); p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref", 2, 2); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-f64vector-ref", p, env); p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", @@ -587,13 +595,15 @@ void scheme_init_unsafe_number(Scheme_Env *env) p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-flvector-length", p, env); p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref", 2, 2); if (scheme_can_inline_fp_op()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-flvector-ref", p, env); p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index 1095be750e..919b066624 100644 --- a/src/mzscheme/src/numcomp.c +++ b/src/mzscheme/src/numcomp.c @@ -109,48 +109,58 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) Scheme_Object *p; p = scheme_make_folding_prim(fx_eq, "unsafe-fx=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx=", p, env); p = scheme_make_folding_prim(fx_lt, "unsafe-fx<", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx<", p, env); p = scheme_make_folding_prim(fx_gt, "unsafe-fx>", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx>", p, env); p = scheme_make_folding_prim(fx_lt_eq, "unsafe-fx<=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx<=", p, env); p = scheme_make_folding_prim(fx_gt_eq, "unsafe-fx>=", 2, 2, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-fx>=", p, env); p = scheme_make_folding_prim(fl_eq, "unsafe-fl=", 2, 2, 1); if (scheme_can_inline_fp_comp()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl=", p, env); p = scheme_make_folding_prim(fl_lt, "unsafe-fl<", 2, 2, 1); if (scheme_can_inline_fp_comp()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl<", p, env); p = scheme_make_folding_prim(fl_gt, "unsafe-fl>", 2, 2, 1); if (scheme_can_inline_fp_comp()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl>", p, env); p = scheme_make_folding_prim(fl_lt_eq, "unsafe-fl<=", 2, 2, 1); if (scheme_can_inline_fp_comp()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl<=", p, env); p = scheme_make_folding_prim(fl_gt_eq, "unsafe-fl>=", 2, 2, 1); if (scheme_can_inline_fp_comp()) SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL; scheme_add_global_constant("unsafe-fl>=", p, env); } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index c8fb71f3ac..67813e449a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -1965,7 +1965,7 @@ typedef struct Optimize_Info Scheme_Object *consts; /* Propagated up and down the chain: */ - int size; + int size, vclock; short inline_fuel; char letrec_not_twice, enforce_const; Scheme_Hash_Table *top_level_consts; @@ -2278,13 +2278,14 @@ Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolv Optimize_Info *scheme_optimize_info_create(void); void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use); -Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use); +Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, int once_used_ok); void scheme_optimize_info_used_top(Optimize_Info *info); void scheme_optimize_mutated(Optimize_Info *info, int pos); Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated); int scheme_optimize_is_used(Optimize_Info *info, int pos); int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos); +int scheme_optimize_is_mutated(Optimize_Info *info, int pos); Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth); @@ -2304,6 +2305,23 @@ Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags) void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map); int scheme_env_uses_toplevel(Optimize_Info *frame); +int scheme_wants_unboxed_arguments(Scheme_Object *rator); + +typedef struct Scheme_Once_Used { + Scheme_Object so; + Scheme_Object *expr; + int pos; + int vclock; + + int used; + int delta; + Optimize_Info *info; + + struct Scheme_Once_Used *next; +} Scheme_Once_Used; + +Scheme_Once_Used *scheme_make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev); + int scheme_resolve_toplevel_pos(Resolve_Info *info); int scheme_resolve_is_toplevel_available(Resolve_Info *info); int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info); diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index 62ac0382b2..dc0fe28e5a 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -172,84 +172,84 @@ enum { scheme_prune_context_type, /* 154 */ scheme_future_type, /* 155 */ scheme_flvector_type, /* 156 */ + scheme_place_type, /* 157 */ + scheme_engine_type, /* 158 */ + scheme_once_used_type, /* 159 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 157 */ + _scheme_last_normal_type_, /* 160 */ - scheme_rt_weak_array, /* 158 */ + scheme_rt_weak_array, /* 161 */ - scheme_rt_comp_env, /* 159 */ - scheme_rt_constant_binding, /* 160 */ - scheme_rt_resolve_info, /* 161 */ - scheme_rt_optimize_info, /* 162 */ - scheme_rt_compile_info, /* 163 */ - scheme_rt_cont_mark, /* 164 */ - scheme_rt_saved_stack, /* 165 */ - scheme_rt_reply_item, /* 166 */ - scheme_rt_closure_info, /* 167 */ - scheme_rt_overflow, /* 168 */ - scheme_rt_overflow_jmp, /* 169 */ - scheme_rt_meta_cont, /* 170 */ - scheme_rt_dyn_wind_cell, /* 171 */ - scheme_rt_dyn_wind_info, /* 172 */ - scheme_rt_dyn_wind, /* 173 */ - scheme_rt_dup_check, /* 174 */ - scheme_rt_thread_memory, /* 175 */ - scheme_rt_input_file, /* 176 */ - scheme_rt_input_fd, /* 177 */ - scheme_rt_oskit_console_input, /* 178 */ - scheme_rt_tested_input_file, /* 179 */ - scheme_rt_tested_output_file, /* 180 */ - scheme_rt_indexed_string, /* 181 */ - scheme_rt_output_file, /* 182 */ - scheme_rt_load_handler_data, /* 183 */ - scheme_rt_pipe, /* 184 */ - scheme_rt_beos_process, /* 185 */ - scheme_rt_system_child, /* 186 */ - scheme_rt_tcp, /* 187 */ - scheme_rt_write_data, /* 188 */ - scheme_rt_tcp_select_info, /* 189 */ - scheme_rt_namespace_option, /* 190 */ - scheme_rt_param_data, /* 191 */ - scheme_rt_will, /* 192 */ - scheme_rt_struct_proc_info, /* 193 */ - scheme_rt_linker_name, /* 194 */ - scheme_rt_param_map, /* 195 */ - scheme_rt_finalization, /* 196 */ - scheme_rt_finalizations, /* 197 */ - scheme_rt_cpp_object, /* 198 */ - scheme_rt_cpp_array_object, /* 199 */ - scheme_rt_stack_object, /* 200 */ - scheme_rt_preallocated_object, /* 201 */ - scheme_thread_hop_type, /* 202 */ - scheme_rt_srcloc, /* 203 */ - scheme_rt_evt, /* 204 */ - scheme_rt_syncing, /* 205 */ - scheme_rt_comp_prefix, /* 206 */ - scheme_rt_user_input, /* 207 */ - scheme_rt_user_output, /* 208 */ - scheme_rt_compact_port, /* 209 */ - scheme_rt_read_special_dw, /* 210 */ - scheme_rt_regwork, /* 211 */ - scheme_rt_buf_holder, /* 212 */ - scheme_rt_parameterization, /* 213 */ - scheme_rt_print_params, /* 214 */ - scheme_rt_read_params, /* 215 */ - scheme_rt_native_code, /* 216 */ - scheme_rt_native_code_plus_case, /* 217 */ - scheme_rt_jitter_data, /* 218 */ - scheme_rt_module_exports, /* 219 */ - scheme_rt_delay_load_info, /* 220 */ - scheme_rt_marshal_info, /* 221 */ - scheme_rt_unmarshal_info, /* 222 */ - scheme_rt_runstack, /* 223 */ - scheme_rt_sfs_info, /* 224 */ - scheme_rt_validate_clearing, /* 225 */ - scheme_rt_rb_node, /* 226 */ + scheme_rt_comp_env, /* 162 */ + scheme_rt_constant_binding, /* 163 */ + scheme_rt_resolve_info, /* 164 */ + scheme_rt_optimize_info, /* 165 */ + scheme_rt_compile_info, /* 166 */ + scheme_rt_cont_mark, /* 167 */ + scheme_rt_saved_stack, /* 168 */ + scheme_rt_reply_item, /* 169 */ + scheme_rt_closure_info, /* 170 */ + scheme_rt_overflow, /* 171 */ + scheme_rt_overflow_jmp, /* 172 */ + scheme_rt_meta_cont, /* 173 */ + scheme_rt_dyn_wind_cell, /* 174 */ + scheme_rt_dyn_wind_info, /* 175 */ + scheme_rt_dyn_wind, /* 176 */ + scheme_rt_dup_check, /* 177 */ + scheme_rt_thread_memory, /* 178 */ + scheme_rt_input_file, /* 179 */ + scheme_rt_input_fd, /* 180 */ + scheme_rt_oskit_console_input, /* 181 */ + scheme_rt_tested_input_file, /* 182 */ + scheme_rt_tested_output_file, /* 183 */ + scheme_rt_indexed_string, /* 184 */ + scheme_rt_output_file, /* 185 */ + scheme_rt_load_handler_data, /* 186 */ + scheme_rt_pipe, /* 187 */ + scheme_rt_beos_process, /* 188 */ + scheme_rt_system_child, /* 189 */ + scheme_rt_tcp, /* 190 */ + scheme_rt_write_data, /* 191 */ + scheme_rt_tcp_select_info, /* 192 */ + scheme_rt_namespace_option, /* 193 */ + scheme_rt_param_data, /* 194 */ + scheme_rt_will, /* 195 */ + scheme_rt_struct_proc_info, /* 196 */ + scheme_rt_linker_name, /* 197 */ + scheme_rt_param_map, /* 198 */ + scheme_rt_finalization, /* 199 */ + scheme_rt_finalizations, /* 200 */ + scheme_rt_cpp_object, /* 201 */ + scheme_rt_cpp_array_object, /* 202 */ + scheme_rt_stack_object, /* 203 */ + scheme_rt_preallocated_object, /* 204 */ + scheme_thread_hop_type, /* 205 */ + scheme_rt_srcloc, /* 206 */ + scheme_rt_evt, /* 207 */ + scheme_rt_syncing, /* 208 */ + scheme_rt_comp_prefix, /* 209 */ + scheme_rt_user_input, /* 210 */ + scheme_rt_user_output, /* 211 */ + scheme_rt_compact_port, /* 212 */ + scheme_rt_read_special_dw, /* 213 */ + scheme_rt_regwork, /* 214 */ + scheme_rt_buf_holder, /* 215 */ + scheme_rt_parameterization, /* 216 */ + scheme_rt_print_params, /* 217 */ + scheme_rt_read_params, /* 218 */ + scheme_rt_native_code, /* 219 */ + scheme_rt_native_code_plus_case, /* 220 */ + scheme_rt_jitter_data, /* 221 */ + scheme_rt_module_exports, /* 222 */ + scheme_rt_delay_load_info, /* 223 */ + scheme_rt_marshal_info, /* 224 */ + scheme_rt_unmarshal_info, /* 225 */ + scheme_rt_runstack, /* 226 */ + scheme_rt_sfs_info, /* 227 */ + scheme_rt_validate_clearing, /* 228 */ + scheme_rt_rb_node, /* 229 */ #endif - scheme_place_type, /* 227 */ - scheme_engine_type, /* 228 */ - _scheme_last_type_ }; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index eaf743382c..422faab278 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1558,12 +1558,14 @@ set_optimize(Scheme_Object *data, Optimize_Info *info) pos = SCHEME_LOCAL_POS(var); /* Register that we use this variable: */ - scheme_optimize_info_lookup(info, pos, NULL, NULL); + scheme_optimize_info_lookup(info, pos, NULL, NULL, 0); /* Offset: */ delta = scheme_optimize_info_get_shift(info, pos); if (delta) var = scheme_make_local(scheme_local_type, pos + delta, 0); + + info->vclock++; } else { scheme_optimize_info_used_top(info); } @@ -1890,6 +1892,7 @@ ref_optimize(Scheme_Object *tl, Optimize_Info *info) info->preserves_marks = 1; info->single_result = 1; + info->size++; return scheme_make_syntax_compiled(REF_EXPD, tl); } @@ -2090,6 +2093,9 @@ apply_values_optimize(Scheme_Object *data, Optimize_Info *info) f = scheme_optimize_expr(f, info); e = scheme_optimize_expr(e, info); + info->size += 1; + info->vclock += 1; + return scheme_optimize_apply_values(f, e, info, info->single_result); } @@ -2424,6 +2430,7 @@ case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info) info->preserves_marks = 1; info->single_result = 1; + info->size += 1; return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr); } @@ -3024,6 +3031,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) Scheme_Let_Header *head = (Scheme_Let_Header *)form; Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start; + Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL; int i, j, pos, is_rec, not_simply_let_star = 0; int size_before_opt, did_set_value; int remove_last_one = 0; @@ -3206,6 +3214,16 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); scheme_optimize_propagate(body_info, pos, value, cnt == 1); did_set_value = 1; + } else if (value && !is_rec) { + int cnt; + cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); + if (cnt == 1) { + /* used only once; we may be able to shift the expression to the use + site, instead of binding to a temporary */ + last_once_used = scheme_make_once_used(value, pos, body_info->vclock, last_once_used); + if (!first_once_used) first_once_used = last_once_used; + scheme_optimize_propagate(body_info, pos, (Scheme_Object *)last_once_used, 1); + } } } @@ -3339,11 +3357,11 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) pos += pre_body->count; prev_body = pre_body; body = pre_body->body; - info->size += 1; } if (for_inline) { body_info->size = rhs_info->size; + body_info->vclock = rhs_info->vclock; } body = scheme_optimize_expr(body, body_info); @@ -3351,16 +3369,21 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) pre_body->body = body; else head->body = body; - info->size += 1; info->single_result = body_info->single_result; info->preserves_marks = body_info->preserves_marks; + info->vclock = body_info->vclock; /* Clear used flags where possible */ body = head->body; pos = 0; for (i = head->num_clauses; i--; ) { int used = 0, j; + + while (first_once_used && (first_once_used->pos < pos)) { + first_once_used = first_once_used->next; + } + pre_body = (Scheme_Compiled_Let_Value *)body; for (j = pre_body->count; j--; ) { if (scheme_optimize_is_used(body_info, pos+j)) { @@ -3369,7 +3392,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) } } if (!used - && scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info)) { + && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info) + || (first_once_used + && (first_once_used->pos == pos) + && first_once_used->used))) { for (j = pre_body->count; j--; ) { if (pre_body->flags[j] & SCHEME_WAS_USED) { pre_body->flags[j] -= SCHEME_WAS_USED; @@ -3380,12 +3406,13 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) int sz; sz = expr_size(pre_body->value); pre_body->value = scheme_false; - info->size -= (sz + 1); + info->size -= sz; } } else { for (j = pre_body->count; j--; ) { pre_body->flags[j] |= SCHEME_WAS_USED; } + info->size += 1; } pos += pre_body->count; body = pre_body->body; @@ -3791,9 +3818,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) info->max_let_depth = max_let_depth; /* Check for (let ([x ]) ( x)) at end, and change to - ( ). This is easy because the local-variable - offsets in do not change (as long as doesn't - access the stack). */ + ( ). This transformation is more generally performed + at the optimization layer, the cocde here pre-dates the mode general + optimzation, and we keep it just in case. The simple case is easy here, + because the local-variable offsets in do not change (as long as + doesn't access the stack). */ last_body = NULL; body = first; while (1) { @@ -3809,7 +3838,8 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) Scheme_App2_Rec *app = (Scheme_App2_Rec *)((Scheme_Let_One *)body)->body; if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) && (SCHEME_LOCAL_POS(app->rand) == 1)) { - if (SCHEME_TYPE(app->rator) > _scheme_values_types_) { + if ((SCHEME_TYPE(app->rator) > _scheme_values_types_) + && !scheme_wants_unboxed_arguments(app->rator)) { /* Move to app, and drop let-one: */ app->rand = ((Scheme_Let_One *)body)->value; scheme_reset_app2_eval_type(app); @@ -4818,11 +4848,11 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port, static Scheme_Object * begin0_optimize(Scheme_Object *obj, Optimize_Info *info) { - int i; + int i, count; - i = ((Scheme_Sequence *)obj)->count; + count = ((Scheme_Sequence *)obj)->count; - while (i--) { + for (i = 0; i < count; i++) { Scheme_Object *le; le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info); ((Scheme_Sequence *)obj)->array[i] = le; @@ -4831,6 +4861,8 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info) /* Optimization of expression 0 has already set single_result */ info->preserves_marks = 1; + info->size += 1; + return scheme_make_syntax_compiled(BEGIN0_EXPD, obj); } diff --git a/src/mzscheme/src/vector.c b/src/mzscheme/src/vector.c index 2818ebdcb2..4e0093b784 100644 --- a/src/mzscheme/src/vector.c +++ b/src/mzscheme/src/vector.c @@ -142,13 +142,15 @@ scheme_init_unsafe_vector (Scheme_Env *env) p = scheme_make_immed_prim(unsafe_vector_len, "unsafe-vector-length", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-vector-length", p, env); p = scheme_make_immed_prim(unsafe_vector_ref, "unsafe-vector-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-vector-ref", p, env); p = scheme_make_immed_prim(unsafe_vector_set, @@ -163,7 +165,8 @@ scheme_init_unsafe_vector (Scheme_Env *env) p = scheme_make_immed_prim(unsafe_struct_ref, "unsafe-struct-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-struct-ref", p, env); p = scheme_make_immed_prim(unsafe_struct_set, @@ -176,13 +179,15 @@ scheme_init_unsafe_vector (Scheme_Env *env) p = scheme_make_immed_prim(unsafe_string_len, "unsafe-string-length", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-string-length", p, env); p = scheme_make_immed_prim(unsafe_string_ref, "unsafe-string-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-string-ref", p, env); p = scheme_make_immed_prim(unsafe_string_set, @@ -190,20 +195,19 @@ scheme_init_unsafe_vector (Scheme_Env *env) 3, 3); SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; scheme_add_global_constant("unsafe-string-set!", p, env); - p = scheme_make_immed_prim(unsafe_string_ref, - "unsafe-string-ref", - 2, 2); p = scheme_make_immed_prim(unsafe_bytes_len, "unsafe-bytes-length", 1, 1); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-bytes-length", p, env); p = scheme_make_immed_prim(unsafe_bytes_ref, "unsafe-bytes-ref", 2, 2); - SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; + SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED + | SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL); scheme_add_global_constant("unsafe-bytes-ref", p, env); p = scheme_make_immed_prim(unsafe_bytes_set,