mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 04:40:29 +02:00
Code Activity

Make integer devirtualization less eager

Browse source 
* module/language/cps/devirtualize-integers.scm (bailout?): Factor out.
  (peel-trace): Adapt to call external bailout? predicate.
  (peel-traces-in-function): Don't peel traces whose alternate is a
  bailout.
This commit is contained in:
Andy Wingo 2018-01-07 12:59:33 +01:00
parent d4addf3792
commit ef23e512b5
1 changed files with 19 additions and 15 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/language/cps/devirtualize-integers.scm
View file

@ -83,6 +83,11 @@
cps cps
(transient-intmap)))) (transient-intmap))))
(define (bailout? cps label)
(match (intmap-ref cps label)
(($ $kargs _ _ ($ $throw)) #t)
(_ #f)))
(define (peel-trace cps label fx kexit use-counts) (define (peel-trace cps label fx kexit use-counts)
"For the graph starting at LABEL, try to peel out a trace that uses "For the graph starting at LABEL, try to peel out a trace that uses
the variable FX. A peelable trace consists of effect-free terms, or the variable FX. A peelable trace consists of effect-free terms, or
@ -116,10 +121,6 @@ the trace should be referenced outside of it."
((= count 1) (intmap-remove live-vars var)) ((= count 1) (intmap-remove live-vars var))
(else (intmap-replace live-vars var (1- count))))) (else (intmap-replace live-vars var (1- count)))))
vars)))) vars))))
(define (bailout? k)
(match (intmap-ref cps k)
(($ $kargs _ _ ($ $throw)) #t)
(_ #f)))
(match (intmap-ref cps label) (match (intmap-ref cps label)
;; We know the initial label is a $kargs, and we won't follow the ;; We know the initial label is a $kargs, and we won't follow the
;; graph to get to $kreceive etc, so we can stop with these two ;; graph to get to $kreceive etc, so we can stop with these two
@ -172,12 +173,12 @@ the trace should be referenced outside of it."
(cond (cond
((not uses-of-interest?) ((not uses-of-interest?)
(fail)) (fail))
((bailout? kt) ((bailout? cps kt)
(continue kf live-vars defs-of-interest? can-terminate-trace? (continue kf live-vars defs-of-interest? can-terminate-trace?
(lambda (kf) (lambda (kf)
(build-term (build-term
($branch kf kt src op param peeled-args))))) ($branch kf kt src op param peeled-args)))))
((bailout? kf) ((bailout? cps kf)
(continue kt live-vars defs-of-interest? can-terminate-trace? (continue kt live-vars defs-of-interest? can-terminate-trace?
(lambda (kt) (lambda (kt)
(build-term (build-term
@ -236,15 +237,18 @@ the trace should be referenced outside of it."
;; Traces start with a fixnum? predicate. We could expand this ;; Traces start with a fixnum? predicate. We could expand this
;; in the future if we wanted to. ;; in the future if we wanted to.
(($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x))) (($ $kargs names vars ($ $branch kf kt src 'fixnum? #f (x)))
(with-cps cps (if (and (bailout? cps kf) #f)
(let$ kt (peel-trace kt x kf use-counts)) ;; Don't peel traces whose alternate is just a bailout.
($ ((lambda (cps) cps
(if kt (with-cps cps
(with-cps cps (let$ kt (peel-trace kt x kf use-counts))
(setk label ($ ((lambda (cps)
($kargs names vars (if kt
($branch kf kt src 'fixnum? #f (x))))) (with-cps cps
cps)))))) (setk label
($kargs names vars
($branch kf kt src 'fixnum? #f (x)))))
cps)))))))
(_ cps))) (_ cps)))
body body
cps)) cps))