Verify pass works on first-order CPS

* module/language/cps2/verify.scm: Work with first-order CPS.

module/language/cps2/verify.scm

@@ -128,75 +128,110 @@ definitions that are available at LABEL."
 
 (define (check-valid-var-uses conts kfun)
   (define (adjoin-def var defs) (intset-add defs var))
-  (let visit-fun ((kfun kfun) (free empty-intset))
+  (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset))
-    (define (visit-exp exp bound)
+    (define (visit-exp exp bound first-order)
       (define (check-use var)
         (unless (intset-ref bound var)
           (error "unbound var" var)))
+      (define (visit-first-order kfun)
+        (if (intset-ref first-order kfun)
+            first-order
+            (visit-fun kfun empty-intset (intset-add first-order kfun))))
       (match exp
-        ((or ($ $const) ($ $prim)) #t)
+        ((or ($ $const) ($ $prim)) first-order)
         ;; todo: $closure
         (($ $fun kfun)
-         (visit-fun kfun bound))
+         (visit-fun kfun bound first-order))
+        (($ $closure kfun)
+         (visit-first-order kfun))
         (($ $rec names vars (($ $fun kfuns) ...))
          (let ((bound (fold1 adjoin-def vars bound)))
-           (for-each (lambda (kfun) (visit-fun kfun bound)) kfuns)))
+           (fold1 (lambda (kfun first-order)
+                   (visit-fun kfun bound first-order))
+                  kfuns first-order)))
         (($ $values args)
-         (for-each check-use args))
+         (for-each check-use args)
+         first-order)
         (($ $call proc args)
          (check-use proc)
-         (for-each check-use args))
+         (for-each check-use args)
-        (($ $callk k proc args)
+         first-order)
+        (($ $callk kfun proc args)
          (check-use proc)
-         (for-each check-use args))
+         (for-each check-use args)
+         (visit-first-order kfun))
         (($ $branch kt ($ $values (arg)))
-         (check-use arg))
+         (check-use arg)
+         first-order)
         (($ $branch kt ($ $primcall name args))
-         (for-each check-use args))
+         (for-each check-use args)
+         first-order)
         (($ $primcall name args)
-         (for-each check-use args))
+         (for-each check-use args)
+         first-order)
         (($ $prompt escape? tag handler)
-         (check-use tag))))
+         (check-use tag)
-    (intmap-for-each
+         first-order)))
-     (lambda (label bound)
+    (intmap-fold
+     (lambda (label bound first-order)
        (let ((bound (intset-union free bound)))
          (match (intmap-ref conts label)
            (($ $kargs names vars ($ $continue k src exp))
-            (visit-exp exp (fold1 adjoin-def vars bound)))
+            (visit-exp exp (fold1 adjoin-def vars bound) first-order))
-           (_ #t))))
+           (_ first-order))))
-     (compute-available-definitions conts kfun))))
+     (compute-available-definitions conts kfun)
+     first-order)))
 
-(define (fold-nested-funs f conts kfun seed)
+(define (reachable-functions conts kfun)
-  (intset-fold
+  (worklist-fold*
-   (lambda (label seed)
+   (lambda (kfun kfuns)
-     (match (intmap-ref conts label)
+     ;(pk 'verify kfun kfuns)
-       (($ $kargs _ _ ($ $continue _ _ ($ $fun label)))
+     (let ((kfuns (intset-add kfuns kfun)))
-        (f label seed))
+       (values (intset-fold
-       (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun label) ...))))
+                (lambda (label nested)
-        (fold1 f label seed))
+                  (define (return kfun*)
-       (_ seed)))
+                    ;(pk 'return label kfuns kfun* nested)
-   (compute-function-body conts kfun)
+                    (append (filter (lambda (kfun)
-   seed))
+                                      (not (intset-ref kfuns kfun)))
+                                    kfun*)
+                            nested))
+                  (define (return1 kfun) (return (list kfun)))
+                  (define (return0) (return '()))
+                  (match (intmap-ref conts label)
+                    (($ $kargs _ _ ($ $continue _ _ exp))
+                     (match exp
+                       (($ $fun label) (return1 label))
+                       (($ $rec _ _ (($ $fun labels) ...)) (return labels))
+                       (($ $closure label nfree) (return1 label))
+                       (($ $callk label) (return1 label))
+                       (_ (return0))))
+                    (_ (return0))))
+                (compute-function-body conts kfun)
+                '())
+               kfuns)))
+   (intset kfun)
+   empty-intset))
 
 (define (check-label-partition conts kfun)
   ;; A continuation can only belong to one function.
-  (let visit-fun ((kfun kfun) (seen empty-intmap))
+  (intset-fold
-    (fold-nested-funs
+   (lambda (kfun seen)
-     visit-fun
-     conts
-     kfun
      (intset-fold
       (lambda (label seen)
         (intmap-add seen label kfun
                     (lambda (old new)
                       (error "label used by two functions" label old new))))
       (compute-function-body conts kfun)
-      seen))))
+      seen))
+   (reachable-functions conts kfun)
+   empty-intmap))
 
 (define (compute-reachable-labels conts kfun)
-  (let visit-fun ((kfun kfun) (seen empty-intset))
+  (intset-fold
-    (fold-nested-funs visit-fun conts kfun
+   (lambda (kfun seen)
-                      (intset-union seen (compute-function-body conts kfun)))))
+     (intset-union seen (compute-function-body conts kfun)))
+   (reachable-functions conts kfun)
+   empty-intset))
 
 (define (check-arities conts kfun)
   (define (check-arity exp cont)