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

inline map', for-each', andmap', and ormap'

Browse Source 
More generally, support a
 (define _id (begin 'compiler-hint:cross-module-inline _proc-expr))
hint, which is how the compiler determines that `map', etc., are
candidates for inlining.
This commit is contained in:
Matthew Flatt 2011-11-30 17:09:28 -07:00
parent 1ca79003f1
commit 99032a75d0
11 changed files with 655 additions and 261 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/racket/private/kw.rkt
View File

@ -796,19 +796,19 @@
(define-syntax (new-define stx)
(let-values ([(id rhs)
(normalize-definition stx #'new-lambda #t #t)])
(let ([plain (lambda (rhs)
(let* ([plain (lambda (rhs)
(quasisyntax/loc stx
(define #,id #,rhs)))])
(syntax-case rhs ()
[(lam-id . _)
(and (let ([ctx (syntax-local-context)])
(define #,id #,rhs)))]
[can-opt? (lambda (lam-id)
(and (identifier? lam-id)
(or (free-identifier=? lam-id #'new-lambda)
(free-identifier=? lam-id #'new-λ))
(let ([ctx (syntax-local-context)])
(or (and (memq ctx '(module module-begin))
(compile-enforce-module-constants))
(and (list? ctx)
(andmap liberal-define-context? ctx))))
(identifier? #'lam-id)
(or (free-identifier=? #'lam-id #'new-lambda)
(free-identifier=? #'lam-id #'new-λ)))
(andmap liberal-define-context? ctx))))))]
[opt (lambda (rhs core-wrap plain)
(parse-lambda rhs
id
plain
@ -827,11 +827,25 @@
#,n-req #,n-opt #,rest?
'#,req-kws '#,all-kws)))
#,(quasisyntax/loc stx
(define #,core-id #,impl))
(define #,core-id #,(core-wrap impl)))
#,(quasisyntax/loc stx
(define #,unpack-id #,kwimpl))
#,(quasisyntax/loc stx
(define proc #,wrap))))))))]
(define proc #,wrap)))))))))])
(syntax-case rhs (begin quote)
[(lam-id . _)
(can-opt? #'lam-id)
(opt rhs values plain)]
[(begin (quote sym) (lam-id . _))
;; looks like a compiler hint
(and (can-opt? #'lam-id)
(identifier? #'sym))
(syntax-case rhs ()
[(_ _ sub-rhs)
(let ([wrap (lambda (stx) #`(begin (quote sym) #,stx))])
(opt #'sub-rhs
wrap
(lambda (rhs) (plain (wrap rhs)))))])]
[_ (plain rhs)]))))
;; ----------------------------------------

16
collects/racket/private/map.rkt
View File

@ -14,6 +14,8 @@
;; -------------------------------------------------------------------------
(define map2
(begin
'compiler-hint:cross-module-inline
(let ([map
(case-lambda
[(f l)
@ -38,9 +40,11 @@
(loop (cdr l1) (cdr l2)))]))
(map f l1 l2))]
[(f . args) (apply map f args)])])
map))
map)))
(define for-each2
(begin
'compiler-hint:cross-module-inline
(let ([for-each
(case-lambda
[(f l)
@ -65,9 +69,11 @@
(loop (cdr l1) (cdr l2)))]))
(for-each f l1 l2))]
[(f . args) (apply for-each f args)])])
for-each))
for-each)))
(define andmap2
(begin
'compiler-hint:cross-module-inline
(let ([andmap
(case-lambda
[(f l)
@ -96,9 +102,11 @@
(loop (cdr l1) (cdr l2)))])))
(andmap f l1 l2))]
[(f . args) (apply andmap f args)])])
andmap))
andmap)))
(define ormap2
(begin
'compiler-hint:cross-module-inline
(let ([ormap
(case-lambda
[(f l)
@ -127,4 +135,4 @@
(loop (cdr l1) (cdr l2)))])))
(ormap f l1 l2))]
[(f . args) (apply ormap f args)])])
ormap)))
ormap))))

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

