* Simple thunks do not allocate now.

bin/ikarus-fasl.c

@@ -359,7 +359,6 @@ static ikp do_read(ikpcb* pcb, fasl_port* p){
     return rtd;
   }
   else if(c == 'Q'){ /* thunk */
-    fprintf(stderr, "THUNK\n");
     ikp proc = ik_alloc(pcb, align(disp_closure_data)) + closure_tag;
     if(put_mark_index){
       p->marks[put_mark_index] = proc;

lib/libcompile.ss

@@ -234,7 +234,6 @@
 (define-record clambda (cases))
 (define-record clambda-code (label cases free))
 (define-record closure (code free*))
-(define-record thunk (code))
 (define-record funcall (op rand*))
 (define-record appcall (op rand*))
 (define-record forcall (op rand*))
@@ -1104,8 +1103,6 @@
 
 
 
-;(define thunk-count 0)
-;(define total-count 0)
 (define (convert-closures prog)
   (define who 'convert-closures)
   (define (Expr* x*)
@@ -1139,10 +1136,6 @@
                                        cls*)
                                  (union (difference body-free fml*) 
                                         cls*-free)))])]))])
-          ;(set! total-count (fxadd1 total-count))
-          ;(when (null? free) 
-          ;  (set! thunk-count (fxadd1 thunk-count))
-          ;  (printf "EMPTY CLOSURE ~s/~s\n" thunk-count total-count))
           (values (make-closure (make-clambda-code (gensym) cls* free) free)
                   free))]))
   (define (Expr ex)
@@ -1613,6 +1606,9 @@
         (make-primcall 'void '()))
       body))
   (define (check-const n body)
+    (cond
+      [(fxzero? n) body]
+      [else
        (make-seq
          (make-conditional 
            (make-primcall '$ap-check-const
@@ -1620,8 +1616,9 @@
            (make-forcall "ik_collect" ;(make-primref 'do-overflow) 
                          (list (make-constant (fx+ n 4096))))
            (make-primcall 'void '()))
-      body))
+         body)]))
   (define (closure-size x)
+    #|FIXME: closures with free vars should not alloc|#
     (record-case x 
       [(closure code free*)
        (align (fx+ disp-closure-data (fx* (length free*) wordsize)))]
@@ -3245,6 +3242,14 @@
       [(code-loc label) (label-address label)]
       [(primref op) (primref-loc op)]
       [else (error 'Simple "what ~s" x)]))
+  (define (do-fix lhs* rhs* ac)
+    ;;; 1. first, set the code pointers in the right places
+    ;;; 2. next, for every variable appearing in the rhs* but is not in
+    ;;;    the lhs*, load it once and set it everywhere it occurs.
+    ;;; 3. next, compute the values of the lhs*, and for every computed
+    ;;;    value, store it on the stack, and set it everywhere it occurs
+    ;;;    in the rhs*
+    ;;; 4. that's it.
     (define (closure-size x)
       (align (fx+ disp-closure-data
                   (fx* wordsize (length (closure-free* x))))))
@@ -3305,19 +3310,50 @@
       (cond
         [(null? ls) ac]
         [else (sum (fx+ ac (car ls)) (cdr ls))]))
-  (define (do-fix lhs* rhs* ac)
+    (define partition
-    ;;; 1. first, set the code pointers in the right places
+      (lambda (lhs* rhs*)
-    ;;; 2. next, for every variable appearing in the rhs* but is not in
+        (let f ([lhs* lhs*] [rhs* rhs*] 
-    ;;;    the lhs*, load it once and set it everywhere it occurs.
+                [tlhs* '()] [trhs* '()]
-    ;;; 3. next, compute the values of the lhs*, and for every computed
+                [clhs* '()] [crhs* '()])
-    ;;;    value, store it on the stack, and set it everywhere it occurs
+          (cond
-    ;;;    in the rhs*
+            [(null? lhs*)
-    ;;; 4. that's it.
+             (values tlhs* trhs* clhs* crhs*)]
+            [(null? (closure-free* (car rhs*)))
+             (f (cdr lhs*) (cdr rhs*) 
+                (cons (car lhs*) tlhs*) (cons (car rhs*) trhs*)
+                clhs* crhs*)]
+            [else
+             (f (cdr lhs*) (cdr rhs*) 
+                tlhs* trhs*
+                (cons (car lhs*) clhs*) 
+                (cons (car rhs*) crhs*))]))))
+    (define do-closures
+      (lambda (lhs* rhs* ac)
         (let* ([n* (map closure-size rhs*)])
           (assign-codes rhs* n* 0
             (assign-nonrec-free* rhs* rhs* n* lhs*
               (assign-rec-free* lhs* rhs* n*
-            (cons (addl (int (sum 0 n*)) apr) ac))))))
+                (cons (addl (int (sum 0 n*)) apr) ac)))))))
+    (define do-thunks
+      (lambda (lhs* rhs* ac)
+        (cond
+          [(null? lhs*) ac]
+          [else
+           (do-thunks (cdr lhs*) (cdr rhs*)
+              (cons (movl (obj (car rhs*)) 
+                          (idx->frame-loc
+                            (frame-var-idx (car lhs*))))
+                    ac))])))
+    (let-values ([(tlhs* trhs* clhs* crhs*)
+                  (partition lhs* rhs*)])
+      (cond
+        [(null? clhs*)
+         (do-thunks tlhs* trhs* ac)]
+        [(null? tlhs*)
+         (do-closures clhs* crhs* ac)]
+        [else
+         (do-thunks tlhs* trhs* 
+           (do-closures clhs* crhs* ac))])))
   (define (frame-adjustment offset)
     (fx* (fxsub1 offset) (fx- 0 wordsize)))
   (define (NonTail x ac) 
@@ -3333,6 +3369,10 @@
       [(primref c)
        (cons (movl (primref-loc c) eax) ac)]
       [(closure label arg*)
+       (cond
+         [(null? arg*)
+          (cons (movl (obj x) eax) ac)]
+         [else
           (let f ([arg* arg*] [off disp-closure-data])
             (cond
               [(null? arg*)
@@ -3344,7 +3384,7 @@
               [else
                (list* (movl (Simple (car arg*)) eax)
                       (movl eax (mem off apr))
-                   (f (cdr arg*) (fx+ off wordsize)))]))]
+                      (f (cdr arg*) (fx+ off wordsize)))]))])]
       [(conditional test conseq altern)
        (let ([Lj (unique-label)] [Lf (unique-label)])
          (Pred test #f Lf
@@ -3895,8 +3935,10 @@
           ls*))
       (let ([code* (list*->code* 
                       (lambda (x)
-                       (if (thunk? x)
+                        (if (closure? x)
-                           (thunk-code x)
+                            (if (null? (closure-free* x))
+                                (code-loc-label (closure-code x))
+                                (error 'compile "BUG: non-thunk escaped: ~s" x))
                             #f))
                       ls*)])
         (car code*)))))