loop detection in the house

* libguile/vm-i-scheme.c (vector-ref, vector-set): Sync registers if we
  call out to C.

* module/language/tree-il/compile-glil.scm (flatten-lambda): Add an
  extra argument, the self-label, which should be the gensym under which
  the procedure is bound in a <fix> expression.
  (flatten): If we see a call to a lexical ref to the self-label in a
  tail position, rename and goto instead of goto/args, which will tear
  down the frame -- or will, in the future. It's a primitive form of
  loop detection.

* module/language/tree-il/primitives.scm (zero?): Expand to (= x 0).

3 files changed, 54 insertions, 23 deletions

diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 675ec1a0a..0cace147d 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -315,7 +315,10 @@ VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
                   && i < SCM_I_VECTOR_LENGTH (vect)))
     RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
   else
-    RETURN (scm_vector_ref (vect, idx));
+    {
+      SYNC_REGISTER ();
+      RETURN (scm_vector_ref (vect, idx));
+    }
 }
 
 VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
@@ -329,7 +332,10 @@ VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
                   && i < SCM_I_VECTOR_LENGTH (vect)))
     SCM_I_VECTOR_WELTS (vect)[i] = val;
   else
-    scm_vector_set_x (vect, idx, val);
+    {
+      SYNC_REGISTER ();
+      scm_vector_set_x (vect, idx, val);
+    }
   NEXT;
 }
 
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 3d25dd181..7c2764236 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -66,7 +66,7 @@
 
     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
       (lambda ()
-        (values (flatten-lambda x allocation)
+        (values (flatten-lambda x #f allocation)
                 (and e (cons (car e) (cddr e)))
                 e)))))
 
@@ -177,7 +177,7 @@
     (proc emit-code)
     (reverse out)))
 
