mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Remove size limit in elide-type-checks

Browse source 
* module/language/cps/dce.scm (elide-type-checks!): Remove limit on
  label-count, now that complexity is under control.
This commit is contained in:
Andy Wingo 2014-06-30 15:30:39 +02:00
parent e21dae43fc
commit 0ad455ca6b
1 changed files with 24 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

49
module/language/cps/dce.scm
View file

@ -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))