X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/b85f5f851fce230d16f3c13c371839f7e619059f..a0329d01095d6ddaa42449ec18a4fb2bc83db16e:/module/language/cps/renumber.scm

diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm
index 217d6b0d7..0621ec92e 100644
--- a/module/language/cps/renumber.scm
+++ b/module/language/cps/renumber.scm
@@ -74,10 +74,7 @@
             (lp (1+ n) next))))))
 
 (define (compute-new-labels-and-vars fun)
-  (call-with-values (lambda ()
-                      (match fun
-                        (($ $fun free body)
-                         (compute-max-label-and-var body))))
+  (call-with-values (lambda () (compute-max-label-and-var fun))
     (lambda (max-label max-var)
       (let ((labels (make-vector (1+ max-label) #f))
             (next-label 0)
@@ -113,9 +110,7 @@
               (($ $letrec names syms funs body)
                (visit-term body))
               (($ $continue k src _) #f)))
-          (match fun
-            (($ $fun free body)
-             (visit-cont body))))
+          (visit-cont fun))
 
         (define (compute-names-in-fun fun)
           (define queue '())
@@ -162,108 +157,111 @@
               (($ $letrec names syms funs body)
                (when reachable?
                  (for-each rename! syms)
-                 (set! queue (fold cons queue funs)))
+                 (set! queue (fold (lambda (fun queue)
+                                     (match fun
+                                       (($ $fun free body)
+                                        (cons body queue))))
+                                   queue
+                                   funs)))
                (visit-term body reachable?))
-              (($ $continue k src (and fun ($ $fun)))
+              (($ $continue k src ($ $fun free body))
                (when reachable?
-                 (set! queue (cons fun queue))))
+                 (set! queue (cons body queue))))
               (($ $continue) #f)))
 
           (collect-conts fun)
           (match fun
-            (($ $fun free (and entry ($ $cont kfun)))
+            (($ $cont kfun)
              (set! next-label (sort-conts kfun labels next-label))
-             (visit-cont entry)
+             (visit-cont fun)
              (for-each compute-names-in-fun (reverse queue)))))
 
         (compute-names-in-fun fun)
         (values labels vars next-label next-var)))))
 
 (define (renumber fun)
-  (match fun
-    (($ $fun free cont)
-     (call-with-values (lambda () (compute-new-labels-and-vars fun))
-       (lambda (labels vars nlabels nvars)
-         (define (relabel label) (vector-ref labels label))
-         (define (rename var) (vector-ref vars var))
-         (define (rename-kw-arity arity)
-           (match arity
-             (($ $arity req opt rest kw aok?)
-              (make-$arity req opt rest
-                           (map (match-lambda
-                                 ((kw kw-name kw-var)
-                                  (list kw kw-name (rename kw-var))))
-                                kw)
-                           aok?))))
-         (define (must-visit-cont cont)
-           (or (visit-cont cont)
-               (error "internal error -- failed to visit cont")))
-         (define (visit-conts conts)
-           (match conts
-             (() '())
-             ((cont . conts)
-              (cond
-               ((visit-cont cont)
-                => (lambda (cont)
-                     (cons cont (visit-conts conts))))
-               (else (visit-conts conts))))))
-         (define (visit-cont cont)
-           (match cont
-             (($ $cont label cont)
-              (let ((label (relabel label)))
-                (and
-                 label
-                 (rewrite-cps-cont cont
-                   (($ $kargs names vars body)
-                    (label ($kargs names (map rename vars) ,(visit-term body))))
-                   (($ $kfun src meta self tail clause)
-                    (label
-                     ($kfun src meta (rename self) ,(must-visit-cont tail)
-                       ,(and clause (must-visit-cont clause)))))
-                   (($ $ktail)
-                    (label ($ktail)))
-                   (($ $kclause arity body alternate)
-                    (label
-                     ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
-                               ,(and alternate (must-visit-cont alternate)))))
-                   (($ $kreceive ($ $arity req () rest () #f) kargs)
-                    (label ($kreceive req rest (relabel kargs))))
-                   (($ $kif kt kf)
-                    (label ($kif (relabel kt) (relabel kf))))))))))
-         (define (visit-term term)
-           (rewrite-cps-term term
-             (($ $letk conts body)
-              ,(match (visit-conts conts)
-                 (() (visit-term body))
-                 (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
-             (($ $letrec names vars funs body)
-              ($letrec names (map rename vars) (map visit-fun funs)
-                       ,(visit-term body)))
-             (($ $continue k src exp)
-              ($continue (relabel k) src ,(visit-exp exp)))))
-         (define (visit-exp exp)
-           (match exp
-             ((or ($ $void) ($ $const) ($ $prim))
-              exp)
-             (($ $fun)
-              (visit-fun exp))
-             (($ $values args)
-              (let ((args (map rename args)))
-                (build-cps-exp ($values args))))
-             (($ $call proc args)
-              (let ((args (map rename args)))
-                (build-cps-exp ($call (rename proc) args))))
-             (($ $callk k proc args)
-              (let ((args (map rename args)))
-                (build-cps-exp ($callk (relabel k) (rename proc) args))))
-             (($ $primcall name args)
-              (let ((args (map rename args)))
-                (build-cps-exp ($primcall name args))))
-             (($ $prompt escape? tag handler)
-              (build-cps-exp
-                ($prompt escape? (rename tag) (relabel handler))))))
-         (define (visit-fun fun)
-           (rewrite-cps-exp fun
-             (($ $fun free body)
-              ($fun (map rename free) ,(must-visit-cont body)))))
-         (values (visit-fun fun) nlabels nvars))))))
+  (call-with-values (lambda () (compute-new-labels-and-vars fun))
+    (lambda (labels vars nlabels nvars)
+      (define (relabel label) (vector-ref labels label))
+      (define (rename var) (vector-ref vars var))
+      (define (rename-kw-arity arity)
+        (match arity
+          (($ $arity req opt rest kw aok?)
+           (make-$arity req opt rest
+                        (map (match-lambda
+                              ((kw kw-name kw-var)
+                               (list kw kw-name (rename kw-var))))
+                             kw)
+                        aok?))))
+      (define (must-visit-cont cont)
+        (or (visit-cont cont)
+            (error "internal error -- failed to visit cont")))
+      (define (visit-conts conts)
+        (match conts
+          (() '())
+          ((cont . conts)
+           (cond
+            ((visit-cont cont)
+             => (lambda (cont)
+                  (cons cont (visit-conts conts))))
+            (else (visit-conts conts))))))
+      (define (visit-cont cont)
+        (match cont
+          (($ $cont label cont)
+           (let ((label (relabel label)))
+             (and
+              label
+              (rewrite-cps-cont cont
+                (($ $kargs names vars body)
+                 (label ($kargs names (map rename vars) ,(visit-term body))))
+                (($ $kfun src meta self tail clause)
+                 (label
+                  ($kfun src meta (rename self) ,(must-visit-cont tail)
+                    ,(and clause (must-visit-cont clause)))))
+                (($ $ktail)
+                 (label ($ktail)))
+                (($ $kclause arity body alternate)
+                 (label
+                  ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body)
+                            ,(and alternate (must-visit-cont alternate)))))
+                (($ $kreceive ($ $arity req () rest () #f) kargs)
+                 (label ($kreceive req rest (relabel kargs))))
+                (($ $kif kt kf)
+                 (label ($kif (relabel kt) (relabel kf))))))))))
+      (define (visit-term term)
+        (rewrite-cps-term term
+          (($ $letk conts body)
+           ,(match (visit-conts conts)
+              (() (visit-term body))
+              (conts (build-cps-term ($letk ,conts ,(visit-term body))))))
+          (($ $letrec names vars funs body)
+           ($letrec names (map rename vars) (map visit-fun funs)
+                    ,(visit-term body)))
+          (($ $continue k src exp)
+           ($continue (relabel k) src ,(visit-exp exp)))))
+      (define (visit-exp exp)
+        (match exp
+          ((or ($ $void) ($ $const) ($ $prim))
+           exp)
+          (($ $fun)
+           (visit-fun exp))
+          (($ $values args)
+           (let ((args (map rename args)))
+             (build-cps-exp ($values args))))
+          (($ $call proc args)
+           (let ((args (map rename args)))
+             (build-cps-exp ($call (rename proc) args))))
+          (($ $callk k proc args)
+           (let ((args (map rename args)))
+             (build-cps-exp ($callk (relabel k) (rename proc) args))))
+          (($ $primcall name args)
+           (let ((args (map rename args)))
+             (build-cps-exp ($primcall name args))))
+          (($ $prompt escape? tag handler)
+           (build-cps-exp
+             ($prompt escape? (rename tag) (relabel handler))))))
+      (define (visit-fun fun)
+        (rewrite-cps-exp fun
+          (($ $fun free body)
+           ($fun (map rename free) ,(must-visit-cont body)))))
+      (values (must-visit-cont fun) nlabels nvars))))