[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/04: Add support for comparing u64 values with SCM val
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/04: Add support for comparing u64 values with SCM values |
|
Date: |
Thu, 03 Dec 2015 08:07:04 +0000 |
wingo pushed a commit to branch master
in repository guile.
commit 1d4b4ec39cc7a7fa18c9e352e5ff4cc59874e039
Author: Andy Wingo <address@hidden>
Date: Thu Dec 3 09:01:24 2015 +0100
Add support for comparing u64 values with SCM values
* libguile/vm-engine.c (BR_U64_SCM_COMPARISON): New helper.
(br-if-u64-<=-scm, br-if-u64-<-scm, br-if-u64-=-scm)
(br-if-u64->-scm, br-if-u64->=-scm): New instructions, to compare an
untagged u64 with a tagged SCM. Avoids many u64->scm operations.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/type-fold.scm:
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm (code-annotation, compute-labels):
* module/language/cps/primitives.scm (*branching-primcall-arities*): Add
support for new opcodes.
* module/language/cps/specialize-numbers.scm
(specialize-u64-scm-comparison): New helper.
* module/language/cps/specialize-numbers.scm (specialize-operations):
Specialize u64 comparisons.
* module/language/cps/types.scm (true-comparison-restrictions): New helper.
(define-comparison-inferrer): Use the new helper. Add support for
u64-<-scm et al.
---
libguile/vm-engine.c | 98 ++++++++++++++++++++++++++--
module/language/cps/compile-bytecode.scm | 5 ++
module/language/cps/effects-analysis.scm | 5 ++
module/language/cps/primitives.scm | 5 ++
module/language/cps/specialize-numbers.scm | 30 +++++++--
module/language/cps/type-fold.scm | 5 ++
module/language/cps/types.scm | 47 +++++++++++--
module/system/vm/assembler.scm | 5 ++
module/system/vm/disassembler.scm | 6 ++-
9 files changed, 187 insertions(+), 19 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 34b95fb..0bd3e78 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3640,11 +3640,99 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (170, unused_170, NULL, NOP)
- VM_DEFINE_OP (171, unused_171, NULL, NOP)
- VM_DEFINE_OP (172, unused_172, NULL, NOP)
- VM_DEFINE_OP (173, unused_173, NULL, NOP)
- VM_DEFINE_OP (174, unused_174, NULL, NOP)
+#define BR_U64_SCM_COMPARISON(x, y, unboxed, boxed) \
+ do { \
+ scm_t_uint32 a, b; \
+ scm_t_uint64 x; \
+ SCM y_scm; \
+ \
+ UNPACK_24 (op, a); \
+ UNPACK_24 (ip[1], b); \
+ x = SP_REF_U64 (a); \
+ y_scm = SP_REF (b); \
+ \
+ if (SCM_I_INUMP (y_scm)) \
+ { \
+ scm_t_signed_bits y = SCM_I_INUM (y_scm); \
+ \
+ if ((ip[2] & 0x1) ? !(unboxed) : (unboxed)) \
+ { \
+ scm_t_int32 offset = ip[2]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (3); \
+ } \
+ else \
+ { \
+ SCM res; \
+ SYNC_IP (); \
+ res = boxed (scm_from_uint64 (x), y_scm); \
+ CACHE_SP (); \
+ if ((ip[2] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \
+ { \
+ scm_t_int32 offset = ip[2]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ if (offset <= 0) \
+ VM_HANDLE_INTERRUPTS; \
+ NEXT (offset); \
+ } \
+ NEXT (3); \
+ } \
+ } while (0)
+
+ /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the U64 value in A is = to the SCM value in B, add OFFSET, a
+ * signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (170, br_if_u64_ee_scm, "br-if-u64-=-scm", OP3 (X8_S24, X8_S24,
B1_X7_L24))
+ {
+ BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y == x,
scm_num_eq_p);
+ }
+
+ /* br-if-u64-<-scm a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the U64 value in A is < than the SCM value in B, add OFFSET, a
+ * signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (171, br_if_u64_lt_scm, "br-if-u64-<-scm", OP3 (X8_S24, X8_S24,
B1_X7_L24))
+ {
+ BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y > x, scm_less_p);
+ }
+
+ /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the U64 value in A is <= than the SCM value in B, add OFFSET, a
+ * signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (172, br_if_u64_le_scm, "br-if-u64-<=-scm", OP3 (X8_S24,
X8_S24, B1_X7_L24))
+ {
+ BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y >= x, scm_leq_p);
+ }
+
+ /* br-if-u64->-scm a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the U64 value in A is > than the SCM value in B, add OFFSET, a
+ * signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (173, br_if_u64_gt_scm, "br-if-u64->-scm", OP3 (X8_S24, X8_S24,
B1_X7_L24))
+ {
+ BR_U64_SCM_COMPARISON(x, y, y < 0 || (scm_t_uint64) y < x, scm_gr_p);
+ }
+
+ /* br-if-u64->=-scm a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the U64 value in A is >= than the SCM value in B, add OFFSET, a
+ * signed 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (174, br_if_u64_ge_scm, "br-if-u64->=-scm", OP3 (X8_S24,
X8_S24, B1_X7_L24))
+ {
+ BR_U64_SCM_COMPARISON(x, y, y <= 0 || (scm_t_uint64) y <= x, scm_geq_p);
+ }
+
VM_DEFINE_OP (175, unused_175, NULL, NOP)
VM_DEFINE_OP (176, unused_176, NULL, NOP)
VM_DEFINE_OP (177, unused_177, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index dc28948..1cb85ad 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -415,6 +415,11 @@
(($ $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 'u64-<-scm (a b)) (binary emit-br-if-u64-<-scm a b))
+ (($ $primcall 'u64-<=-scm (a b)) (binary emit-br-if-u64-<=-scm a b))
+ (($ $primcall 'u64-=-scm (a b)) (binary emit-br-if-u64-=-scm a b))
+ (($ $primcall 'u64->=-scm (a b)) (binary emit-br-if-u64->=-scm a b))
+ (($ $primcall 'u64->-scm (a b)) (binary emit-br-if-u64->-scm a b))
(($ $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 37fb740..70344a2 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -432,6 +432,11 @@ is or might be a read or a write to the same location as
A."
((u64-> . _))
((u64-<= . _))
((u64->= . _))
+ ((u64-<-scm . _) &type-check)
+ ((u64-<=-scm . _) &type-check)
+ ((u64-=-scm . _) &type-check)
+ ((u64->=-scm . _) &type-check)
+ ((u64->-scm . _) &type-check)
((zero? . _) &type-check)
((add . _) &type-check)
((add/immediate . _) &type-check)
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index d648845..bc03c98 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -94,6 +94,11 @@
(u64-> . (1 . 2))
(u64-<= . (1 . 2))
(u64->= . (1 . 2))
+ (u64-<-scm . (1 . 2))
+ (u64-<=-scm . (1 . 2))
+ (u64-=-scm . (1 . 2))
+ (u64->=-scm . (1 . 2))
+ (u64->-scm . (1 . 2))
(logtest . (1 . 2))))
(define (compute-prim-instructions)
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index 6546c73..24ce209 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -122,6 +122,17 @@
($continue kunbox-b src
($primcall 'scm->u64 (a)))))))
+(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm)
+ (let ((op (symbol-append 'u64- op '-scm)))
+ (with-cps cps
+ (letv u64)
+ (letk kop ($kargs ('u64) (u64)
+ ($continue kf src
+ ($branch kt ($primcall op (u64 b-scm))))))
+ (build-term
+ ($continue kop src
+ ($primcall 'scm->u64 (a-u64)))))))
+
(define (specialize-operations cps)
(define (visit-cont label cont cps types)
(define (operand-in-range? var &type &min &max)
@@ -235,11 +246,20 @@
($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a
b)))))
(values
- (if (and (u64-operand? a) (u64-operand? b))
- (with-cps cps
- (let$ body (specialize-u64-comparison k kt src op a b))
- (setk label ($kargs names vars ,body)))
- cps)
+ (if (u64-operand? a)
+ (let ((specialize (if (u64-operand? b)
+ specialize-u64-comparison
+ specialize-u64-scm-comparison)))
+ (with-cps cps
+ (let$ body (specialize k kt src op a b))
+ (setk label ($kargs names vars ,body))))
+ (if (u64-operand? b)
+ (let ((op (match op
+ ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<))))
+ (with-cps cps
+ (let$ body (specialize-u64-scm-comparison k kt src op b a))
+ (setk label ($kargs names vars ,body))))
+ cps))
types))
(_ (values cps types))))
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index e3939e0..d935ea2 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -109,6 +109,7 @@
((= >= >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-< <)
+(define-branch-folder-alias u64-<-scm <)
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -116,6 +117,7 @@
((>) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-<= <=)
+(define-branch-folder-alias u64-<=-scm <=)
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -123,6 +125,7 @@
((< >) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-= =)
+(define-branch-folder-alias u64-=-scm =)
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -130,6 +133,7 @@
((<) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64->= >=)
+(define-branch-folder-alias u64->=-scm >=)
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -137,6 +141,7 @@
((= <= <) (values #t #f))
(else (values #f #f))))
(define-branch-folder-alias u64-> >)
+(define-branch-folder-alias u64->-scm >)
(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 a856170..2c2a775 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -840,17 +840,20 @@ minimum, and maximum."
(infer-integer-ranges)
(infer-real-ranges)))
+(define-syntax-rule (true-comparison-restrictions op a b a-type b-type)
+ (call-with-values
+ (lambda ()
+ (restricted-comparison-ranges op
+ (&type a) (&min a) (&max a)
+ (&type b) (&min b) (&max b)))
+ (lambda (min0 max0 min1 max1)
+ (restrict! a a-type min0 max0)
+ (restrict! b b-type min1 max1))))
+
(define-syntax-rule (define-comparison-inferrer (op inverse))
(define-predicate-inferrer (op a b true?)
(when (zero? (logand (logior (&type a) (&type b)) (lognot &number)))
- (call-with-values
- (lambda ()
- (restricted-comparison-ranges (if true? 'op 'inverse)
- (&type a) (&min a) (&max a)
- (&type b) (&min b) (&max b)))
- (lambda (min0 max0 min1 max1)
- (restrict! a &real min0 max0)
- (restrict! b &real min1 max1))))))
+ (true-comparison-restrictions (if true? 'op 'inverse) a b &real &real))))
(define-simple-type-checker (< &real &real))
(define-comparison-inferrer (< >=))
@@ -872,6 +875,34 @@ minimum, and maximum."
(restrict! a &u64 min max)
(restrict! b &u64 min max))))
+(define-simple-type-checker (u64-=-scm &u64 &real))
+(define-predicate-inferrer (u64-=-scm a b true?)
+ (when (and true? (zero? (logand (&type b) (lognot &real))))
+ (let ((min (max (&min a) (&min b)))
+ (max (min (&max a) (&max b))))
+ (restrict! a &u64 min max)
+ (restrict! b &real min max))))
+
+(define-simple-type-checker (u64-<-scm &u64 &real))
+(define-predicate-inferrer (u64-<-scm a b true?)
+ (when (and true? (zero? (logand (&type b) (lognot &real))))
+ (true-comparison-restrictions '< a b &u64 &real)))
+
+(define-simple-type-checker (u64-<=-scm &u64 &real))
+(define-predicate-inferrer (u64-<=-scm a b true?)
+ (when (and true? (zero? (logand (&type b) (lognot &real))))
+ (true-comparison-restrictions '<= a b &u64 &real)))
+
+(define-simple-type-checker (u64->=-scm &u64 &real))
+(define-predicate-inferrer (u64->=-scm a b true?)
+ (when (and true? (zero? (logand (&type b) (lognot &real))))
+ (true-comparison-restrictions '>= a b &u64 &real)))
+
+(define-simple-type-checker (u64->-scm &u64 &real))
+(define-predicate-inferrer (u64->-scm a b true?)
+ (when (and true? (zero? (logand (&type b) (lognot &real))))
+ (true-comparison-restrictions '> a b &u64 &real)))
+
(define (infer-u64-comparison-ranges op min0 max0 min1 max1)
(match op
('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index a4d5efc..4fcf172 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -98,6 +98,11 @@
emit-br-if-u64-=
emit-br-if-u64-<
emit-br-if-u64-<=
+ emit-br-if-u64-<-scm
+ emit-br-if-u64-<=-scm
+ emit-br-if-u64-=-scm
+ emit-br-if-u64->=-scm
+ emit-br-if-u64->-scm
(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 6c21ad6..b0867e6 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -196,6 +196,8 @@ address of that offset."
'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-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm
+ 'br-if-u64->-scm 'br-if-u64->=-scm
'br-if-logtest) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
(('br-if-tc7 slot invert? tc7 target)
@@ -298,7 +300,9 @@ address of that offset."
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-u64-= br-if-u64-< br-if-u64-<=)
+ br-if-u64-= br-if-u64-< br-if-u64-<=
+ br-if-u64-<-scm br-if-u64-<=-scm br-if-u64-=-scm
+ br-if-u64->-scm br-if-u64->=-scm)
(match arg
((_ ... target)
(add-label! (+ offset target) "L"))))