@ -110,9 +110,11 @@ disables the @tech{JIT} compiler's assumptions about module
definitions when interactive exploration is more important. See
@secref["module-set"] for more information.
Currently, the compiler does not attempt to inline or propagate
constants across module boundaries, except for exports of the built-in
modules (such as the one that originally provides @racket[+]).
The compiler may inline functions or propagate constants across module
boundaries. To avoid generating too much code in the case of function
inlining, the compiler is conservative when choosing candidates for
cross-module inlining; see @secref["func-call-performance"] for
information on providing inlining hints to the compiler.
The later section @secref["letrec-performance"] provides some
additional caveats concerning inlining of module bindings.
@ -152,6 +154,25 @@ therefore permit call optimizations, so
within a module would perform the same as the @racket[letrec] version.
For direct calls to functions with keyword arguments, the compiler can
typically check keyword arguments statically and generate a direct
call to a non-keyword variant of the function, which reduces the
run-time overhead of keyword checking. This optimization applies only
for keyword-accepting procedures that are bound with @racket[define].
For immediate calls to functions that are small enough, the compiler
may inline the function call by replacing the call with the body of
the function. In addition to the size of the target function's body,
the compiler's heuristics take into account the amount of inlining
already performed at the call site and whether the called function
itself calls functions other than simple primitive operations. When a
module is compiled, some functions defined at the module level are
determined to be candidates for inlining into other modules; normally,
only trivial functions are considered candidates for cross-module
inlining, but a programmer can use the pattern @racket[(define _id
(begin @#,indexed-racket['compiler-hint:cross-module-inline]
_proc-expr))] to encourage the compiler to inline larger functions.
Primitive operations like @racket[pair?], @racket[car], and
@racket[cdr] are inlined at the machine-code level by the @tech{JIT}
compiler. See also the later section @secref["fixnums+flonums"] for

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

@ -1372,6 +1372,41 @@
(require racket/bool)
(list #t)))
(test-comp `(module m racket/base
(require racket/list)
empty?
(empty? 10))
`(module m racket/base
(require racket/list)
empty? ; so that it counts as imported
(null? 10)))
(module check-inline-request racket/base
(provide loop)
(define loop
(begin
'compiler-hint:cross-module-inline
;; large enough that the compiler wouldn't infer inlining:
(lambda (f n)
(let loop ([i n])
(if (zero? i)
10
(cons (f i) (loop (sub1 n)))))))))
(test-comp `(module m racket/base
(require 'check-inline-request)
loop
(loop list 1)) ; 1 is small enough to fully unroll
`(module m racket/base
(require 'check-inline-request)
loop ; so that it counts as imported
(let ([f list]
[n 1])
(let loop ([i n])
(if (zero? i)
10
(cons (f i) (loop (sub1 n))))))))
;; check omit & reorder possibilities for unsafe
;; operations on mutable values:
(let ()

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,5 +1,6 @@
Version 5.2.0.5
Cross-module inlining of trivial functions
Cross-module inlining of trivial functions, plus map, for-each,
andmap, and ormap; 'compiler-hint:cross-module-inline hint
compiler/zo-structs: added inline-variant
Version 5.2.0.4

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

@ -2780,7 +2780,7 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
} else {
Scheme_Object *body;
body = compile_block(forms, env, rec, drec);
return scheme_make_sequence_compilation(body, 1);
return scheme_make_sequence_compilation(body, 2);
}
}
@ -2852,7 +2852,7 @@ do_begin_syntax(char *name,
body = scheme_compile_list(forms, env, rec, drec);
}
forms = scheme_make_sequence_compilation(body, zero ? -1 : 1);
forms = scheme_make_sequence_compilation(body, zero ? -1 : 2);
if (!zero
&& SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type)
@ -2883,6 +2883,15 @@ Scheme_Sequence *scheme_malloc_sequence(int count)
* sizeof(Scheme_Object *));
}
static int scheme_is_compiler_hint(Scheme_Object *v, int opt)
{
/* Yes, this is a hack! */
return ((opt == 2)
&& SCHEME_SYMBOLP(v)
&& !scheme_strncmp(SCHEME_SYM_VAL(v), "compiler-hint:", 14));
}
Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
{
/* We have to be defensive in processing `seq'; it might be bad due
@ -2911,7 +2920,8 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
total++;
} else if (opt
&& (((opt > 0) && !last) || ((opt < 0) && !first))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) {
&& scheme_omittable_expr(v, -1, -1, 0, NULL, -1)
&& !scheme_is_compiler_hint(v, opt)) {
/* A value that is not the result. We'll drop it. */
total++;
} else {
@ -2971,7 +2981,8 @@ Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt)
} else if (opt
&& (((opt > 0) && (k < total))
|| ((opt < 0) && k))
&& scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) {
&& scheme_omittable_expr(v, -1, -1, 0, NULL, -1)
&& !scheme_is_compiler_hint(v, opt)) {
/* Value not the result. Do nothing. */
} else
o->array[i++] = v;

2
src/racket/src/mzmark_resolve.inc
View File

