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

bytecode-compiler changes to help enable flonum unboxing

Browse Source 
svn: r17283
This commit is contained in:
Matthew Flatt 2009-12-13 04:39:46 +00:00
parent f170b1529f
commit 5772fa0a9f
20 changed files with 738 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/compiler/decompile.ss
View File

@ -246,11 +246,13 @@
[(struct application (rator rands)) [(struct application (rator rands))
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand)) (let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
stack)]) stack)])
(annotate-inline (annotate-unboxed
`(,(decompile-expr rator globs stack closed) rands
,@(map (lambda (rand) (annotate-inline
(decompile-expr rand globs stack closed)) `(,(decompile-expr rator globs stack closed)
rands))))] ,@(map (lambda (rand)
(decompile-expr rand globs stack closed))
rands)))))]
[(struct apply-values (proc args-expr)) [(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack closed) `(#%apply-values ,(decompile-expr proc globs stack closed)
,(decompile-expr args-expr globs stack closed))] ,(decompile-expr args-expr globs stack closed))]
@ -333,6 +335,29 @@
(cons '#%in a) (cons '#%in a)
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))
;; ---------------------------------------- ;; ----------------------------------------
#; #;

9
collects/scribblings/guide/performance.scrbl
View File

@ -269,8 +269,13 @@ operations allow the @tech{JIT} compiler to generate code that avoids
boxing and unboxing intermediate results. Currently, only expressions boxing and unboxing intermediate results. Currently, only expressions
involving a combination of unchecked flonum operations, involving a combination of unchecked flonum operations,
@scheme[unsafe-fx->fl], constants, and variable references are @scheme[unsafe-fx->fl], constants, and variable references are
optimized to avoid boxing. See also @secref["unchecked-unsafe"], optimized to avoid boxing; the bytecode compiler attempts to move
especially the warnings about unsafety. 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.
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------

15
collects/scribblings/mzc/decompile.scrbl
View File

@ -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 it may even contain cyclic references to itself or other constant
closures.} 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 @item{Some applications of core primitives are annotated with
@schemeidfont{#%in}, which indicates that the JIT compiler will @schemeidfont{#%in}, which indicates that the JIT compiler will
inline the operation. (Inlining information is not part of the 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 @schememodname[scheme/unsafe/ops] are always inlined, so
@schemeidfont{#%in} is not shown for them.} @schemeidfont{#%in} is not shown for them.}
@item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to @item{Some applications of unsafe flonum operations from
@scheme[(call-with-values (lambda () _expr) _proc)], but the run-time @schememodname[scheme/unsafe/ops] are annotated with
system avoids allocating a closure for @scheme[_expr].} @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 @item{A @schemeidfont{#%decode-syntax} form corresponds to a syntax
object. Future improvements to the decompiler will convert such object. Future improvements to the decompiler will convert such

2
collects/tests/mzscheme/benchmarks/common/auto.ss
View File

@ -271,7 +271,7 @@ exec mzscheme -qu "$0" ${1+"$@"}
run-larceny run-larceny
extract-larceny-times extract-larceny-times
clean-up-fasl clean-up-fasl
'(maze maze2)) '())
(make-impl 'ikarus (make-impl 'ikarus
mk-ikarus mk-ikarus
run-ikarus run-ikarus

25
collects/tests/mzscheme/benchmarks/shootout/spectralnorm-unsafe.ss
View File

@ -28,15 +28,13 @@
;; return element i,j of infinite matrix A ;; return element i,j of infinite matrix A
(define (A i j) (define (A i j)
(let ([n (unsafe-fx+ i (unsafe-fx+ j 1))] (unsafe-fl/ 1.0
[i+j (unsafe-fx+ i j)] (unsafe-fl+
[i+1 (unsafe-fx+ i 1)]) (unsafe-fl* (unsafe-fx->fl (unsafe-fx+ i j))
(unsafe-fl/ 1.0 (unsafe-fl/ (unsafe-fx->fl
(unsafe-fl+ (unsafe-fx+ i (unsafe-fx+ j 1)))
(unsafe-fl* (unsafe-fx->fl i+j) 2.0))
(unsafe-fl/ (unsafe-fx->fl n) (unsafe-fx->fl (unsafe-fx+ i 1)))))
2.0))
(unsafe-fx->fl i+1)))))
;; multiply vector v by matrix A ;; multiply vector v by matrix A
(define (MultiplyAv n v Av) (define (MultiplyAv n v Av)
@ -49,10 +47,10 @@
;; multiply vector v by matrix A transposed ;; multiply vector v by matrix A transposed
(define (MultiplyAtv n v Atv) (define (MultiplyAtv n v Atv)
(for ([i (in-range n)]) (for ([i (in-range n)])
(vector-set! Atv i (unsafe-vector-set! Atv i
(for/fold ([r 0.0]) (for/fold ([r 0.0])
([j (in-range n)]) ([j (in-range n)])
(unsafe-fl+ r (unsafe-fl* (A j i) (unsafe-vector-ref v j))))))) (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 ;; multiply vector v by matrix A and then by matrix A transposed
(define (MultiplyAtAv n v AtAv) (define (MultiplyAtAv n v AtAv)
@ -64,4 +62,3 @@
(real->decimal-string (real->decimal-string
(Approximate (command-line #:args (n) (string->number n))) (Approximate (command-line #:args (n) (string->number n)))
9)) 9))

4
collects/tests/mzscheme/foreign-test.ss
View File

@ -159,7 +159,9 @@
(collect-garbage) (collect-garbage)
(t 81 'use_grabbed_callback (_fun _int -> _int) 9))]) (t 81 'use_grabbed_callback (_fun _int -> _int) 9))])
(with-keeper #t) (with-keeper #t)
(with-keeper (box #f))) (let ([b (box #f)])
(with-keeper b)
(set-box! b #f)))
;; --- ;; ---
;; test exposing internal mzscheme functionality ;; test exposing internal mzscheme functionality
(test '(1 2) (test '(1 2)

8
collects/tests/mzscheme/optimize.ss
View File

@ -629,6 +629,14 @@
(values x)) (values x))
'(let ([x (random)]) '(let ([x (random)])
x)) 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)]) (test-comp '(let-values ([(x y) (values 1 2)])
(+ x y)) (+ x y))

2
src/mzscheme/include/scheme.h
View File

@ -639,7 +639,7 @@ typedef struct Scheme_Offset_Cptr
#define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (128 | 256) #define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (128 | 256)
#define SCHEME_PRIM_IS_MULTI_RESULT 512 #define SCHEME_PRIM_IS_MULTI_RESULT 512
#define SCHEME_PRIM_IS_BINARY_INLINED 1024 #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_METHOD 4096
#define SCHEME_PRIM_IS_CLOSURE 8192 #define SCHEME_PRIM_IS_CLOSURE 8192
#define SCHEME_PRIM_IS_UNARY_INLINED 16384 #define SCHEME_PRIM_IS_UNARY_INLINED 16384

65
src/mzscheme/src/env.c
View File

@ -3380,6 +3380,23 @@ void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *valu
info->consts = p; 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) void scheme_optimize_mutated(Optimize_Info *info, int pos)
/* pos must be in immediate frame */ /* pos must be in immediate frame */
{ {
@ -3428,6 +3445,22 @@ int scheme_optimize_is_used(Optimize_Info *info, int pos)
return 0; 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 scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
{ {
int j, i; int j, i;
@ -3456,7 +3489,8 @@ int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
return 0; 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; Scheme_Object *p, *n;
int delta = 0; 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)) { } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) {
/* Ok */ /* Ok */
} else if (closure_offset) { } 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; 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)) { } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) {
int pos; int pos;
@ -3511,7 +3555,7 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
if (!*single_use) if (!*single_use)
single_use = NULL; 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) { if (!n) {
/* Return shifted reference to other local: */ /* 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; 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 scheme_optimize_info_is_ready(Optimize_Info *info, int pos)
{ {
int closure_offset, single_use, ready = 1; 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; 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->enforce_const = info->enforce_const;
naya->top_level_consts = info->top_level_consts; naya->top_level_consts = info->top_level_consts;
naya->context = info->context; naya->context = info->context;
naya->vclock = info->vclock;
return naya; return naya;
} }
@ -3575,7 +3621,7 @@ int scheme_optimize_info_get_shift(Optimize_Info *info, int pos)
} }
if (!info) if (!info)
*(long *)0x0 = 1; scheme_signal_error("error looking for local-variable offset");
return delta; 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) void scheme_optimize_info_done(Optimize_Info *info)
{ {
info->next->size += info->size; info->next->size += info->size;
info->next->vclock = info->vclock;
} }
/*========================================================================*/ /*========================================================================*/
/* compile-time env for resolve */ /* 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_resolve_info, mark_resolve_info);
GC_REG_TRAV(scheme_rt_optimize_info, mark_optimize_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_rt_sfs_info, mark_sfs_info);
GC_REG_TRAV(scheme_once_used_type, mark_once_used);
} }
END_XFORM_SKIP; END_XFORM_SKIP;

384
src/mzscheme/src/eval.c
View File

@ -921,6 +921,16 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 1; 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; return 0;
} }
@ -940,6 +950,17 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 1; 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)) { if ((vtype == scheme_application3_type)) {
@ -968,11 +989,51 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
return 1; 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; 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) 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)) { 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)) { if (SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) {
/* Check for inlining: */ /* 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) if (!le)
return NULL; return NULL;
} }
@ -2515,6 +2576,267 @@ static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rat
return NULL; 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 (<unboxed-arg-proc> (let* ([x <arg>]...) <expr>))
to (let* ([x <arg>]...) (<unboxed-arg-proc> <expr>)) */
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 (<unboxed-arg-proc> <arg>) to
(let ([x <arg>]) (<unboxed-arg-proc> 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) static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info)
{ {
Scheme_Object *le; Scheme_Object *le;
@ -2553,6 +2875,8 @@ static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info
} }
info->size += 1; info->size += 1;
if (!purely_functional_primitive(app->args[0], app->num_args))
info->vclock += 1;
if (all_vals) { if (all_vals) {
le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info); 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)) if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc))
return scheme_null; 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) 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; int offset;
Scheme_Object *expr; Scheme_Object *expr;
expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0); 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 (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
if (info->top_level_consts) { 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); le = scheme_optimize_expr(app->rand, info);
app->rand = le; app->rand = le;
info->size += 1;
if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) { if (SCHEME_TYPE(le) > _scheme_compiled_values_types_) {
le = try_optimize_fold(app->rator, (Scheme_Object *)app, info); le = try_optimize_fold(app->rator, (Scheme_Object *)app, info);
if (le) 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) if ((SAME_OBJ(scheme_values_func, app->rator)
|| SAME_OBJ(scheme_list_star_proc, app->rator)) || SAME_OBJ(scheme_list_star_proc, app->rator))
&& scheme_omittable_expr(app->rand, 1, -1, 0, info)) { && (scheme_omittable_expr(app->rand, 1, -1, 0, info)
|| single_valued_noncm_expression(app->rand))) {
info->preserves_marks = 1; info->preserves_marks = 1;
info->single_result = 1; info->single_result = 1;
return app->rand; return app->rand;
} }
if (!purely_functional_primitive(app->rator, 1))
info->vclock += 1;
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
if (rator_flags & CLOS_RESULT_TENTATIVE) { 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; 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) 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; return le;
} }
if (!purely_functional_primitive(app->rator, 2))
info->vclock += 1;
/* Check for (call-with-values (lambda () M) N): */ /* Check for (call-with-values (lambda () M) N): */
if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) { if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) {
if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) { 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; 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, 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_Sequence *s = (Scheme_Sequence *)o;
Scheme_Object *le; Scheme_Object *le;
int i; int i, count;
int drop = 0, preserves_marks = 0, single_result = 0; 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); le = scheme_optimize_expr(s->array[i], info);
if (i == s->count - 1) { if (i == s->count - 1) {
single_result = info->single_result; 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 /* Inlining and constant propagation can expose
omittable expressions. */ omittable expressions. */
if ((i + 1 != s->count) if ((i + 1 != count)
&& scheme_omittable_expr(le, -1, -1, 0, NULL)) { && scheme_omittable_expr(le, -1, -1, 0, NULL)) {
drop++; drop++;
s->array[i] = NULL; s->array[i] = NULL;
@ -3007,6 +3342,8 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
} else } else
t = scheme_optimize_expr(t, info); t = scheme_optimize_expr(t, info);
info->vclock += 1; /* model branch as clock increment */
/* For test position, convert (if <expr> #t #f) to <expr> */ /* For test position, convert (if <expr> #t #f) to <expr> */
if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type)
&& SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true) && 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)) else if (single_result && (info->single_result < 0))
single_result = -1; single_result = -1;
info->vclock += 1; /* model join as clock increment */
info->preserves_marks = preserves_marks; info->preserves_marks = preserves_marks;
info->single_result = single_result; 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); 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 (val) {
if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) { if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) {
info->size -= 1; Scheme_Once_Used *o = (Scheme_Once_Used *)val;
return scheme_optimize_expr(val, info); 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); 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); expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY);
} }
} }
info->vclock += 1;
} }
} else {
info->vclock += 1;
} }
scheme_optimize_info_used_top(info); scheme_optimize_info_used_top(info);
return expr; return expr;

2
src/mzscheme/src/fun.c
View File

@ -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, info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params,
SCHEME_LAMBDA_FRAME); SCHEME_LAMBDA_FRAME);
info->vclock += 1; /* model delayed evaluation as vclock increment */
/* For reporting warnings: */ /* For reporting warnings: */
if (info->context && SCHEME_PAIRP(info->context)) if (info->context && SCHEME_PAIRP(info->context))
ctx = scheme_make_pair((Scheme_Object *)data, ctx = scheme_make_pair((Scheme_Object *)data,

29
src/mzscheme/src/mzmark.c
View File

@ -2973,6 +2973,33 @@ static int mark_sfs_info_FIXUP(void *p) {
#define mark_sfs_info_IS_CONST_SIZE 1 #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 */ #endif /* ENV */
/**********************************************************************/ /**********************************************************************/
@ -3610,7 +3637,7 @@ static int mark_input_fd_FIXUP(void *p) {
#endif #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) { static int mark_system_child_SIZE(void *p) {
return return
gcBYTES_TO_WORDS(sizeof(System_Child)); gcBYTES_TO_WORDS(sizeof(System_Child));

10
src/mzscheme/src/mzmarksrc.c
View File

@ -1194,6 +1194,16 @@ mark_sfs_info {
gcBYTES_TO_WORDS(sizeof(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; END env;
/**********************************************************************/ /**********************************************************************/

23
src/mzscheme/src/numarith.c
View File

@ -113,54 +113,65 @@ void scheme_init_unsafe_numarith(Scheme_Env *env)
Scheme_Object *p; Scheme_Object *p;
p = scheme_make_folding_prim(fx_plus, "unsafe-fx+", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx+", p, env);
p = scheme_make_folding_prim(fx_minus, "unsafe-fx-", 2, 2, 1); p = scheme_make_folding_prim(fx_minus, "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_UNARY_INLINED); | SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fx-", p, env); scheme_add_global_constant("unsafe-fx-", p, env);
p = scheme_make_folding_prim(fx_mult, "unsafe-fx*", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx*", p, env);
p = scheme_make_folding_prim(fx_div, "unsafe-fxquotient", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fxquotient", p, env);
p = scheme_make_folding_prim(fx_rem, "unsafe-fxremainder", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fxremainder", p, env);
p = scheme_make_folding_prim(fx_abs, "unsafe-fxabs", 1, 1, 1); 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); scheme_add_global_constant("unsafe-fxabs", p, env);
p = scheme_make_folding_prim(fl_plus, "unsafe-fl+", 2, 2, 1); p = scheme_make_folding_prim(fl_plus, "unsafe-fl+", 2, 2, 1);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl+", p, env);
p = scheme_make_folding_prim(fl_minus, "unsafe-fl-", 2, 2, 1); p = scheme_make_folding_prim(fl_minus, "unsafe-fl-", 2, 2, 1);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl-", p, env);
p = scheme_make_folding_prim(fl_mult, "unsafe-fl*", 2, 2, 1); p = scheme_make_folding_prim(fl_mult, "unsafe-fl*", 2, 2, 1);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl*", p, env);
p = scheme_make_folding_prim(fl_div, "unsafe-fl/", 2, 2, 1); p = scheme_make_folding_prim(fl_div, "unsafe-fl/", 2, 2, 1);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl/", p, env);
p = scheme_make_folding_prim(fl_abs, "unsafe-flabs", 1, 1, 1); p = scheme_make_folding_prim(fl_abs, "unsafe-flabs", 1, 1, 1);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; 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); scheme_add_global_constant("unsafe-flabs", p, env);
} }

24
src/mzscheme/src/number.c
View File

@ -545,38 +545,46 @@ void scheme_init_unsafe_number(Scheme_Env *env)
Scheme_Object *p; Scheme_Object *p;
p = scheme_make_folding_prim(fx_and, "unsafe-fxand", 0, -1, 1); 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); scheme_add_global_constant("unsafe-fxand", p, env);
p = scheme_make_folding_prim(fx_or, "unsafe-fxior", 0, -1, 1); 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); scheme_add_global_constant("unsafe-fxior", p, env);
p = scheme_make_folding_prim(fx_xor, "unsafe-fxxor", 0, -1, 1); 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); scheme_add_global_constant("unsafe-fxxor", p, env);
p = scheme_make_folding_prim(fx_not, "unsafe-fxnot", 1, 1, 1); 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); scheme_add_global_constant("unsafe-fxnot", p, env);
p = scheme_make_folding_prim(fx_lshift, "unsafe-fxlshift", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fxlshift", p, env);
p = scheme_make_folding_prim(fx_rshift, "unsafe-fxrshift", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fxrshift", p, env);
p = scheme_make_folding_prim(fx_to_fl, "unsafe-fx->fl", 1, 1, 1); p = scheme_make_folding_prim(fx_to_fl, "unsafe-fx->fl", 1, 1, 1);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED; 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); scheme_add_global_constant("unsafe-fx->fl", p, env);
p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref", p = scheme_make_immed_prim(fl_ref, "unsafe-f64vector-ref",
2, 2); 2, 2);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-f64vector-ref", p, env);
p = scheme_make_immed_prim(fl_set, "unsafe-f64vector-set!", 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", p = scheme_make_immed_prim(unsafe_flvector_length, "unsafe-flvector-length",
1, 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-flvector-length", p, env); scheme_add_global_constant("unsafe-flvector-length", p, env);
p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref", p = scheme_make_immed_prim(unsafe_flvector_ref, "unsafe-flvector-ref",
2, 2); 2, 2);
if (scheme_can_inline_fp_op()) if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-flvector-ref", p, env);
p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!", p = scheme_make_immed_prim(unsafe_flvector_set, "unsafe-flvector-set!",

20
src/mzscheme/src/numcomp.c
View File

@ -109,48 +109,58 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env)
Scheme_Object *p; Scheme_Object *p;
p = scheme_make_folding_prim(fx_eq, "unsafe-fx=", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx=", p, env);
p = scheme_make_folding_prim(fx_lt, "unsafe-fx<", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx<", p, env);
p = scheme_make_folding_prim(fx_gt, "unsafe-fx>", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx>", p, env);
p = scheme_make_folding_prim(fx_lt_eq, "unsafe-fx<=", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx<=", p, env);
p = scheme_make_folding_prim(fx_gt_eq, "unsafe-fx>=", 2, 2, 1); 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); scheme_add_global_constant("unsafe-fx>=", p, env);
p = scheme_make_folding_prim(fl_eq, "unsafe-fl=", 2, 2, 1); p = scheme_make_folding_prim(fl_eq, "unsafe-fl=", 2, 2, 1);
if (scheme_can_inline_fp_comp()) if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl=", p, env);
p = scheme_make_folding_prim(fl_lt, "unsafe-fl<", 2, 2, 1); p = scheme_make_folding_prim(fl_lt, "unsafe-fl<", 2, 2, 1);
if (scheme_can_inline_fp_comp()) if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl<", p, env);
p = scheme_make_folding_prim(fl_gt, "unsafe-fl>", 2, 2, 1); p = scheme_make_folding_prim(fl_gt, "unsafe-fl>", 2, 2, 1);
if (scheme_can_inline_fp_comp()) if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl>", p, env);
p = scheme_make_folding_prim(fl_lt_eq, "unsafe-fl<=", 2, 2, 1); p = scheme_make_folding_prim(fl_lt_eq, "unsafe-fl<=", 2, 2, 1);
if (scheme_can_inline_fp_comp()) if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl<=", p, env);
p = scheme_make_folding_prim(fl_gt_eq, "unsafe-fl>=", 2, 2, 1); p = scheme_make_folding_prim(fl_gt_eq, "unsafe-fl>=", 2, 2, 1);
if (scheme_can_inline_fp_comp()) if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED; 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); scheme_add_global_constant("unsafe-fl>=", p, env);
} }

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

@ -1965,7 +1965,7 @@ typedef struct Optimize_Info
Scheme_Object *consts; Scheme_Object *consts;
/* Propagated up and down the chain: */ /* Propagated up and down the chain: */
int size; int size, vclock;
short inline_fuel; short inline_fuel;
char letrec_not_twice, enforce_const; char letrec_not_twice, enforce_const;
Scheme_Hash_Table *top_level_consts; 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); Optimize_Info *scheme_optimize_info_create(void);
void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use); 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_info_used_top(Optimize_Info *info);
void scheme_optimize_mutated(Optimize_Info *info, int pos); void scheme_optimize_mutated(Optimize_Info *info, int pos);
Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated); 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_is_used(Optimize_Info *info, int pos);
int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_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_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); 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); void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map);
int scheme_env_uses_toplevel(Optimize_Info *frame); 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_toplevel_pos(Resolve_Info *info);
int scheme_resolve_is_toplevel_available(Resolve_Info *info); int scheme_resolve_is_toplevel_available(Resolve_Info *info);
int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info); int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info);

146
src/mzscheme/src/stypes.h
View File

@ -172,84 +172,84 @@ enum {
scheme_prune_context_type, /* 154 */ scheme_prune_context_type, /* 154 */
scheme_future_type, /* 155 */ scheme_future_type, /* 155 */
scheme_flvector_type, /* 156 */ scheme_flvector_type, /* 156 */
scheme_place_type, /* 157 */
scheme_engine_type, /* 158 */
scheme_once_used_type, /* 159 */
#ifdef MZTAG_REQUIRED #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_comp_env, /* 162 */
scheme_rt_constant_binding, /* 160 */ scheme_rt_constant_binding, /* 163 */
scheme_rt_resolve_info, /* 161 */ scheme_rt_resolve_info, /* 164 */
scheme_rt_optimize_info, /* 162 */ scheme_rt_optimize_info, /* 165 */
scheme_rt_compile_info, /* 163 */ scheme_rt_compile_info, /* 166 */
scheme_rt_cont_mark, /* 164 */ scheme_rt_cont_mark, /* 167 */
scheme_rt_saved_stack, /* 165 */ scheme_rt_saved_stack, /* 168 */
scheme_rt_reply_item, /* 166 */ scheme_rt_reply_item, /* 169 */
scheme_rt_closure_info, /* 167 */ scheme_rt_closure_info, /* 170 */
scheme_rt_overflow, /* 168 */ scheme_rt_overflow, /* 171 */
scheme_rt_overflow_jmp, /* 169 */ scheme_rt_overflow_jmp, /* 172 */
scheme_rt_meta_cont, /* 170 */ scheme_rt_meta_cont, /* 173 */
scheme_rt_dyn_wind_cell, /* 171 */ scheme_rt_dyn_wind_cell, /* 174 */
scheme_rt_dyn_wind_info, /* 172 */ scheme_rt_dyn_wind_info, /* 175 */
scheme_rt_dyn_wind, /* 173 */ scheme_rt_dyn_wind, /* 176 */
scheme_rt_dup_check, /* 174 */ scheme_rt_dup_check, /* 177 */
scheme_rt_thread_memory, /* 175 */ scheme_rt_thread_memory, /* 178 */
scheme_rt_input_file, /* 176 */ scheme_rt_input_file, /* 179 */
scheme_rt_input_fd, /* 177 */ scheme_rt_input_fd, /* 180 */
scheme_rt_oskit_console_input, /* 178 */ scheme_rt_oskit_console_input, /* 181 */
scheme_rt_tested_input_file, /* 179 */ scheme_rt_tested_input_file, /* 182 */
scheme_rt_tested_output_file, /* 180 */ scheme_rt_tested_output_file, /* 183 */
scheme_rt_indexed_string, /* 181 */ scheme_rt_indexed_string, /* 184 */
scheme_rt_output_file, /* 182 */ scheme_rt_output_file, /* 185 */
scheme_rt_load_handler_data, /* 183 */ scheme_rt_load_handler_data, /* 186 */
scheme_rt_pipe, /* 184 */ scheme_rt_pipe, /* 187 */
scheme_rt_beos_process, /* 185 */ scheme_rt_beos_process, /* 188 */
scheme_rt_system_child, /* 186 */ scheme_rt_system_child, /* 189 */
scheme_rt_tcp, /* 187 */ scheme_rt_tcp, /* 190 */
scheme_rt_write_data, /* 188 */ scheme_rt_write_data, /* 191 */
scheme_rt_tcp_select_info, /* 189 */ scheme_rt_tcp_select_info, /* 192 */
scheme_rt_namespace_option, /* 190 */ scheme_rt_namespace_option, /* 193 */
scheme_rt_param_data, /* 191 */ scheme_rt_param_data, /* 194 */
scheme_rt_will, /* 192 */ scheme_rt_will, /* 195 */
scheme_rt_struct_proc_info, /* 193 */ scheme_rt_struct_proc_info, /* 196 */
scheme_rt_linker_name, /* 194 */ scheme_rt_linker_name, /* 197 */
scheme_rt_param_map, /* 195 */ scheme_rt_param_map, /* 198 */
scheme_rt_finalization, /* 196 */ scheme_rt_finalization, /* 199 */
scheme_rt_finalizations, /* 197 */ scheme_rt_finalizations, /* 200 */
scheme_rt_cpp_object, /* 198 */ scheme_rt_cpp_object, /* 201 */
scheme_rt_cpp_array_object, /* 199 */ scheme_rt_cpp_array_object, /* 202 */
scheme_rt_stack_object, /* 200 */ scheme_rt_stack_object, /* 203 */
scheme_rt_preallocated_object, /* 201 */ scheme_rt_preallocated_object, /* 204 */
scheme_thread_hop_type, /* 202 */ scheme_thread_hop_type, /* 205 */
scheme_rt_srcloc, /* 203 */ scheme_rt_srcloc, /* 206 */
scheme_rt_evt, /* 204 */ scheme_rt_evt, /* 207 */
scheme_rt_syncing, /* 205 */ scheme_rt_syncing, /* 208 */
scheme_rt_comp_prefix, /* 206 */ scheme_rt_comp_prefix, /* 209 */
scheme_rt_user_input, /* 207 */ scheme_rt_user_input, /* 210 */
scheme_rt_user_output, /* 208 */ scheme_rt_user_output, /* 211 */
scheme_rt_compact_port, /* 209 */ scheme_rt_compact_port, /* 212 */
scheme_rt_read_special_dw, /* 210 */ scheme_rt_read_special_dw, /* 213 */
scheme_rt_regwork, /* 211 */ scheme_rt_regwork, /* 214 */
scheme_rt_buf_holder, /* 212 */ scheme_rt_buf_holder, /* 215 */
scheme_rt_parameterization, /* 213 */ scheme_rt_parameterization, /* 216 */
scheme_rt_print_params, /* 214 */ scheme_rt_print_params, /* 217 */
scheme_rt_read_params, /* 215 */ scheme_rt_read_params, /* 218 */
scheme_rt_native_code, /* 216 */ scheme_rt_native_code, /* 219 */
scheme_rt_native_code_plus_case, /* 217 */ scheme_rt_native_code_plus_case, /* 220 */
scheme_rt_jitter_data, /* 218 */ scheme_rt_jitter_data, /* 221 */
scheme_rt_module_exports, /* 219 */ scheme_rt_module_exports, /* 222 */
scheme_rt_delay_load_info, /* 220 */ scheme_rt_delay_load_info, /* 223 */
scheme_rt_marshal_info, /* 221 */ scheme_rt_marshal_info, /* 224 */
scheme_rt_unmarshal_info, /* 222 */ scheme_rt_unmarshal_info, /* 225 */
scheme_rt_runstack, /* 223 */ scheme_rt_runstack, /* 226 */
scheme_rt_sfs_info, /* 224 */ scheme_rt_sfs_info, /* 227 */
scheme_rt_validate_clearing, /* 225 */ scheme_rt_validate_clearing, /* 228 */
scheme_rt_rb_node, /* 226 */ scheme_rt_rb_node, /* 229 */
#endif #endif
scheme_place_type, /* 227 */
scheme_engine_type, /* 228 */
_scheme_last_type_ _scheme_last_type_
}; };

56
src/mzscheme/src/syntax.c
View File

@ -1558,12 +1558,14 @@ set_optimize(Scheme_Object *data, Optimize_Info *info)
pos = SCHEME_LOCAL_POS(var); pos = SCHEME_LOCAL_POS(var);
/* Register that we use this variable: */ /* Register that we use this variable: */
scheme_optimize_info_lookup(info, pos, NULL, NULL); scheme_optimize_info_lookup(info, pos, NULL, NULL, 0);
/* Offset: */ /* Offset: */
delta = scheme_optimize_info_get_shift(info, pos); delta = scheme_optimize_info_get_shift(info, pos);
if (delta) if (delta)
var = scheme_make_local(scheme_local_type, pos + delta, 0); var = scheme_make_local(scheme_local_type, pos + delta, 0);
info->vclock++;
} else { } else {
scheme_optimize_info_used_top(info); scheme_optimize_info_used_top(info);
} }
@ -1890,6 +1892,7 @@ ref_optimize(Scheme_Object *tl, Optimize_Info *info)
info->preserves_marks = 1; info->preserves_marks = 1;
info->single_result = 1; info->single_result = 1;
info->size++;
return scheme_make_syntax_compiled(REF_EXPD, tl); 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); f = scheme_optimize_expr(f, info);
e = scheme_optimize_expr(e, info); e = scheme_optimize_expr(e, info);
info->size += 1;
info->vclock += 1;
return scheme_optimize_apply_values(f, e, info, info->single_result); 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->preserves_marks = 1;
info->single_result = 1; info->single_result = 1;
info->size += 1;
return scheme_make_syntax_compiled(CASE_LAMBDA_EXPD, expr); 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_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; 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_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 i, j, pos, is_rec, not_simply_let_star = 0;
int size_before_opt, did_set_value; int size_before_opt, did_set_value;
int remove_last_one = 0; 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); cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT);
scheme_optimize_propagate(body_info, pos, value, cnt == 1); scheme_optimize_propagate(body_info, pos, value, cnt == 1);
did_set_value = 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; pos += pre_body->count;
prev_body = pre_body; prev_body = pre_body;
body = pre_body->body; body = pre_body->body;
info->size += 1;
} }
if (for_inline) { if (for_inline) {
body_info->size = rhs_info->size; body_info->size = rhs_info->size;
body_info->vclock = rhs_info->vclock;
} }
body = scheme_optimize_expr(body, body_info); 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; pre_body->body = body;
else else
head->body = body; head->body = body;
info->size += 1;
info->single_result = body_info->single_result; info->single_result = body_info->single_result;
info->preserves_marks = body_info->preserves_marks; info->preserves_marks = body_info->preserves_marks;
info->vclock = body_info->vclock;
/* Clear used flags where possible */ /* Clear used flags where possible */
body = head->body; body = head->body;
pos = 0; pos = 0;
for (i = head->num_clauses; i--; ) { for (i = head->num_clauses; i--; ) {
int used = 0, j; 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; pre_body = (Scheme_Compiled_Let_Value *)body;
for (j = pre_body->count; j--; ) { for (j = pre_body->count; j--; ) {
if (scheme_optimize_is_used(body_info, pos+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 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--; ) { for (j = pre_body->count; j--; ) {
if (pre_body->flags[j] & SCHEME_WAS_USED) { if (pre_body->flags[j] & SCHEME_WAS_USED) {
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; int sz;
sz = expr_size(pre_body->value); sz = expr_size(pre_body->value);
pre_body->value = scheme_false; pre_body->value = scheme_false;
info->size -= (sz + 1); info->size -= sz;
} }
} else { } else {
for (j = pre_body->count; j--; ) { for (j = pre_body->count; j--; ) {
pre_body->flags[j] |= SCHEME_WAS_USED; pre_body->flags[j] |= SCHEME_WAS_USED;
} }
info->size += 1;
} }
pos += pre_body->count; pos += pre_body->count;
body = pre_body->body; body = pre_body->body;
@ -3791,9 +3818,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
info->max_let_depth = max_let_depth; info->max_let_depth = max_let_depth;
/* Check for (let ([x <expr>]) (<simple> x)) at end, and change to /* Check for (let ([x <expr>]) (<simple> x)) at end, and change to
(<simple> <expr>). This is easy because the local-variable (<simple> <expr>). This transformation is more generally performed
offsets in <expr> do not change (as long as <simple> doesn't at the optimization layer, the cocde here pre-dates the mode general
access the stack). */ optimzation, and we keep it just in case. The simple case is easy here,
because the local-variable offsets in <expr> do not change (as long as
<simple> doesn't access the stack). */
last_body = NULL; last_body = NULL;
body = first; body = first;
while (1) { 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; Scheme_App2_Rec *app = (Scheme_App2_Rec *)((Scheme_Let_One *)body)->body;
if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)
&& (SCHEME_LOCAL_POS(app->rand) == 1)) { && (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 <expr> to app, and drop let-one: */ /* Move <expr> to app, and drop let-one: */
app->rand = ((Scheme_Let_One *)body)->value; app->rand = ((Scheme_Let_One *)body)->value;
scheme_reset_app2_eval_type(app); scheme_reset_app2_eval_type(app);
@ -4818,11 +4848,11 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
static Scheme_Object * static Scheme_Object *
begin0_optimize(Scheme_Object *obj, Optimize_Info *info) 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; Scheme_Object *le;
le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info); le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info);
((Scheme_Sequence *)obj)->array[i] = le; ((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 */ /* Optimization of expression 0 has already set single_result */
info->preserves_marks = 1; info->preserves_marks = 1;
info->size += 1;
return scheme_make_syntax_compiled(BEGIN0_EXPD, obj); return scheme_make_syntax_compiled(BEGIN0_EXPD, obj);
} }

24
src/mzscheme/src/vector.c
View File

@ -142,13 +142,15 @@ scheme_init_unsafe_vector (Scheme_Env *env)
p = scheme_make_immed_prim(unsafe_vector_len, p = scheme_make_immed_prim(unsafe_vector_len,
"unsafe-vector-length", "unsafe-vector-length",
1, 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-vector-length", p, env); scheme_add_global_constant("unsafe-vector-length", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref, p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref", "unsafe-vector-ref",
2, 2); 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); scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set, 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, p = scheme_make_immed_prim(unsafe_struct_ref,
"unsafe-struct-ref", "unsafe-struct-ref",
2, 2); 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); scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set, 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, p = scheme_make_immed_prim(unsafe_string_len,
"unsafe-string-length", "unsafe-string-length",
1, 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-string-length", p, env); scheme_add_global_constant("unsafe-string-length", p, env);
p = scheme_make_immed_prim(unsafe_string_ref, p = scheme_make_immed_prim(unsafe_string_ref,
"unsafe-string-ref", "unsafe-string-ref",
2, 2); 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); scheme_add_global_constant("unsafe-string-ref", p, env);
p = scheme_make_immed_prim(unsafe_string_set, p = scheme_make_immed_prim(unsafe_string_set,
@ -190,20 +195,19 @@ scheme_init_unsafe_vector (Scheme_Env *env)
3, 3); 3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED; SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-string-set!", p, env); 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, p = scheme_make_immed_prim(unsafe_bytes_len,
"unsafe-bytes-length", "unsafe-bytes-length",
1, 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-bytes-length", p, env); scheme_add_global_constant("unsafe-bytes-length", p, env);
p = scheme_make_immed_prim(unsafe_bytes_ref, p = scheme_make_immed_prim(unsafe_bytes_ref,
"unsafe-bytes-ref", "unsafe-bytes-ref",
2, 2); 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); scheme_add_global_constant("unsafe-bytes-ref", p, env);
p = scheme_make_immed_prim(unsafe_bytes_set, p = scheme_make_immed_prim(unsafe_bytes_set,