-(define (flatten-lambda x allocation)
+(define (flatten-lambda x self-label allocation)
   (receive (ids vars nargs nrest)
       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
                (oids '()) (ovars '()) (n 0))
@@ -193,6 +193,9 @@
        nargs nrest nlocs (lambda-meta x)
        (with-output-to-code
         (lambda (emit-code)
+          ;; emit label for self tail calls
+          (if self-label
+              (emit-code #f (make-glil-label self-label)))
           ;; write bindings and source debugging info
           (emit-bindings #f ids vars allocation x emit-code)
           (if (lambda-src x)
@@ -201,14 +204,14 @@
           (for-each
            (lambda (v)
              (pmatch (hashq-ref (hashq-ref allocation v) x)
-               ((#t #t . ,n)
-                (emit-code #f (make-glil-lexical #t #f 'ref n))
-                (emit-code #f (make-glil-lexical #t #t 'box n)))))
+                     ((#t #t . ,n)
+                      (emit-code #f (make-glil-lexical #t #f 'ref n))
+                      (emit-code #f (make-glil-lexical #t #t 'box n)))))
            vars)
           ;; and here, here, dear reader: we compile.
-          (flatten (lambda-body x) allocation x emit-code)))))))
+          (flatten (lambda-body x) allocation x self-label emit-code)))))))
 
-(define (flatten x allocation proc emit-code)
+(define (flatten x allocation self self-label emit-code)
   (define (emit-label label)
     (emit-code #f (make-glil-label label)))
   (define (emit-branch src inst label)
@@ -384,6 +387,25 @@
                  (error "bad primitive op: too many pushes"
                         op (instruction-pushes op))))))
         
+        ;; da capo al fine
+        ((and (lexical-ref? proc)
+              self-label (eq? (lexical-ref-gensym proc) self-label)
+              ;; self-call in tail position is a goto
+              (eq? context 'tail)
+              ;; make sure the arity is right
+              (list? (lambda-vars self))
+              (= (length args) (length (lambda-vars self))))
+         ;; evaluate new values
+         (for-each comp-push args)
+         ;; rename & goto
+         (for-each (lambda (sym)
+                     (pmatch (hashq-ref (hashq-ref allocation sym) self)
+                       ((#t ,boxed? . ,index)
+                        (emit-code #f (make-glil-lexical #t #f 'set index)))
+                       (,x (error "what" x))))
+                   (reverse (lambda-vars self)))
+         (emit-branch src 'br self-label))
+        
         (else
          (comp-push proc)
          (for-each comp-push args)
@@ -442,7 +464,7 @@
       ((<lexical-ref> src name gensym)
        (case context
          ((push vals tail)
-          (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+          (pmatch (hashq-ref (hashq-ref allocation gensym) self)
             ((,local? ,boxed? . ,index)
              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
             (,loc
@@ -452,7 +474,7 @@
       
       ((<lexical-set> src name gensym exp)
        (comp-push exp)
-       (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
+       (pmatch (hashq-ref (hashq-ref allocation gensym) self)
          ((,local? ,boxed? . ,index)
           (emit-code src (make-glil-lexical local? boxed? 'set index)))
          (,loc
@@ -510,7 +532,7 @@
        (let ((free-locs (cdr (hashq-ref allocation x))))
          (case context
            ((push vals tail)
-            (emit-code #f (flatten-lambda x allocation))
+            (emit-code #f (flatten-lambda x #f allocation))
             (if (not (null? free-locs))
                 (begin
                   (for-each
@@ -527,9 +549,9 @@
       
       ((<let> src names vars vals body)
        (for-each comp-push vals)
-       (emit-bindings src names vars allocation proc emit-code)
+       (emit-bindings src names vars allocation self emit-code)
        (for-each (lambda (v)
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #f . ,n)
                       (emit-code src (make-glil-lexical #t #f 'set n)))
                      ((#t #t . ,n)
@@ -541,15 +563,15 @@
 
       ((<letrec> src names vars vals body)
        (for-each (lambda (v)
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #t . ,n)
                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
                      (,loc (error "badness" x loc))))
                  vars)
        (for-each comp-push vals)
-       (emit-bindings src names vars allocation proc emit-code)
+       (emit-bindings src names vars allocation self emit-code)
        (for-each (lambda (v)
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #t . ,n)
                       (emit-code src (make-glil-lexical #t #t 'set n)))
                      (,loc (error "badness" x loc))))
@@ -563,20 +585,20 @@
        ;; set them to their local var slots first, then capture their
        ;; bindings, mutating them in place.
        (for-each (lambda (x v)
-                   (emit-code #f (flatten-lambda x allocation))
+                   (emit-code #f (flatten-lambda x v allocation))
                    (if (not (null? (cdr (hashq-ref allocation x))))
                        ;; But we do have to make-closure them first, so
                        ;; we are mutating fresh closures on the heap.
                        (begin
                          (emit-code #f (make-glil-const #f))
                          (emit-code #f (make-glil-call 'make-closure 2))))
-                   (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #f . ,n)
                       (emit-code src (make-glil-lexical #t #f 'set n)))
                      (,loc (error "badness" x loc))))
                  vals
                  vars)
-       (emit-bindings src names vars allocation proc emit-code)
+       (emit-bindings src names vars allocation self emit-code)
        ;; Now go back and fix up the bindings.
        (for-each
         (lambda (x v)
@@ -591,7 +613,7 @@
                        (else (error "what" x loc))))
                    free-locs)
                   (emit-code #f (make-glil-call 'vector (length free-locs)))
-                  (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                  (pmatch (hashq-ref (hashq-ref allocation v) self)
                     ((#t #f . ,n)
                      (emit-code #f (make-glil-lexical #t #f 'fix n)))
                     (,loc (error "badness" x loc)))))))
@@ -616,10 +638,10 @@
              (emit-code #f (make-glil-const 1))
              (emit-label MV)
              (emit-code src (make-glil-mv-bind
-                             (vars->bind-list names vars allocation proc)
+                             (vars->bind-list names vars allocation self)
                              rest?))
              (for-each (lambda (v)
-                         (pmatch (hashq-ref (hashq-ref allocation v) proc)
+                         (pmatch (hashq-ref (hashq-ref allocation v) self)
                            ((#t #f . ,n)
                             (emit-code src (make-glil-lexical #t #f 'set n)))
                            ((#t #t . ,n)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 24900c64d..955c7bf25 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -200,6 +200,9 @@
                             (cons `((src . ,(car in))
                                     ,(consequent (cadr in))) out)))))))
 
+(define-primitive-expander zero? (x)
+  (= x 0))
+
 (define-primitive-expander +
   () 0
   (x) x