diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index e541684f17..70a64f71c1 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -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 .... diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index ce0578b3a2..a19caea4ad 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -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) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index fb80fdf419..0ed2853c66 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -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)) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 0a7bb68e36..6e301a729f 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -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 diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 2077e1e0d6..f3819089de 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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) { @@ -2970,14 +2983,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (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)) { - 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_)) { + && (((Scheme_Local *)clv->body)->position == 0)) { + if (worth_lifting(clv->value)) { if (for_inline) { /* Just drop the inline-introduced let */ return scheme_optimize_expr(clv->value, info); @@ -3214,7 +3221,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline) body_info->letrec_not_twice = 1; value = scheme_optimize_expr(self_value, body_info); - + body_info->letrec_not_twice = 0; clv->value = value; @@ -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 ]) 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] ...) ) */ + 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; }