fix `nil?' type inference

[bpt/guile.git] / module / language / cps / type-fold.scm

diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 21f242b..c82a11a 100644 (file)
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -1,5 +1,5 @@
 ;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;; Copyright (C) 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 License as
@@ -67,7 +67,6 @@
 ;; All the cases that are in compile-bytecode.
 (define-unary-type-predicate-folder pair? &pair)
 (define-unary-type-predicate-folder null? &null)
-(define-unary-type-predicate-folder nil? &nil)
 (define-unary-type-predicate-folder symbol? &symbol)
 (define-unary-type-predicate-folder variable? &box)
 (define-unary-type-predicate-folder vector? &vector)
@@ -356,8 +355,6 @@
         (($ $letk conts body)
          (for-each visit-cont conts)
          (visit-term body label))
-        (($ $letrec _ _ _ body)
-         (visit-term body label))
         (($ $continue k src ($ $primcall name args))
          ;; We might be able to fold primcalls that define a value.
          (match (lookup-cont k dfg)
@@ -402,11 +399,10 @@
              (($ $letk conts body)
               ($letk ,(map visit-cont conts)
                 ,(visit-term body label)))
-             (($ $letrec names vars funs body)
-              ($letrec names vars (map visit-fun funs)
-                ,(visit-term body label)))
              (($ $continue k src (and fun ($ $fun)))
               ($continue k src ,(visit-fun fun)))
+             (($ $continue k src ($ $rec names vars funs))
+              ($continue k src ($rec names vars (map visit-fun funs))))
              (($ $continue k src (and primcall ($ $primcall name args)))
               ,(cond
                 ((bitvector-ref folded? (label->idx label))
@@ -433,8 +429,8 @@
              (_ ,term)))
          (define (visit-fun fun)
            (rewrite-cps-exp fun
-             (($ $fun free body)
-              ($fun free ,(fold-constants* body dfg)))))
+             (($ $fun body)
+              ($fun ,(fold-constants* body dfg)))))
          (rewrite-cps-cont fun
            (($ $cont kfun ($ $kfun src meta self tail clause))
             (kfun ($kfun src meta self ,tail ,(visit-cont clause))))))))))