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

Run sigbits fixpoint based on use/def graph, not cfg

Browse source 
* module/language/cps/specialize-numbers.scm (sigbits-ref): New helper.
(invert-graph*): New helper.
(compute-significant-bits): When visiting a term changes computed
needed-bits for one of its definitions, we need to revisit the variables
that contributed to its result (the uses), because they might need more
bits as well.  Previously we were doing this by enqueueing predecessors
to the term, which worked if the uses were defined in predecessors, or
if all defining terms were already in the worklist, which is the case
without loops.  But with loops, when revisiting a term, you could see
that it causes sigbits to change, enqueue its predecessors, but then the
predecessors don't change anything and the fixpoint stops before
reaching the definitions of the variables we need.  So instead we
compute the use-def graph and enqueue defs directly.
This commit is contained in:
Andy Wingo 2024-09-26 11:14:52 +02:00
parent 30c3849092
commit aff9ac9688
1 changed files with 54 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

120
module/language/cps/specialize-numbers.scm
View file

@ -286,6 +286,9 @@
(and (type<=? type (logior &exact-integer &u64 &s64)) (and (type<=? type (logior &exact-integer &u64 &s64))
(range->sigbits min max))))) (range->sigbits min max)))))
(define (sigbits-ref sigbits var)
(intmap-ref sigbits var (lambda (_) 0)))
(define significant-bits-handlers (make-hash-table)) (define significant-bits-handlers (make-hash-table))
(define-syntax-rule (define-significant-bits-handler (define-syntax-rule (define-significant-bits-handler
((primop label types out def ...) param arg ...) ((primop label types out def ...) param arg ...)
@ -297,24 +300,42 @@
(define-significant-bits-handler ((logand label types out res) param a b) (define-significant-bits-handler ((logand label types out res) param a b)
(let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
(inferred-sigbits types label b) (inferred-sigbits types label b)
(intmap-ref out res (lambda (_) 0))))) (sigbits-ref out res))))
(intmap-add (intmap-add out a sigbits sigbits-union) (intmap-add (intmap-add out a sigbits sigbits-union)
b sigbits sigbits-union))) b sigbits sigbits-union)))
(define-significant-bits-handler ((logand/immediate label types out res) param a) (define-significant-bits-handler ((logand/immediate label types out res) param a)
(let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
param param
(intmap-ref out res (lambda (_) 0))))) (sigbits-ref out res))))
(intmap-add out a sigbits sigbits-union))) (intmap-add out a sigbits sigbits-union)))
(define (significant-bits-handler primop) (define (significant-bits-handler primop)
(hashq-ref significant-bits-handlers primop)) (hashq-ref significant-bits-handlers primop))
(define (invert-graph* defs)
"Given a graph LABEL->VAR..., return a graph VAR->LABEL.... Like the one
in (language cps graphs), but different because it doesn't assume that
the domain will be the same before and after."
(persistent-intmap
(intmap-fold (lambda (label vars out)
(intset-fold
(lambda (var out)
(intmap-add! out var (intset label) intset-union))
vars
out))
defs
empty-intmap)))
(define (compute-significant-bits cps types kfun) (define (compute-significant-bits cps types kfun)
"Given the locally inferred types @var{types}, compute a map of VAR -> "Given the locally inferred types @var{types}, compute a map of VAR ->
BITS indicating the significant bits needed for a variable. BITS may be BITS indicating the significant bits needed for a variable. BITS may be
#f to indicate all bits, or a non-negative integer indicating a bitmask." #f to indicate all bits, or a non-negative integer indicating a bitmask."
(let ((preds (invert-graph (compute-successors cps kfun)))) (let ((cps (intmap-select cps (compute-function-body cps kfun))))
(let lp ((worklist (intmap-keys preds)) (out empty-intmap)) ;; Label -> Var...
(define-values (defs uses) (compute-defs-and-uses cps))
;; Var -> Label...
(define defs-by-var (invert-graph* defs))
(let lp ((worklist (intmap-keys cps)) (out empty-intmap))
(match (intset-prev worklist) (match (intset-prev worklist)
(#f out) (#f out)
(label (label
@ -322,69 +343,36 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (continue out*) (define (continue out*)
(if (eq? out out*) (if (eq? out out*)
(lp worklist out) (lp worklist out)
(lp (intset-union worklist (intmap-ref preds label)) (lp (intset-fold
(lambda (use worklist)
(intset-union worklist (intmap-ref defs-by-var use)))
(intmap-ref uses label)
worklist)
out*))) out*)))
(define (add-def out var) (define (add-unknown-use var out)
(intmap-add out var 0 sigbits-union))
(define (add-defs out vars)
(match vars
(() out)
((var . vars) (add-defs (add-def out var) vars))))
(define (add-unknown-use out var)
(intmap-add out var (inferred-sigbits types label var) (intmap-add out var (inferred-sigbits types label var)
sigbits-union)) sigbits-union))
(define (add-unknown-uses out vars) (define (default)
(match vars (intset-fold add-unknown-use (intmap-ref uses label) out))
(() out)
((var . vars)
(add-unknown-uses (add-unknown-use out var) vars))))
(continue (continue
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kfun src meta self) (($ $kargs _ _ ($ $continue k _ ($ $primcall op param args)))
(if self (add-def out self) out)) (match (significant-bits-handler op)
(($ $kargs names vars term) (#f (default))
(let ((out (add-defs out vars))) (h
(match term (match (intmap-ref cps k)
(($ $continue k src exp) (($ $kargs _ defs)
(match exp (h label types out param args defs))))))
((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun) (($ $kargs _ _ ($ $continue k _ ($ $values args)))
($ $code) ($ $rec)) (match (intmap-ref cps k)
;; No uses, so no info added to sigbits. (($ $kargs _ vars)
out) (fold (lambda (arg var out)
(($ $values args) (intmap-add out arg (sigbits-ref out var)
(match (intmap-ref cps k) sigbits-union))
(($ $kargs _ vars) out args vars))
(fold (lambda (arg var out) (($ $ktail)
(intmap-add out arg (intmap-ref out var (lambda (_) 0)) (default))))
sigbits-union)) (_ (default))))))))))
out args vars))
(($ $ktail)
(add-unknown-uses out args))))
(($ $call proc args)
(add-unknown-use (add-unknown-uses out args) proc))
(($ $callk label proc args)
(let ((out (add-unknown-uses out args)))
(if proc
(add-unknown-use out proc)
out)))
(($ $calli args callee)
(add-unknown-uses (add-unknown-use out callee) args))
(($ $primcall name param args)
(let ((h (significant-bits-handler name)))
(if h
(match (intmap-ref cps k)
(($ $kargs _ defs)
(h label types out param args defs)))
(add-unknown-uses out args))))))
(($ $branch kf kt src op param args)
(add-unknown-uses out args))
(($ $switch kf kt src arg)
(add-unknown-use out arg))
(($ $prompt k kh src escape? tag)
(add-unknown-use out tag))
(($ $throw src op param args)
(add-unknown-uses out args)))))
(_ out)))))))))
(define (specialize-operations cps) (define (specialize-operations cps)
(define (u6-parameter? param) (define (u6-parameter? param)
@ -416,7 +404,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (all-u64-bits-set? var) (define (all-u64-bits-set? var)
(operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64)))) (operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64))))
(define (only-fixnum-bits-used? var) (define (only-fixnum-bits-used? var)
(let ((bits (intmap-ref sigbits var))) (let ((bits (sigbits-ref sigbits var)))
(and bits (= bits (logand bits (target-most-positive-fixnum)))))) (and bits (= bits (logand bits (target-most-positive-fixnum))))))
(define (fixnum-result? result) (define (fixnum-result? result)
(or (only-fixnum-bits-used? result) (or (only-fixnum-bits-used? result)
@ -429,7 +417,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
min max min max
(target-most-positive-fixnum))))))) (target-most-positive-fixnum)))))))
(define (only-u64-bits-used? var) (define (only-u64-bits-used? var)
(let ((bits (intmap-ref sigbits var))) (let ((bits (sigbits-ref sigbits var)))
(and bits (= bits (logand bits (1- (ash 1 64))))))) (and bits (= bits (logand bits (1- (ash 1 64)))))))
(define (u64-result? result) (define (u64-result? result)
(or (only-u64-bits-used? result) (or (only-u64-bits-used? result)
@ -490,7 +478,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
u64->fixnum) u64->fixnum)
((only-fixnum-bits-used? result) ((only-fixnum-bits-used? result)
(lambda (cps k src u64) (lambda (cps k src u64)
(u64->fixnum/truncate cps k src u64 (intmap-ref sigbits result)))) (u64->fixnum/truncate cps k src u64 (sigbits-ref sigbits result))))
(else (else
u64->scm))))) u64->scm)))))
(define (box-f64 result) (define (box-f64 result)
@ -576,7 +564,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(('logand/immediate (? u64-result?) param a) (('logand/immediate (? u64-result?) param a)
(specialize-unop cps k src 'ulogand/immediate (specialize-unop cps k src 'ulogand/immediate
(logand param (logand param
(or (intmap-ref sigbits result) -1) (or (sigbits-ref sigbits a) -1)
(1- (ash 1 64))) (1- (ash 1 64)))
a a
(unbox-u64/truncate a) (box-u64 result))) (unbox-u64/truncate a) (box-u64 result)))