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

make the optimizer slightly smarter, so that it can see through more patterns of nested let and letrec procedure bindings

Browse Source 
svn: r12434
This commit is contained in:
Matthew Flatt 2008-11-14 00:48:54 +00:00
parent f4f559fc3b
commit 59f3f19f84
5 changed files with 91 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/decompile.ss
View File

@ -40,7 +40,7 @@
;; Main entry:
(define (decompile top)
(match top
[(struct compilation-top (_ prefix form))
[(struct compilation-top (max-let-depth prefix form))
(let-values ([(globs defns) (decompile-prefix prefix)])
`(begin
,@defns
@ -88,7 +88,7 @@
(define (decompile-module mod-form stack)
(match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body))
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(let-values ([(globs defns) (decompile-prefix prefix)]
[(stack) (append '(#%modvars) stack)])
`(module ,name ....

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

@ -23,7 +23,7 @@
;; In stxs of prefix:
(define-form-struct stx (encoded)) ; todo: decode syntax objects
(define-form-struct mod (name self-modidx prefix provides requires body syntax-body))
(define-form-struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(define-form-struct lam (name flags num-params rest? closure-map max-let-depth body)) ; `lambda'
(define-form-struct closure (code gen-id)) ; a static closure (nothing to close over)
@ -220,7 +220,8 @@
make-def-for-syntax
make-def-syntaxes)
ids expr prefix max-let-depth)]))
(vector->list syntax-body)))]))]))
(vector->list syntax-body))
max-let-depth)]))]))
(define (read-module-wrap v)
v)

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

@ -619,6 +619,14 @@
15)
15)
(test-comp '(letrec ((even
(let ([unused 6])
(let ([even (lambda (x) (if (zero? x) #t (even (sub1 x))))])
(values even)))))
(even 10000))
'(letrec ((even (lambda (x) (if (zero? x) #t (even (sub1 x))))))
(even 10000)))
(test-comp '(procedure? add1)
#t)
(test-comp '(procedure? (lambda (x) x))

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

@ -6,10 +6,10 @@ In scheme/port: added [call-]with-input-from-{string,bytes} and
Version 4.1.2.4
Added call-with-immediate-continuation-mark
In scheme/port: added port->string, port->bytes, port->lines
port->bytes-lines, and display-list
port->bytes-lines, and display-lines
In scheme/file: added file->string, file->bytes, file->lines,
file->value, file->bytes-lines, write-to-file, display-to-file,
and display-list-to-file
and display-lines-to-file
Version 4.1.2.3
Added variable-reference? and empty #%variable-reference form

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

@ -2953,6 +2953,19 @@ static int might_invoke_call_cc(Scheme_Object *value)
return !is_liftable(value, -1, 10, 0);
}
static int worth_lifting(Scheme_Object *v)
{
Scheme_Type lhs;
lhs = SCHEME_TYPE(v);
if ((lhs == scheme_compiled_unclosed_procedure_type)
|| (lhs == scheme_local_type)
|| (lhs == scheme_compiled_toplevel_type)
|| (lhs == scheme_compiled_quote_syntax_type)
|| (lhs > _scheme_compiled_values_types_))
return 1;
return 0;
}
Scheme_Object *
scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
{
@ -2971,13 +2984,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
&& (((Scheme_Local *)clv->body)->position == 0)) {
Scheme_Type lhs;
lhs = SCHEME_TYPE(clv->value);
if ((lhs == scheme_compiled_unclosed_procedure_type)
|| (lhs == scheme_local_type)
|| (lhs == scheme_compiled_toplevel_type)
|| (lhs == scheme_compiled_quote_syntax_type)
|| (lhs > _scheme_compiled_values_types_)) {
if (worth_lifting(clv->value)) {
if (for_inline) {
/* Just drop the inline-introduced let */
return scheme_optimize_expr(clv->value, info);
@ -3333,11 +3340,11 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
body = pre_body->body;
}
scheme_optimize_info_done(body_info);
/* Optimized away all clauses? */
if (!head->num_clauses)
if (!head->num_clauses) {
scheme_optimize_info_done(body_info);
return head->body;
}
if (is_rec && !not_simply_let_star) {
/* We can simplify letrec to let* */
@ -3345,6 +3352,63 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR;
}
{
int extract_depth = 0;
value = NULL;
/* Check again for (let ([x <proc>]) x). */
if (!is_rec && (head->count == 1) && (head->num_clauses == 1)) {
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
&& (((Scheme_Local *)clv->body)->position == 0)) {
if (worth_lifting(clv->value)) {
value = clv->value;
extract_depth = 1;
}
}
}
/* Check for (let ([unused #f] ...) <proc>) */
if (!value) {
if (head->count == head->num_clauses) {
body = head->body;
pos = 0;
for (i = head->num_clauses; i--; ) {
pre_body = (Scheme_Compiled_Let_Value *)body;
if ((pre_body->count != 1)
|| !SCHEME_FALSEP(pre_body->value)
|| (pre_body->flags[0] & SCHEME_WAS_USED))
break;
body = pre_body->body;
}
if (i < 0) {
if (worth_lifting(body)) {
value = body;
extract_depth = head->count;
rhs_info = body_info;
}
}
}
}
if (value) {
value = scheme_optimize_clone(1, value, rhs_info, 0, 0);
if (value) {
info = scheme_optimize_info_add_frame(info, extract_depth, 0, 0);
info->inline_fuel = 0;
value = scheme_optimize_expr(value, info);
info->next->single_result = info->single_result;
info->next->preserves_marks = info->preserves_marks;
scheme_optimize_info_done(info);
return value;
}
}
}
scheme_optimize_info_done(body_info);
return form;
}