X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3e1b97c1b06b76ef178ffd2ffe68a1babc86333c..50fcdfece306a437ebad326679245e206cfbe6b2:/module/language/cps/arities.scm

diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index 8b9ce411c..fa7cc1418 100644
--- 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,16 +32,14 @@
   #:use-module (language cps primitives)
   #:export (fix-arities))
 
-(define (fix-clause-arities clause dfg)
+(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 (cut fix-arities* <> dfg) funs)
-                  ,(visit-term body)))
         (($ $continue k src exp)
          ,(visit-exp k src exp))))
 
@@ -56,7 +54,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
@@ -77,20 +76,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 dfg)
            (($ $ktail)
             ,(rewrite-cps-term exp
-               (($values (sym))
+               (($ $values (sym))
                 ($continue ktail src ($primcall 'return (sym))))
                (_
                 ,(let-fresh (k*) (v)
@@ -129,19 +129,30 @@
 
     (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 dfg)))
+        (($ $fun body)
+         ,(adapt-exp 1 k src (build-cps-exp
+                               ($fun ,(fix-arities* body dfg)))))
+        (($ $rec names syms funs)
+         ;; Assume $rec expressions have the correct arity.
+         ($continue k src
+           ($rec names syms (map (lambda (fun)
+                                   (rewrite-cps-exp fun
+                                     (($ $fun body)
+                                      ($fun ,(fix-arities* body dfg)))))
+                                 funs))))
         ((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))
@@ -181,13 +192,8 @@
          ,cont)))
 
     (rewrite-cps-cont clause
-      (($ $cont sym ($ $kentry self tail clause))
-       (sym ($kentry self ,tail ,(and clause (visit-cont clause))))))))
-
-(define (fix-arities* fun dfg)
-  (rewrite-cps-exp fun
-    (($ $fun src meta free body)
-     ($fun src meta free ,(fix-clause-arities body dfg)))))
+      (($ $cont sym ($ $kfun src meta self tail clause))
+       (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))))))
 
 (define (fix-arities fun)
   (let ((dfg (compute-dfg fun)))