minor optimization to letrec

assemble.rkt

@@ -131,6 +131,8 @@ EOF
        empty]
       [(MakeCompiledProcedure? op)
        (list (MakeCompiledProcedure-label op))]
+      [(MakeCompiledProcedureShell? op)
+       (list (MakeCompiledProcedureShell-label op))]
       [(ApplyPrimitiveProcedure? op)
        empty]
       [(GetControlStackLabel? op)
@@ -389,6 +391,12 @@ EOF
                           ", ")
              (assemble-display-name (MakeCompiledProcedure-display-name op)))]
     
+    [(MakeCompiledProcedureShell? op)
+     (format "new Closure(~a, ~a, undefined, ~a)"
+             (MakeCompiledProcedureShell-label op)
+             (MakeCompiledProcedureShell-arity op)
+             (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
+    
     [(ApplyPrimitiveProcedure? op)
      (format "MACHINE.proc(MACHINE, ~a)"
              (ApplyPrimitiveProcedure-arity op))]

compile.rkt

@@ -321,13 +321,34 @@
                                     (Lam-closure-map exp)
                                     (Lam-name exp)))))))
 
+
+(: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
+;; Write out code for lambda expressions, minus the closure map.
+;; Assumption: all of the lambda bodies have already been written out at the top, in -compile.
+(define (compile-lambda-shell exp cenv target linkage) 
+  (end-with-linkage 
+   linkage
+   cenv
+   (make-instruction-sequence 
+    `(,(make-AssignPrimOpStatement 
+        target
+        (make-MakeCompiledProcedureShell (Lam-entry-label exp)
+                                         (Lam-num-parameters exp)
+                                         (Lam-name exp)))))))
+
+
 (: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence))
 ;; Compiles the body of the lambda in the appropriate environment.
 (define (compile-lambda-body exp cenv)
   (append-instruction-sequences
+   
    (make-instruction-sequence 
-    `(,(Lam-entry-label exp)
+    `(,(Lam-entry-label exp)))
-      ,(make-PerformStatement (make-InstallClosureValues!))))
+
+   (if (not (empty? (Lam-closure-map exp)))
+       (make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!))))
+       empty-instruction-sequence)
+   
    (compile (Lam-body exp)
             (append (map (lambda: ([d : Natural]) 
                                   (list-ref cenv d))
@@ -412,7 +433,9 @@
                                                      (make-EnvLexicalReference i #f)
                                                      'val))))])    
     (append-instruction-sequences
+     (if (not (empty? (App-operands exp)))
          (make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
+         empty-instruction-sequence)
      proc-code
      (juggle-operands operand-codes)
      (compile-general-procedure-call cenv 
@@ -550,15 +573,18 @@
        (end-with-linkage
         linkage
         cenv
+        (append-instruction-sequences
          (make-instruction-sequence 
           `(,(make-AssignPrimOpStatement 
               ;; Optimization: we put the result directly in the registers, or in
               ;; the appropriate spot on the stack.  This takes into account the popenviroment
               ;; that happens right afterwards.
               (adjust-target-depth target n)                     
-             (make-ApplyPrimitiveProcedure n))
+              (make-ApplyPrimitiveProcedure n))))
-           ,(make-PopEnvironment n 0))))
+         (if (not (= n 0))
-
+             (make-instruction-sequence
+              `(,(make-PopEnvironment n 0)))
+             empty-instruction-sequence)))
        after-call))))
 
 
@@ -729,7 +755,8 @@
 
 (: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-let-rec exp cenv target linkage)
-  (let*: ([extended-cenv : CompileTimeEnvironment (append (map (lambda: ([p : Lam])
+  (let*: ([extended-cenv : CompileTimeEnvironment
+                         (append (map (lambda: ([p : Lam])
                                                (extract-static-knowledge 
                                                 p
                                                 (append (build-list (length (LetRec-procs exp))
@@ -757,7 +784,7 @@
           (apply append-instruction-sequences
                  (map (lambda: ([lam : Lam]
                                 [i : Natural])
-                               (compile-lambda lam 
+                               (compile-lambda-shell lam 
                                                      extended-cenv
                                                      (make-EnvLexicalReference i #f) 
                                                      'next))

il-structs.rkt

@@ -117,6 +117,7 @@
 ;; The operators that return values, that are used in AssignPrimopStatement.
 (define-type PrimitiveOperator (U GetCompiledProcedureEntry
                                   MakeCompiledProcedure
+                                  MakeCompiledProcedureShell
                                   ApplyPrimitiveProcedure
 
                                   GetControlStackLabel
@@ -140,6 +141,14 @@
                                        [display-name : (U Symbol False)])
   #:transparent)
 
+;; Constructs a closure shell.  Like MakeCompiledProcedure, but doesn't
+;; bother with trying to capture the free variables.
+(define-struct: MakeCompiledProcedureShell ([label : Symbol]
+                                            [arity : Natural]
+                                            [display-name : (U Symbol False)])
+  #:transparent)
+
+
 ;; Applies the primitive procedure that's stored in the proc register, using
 ;; the arity number of values that are bound in the environment as arguments
 ;; to that primitive.

simulator.rkt

@@ -301,6 +301,12 @@
                                                  (MakeCompiledProcedure-closed-vals op))
                                             (MakeCompiledProcedure-display-name op)))]
 
+          [(MakeCompiledProcedureShell? op)
+           (target-updater! m (make-closure (MakeCompiledProcedureShell-label op)
+                                            (MakeCompiledProcedureShell-arity op)
+                                            '()
+                                            (MakeCompiledProcedureShell-display-name op)))]
+          
           [(ApplyPrimitiveProcedure? op)
            (let: ([prim : SlotValue (machine-proc m)]
                   [args : (Listof PrimitiveValue)

test-compiler.rkt

@@ -733,6 +733,26 @@
       
 
 
+
+
+
+(test '(letrec ([sum-iter (lambda (x acc)
+                               (if (= x 0)
+                                   acc
+                                   (let* ([y (sub1 x)]
+                                          [z (+ x acc)])
+                                     (sum-iter y z))))])
+            (sum-iter 300 0))
+        45150
+        #:stack-limit 10
+        #:control-limit 1)
+
+
+
+
+
+
+
 #;(test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt")))