Remove $void CPS expression type

[bpt/guile.git] / module / language / cps / arities.scm

diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index daddaf5..479d56d 100644 (file)
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -32,22 +32,28 @@
   #:use-module (language cps primitives)
   #:export (fix-arities))
 
-(define (fix-clause-arities clause conts)
+(define (fix-arities* clause dfg)
   (let ((ktail (match clause
-                 (($ $cont _ ($ $kentry _ ($ $cont ktail) _)) ktail))))
+                 (($ $cont _
+                     ($ $kfun src meta _ ($ $cont ktail) _)) ktail))))
     (define (visit-term term)
       (rewrite-cps-term term
         (($ $letk conts body)
          ($letk ,(map visit-cont conts) ,(visit-term body)))
         (($ $letrec names syms funs body)
-         ($letrec names syms (map fix-arities* funs) ,(visit-term body)))
+         ($letrec names syms (map (lambda (fun)
+                                    (rewrite-cps-exp fun
+                                      (($ $fun free body)
+                                       ($fun free ,(fix-arities* body dfg)))))
+                                  funs)
+           ,(visit-term body)))
         (($ $continue k src exp)
          ,(visit-exp k src exp))))
 
     (define (adapt-exp nvals k src exp)
       (match nvals
         (0
-         (rewrite-cps-term (lookup-cont k conts)
+         (rewrite-cps-term (lookup-cont k dfg)
            (($ $ktail)
             ,(let-fresh (kvoid kunspec) (unspec)
                (build-cps-term
@@ -55,7 +61,8 @@
                                      ($continue k src
                                        ($primcall 'return (unspec)))))
                           (kvoid ($kargs () ()
-                                   ($continue kunspec src ($void)))))
+                                   ($continue kunspec src
+                                     ($const *unspecified*)))))
                    ($continue kvoid src ,exp)))))
            (($ $kreceive arity kargs)
             ,(match arity
@@ -76,20 +83,21 @@
                                           ($primcall 'values (void)))))
                              (kvoid ($kargs () ()
                                       ($continue kvalues src
-                                        ($void)))))
+                                        ($const *unspecified*)))))
                       ($continue kvoid src ,exp)))))))
            (($ $kargs () () _)
             ($continue k src ,exp))
            (_
             ,(let-fresh (k*) ()
                (build-cps-term
-                 ($letk ((k* ($kargs () () ($continue k src ($void)))))
+                 ($letk ((k* ($kargs () () ($continue k src
+                                             ($const *unspecified*)))))
                    ($continue k* src ,exp)))))))
         (1
-         (rewrite-cps-term (lookup-cont k conts)
+         (rewrite-cps-term (lookup-cont k dfg)
            (($ $ktail)
             ,(rewrite-cps-term exp
-               (($values (sym))
+               (($ $values (sym))
                 ($continue ktail src ($primcall 'return (sym))))
                (_
                 ,(let-fresh (k*) (v)
@@ -128,19 +136,22 @@
 
     (define (visit-exp k src exp)
       (rewrite-cps-term exp
-        ((or ($ $void)
-             ($ $const)
+        ((or ($ $const)
              ($ $prim)
              ($ $values (_)))
          ,(adapt-exp 1 k src exp))
-        (($ $fun)
-         ,(adapt-exp 1 k src (fix-arities* exp)))
+        (($ $fun free body)
+         ,(adapt-exp 1 k src (build-cps-exp
+                               ($fun free ,(fix-arities* body dfg)))))
         ((or ($ $call) ($ $callk))
          ;; In general, calls have unknown return arity.  For that
          ;; reason every non-tail call has a $kreceive continuation to
          ;; adapt the return to the target continuation, and we don't
          ;; need to do any adapting here.
          ($continue k src ,exp))
+        (($ $branch)
+         ;; Assume branching primcalls have the correct arity.
+         ($continue k src ,exp))
         (($ $primcall 'return (arg))
          ;; Primcalls to return are in tail position.
          ($continue ktail src ,exp))
@@ -173,21 +184,17 @@
       (rewrite-cps-cont cont
         (($ $cont sym ($ $kargs names syms body))
          (sym ($kargs names syms ,(visit-term body))))
-        (($ $cont sym ($ $kclause arity body))
-         (sym ($kclause ,arity ,(visit-cont body))))
+        (($ $cont sym ($ $kclause arity body alternate))
+         (sym ($kclause ,arity ,(visit-cont body)
+                        ,(and alternate (visit-cont alternate)))))
         (($ $cont)
          ,cont)))
 
     (rewrite-cps-cont clause
-      (($ $cont sym ($ $kentry self tail clauses))
-       (sym ($kentry self ,tail ,(map visit-cont clauses)))))))
-
-(define (fix-arities* fun)
-  (let ((conts (build-local-cont-table fun)))
-    (rewrite-cps-exp fun
-      (($ $fun src meta free body)
-       ($fun src meta free ,(fix-clause-arities body conts))))))
+      (($ $cont sym ($ $kfun src meta self tail clause))
+       (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
 
 (define (fix-arities fun)
-  (with-fresh-name-state fun
-    (fix-arities* fun)))
+  (let ((dfg (compute-dfg fun)))
+    (with-fresh-name-state-from-dfg dfg
+      (fix-arities* fun dfg))))