mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-10 15:50:50 +02:00
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.
This commit is contained in:
Andy Wingo
parent
dea84a46b4
commit
17bd5a8938
8 changed files with 304 additions and 36 deletions
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -357,6 +412,35 @@ BITS indicating the significant bits needed for a variable. BITS may be
|
|||
cps))
|
||||
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)
|
||||
|
|
@ -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))
|
||||
((= b-min b-max)
|
||||
(if (< b-min 0)
|
||||
(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))))
|
||||
(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
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue