Limit impact of O(n^2) type analysis by imposing limit

* module/language/cps/types.scm (infer-types): Add #:max-label-count
  argument.

* module/language/cps/type-fold.scm (compute-folded, fold-constants*):
  Disable for big functions.  Perhaps we can relax this if we find an
  O(n log n) way to represent types.

diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index ca02fec..91f23df 100644 (file)
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -134,9 +134,11 @@
      ((eqv? type &nil) #nil)
      ((eqv? type &null) '())
      (else (error "unhandled type" type val))))
-  (let* ((typev (infer-types fun dfg))
-         (folded? (make-bitvector (/ (vector-length typev) 2) #f))
-         (folded-values (make-vector (bitvector-length folded?) #f)))
+  (let* ((typev (infer-types fun dfg #:max-label-count 3000))
+         (folded? (and typev
+                       (make-bitvector (/ (vector-length typev) 2) #f)))
+         (folded-values (and typev
+                             (make-vector (bitvector-length folded?) #f))))
     (define (label->idx label) (- label min-label))
     (define (var->idx var) (- var min-var))
     (define (maybe-fold-value! label name k def)
@@ -201,9 +203,10 @@
                                           (var->idx arg0) (var->idx arg1)))))
            (_ #f)))
         (_ #f)))
-    (match fun
-      (($ $cont kfun ($ $kfun src meta self tail clause))
-       (visit-cont clause)))
+    (when typev
+      (match fun
+        (($ $cont kfun ($ $kfun src meta self tail clause))
+         (visit-cont clause))))
     (values folded? folded-values)))
 
 (define (fold-constants* fun dfg)
@@ -232,7 +235,8 @@
              (($ $continue k src (and fun ($ $fun)))
               ($continue k src ,(visit-fun fun)))
              (($ $continue k src (and primcall ($ $primcall)))
-              ,(if (bitvector-ref folded? (label->idx label))
+              ,(if (and folded?
+                        (bitvector-ref folded? (label->idx label)))
                    (let ((val (vector-ref folded-values (label->idx label))))
                      ;; Uncomment for debugging.
                      ;; (pk 'folded src primcall val)

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 44deb04..22335f7 100644 (file)
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1381,7 +1381,7 @@ mapping symbols to types."
        ;; All done!  Return the computed types.
        (else typev)))))
 
-(define (infer-types fun dfg)
+(define* (infer-types fun dfg #:key (max-label-count +inf.0))
   ;; Fun must be renumbered.
   (match fun
     (($ $cont min-label ($ $kfun _ _ min-var))
@@ -1412,7 +1412,8 @@ mapping symbols to types."
                    (values label-count var-count)))))
             fun 0 0))
        (lambda (label-count var-count)
-         (infer-types* dfg min-label label-count min-var var-count))))))
+         (and (< label-count max-label-count)
+              (infer-types* dfg min-label label-count min-var var-count)))))))
 
 (define (lookup-pre-type typev label def)
   (if (< def 0)