in the middle of letrec

compile.rkt

@@ -77,7 +77,10 @@
           [(InstallValue? exp)
            (loop (InstallValue-body exp))]
           [(BoxEnv? exp)
-           '()])))
+           '()]
+          [(LetRec? exp)
+           (append (apply append (map loop (LetRec-procs exp)))
+                   (loop (LetRec-body exp)))])))
          
     
 
@@ -121,7 +124,9 @@
     [(InstallValue? exp)
      (compile-install-value exp cenv target linkage)]
     [(BoxEnv? exp)
-     (compile-box-environment-value exp cenv target linkage)]))
+     (compile-box-environment-value exp cenv target linkage)]
+    [(LetRec? exp)
+     (compile-let-rec exp cenv target linkage)]))
 
 
 
@@ -584,6 +589,56 @@
            after-let))))
 
 
+
+(: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence))
+(define (compile-let-rec exp cenv target linkage)
+  (let*: ([extended-cenv : CompileTimeEnvironment (append (map extract-static-knowledge
+                                                              (reverse (LetRec-procs exp)))
+                                                         cenv)]
+         [n : Natural (length (LetRec-procs exp))]
+         [after-body-code : Linkage (make-label 'afterBodyCode)]
+         [letrec-linkage : Linkage (cond
+                                     [(eq? linkage 'next)
+                                      'next]
+                                     [(eq? linkage 'return)
+                                      'return]
+                                     [(symbol? linkage)
+                                      after-body-code])])
+        (end-with-linkage
+         linkage
+         extended-cenv
+         (append-instruction-sequences
+          (make-instruction-sequence `(,(make-PushEnvironment n #f)))
+          
+          ;; Install each of the closure shells
+          (apply append-instruction-sequences
+                 (map (lambda: ([lam : Lam]
+                                [i : Natural])
+                               (compile-lambda lam 
+                                               extended-cenv
+                                               (make-EnvLexicalReference i #f) 
+                                               'next))
+                      (LetRec-procs exp)
+                      (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
+          
+          ;; Fix the closure maps of each
+          (apply append-instruction-sequences
+                 (map (lambda: ([lam : Lam]
+                                [i : Natural])
+                               (make-instruction-sequence 
+                                `(,(make-PerformStatement 
+                                    (make-FixClosureShellMap! i (Lam-closure-map lam))))))
+                               
+                      (LetRec-procs exp)
+                      (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
+          
+          ;; Compile the body
+          (compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage)
+          after-body-code
+          (make-instruction-sequence `(,(make-PopEnvironment n 0)))))))
+  
+
+
 (: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-install-value exp cenv target linkage)
   (compile (InstallValue-body exp)

expression-structs.rkt

@@ -11,6 +11,7 @@
                                Branch Lam Seq App
                                Let1 
                                LetVoid 
+                               LetRec
                                InstallValue
                                BoxEnv))
 
@@ -54,6 +55,10 @@
                          [boxes? : Boolean])
   #:transparent)
 
+(define-struct: LetRec ([procs : (Listof Lam)]
+                        [body : ExpressionCore])
+  #:transparent)
+
 (define-struct: InstallValue ([depth : Natural]
                               [body : ExpressionCore]
                               [box? : Boolean])

il-structs.rkt

@@ -199,6 +199,11 @@
 (define-struct: InstallClosureValues! ()
   #:transparent)
 
+(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
+                                     [depth : Natural] 
+                                     
+                                     [closed-vals : (Listof Natural)])
+  #:transparent)
 
 ;; Changes over the control located at the given argument from the structure in env[1]
 (define-struct: RestoreControl! ())
@@ -213,6 +218,7 @@
                                CheckClosureArity!
                                ExtendEnvironment/Prefix!
                                InstallClosureValues!
+                               FixClosureShellMap!
                                
                                RestoreEnvironment!
                                RestoreControl!))

parse.rkt

@@ -437,25 +437,40 @@
 
 ;; Letrec's currently doing a set! kind of thing.
 (define (parse-letrec exp cenv)
-  (let ([vars (let-variables exp)]
+  (let* ([vars (let-variables exp)]
-        [rhss (let-rhss exp)]
+         [rhss (let-rhss exp)]
-        [body (let-body exp)])
+         [body (let-body exp)]
+         [n (length vars)])
     (cond 
       [(= 0 (length vars))
        (parse `(begin ,@body) cenv)]
+      [(and (andmap lambda? rhss)
+            (empty? (list-intersection 
+                     vars
+                     (append (find-mutated-names body)
+                             (apply append (map find-mutated-names rhss))))))
+       (let ([new-cenv  (extend-lexical-environment/names cenv 
+                                                          (reverse vars)
+                                                          (build-list n (lambda (i) #f)))])
+         ;; Semantics: allocate a closure shell for each lambda form in procs.
+         ;; Install them in reverse order, so that the closure shell for the last element
+         ;; in procs is at stack position 0.
+         (make-LetRec (map (lambda (rhs) (parse rhs new-cenv))
+                           rhss)
+                      (parse `(begin ,@body) new-cenv)))]
       [else
-       (let ([new-cenv (extend-lexical-environment/boxed-names cenv vars)])
+       (let ([new-cenv  (extend-lexical-environment/boxed-names cenv (reverse vars))])
          (make-LetVoid (length vars)
                        (seq (append 
-                                  (map (lambda (var rhs index) 
+                             (map (lambda (var rhs index) 
-                                         (make-InstallValue index 
+                                    (make-InstallValue (- n 1 index)
-                                                            (parameterize ([current-defined-name var])
+                                                       (parameterize ([current-defined-name var])
-                                                              (parse rhs new-cenv))
+                                                         (parse rhs new-cenv))
-                                                            #t))
+                                                       #t))
-                                       vars
+                                  vars
-                                       rhss
+                                  rhss
-                                       (build-list (length rhss) (lambda (i) i)))
+                                  (build-list (length rhss) (lambda (i) i)))
-                                  (list (parse `(begin ,@body) new-cenv))))
+                             (list (parse `(begin ,@body) new-cenv))))
                        #t))])))
 
 

simulator-structs.rkt

@@ -77,7 +77,8 @@
                          [arity : Natural]
                          [vals : (Listof SlotValue)]
                          [display-name : (U Symbol False)])
-  #:transparent)
+  #:transparent
+  #:mutable)
 
 
 

simulator.rkt

@@ -232,6 +232,13 @@
                     (error 'step-perform "Procedure register doesn't hold a procedure: ~s"
                            a-proc)]))]
           
+          [(FixClosureShellMap!? op)
+           (let: ([a-closure-shell : closure (ensure-closure (env-ref m (FixClosureShellMap!-depth op)))])
+                 (set-closure-vals! a-closure-shell
+                                    (map (lambda: ([d : Natural]) (env-ref m d))
+                                         (FixClosureShellMap!-closed-vals op)))
+                 'ok)]
+          
           [(RestoreControl!? op)
            (set-machine-control! m (CapturedControl-frames (ensure-CapturedControl (env-ref m 0))))
            'ok]
@@ -385,6 +392,11 @@
       v
       (error 'ensure-closure)))
 
+(: ensure-closure (SlotValue -> closure))
+(define (ensure-closure v)
+  (if (closure? v)
+      v
+      (error 'ensure-closure)))
 
 
 (: ensure-symbol (Any -> Symbol))