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

unboxing of let-bound flonums (v4.2.3.6)

Browse Source 
svn: r17328
This commit is contained in:
Matthew Flatt 2009-12-16 13:30:40 +00:00
parent e9cc9f643b
commit 45e84ca087
28 changed files with 1169 additions and 717 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/compiler/decompile.ss
View File

@ -189,14 +189,16 @@
[(struct assign (id rhs undef-ok?))
`(set! ,(decompile-expr id globs stack closed)
,(decompile-expr rhs globs stack closed))]
[(struct localref (unbox? offset clear? other-clears?))
[(struct localref (unbox? offset clear? other-clears? flonum?))
(let ([id (list-ref/protect stack offset 'localref)])
(let ([e (if unbox?
`(#%unbox ,id)
id)])
(if clear?
`(#%sfs-clear ,e)
e)))]
(if flonum?
`(#%from-flonum ,e)
e))))]
[(? lam?)
`(lambda . ,(decompile-lam expr globs stack closed))]
[(struct case-lam (name lams))
@ -204,10 +206,13 @@
,@(map (lambda (lam)
(decompile-lam lam globs stack closed))
lams))]
[(struct let-one (rhs body))
[(struct let-one (rhs body flonum?))
(let ([id (or (extract-id rhs)
(gensym 'local))])
`(let ([,id ,(decompile-expr rhs globs (cons id stack) closed)])
`(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)])
(if flonum?
(list '#%as-flonum v)
v))])
,(decompile-expr body globs (cons id stack) closed)))]
[(struct let-void (count boxes? body))
(let ([ids (make-vector count #f)])

21
collects/compiler/zo-marshal.ss
View File

@ -133,14 +133,14 @@
(void)]
[(struct assign (id rhs undef-ok?))
(traverse-expr rhs visit)]
[(struct localref (unbox? offset clear? other-clears?))
[(struct localref (unbox? offset clear? other-clears? flonum?))
(void)]
[(? lam?)
(traverse-lam expr visit)]
[(struct case-lam (name lams))
(traverse-data name visit)
(for-each (lambda (lam) (traverse-lam lam visit)) lams)]
[(struct let-one (rhs body))
[(struct let-one (rhs body flonum?))
(traverse-expr rhs visit)
(traverse-expr body visit)]
[(struct let-void (count boxes? body))
@ -252,7 +252,7 @@
CPT_VECTOR
CPT_HASH_TABLE
CPT_STX
CPT_GSTX
CPT_LET_ONE_FLONUM
CPT_MARSHALLED
CPT_QUOTE
CPT_REFERENCE
@ -531,7 +531,7 @@
(out-syntax SET_EXPD
(cons undef-ok? (cons id rhs))
out)]
[(struct localref (unbox? offset clear? other-clears?))
[(struct localref (unbox? offset clear? other-clears? flonum?))
(if (and (not clear?) (not other-clears?)
(offset . < . (- CPT_SMALL_LOCAL_END CPT_SMALL_LOCAL_START)))
(out-byte (+ (if unbox?
@ -545,8 +545,13 @@
(out-number offset out)
(begin
(out-number (- (add1 offset)) out)
(out-number (+ (if clear? #x1 0)
(if other-clears? #x2 0))
(out-number (if clear?
#x1
(if other-clears?
#x2
(if flonum?
#x3
0)))
out)))))]
[(? lam?)
(out-lam expr out)]
@ -567,8 +572,8 @@
(cons (or name null)
lams)
out)]
[(struct let-one (rhs body))
(out-byte CPT_LET_ONE out)
[(struct let-one (rhs body flonum?))
(out-byte (if flonum? CPT_LET_ONE_FLONUM CPT_LET_ONE) out)
(out-expr (protect-quote rhs) out)
(out-expr (protect-quote body) out)]
[(struct let-void (count boxes? body))

17
collects/compiler/zo-parse.ss
View File

@ -41,13 +41,13 @@
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam
(define-form-struct (let-one expr) (rhs body)) ; pushes one value onto stack
(define-form-struct (let-one expr) (rhs body flonum?)) ; pushes one value onto stack
(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots
(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s)
(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots
(define-form-struct (boxenv expr) (pos body)) ; box existing stack element
(define-form-struct (localref expr) (unbox? pos clear? other-clears?)) ; access local via stack
(define-form-struct (localref expr) (unbox? pos clear? other-clears? flonum?)) ; access local via stack
(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
@ -410,7 +410,7 @@
[16 vector]
[17 hash-table]
[18 stx]
[19 gstx] ; unused
[19 let-one-flonum]
[20 marshalled]
[21 quote]
[22 reference]
@ -491,9 +491,11 @@
(define (make-local unbox? pos flags)
(define SCHEME_LOCAL_CLEAR_ON_READ #x01)
(define SCHEME_LOCAL_OTHER_CLEARS #x02)
(define SCHEME_LOCAL_FLONUM #x03)
(make-localref unbox? pos
(positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ))
(positive? (bitwise-and flags SCHEME_LOCAL_OTHER_CLEARS))))
(= flags SCHEME_LOCAL_CLEAR_ON_READ)
(= flags SCHEME_LOCAL_OTHER_CLEARS)
(= flags SCHEME_LOCAL_FLONUM)))
(define (a . << . b)
(arithmetic-shift a b))
@ -786,8 +788,9 @@
(if ppr null (read-compact cp)))
(read-compact-list l ppr cp))
(loop l ppr)))]
[(let-one)
(make-let-one (read-compact cp) (read-compact cp))]
[(let-one let-one-flonum)
(make-let-one (read-compact cp) (read-compact cp)
(eq? cpt-tag 'let-one-flonum))]
[(branch)
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
[(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]

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

@ -266,16 +266,19 @@ contrast are never boxed, so they are especially cheap to use.
The @schememodname[scheme/unsafe/ops] library provides fixnum- and
flonum-specific operations, and combinations of unchecked flonum
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; 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.
boxing and unboxing intermediate results. Expressions involving a
combination of unchecked flonum operations, @scheme[unsafe-fx->fl],
constants, and variable references are optimized to avoid boxing. When
such a result is bound with @scheme[let] and then consumed by another
unchecked flonum operation, the result is similarly unboxed, unless it
is captured in a closure. The bytecode decompiler (see @secref[#:doc
'(lib "scribblings/mzc/mzc.scrbl") "decompile"] annotates combinations
where the JIT can avoid boxes with @schemeidfont{#%flonum},
@schemeidfont{#%as-flonum}, and @schemeidfont{#%from-flonum}. See also
@secref["unchecked-unsafe"], especially the warnings about unsafety.
@margin-note{Unboxing of local bindings is not supported by the JIT for
PowerPC.}
@; ----------------------------------------------------------------------

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

@ -87,11 +87,15 @@ Many forms in the decompiled code, such as @scheme[module],
@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
might 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.}
@schemeidfont{#%flonum} or @schemeidfont{#%from-flonum} argument
indicates a potential performance improvement. A
@schemeidfont{#%from-flonum} wraps an identifier that is bound by
@scheme[let] with a @schemeidfont{#%as-flonum} around its value,
which indicates a local binding that can avoid boxing (when used as
an argument to an operation that can work with unboxed values).}
@item{A @schemeidfont{#%decode-syntax} form corresponds to a syntax
object. Future improvements to the decompiler will convert such

4
collects/scribblings/reference/unsafe.scrbl
View File

@ -95,12 +95,14 @@ Like @scheme[exact->inexact], but constrained to consume @tech{fixnums}.
@defproc[(unsafe-fl* [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl/ [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-flabs [a inexact-real?]) inexact-real?]
@defproc[(unsafe-flsqrt [a inexact-real?]) inexact-real?]
)]{
For real @tech{inexact numbers}: Like @scheme[+], @scheme[-],
@scheme[*], @scheme[/], and @scheme[abs], but constrained to consume
real @tech{inexact numbers}. The result is always a real @tech{inexact
number}.}
number}. If a negative number is provided to @scheme[unsafe-sqrt], the
result is @scheme[+nan.0].}
@deftogether[(

24
collects/tests/mzscheme/benchmarks/shootout/nbody-vec-unsafe.ss
View File

@ -123,7 +123,7 @@ Correct output N = 1000 is
[dx (fl- (body-x o1) (body-x i1))]
[dy (fl- (body-y o1) (body-y i1))]
[dz (fl- (body-z o1) (body-z i1))]
[dist (sqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz)))]
[dist (flsqrt (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz)))]
[e (fl- e (fl/ (fl* (body-mass o1) (body-mass i1)) dist))])
(loop-i (unsafe-fx+ i 1) e))))))))
@ -131,8 +131,7 @@ Correct output N = 1000 is
(define (advance)
(let loop-o ([o 0])
(unless (unsafe-fx= o *system-size*)
(let* ([o1 (unsafe-vector-ref *system* o)]
[om (body-mass o1)])
(let* ([o1 (unsafe-vector-ref *system* o)])
(let loop-i ([i (unsafe-fx+ o 1)]
[vx (body-vx o1)]
[vy (body-vy o1)]
@ -143,14 +142,19 @@ Correct output N = 1000 is
[dy (fl- (body-y o1) (body-y i1))]
[dz (fl- (body-z o1) (body-z i1))]
[dist2 (fl+ (fl+ (fl* dx dx) (fl* dy dy)) (fl* dz dz))]
[mag (fl/ +dt+ (fl* dist2 (sqrt dist2)))])
(set-body-vx! i1 (fl+ (body-vx i1) (fl* (fl* dx mag) (body-mass o1))))
(set-body-vy! i1 (fl+ (body-vy i1) (fl* (fl* dy mag) (body-mass o1))))
(set-body-vz! i1 (fl+ (body-vz i1) (fl* (fl* dz mag) (body-mass o1))))
[mag (fl/ +dt+ (fl* dist2 (flsqrt dist2)))]
[dxmag (fl* dx mag)]
[dymag (fl* dy mag)]
[dzmag (fl* dz mag)]
[om (body-mass o1)]
[im (body-mass i1)])
(set-body-vx! i1 (fl+ (body-vx i1) (fl* dxmag om)))
(set-body-vy! i1 (fl+ (body-vy i1) (fl* dymag om)))
(set-body-vz! i1 (fl+ (body-vz i1) (fl* dzmag om)))
(loop-i (unsafe-fx+ i 1)
(fl- vx (fl* (fl* dx mag) (body-mass i1)))
(fl- vy (fl* (fl* dy mag) (body-mass i1)))
(fl- vz (fl* (fl* dz mag) (body-mass i1)))))
(fl- vx (fl* dxmag im))
(fl- vy (fl* dymag im))
(fl- vz (fl* dzmag im))))
(begin (set-body-vx! o1 vx)
(set-body-vy! o1 vy)
(set-body-vz! o1 vz)

4
collects/tests/mzscheme/unsafe.ss
View File

@ -127,6 +127,10 @@
(test-un 0.0 unsafe-flabs -0.0)
(test-un +inf.0 unsafe-flabs -inf.0)
(test-un 5.0 unsafe-flsqrt 25.0)
(test-un 0.5 unsafe-flsqrt 0.25)
(test-un +nan.0 unsafe-flsqrt -1.0)
(test-un 8.0 'unsafe-fx->fl 8)
(test-un -8.0 'unsafe-fx->fl -8)

5
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,8 @@
Version 4.2.3.6
Changed JIT to support unboxed local binding of known-flonum
arguments to unsafe-fl functions
Added unsafe-flsqrt
Version 4.2.3.5
Added #:save-errno option for foreign-function types

999
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

@ -59,7 +59,7 @@ static Scheme_Env *unsafe_env;
#define MAX_CONST_LOCAL_POS 64
#define MAX_CONST_LOCAL_TYPES 2
#define MAX_CONST_LOCAL_FLAG_VAL 2
#define MAX_CONST_LOCAL_FLAG_VAL 3
#define SCHEME_LOCAL_FLAGS_MASK 0x3
static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1];
#define MAX_CONST_TOPLEVEL_DEPTH 16
@ -713,15 +713,21 @@ static void init_scheme_local()
#ifndef USE_TAGGED_ALLOCATION
GC_CAN_IGNORE Scheme_Local *all;
all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS);
all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local)
* (MAX_CONST_LOCAL_FLAG_VAL + 1)
* MAX_CONST_LOCAL_TYPES
* MAX_CONST_LOCAL_POS);
# ifdef MEMORY_COUNTING_ON
scheme_misc_count += sizeof(Scheme_Local) * 3 * 2 * MAX_CONST_LOCAL_POS;
scheme_misc_count += (sizeof(Scheme_Local)
* (MAX_CONST_LOCAL_FLAG_VAL + 1)
* MAX_CONST_LOCAL_TYPES
* MAX_CONST_LOCAL_POS);
# endif
#endif
for (i = 0; i < MAX_CONST_LOCAL_POS; i++) {
for (k = 0; k < 2; k++) {
for (cor = 0; cor < 3; cor++) {
for (k = 0; k < MAX_CONST_LOCAL_TYPES; k++) {
for (cor = 0; cor < (MAX_CONST_LOCAL_FLAG_VAL + 1); cor++) {
Scheme_Object *v;
#ifndef USE_TAGGED_ALLOCATION
@ -1898,6 +1904,7 @@ Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags)
case 0:
case SCHEME_LOCAL_CLEAR_ON_READ:
case SCHEME_LOCAL_OTHER_CLEARS:
case SCHEME_LOCAL_FLONUM:
break;
default:
flags = SCHEME_LOCAL_OTHER_CLEARS;
@ -3397,7 +3404,7 @@ Scheme_Once_Used *scheme_make_once_used(Scheme_Object *val, int pos, int vclock,
return o;
}
void scheme_optimize_mutated(Optimize_Info *info, int pos)
static void register_use(Optimize_Info *info, int pos, int flag)
/* pos must be in immediate frame */
{
if (!info->use) {
@ -3406,7 +3413,13 @@ void scheme_optimize_mutated(Optimize_Info *info, int pos)
memset(use, 0, info->new_frame);
info->use = use;
}
info->use[pos] = 1;
info->use[pos] |= flag;
}
void scheme_optimize_mutated(Optimize_Info *info, int pos)
/* pos must be in immediate frame */
{
register_use(info, pos, 0x1);
}
Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated)
@ -3424,7 +3437,7 @@ Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_
}
if (unless_mutated)
if (info->use && info->use[pos])
if (info->use && (info->use[pos] & 0x1))
return NULL;
return scheme_make_local(scheme_local_type, pos + delta, 0);
@ -3455,12 +3468,31 @@ int scheme_optimize_is_mutated(Optimize_Info *info, int pos)
info = info->next;
}
if (info->use && info->use[pos])
if (info->use && (info->use[pos] & 0x1))
return 1;
return 0;
}
int scheme_optimize_is_unbox_arg(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] & 0x2)) {
/* make sure it's not captured by a closure */
if (!info->stat_dists || (info->sd_depths[pos] < 2))
return 1;
}
return 0;
}
int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
{
int j, i;
@ -3490,7 +3522,7 @@ int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos)
}
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)
int *not_ready, int once_used_ok, int context)
{
Scheme_Object *p, *n;
int delta = 0;
@ -3505,6 +3537,9 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
info = info->next;
}
if (context & OPT_CONTEXT_FLONUM_ARG)
register_use(info, pos, 0x2);
p = info->consts;
while (p) {
n = SCHEME_VEC_ELS(p)[1];
@ -3555,7 +3590,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, 0);
n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, 0, context);
if (!n) {
/* Return shifted reference to other local: */
@ -3575,16 +3610,16 @@ static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int
}
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use,
int once_used_ok)
int once_used_ok, int context)
{
return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok);
return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok, context);
}
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, 0);
do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0, 0);
return ready;
}
@ -3791,7 +3826,6 @@ Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsi
ia = MALLOC_N_ATOMIC(int, mapc);
naya->flags = ia;
/* necessary? added when changed allocation to atomic */
for (i = mapc; i--; ) {
naya->old_pos[i] = 0;
naya->new_pos[i] = 0;

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

@ -758,9 +758,9 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved,
if ((vtype > _scheme_compiled_values_types_)
|| ((vtype == scheme_local_type)
&& !(SCHEME_LOCAL_FLAGS(o) & SCHEME_LOCAL_CLEAR_ON_READ))
&& !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ))
|| ((vtype == scheme_local_unbox_type)
&& !(SCHEME_LOCAL_FLAGS(o) & SCHEME_LOCAL_CLEAR_ON_READ))
&& !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ))
|| (vtype == scheme_unclosed_procedure_type)
|| (vtype == scheme_compiled_unclosed_procedure_type)
|| (vtype == scheme_case_lambda_sequence_type)
@ -1974,7 +1974,9 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info)
? scheme_local_unbox_type
: scheme_local_type,
pos,
0);
((flags & SCHEME_INFO_FLONUM_ARG)
? SCHEME_LOCAL_FLONUM
: 0));
}
}
case scheme_compiled_syntax_type:
@ -2283,7 +2285,8 @@ static Scheme_Object *try_optimize_fold(Scheme_Object *f, Scheme_Object *o, Opti
}
static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info,
int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3)
int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int context)
{
Scheme_Let_Header *lh;
Scheme_Compiled_Let_Value *lv, *prev = NULL;
@ -2293,7 +2296,7 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
if (!argc) {
info = scheme_optimize_info_add_frame(info, 0, 0, 0);
info->inline_fuel >>= 1;
p = scheme_optimize_expr(p, info);
p = scheme_optimize_expr(p, info, context);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info);
@ -2335,7 +2338,7 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
else
lh->body = p;
return scheme_optimize_lets((Scheme_Object *)lh, info, 1);
return scheme_optimize_lets((Scheme_Object *)lh, info, 1, context);
}
#if 0
@ -2346,7 +2349,7 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc,
Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3,
int *_flags)
int *_flags, int context)
/* If not app, app2, or app3, just return a known procedure, if any,
and do not check arity. */
{
@ -2363,7 +2366,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, 0);
le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use, 0, 0);
if (!le)
return NULL;
}
@ -2397,7 +2400,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
le = scheme_optimize_clone(0, data->code, info, offset, argc);
if (le) {
LOG_INLINE(fprintf(stderr, "Inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
return apply_inlined(le, data, info, argc, app, app2, app3);
return apply_inlined(le, data, info, argc, app, app2, app3, context);
} else {
LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???"));
}
@ -2542,7 +2545,8 @@ static void reset_rator(Scheme_Object *app, Scheme_Object *a)
}
}
static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rator, Optimize_Info *info, int argc)
static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rator, Optimize_Info *info,
int argc, int context)
{
if (SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_let_void_type)) {
Scheme_Let_Header *head = (Scheme_Let_Header *)rator;
@ -2568,7 +2572,7 @@ static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rat
clv->flags[0] |= SCHEME_WAS_ONLY_APPLIED;
}
return scheme_optimize_expr(rator, info);
return scheme_optimize_expr(rator, info, context);
}
}
}
@ -2598,7 +2602,7 @@ static int purely_functional_primitive(Scheme_Object *rator, int n)
#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm))
int scheme_wants_unboxed_arguments(Scheme_Object *rator)
int scheme_wants_flonum_arguments(Scheme_Object *rator)
{
if (SCHEME_PRIMP(rator)
&& (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) {
@ -2700,6 +2704,31 @@ static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *inf
return 0;
}
int scheme_expr_produces_flonum(Scheme_Object *expr)
{
switch (SCHEME_TYPE(expr)) {
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)expr;
return produces_unboxed(app->args[0]);
}
break;
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr;
return produces_unboxed(app->rator);
}
break;
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr;
return produces_unboxed(app->rator);
}
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;
@ -2707,7 +2736,7 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r
Scheme_Compiled_Let_Value *inner = NULL;
int i, lifted = 0;
if (scheme_wants_unboxed_arguments(rator)) {
if (scheme_wants_flonum_arguments(rator)) {
for (i = 0; i < count; i++) {
if (count == 1)
rand = ((Scheme_App2_Rec *)_app)->rand;
@ -2837,38 +2866,40 @@ static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *r
return result;
}
static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info)
static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_Object *le;
Scheme_App_Rec *app;
int i, n, all_vals = 1, rator_flags = 0;
int i, n, all_vals = 1, rator_flags = 0, sub_context = 0;
app = (Scheme_App_Rec *)o;
le = check_app_let_rator(o, app->args[0], info, app->num_args);
le = check_app_let_rator(o, app->args[0], info, app->num_args, context);
if (le) return le;
n = app->num_args + 1;
for (i = 0; i < n; i++) {
if (!i) {
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context);
if (le)
return le;
}
le = scheme_optimize_expr(app->args[i], info);
le = scheme_optimize_expr(app->args[i], info, sub_context);
app->args[i] = le;
if (!i) {
if (SAME_TYPE(SCHEME_TYPE(app->args[0]),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags);
le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context);
if (le)
return le;
}
}
if (scheme_wants_flonum_arguments(app->args[0]))
sub_context |= OPT_CONTEXT_FLONUM_ARG;
}
if (i && (SCHEME_TYPE(le) < _scheme_compiled_values_types_))
all_vals = 0;
@ -2907,7 +2938,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, 0);
c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL, 0, 0);
}
if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) {
if (info->top_level_consts) {
@ -2944,32 +2975,35 @@ static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *r
return NULL;
}
static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info)
static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_App2_Rec *app;
Scheme_Object *le;
int rator_flags = 0;
int rator_flags = 0, sub_context = 0;
app = (Scheme_App2_Rec *)o;
le = check_app_let_rator(o, app->rator, info, 1);
le = check_app_let_rator(o, app->rator, info, 1, context);
if (le) return le;
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context);
if (le)
return le;
le = scheme_optimize_expr(app->rator, info);
le = scheme_optimize_expr(app->rator, info, sub_context);
app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags);
le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context);
if (le)
return le;
}
le = scheme_optimize_expr(app->rand, info);
if (scheme_wants_flonum_arguments(app->rator))
sub_context |= OPT_CONTEXT_FLONUM_ARG;
le = scheme_optimize_expr(app->rand, info, sub_context);
app->rand = le;
info->size += 1;
@ -3010,35 +3044,38 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
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, int context)
{
Scheme_App3_Rec *app;
Scheme_Object *le;
int all_vals = 1;
int rator_flags = 0;
int rator_flags = 0, sub_context = 0;
app = (Scheme_App3_Rec *)o;
le = check_app_let_rator(o, app->rator, info, 2);
le = check_app_let_rator(o, app->rator, info, 2, context);
if (le) return le;
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context);
if (le)
return le;
le = scheme_optimize_expr(app->rator, info);
le = scheme_optimize_expr(app->rator, info, sub_context);
app->rator = le;
if (SAME_TYPE(SCHEME_TYPE(app->rator),scheme_compiled_unclosed_procedure_type)) {
/* Found "((lambda" after optimizing; try again */
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags);
le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context);
if (le)
return le;
}
if (scheme_wants_flonum_arguments(app->rator))
sub_context |= OPT_CONTEXT_FLONUM_ARG;
/* 1st arg */
le = scheme_optimize_expr(app->rand1, info);
le = scheme_optimize_expr(app->rand1, info, sub_context);
app->rand1 = le;
if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
@ -3046,7 +3083,7 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
/* 2nd arg */
le = scheme_optimize_expr(app->rand2, info);
le = scheme_optimize_expr(app->rand2, info, sub_context);
app->rand2 = le;
if (SCHEME_TYPE(le) < _scheme_compiled_values_types_)
@ -3077,7 +3114,8 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
? ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)
? -1
: 1)
: 0));
: 0),
context);
}
}
}
@ -3141,7 +3179,8 @@ static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *inf
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
Optimize_Info *info,
int e_single_result)
int e_single_result,
int context)
/* f and e are already optimized */
{
Scheme_Object *f_is_proc = NULL;
@ -3159,7 +3198,7 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
if (rev) {
int rator2_flags;
Scheme_Object *o_f;
o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags);
o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context);
if (o_f) {
f_is_proc = rev;
@ -3209,7 +3248,7 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
app2->rator = f_cloned;
app2->rand = cloned;
info->inline_fuel >>= 1; /* because we've already optimized the rand */
return optimize_application2((Scheme_Object *)app2, info);
return optimize_application2((Scheme_Object *)app2, info, context);
}
}
@ -3221,7 +3260,7 @@ Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
return scheme_make_syntax_compiled(APPVALS_EXPD, cons(f, e));
}
static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info)
static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_Sequence *s = (Scheme_Sequence *)o;
Scheme_Object *le;
@ -3230,7 +3269,7 @@ static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info)
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, 0);
if (i == s->count - 1) {
single_result = info->single_result;
preserves_marks = info->preserves_marks;
@ -3307,7 +3346,7 @@ static int equivalent_exprs(Scheme_Object *a, Scheme_Object *b)
return 0;
}
static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_Branch_Rec *b;
Scheme_Object *t, *tb, *fb;
@ -3338,9 +3377,9 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_let_void_type)) {
/* Maybe convert: (let ([x M]) (if x x N)) => (if M #t N) */
t = scheme_optimize_lets_for_test(t, info);
t = scheme_optimize_lets_for_test(t, info, 0);
} else
t = scheme_optimize_expr(t, info);
t = scheme_optimize_expr(t, info, 0);
info->vclock += 1; /* model branch as clock increment */
@ -3352,14 +3391,14 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) {
if (SCHEME_FALSEP(t))
return scheme_optimize_expr(fb, info);
return scheme_optimize_expr(fb, info, 0);
else
return scheme_optimize_expr(tb, info);
return scheme_optimize_expr(tb, info, 0);
} else if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_quote_syntax_type)
|| SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_unclosed_procedure_type))
return scheme_optimize_expr(tb, info);
return scheme_optimize_expr(tb, info, 0);
tb = scheme_optimize_expr(tb, info);
tb = scheme_optimize_expr(tb, info, 0);
if (!info->preserves_marks)
preserves_marks = 0;
@ -3370,7 +3409,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
else if (info->single_result < 0)
single_result = -1;
fb = scheme_optimize_expr(fb, info);
fb = scheme_optimize_expr(fb, info, 0);
if (!info->preserves_marks)
preserves_marks = 0;
@ -3426,16 +3465,16 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
return o;
}
static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info)
static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int context)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b;
k = scheme_optimize_expr(wcm->key, info);
k = scheme_optimize_expr(wcm->key, info, 0);
v = scheme_optimize_expr(wcm->val, info);
v = scheme_optimize_expr(wcm->val, info, 0);
b = scheme_optimize_expr(wcm->body, info);
b = scheme_optimize_expr(wcm->body, info, 0);
/* info->single_result is already set */
info->preserves_marks = 0;
@ -3454,14 +3493,15 @@ static Scheme_Object *optimize_k(void)
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1;
Optimize_Info *info = (Optimize_Info *)p->ku.k.p2;
int context = p->ku.k.i1;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
return scheme_optimize_expr(expr, info);
return scheme_optimize_expr(expr, info, context);
}
Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context)
{
Scheme_Type type = SCHEME_TYPE(expr);
@ -3472,6 +3512,7 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
p->ku.k.p1 = (void *)expr;
p->ku.k.p2 = (void *)info;
p->ku.k.i1 = context;
return scheme_handle_stack_overflow(optimize_k);
}
@ -3490,7 +3531,7 @@ 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, 1);
val = scheme_optimize_info_lookup(info, pos, NULL, NULL, 1, context);
if (val) {
if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) {
Scheme_Once_Used *o = (Scheme_Once_Used *)val;
@ -3500,15 +3541,15 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
if (val) {
info->size -= 1;
o->used = 1;
return scheme_optimize_expr(val, info);
return scheme_optimize_expr(val, info, context);
}
}
/* Can't move expression, so lookup again to mark as used. */
(void)scheme_optimize_info_lookup(info, pos, NULL, NULL, 0);
(void)scheme_optimize_info_lookup(info, pos, NULL, NULL, 0, context);
} else {
if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) {
info->size -= 1;
return scheme_optimize_expr(val, info);
return scheme_optimize_expr(val, info, context);
}
return val;
}
@ -3525,24 +3566,24 @@ Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info)
Scheme_Syntax_Optimizer f;
f = scheme_syntax_optimizers[SCHEME_PINT_VAL(expr)];
return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info);
return f((Scheme_Object *)SCHEME_IPTR_VAL(expr), info, context);
}
case scheme_application_type:
return optimize_application(expr, info);
return optimize_application(expr, info, context);
case scheme_application2_type:
return optimize_application2(expr, info);
return optimize_application2(expr, info, context);
case scheme_application3_type:
return optimize_application3(expr, info);
return optimize_application3(expr, info, context);
case scheme_sequence_type:
return optimize_sequence(expr, info);
return optimize_sequence(expr, info, context);
case scheme_branch_type:
return optimize_branch(expr, info);
return optimize_branch(expr, info, context);
case scheme_with_cont_mark_type:
return optimize_wcm(expr, info);
return optimize_wcm(expr, info, context);
case scheme_compiled_unclosed_procedure_type:
return scheme_optimize_closure_compilation(expr, info);
return scheme_optimize_closure_compilation(expr, info, context);
case scheme_compiled_let_void_type:
return scheme_optimize_lets(expr, info, 0);
return scheme_optimize_lets(expr, info, 0, context);
case scheme_compiled_toplevel_type:
info->size += 1;
if (info->top_level_consts) {
@ -4555,7 +4596,7 @@ static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
lo->body = body;
et = scheme_get_eval_type(lo->value);
SCHEME_LET_EVAL_TYPE(lo) = et;
SCHEME_LET_EVAL_TYPE(lo) = (et | (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM));
return o;
}
@ -4685,7 +4726,7 @@ Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_
case scheme_local_unbox_type:
if (!info->pass)
scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
else {
else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) {
int pos, at_ip;
pos = SCHEME_LOCAL_POS(expr);
at_ip = info->max_used[info->stackpos + pos];
@ -5547,7 +5588,7 @@ static void *compile_k(void)
oi->enforce_const = enforce_consts;
if (!(comp_flags & COMP_CAN_INLINE))
oi->inline_fuel = -1;
o = scheme_optimize_expr(o, oi);
o = scheme_optimize_expr(o, oi, 0);
rp = scheme_resolve_prefix(0, cenv->prefix, 1);
ri = scheme_resolve_info_create(rp);
@ -8131,7 +8172,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
#if 1
# define EVAL_SFS_CLEAR(runstack, obj) \
if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { \
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ) { \
runstack[SCHEME_LOCAL_POS(obj)] = NULL; \
}
# define SFS_CLEAR_RUNSTACK_ONE(runstack, pos) runstack[pos] = NULL
@ -10685,6 +10726,7 @@ void scheme_pop_prefix(Scheme_Object **rs)
#define VALID_TOPLEVELS 4
#define VALID_VAL_NOCLEAR 5
#define VALID_BOX_NOCLEAR 6
#define VALID_FLONUM 7
typedef struct Validate_Clearing {
MZTAG_IF_REQUIRED
@ -11042,7 +11084,7 @@ static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct V
{
if ((vc->self_pos >= 0)
&& SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)
&& !(SCHEME_LOCAL_FLAGS(rator) & SCHEME_LOCAL_CLEARING_MASK)
&& !SCHEME_GET_LOCAL_FLAGS(rator)
&& ((SCHEME_LOCAL_POS(rator) + delta) == vc->self_pos)) {
/* For a self call, the JIT needs the closure data to be intact. */
int i, pos;
@ -11174,7 +11216,10 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
if ((q < 0) || (p >= depth))
scheme_ill_formed_code(port);
if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) {
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) {
if (stack[p] != VALID_FLONUM)
scheme_ill_formed_code(port);
} else if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) {
if (result_ignored && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR))) {
/* ok to look up and ignore box */
} else if ((proc_with_refs_ok >= 2)
@ -11188,13 +11233,13 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
scheme_ill_formed_code(port);
}
if (SCHEME_LOCAL_FLAGS(expr) & SCHEME_LOCAL_CLEAR_ON_READ) {
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) {
if ((stack[p] == VALID_VAL_NOCLEAR) || (stack[p] == VALID_BOX_NOCLEAR))
scheme_ill_formed_code(port);
if (p >= letlimit)
clearing_stack_push(vc, p, stack[p]);
stack[p] = VALID_NOT;
} else if (!(SCHEME_LOCAL_FLAGS(expr) & SCHEME_LOCAL_OTHER_CLEARS)) {
} else if (!(SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_OTHER_CLEARS)) {
if (stack[p] == VALID_BOX) {
if (p >= letlimit)
noclear_stack_push(vc, p);
@ -11216,13 +11261,13 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
&& (stack[p] != VALID_BOX_NOCLEAR)))
scheme_ill_formed_code(port);
if (SCHEME_LOCAL_FLAGS(expr) & SCHEME_LOCAL_CLEAR_ON_READ) {
if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) {
if (stack[p] == VALID_BOX_NOCLEAR)
scheme_ill_formed_code(port);
if (p >= letlimit)
clearing_stack_push(vc, p, stack[p]);
stack[p] = VALID_NOT;
} else if (!(SCHEME_LOCAL_FLAGS(expr) & SCHEME_LOCAL_OTHER_CLEARS)) {
} else if (!(SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_OTHER_CLEARS)) {
if (stack[p] == VALID_BOX) {
if (p >= letlimit)
noclear_stack_push(vc, p);
@ -11508,6 +11553,9 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
scheme_ill_formed_code(port);
#endif
if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM)
stack[delta] = VALID_FLONUM;
else
stack[delta] = VALID_VAL;
expr = lo->body;

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

@ -965,7 +965,7 @@ typedef struct {
} Closure_Info;
Scheme_Object *
scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int context)
{
Scheme_Closure_Data *data;
Scheme_Object *code, *ctx;
@ -999,7 +999,7 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
scheme_optimize_mutated(info, i);
}
code = scheme_optimize_expr(data->code, info);
code = scheme_optimize_expr(data->code, info, 0);
if (info->single_result)
SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SINGLE_RESULT;

254
src/mzscheme/src/jit.c
View File

@ -162,6 +162,7 @@ static void *bad_app_vals_target;
static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code;
static void *finish_tail_call_code, *finish_tail_call_fixup_code;
static void *module_run_start_code, *module_start_start_code;
static void *box_flonum_from_stack_code;
typedef struct {
MZTAG_IF_REQUIRED
@ -178,7 +179,9 @@ typedef struct {
. 1 -> shift >>2 to get orig pushed count
. 1 -> shift >>4 to get arity for single orig pushed
. shift >>2 to get flags
. 1 -> shift >>1 to get new (native) pushed */
. 1 -> case 0x2 bit:
. 0 -> shift >>2 to get new (native) pushed
. 1 -> shift >>2 to get flonum stack pos */
int num_mappings, mappings_size;
int retained;
int need_set_rs;
@ -199,6 +202,7 @@ typedef struct {
void *patch_depth;
int rs_virtual_offset;
int unbox, unbox_depth;
int flostack_offset, flostack_space;
} mz_jit_state;
#define mz_RECORD_STATUS(s) (jitter->status_at_ptr = _jit.x.pc, jitter->reg_status = (s))
@ -788,14 +792,6 @@ static Scheme_Object *apply_checked_fail(Scheme_Object **args)
# define mz_st_runstack_base_alt(reg) mz_set_local_p(reg, JIT_RUNSTACK_BASE_LOCAL)
#endif
#ifdef MZ_USE_JIT_PPC
# define JIT_STACK 1
# define JIT_STACK_FRAME 1
#else
# define JIT_STACK JIT_SP
# define JIT_STACK_FRAME JIT_FP
#endif
#define JIT_UPDATE_THREAD_RSPTR() mz_tl_sti_p(tl_MZ_RUNSTACK, JIT_RUNSTACK, JIT_R0)
#define JIT_UPDATE_THREAD_RSPTR_IF_NEEDED() \
if (jitter->need_set_rs) { \
@ -891,12 +887,13 @@ static void mz_pushr_p_it(mz_jit_state *jitter, int reg)
jitter->max_extra_pushed = jitter->extra_pushed;
if (!(jitter->mappings[jitter->num_mappings] & 0x1)
|| (jitter->mappings[jitter->num_mappings] & 0x2)
|| (jitter->mappings[jitter->num_mappings] < 0)) {
new_mapping(jitter);
}
v = (jitter->mappings[jitter->num_mappings]) >> 1;
v = (jitter->mappings[jitter->num_mappings]) >> 2;
v++;
jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1);
jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1);
mz_rs_dec(1);
CHECK_RUNSTACK_OVERFLOW_NOCL();
@ -913,12 +910,13 @@ static void mz_popr_p_it(mz_jit_state *jitter, int reg)
jitter->extra_pushed--;
JIT_ASSERT(jitter->mappings[jitter->num_mappings] & 0x1);
v = jitter->mappings[jitter->num_mappings] >> 1;
JIT_ASSERT(!(jitter->mappings[jitter->num_mappings] & 0x2));
v = jitter->mappings[jitter->num_mappings] >> 2;
v--;
if (!v)
--jitter->num_mappings;
else
jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1);
jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1);
mz_rs_ldr(reg);
mz_rs_inc(1);
@ -931,13 +929,14 @@ static void mz_runstack_skipped(mz_jit_state *jitter, int n)
int v;
if (!(jitter->mappings[jitter->num_mappings] & 0x1)
|| (jitter->mappings[jitter->num_mappings] & 0x2)
|| (jitter->mappings[jitter->num_mappings] > 0)) {
new_mapping(jitter);
}
v = (jitter->mappings[jitter->num_mappings]) >> 1;
v = (jitter->mappings[jitter->num_mappings]) >> 2;
JIT_ASSERT(v <= 0);
v -= n;
jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1);
jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1);
jitter->self_pos += n;
}
@ -946,13 +945,14 @@ static void mz_runstack_unskipped(mz_jit_state *jitter, int n)
int v;
JIT_ASSERT(jitter->mappings[jitter->num_mappings] & 0x1);
v = (jitter->mappings[jitter->num_mappings]) >> 1;
JIT_ASSERT(!(jitter->mappings[jitter->num_mappings] & 0x2));
v = (jitter->mappings[jitter->num_mappings]) >> 2;
JIT_ASSERT(v + n <= 0);
v += n;
if (!v)
--jitter->num_mappings;
else
jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1);
jitter->mappings[jitter->num_mappings] = ((v << 2) | 0x1);
jitter->self_pos -= n;
}
@ -982,6 +982,18 @@ static void mz_runstack_closure_pushed(mz_jit_state *jitter, int a, int flags)
/* closures are never popped; they go away due to returns or tail calls */
}
static void mz_runstack_flonum_pushed(mz_jit_state *jitter, int pos)
{
jitter->depth += 1;
if (jitter->depth > jitter->max_depth)
jitter->max_depth = jitter->depth;
jitter->self_pos += 1;
new_mapping(jitter);
jitter->mappings[jitter->num_mappings] = (pos << 2) | 0x3;
jitter->need_set_rs = 1;
/* flonums are never popped; they go away due to returns or tail calls */
}
static void mz_runstack_popped(mz_jit_state *jitter, int n)
{
int v;
@ -1023,10 +1035,16 @@ static int mz_runstack_restored(mz_jit_state *jitter)
int amt = 0, c;
while ((c = jitter->mappings[jitter->num_mappings])) {
if (c & 0x1) {
/* native push */
c >>= 1;
if (c & 0x2) {
/* single flonum */
amt++;
jitter->self_pos--;
} else {
/* native push or skip */
c >>= 2;
if (c > 0)
amt += c;
}
} else if (c & 0x2) {
/* single procedure */
amt++;
@ -1046,17 +1064,38 @@ static int mz_runstack_restored(mz_jit_state *jitter)
return amt;
}
static int mz_flostack_save(mz_jit_state *jitter, int *pos)
{
*pos = jitter->flostack_offset;
return jitter->flostack_space;
}
static void mz_flostack_restore(mz_jit_state *jitter, int space, int pos)
{
if (space != jitter->flostack_space) {
int delta = jitter->flostack_space - space;
jit_addi_p(JIT_SP, JIT_SP, delta * sizeof(double));
jitter->flostack_space = space;
}
jitter->flostack_offset = pos;
}
static int mz_remap_it(mz_jit_state *jitter, int i)
{
int j = i, p = jitter->num_mappings, c;
while (p && (j >= 0)) {
c = jitter->mappings[p];
if (c & 0x1) {
if (c & 0x2) {
/* single flonum */
j--;
} else {
/* native push or skip */
c >>= 1;
c >>= 2;
i += c;
if (c < 0)
j += c;
}
} else if (c & 0x2) {
/* single procedure */
j--;
@ -1075,10 +1114,15 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity, int *_flags)
while (p && (j >= 0)) {
c = jitter->mappings[p];
if (c & 0x1) {
/* native push */
c >>= 1;
if (c & 0x2) {
/* single flonum */
j--;
} else {
/* native push or skip */
c >>= 2;
if (c < 0)
j += c;
}
} else if (c & 0x2) {
/* procedure */
if (!j) {
@ -1098,6 +1142,37 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity, int *_flags)
return 0;
}
static int mz_flonum_pos(mz_jit_state *jitter, int i)
{
int j = i, p = jitter->num_mappings, c;
while (p && (j >= 0)) {
c = jitter->mappings[p];
if (c & 0x1) {
if (c & 0x2) {
/* single flonum */
if (!j) {
/* the one we're looking for */
return c >> 2;
}
j--;
} else {
/* native push or skip */
c >>= 2;
if (c < 0)
j += c;
}
} else if (c & 0x2) {
/* single procedure */
j--;
} else {
/* pushed N */
j -= (c >> 2);
}
--p;
}
return 0;
}
static int stack_safety(mz_jit_state *jitter, int cnt, int offset)
/* de-sync'd rs ok */
{
@ -1191,8 +1266,8 @@ int check_location;
# define JIT_LOCAL1 56
# define JIT_LOCAL2 60
# define JIT_LOCAL3 64
# define mz_set_local_p(x, l) jit_stxi_p(l, 1, x)
# define mz_get_local_p(x, l) jit_ldxi_p(x, 1, l)
# define mz_set_local_p(x, l) jit_stxi_p(l, JIT_FP, x)
# define mz_get_local_p(x, l) jit_ldxi_p(x, JIT_FP, l)
# define mz_patch_branch_at(a, v) (_jitl.long_jumps ? (void)jit_patch_movei(a-4, a-3, v) : (void)jit_patch_branch(a-1, v))
# define mz_patch_ucbranch_at(a, v) (_jitl.long_jumps ? (void)jit_patch_movei(a-4, a-3, v) : (void)jit_patch_ucbranch(a-1, v))
# define mz_prolog(x) (MFLRr(x), mz_set_local_p(x, JIT_LOCAL2))
@ -1283,6 +1358,7 @@ static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg)
# endif
# define mz_push_locals() SUBQir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP)
# define mz_pop_locals() ADDQir((LOCAL_FRAME_SIZE << JIT_LOG_WORD_SIZE), JIT_SP)
# define JIT_FRAME_FLONUM_OFFSET (-(JIT_WORD_SIZE * (LOCAL_FRAME_SIZE + 3)))
# define _jit_prolog_again(jitter, n, ret_addr_reg) (PUSHQr(ret_addr_reg), jit_base_prolog())
# ifdef MZ_USE_JIT_X86_64
# define jit_shuffle_saved_regs() (MOVQrr(_ESI, _R12), MOVQrr(_EDI, _R13))
@ -2081,7 +2157,7 @@ static int is_non_gc(Scheme_Object *obj, int depth)
static int ok_to_move_local(Scheme_Object *obj)
{
if (SAME_TYPE(SCHEME_TYPE(obj), scheme_local_type)
&& !(SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEARING_MASK)) {
&& !SCHEME_GET_LOCAL_FLAGS(obj)) {
return 1;
} else
return 0;
@ -2332,7 +2408,7 @@ static int generate_pause_for_gc_and_retry(mz_jit_state *jitter,
register back. */
if (i == 1) {
mz_patch_branch(refpause);
JIT_UPDATE_THREAD_RSPTR_FOR_BRANCH_IF_NEEDED();
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(0);
mz_finish(scheme_future_gc_pause);
}
@ -2740,7 +2816,7 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
/* Before inlined native, check stack depth: */
(void)mz_tl_ldi_p(JIT_R1, tl_scheme_jit_stack_boundary); /* assumes USE_STACK_BOUNDARY_VAR */
ref9 = jit_bltr_ul(jit_forward(), JIT_STACK, JIT_R1); /* assumes down-growing stack */
ref9 = jit_bltr_ul(jit_forward(), JIT_SP, JIT_R1); /* assumes down-growing stack */
CHECK_LIMIT();
#ifndef FUEL_AUTODECEREMENTS
@ -3358,7 +3434,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
for (i = 0; i < num_rands; i++) {
v = (alt_rands ? alt_rands[i+1] : app->args[i+1]);
if (SAME_TYPE(SCHEME_TYPE(v), scheme_local_type)
&& !(SCHEME_LOCAL_FLAGS(v) & SCHEME_LOCAL_OTHER_CLEARS)) {
&& !(SCHEME_GET_LOCAL_FLAGS(v) == SCHEME_LOCAL_OTHER_CLEARS)) {
int pos;
pos = mz_remap(SCHEME_LOCAL_POS(v));
if (pos == (jitter->depth + jitter->extra_pushed + args_already_in_place))
@ -3505,6 +3581,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
&& (num_rands >= MAX_SHARED_CALL_RANDS)) {
LOG_IT(("<-many args\n"));
if (is_tail) {
mz_flostack_restore(jitter, 0, 0);
if (direct_prim) {
generate_direct_prim_tail_call(jitter, num_rands);
} else {
@ -3529,6 +3606,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
void *code;
int dp = (direct_prim ? 1 : (direct_native ? (1 + direct_native + (nontail_self ? 1 : 0)) : 0));
if (is_tail) {
mz_flostack_restore(jitter, 0, 0);
if (!shared_tail_code[dp][num_rands]) {
code = generate_shared_call(num_rands, jitter, multi_ok, is_tail, direct_prim, direct_native, 0);
shared_tail_code[dp][num_rands] = code;
@ -3596,6 +3674,7 @@ static int is_unboxable_op(Scheme_Object *obj, int flag)
if (IS_NAMED_PRIM(obj, "unsafe-fl*")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-fl/")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flabs")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flsqrt")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-fx->fl")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-f64vector-ref")) return 1;
if (IS_NAMED_PRIM(obj, "unsafe-flvector-ref")) return 1;
@ -3741,7 +3820,8 @@ static int can_fast_double(int arith, int cmp, int two_args)
|| (arith == 2)
|| (arith == -2)
|| (arith == 11)
|| (arith == 12))
|| (arith == 12)
|| (arith == 13))
return 1;
#endif
#ifdef INLINE_FP_COMP
@ -3777,6 +3857,7 @@ static int can_fast_double(int arith, int cmp, int two_args)
#define jit_divrr_d_fppop(rd,s1,s2) jit_divrr_d(rd,s1,s2)
#define jit_negr_d_fppop(rd,rs) jit_negr_d(rd,rs)
#define jit_abs_d_fppop(rd,rs) jit_abs_d(rd,rs)
#define jit_sqrt_d_fppop(rd,rs) jit_sqrt_d(rd,rs)
#define jit_sti_d_fppop(id, rs) jit_sti_d(id, rs)
#define jit_str_d_fppop(id, rd, rs) jit_str_d(id, rd, rs)
#define jit_stxi_d_fppop(id, rd, rs) jit_stxi_d(id, rd, rs)
@ -3806,7 +3887,7 @@ static int generate_unboxing(mz_jit_state *jitter)
}
static int generate_alloc_double(mz_jit_state *jitter)
/* value should be in JIT_FPR0 */
/* value should be in JIT_FPR0; R0-R2 not saved; V1 used */
{
#ifdef INLINE_FP_OPS
# ifdef CAN_INLINE_ALLOC
@ -3877,6 +3958,8 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
reversed = 0;
} else if (arith == 11) {
/* abs needs no extra number */
} else if (arith == 13) {
/* sqrt needs no extra number */
} else if (arith == 12) {
/* exact->inexact needs no extra number */
} else {
@ -3953,6 +4036,9 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r
case 12: /* exact->inexact */
no_alloc = 1;
break;
case 13: /* sqrt */
jit_sqrt_d_fppop(fpr0, fpr0);
break;
default:
break;
}
@ -4039,6 +4125,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj
arith = 10 -> max
arith = 11 -> abs
arith = 12 -> exact->inexact
arith = 13 -> sqrt
cmp = 0 -> = or zero?
cmp = +/-1 -> >=/<=
cmp = +/-2 -> >/< or positive/negative?
@ -5666,6 +5753,9 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "unsafe-flabs")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 11, 0, 0, NULL, 1, 0, 1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-flsqrt")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 13, 0, 0, NULL, 1, 0, 1, NULL);
return 1;
} else if (IS_NAMED_PRIM(rator, "exact->inexact")) {
generate_arith(jitter, rator, app->rand, NULL, 1, 12, 0, 0, NULL, 1, 0, 0, NULL);
return 1;
@ -7268,6 +7358,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter,
{
int amt, need_ends = 1, using_local1 = 0;
int flostack, flostack_pos;
START_JIT_DATA();
/* Might change the stack or marks: */
@ -7291,6 +7382,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter,
CHECK_LIMIT();
}
mz_runstack_saved(jitter);
flostack = mz_flostack_save(jitter, &flostack_pos);
CHECK_LIMIT();
PAUSE_JIT_DATA();
@ -7302,6 +7394,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter,
RESUME_JIT_DATA();
CHECK_LIMIT();
mz_flostack_restore(jitter, flostack, flostack_pos);
amt = mz_runstack_restored(jitter);
if (amt) {
mz_rs_inc(amt);
@ -7419,12 +7512,18 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
}
case scheme_local_type:
{
/* Other parts of the JIT rely on this code modifying the target register, only */
int pos;
/* Other parts of the JIT rely on this code modifying only the target register,
unless the flag is SCHEME_LOCAL_FLONUM */
int pos, flonum;
START_JIT_DATA();
#if defined(CAN_INLINE_ALLOC) && defined(JIT_FRAME_FLONUM_OFFSET)
flonum = (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_FLONUM);
#else
flonum = 0;
#endif
pos = mz_remap(SCHEME_LOCAL_POS(obj));
LOG_IT(("local %d [%d]\n", pos, SCHEME_LOCAL_FLAGS(obj)));
if (!result_ignored) {
if (!result_ignored && (!flonum || !jitter->unbox)) {
if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) {
mz_rs_ldxi(target, pos);
VALIDATE_RESULT(target);
@ -7432,11 +7531,38 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
jit_movr_p(target, JIT_R0);
}
}
if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) {
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ) {
mz_rs_stxi(pos, JIT_RUNSTACK);
}
CHECK_LIMIT();
if (flonum && !result_ignored) {
#ifdef JIT_FRAME_FLONUM_OFFSET
int offset;
offset = mz_flonum_pos(jitter, SCHEME_LOCAL_POS(obj));
offset = JIT_FRAME_FLONUM_OFFSET - (offset * sizeof(double));
if (jitter->unbox) {
int fpr0;
fpr0 = JIT_FPR(jitter->unbox_depth);
jit_ldxi_d_fppush(fpr0, JIT_FP, offset);
} else {
GC_CAN_IGNORE jit_insn *ref;
mz_rs_sync();
__START_TINY_JUMPS__(1);
ref = jit_bnei_p(jit_forward(), target, NULL);
__END_TINY_JUMPS__(1);
CHECK_LIMIT();
jit_movi_l(JIT_R0, offset);
(void)jit_calli(box_flonum_from_stack_code);
mz_rs_stxi(pos, JIT_R0);
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
__END_TINY_JUMPS__(1);
CHECK_LIMIT();
}
#endif
} else {
if (jitter->unbox) generate_unboxing(jitter);
}
END_JIT_DATA(2);
return 1;
}
@ -7451,7 +7577,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
mz_rs_ldxi(JIT_R0, pos);
jit_ldr_p(target, JIT_R0);
}
if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) {
if (SCHEME_GET_LOCAL_FLAGS(obj) == SCHEME_LOCAL_CLEAR_ON_READ) {
LOG_IT(("clear-on-read\n"));
mz_rs_stxi(pos, JIT_RUNSTACK);
}
@ -7479,7 +7605,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
case BEGIN0_EXPD:
{
Scheme_Sequence *seq;
jit_insn *ref, *ref2;
GC_CAN_IGNORE jit_insn *ref, *ref2;
int i;
START_JIT_DATA();
@ -7665,6 +7791,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE);
if (is_tail) {
__END_SHORT_JUMPS__(1);
mz_flostack_restore(jitter, 0, 0);
(void)jit_bltr_ul(app_values_tail_slow_code, JIT_R0, JIT_R2);
__START_SHORT_JUMPS__(1);
ref5 = 0;
@ -7910,7 +8037,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
{
Scheme_Branch_Rec *branch = (Scheme_Branch_Rec *)obj;
jit_insn *refs[6], *ref2;
int nsrs, nsrs1, g1, g2, amt, need_sync;
int nsrs, nsrs1, g1, g2, amt, need_sync, flostack, flostack_pos;
int else_is_empty = 0;
#ifdef NEED_LONG_JUMPS
int then_short_ok, else_short_ok;
@ -7962,6 +8089,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* True branch */
mz_runstack_saved(jitter);
flostack = mz_flostack_save(jitter, &flostack_pos);
nsrs = jitter->need_set_rs;
PAUSE_JIT_DATA();
LOG_IT(("...then...\n"));
@ -7969,6 +8097,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
g1 = generate(branch->tbranch, jitter, is_tail, multi_ok, orig_target);
RESUME_JIT_DATA();
CHECK_LIMIT();
mz_flostack_restore(jitter, flostack, flostack_pos);
amt = mz_runstack_restored(jitter);
if (g1 != 2) {
if (!is_tail) {
@ -7992,6 +8121,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
/* False branch */
mz_runstack_saved(jitter);
flostack = mz_flostack_save(jitter, &flostack_pos);
__START_SHORT_JUMPS__(then_short_ok);
if (refs[0]) {
mz_patch_branch(refs[0]);
@ -8019,6 +8149,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
g2 = generate(branch->fbranch, jitter, is_tail, multi_ok, orig_target);
RESUME_JIT_DATA();
CHECK_LIMIT();
mz_flostack_restore(jitter, flostack, flostack_pos);
amt = mz_runstack_restored(jitter);
if (g2 != 2) {
if (!is_tail) {
@ -8252,12 +8383,21 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
case scheme_let_one_type:
{
Scheme_Let_One *lv = (Scheme_Let_One *)obj;
int flonum;
START_JIT_DATA();
LOG_IT(("leto...\n"));
mz_runstack_skipped(jitter, 1);
#if defined(CAN_INLINE_ALLOC) && defined(JIT_FRAME_FLONUM_OFFSET)
flonum = SCHEME_LET_EVAL_TYPE(lv) & LET_ONE_FLONUM;
#else
flonum = 0;
#endif
if (flonum)
jitter->unbox++;
PAUSE_JIT_DATA();
generate_non_tail(lv->value, jitter, 0, 1, 0); /* no sync */
RESUME_JIT_DATA();
@ -8267,7 +8407,25 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
mz_rs_dec(1);
CHECK_RUNSTACK_OVERFLOW();
if (flonum) {
#if defined(JIT_FRAME_FLONUM_OFFSET)
int offset;
--jitter->unbox;
if (jitter->flostack_offset == jitter->flostack_space) {
int space = 4 * sizeof(double);
jitter->flostack_space += 4;
jit_subi_l(JIT_SP, JIT_SP, space);
}
jitter->flostack_offset += 1;
mz_runstack_flonum_pushed(jitter, jitter->flostack_offset);
offset = JIT_FRAME_FLONUM_OFFSET - (jitter->flostack_offset * sizeof(double));
(void)jit_stxi_d_fppop(offset, JIT_FP, JIT_FPR0);
(void)jit_movi_p(JIT_R0, NULL);
#endif
} else {
mz_runstack_pushed(jitter, 1);
}
mz_rs_str(JIT_R0);
@ -8971,7 +9129,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* *** get_stack_pointer_code *** */
get_stack_pointer_code = jit_get_ip().ptr;
jit_leaf(0);
jit_movr_p(JIT_R0, JIT_STACK_FRAME);
jit_movr_p(JIT_R0, JIT_FP);
/* Get frame pointer of caller... */
#ifdef MZ_USE_JIT_PPC
jit_ldr_p(JIT_R0, JIT_R0);
@ -9287,6 +9445,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* In set mode, value was already on run stack */
jit_movi_i(JIT_R1, 3);
}
CHECK_LIMIT();
JIT_UPDATE_THREAD_RSPTR();
jit_prepare(2);
jit_pusharg_p(JIT_RUNSTACK);
@ -9297,6 +9456,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
(void)mz_finish(ts_scheme_checked_flvector_set);
}
/* does not return */
CHECK_LIMIT();
}
@ -9634,6 +9794,23 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
#endif
/* *** box_flonum_from_stack_code *** */
/* R0 has offset from frame pointer to double on stack */
{
box_flonum_from_stack_code = jit_get_ip().ptr;
mz_prolog(JIT_R2);
JIT_UPDATE_THREAD_RSPTR();
jit_movr_p(JIT_R1, JIT_FP);
jit_ldxr_d_fppush(JIT_FPR0, JIT_R1, JIT_R0);
generate_alloc_double(jitter);
CHECK_LIMIT();
mz_epilog(JIT_R2);
}
return 1;
}
@ -10095,6 +10272,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
/* r == 2 => tail call performed */
if (r != 2) {
mz_flostack_restore(jitter, 0, 0);
jit_movr_p(JIT_RET, JIT_R0);
mz_pop_threadlocal();
mz_pop_locals();

1
src/mzscheme/src/lightning/i386/fp.h
View File

@ -84,6 +84,7 @@
#define jit_divrr_d_fppop(rd,s1,s2) (FDIVRPr(1))
#define jit_negr_d_fppop(rd,rs) ( _OO (0xd9e0))
#define jit_abs_d_fppop(rd,rs) ( _OO (0xd9e1))
#define jit_sqrt_d_fppop(rd,rs) ( _OO (0xd9fa))
/* - moves:

12
src/mzscheme/src/lightning/ppc/core-common.h
View File

@ -456,7 +456,6 @@ static jit_state _jit;
#endif
#ifndef jit_getarg_c
#ifndef JIT_FP
#define jit_getarg_c(reg, ofs) jit_extr_c_i ((reg), (ofs))
#define jit_getarg_i(reg, ofs) jit_movr_i ((reg), (ofs))
#define jit_getarg_l(reg, ofs) jit_movr_l ((reg), (ofs))
@ -466,17 +465,6 @@ static jit_state _jit;
#define jit_getarg_ui(reg, ofs) jit_movr_ui ((reg), (ofs))
#define jit_getarg_ul(reg, ofs) jit_extr_uc_ul((reg), (ofs))
#define jit_getarg_us(reg, ofs) jit_extr_us_ul((reg), (ofs))
#else
#define jit_getarg_c(reg, ofs) jit_ldxi_c((reg), JIT_FP, (ofs));
#define jit_getarg_uc(reg, ofs) jit_ldxi_uc((reg), JIT_FP, (ofs));
#define jit_getarg_s(reg, ofs) jit_ldxi_s((reg), JIT_FP, (ofs));
#define jit_getarg_us(reg, ofs) jit_ldxi_us((reg), JIT_FP, (ofs));
#define jit_getarg_i(reg, ofs) jit_ldxi_i((reg), JIT_FP, (ofs));
#define jit_getarg_ui(reg, ofs) jit_ldxi_ui((reg), JIT_FP, (ofs));
#define jit_getarg_l(reg, ofs) jit_ldxi_l((reg), JIT_FP, (ofs));
#define jit_getarg_ul(reg, ofs) jit_ldxi_ul((reg), JIT_FP, (ofs));
#define jit_getarg_p(reg, ofs) jit_ldxi_p((reg), JIT_FP, (ofs));
#endif
#endif

1
src/mzscheme/src/lightning/ppc/core.h
View File

@ -46,6 +46,7 @@ struct jit_local_state {
};
#define JIT_SP 1
#define JIT_FP 1
#define JIT_RET 3
#define JIT_R_NUM 3
#define JIT_V_NUM 7

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

@ -88,10 +88,10 @@ static Scheme_Object *top_level_require_execute(Scheme_Object *data);
static Scheme_Object *module_jit(Scheme_Object *data);
static Scheme_Object *top_level_require_jit(Scheme_Object *data);
static Scheme_Object *module_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *module_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *module_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *module_sfs(Scheme_Object *data, SFS_Info *info);
static Scheme_Object *top_level_require_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *top_level_require_resolve(Scheme_Object *data, Resolve_Info *info);
static Scheme_Object *top_level_require_sfs(Scheme_Object *data, SFS_Info *info);
@ -5089,7 +5089,7 @@ static int set_code_closure_flags(Scheme_Object *clones,
}
static Scheme_Object *
module_optimize(Scheme_Object *data, Optimize_Info *info)
module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
Scheme_Module *m = (Scheme_Module *)data;
Scheme_Object *e, *vars, *old_context;
@ -5104,7 +5104,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
cnt = SCHEME_VEC_SIZE(m->body);
for (i_m = 0; i_m < cnt; i_m++) {
/* Optimize this expression: */
e = scheme_optimize_expr(SCHEME_VEC_ELS(m->body)[i_m], info);
e = scheme_optimize_expr(SCHEME_VEC_ELS(m->body)[i_m], info, 0);
SCHEME_VEC_ELS(m->body)[i_m] = e;
if (info->enforce_const) {
@ -5234,7 +5234,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
while (1) {
/* Re-optimize this expression. We can optimize anything without
shift-cloning, since there are no local variables in scope. */
e = scheme_optimize_expr(SCHEME_VEC_ELS(m->body)[start_simltaneous], info);
e = scheme_optimize_expr(SCHEME_VEC_ELS(m->body)[start_simltaneous], info, 0);
SCHEME_VEC_ELS(m->body)[start_simltaneous] = e;
if (re_consts) {
@ -6467,7 +6467,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env,
oi->context = (Scheme_Object *)env->genv->module;
if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
oi->inline_fuel = -1;
m = scheme_optimize_expr(m, oi);
m = scheme_optimize_expr(m, oi, 0);
/* Simplify only in compile mode; it is too slow in expand mode. */
rp = scheme_resolve_prefix(1, eenv->prefix, rec[drec].comp);
@ -9337,7 +9337,7 @@ static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port,
}
static Scheme_Object *
top_level_require_optimize(Scheme_Object *data, Optimize_Info *info)
top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
return scheme_make_syntax_compiled(REQUIRE_EXPD, data);
}

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

@ -1479,7 +1479,7 @@ mark_input_fd {
}
#endif
#if defined(UNIX_PROCESSES)
#if defined(UNIX_PROCESSES) && !(defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC))
mark_system_child {
mark:
System_Child *sc = (System_Child *)p;

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

@ -47,6 +47,7 @@ static Scheme_Object *fl_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_div (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_abs (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_sqrt (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero
@ -173,6 +174,12 @@ void scheme_init_unsafe_numarith(Scheme_Env *env)
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);
p = scheme_make_folding_prim(fl_sqrt, "unsafe-flsqrt", 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-flsqrt", p, env);
}
Scheme_Object *
@ -840,3 +847,12 @@ static Scheme_Object *fl_abs(int argc, Scheme_Object *argv[])
v = fabs(v);
return scheme_make_double(v);
}
static Scheme_Object *fl_sqrt(int argc, Scheme_Object *argv[])
{
double v;
if (scheme_current_thread->constant_folding) return scheme_sqrt(argc, argv);
v = SCHEME_DBL_VAL(argv[0]);
v = sqrt(v);
return scheme_make_double(v);
}

7
src/mzscheme/src/print.c
View File

@ -2437,7 +2437,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
int unbox = SAME_TYPE(SCHEME_TYPE(obj), scheme_local_unbox_type);
Scheme_Local *loc = (Scheme_Local *)obj;
if ((loc->position < CPT_RANGE(SMALL_LOCAL))
&& !(SCHEME_LOCAL_FLAGS(loc) & SCHEME_LOCAL_CLEARING_MASK)) {
&& !SCHEME_GET_LOCAL_FLAGS(loc)) {
unsigned char s[1];
s[0] = loc->position + (unbox
? CPT_SMALL_LOCAL_UNBOX_START
@ -2446,7 +2446,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
} else {
int flags;
print_compact(pp, unbox ? CPT_LOCAL_UNBOX : CPT_LOCAL);
flags = SCHEME_LOCAL_FLAGS(loc) & SCHEME_LOCAL_CLEARING_MASK;
flags = SCHEME_GET_LOCAL_FLAGS(loc);
if (flags) {
print_compact_number(pp, -(loc->position + 1));
print_compact_number(pp, flags);
@ -2507,6 +2507,9 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
lo = (Scheme_Let_One *)obj;
if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM)
print_compact(pp, CPT_LET_ONE_FLONUM);
else
print_compact(pp, CPT_LET_ONE);
print(scheme_protect_quote(lo->value), notdisplay, 1, NULL, mt, pp);
closed = print(scheme_protect_quote(lo->body), notdisplay, 1, NULL, mt, pp);

6
src/mzscheme/src/read.c
View File

@ -4640,7 +4640,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
}
break;
case CPT_STX:
case CPT_GSTX:
{
if (!port->ut) {
Scheme_Unmarshal_Tables *ut;
@ -4675,7 +4674,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
0, 0);
}
v = scheme_unmarshal_datum_to_syntax(v, port->ut, ch == CPT_GSTX);
v = scheme_unmarshal_datum_to_syntax(v, port->ut, 0);
scheme_num_read_syntax_objects++;
if (!v)
scheme_ill_formed_code(port);
@ -4741,6 +4740,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
}
break;
case CPT_LET_ONE:
case CPT_LET_ONE_FLONUM:
{
Scheme_Let_One *lo;
int et;
@ -4753,6 +4753,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
v = read_compact(port, 1);
lo->body = v;
et = scheme_get_eval_type(lo->value);
if (ch == CPT_LET_ONE_FLONUM)
et |= LET_ONE_FLONUM;
SCHEME_LET_EVAL_TYPE(lo) = et;
return (Scheme_Object *)lo;

2
src/mzscheme/src/schcpt.h
View File

@ -19,7 +19,7 @@ enum {
CPT_VECTOR,
CPT_HASH_TABLE,
CPT_STX,
CPT_GSTX,
CPT_LET_ONE_FLONUM,
CPT_MARSHALLED, /* 20 */
CPT_QUOTE,
CPT_REFERENCE,

2
src/mzscheme/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 965
#define EXPECTED_UNSAFE_COUNT 52
#define EXPECTED_UNSAFE_COUNT 53
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

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

@ -999,7 +999,10 @@ typedef struct Scheme_Local {
#define SCHEME_LOCAL_CLEAR_ON_READ 0x1
#define SCHEME_LOCAL_OTHER_CLEARS 0x2
#define SCHEME_LOCAL_CLEARING_MASK 0x3
#define SCHEME_LOCAL_FLONUM 0x3
#define SCHEME_LOCAL_FLAGS_MASK 0x3
#define SCHEME_GET_LOCAL_FLAGS(obj) (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_FLAGS_MASK)
typedef struct Scheme_Toplevel {
Scheme_Inclhash_Object iso; /* keyex used for flags (and can't be hashed) */
@ -1033,12 +1036,13 @@ typedef struct Scheme_Let_Value {
#define SCHEME_LET_AUTOBOX(lh) MZ_OPT_HASH_KEY(&lh->iso)
typedef struct Scheme_Let_One {
Scheme_Inclhash_Object iso; /* keyex used for eval_type */
Scheme_Inclhash_Object iso; /* keyex used for eval_type + flonum (and can't be hashed) */
Scheme_Object *value;
Scheme_Object *body;
} Scheme_Let_One;
#define SCHEME_LET_EVAL_TYPE(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define LET_ONE_FLONUM 0x8
typedef struct Scheme_Let_Void {
Scheme_Inclhash_Object iso; /* keyex used for autobox */
@ -1985,7 +1989,7 @@ typedef struct Optimize_Info
Scheme_Object *context; /* for logging */
} Optimize_Info;
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info);
typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info, int context);
typedef struct Scheme_Object *(*Scheme_Syntax_Cloner)(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
typedef struct Scheme_Object *(*Scheme_Syntax_Shifter)(Scheme_Object *data, int delta, int after_depth);
@ -2240,13 +2244,16 @@ Scheme_Object *scheme_protect_quote(Scheme_Object *expr);
Scheme_Object *scheme_make_syntax_resolved(int idx, Scheme_Object *data);
Scheme_Object *scheme_make_syntax_compiled(int idx, Scheme_Object *data);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline);
Scheme_Object *scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info);
Scheme_Object *scheme_optimize_expr(Scheme_Object *, Optimize_Info *, int context);
Scheme_Object *scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context);
Scheme_Object *scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info, int context);
#define OPT_CONTEXT_FLONUM_ARG 0x1
Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e,
Optimize_Info *info,
int e_single_result);
int e_single_result,
int context);
int scheme_compiled_duplicate_ok(Scheme_Object *o);
int scheme_compiled_propagate_ok(Scheme_Object *o, Optimize_Info *info);
@ -2278,7 +2285,8 @@ 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, int once_used_ok);
Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use,
int once_used_ok, int context);
void scheme_optimize_info_used_top(Optimize_Info *info);
void scheme_optimize_mutated(Optimize_Info *info, int pos);
@ -2286,6 +2294,7 @@ Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_
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);
int scheme_optimize_is_unbox_arg(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);
@ -2305,7 +2314,8 @@ 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);
int scheme_wants_flonum_arguments(Scheme_Object *rator);
int scheme_expr_produces_flonum(Scheme_Object *expr);
typedef struct Scheme_Once_Used {
Scheme_Object so;
@ -2374,7 +2384,7 @@ Scheme_Object *scheme_make_closure_compilation(Scheme_Comp_Env *env,
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list,
int strip_values);
Scheme_Object *scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info);
Scheme_Object *scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int context);
Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
int can_lift, int convert, int just_compute_lift,
Scheme_Object *precomputed_lift);
@ -2407,13 +2417,15 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
#define SCHEME_WAS_SET_BANGED 0x2
#define SCHEME_WAS_ONLY_APPLIED 0x4
#define SCHEME_WAS_APPLIED_EXCEPT_ONCE 0x8
#define SCHEME_WAS_FLONUM_ARGUMENT 0x80
#define SCHEME_USE_COUNT_MASK 0x70
#define SCHEME_USE_COUNT_SHIFT 4
#define SCHEME_USE_COUNT_INF (SCHEME_USE_COUNT_MASK >> SCHEME_USE_COUNT_SHIFT)
/* flags reported by scheme_resolve_info_flags */
#define SCHEME_INFO_BOXED 1
#define SCHEME_INFO_BOXED 0x1
#define SCHEME_INFO_FLONUM_ARG 0x2
/* flags used with scheme_new_frame */
#define SCHEME_TOPLEVEL_FRAME 1

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.3.5"
#define MZSCHEME_VERSION "4.2.3.6"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

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

@ -106,15 +106,15 @@ static Scheme_Object *splice_execute(Scheme_Object *data);
static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
static Scheme_Object *define_values_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *ref_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *set_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *define_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info);
static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *apply_values_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *splice_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *ref_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *set_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *define_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info, int context);
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info, int context);
static Scheme_Object *case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context);
static Scheme_Object *begin0_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *splice_optimize(Scheme_Object *data, Optimize_Info *info, int context);
static Scheme_Object *begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
static Scheme_Object *set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth);
@ -990,13 +990,13 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
}
static Scheme_Object *
define_values_optimize(Scheme_Object *data, Optimize_Info *info)
define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
Scheme_Object *vars = SCHEME_CAR(data);
Scheme_Object *val = SCHEME_CDR(data);
scheme_optimize_info_used_top(info);
val = scheme_optimize_expr(val, info);
val = scheme_optimize_expr(val, info, 0);
return scheme_make_syntax_compiled(DEFINE_VALUES_EXPD, cons(vars, val));
}
@ -1538,7 +1538,7 @@ static void set_validate(Scheme_Object *data, Mz_CPort *port,
}
static Scheme_Object *
set_optimize(Scheme_Object *data, Optimize_Info *info)
set_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
Scheme_Object *var, *val, *set_undef;
@ -1547,7 +1547,7 @@ set_optimize(Scheme_Object *data, Optimize_Info *info)
var = SCHEME_CAR(data);
val = SCHEME_CDR(data);
val = scheme_optimize_expr(val, info);
val = scheme_optimize_expr(val, info, 0);
info->preserves_marks = 1;
info->single_result = 1;
@ -1558,7 +1558,7 @@ 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, 0);
scheme_optimize_info_lookup(info, pos, NULL, NULL, 0, 0);
/* Offset: */
delta = scheme_optimize_info_get_shift(info, pos);
@ -1886,7 +1886,7 @@ static void ref_validate(Scheme_Object *tl, Mz_CPort *port,
}
static Scheme_Object *
ref_optimize(Scheme_Object *tl, Optimize_Info *info)
ref_optimize(Scheme_Object *tl, Optimize_Info *info, int context)
{
scheme_optimize_info_used_top(info);
@ -2083,20 +2083,20 @@ static Scheme_Object *apply_values_jit(Scheme_Object *data)
}
static Scheme_Object *
apply_values_optimize(Scheme_Object *data, Optimize_Info *info)
apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
Scheme_Object *f, *e;
f = SCHEME_CAR(data);
e = SCHEME_CDR(data);
f = scheme_optimize_expr(f, info);
e = scheme_optimize_expr(e, info);
f = scheme_optimize_expr(f, info, 0);
e = scheme_optimize_expr(e, info, 0);
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, context);
}
static Scheme_Object *
@ -2416,7 +2416,7 @@ case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
}
static Scheme_Object *
case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info)
case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context)
{
Scheme_Object *le;
int i;
@ -2424,7 +2424,7 @@ case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info)
for (i = 0; i < seq->count; i++) {
le = seq->array[i];
le = scheme_optimize_expr(le, info);
le = scheme_optimize_expr(le, info, 0);
seq->array[i] = le;
}
@ -3025,7 +3025,7 @@ static int worth_lifting(Scheme_Object *v)
}
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context)
{
Optimize_Info *body_info, *rhs_info;
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
@ -3046,10 +3046,10 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
if (worth_lifting(clv->value)) {
if (for_inline) {
/* Just drop the inline-introduced let */
return scheme_optimize_expr(clv->value, info);
return scheme_optimize_expr(clv->value, info, context);
} else {
info = scheme_optimize_info_add_frame(info, 1, 0, 0);
body = scheme_optimize_expr(clv->value, info);
body = scheme_optimize_expr(clv->value, info, context);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info);
@ -3118,7 +3118,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
body_info->transitive_use_pos = pos + 1;
}
value = scheme_optimize_expr(pre_body->value, rhs_info);
value = scheme_optimize_expr(pre_body->value, rhs_info, 0);
pre_body->value = value;
body_info->transitive_use_pos = 0;
@ -3289,7 +3289,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
avoid the possibility of N^2 behavior. */
body_info->letrec_not_twice = 1;
value = scheme_optimize_expr(self_value, body_info);
value = scheme_optimize_expr(self_value, body_info, 0);
body_info->letrec_not_twice = 0;
@ -3364,7 +3364,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
body_info->vclock = rhs_info->vclock;
}
body = scheme_optimize_expr(body, body_info);
body = scheme_optimize_expr(body, body_info, 0);
if (head->num_clauses)
pre_body->body = body;
else
@ -3411,6 +3411,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
} else {
for (j = pre_body->count; j--; ) {
pre_body->flags[j] |= SCHEME_WAS_USED;
if (scheme_optimize_is_unbox_arg(body_info, pos+j))
pre_body->flags[j] |= SCHEME_WAS_FLONUM_ARGUMENT;
}
info->size += 1;
}
@ -3476,7 +3478,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
if (value) {
info = scheme_optimize_info_add_frame(info, extract_depth, 0, 0);
info->inline_fuel = 0;
value = scheme_optimize_expr(value, info);
value = scheme_optimize_expr(value, info, context);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info);
@ -3491,7 +3493,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
}
Scheme_Object *
scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info, int context)
/* Special case for when the `let' expression appears in an `if' test */
{
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
@ -3520,7 +3522,7 @@ scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0);
form = scheme_optimize_expr((Scheme_Object *)b3, sub_info);
form = scheme_optimize_expr((Scheme_Object *)b3, sub_info, context);
info->single_result = sub_info->single_result;
info->preserves_marks = sub_info->preserves_marks;
@ -3532,8 +3534,7 @@ scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
}
}
return scheme_optimize_lets(form, info, 0);
return scheme_optimize_lets(form, info, 0, context);
}
static int is_lifted_reference(Scheme_Object *v)
@ -3614,6 +3615,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
Scheme_Object *first = NULL, *body, *last_body = NULL;
Scheme_Letrec *letrec;
mzshort *skips, skips_fast[5];
char *flonums, flonums_fast[5];
Scheme_Object **lifted, *lifted_fast[5], *boxes;
int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc;
int rec_proc_nonapply = 0;
@ -3697,9 +3699,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (j <= 5) {
skips = skips_fast;
lifted = lifted_fast;
flonums = flonums_fast;
} else {
skips = MALLOC_N_ATOMIC(mzshort, j);
lifted = MALLOC_N(Scheme_Object*, j);
flonums = MALLOC_N_ATOMIC(char, j);
}
clv = (Scheme_Compiled_Let_Value *)head->body;
@ -3708,6 +3712,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
skips[i] = 1;
else
skips[i] = 0;
if ((clv->flags[0] & SCHEME_WAS_FLONUM_ARGUMENT)
&& scheme_expr_produces_flonum(clv->value))
flonums[i] = SCHEME_INFO_FLONUM_ARG;
else
flonums[i] = 0;
lifted[i] = NULL;
}
@ -3731,9 +3740,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
shift_lift(lifted[j], frame_size, lifts_frame_size);
}
if (skips[j])
scheme_resolve_info_add_mapping(linfo, j, 0, 0, lifted[j]);
scheme_resolve_info_add_mapping(linfo, j, 0, flonums[j], lifted[j]);
else
scheme_resolve_info_add_mapping(linfo, j, k++, 0, lifted[j]);
scheme_resolve_info_add_mapping(linfo, j, k++, flonums[j], lifted[j]);
}
lifts_frame_size = frame_size;
@ -3773,6 +3782,8 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
lo->value = le;
et = scheme_get_eval_type(lo->value);
if (flonums[i])
et |= LET_ONE_FLONUM;
SCHEME_LET_EVAL_TYPE(lo) = et;
if (last)
@ -3799,9 +3810,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
scheme_resolve_info_add_mapping(linfo, i, ((skips[i] < 0)
? (k - skips[i] - 1)
: (skips[i] - 1 + frame_size)),
0, lifted[i]);
flonums[i], lifted[i]);
else
scheme_resolve_info_add_mapping(linfo, i, k++, 0, lifted[i]);
scheme_resolve_info_add_mapping(linfo, i, k++, flonums[i], lifted[i]);
}
body = scheme_resolve_expr(body, linfo);
@ -3839,7 +3850,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type)
&& (SCHEME_LOCAL_POS(app->rand) == 1)) {
if ((SCHEME_TYPE(app->rator) > _scheme_values_types_)
&& !scheme_wants_unboxed_arguments(app->rator)) {
&& !scheme_wants_flonum_arguments(app->rator)) {
/* Move <expr> to app, and drop let-one: */
app->rand = ((Scheme_Let_One *)body)->value;
scheme_reset_app2_eval_type(app);
@ -4846,7 +4857,7 @@ static void begin0_validate(Scheme_Object *data, Mz_CPort *port,
}
static Scheme_Object *
begin0_optimize(Scheme_Object *obj, Optimize_Info *info)
begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context)
{
int i, count;
@ -4854,7 +4865,7 @@ begin0_optimize(Scheme_Object *obj, Optimize_Info *info)
for (i = 0; i < count; i++) {
Scheme_Object *le;
le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info);
le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info, 0);
((Scheme_Sequence *)obj)->array[i] = le;
}
@ -5134,9 +5145,9 @@ static Scheme_Object *splice_jit(Scheme_Object *data)
}
static Scheme_Object *
splice_optimize(Scheme_Object *data, Optimize_Info *info)
splice_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
data = scheme_optimize_expr(data, info);
data = scheme_optimize_expr(data, info, 0);
if (SCHEME_TYPE(data) != scheme_sequence_type)
return data;
@ -5542,7 +5553,7 @@ static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_
if (info->inline_fuel < 0)
einfo->inline_fuel = -1;
val = scheme_optimize_expr(val, einfo);
val = scheme_optimize_expr(val, einfo, 0);
return scheme_make_syntax_compiled((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD),
cons(cp,
@ -5550,12 +5561,12 @@ static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_
cons(names, val))));
}
static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info)
static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
return do_define_syntaxes_optimize(data, info, 0);
}
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info)
static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
return do_define_syntaxes_optimize(data, info, 1);
}
@ -5891,7 +5902,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object
oi = scheme_optimize_info_create();
if (!(rec[drec].comp_flags & COMP_CAN_INLINE))
oi->inline_fuel = -1;
a = scheme_optimize_expr(a, oi);
a = scheme_optimize_expr(a, oi, 0);
ri = scheme_resolve_info_create(rp);
a = scheme_resolve_expr(a, ri);