mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

DCE uses type analysis to elide type checks

Browse source 
* module/language/cps/dce.scm (elide-type-checks!, compute-live-code):
  Replace old ad-hoc type check elision with one driven from type
  analysis.  Type check elision only operates on smallish functions, to
  avoid n**2 explosion in type inference.
This commit is contained in:
Andy Wingo 2014-05-14 16:59:08 +02:00
parent a7ee377dbe
commit 3be43fb782
1 changed files with 57 additions and 109 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -40,6 +40,7 @@
#:use-module (language cps dfg) #:use-module (language cps dfg)
#:use-module (language cps effects-analysis) #:use-module (language cps effects-analysis)
#:use-module (language cps renumber) #:use-module (language cps renumber)
#:use-module (language cps types)
#:export (eliminate-dead-code)) #:export (eliminate-dead-code))
(define-record-type $fun-data (define-record-type $fun-data
@ -76,96 +77,31 @@
(lp (1+ n)))) (lp (1+ n))))
defs)) defs))
(define (constant-type val) (define (elide-type-checks! fun dfg effects min-label label-count)
(cond (when (< label-count 2000)
((and (exact-integer? val) (<= 0 val most-positive-fixnum)) (match fun
'size) (($ $cont kfun ($ $kfun src meta min-var))
((number? val) 'number) (let ((typev (infer-types fun dfg)))
((vector? val) 'vector) (define (idx->label idx) (+ idx min-label))
((pair? val) 'pair) (define (var->idx var) (- var min-var))
((char? val) 'char) (let lp ((lidx 0))
(else #f))) (when (< lidx label-count)
(let ((fx (vector-ref effects lidx)))
(define (lookup-type arg dfg) (unless (causes-all-effects? fx)
(match (lookup-predecessors (lookup-def arg dfg) dfg) (when (causes-effect? fx &type-check)
((pred) (match (lookup-cont (idx->label lidx) dfg)
(match (lookup-cont pred dfg) (($ $kargs _ _ term)
(($ $kargs _ _ term) (match (find-call term)
(match (find-expression term) (($ $continue k src ($ $primcall name args))
(($ $const val) (constant-type val)) (let ((args (map var->idx args)))
(($ $primcall name args) ;; Negative args are closure variables.
(match (check-primcall-arg-types dfg name args) (unless (or-map negative? args)
((type) type) (when (primcall-types-check? lidx typev name args)
(_ #f))) (vector-set! effects lidx
(($ $values (var)) (lookup-type var dfg)) (logand fx (lognot &type-check)))))))
(($ $void) 'unspecified) (_ #f)))
(_ #f))) (_ #f)))))
(_ #f))) (lp (1+ lidx)))))))))
(_ #f)))
(define (default-type-checker . _)
#f)
(define *primcall-type-checkers* (make-hash-table))
(define-syntax-rule (define-primcall-type-checker (name dfg arg ...)
body ...)
(hashq-set! *primcall-type-checkers* 'name
(lambda (dfg arg ...) body ...)))
(define-syntax-rule (define-simple-primcall-types
((name (arg arg-type) ...) result ...)
...)
(begin
(define-primcall-type-checker (name dfg arg ...)
(define (check-type val type)
(or (eqv? type #t)
(eqv? (lookup-type val dfg) type)))
(and (check-type arg 'arg-type)
...
'(result ...)))
...))
(define-simple-primcall-types
((cons (car #t) (cdr #t)) pair)
((car (pair pair)) #f)
((cdr (pair pair)) #f)
((set-car! (pair pair) (car #t)))
((set-cdr! (pair pair) (car #t)))
((make-vector (len size) (fill #t)) vector)
((make-vector/immediate (len size) (fill #t)) vector)
((vector-length (vector vector)) size)
((box (val #t)) box)
((box-ref (box box)) #f)
((box-set! (box box) (val #t)))
((make-struct (vtable vtable) (len size)) struct)
((make-struct/immediate (vtable vtable) (len size)) struct))
(define (vector-index-within-range? dfg vec idx)
(define (constant-value var)
(call-with-values (lambda () (find-constant-value var dfg))
(lambda (found? val)
(unless found?
(error "should have found value" var))
val)))
(let lp ((vec vec))
(match (find-defining-expression vec dfg)
(($ $primcall 'make-vector/immediate (len fill))
(<= 0 (constant-value idx) (1- (constant-value len))))
(($ $values (vec)) (lp vec))
(_ #f))))
(define-primcall-type-checker (vector-ref/immediate dfg vec idx)
(and (vector-index-within-range? dfg vec idx)
'(#f)))
(define-primcall-type-checker (vector-set!/immediate dfg vec idx val)
(and (vector-index-within-range? dfg vec idx)
'()))
(define (check-primcall-arg-types dfg name args)
(apply (hashq-ref *primcall-type-checkers* name default-type-checker)
dfg args))
(define (compute-live-code fun) (define (compute-live-code fun)
(let* ((fun-data-table (make-hash-table)) (let* ((fun-data-table (make-hash-table))
@ -192,16 +128,31 @@
(defs (compute-defs dfg min-label label-count)) (defs (compute-defs dfg min-label label-count))
(fun-data (make-fun-data (fun-data (make-fun-data
min-label effects live-conts defs))) min-label effects live-conts defs)))
(elide-type-checks! fun dfg effects min-label label-count)
(hashq-set! fun-data-table fun fun-data) (hashq-set! fun-data-table fun fun-data)
(set! changed? #t) (set! changed? #t)
fun-data))))) fun-data)))))
(define (visit-fun fun) (define (visit-fun fun)
(match (ensure-fun-data fun) (match (ensure-fun-data fun)
(($ $fun-data min-label effects live-conts defs) (($ $fun-data min-label effects live-conts defs)
(define (types-check? exp) (define (idx->label idx) (+ idx min-label))
(match exp (define (label->idx label) (- label min-label))
(($ $primcall name args) (define (known-allocation? var dfg)
(check-primcall-arg-types dfg name args)))) (match (lookup-predecessors (lookup-def var dfg) dfg)
((def-exp-k)
(match (lookup-cont def-exp-k dfg)
(($ $kargs _ _ term)
(match (find-call term)
(($ $continue k src ($ $values (var)))
(known-allocation? var dfg))
(($ $continue k src ($ $primcall))
(let ((kidx (label->idx def-exp-k)))
(and (>= kidx 0)
(causes-effect? (vector-ref effects kidx)
&allocation))))
(_ #f)))
(_ #f)))
(_ #f)))
(define (visit-grey-exp n exp) (define (visit-grey-exp n exp)
(let ((defs (vector-ref defs n)) (let ((defs (vector-ref defs n))
(fx (vector-ref effects n))) (fx (vector-ref effects n)))
@ -213,25 +164,22 @@
;; Does this expression cause all effects? If so, it's ;; Does this expression cause all effects? If so, it's
;; definitely live. ;; definitely live.
(causes-all-effects? fx) (causes-all-effects? fx)
;; Does it cause a type check, but we can't prove that the ;; Does it cause a type check, but we weren't able to
;; types check? ;; prove that the types check?
(and (causes-effect? fx &type-check) (causes-effect? fx &type-check)
(not (types-check? exp)))
;; We might have a setter. If the object being assigned ;; We might have a setter. If the object being assigned
;; to is live, then this expression is live. Otherwise ;; to is live or was not created by us, then this
;; the value is still dead. ;; expression is live. Otherwise the value is still dead.
(and (causes-effect? fx &write) (and (causes-effect? fx &write)
(match exp (match exp
(($ $primcall 'vector-set!/immediate (vec idx val)) (($ $primcall
(value-live? vec)) (or 'vector-set! 'vector-set!/immediate
(($ $primcall 'set-car! (pair car)) 'set-car! 'set-cdr!
(value-live? pair)) 'box-set!)
(($ $primcall 'set-cdr! (pair cdr)) (obj . _))
(value-live? pair)) (or (value-live? obj)
(($ $primcall 'box-set! (box val)) (not (known-allocation? obj dfg))))
(value-live? box))
(_ #t)))))) (_ #t))))))
(define (idx->label idx) (+ idx min-label))
(let lp ((n (1- (vector-length effects)))) (let lp ((n (1- (vector-length effects))))
(unless (< n 0) (unless (< n 0)
(let ((cont (lookup-cont (idx->label n) dfg))) (let ((cont (lookup-cont (idx->label n) dfg)))