[Guile-commits] GNU Guile branch, master, updated. v2.1.0-60-g0ad455c

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=0ad455ca6b8058a08fc88d911c3814b06275fe4e

The branch, master has been updated
       via  0ad455ca6b8058a08fc88d911c3814b06275fe4e (commit)
      from  e21dae43fcd63b0e261e76d78e7eaf4aed10a190 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 0ad455ca6b8058a08fc88d911c3814b06275fe4e
Author: Andy Wingo <address@hidden>
Date:   Mon Jun 30 15:30:39 2014 +0200

    Remove size limit in elide-type-checks
    
    * module/language/cps/dce.scm (elide-type-checks!): Remove limit on
      label-count, now that complexity is under control.

-----------------------------------------------------------------------

Summary of changes:
 module/language/cps/dce.scm |   49 +++++++++++++++++++++----------------------
 1 files changed, 24 insertions(+), 25 deletions(-)

diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm
index 2f34c38..b3dba09 100644
--- a/module/language/cps/dce.scm
+++ b/module/language/cps/dce.scm
@@ -80,31 +80,30 @@
     defs))
 
 (define (elide-type-checks! fun dfg effects min-label label-count)
-  (when (< label-count 2000)
-    (match fun
-     (($ $cont kfun ($ $kfun src meta min-var))
-      (let ((typev (infer-types fun dfg)))
-        (define (idx->label idx) (+ idx min-label))
-        (define (var->idx var) (- var min-var))
-        (define (visit-primcall lidx fx name args)
-          (when (primcall-types-check? typev (idx->label lidx) name args)
-            (vector-set! effects lidx
-                         (logand fx (lognot &type-check)))))
-        (let lp ((lidx 0))
-          (when (< lidx label-count)
-            (let ((fx (vector-ref effects lidx)))
-              (unless (causes-all-effects? fx)
-                (when (causes-effect? fx &type-check)
-                  (match (lookup-cont (idx->label lidx) dfg)
-                    (($ $kargs _ _ term)
-                     (match (find-call term)
-                       (($ $continue k src ($ $primcall name args))
-                        (visit-primcall lidx fx name args))
-                       (($ $continue k src ($ $branch _ ($primcall name args)))
-                        (visit-primcall lidx fx name args))
-                       (_ #f)))
-                    (_ #f)))))
-            (lp (1+ lidx)))))))))
+  (match fun
+    (($ $cont kfun ($ $kfun src meta min-var))
+     (let ((typev (infer-types fun dfg)))
+       (define (idx->label idx) (+ idx min-label))
+       (define (var->idx var) (- var min-var))
+       (define (visit-primcall lidx fx name args)
+         (when (primcall-types-check? typev (idx->label lidx) name args)
+           (vector-set! effects lidx
+                        (logand fx (lognot &type-check)))))
+       (let lp ((lidx 0))
+         (when (< lidx label-count)
+           (let ((fx (vector-ref effects lidx)))
+             (unless (causes-all-effects? fx)
+               (when (causes-effect? fx &type-check)
+                 (match (lookup-cont (idx->label lidx) dfg)
+                   (($ $kargs _ _ term)
+                    (match (find-call term)
+                      (($ $continue k src ($ $primcall name args))
+                       (visit-primcall lidx fx name args))
+                      (($ $continue k src ($ $branch _ ($primcall name args)))
+                       (visit-primcall lidx fx name args))
+                      (_ #f)))
+                   (_ #f)))))
+           (lp (1+ lidx))))))))
 
 (define (compute-live-code fun)
   (let* ((fun-data-table (make-hash-table))


hooks/post-receive
-- 
GNU Guile