summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/compile-bytecode.scm8
-rw-r--r--module/language/cps/effects-analysis.scm4
-rw-r--r--module/language/cps/specialize-numbers.scm130
-rw-r--r--module/language/cps/type-fold.scm5
-rw-r--r--module/language/cps/types.scm40
-rw-r--r--module/language/tree-il/compile-cps.scm7
-rw-r--r--module/system/vm/assembler.scm4
7 files changed, 166 insertions, 32 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 43c6d7133..2b5d7591a 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -192,6 +192,14 @@
(emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'umul/immediate y (x))
(emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'rsh (x y))
+ (emit-rsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
+ (($ $primcall 'lsh (x y))
+ (emit-lsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
+ (($ $primcall 'rsh/immediate y (x))
+ (emit-rsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
+ (($ $primcall 'lsh/immediate y (x))
+ (emit-lsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'ursh/immediate y (x))
(emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y))
(($ $primcall 'ulsh/immediate y (x))
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index e3dacaf9c..7679c7ee3 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -470,6 +470,10 @@ is or might be a read or a write to the same location as A."
((even? _) &type-check)
((odd? _) &type-check)
((ash n m) &type-check)
+ ((rsh n m) &type-check)
+ ((lsh n m) &type-check)
+ ((rsh/immediate n) &type-check)
+ ((lsh/immediate n) &type-check)
((logand . _) &type-check)
((logior . _) &type-check)
((logxor . _) &type-check)
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm
index aa08c8ff9..9daa78a3a 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -61,6 +61,46 @@
#:use-module (language cps with-cps)
#:export (specialize-numbers))
+(define (specialize-f64-unop cps k src op a b)
+ (cond
+ ((eq? op 'sub/immediate)
+ (specialize-f64-unop cps k src 'add/immediate a (- b)))
+ (else
+ (let ((fop (match op
+ ('add/immediate 'fadd/immediate)
+ ('mul/immediate 'fmul/immediate))))
+ (with-cps cps
+ (letv f64-a result)
+ (letk kbox ($kargs ('result) (result)
+ ($continue k src
+ ($primcall 'f64->scm #f (result)))))
+ (letk kop ($kargs ('f64-a) (f64-a)
+ ($continue kbox src
+ ($primcall fop b (f64-a)))))
+ (build-term
+ ($continue kop src
+ ($primcall 'scm->f64 #f (a)))))))))
+
+(define* (specialize-u64-unop cps k src op a b #:key
+ (unbox-a 'scm->u64))
+ (let ((uop (match op
+ ('add/immediate 'uadd/immediate)
+ ('sub/immediate 'usub/immediate)
+ ('mul/immediate 'umul/immediate)
+ ('rsh/immediate 'ursh/immediate)
+ ('lsh/immediate 'ulsh/immediate))))
+ (with-cps cps
+ (letv u64-a result)
+ (letk kbox ($kargs ('result) (result)
+ ($continue k src
+ ($primcall 'u64->scm #f (result)))))
+ (letk kop ($kargs ('u64-a) (u64-a)
+ ($continue kbox src
+ ($primcall uop b (u64-a)))))
+ (build-term
+ ($continue kop src
+ ($primcall unbox-a #f (a)))))))
+
(define (specialize-f64-binop cps k src op a b)
(let ((fop (match op
('add 'fadd)
@@ -92,9 +132,7 @@
('logand 'ulogand)
('logior 'ulogior)
('logxor 'ulogxor)
- ('logsub 'ulogsub)
- ('rsh 'ursh)
- ('lsh 'ulsh))))
+ ('logsub 'ulogsub))))
(with-cps cps
(letv u64-a u64-b result)
(letk kbox ($kargs ('result) (result)
@@ -110,6 +148,23 @@
($continue kunbox-b src
($primcall unbox-a #f (a)))))))
+(define* (specialize-u64-shift cps k src op a b #:key
+ (unbox-a 'scm->u64))
+ (let ((uop (match op
+ ('rsh 'ursh)
+ ('lsh 'ulsh))))
+ (with-cps cps
+ (letv u64-a result)
+ (letk kbox ($kargs ('result) (result)
+ ($continue k src
+ ($primcall 'u64->scm #f (result)))))
+ (letk kop ($kargs ('u64-a) (u64-a)
+ ($continue kbox src
+ ($primcall uop #f (u64-a b)))))
+ (build-term
+ ($continue kop src
+ ($primcall unbox-a #f (a)))))))
+
(define (truncate-u64 cps k src scm)
(with-cps cps
(letv u64)
@@ -358,6 +413,35 @@ BITS indicating the significant bits needed for a variable. BITS may be
types
sigbits))))))
(($ $kargs names vars
+ ($ $continue k src
+ ($ $primcall (and op
+ (or 'add/immediate 'sub/immediate
+ 'mul/immediate
+ 'rsh/immediate 'lsh/immediate))
+ b (a))))
+ (match (intmap-ref cps k)
+ (($ $kargs (_) (result))
+ (call-with-values (lambda ()
+ (lookup-post-type types label result 0))
+ (lambda (type min max)
+ (values
+ (cond
+ ((eqv? type &flonum)
+ (with-cps cps
+ (let$ body (specialize-f64-unop k src op a b))
+ (setk label ($kargs names vars ,body))))
+ ((and (type<=? type &exact-integer)
+ (or (<= 0 min max #xffffffffffffffff)
+ (only-u64-bits-used? result))
+ (u64-operand? a) (<= 0 b #xffffFFFFffffFFFF))
+ (with-cps cps
+ (let$ body (specialize-u64-unop k src op a b))
+ (setk label ($kargs names vars ,body))))
+ (else
+ cps))
+ types
+ sigbits))))))
+ (($ $kargs names vars
($ $continue k src ($ $primcall 'ash #f (a b))))
(match (intmap-ref cps k)
(($ $kargs (_) (result))
@@ -373,28 +457,40 @@ BITS indicating the significant bits needed for a variable. BITS may be
(<= 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 b-max)
+ (if (< b-min 0)
+ (with-cps cps
+ (let$ body
+ (specialize-u64-unop k src
+ 'rsh/immediate a (- b-min)))
+ (setk label ($kargs names vars ,body)))
+ (with-cps cps
+ (let$ body
+ (specialize-u64-unop k src
+ 'lsh/immediate a b-min))
+ (setk label ($kargs names vars ,body)))))
((< b-min 0)
(with-cps cps
(let$ body
(with-cps-constants ((zero 0))
- (letv bits)
+ (letv count ucount)
(let$ body
- (specialize-u64-binop k src 'rsh a bits))
- (letk kneg ($kargs ('bits) (bits) ,body))
- (build-term
- ($continue kneg src
- ($primcall 'sub #f (zero b))))))
+ (specialize-u64-shift k src 'rsh a ucount))
+ (letk kucount ($kargs ('ucount) (ucount) ,body))
+ (letk kcount ($kargs ('count) (count)
+ ($continue kucount src
+ ($primcall 'scm->u64 #f (count)))))
+ (build-term ($continue kcount src
+ ($primcall 'sub #f (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)))))
+ (letv ucount)
+ (let$ body (specialize-u64-shift k src 'lsh a ucount))
+ (letk kunbox ($kargs ('ucount) (ucount) ,body))
+ (setk label ($kargs names vars
+ ($continue kunbox src
+ ($primcall 'scm->u64 #f (b))))))))
types
sigbits))))))
(($ $kargs names vars
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index ce280b96c..fdbefaeb1 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -231,8 +231,7 @@
(let ((n (let lp ((bits 0) (constant constant))
(if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
(with-cps cps
- ($ (with-cps-constants ((bits n))
- (build-term ($continue k src ($primcall 'ash #f (arg bits)))))))))
+ (build-term ($continue k src ($primcall 'lsh/immediate n (arg)))))))
(define (mul/constant constant constant-type arg arg-type)
(cond
((not (or (type<=? constant-type &exact-integer)
@@ -255,7 +254,7 @@
((and (type<=? (logior constant-type arg-type) &exact-integer)
(positive? constant)
(zero? (logand constant (1- constant))))
- ;; (* arg power-of-2) -> (ash arg (log2 power-of-2
+ ;; (* arg power-of-2) -> (ash arg (log2 power-of-2))
(power-of-two constant arg))
(else
(fail))))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 4a764fb10..9561d6d92 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1372,25 +1372,45 @@ minimum, and maximum."
;; Bit operations.
(define-simple-type-checker (ash &exact-integer &exact-integer))
-(define-type-inferrer (ash val count result)
+(define-simple-type-checker (lsh &exact-integer &u64))
+(define-simple-type-checker (rsh &exact-integer &u64))
+(define (compute-ash-range min-val max-val min-shift max-shift)
(define (ash* val count)
;; As we only precisely represent a 64-bit range, don't bother inferring
;; shifts that might exceed that range.
(cond
((inf? val) val) ; Preserves sign.
- ((< -64 count 64) (ash val count))
+ ((< count 64) (ash val (max count 0)))
((zero? val) 0)
((positive? val) +inf.0)
(else -inf.0)))
+ (let ((-- (ash* min-val min-shift))
+ (-+ (ash* min-val max-shift))
+ (++ (ash* max-val max-shift))
+ (+- (ash* max-val min-shift)))
+ (values (min -- -+ ++ +-) (max -- -+ ++ +-))))
+(define-type-inferrer (ash val count result)
(restrict! val &exact-integer -inf.0 +inf.0)
(restrict! count &exact-integer -inf.0 +inf.0)
- (let ((-- (ash* (&min val) (&min count)))
- (-+ (ash* (&min val) (&max count)))
- (++ (ash* (&max val) (&max count)))
- (+- (ash* (&max val) (&min count))))
- (define-exact-integer! result
- (min -- -+ ++ +-)
- (max -- -+ ++ +-))))
+ (let-values (((min max) (compute-ash-range (&min val)
+ (&max val)
+ (&min count)
+ (&max count))))
+ (define-exact-integer! result min max)))
+(define-type-inferrer (lsh val count result)
+ (restrict! val &exact-integer -inf.0 +inf.0)
+ (let-values (((min max) (compute-ash-range (&min val)
+ (&max val)
+ (&min/0 count)
+ (&max/u64 count))))
+ (define-exact-integer! result min max)))
+(define-type-inferrer (rsh val count result)
+ (restrict! val &exact-integer -inf.0 +inf.0)
+ (let-values (((min max) (compute-ash-range (&min val)
+ (&max val)
+ (- (&min/0 count))
+ (- (&max/u64 count)))))
+ (define-exact-integer! result min max)))
(define-simple-type-checker (ursh &u64 &u64))
(define-type-inferrer (ursh a b result)
@@ -1404,8 +1424,6 @@ minimum, and maximum."
(define-simple-type-checker (ulsh &u64 &u64))
(define-type-inferrer (ulsh a b result)
- (restrict! a &u64 0 &u64-max)
- (restrict! b &u64 0 &u64-max)
(if (and (< (&max/u64 b) 64)
(<= (ash (&max/u64 a) (&max/u64 b)) &u64-max))
;; No overflow; we can be precise.
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 6835ce08e..a242da99d 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -669,7 +669,8 @@
...
(_ def)))
(define (uint? val) (and (exact-integer? val) (<= 0 val)))
- ;; FIXME: Add cases for mul, rsh, lsh
+ (define (negint? val) (and (exact-integer? val) (< val 0)))
+ ;; FIXME: Add case for mul
(specialize-case
(('make-vector ($ <const> _ (? uint? n)) init)
(make-vector/immediate n (init)))
@@ -689,6 +690,10 @@
(add/immediate y (x)))
(('sub x ($ <const> _ (? number? y)))
(sub/immediate y (x)))
+ (('ash x ($ <const> _ (? uint? y)))
+ (lsh/immediate y (x)))
+ (('ash x ($ <const> _ (? negint? y)))
+ (rsh/immediate (- y) (x)))
(_ (default))))
(when (branching-primitive? name)
(error "branching primcall in bad context" name))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 1f2189159..67ef7676a 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -189,6 +189,10 @@
emit-rem
emit-mod
emit-ash
+ emit-lsh
+ emit-rsh
+ emit-lsh/immediate
+ emit-rsh/immediate
emit-fadd
emit-fsub
emit-fmul