SCC-letrec optimization is now online.

scheme/ikarus.compiler.ss

@@ -772,15 +772,17 @@
         (let ([sccs (compute-sccs! G)])
           (map (lambda (scc) (map node-data scc)) sccs)))))
   (define (gen-letrecs scc* ordered? body) 
-    (define (gen-letrec scc ordered? body)
+    (define (mkfix b* body)
+      (if (null? b*) 
+          body
+          (make-fix (map binding-lhs b*) 
+                    (map binding-rhs b*) 
+                    body)))
+    (define (gen-letrec scc fix* body)
       (define (mklet lhs* rhs* body)
         (if (null? lhs*) 
             body
             (make-bind lhs* rhs* body)))
-      (define (mkfix lhs* rhs* body)
-        (if (null? lhs*) 
-            body
-            (make-fix lhs* rhs* body)))
       (define (lambda-binding? x)
         (and (not (var-assigned (binding-lhs x)))
              (clambda? (binding-rhs x))))
@@ -801,33 +803,41 @@
          (let ([b (car scc)])
            (cond
              [(lambda-binding? b)
-              (mkfix (list (binding-lhs b))
-                     (list (binding-rhs b))
-                     body)]
+              (values (cons b fix*) body)]
              [(not (memq b (binding-free* b)))
+              (values '()
                 (mklet (list (binding-lhs b))
                        (list (binding-rhs b))
-                     body)]
+                  (mkfix fix* body)))]
              [else 
+              (values '()
                 (mklet (list (binding-lhs b)) 
                        (list (make-primcall 'void '()))
-                (mkset!s scc body))]))]
+                  (mkset!s scc 
+                    (mkfix fix* body))))]))]
         [else 
          (let-values ([(lambda* complex*) 
                        (partition lambda-binding? scc)])
+           (cond
+             [(null? complex*) 
+              (values (append lambda* fix*) body)]
+             [else
               (let ([complex* 
                      (if ordered? (sort-bindings complex*) complex*)])
+                (values '()
                   (mklet (map binding-lhs complex*)
                          (map (lambda (x) (make-primcall 'void '()))
                                complex*)
-                (mkfix (map binding-lhs lambda*)
-                       (map binding-rhs lambda*)
-                  (mkset!s complex* body)))))]))
+                     (mkfix (append lambda* fix*)
+                       (mkset!s complex* body)))))]))]))
+    (let-values ([(fix* body)
+                  (let f ([scc* scc*])
                     (cond
-      [(null? scc*) body]
+                      [(null? scc*) (values '() body)]
                       [else 
-       (gen-letrec (car scc*) ordered?
-         (gen-letrecs (cdr scc*) ordered? body))]))
+                       (let-values ([(fix* body) (f (cdr scc*))])
+                         (gen-letrec (car scc*) fix* body))]))])
+      (mkfix fix* body)))
   (define (do-recbind lhs* rhs* body bc ordered?)
     (define (make-bindings lhs* rhs* bc i)
       (cond
@@ -2859,7 +2869,7 @@
     [else 
      (printf "    ~s\n" x)]))
 
-(define scc-letrec (make-parameter #f))
+(define scc-letrec (make-parameter #t))
 
 (define (compile-core-expr->code p)
   (let* ([p (recordize p)]

scheme/ikarus.fasl.write.ss

@@ -33,26 +33,26 @@
   (module (wordsize)
     (include "ikarus.config.ss"))
 
-  (define-syntax fxshift 
-    (identifier-syntax
-      (case wordsize
-        [(4) 2]
-        [(8) 3]
-        [else (error 'fxshift "invalid wordsize" wordsize)])))
-
-  (define-syntax intbits (identifier-syntax (* wordsize 8)))
-
-  (define-syntax fxbits (identifier-syntax (- intbits fxshift)))
-
-  ;;;(define fxshift 
+  ;;; (define-syntax fxshift 
+  ;;;   (identifier-syntax
   ;;;     (case wordsize
   ;;;       [(4) 2]
   ;;;       [(8) 3]
-  ;;;    [else (error 'fxshift "invalid wordsize" wordsize)]))
+  ;;;       [else (error 'fxshift "invalid wordsize" wordsize)])))
 
-  ;;;(define intbits (* wordsize 8))
+  ;;; (define-syntax intbits (identifier-syntax (* wordsize 8)))
 
-  ;;;(define fxbits (- intbits fxshift))
+  ;;; (define-syntax fxbits (identifier-syntax (- intbits fxshift)))
+
+  (define fxshift 
+    (case wordsize
+      [(4) 2]
+      [(8) 3]
+      [else (error 'fxshift "invalid wordsize" wordsize)]))
+
+  (define intbits (* wordsize 8))
+
+  (define fxbits (- intbits fxshift))
 
   (define (fx? x)
     (and (or (fixnum? x) (bignum? x)) 

scheme/last-revision

@@ -1 +1 @@
-1374
+1375