added basic letrec/letrec* handling (as in the one defined in R5RS)

scheme/ikarus.compiler.optimize-letrec.ss

@@ -2,6 +2,83 @@
 
 (module (debug-scc optimize-letrec)
 
+  (define (mark-assigned! lhs)
+    ;;; FIXME: this is very fragile
+    (unless (prelex-source-assigned? lhs) 
+      (set-prelex-source-assigned?! lhs 
+         (or (prelex-global-location lhs) #t))))
+  (define (optimize-letrec/basic x)
+    (define who 'optimize-letrec/basic)
+    (define (assign* lhs* rhs* body)
+      (let f ([lhs* lhs*] [rhs* rhs*])
+        (cond
+          [(null? lhs*) body]
+          [else 
+           (make-seq
+             (make-assign (car lhs*) (car rhs*))
+             (f (cdr lhs*) (cdr rhs*)))])))
+    (define (do-rec*bind lhs* rhs* body)
+      (for-each mark-assigned! lhs*)
+      (make-bind lhs* (map (lambda (x) (make-constant #f)) lhs*)
+        (assign* lhs* rhs* body)))
+    (define (do-recbind lhs* rhs* body)
+      (for-each mark-assigned! lhs*)
+      (let ([t* (map (lambda (x) 
+                       (let ([x (make-prelex (prelex-name x) (prelex-operand x))])
+                         (set-prelex-source-referenced?! x #t)
+                         x))
+                     lhs*)])
+        (make-bind lhs* (map (lambda (x) (make-constant #f)) lhs*)
+          (make-bind t* rhs*
+            (assign* lhs* t* body)))))
+    (define (L x)
+      (struct-case x
+        [(clambda g cls* cp free name)
+         (make-clambda g
+           (map (lambda (x)
+                  (struct-case x
+                    [(clambda-case info body)
+                     (make-clambda-case info (E body))]))
+                cls*)
+           cp free name)]))
+    (define (E x)
+      (struct-case x
+        [(constant) x]
+        [(prelex)
+         (assert (prelex-source-referenced? x))
+         x]
+        [(assign lhs rhs)
+         (assert (prelex-source-assigned? lhs))
+         (make-assign lhs (E rhs))]
+        [(primref) x]
+        [(bind lhs* rhs* body)
+         (if (null? lhs*)
+             (E body)
+             (make-bind lhs* (map E rhs*) (E body)))]
+        [(recbind lhs* rhs* body)
+         (if (null? lhs*)
+             (E body)
+             (do-recbind lhs* (map E rhs*) (E body)))]
+        [(rec*bind lhs* rhs* body)
+         (if (null? lhs*)
+             (E body)
+             (do-rec*bind lhs* (map E rhs*) (E body)))]
+        [(conditional e0 e1 e2)
+         (make-conditional (E e0) (E e1) (E e2))]
+        [(seq e0 e1) (make-seq (E e0) (E e1))]
+        [(clambda g cls* cp free name)
+         (L x)]
+        [(funcall rator rand*)
+         (make-funcall (E rator) (map E rand*))]
+        [(mvcall p c)
+         (make-mvcall (E p) (E c))]
+        [(forcall rator rand*) 
+         (make-forcall rator (map E rand*))]
+        [else (error who "invalid expression" (unparse x))]))
+    (E x))
+
+
+
   (define (optimize-letrec/scc x)
     (define who 'optimize-letrec/scc)
     (module (get-sccs-in-order)
@@ -257,5 +334,8 @@
 
   (define debug-scc (make-parameter #f))
 
+  (define current-letrec-pass 
+    (make-parameter optimize-letrec/scc))
+
   (define (optimize-letrec x)
-  (optimize-letrec/scc x)))
+    ((current-letrec-pass) x)))

scheme/last-revision

@@ -1 +1 @@
-1821
+1822