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

Specialize u64 bit operations

Browse source 
* module/language/cps/specialize-numbers.scm (specialize-u64-binop):
  (specialize-operations): Specialize u64 bit operations.
This commit is contained in:
Andy Wingo 2015-12-01 10:53:25 +01:00
parent 3d6dd2f81c
commit 73065c7131
1 changed files with 89 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -81,11 +81,18 @@
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->f64 (a))))))) ($primcall 'scm->f64 (a)))))))
(define (specialize-u64-binop cps k src op a b) (define* (specialize-u64-binop cps k src op a b #:key
(unbox-a 'scm->u64)
(unbox-b 'scm->u64))
(let ((uop (match op (let ((uop (match op
('add 'uadd) ('add 'uadd)
('sub 'usub) ('sub 'usub)
('mul 'umul)))) ('mul 'umul)
('logand 'ulogand)
('logior 'ulogior)
('logsub 'ulogsub)
('rsh 'ursh)
('lsh 'ulsh))))
(with-cps cps (with-cps cps
(letv u64-a u64-b result) (letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result) (letk kbox ($kargs ('result) (result)
@ -96,10 +103,10 @@
($primcall uop (u64-a u64-b))))) ($primcall uop (u64-a u64-b)))))
(letk kunbox-b ($kargs ('u64-a) (u64-a) (letk kunbox-b ($kargs ('u64-a) (u64-a)
($continue kop src ($continue kop src
($primcall 'scm->u64 (b))))) ($primcall unbox-b (b)))))
(build-term (build-term
($continue kunbox-b src ($continue kunbox-b src
($primcall 'scm->u64 (a))))))) ($primcall unbox-a (a)))))))
(define (specialize-u64-comparison cps kf kt src op a b) (define (specialize-u64-comparison cps kf kt src op a b)
(let ((op (symbol-append 'u64- op))) (let ((op (symbol-append 'u64- op)))
@ -151,6 +158,79 @@
(else (else
cps)) cps))
types)))))) types))))))
(($ $kargs names vars
($ $continue k src ($ $primcall 'ash (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(call-with-values (lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(call-with-values (lambda ()
(lookup-pre-type types label b))
(lambda (b-type b-min b-max)
(values
(cond
((or (not (eqv? type &exact-integer))
(not (<= 0 min max #xffffffffffffffff))
(not (u64-operand? a))
(not (eqv? b-type &exact-integer))
(< b-min 0 b-max)
(<= b-min -64)
(<= 64 b-max))
cps)
((and (< b-min 0) (= b-min b-max))
(with-cps cps
(let$ body
(with-cps-constants ((bits (- b-min)))
($ (specialize-u64-binop k src 'rsh a bits))))
(setk label ($kargs names vars ,body))))
((< b-min 0)
(with-cps cps
(let$ body
(with-cps-constants ((zero 0))
(letv bits)
(let$ body
(specialize-u64-binop k src 'rsh a bits))
(letk kneg ($kargs ('bits) (bits) ,body))
(build-term
($continue kneg src
($primcall 'sub (zero b))))))
(setk label ($kargs names vars ,body))))
(else
(with-cps cps
(let$ body (specialize-u64-binop k src 'lsh a b))
(setk label ($kargs names vars ,body)))))
types))))))))
(($ $kargs names vars
($ $continue k src
($ $primcall (and op (or 'logand 'logior 'logsub)) (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
(call-with-values (lambda ()
(lookup-post-type types label result 0))
(lambda (type min max)
(values
(cond
((and (eqv? type &exact-integer)
(<= 0 min max #xffffffffffffffff))
;; If we know the result is a u64, then any
;; out-of-range bits won't affect the result and so we
;; can project the operands onto u64.
(with-cps cps
(let$ body
(specialize-u64-binop k src op a b
#:unbox-a
(if (u64-operand? a)
'scm->u64
'scm->u64/truncate)
#:unbox-b
(if (u64-operand? b)
'scm->u64
'scm->u64/truncate)))
(setk label ($kargs names vars ,body))))
(else
cps))
types))))))
(($ $kargs names vars (($ $kargs names vars
($ $continue k src ($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
@ -184,7 +264,7 @@
;; include an unbox operation. ;; include an unbox operation.
(define (compute-specializable-vars cps body preds defs (define (compute-specializable-vars cps body preds defs
exp-result-unboxable? exp-result-unboxable?
unbox-op) unbox-ops)
;; Compute a map of VAR->LABEL... indicating the set of labels that ;; Compute a map of VAR->LABEL... indicating the set of labels that
;; define VAR with unboxable values, given the set of vars ;; define VAR with unboxable values, given the set of vars
;; UNBOXABLE-VARS which is known already to be unboxable. ;; UNBOXABLE-VARS which is known already to be unboxable.
@ -238,7 +318,7 @@
(match (intmap-ref cps label) (match (intmap-ref cps label)
(($ $kargs _ _ ($ $continue k _ exp)) (($ $kargs _ _ ($ $continue k _ exp))
(match exp (match exp
(($ $primcall (? (lambda (op) (eq? op unbox-op))) (var)) (($ $primcall (? (lambda (op) (memq op unbox-ops))) (var))
(intset-add unbox-uses var)) (intset-add unbox-uses var))
(($ $values vars) (($ $values vars)
(match (intmap-ref cps k) (match (intmap-ref cps k)
@ -271,7 +351,7 @@
($ $const (and (? number?) (? inexact?) (? real?)))) ($ $const (and (? number?) (? inexact?) (? real?))))
#t) #t)
(_ #f))) (_ #f)))
(compute-specializable-vars cps body preds defs exp-result-f64? 'scm->f64)) (compute-specializable-vars cps body preds defs exp-result-f64? '(scm->f64)))
;; Compute vars whose definitions are all exact integers in the u64 ;; Compute vars whose definitions are all exact integers in the u64
;; range and whose uses include an unbox operation. ;; range and whose uses include an unbox operation.
@ -285,7 +365,8 @@
#t) #t)
(_ #f))) (_ #f)))
(compute-specializable-vars cps body preds defs exp-result-u64? 'scm->u64)) (compute-specializable-vars cps body preds defs exp-result-u64?
'(scm->u64 'scm->u64/truncate)))
(define (compute-phi-vars cps preds) (define (compute-phi-vars cps preds)
(intmap-fold (lambda (label preds phis) (intmap-fold (lambda (label preds phis)