mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +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)) defs))
(define (elide-type-checks! fun dfg effects min-label label-count) (define (elide-type-checks! fun dfg effects min-label label-count)
(when (< label-count 2000) (match fun
(match fun (($ $cont kfun ($ $kfun src meta min-var))
(($ $cont kfun ($ $kfun src meta min-var)) (let ((typev (infer-types fun dfg)))
(let ((typev (infer-types fun dfg))) (define (idx->label idx) (+ idx min-label))
(define (idx->label idx) (+ idx min-label)) (define (var->idx var) (- var min-var))
(define (var->idx var) (- var min-var)) (define (visit-primcall lidx fx name args)
(define (visit-primcall lidx fx name args) (when (primcall-types-check? typev (idx->label lidx) name args)
(when (primcall-types-check? typev (idx->label lidx) name args) (vector-set! effects lidx
(vector-set! effects lidx (logand fx (lognot &type-check)))))
(logand fx (lognot &type-check))))) (let lp ((lidx 0))
(let lp ((lidx 0)) (when (< lidx label-count)
(when (< lidx label-count) (let ((fx (vector-ref effects lidx)))
(let ((fx (vector-ref effects lidx))) (unless (causes-all-effects? fx)
(unless (causes-all-effects? fx) (when (causes-effect? fx &type-check)
(when (causes-effect? fx &type-check) (match (lookup-cont (idx->label lidx) dfg)
(match (lookup-cont (idx->label lidx) dfg) (($ $kargs _ _ term)
(($ $kargs _ _ term) (match (find-call term)
(match (find-call term) (($ $continue k src ($ $primcall name args))
(($ $continue k src ($ $primcall name args)) (visit-primcall lidx fx name args))
(visit-primcall lidx fx name args)) (($ $continue k src ($ $branch _ ($primcall name args)))
(($ $continue k src ($ $branch _ ($primcall name args))) (visit-primcall lidx fx name args))
(visit-primcall lidx fx name args)) (_ #f)))
(_ #f))) (_ #f)))))
(_ #f))))) (lp (1+ lidx))))))))
(lp (1+ lidx)))))))))
(define (compute-live-code fun) (define (compute-live-code fun)
(let* ((fun-data-table (make-hash-table)) (let* ((fun-data-table (make-hash-table))