summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/specialize-numbers.scm120
1 files changed, 54 insertions, 66 deletions
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm
index b46919a40..4983326f6 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -286,6 +286,9 @@
(and (type<=? type (logior &exact-integer &u64 &s64))
(range->sigbits min max)))))
+(define (sigbits-ref sigbits var)
+ (intmap-ref sigbits var (lambda (_) 0)))
+
(define significant-bits-handlers (make-hash-table))
(define-syntax-rule (define-significant-bits-handler
((primop label types out def ...) param arg ...)
@@ -297,24 +300,42 @@
(define-significant-bits-handler ((logand label types out res) param a b)
(let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
(inferred-sigbits types label b)
- (intmap-ref out res (lambda (_) 0)))))
+ (sigbits-ref out res))))
(intmap-add (intmap-add out a sigbits sigbits-union)
b sigbits sigbits-union)))
(define-significant-bits-handler ((logand/immediate label types out res) param a)
(let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a)
param
- (intmap-ref out res (lambda (_) 0)))))
+ (sigbits-ref out res))))
(intmap-add out a sigbits sigbits-union)))
(define (significant-bits-handler 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)
"Given the locally inferred types @var{types}, compute a map of VAR ->
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."
- (let ((preds (invert-graph (compute-successors cps kfun))))
- (let lp ((worklist (intmap-keys preds)) (out empty-intmap))
+ (let ((cps (intmap-select cps (compute-function-body cps kfun))))
+ ;; 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)
(#f out)
(label
@@ -322,69 +343,36 @@ BITS indicating the significant bits needed for a variable. BITS may be
(define (continue out*)
(if (eq? out 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*)))
- (define (add-def out var)
- (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)
+ (define (add-unknown-use var out)
(intmap-add out var (inferred-sigbits types label var)
sigbits-union))
- (define (add-unknown-uses out vars)
- (match vars
- (() out)
- ((var . vars)
- (add-unknown-uses (add-unknown-use out var) vars))))
+ (define (default)
+ (intset-fold add-unknown-use (intmap-ref uses label) out))
(continue
(match (intmap-ref cps label)
- (($ $kfun src meta self)
- (if self (add-def out self) out))
- (($ $kargs names vars term)
- (let ((out (add-defs out vars)))
- (match term
- (($ $continue k src exp)
- (match exp
- ((or ($ $const) ($ $prim) ($ $fun) ($ $const-fun)
- ($ $code) ($ $rec))
- ;; No uses, so no info added to sigbits.
- out)
- (($ $values args)
- (match (intmap-ref cps k)
- (($ $kargs _ vars)
- (fold (lambda (arg var out)
- (intmap-add out arg (intmap-ref out var (lambda (_) 0))
- sigbits-union))
- 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)))))))))
+ (($ $kargs _ _ ($ $continue k _ ($ $primcall op param args)))
+ (match (significant-bits-handler op)
+ (#f (default))
+ (h
+ (match (intmap-ref cps k)
+ (($ $kargs _ defs)
+ (h label types out param args defs))))))
+ (($ $kargs _ _ ($ $continue k _ ($ $values args)))
+ (match (intmap-ref cps k)
+ (($ $kargs _ vars)
+ (fold (lambda (arg var out)
+ (intmap-add out arg (sigbits-ref out var)
+ sigbits-union))
+ out args vars))
+ (($ $ktail)
+ (default))))
+ (_ (default))))))))))
(define (specialize-operations cps)
(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)
(operand-in-range? var &exact-integer (1- (ash 1 64)) (1- (ash 1 64))))
(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))))))
(define (fixnum-result? 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
(target-most-positive-fixnum)))))))
(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)))))))
(define (u64-result? 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)
((only-fixnum-bits-used? result)
(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
u64->scm)))))
(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)
(specialize-unop cps k src 'ulogand/immediate
(logand param
- (or (intmap-ref sigbits result) -1)
+ (or (sigbits-ref sigbits a) -1)
(1- (ash 1 64)))
a
(unbox-u64/truncate a) (box-u64 result)))