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

fix optimizer bug

Browse Source 
The lambda-lifting transformation needs to iterate to a fixpoint
where each lambda's added arguments and order are known. The
check for whether something changed was formerly just the number
of added arguments, but that's not good enough, because a binding
might get lifted away while another one acquires an extra argument.
The right test is to check the count and original bindings for the
added arguments.

Closes PR 12910
This commit is contained in:
Matthew Flatt 2012-07-15 10:30:18 -06:00
parent 9b51973b79
commit 73e901a262
2 changed files with 122 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2026,6 +2026,89 @@
(test -2200000.0 non-tail2)
(test-values '(-100001.0 100001.0) tail))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check for corect fixpoint calculation when lifting
;; This test is especilly fragile. It's a minimized(?) variant
;; of PR 12910, where just enbought `with-continuation-mark's
;; are needed to thwart inlining, and enough functions are
;; present in the right order to require enough fixpoint
;; iterations.
(define a-top-level-variable 5)
(define (do-test-of-lift-fixpoint)
(define-syntax-rule (wcm e) (with-continuation-mark a-top-level-variable 'e e))
(define (parse-string input-string)
(let* ((nextTokenIsReady #f)
(nextCharacter #\space)
(nextCharacterIsReady #f)
(count 0)
(input-index 0)
(input-length (string-length input-string)))
(define (scanner0)
(state0 (wcm (scanchar))))
(define (state0 c)
(if (eq? c #\()
(begin
(consumechar)
'lparen)
(if (eq? c #\,)
(wcm (state1 (scanchar)))
(void))))
(define (state1 c)
(wcm (consumechar)))
(define (parse-datum)
(let ([t (next-token)])
(if (eq? t 'lparen)
(parse-compound-datum)
(wcm (parse-simple-datum)))))
(define (parse-simple-datum)
(wcm (next-token)))
(define (parse-compound-datum)
(wcm
(begin
(consume-token!)
(parse-datum))))
(define (next-token)
(wcm (scanner0)))
(define (consume-token!)
(set! nextTokenIsReady #f))
(define (scanchar)
(when (= count 4) (error "looped correctly"))
(begin
(set! count (add1 count))
(if nextCharacterIsReady
nextCharacter
(begin
(if (< input-index input-length)
(set! nextCharacter
(wcm (string-ref input-string input-index)))
(set! nextCharacter #\~))
(set! nextCharacterIsReady #t)
(scanchar)))))
(define (consumechar)
(when (wcm (not nextCharacterIsReady))
(scanchar)))
(parse-datum)))
(set! parse-string parse-string)
(parse-string "()"))
(err/rt-test (do-test-of-lift-fixpoint) exn:fail?)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

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

@ -916,6 +916,18 @@ static int get_convert_arg_count(Scheme_Object *lift)
return 0;
}
static mzshort* get_convert_arg_map(Scheme_Object *lift)
{
if (!lift)
return NULL;
else if (SCHEME_RPAIRP(lift)) {
Scheme_Object **ca;
ca = (Scheme_Object **)SCHEME_CDR(lift);
return (mzshort *)ca[1];
} else
return NULL;
}
static Scheme_Object *drop_zero_value_return(Scheme_Object *expr)
{
if (SAME_TYPE(SCHEME_TYPE(expr), scheme_sequence_type)) {
@ -1349,9 +1361,11 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
&& is_nonconstant_procedure(clv->value, info, head->count)) {
Scheme_Object *lift, *old_lift;
int old_convert_count;
mzshort *old_convert_map, *convert_map;
old_lift = lifted_recs[rpos];
old_convert_count = get_convert_arg_count(old_lift);
old_convert_map = get_convert_arg_map(old_lift);
lift = resolve_closure_compilation(clv->value, val_linfo, 1, 1, 1,
(resolve_phase ? NULL : old_lift));
@ -1363,6 +1377,14 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
lifted_recs[rpos] = lift;
if (get_convert_arg_count(lift) != old_convert_count)
converted = 1;
else if (old_convert_map) {
int z;
convert_map = get_convert_arg_map(lift);
for (z = 0; z < old_convert_count; z++) {
if (old_convert_map[z] != convert_map[z])
converted = 1;
}
}
} else {
lifted_recs = NULL;
converted = 0;
@ -2008,7 +2030,7 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
evaluated immediately) to new locations (where closures
effectively shift and compact values on the stack).
We don't have to include bindings added because an oiriginal
We don't have to include bindings added because an original
binding was lifted (i.e., the extra bindings in `captured'),
because they don't appear in the body. Instead, they are
introduced directly in resolved form through the `lifted' info.
@ -2042,26 +2064,37 @@ resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info,
--sz;
cmap = MALLOC_N_ATOMIC(mzshort, sz);
for (j = 0; j < sz; j++) {
int is_boxed = 0, is_flonum = 0;
loc = SCHEME_VEC_ELS(vec)[j+1];
if (SCHEME_BOXP(loc)) {
if (!boxmap)
boxmap = allocate_boxmap(sz);
boxmap_set(boxmap, j, 1, 0);
loc = SCHEME_BOX_VAL(loc);
is_boxed = 1;
} else if (SCHEME_VECTORP(loc)) {
if (!boxmap)
boxmap = allocate_boxmap(sz);
boxmap_set(boxmap, j, 2, 0);
loc = SCHEME_VEC_ELS(loc)[0];
is_flonum = 1;
}
loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc)));
cp = SCHEME_INT_VAL(loc);
if (cp < 0) {
cp = -cp;
if (cp & 0x1)
if (cp & 0x1) {
cp = (cp - 1) / 2;
else
if (convert && !is_boxed)
scheme_signal_error("internal error: lift mismatch (boxed)");
} else {
cp = (cp - 2) / 2;
if (convert && !is_flonum)
scheme_signal_error("internal error: lift mismatch (flonum)");
}
} else {
if (convert && (is_boxed || is_flonum))
scheme_signal_error("internal error: lift mismatch");
}
cmap[j] = cp + (has_tl && convert ? 1 : 0);
}