@ -56,6 +56,7 @@ static int mark_unresolve_info_MARK(void *p, struct NewGC *gc) {
gcMARK2(i->flags, gc);
gcMARK2(i->depths, gc);
gcMARK2(i->prefix, gc);
gcMARK2(i->closures, gc);
return
gcBYTES_TO_WORDS(sizeof(Unresolve_Info));
@ -67,6 +68,7 @@ static int mark_unresolve_info_FIXUP(void *p, struct NewGC *gc) {
gcFIXUP2(i->flags, gc);
gcFIXUP2(i->depths, gc);
gcFIXUP2(i->prefix, gc);
gcFIXUP2(i->closures, gc);
return
gcBYTES_TO_WORDS(sizeof(Unresolve_Info));

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

@ -1240,6 +1240,7 @@ mark_unresolve_info {
gcMARK2(i->flags, gc);
gcMARK2(i->depths, gc);
gcMARK2(i->prefix, gc);
gcMARK2(i->closures, gc);
size:
gcBYTES_TO_WORDS(sizeof(Unresolve_Info));

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

@ -904,6 +904,23 @@ static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data,
return p;
}
int scheme_check_leaf_rator(Scheme_Object *le, int *_flags)
{
if (le && SCHEME_PRIMP(le)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_NONCM) {
if (_flags)
*_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT);
if (opt >= SCHEME_PRIM_OPT_IMMEDIATE) {
return 1;
}
}
}
return 0;
}
#if 0
# define LOG_INLINE(x) x
#else
@ -964,8 +981,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
iv = scheme_hash_get(info->cp->inline_variants, scheme_make_integer(pos));
if (iv) {
if (SAME_TYPE(SCHEME_TYPE(iv), scheme_inline_variant_type)) {
iv = scheme_unresolve(iv);
// printf("un: %p\n", iv);
iv = scheme_unresolve(iv, argc);
scheme_hash_set(info->cp->inline_variants, scheme_make_integer(pos), iv);
}
if (iv) {
@ -1083,16 +1099,8 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
}
}
if (le && SCHEME_PRIMP(le)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_OPT_MASK;
if (opt >= SCHEME_PRIM_OPT_NONCM) {
*_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT);
if (opt >= SCHEME_PRIM_OPT_IMMEDIATE) {
if (scheme_check_leaf_rator(le, _flags))
nonleaf = 0;
}
}
}
if (le && SCHEME_PROCP(le) && (app || app2 || app3)) {
Scheme_Object *a[1];
@ -4577,16 +4585,53 @@ static int set_code_closure_flags(Scheme_Object *clones,
return flags;
}
static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimize_Info *info)
static Scheme_Object *is_cross_module_inline_candidiate(Scheme_Object *e, Optimize_Info *info,
int size_override)
{
if (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_unclosed_procedure_type)) {
if (compiled_proc_body_size(e, 1) < CROSS_MODULE_INLINE_SIZE)
if (IS_COMPILED_PROC(e)) {
if (size_override || (compiled_proc_body_size(e, 1) < CROSS_MODULE_INLINE_SIZE))
return scheme_optimize_clone(0, e, info, 0, 0);
}
return NULL;
}
static int is_general_compiled_proc(Scheme_Object *e)
{
/* recognize (begin <omitable>* <proc>) */
if (SCHEME_TYPE(e) == scheme_sequence_type) {
Scheme_Sequence *seq = (Scheme_Sequence *)e;
if (seq->count > 0) {
int i;
for (i = seq->count - 1; i--; ) {
if (!scheme_omittable_expr(seq->array[i], -1, 20, 0, NULL, -1))
return 0;
}
}
e = seq->array[seq->count - 1];
}
/* recognize (let ([x <proc>]) x) */
if (SCHEME_TYPE(e) == scheme_compiled_let_void_type) {
Scheme_Let_Header *lh = (Scheme_Let_Header *)e;
if (!(SCHEME_LET_FLAGS(lh) & SCHEME_LET_RECURSIVE)
&& (lh->count == 1)
&& (lh->num_clauses == 1)
&& SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) {
Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body;
if (IS_COMPILED_PROC(lv->value)) {
if (SAME_TYPE(SCHEME_TYPE(lv->body), scheme_local_type))
return (SCHEME_LOCAL_POS(lv->body) == 0);
}
}
}
if (IS_COMPILED_PROC(e))
return 1;
return 0;
}
static Scheme_Object *
module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
{
@ -4594,7 +4639,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
Scheme_Object *e, *vars, *old_context;
int start_simltaneous = 0, i_m, cnt;
Scheme_Object *cl_first = NULL, *cl_last = NULL;
Scheme_Hash_Table *consts = NULL, *fixed_table = NULL, *re_consts = NULL, *originals = NULL;
Scheme_Hash_Table *consts = NULL, *fixed_table = NULL, *re_consts = NULL;
Scheme_Hash_Table *originals = NULL, *size_overrides = NULL;
int cont, next_pos_ready = -1, inline_fuel, is_proc_def;
Comp_Prefix *prev_cp;
@ -4651,13 +4697,31 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
/* Optimize this expression: */
e = SCHEME_VEC_ELS(m->bodies[0])[i_m];
/* detect (define-values ... (begin 'compiler-hint:cross-module-inline <proc>)) */
if (info->enforce_const
&& SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
Scheme_Object *e2;
e2 = SCHEME_VEC_ELS(e)[1];
if (SAME_TYPE(SCHEME_TYPE(e2), scheme_sequence_type)) {
Scheme_Sequence *seq = (Scheme_Sequence *)e2;
if (seq->count == 2) {
if (SCHEME_SYMBOLP(seq->array[0])
&& !SCHEME_SYM_WEIRDP(seq->array[0])
&& !strcmp(SCHEME_SYM_VAL(seq->array[0]), "compiler-hint:cross-module-inline")) {
if (!size_overrides)
size_overrides = scheme_make_hash_table(SCHEME_hash_ptr);
scheme_hash_set(size_overrides, scheme_make_integer(i_m), scheme_true);
}
}
}
}
is_proc_def = 0;
if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) {
if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
Scheme_Object *e2;
e2 = (Scheme_Object *)e;
e2 = SCHEME_VEC_ELS(e2)[1];
if (IS_COMPILED_PROC(e2))
e2 = SCHEME_VEC_ELS(e)[1];
if (is_general_compiled_proc(e2))
is_proc_def = 1;
}
}
@ -4901,20 +4965,29 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
/* For functions that are potentially inlineable, perhaps
before optimization, insert inline_variant records: */
if (info->enforce_const) {
for (i_m = 0; i_m < cnt; i_m++) {
/* Optimize this expression: */
e = SCHEME_VEC_ELS(m->bodies[0])[i_m];
if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) {
vars = SCHEME_VEC_ELS(e)[0];
if (SCHEME_PAIRP(vars) && SCHEME_NULLP(SCHEME_CDR(vars))) {
Scheme_Object *sub_e, *alt_e;
sub_e = SCHEME_VEC_ELS(e)[1];
if (IS_COMPILED_PROC(sub_e)) {
alt_e = is_cross_module_inline_candidiate(sub_e, info);
alt_e = is_cross_module_inline_candidiate(sub_e, info, 0);
alt_e = NULL;
if (!alt_e && originals) {
alt_e = scheme_hash_get(originals, scheme_make_integer(i_m));
if (SAME_OBJ(alt_e, sub_e))
if (SAME_OBJ(alt_e, sub_e) && !size_overrides)
alt_e = NULL;
else if (alt_e)
alt_e = is_cross_module_inline_candidiate(alt_e, info);
else if (alt_e) {
int size_override;
if (size_overrides && scheme_hash_get(size_overrides, scheme_make_integer(i_m)))
size_override = 1;
else
size_override = 0;
alt_e = is_cross_module_inline_candidiate(alt_e, info, size_override);
}
}
if (alt_e) {
Scheme_Object *iv;
@ -4927,6 +5000,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info, int context)
}
}
}
}
/* Check one more time for expressions that we can omit: */
{

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

@ -40,7 +40,7 @@
struct Resolve_Info
{
MZTAG_IF_REQUIRED
char use_jit, in_module, in_proc, enforce_const;
char use_jit, in_module, in_proc, enforce_const, no_lift;
int size, oldsize, count, pos;
int max_let_depth; /* filled in by sub-expressions */
Resolve_Prefix *prefix;
@ -626,13 +626,20 @@ static Scheme_Object *
inline_variant_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
Scheme_Object *a;
char no_lift;
a = SCHEME_VEC_ELS(data)[0];
a = scheme_resolve_expr(a, rslv);
SCHEME_VEC_ELS(data)[0] = a;
/* Don't lift closures in the inline variant, since that
just creates lifted bindings and closure cycles that we
don't want to deal with when inlining. */
a = SCHEME_VEC_ELS(data)[1];
no_lift = rslv->no_lift;
rslv->no_lift = 1;
a = scheme_resolve_expr(a, rslv);
rslv->no_lift = no_lift;
SCHEME_VEC_ELS(data)[1] = a;
return data;
@ -1252,7 +1259,9 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
Then fall back to assuming no lifts. */
linfo = 0;
for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply) ? 0 : 2); resolve_phase < 3; resolve_phase++) {
for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply && !info->no_lift) ? 0 : 2);
resolve_phase < 3;
resolve_phase++) {
/* Don't try plain lifting if we're not inside a proc: */
if ((resolve_phase == 1) && !resolve_is_inside_proc(info))
@ -2584,6 +2593,7 @@ static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int oldsi
naya->pos = 0;
naya->toplevel_pos = -1;
naya->lifts = info->lifts;
naya->no_lift = info->no_lift;
if (mapc) {
int i, *ia;
@ -3005,6 +3015,12 @@ static int resolving_in_procedure(Resolve_Info *info)
/* uresolve */
/*========================================================================*/
#if 0
# define return_NULL return (printf("%d\n", __LINE__), NULL)
#else
# define return_NULL return NULL
#endif
typedef struct Unresolve_Info {
MZTAG_IF_REQUIRED
int stack_pos; /* stack in resolved coordinates */
@ -3013,10 +3029,11 @@ typedef struct Unresolve_Info {
int *flags;
mzshort *depths;
Scheme_Prefix *prefix;
int fail_after_all;
Scheme_Hash_Table *closures; /* handle cycles */
int has_non_leaf, body_size;
} Unresolve_Info;
static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui);
static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int as_rator);
static Unresolve_Info *new_unresolve_info(Scheme_Prefix *prefix)
{
@ -3080,15 +3097,48 @@ static int *unresolve_stack_pop(Unresolve_Info *ui, int pos, int n)
return f;
}
XFORM_NONGCING static int combine_flags(int a, int b)
{
int ac, bc;
/* We don't currently try to support SCHEME_WAS_APPLIED_EXCEPT_ONCE,
since that's to detect ((letrec ([f ....]) f) ....) patterns
that would have been converted away already for code to inline
across a module boundary. We do need to track SCHEME_WAS_ONLY_APPLIED,
so that the resolver can ultimately lift expressions. */
if ((b & SCHEME_WAS_ONLY_APPLIED) && !(a & SCHEME_WAS_ONLY_APPLIED)) {
bc = b;
b = a;
a = bc;
}
if (a & SCHEME_WAS_ONLY_APPLIED) {
if ((b & SCHEME_WAS_USED) && !(b & SCHEME_WAS_ONLY_APPLIED))
a -= SCHEME_WAS_ONLY_APPLIED;
}
ac = (a & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT;
bc = (b & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT;
ac += bc;
if (ac > SCHEME_USE_COUNT_INF)
ac = SCHEME_USE_COUNT_INF;
a |= b;
a = (a - (a & SCHEME_USE_COUNT_MASK)) | (ac << SCHEME_USE_COUNT_SHIFT);
return a;
}
static int unresolve_set_flag(Unresolve_Info *ui, int pos, int flag)
{
int i = ui->stack_pos - pos - 1;
int old_flag, i = ui->stack_pos - pos - 1;
if (pos >= ui->stack_pos) scheme_signal_error("internal error: unresolve too far");
flag |= ui->flags[i];
if (((flag & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT) < SCHEME_USE_COUNT_INF)
flag += (1 << SCHEME_USE_COUNT_SHIFT);
old_flag = ui->flags[i];
flag = combine_flags(flag | (1 << SCHEME_USE_COUNT_SHIFT), old_flag);
ui->flags[i] = flag;
return ui->depth - ui->depths[i] - 1;
@ -3099,12 +3149,16 @@ Scheme_Object *unresolve_closure(Scheme_Closure_Data *rdata, Unresolve_Info *ui)
Scheme_Closure_Data *data;
Scheme_Object *body;
Closure_Info *cl;
int pos, data_pos, *flags;
int i, pos, data_pos, *flags, init_size, has_non_leaf;
scheme_delay_load_closure(rdata);
if (rdata->closure_size)
return 0; /* won't work, yet */
if (rdata->closure_size) {
for (i = rdata->closure_size; i--; ) {
if (rdata->closure_map[i] > ui->stack_pos)
return_NULL; /* needs something (perhaps prefix) beyond known stack */
}
}
data = MALLOC_ONE_TAGGED(Scheme_Closure_Data);
@ -3118,11 +3172,22 @@ Scheme_Object *unresolve_closure(Scheme_Closure_Data *rdata, Unresolve_Info *ui)
pos = unresolve_stack_push(ui, data->num_params, 0);
if (rdata->closure_size)
data_pos = unresolve_stack_push(ui, data->closure_size, 0);
if (rdata->closure_size) {
data_pos = unresolve_stack_push(ui, rdata->closure_size, 1);
/* remap closure slots: */
for (i = rdata->closure_size; i--; ) {
int mp;
mp = ui->depths[pos - rdata->closure_map[i] - 1];
ui->depths[ui->stack_pos - i - 1] = mp;
}
}
body = unresolve_expr(rdata->code, ui);
if (!body) return NULL;
init_size = ui->body_size;
has_non_leaf = ui->has_non_leaf;
ui->has_non_leaf = 0;
body = unresolve_expr(rdata->code, ui, 0);
if (!body) return_NULL;
data->code = body;
@ -3130,8 +3195,22 @@ Scheme_Object *unresolve_closure(Scheme_Closure_Data *rdata, Unresolve_Info *ui)
SET_REQUIRED_TAG(cl->type = scheme_rt_closure_info);
data->closure_map = (mzshort *)cl;
if (rdata->closure_size)
cl->body_size = (ui->body_size - init_size);
cl->has_nonleaf = ui->has_non_leaf;
ui->has_non_leaf = has_non_leaf;
if (rdata->closure_size) {
/* copy flags from unpacked closure to original slots */
for (i = rdata->closure_size; i--; ) {
int a, b;
a = ui->flags[pos - rdata->closure_map[i] - 1];
b = ui->flags[ui->stack_pos - i - 1];
a = combine_flags(a, b);
ui->flags[pos - rdata->closure_map[i] - 1] = a;
}
(void)unresolve_stack_pop(ui, data_pos, 0);
}
flags = unresolve_stack_pop(ui, pos, data->num_params);
cl->local_flags = flags;
@ -3148,11 +3227,17 @@ static Scheme_Object *unresolve_expr_k(void)
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
return unresolve_expr(e, ui);
return unresolve_expr(e, ui, p->ku.k.i1);
}
static void check_nonleaf_rator(Scheme_Object *rator, Unresolve_Info *ui)
{
if (!scheme_check_leaf_rator(rator, NULL))
ui->has_non_leaf = 1;
}
static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui, int as_rator)
{
#ifdef DO_STACK_CHECK
{
@ -3162,35 +3247,63 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
p->ku.k.p1 = (void *)e;
p->ku.k.p2 = (void *)ui;
p->ku.k.i1 = as_rator;
return scheme_handle_stack_overflow(unresolve_expr_k);
}
}
#endif
ui->body_size++;
switch (SCHEME_TYPE(e)) {
case scheme_local_type:
return scheme_make_local(scheme_local_type,
unresolve_set_flag(ui, SCHEME_LOCAL_POS(e), SCHEME_WAS_USED),
unresolve_set_flag(ui,
SCHEME_LOCAL_POS(e),
(SCHEME_WAS_USED
| (as_rator
? SCHEME_WAS_ONLY_APPLIED
: 0))),
0);
case scheme_local_unbox_type:
return scheme_make_local(scheme_local_type,
unresolve_set_flag(ui, SCHEME_LOCAL_POS(e),
(SCHEME_WAS_SET_BANGED | SCHEME_WAS_USED)),
0);
case scheme_sequence_type:
{
Scheme_Sequence *seq = (Scheme_Sequence *)e, *seq2;
int i;
seq2 = scheme_malloc_sequence(seq->count);
seq2->so.type = scheme_sequence_type;
seq2->count = seq->count;
for (i = seq->count; i--; ) {
e = unresolve_expr(seq->array[i], ui, 0);
if (!e) return_NULL;
seq2->array[i] = e;
}
return (Scheme_Object *)seq2;
}
break;
case scheme_application_type:
{
Scheme_App_Rec *app = (Scheme_App_Rec *)e, *app2;
Scheme_Object *a;
int pos, i;
ui->body_size += app->num_args;
check_nonleaf_rator(app->args[0], ui);
pos = unresolve_stack_push(ui, app->num_args, 1);
app2 = scheme_malloc_application(app->num_args+1);
for (i = app->num_args + 1; i--; ) {
a = unresolve_expr(app->args[i], ui);
if (!a) return NULL;
a = unresolve_expr(app->args[i], ui, !i);
if (!a) return_NULL;
app2->args[i] = a;
}
@ -3204,12 +3317,15 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
Scheme_Object *rator, *rand;
int pos;
ui->body_size += 1;
check_nonleaf_rator(app->rator, ui);
pos = unresolve_stack_push(ui, 1, 1);
rator = unresolve_expr(app->rator, ui);
if (!rator) return NULL;
rand = unresolve_expr(app->rand, ui);
if (!rand) return NULL;
rator = unresolve_expr(app->rator, ui, 1);
if (!rator) return_NULL;
rand = unresolve_expr(app->rand, ui, 0);
if (!rand) return_NULL;
(void)unresolve_stack_pop(ui, pos, 0);
@ -3226,14 +3342,17 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
Scheme_Object *rator, *rand1, *rand2;
int pos;
ui->body_size += 2;
check_nonleaf_rator(app->rator, ui);
pos = unresolve_stack_push(ui, 2, 1);
rator = unresolve_expr(app->rator, ui);
if (!rator) return NULL;
rand1 = unresolve_expr(app->rand1, ui);
if (!rand1) return NULL;
rand2 = unresolve_expr(app->rand2, ui);
if (!rand2) return NULL;
rator = unresolve_expr(app->rator, ui, 1);
if (!rator) return_NULL;
rand1 = unresolve_expr(app->rand1, ui, 0);
if (!rand1) return_NULL;
rand2 = unresolve_expr(app->rand2, ui, 0);
if (!rand2) return_NULL;
(void)unresolve_stack_pop(ui, pos, 0);
@ -3250,12 +3369,12 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)e, *b2;
Scheme_Object *tst, *thn, *els;
tst = unresolve_expr(b->test, ui);
if (!tst) return NULL;
thn = unresolve_expr(b->tbranch, ui);
if (!thn) return NULL;
els = unresolve_expr(b->fbranch, ui);
if (!els) return NULL;
tst = unresolve_expr(b->test, ui, 0);
if (!tst) return_NULL;
thn = unresolve_expr(b->tbranch, ui, 0);
if (!thn) return_NULL;
els = unresolve_expr(b->fbranch, ui, 0);
if (!els) return_NULL;
b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec);
b2->so.type = scheme_branch_type;
@ -3265,24 +3384,83 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
return (Scheme_Object *)b2;
}
case scheme_let_void_type:
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)e;
if (SAME_TYPE(SCHEME_TYPE(lv->body), scheme_letrec_type)) {
Scheme_Letrec *lr = (Scheme_Letrec *)lv->body;
if (lv->count == lr->count) {
Scheme_Let_Header *lh;
Scheme_Compiled_Let_Value *clv, *prev = NULL;
Scheme_Object *rhs, *body;
int i, pos, *all_flags, *flags;
lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
lh->iso.so.type = scheme_compiled_let_void_type;
lh->count = lv->count;
lh->num_clauses = lv->count;
SCHEME_LET_FLAGS(lh) += SCHEME_LET_RECURSIVE;
pos = unresolve_stack_push(ui, lv->count, 0);
for (i = lv->count; i--; ) {
rhs = unresolve_expr(lr->procs[i], ui, 0);
if (!rhs) return_NULL;
clv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
clv->iso.so.type = scheme_compiled_let_value_type;
clv->count = 1;
clv->position = i;
clv->value = rhs;
if (prev)
prev->body = (Scheme_Object *)clv;
else
lh->body = (Scheme_Object *)clv;
prev = clv;
}
body = unresolve_expr(lr->body, ui, 0);
if (!body) return_NULL;
if (prev)
prev->body = body;
else
lh->body = body;
all_flags = unresolve_stack_pop(ui, pos, lv->count);
clv = (Scheme_Compiled_Let_Value *)lh->body;
for (i = lv->count; i--; ) {
flags = (int *)scheme_malloc_atomic(sizeof(int));
flags[0] = all_flags[i];
clv->flags = flags;
clv = (Scheme_Compiled_Let_Value *)clv->body;
}
return (Scheme_Object *)lh;
}
}
return_NULL;
}
case scheme_let_one_type:
{
Scheme_Let_One *lo = (Scheme_Let_One *)e;
Scheme_Object *rhs, *body;
Scheme_Let_Header *lh;
Scheme_Compiled_Let_Value *lv;
Scheme_Compiled_Let_Value *clv;
int *flags, pos;
ui->fail_after_all = 1;
pos = unresolve_stack_push(ui, 1, 1 /* => pre-bind RHS */);
rhs = unresolve_expr(lo->value, ui);
if (!rhs) return NULL;
pos = unresolve_stack_push(ui, 1, 1 /* => post-bind RHS */);
rhs = unresolve_expr(lo->value, ui, 0);
if (!rhs) return_NULL;
(void)unresolve_stack_pop(ui, pos, 0);
pos = unresolve_stack_push(ui, 1, 0);
body = unresolve_expr(lo->body, ui);
if (!body) return NULL;
body = unresolve_expr(lo->body, ui, 0);
if (!body) return_NULL;
flags = unresolve_stack_pop(ui, pos, 1);
lh = MALLOC_ONE_TAGGED(Scheme_Let_Header);
@ -3290,49 +3468,96 @@ static Scheme_Object *unresolve_expr(Scheme_Object *e, Unresolve_Info *ui)
lh->count = 1;
lh->num_clauses = 1;
lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
lv->iso.so.type = scheme_compiled_let_value_type;
lv->count = 1;
lv->position = 0;
lv->value = rhs;
lv->flags = flags;
lv->body = body;
clv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value);
clv->iso.so.type = scheme_compiled_let_value_type;
clv->count = 1;
clv->position = 0;
clv->value = rhs;
clv->flags = flags;
clv->body = body;
lh->body = (Scheme_Object *)lv;
lh->body = (Scheme_Object *)clv;
return (Scheme_Object *)lh;
}
case scheme_closure_type:
{
Scheme_Object *r;
if (!ui->closures) {
Scheme_Hash_Table *ht;
ht = scheme_make_hash_table(SCHEME_hash_ptr);
ui->closures = ht;
}
if (scheme_hash_get(ui->closures, e))
return_NULL; /* can't handle cyclic closures */
scheme_hash_set(ui->closures, e, scheme_true);
r = unresolve_closure(SCHEME_COMPILED_CLOS_CODE(e), ui);
scheme_hash_set(ui->closures, e, NULL);
return r;
}
case scheme_unclosed_procedure_type:
{
return unresolve_closure((Scheme_Closure_Data *)e, ui);
}
default:
if (SCHEME_TYPE(e) > _scheme_values_types_) {
if (scheme_compiled_duplicate_ok(e, 1))
return e;
}
// printf("no %d\n", SCHEME_TYPE(e));
return NULL;
return_NULL;
}
}
Scheme_Object *scheme_unresolve(Scheme_Object *iv)
Scheme_Object *scheme_unresolve(Scheme_Object *iv, int argc)
{
Scheme_Object *o;
Scheme_Closure_Data *data = NULL;
o = SCHEME_VEC_ELS(iv)[1];
if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type)) {
o = (Scheme_Object *)((Scheme_Closure *)o)->code;
if (((Scheme_Closure_Data *)o)->closure_size)
return NULL;
if (SAME_TYPE(SCHEME_TYPE(o), scheme_closure_type))
data = ((Scheme_Closure *)o)->code;
else if (SAME_TYPE(SCHEME_TYPE(o), scheme_unclosed_procedure_type))
data = (Scheme_Closure_Data *)o;
else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_lambda_sequence_type)
|| SAME_TYPE(SCHEME_TYPE(o), scheme_case_closure_type)) {
Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)o;
int i, cnt;
cnt = seqin->count;
for (i = 0; i < cnt; i++) {
if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) {
/* An empty closure, created at compile time */
data = ((Scheme_Closure *)seqin->array[i])->code;
} else {
data = (Scheme_Closure_Data *)seqin->array[i];
}
if ((!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
&& (data->num_params == argc))
|| ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)
&& (data->num_params - 1 <= argc)))
break;
else
data = NULL;
}
} else
data = NULL;
if (!data)
return_NULL;
if (data->closure_size)
return_NULL;
if (SAME_TYPE(SCHEME_TYPE(o), scheme_unclosed_procedure_type)) {
/* convert an optimized & resolved closure back to compiled form: */
return unresolve_closure((Scheme_Closure_Data *)o,
return unresolve_closure(data,
new_unresolve_info((Scheme_Prefix *)SCHEME_VEC_ELS(iv)[2]));
}
return NULL;
}
/*========================================================================*/
/* precise GC traversers */
/*========================================================================*/

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

@ -2606,7 +2606,9 @@ Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e);
Scheme_Object *scheme_resolve_expr(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_resolve_list(Scheme_Object *, Resolve_Info *);
Scheme_Object *scheme_unresolve(Scheme_Object *);
Scheme_Object *scheme_unresolve(Scheme_Object *, int argv);
int scheme_check_leaf_rator(Scheme_Object *le, int *_flags);
int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be_liftable);