mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 06:20:23 +02:00
Add untagged bitwise operations
* libguile/vm-engine.c (ulogand, ulogior, ulogsub, ulsh, ursh) (scm->u64/truncate): New ops. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/types.scm: * module/language/cps/utils.scm (compute-constant-values): * module/system/vm/assembler.scm: Wire up support for the new ops.
This commit is contained in:
Andy Wingo
parent
eb86afcc7a
commit
3d6dd2f81c
8 changed files with 170 additions and 9 deletions
|
|
@ -3503,12 +3503,112 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
|
|||
RETURN_EXP (scm_logand (x, scm_lognot (y)));
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (162, unused_162, NULL, NOP)
|
||||
VM_DEFINE_OP (163, unused_163, NULL, NOP)
|
||||
VM_DEFINE_OP (164, unused_164, NULL, NOP)
|
||||
VM_DEFINE_OP (165, unused_165, NULL, NOP)
|
||||
VM_DEFINE_OP (166, unused_166, NULL, NOP)
|
||||
VM_DEFINE_OP (167, unused_167, NULL, NOP)
|
||||
/* ulogand dst:8 a:8 b:8
|
||||
*
|
||||
* Place the bitwise AND of the u64 values in A and B into DST.
|
||||
*/
|
||||
VM_DEFINE_OP (162, ulogand, "ulogand", OP1 (X8_S8_S8_S8) | OP_DST)
|
||||
{
|
||||
scm_t_uint8 dst, a, b;
|
||||
|
||||
UNPACK_8_8_8 (op, dst, a, b);
|
||||
|
||||
SP_SET_U64 (dst, SP_REF_U64 (a) & SP_REF_U64 (b));
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* ulogior dst:8 a:8 b:8
|
||||
*
|
||||
* Place the bitwise inclusive OR of the u64 values in A and B into
|
||||
* DST.
|
||||
*/
|
||||
VM_DEFINE_OP (163, ulogior, "ulogior", OP1 (X8_S8_S8_S8) | OP_DST)
|
||||
{
|
||||
scm_t_uint8 dst, a, b;
|
||||
|
||||
UNPACK_8_8_8 (op, dst, a, b);
|
||||
|
||||
SP_SET_U64 (dst, SP_REF_U64 (a) | SP_REF_U64 (b));
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* ulogsub dst:8 a:8 b:8
|
||||
*
|
||||
* Place the (A & ~B) of the u64 values A and B into DST.
|
||||
*/
|
||||
VM_DEFINE_OP (164, ulogsub, "ulogsub", OP1 (X8_S8_S8_S8) | OP_DST)
|
||||
{
|
||||
scm_t_uint8 dst, a, b;
|
||||
|
||||
UNPACK_8_8_8 (op, dst, a, b);
|
||||
|
||||
SP_SET_U64 (dst, SP_REF_U64 (a) & ~SP_REF_U64 (b));
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* ursh dst:8 a:8 b:8
|
||||
*
|
||||
* Shift the u64 value in A right by B bits, and place the result in
|
||||
* DST. Only the lower 6 bits of B are used.
|
||||
*/
|
||||
VM_DEFINE_OP (165, ursh, "ursh", OP1 (X8_S8_S8_S8) | OP_DST)
|
||||
{
|
||||
scm_t_uint8 dst, a, b;
|
||||
|
||||
UNPACK_8_8_8 (op, dst, a, b);
|
||||
|
||||
SP_SET_U64 (dst, SP_REF_U64 (a) >> (SP_REF_U64 (b) & 63));
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* ulsh dst:8 a:8 b:8
|
||||
*
|
||||
* Shift the u64 value in A left by B bits, and place the result in
|
||||
* DST. Only the lower 6 bits of B are used.
|
||||
*/
|
||||
VM_DEFINE_OP (166, ulsh, "ulsh", OP1 (X8_S8_S8_S8) | OP_DST)
|
||||
{
|
||||
scm_t_uint8 dst, a, b;
|
||||
|
||||
UNPACK_8_8_8 (op, dst, a, b);
|
||||
|
||||
SP_SET_U64 (dst, SP_REF_U64 (a) << (SP_REF_U64 (b) & 63));
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
/* scm->u64/truncate dst:12 src:12
|
||||
*
|
||||
* Unpack an exact integer from SRC and place it in the unsigned
|
||||
* 64-bit register DST, truncating any high bits. If the number in
|
||||
* SRC is negative, all the high bits will be set.
|
||||
*/
|
||||
VM_DEFINE_OP (167, scm_to_u64_truncate, "scm->u64/truncate", OP1 (X8_S12_S12) | OP_DST)
|
||||
{
|
||||
scm_t_uint16 dst, src;
|
||||
SCM x;
|
||||
|
||||
UNPACK_12_12 (op, dst, src);
|
||||
SYNC_IP ();
|
||||
x = SP_REF (src);
|
||||
|
||||
if (SCM_I_INUMP (x))
|
||||
SP_SET_U64 (dst, (scm_t_uint64) SCM_I_INUM (x));
|
||||
else
|
||||
{
|
||||
SYNC_IP ();
|
||||
SP_SET_U64 (dst,
|
||||
scm_to_uint64
|
||||
(scm_logand (x, scm_from_uint64 ((scm_t_uint64) -1))));
|
||||
}
|
||||
|
||||
NEXT (1);
|
||||
}
|
||||
|
||||
VM_DEFINE_OP (168, unused_168, NULL, NOP)
|
||||
VM_DEFINE_OP (169, unused_169, NULL, NOP)
|
||||
VM_DEFINE_OP (170, unused_170, NULL, NOP)
|
||||
|
|
|
|||
|
|
@ -204,6 +204,8 @@
|
|||
(emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'scm->u64 (src))
|
||||
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'scm->u64/truncate (src))
|
||||
(emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
|
||||
(($ $primcall 'load-u64 (src))
|
||||
(emit-load-u64 asm (from-sp dst) (constant src)))
|
||||
(($ $primcall 'u64->scm (src))
|
||||
|
|
|
|||
|
|
@ -367,6 +367,7 @@ is or might be a read or a write to the same location as A."
|
|||
((load-f64 _))
|
||||
((f64->scm _))
|
||||
((scm->u64 _) &type-check)
|
||||
((scm->u64/truncate _) &type-check)
|
||||
((load-u64 _))
|
||||
((u64->scm _))
|
||||
((scm->s64 _) &type-check)
|
||||
|
|
@ -467,6 +468,11 @@ is or might be a read or a write to the same location as A."
|
|||
((logxor . _) &type-check)
|
||||
((logsub . _) &type-check)
|
||||
((lognot . _) &type-check)
|
||||
((ulogand . _))
|
||||
((ulogior . _))
|
||||
((ulogsub . _))
|
||||
((ursh . _))
|
||||
((ulsh . _))
|
||||
((logtest a b) &type-check)
|
||||
((logbit? a b) &type-check)
|
||||
((sqrt _) &type-check)
|
||||
|
|
|
|||
|
|
@ -800,9 +800,10 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
'bv-f32-ref 'bv-f64-ref
|
||||
'fadd 'fsub 'fmul 'fdiv))
|
||||
(intmap-add representations var 'f64))
|
||||
(($ $primcall (or 'scm->u64 'load-u64
|
||||
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
|
||||
'bv-length 'vector-length 'string-length
|
||||
'uadd 'usub 'umul
|
||||
'ulogand 'ulogior 'ulogsub 'ursh 'ulsh
|
||||
'uadd/immediate 'usub/immediate 'umul/immediate
|
||||
'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref))
|
||||
(intmap-add representations var 'u64))
|
||||
|
|
|
|||
|
|
@ -66,6 +66,7 @@
|
|||
(('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x))))
|
||||
(('scm->f64 (? f64?)) (rename 'load-f64))
|
||||
(('scm->u64 (? u64?)) (rename 'load-u64))
|
||||
(('scm->u64/truncate (? u64?)) (rename 'load-u64))
|
||||
(('scm->s64 (? s64?)) (rename 'load-s64))
|
||||
(_ #f)))
|
||||
(intmap-map
|
||||
|
|
|
|||
|
|
@ -733,9 +733,15 @@ minimum, and maximum."
|
|||
(check-type scm &exact-integer 0 #xffffffffffffffff))
|
||||
(define-type-inferrer (scm->u64 scm result)
|
||||
(restrict! scm &exact-integer 0 #xffffffffffffffff)
|
||||
(define! result &u64 (max (&min scm) 0) (min (&max scm) #xffffffffffffffff)))
|
||||
(define! result &u64 (max (&min scm) 0) (min (&max scm) &u64-max)))
|
||||
(define-type-aliases scm->u64 load-u64)
|
||||
|
||||
(define-type-checker (scm->u64/truncate scm)
|
||||
(check-type scm &exact-integer &range-min &range-max))
|
||||
(define-type-inferrer (scm->u64/truncate scm result)
|
||||
(restrict! scm &exact-integer &range-min &range-max)
|
||||
(define! result &u64 0 &u64-max))
|
||||
|
||||
(define-type-checker (u64->scm u64)
|
||||
#t)
|
||||
(define-type-inferrer (u64->scm u64 result)
|
||||
|
|
@ -1190,6 +1196,25 @@ minimum, and maximum."
|
|||
(min -- -+ ++ +-)
|
||||
(max -- -+ ++ +-))))
|
||||
|
||||
(define-simple-type-checker (ursh &u64 &u64))
|
||||
(define-type-inferrer (ursh a b result)
|
||||
(restrict! a &u64 0 &u64-max)
|
||||
(restrict! b &u64 0 &u64-max)
|
||||
(define! result &u64
|
||||
(ash (&min a) (- (&max b)))
|
||||
(ash (&max a) (- (&min b)))))
|
||||
|
||||
(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 b) 64)
|
||||
(<= (ash (&max a) (&max b)) &u64-max))
|
||||
;; No overflow; we can be precise.
|
||||
(define! result &u64 (ash (&min a) (&min b)) (ash (&max a) (&max b)))
|
||||
;; Otherwise assume the whole range.
|
||||
(define! result &u64 0 &u64-max)))
|
||||
|
||||
(define (next-power-of-two n)
|
||||
(let lp ((out 1))
|
||||
(if (< n out)
|
||||
|
|
@ -1212,6 +1237,12 @@ minimum, and maximum."
|
|||
(logand-min (&min a) (&min b))
|
||||
(logand-max (&max a) (&max b))))
|
||||
|
||||
(define-simple-type-checker (ulogand &u64 &u64))
|
||||
(define-type-inferrer (ulogand a b result)
|
||||
(restrict! a &u64 0 &u64-max)
|
||||
(restrict! b &u64 0 &u64-max)
|
||||
(define! result &u64 0 (max (&max a) (&max b))))
|
||||
|
||||
(define-simple-type-checker (logsub &exact-integer &exact-integer))
|
||||
(define-type-inferrer (logsub a b result)
|
||||
(define (logsub-bounds min-a max-a min-b max-b)
|
||||
|
|
@ -1237,6 +1268,12 @@ minimum, and maximum."
|
|||
(lambda (min max)
|
||||
(define! result &exact-integer min max))))
|
||||
|
||||
(define-simple-type-checker (ulogsub &u64 &u64))
|
||||
(define-type-inferrer (ulogsub a b result)
|
||||
(restrict! a &u64 0 &u64-max)
|
||||
(restrict! b &u64 0 &u64-max)
|
||||
(define! result &u64 0 (&max a)))
|
||||
|
||||
(define-simple-type-checker (logior &exact-integer &exact-integer))
|
||||
(define-type-inferrer (logior a b result)
|
||||
;; Saturate all bits of val.
|
||||
|
|
@ -1258,6 +1295,14 @@ minimum, and maximum."
|
|||
(logior-min (&min a) (&min b))
|
||||
(logior-max (&max a) (&max b))))
|
||||
|
||||
(define-simple-type-checker (ulogior &u64 &u64))
|
||||
(define-type-inferrer (ulogior a b result)
|
||||
(restrict! a &u64 0 &u64-max)
|
||||
(restrict! b &u64 0 &u64-max)
|
||||
(define! result &u64
|
||||
(max (&min a) (&min b))
|
||||
(1- (next-power-of-two (logior (&max a) (&max b))))))
|
||||
|
||||
;; For our purposes, treat logxor the same as logior.
|
||||
(define-type-aliases logior logxor)
|
||||
|
||||
|
|
|
|||
|
|
@ -214,7 +214,7 @@ disjoint, an error will be signalled."
|
|||
(if (and f64 (number? f64) (inexact? f64) (real? f64))
|
||||
(intmap-add! out var f64)
|
||||
out)))
|
||||
(($ $primcall 'scm->u64 (val))
|
||||
(($ $primcall (or 'scm->u64 'scm->u64/truncate) (val))
|
||||
(let ((u64 (intmap-ref out val (lambda (_) #f))))
|
||||
(if (and u64 (number? u64) (exact-integer? u64)
|
||||
(<= 0 u64 #xffffFFFFffffFFFF))
|
||||
|
|
|
|||
|
|
@ -153,6 +153,11 @@
|
|||
(emit-logior* . emit-logior)
|
||||
(emit-logxor* . emit-logxor)
|
||||
(emit-logsub* . emit-logsub)
|
||||
(emit-ulogand* . emit-ulogand)
|
||||
(emit-ulogior* . emit-ulogior)
|
||||
(emit-ulogsub* . emit-ulogsub)
|
||||
(emit-ursh* . emit-ursh)
|
||||
(emit-ulsh* . emit-ulsh)
|
||||
(emit-make-vector* . emit-make-vector)
|
||||
(emit-make-vector/immediate* . emit-make-vector/immediate)
|
||||
(emit-vector-length* . emit-vector-length)
|
||||
|
|
@ -173,6 +178,7 @@
|
|||
emit-load-f64
|
||||
(emit-f64->scm* . emit-f64->scm)
|
||||
(emit-scm->u64* . emit-scm->u64)
|
||||
(emit-scm->u64/truncate* . emit-scm->u64/truncate)
|
||||
emit-load-u64
|
||||
(emit-u64->scm* . emit-u64->scm)
|
||||
(emit-scm->s64* . emit-scm->s64)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue