[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 14/16: Add lsh, rsh instructions
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 14/16: Add lsh, rsh instructions |
|
Date: |
Sun, 5 Nov 2017 09:00:42 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 17bd5a893835b44acbfc5ee4254813e9a6ceea25
Author: Andy Wingo <address@hidden>
Date: Sun Nov 5 10:46:13 2017 +0100
Add lsh, rsh instructions
* libguile/vm-engine.c (lsh, rsh, lsh/immediate, rsh/immediate): New
instructions taking unboxed bit counts.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/specialize-numbers.scm (specialize-f64-unop):
(specialize-u64-unop): Add ability to specialize add/immediate, etc,
and add lsh/immediate as well.
(specialize-u64-binop, specialize-u64-shift): Move rsh/lsh
specialization to its own procedure, given that the bit count is
already unboxed.
(specialize-operations): Adapt to support more /immediate
instructions.
* module/language/cps/type-fold.scm (mul): Reify an lsh/immediate
instead of an ash.
* module/language/cps/types.scm (compute-ash-range): Add type inferrers
for lsh, rsh, and their immediate variants.
* module/system/vm/assembler.scm: Export emit-lsh and so on.
* module/language/tree-il/compile-cps.scm (convert): Convert "ash" on
immediates to rsh/immediate or lsh/immediate.
---
libguile/vm-engine.c | 142 ++++++++++++++++++++++++++++-
module/language/cps/compile-bytecode.scm | 8 ++
module/language/cps/effects-analysis.scm | 4 +
module/language/cps/specialize-numbers.scm | 130 ++++++++++++++++++++++----
module/language/cps/type-fold.scm | 5 +-
module/language/cps/types.scm | 40 +++++---
module/language/tree-il/compile-cps.scm | 7 +-
module/system/vm/assembler.scm | 4 +
8 files changed, 304 insertions(+), 36 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index ffbe5c1..7c0a226 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -4024,15 +4024,149 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (249, unused_249, NULL, NOP)
VM_DEFINE_OP (250, unused_250, NULL, NOP)
VM_DEFINE_OP (251, unused_251, NULL, NOP)
- VM_DEFINE_OP (252, unused_252, NULL, NOP)
- VM_DEFINE_OP (253, unused_253, NULL, NOP)
- VM_DEFINE_OP (254, unused_254, NULL, NOP)
- VM_DEFINE_OP (255, unused_255, NULL, NOP)
{
vm_error_bad_instruction (op);
abort (); /* never reached */
}
+ /* Temporary instructions down here, while we incrementally proceed
+ with instruction explosion. */
+
+ /* lsh dst:8 a:8 b:8
+ *
+ * Shift A left by B bits, and place the result in DST. B is a U64
+ * value.
+ */
+ VM_DEFINE_OP (252, lsh, "lsh", OP1 (X8_S8_S8_S8) | OP_DST)
+ {
+ scm_t_uint8 dst, x, y;
+ SCM a, result;
+ scm_t_uint64 b;
+
+ UNPACK_8_8_8 (op, dst, x, y);
+ a = SP_REF (x);
+ b = SP_REF_U64 (y);
+
+ if (SCM_LIKELY (SCM_I_INUMP (a))
+ && b < (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1)
+ && ((scm_t_bits)
+ (SCM_SRS (SCM_I_INUM (a), (SCM_I_FIXNUM_BIT-1 - b)) + 1)
+ <= 1))
+ {
+ scm_t_signed_bits nn = SCM_I_INUM (a);
+ result = SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b));
+ }
+ else
+ {
+ SYNC_IP ();
+ /* B has to be a bignum. FIXME: use instruction explosion to
+ ensure that. */
+ result = scm_ash (a, scm_from_uint64 (b));
+ CACHE_SP ();
+ }
+ SP_SET (dst, result);
+ NEXT (1);
+ }
+ /* rsh dst:8 a:8 b:8
+ *
+ * Shift A right by B bits, and place the result in DST. B is a U64
+ * value.
+ */
+ VM_DEFINE_OP (253, rsh, "rsh", OP1 (X8_S8_S8_S8) | OP_DST)
+ {
+ scm_t_uint8 dst, x, y;
+ SCM a, result;
+ scm_t_uint64 b;
+
+ UNPACK_8_8_8 (op, dst, x, y);
+ a = SP_REF (x);
+ b = SP_REF_U64 (y);
+
+ if (SCM_LIKELY (SCM_I_INUMP (a)))
+ {
+ if (b > (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1))
+ b = SCM_I_FIXNUM_BIT - 1;
+ result = SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b));
+ }
+ else
+ {
+ SYNC_IP ();
+ /* B has to be a bignum. FIXME: use instruction explosion to
+ ensure that. */
+ result = scm_ash (a, scm_difference (SCM_INUM0, scm_from_uint64
(b)));
+ CACHE_SP ();
+ }
+ SP_SET (dst, result);
+ NEXT (1);
+ }
+ /* lsh/immediate dst:8 a:8 b:8
+ *
+ * Shift A left by B bits, and place the result in DST. B is an
+ * immediate unsigned integer.
+ */
+ VM_DEFINE_OP (254, lsh_immediate, "lsh/immediate", OP1 (X8_S8_S8_C8) |
OP_DST)
+ {
+ scm_t_uint8 dst, x, y;
+ SCM a, result;
+ unsigned int b;
+
+ UNPACK_8_8_8 (op, dst, x, y);
+ a = SP_REF (x);
+ b = y;
+
+ if (SCM_LIKELY (SCM_I_INUMP (a))
+ && b < (unsigned int) (SCM_I_FIXNUM_BIT - 1)
+ && ((scm_t_bits)
+ (SCM_SRS (SCM_I_INUM (a), (SCM_I_FIXNUM_BIT-1 - b)) + 1)
+ <= 1))
+ {
+ scm_t_signed_bits nn = SCM_I_INUM (a);
+ result = SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b));
+ }
+ else
+ {
+ SYNC_IP ();
+ /* B has to be a bignum. FIXME: use instruction explosion to
+ ensure that. */
+ result = scm_ash (a, SCM_I_MAKINUM (b));
+ CACHE_SP ();
+ }
+ SP_SET (dst, result);
+ NEXT (1);
+ }
+ /* rsh dst:8 a:8 b:8
+ *
+ * Shift A right by B bits, and place the result in DST. B is an
+ * immediate unsigned integer.
+ */
+ VM_DEFINE_OP (255, rsh_immediate, "rsh/immediate", OP1 (X8_S8_S8_C8) |
OP_DST)
+ {
+ scm_t_uint8 dst, x, y;
+ SCM a, result;
+ int b;
+
+ UNPACK_8_8_8 (op, dst, x, y);
+ a = SP_REF (x);
+ b = y;
+
+ if (SCM_LIKELY (SCM_I_INUMP (a)))
+ {
+ if (b > (int) (SCM_I_FIXNUM_BIT - 1))
+ b = SCM_I_FIXNUM_BIT - 1;
+ result = SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b));
+ }
+ else
+ {
+ SYNC_IP ();
+ /* B has to be a bignum. FIXME: use instruction explosion to
+ ensure that. */
+ result = scm_ash (a, SCM_I_MAKINUM (-b));
+ CACHE_SP ();
+ }
+ SP_SET (dst, result);
+ NEXT (1);
+ }
+
END_DISPATCH_SWITCH;
}
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 43c6d71..2b5d759 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 e3dacaf..7679c7e 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 aa08c8f..9daa78a 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 ce280b9..fdbefae 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 4a764fb..9561d6d 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 6835ce0..a242da9 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 1f21891..67ef767 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
- [Guile-commits] 13/16: Earlier conversion to /imm primcalls, (continued)
- [Guile-commits] 13/16: Earlier conversion to /imm primcalls, Andy Wingo, 2017/11/05
- [Guile-commits] 02/16: cache-current-module, etc use immediate primcall parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 05/16: Immediate variants of vector-ref, etc use immediate param, Andy Wingo, 2017/11/05
- [Guile-commits] 15/16: error, scm-error primcalls expand to `throw', Andy Wingo, 2017/11/05
- [Guile-commits] 07/16: builtin-ref takes immediate parameter, Andy Wingo, 2017/11/05
- [Guile-commits] 09/16: reify-primitives reifies constants for out-of-range imm params, Andy Wingo, 2017/11/05
- [Guile-commits] 03/16: load-f64, etc take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 04/16: free-ref, free-set take immediate parameters, Andy Wingo, 2017/11/05
- [Guile-commits] 11/16: (system base types) uses target's idea of max size_t, Andy Wingo, 2017/11/05
- [Guile-commits] 16/16: Add new "throw" VM ops, Andy Wingo, 2017/11/05
- [Guile-commits] 14/16: Add lsh, rsh instructions,
Andy Wingo <=
- [Guile-commits] 06/16: Immediate parameter for struct-ref et al, Andy Wingo, 2017/11/05
- [Guile-commits] 08/16: Remaining /immediate instructions take primcall imm param, Andy Wingo, 2017/11/05
- [Guile-commits] 01/16: $primcall has a "param" member, Andy Wingo, 2017/11/05