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

fix letrec compilation when call/cc is used on the RHS of something that otherwise looks like it could be let*; add #%in annotations to decompiler output

Browse Source 
svn: r11329
This commit is contained in:
Matthew Flatt 2008-08-19 15:18:09 +00:00
parent ece880b3a2
commit ebab4270bf
4 changed files with 85 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/compiler/decompile.ss
View File

@ -237,10 +237,11 @@
[(struct application (rator rands))
(let ([stack (append (for/list ([i (in-list rands)]) (gensym 'rand))
stack)])
`(,(decompile-expr rator globs stack)
,@(map (lambda (rand)
(decompile-expr rand globs stack))
rands)))]
(annotate-inline
`(,(decompile-expr rator globs stack)
,@(map (lambda (rand)
(decompile-expr rand globs stack))
rands))))]
[(struct apply-values (proc args-expr))
`(#%apply-values ,(decompile-expr proc globs stack)
,(decompile-expr args-expr globs stack))]
@ -284,6 +285,28 @@
,(decompile-expr body globs (append captures
(append vars rest-vars)))))]))
(define (annotate-inline a)
(if (and (symbol? (car a))
(case (length a)
[(2) (memq (car a) '(not null? pair? mpair? symbol?
syntax? char? boolean?
number? real? exact-integer?
fixnum? inexact-real?
procedure? vector? box? string? bytes? eof-object?
zero? negative? exact-nonnegative-integer?
exact-positive-integer?
car cdr caar cadr cdar cddr
mcar mcdr unbox syntax-e
add1 sub1 - abs bitwise-not))]
[(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=?
+ - * / min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!))]))
(cons '#%in a)
a))
;; ----------------------------------------
#;

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

@ -32,8 +32,7 @@ Many forms in the decompiled code, such as @scheme[module],
variable will be defined before the access.
Uses of core primitives are shown without a leading @litchar{_}, and
they are never wrapped with @schemeidfont{#%checked}. Applications of
some primitives are inlined by the JIT compiler.}
they are never wrapped with @schemeidfont{#%checked}.}
@item{Local-variable access may be wrapped with
@schemeidfont{#%sfs-clear}, which indicates that the variable-stack
@ -70,6 +69,12 @@ Many forms in the decompiled code, such as @scheme[module],
it may even contain cyclic references to itself or other constant
closures.}
@item{Some applications of core primitives are annotated with
@schemeidfont{#%in}, which indicates that the JIT compiler will
inline the operation. (Inlining information is not part of the
bytecode, but is instead based on an enumeration of primitives that
the JIT is known to handle specially.)}
@item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to
@scheme[(call-with-values (lambda () _expr) _proc)], but the run-time
system avoids allocating a closure for @scheme[_expr].}

7
collects/tests/mzscheme/basic.ss
View File

@ -1827,6 +1827,13 @@
(void)))
count))
;; Letrec must allocate early, though:
(test #f 'letrec+call/cc
(letrec ((x (call-with-current-continuation list)))
(if (pair? x)
((car x) (lambda () x))
(pair? (x)))))
(arity-test call/cc 1 2)
(arity-test call/ec 1 1)
(err/rt-test (call/cc 4))

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

@ -2719,11 +2719,24 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
/* let, let-values, letrec, etc. */
/**********************************************************************/
static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
static int is_liftable_prim(Scheme_Object *v)
{
if (SCHEME_PRIMP(v)) {
if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK)
>= SCHEME_PRIM_OPT_IMMEDIATE)
return 1;
}
return 0;
}
static int is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator)
{
Scheme_Type t = SCHEME_TYPE(o);
switch (t) {
case scheme_compiled_unclosed_procedure_type:
return !as_rator;
case scheme_compiled_toplevel_type:
return 1;
case scheme_local_type:
@ -2733,9 +2746,9 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
case scheme_branch_type:
if (fuel) {
Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o;
if (is_liftable(b->test, bind_count, fuel - 1)
&& is_liftable(b->tbranch, bind_count, fuel - 1)
&& is_liftable(b->fbranch, bind_count, fuel - 1))
if (is_liftable(b->test, bind_count, fuel - 1, 0)
&& is_liftable(b->tbranch, bind_count, fuel - 1, as_rator)
&& is_liftable(b->fbranch, bind_count, fuel - 1, as_rator))
return 1;
}
break;
@ -2743,8 +2756,12 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
{
Scheme_App_Rec *app = (Scheme_App_Rec *)o;
int i;
if (!is_liftable_prim(app->args[0]))
return 0;
if (bind_count >= 0)
bind_count += app->num_args;
for (i = app->num_args + 1; i--; ) {
if (!is_liftable(app->args[i], bind_count + app->num_args, fuel - 1))
if (!is_liftable(app->args[i], bind_count, fuel - 1, 1))
return 0;
}
return 1;
@ -2752,16 +2769,24 @@ static int is_liftable(Scheme_Object *o, int bind_count, int fuel)
case scheme_application2_type:
{
Scheme_App2_Rec *app = (Scheme_App2_Rec *)o;
if (is_liftable(app->rator, bind_count + 1, fuel - 1)
&& is_liftable(app->rand, bind_count + 1, fuel - 1))
if (!is_liftable_prim(app->rator))
return 0;
if (bind_count >= 0)
bind_count += 1;
if (is_liftable(app->rator, bind_count, fuel - 1, 1)
&& is_liftable(app->rand, bind_count, fuel - 1, 1))
return 1;
}
case scheme_application3_type:
{
Scheme_App3_Rec *app = (Scheme_App3_Rec *)o;
if (is_liftable(app->rator, bind_count + 2, fuel - 1)
&& is_liftable(app->rand1, bind_count + 2, fuel - 1)
&& is_liftable(app->rand2, bind_count + 2, fuel - 1))
if (!is_liftable_prim(app->rator))
return 0;
if (bind_count >= 0)
bind_count += 2;
if (is_liftable(app->rator, bind_count, fuel - 1, 1)
&& is_liftable(app->rand1, bind_count, fuel - 1, 1)
&& is_liftable(app->rand2, bind_count, fuel - 1, 1))
return 1;
}
default:
@ -2915,6 +2940,11 @@ static int expr_size(Scheme_Object *o)
return 1;
}
static int might_invoke_call_cc(Scheme_Object *value)
{
return !is_liftable(value, -1, 10, 0);
}
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
{
@ -3010,7 +3040,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
if (is_rec && !not_simply_let_star) {
/* Keep track of whether we can simplify to let*: */
if (scheme_optimize_any_uses(rhs_info, pos, head->count))
if (might_invoke_call_cc(value)
|| scheme_optimize_any_uses(rhs_info, pos, head->count))
not_simply_let_star = 1;
}
@ -3103,7 +3134,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
&& !body_info->letrec_not_twice
&& ((i < 1)
|| (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1)
&& !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5)))) {
&& !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) {
if (did_set_value) {
/* Next RHS ends a reorderable sequence.
Re-optimize from retry_start to pre_body, inclusive.
@ -3420,7 +3451,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (is_proc)
is_lift = 0;
else
is_lift = is_liftable(clv->value, head->count, 5);
is_lift = is_liftable(clv->value, head->count, 5, 1);
if (!is_proc && !is_lift) {
recbox = 1;