"fix" <let>-bound lambda expressions too

* module/language/tree-il/compile-glil.scm (compile-glil): Compute
  warnings before optimizing, as unreferenced variables will be
  optimized out.

* libguile/_scm.h: Fix C99 comment.

* module/language/tree-il/fix-letrec.scm (partition-vars): Also analyze
  let-bound vars.
  (fix-letrec!): Fix a bug whereby a set! to an unreffed var would be
  called for value, not effect. Also "fix" <let>-bound lambda
  expressions -- really speeds up pmatch.

* test-suite/tests/tree-il.test ("lexical sets", "the or hack"): Update
  to take into account the new optimizations.

libguile/_scm.h

@@ -170,7 +170,7 @@
 /* The word size marker in objcode.  */
 #define SCM_OBJCODE_WORD_SIZE  SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
 
-// major and minor versions must be single characters
+/* Major and minor versions must be single characters. */
 #define SCM_OBJCODE_MAJOR_VERSION 0
 #define SCM_OBJCODE_MINOR_VERSION B
 #define SCM_OBJCODE_MAJOR_VERSION_STRING        \

module/language/tree-il/compile-glil.scm

@@ -53,16 +53,16 @@
     (or (and=> (memq #:warnings opts) cadr)
         '()))
 
-  (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+  ;; Go throught the warning passes.
-         (x (optimize! x e opts))
+  (for-each (lambda (kind)
-         (allocation (analyze-lexicals x)))
-
-    ;; Go throught the warning passes.
-    (for-each (lambda (kind)
                 (let ((warn (assoc-ref %warning-passes kind)))
                   (and (procedure? warn)
                        (warn x))))
-              warnings)
+            warnings)
+
+  (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
+         (x (optimize! x e opts))
+         (allocation (analyze-lexicals x)))
 
     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
       (lambda ()

module/language/tree-il/fix-letrec.scm

@@ -78,6 +78,13 @@
                                simple
                                lambda*
                                complex))
+                      ((<let> vars)
+                       (values (append vars unref)
+                               ref
+                               set
+                               simple
+                               lambda*
+                               complex))
                       (else
                        (values unref ref set simple lambda* complex))))
                   (lambda (x unref ref set simple lambda* complex)
@@ -108,6 +115,39 @@
                           (else
                            (lp (cdr vars) (cdr vals)
                                s l (cons (car vars) c))))))
+                      ((<let> (orig-vars vars) vals)
+                       ;; The point is to compile let-bound lambdas as
+                       ;; efficiently as we do letrec-bound lambdas, so
+                       ;; we use the same algorithm for analyzing the
+                       ;; vars. There is no problem recursing into the
+                       ;; bindings after the let, because all variables
+                       ;; have been renamed.
+                       (let lp ((vars orig-vars) (vals vals)
+                                (s '()) (l '()) (c '()))
+                         (cond
+                          ((null? vars)
+                           (values unref
+                                   ref
+                                   set
+                                   (append s simple)
+                                   (append l lambda*)
+                                   (append c complex)))
+                          ((memq (car vars) unref)
+                           (lp (cdr vars) (cdr vals)
+                               s l c))
+                          ((memq (car vars) set)
+                           (lp (cdr vars) (cdr vals)
+                               s l (cons (car vars) c)))
+                          ((and (lambda? (car vals))
+                                (not (memq (car vars) set)))
+                           (lp (cdr vars) (cdr vals)
+                               s (cons (car vars) l) c))
+                          ;; There is no difference between simple and
+                          ;; complex, for the purposes of let. Just lump
+                          ;; them all into complex.
+                          (else
+                           (lp (cdr vars) (cdr vals)
+                               s l (cons (car vars) c))))))
                       (else
                        (values unref ref set simple lambda* complex))))
                   '()
@@ -128,7 +168,7 @@
          ;; expression, called for effect.
          ((<lexical-set> gensym exp)
           (if (memq gensym unref)
-              (make-sequence #f (list (make-void #f) exp))
+              (make-sequence #f (list exp (make-void #f)))
               x))
 
          ((<letrec> src names vars vals body)
@@ -176,5 +216,25 @@
                        ;; Finally, the body.
                        body)))))))))
 
+         ((<let> src names vars vals body)
+          (let ((binds (map list vars names vals)))
+            (define (lookup set)
+              (map (lambda (v) (assq v binds))
+                   (lset-intersection eq? vars set)))
+            (let ((u (lookup unref))
+                  (l (lookup lambda*))
+                  (c (lookup complex)))
+              (make-sequence
+               src
+               (append
+                ;; unreferenced bindings, called for effect.
+                (map caddr u)
+                (list
+                 ;; unassigned lambdas use fix.
+                 (make-fix src (map cadr l) (map car l) (map caddr l)
+                           ;; and the "complex" bindings.
+                           (make-let src (map cadr c) (map car c) (map caddr c)
+                                     body))))))))
+         
          (else x)))
      x)))

test-suite/tests/tree-il.test

@@ -151,25 +151,33 @@
 
 (with-test-prefix "lexical sets"
   (assert-tree-il->glil
-   (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
+   ;; unreferenced sets may be optimized away -- make sure they are ref'd
+   (let (x) (y) ((const 1))
+        (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
    (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (lexical #t #t set 0) (void) (call return 1)
+            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
-            (unbind)))
+            (void) (call return 1)
-
-  (assert-tree-il->glil
-   (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
-   (program 0 0 1 ()
-            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (lexical #t #t set 0) (const #f) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
-     (apply (primitive null?) (set! (lexical x y) (const 2))))
+        (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+               (lexical x y)))
    (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
-            (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
+            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
+            (lexical #t #t ref 0) (call return 1)
+            (unbind)))
+
+  (assert-tree-il->glil
+   (let (x) (y) ((const 1))
+     (apply (primitive null?)
+            (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
+   (program 0 0 1 ()
+            (const 1) (bind (x #t 0)) (lexical #t #t box 0)
+            (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
+            (call null? 1) (call return 1)
             (unbind))))
 
 (with-test-prefix "module refs"
@@ -413,20 +421,19 @@
             (unbind))
    (eq? l1 l2))
 
+  ;; second bound var is unreferenced
   (assert-tree-il->glil/pmatch
    (let (x) (y) ((const 1))
         (if (lexical x y)
             (lexical x y)
             (let (a) (b) ((const 2))
                  (lexical x y))))
-   (program 0 0 2 ()
+   (program 0 0 1 ()
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (branch br-if-not ,l1)
             (lexical #t #f ref 0) (call return 1)
             (label ,l2)
-            (const 2) (bind (a #f 1)) (lexical #t #f set 1)
             (lexical #t #f ref 0) (call return 1)
-            (unbind)
             (unbind))
    (eq? l1 l2)))