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

svn: r12434

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 ....

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)
 

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))

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

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_Local *)clv->body)->position == 0)) {
-      Scheme_Type lhs;
+      if (worth_lifting(clv->value)) {
-      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 (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;
 }