[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 21/41: Add instructions to branch on u64 comparisons
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 21/41: Add instructions to branch on u64 comparisons |
|
Date: |
Wed, 02 Dec 2015 08:06:52 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 07607f66b81f644077fc734b591da2aa84af10e2
Author: Andy Wingo <address@hidden>
Date: Thu Nov 19 22:49:54 2015 +0100
Add instructions to branch on u64 comparisons
* libguile/vm-engine.c (BR_U64_ARITHMETIC): New helper.
(br-if-u64-=, br-if-u64-<, br-if-u64->=): New instructions.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm (u64-=, infer-u64-comparison-ranges):
(define-u64-comparison-inferrer, u64-<, u64-<=, u64->=, u64->):
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm (code-annotation):
(compute-labels): Compiler and toolchain support for the new
instructions.
---
libguile/vm-engine.c | 47 ++++++++++++++++++++++++++++--
module/language/cps/compile-bytecode.scm | 5 +++
module/language/cps/effects-analysis.scm | 5 +++
module/language/cps/primitives.scm | 5 +++
module/language/cps/type-fold.scm | 9 +++++-
module/language/cps/types.scm | 37 +++++++++++++++++++++++
module/system/vm/assembler.scm | 3 ++
module/system/vm/disassembler.scm | 4 ++-
8 files changed, 110 insertions(+), 5 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 2839763..e7994cd 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -376,6 +376,25 @@
} \
}
+#define BR_U64_ARITHMETIC(crel,srel) \
+ { \
+ scm_t_uint32 a, b; \
+ scm_t_uint64 x, y; \
+ UNPACK_24 (op, a); \
+ UNPACK_24 (ip[1], b); \
+ x = SP_REF_U64 (a); \
+ y = SP_REF_U64 (b); \
+ if ((ip[2] & 0x1) ? !(x crel y) : (x crel y)) \
+ { \
+ scm_t_int32 offset = ip[2]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (3); \
+ }
+
#define ARGS1(a1) \
scm_t_uint16 dst, src; \
SCM a1; \
@@ -3358,9 +3377,31 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (146, unused_146, NULL, NOP)
- VM_DEFINE_OP (147, unused_147, NULL, NOP)
- VM_DEFINE_OP (148, unused_148, NULL, NOP)
+ /* br-if-= a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is = to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (146, br_if_u64_ee, "br-if-u64-=", OP3 (X8_S24, X8_S24,
B1_X7_L24))
+ {
+ BR_U64_ARITHMETIC (==, scm_num_eq_p);
+ }
+
+ /* br-if-< a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the value in A is < to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (147, br_if_u64_lt, "br-if-u64-<", OP3 (X8_S24, X8_S24,
B1_X7_L24))
+ {
+ BR_U64_ARITHMETIC (<, scm_less_p);
+ }
+
+ VM_DEFINE_OP (148, br_if_u64_le, "br-if-u64-<=", OP3 (X8_S24, X8_S24,
B1_X7_L24))
+ {
+ BR_U64_ARITHMETIC (<=, scm_leq_p);
+ }
+
VM_DEFINE_OP (149, unused_149, NULL, NOP)
VM_DEFINE_OP (150, unused_150, NULL, NOP)
VM_DEFINE_OP (151, unused_151, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 9e659e2..2a6370c 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -373,6 +373,11 @@
(($ $primcall '= (a b)) (binary emit-br-if-= a b))
(($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
(($ $primcall '> (a b)) (binary emit-br-if-< b a))
+ (($ $primcall 'u64-< (a b)) (binary emit-br-if-u64-< a b))
+ (($ $primcall 'u64-<= (a b)) (binary emit-br-if-u64-<= a b))
+ (($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b))
+ (($ $primcall 'u64->= (a b)) (binary emit-br-if-u64-<= b a))
+ (($ $primcall 'u64-> (a b)) (binary emit-br-if-u64-< b a))
(($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
(define (compile-trunc label k exp nreq rest-var)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 5b5bf17..fc82293 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -411,6 +411,11 @@ is or might be a read or a write to the same location as
A."
((> . _) &type-check)
((<= . _) &type-check)
((>= . _) &type-check)
+ ((u64-= . _))
+ ((u64-< . _))
+ ((u64-> . _))
+ ((u64-<= . _))
+ ((u64->= . _))
((zero? . _) &type-check)
((add . _) &type-check)
((mul . _) &type-check)
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 80c01f0..3628b5c 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -88,6 +88,11 @@
(> . (1 . 2))
(<= . (1 . 2))
(>= . (1 . 2))
+ (u64-= . (1 . 2))
+ (u64-< . (1 . 2))
+ (u64-> . (1 . 2))
+ (u64-<= . (1 . 2))
+ (u64->= . (1 . 2))
(logtest . (1 . 2))))
(define (compute-prim-instructions)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index c370306..e3939e0 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -93,7 +93,9 @@
(define-branch-folder-alias eqv? eq?)
(define (compare-ranges type0 min0 max0 type1 min1 max1)
- (and (zero? (logand (logior type0 type1) (lognot &real)))
+ ;; Since &real, &u64, and &f64 are disjoint, we can compare once
+ ;; against their mask instead of doing three "or" comparisons.
+ (and (zero? (logand (logior type0 type1) (lognot (logior &real &f64 &u64))))
(cond ((< max0 min1) '<)
((> min0 max1) '>)
((= min0 max0 min1 max1) '=)
@@ -106,30 +108,35 @@
((<) (values #t #t))
((= >= >) (values #t #f))
(else (values #f #f))))
+(define-branch-folder-alias u64-< <)
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((< <= =) (values #t #t))
((>) (values #t #f))
(else (values #f #f))))
+(define-branch-folder-alias u64-<= <=)
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((=) (values #t #t))
((< >) (values #t #f))
(else (values #f #f))))
+(define-branch-folder-alias u64-= =)
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((> >= =) (values #t #t))
((<) (values #t #f))
(else (values #f #f))))
+(define-branch-folder-alias u64->= >=)
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
((>) (values #t #t))
((= <= <) (values #t #f))
(else (values #f #f))))
+(define-branch-folder-alias u64-> >)
(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
(define (logand-min a b)
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 857a372..81d2eb1 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -835,6 +835,43 @@ minimum, and maximum."
(define-simple-type-checker (> &real &real))
(define-comparison-inferrer (> <=))
+(define-simple-type-checker (u64-= &u64 &u64))
+(define-predicate-inferrer (u64-= a b true?)
+ (when true?
+ (let ((min (max (&min a) (&min b)))
+ (max (min (&max a) (&max b))))
+ (restrict! a &u64 min max)
+ (restrict! b &u64 min max))))
+
+(define (infer-u64-comparison-ranges op min0 max0 min1 max1)
+ (match op
+ ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
+ ('<= (values min0 (min max0 max1) (max min0 min1) max1))
+ ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
+ ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
+(define-syntax-rule (define-u64-comparison-inferrer (u64-op op inverse))
+ (define-predicate-inferrer (u64-op a b true?)
+ (call-with-values
+ (lambda ()
+ (infer-u64-comparison-ranges (if true? 'op 'inverse)
+ (&min a) (&max a)
+ (&min b) (&max b)))
+ (lambda (min0 max0 min1 max1)
+ (restrict! a &u64 min0 max0)
+ (restrict! b &u64 min1 max1)))))
+
+(define-simple-type-checker (u64-< &u64 &u64))
+(define-u64-comparison-inferrer (u64-< < >=))
+
+(define-simple-type-checker (u64-<= &u64 &u64))
+(define-u64-comparison-inferrer (u64-<= <= >))
+
+(define-simple-type-checker (u64->= &u64 &u64))
+(define-u64-comparison-inferrer (u64-<= >= <))
+
+(define-simple-type-checker (u64-> &u64 &u64))
+(define-u64-comparison-inferrer (u64-> > <=))
+
;; Arithmetic.
(define-syntax-rule (define-unary-result! a result min max)
(let ((min* min)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8155ebe..0ee3918 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -95,6 +95,9 @@
emit-br-if-<
emit-br-if-<=
emit-br-if-logtest
+ emit-br-if-u64-=
+ emit-br-if-u64-<
+ emit-br-if-u64-<=
(emit-mov* . emit-mov)
(emit-fmov* . emit-fmov)
(emit-box* . emit-box)
diff --git a/module/system/vm/disassembler.scm
b/module/system/vm/disassembler.scm
index d90c885..b071254 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -195,6 +195,7 @@ address of that offset."
'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
'br-if-char 'br-if-eq 'br-if-eqv
'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
+ 'br-if-u64-= 'br-if-u64-< 'br-if-u64-<=
'br-if-logtest) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
(('br-if-tc7 slot invert? tc7 target)
@@ -296,7 +297,8 @@ address of that offset."
br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
br-if-true br-if-null br-if-nil br-if-pair br-if-struct
br-if-char br-if-tc7 br-if-eq br-if-eqv
- br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
+ br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest
+ br-if-u64-= br-if-u64-< br-if-u64-<=)
(match arg
((_ ... target)
(add-label! (+ offset target) "L"))))
- [Guile-commits] 13/41: Remove `procedure' repl command, (continued)
- [Guile-commits] 13/41: Remove `procedure' repl command, Andy Wingo, 2015/12/02
- [Guile-commits] 14/41: VM traps don't match on value of slot 0, Andy Wingo, 2015/12/02
- [Guile-commits] 17/41: Remove frame->module, Andy Wingo, 2015/12/02
- [Guile-commits] 19/41: Add bv-length instruction, Andy Wingo, 2015/12/02
- [Guile-commits] 18/41: Range inference over the full U64+S64 range, Andy Wingo, 2015/12/02
- [Guile-commits] 20/41: bv-f{32, 64}-{ref, set!} take unboxed u64 index, Andy Wingo, 2015/12/02
- [Guile-commits] 23/41: Beginning of u64 phi unboxing, Andy Wingo, 2015/12/02
- [Guile-commits] 16/41: Add low-level support for unboxed 64-bit unsigned ints, Andy Wingo, 2015/12/02
- [Guile-commits] 22/41: Specialize u64 comparisons, Andy Wingo, 2015/12/02
- [Guile-commits] 26/41: Slower range saturation in type inference, Andy Wingo, 2015/12/02
- [Guile-commits] 21/41: Add instructions to branch on u64 comparisons,
Andy Wingo <=
- [Guile-commits] 25/41: Add unsigned 64-bit arithmetic operators: uadd, usub, umul, Andy Wingo, 2015/12/02
- [Guile-commits] 24/41: Unbox u64 phi values, Andy Wingo, 2015/12/02
- [Guile-commits] 28/41: Specialize u64 arithmetic, Andy Wingo, 2015/12/02
- [Guile-commits] 37/41: Disable warnings on bootstrap build, Andy Wingo, 2015/12/02
- [Guile-commits] 35/41: Add current-thread VM op, Andy Wingo, 2015/12/02
- [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