[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 38/41: Add untagged bitwise operations
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 38/41: Add untagged bitwise operations |
|
Date: |
Wed, 02 Dec 2015 08:06:59 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 3d6dd2f81c02c37ec027e49ad25ddc57c7fbf0d1
Author: Andy Wingo <address@hidden>
Date: Tue Dec 1 10:51:00 2015 +0100
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.
---
libguile/vm-engine.c | 112 ++++++++++++++++++++++++--
module/language/cps/compile-bytecode.scm | 2 +
module/language/cps/effects-analysis.scm | 6 ++
module/language/cps/slot-allocation.scm | 3 +-
module/language/cps/specialize-primcalls.scm | 1 +
module/language/cps/types.scm | 47 +++++++++++-
module/language/cps/utils.scm | 2 +-
module/system/vm/assembler.scm | 6 ++
8 files changed, 170 insertions(+), 9 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 33d2b7b..99ff780 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -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)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 8d1c8ee..d4a5345 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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))
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 7018a11..fb64cac 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -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)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 0f5a43d..dd860be 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -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))
diff --git a/module/language/cps/specialize-primcalls.scm
b/module/language/cps/specialize-primcalls.scm
index 59c3055..710cc32 100644
--- a/module/language/cps/specialize-primcalls.scm
+++ b/module/language/cps/specialize-primcalls.scm
@@ -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
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 3f13d92..6b035dc 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -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)
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm
index 750fd17..64b403d 100644
--- a/module/language/cps/utils.scm
+++ b/module/language/cps/utils.scm
@@ -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))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 3f08d7e..f94d0f0 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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)
- [Guile-commits] 27/41: Better range inference for indexes of vector-ref, string-ref et al, (continued)
- [Guile-commits] 27/41: Better range inference for indexes of vector-ref, string-ref et al, Andy Wingo, 2015/12/02
- [Guile-commits] 29/41: Remove add1 and sub1, Andy Wingo, 2015/12/02
- [Guile-commits] 30/41: Add tagged and untagged arithmetic ops with immediate operands, Andy Wingo, 2015/12/02
- [Guile-commits] 32/41: Add support for unboxed s64 values, Andy Wingo, 2015/12/02
- [Guile-commits] 39/41: Specialize u64 bit operations, Andy Wingo, 2015/12/02
- [Guile-commits] 31/41: New instructions load-f64, load-u64, Andy Wingo, 2015/12/02
- [Guile-commits] 36/41: Add logsub op., Andy Wingo, 2015/12/02
- [Guile-commits] 40/41: More efficient assembler instructions, Andy Wingo, 2015/12/02
- [Guile-commits] 33/41: Untag values and indexes for all bytevector instructions, Andy Wingo, 2015/12/02
- [Guile-commits] 41/41: Assembler has a single growable vector, Andy Wingo, 2015/12/02
- [Guile-commits] 38/41: Add untagged bitwise operations,
Andy Wingo <=
- [Guile-commits] 34/41: Unbox indexes of vectors, strings, and structs, Andy Wingo, 2015/12/02