Here is an updated patch. All of the code is the same but I added
docs in doc/ref/vm.texi.
- Dave
From 7d8017812a77489f362c2b9b97ee0988e5d3d7bc Mon Sep 17 00:00:00 2001
From: David Thompson <dthomps...@worcester.edu>
Date: Mon, 12 Dec 2016 22:46:08 -0500
Subject: [PATCH] Add unboxed floating point comparison instructions.
* libguile/vm-engine.c (BR_F64_ARITHMETIC): New preprocessor macro.
(br_if_f64_ee, br_if_f64_lt, br_if_f64_le, br_if_f64_gt, br_if_f64_ge):
New VM instructions.
* module/language/cps/compile-bytecode.scm (compile-function): Emit f64
comparison instructions.
* module/language/cps/effects-analysis.scm: Define effects for f64
primcalls.
* module/language/cps/primitives.scm (*branching-primcall-arities*): Add
arities for f64 primcalls.
* module/language/cps/specialize-numbers.scm (specialize-f64-comparison):
New procedure.
(specialize-operations): Specialize f64 comparisons.
* module/language/cps/type-fold.scm: Define branch folder aliases for
f64 primcalls.
* module/language/cps/types.scm: Define type checkers and comparison
inferrers for f64 primcalls.
(&max/f64, define-f64-comparison-inferrer): New syntax.
(infer-f64-comparison-ranges): New procedure.
* module/system/vm/assembler.scm (emit-br-if-f64-=, emit-br-if-f64-<)
(emit-br-if-f64-<=, emit-br-if-f64->, emit-br-if-f64->=): Export.
* module/system/vm/disassembler.scm (code-annotation): Add annotations
for f64 comparison instructions.
* doc/ref/vm.texi ("Unboxed Floating-Point Arithmetic"): Document new
instructions.
---
doc/ref/vm.texi | 11 +++++
libguile/vm-engine.c | 68 +++++++++++++++++++++++++++---
module/language/cps/compile-bytecode.scm | 7 ++-
module/language/cps/effects-analysis.scm | 5 +++
module/language/cps/primitives.scm | 7 ++-
module/language/cps/specialize-numbers.scm | 49 +++++++++++++++------
module/language/cps/type-fold.scm | 5 +++
module/language/cps/types.scm | 30 +++++++++++++
module/system/vm/assembler.scm | 5 +++
module/system/vm/disassembler.scm | 2 +
10 files changed, 168 insertions(+), 21 deletions(-)
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 1abbbce..b61d05f 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -1665,6 +1665,17 @@ Load a 64-bit value formed by joining @var{high-bits} and
@var{low-bits}, and write it to @var{dst}.
@end deftypefn
+@deftypefn Instruction {} br-if-f64-= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-f64-< s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-f64-<= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-f64-> s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+@deftypefnx Instruction {} br-if-f64->= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset}
+If the unboxed IEEE double value in @var{a} is @code{=}, @code{<},
+@code{<=}, @code{>}, or @code{>=} to the unboxed IEEE double value in
+@var{b}, respectively, add @var{offset} to the current instruction
+pointer.
+@end deftypefn
+
@deftypefn Instruction {} fadd s8:@var{dst} s8:@var{a} s8:@var{b}
@deftypefnx Instruction {} fsub s8:@var{dst} s8:@var{a} s8:@var{b}
@deftypefnx Instruction {} fmul s8:@var{dst} s8:@var{a} s8:@var{b}
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4406845..6a7ba51 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -358,6 +358,24 @@
NEXT (3); \
}
+#define BR_F64_ARITHMETIC(crel) \
+ { \
+ scm_t_uint32 a, b; \
+ scm_t_uint64 x, y; \
+ UNPACK_24 (op, a); \
+ UNPACK_24 (ip[1], b); \
+ x = SP_REF_F64 (a); \
+ y = SP_REF_F64 (b); \
+ if ((ip[2] & 0x1) ? !(x crel y) : (x crel y)) \
+ { \
+ scm_t_int32 offset = ip[2]; \
+ offset >>= 8; /* Sign-extending shift. */ \
+ NEXT (offset); \
+ } \
+ NEXT (3); \
+ }
+
+
#define ARGS1(a1) \
scm_t_uint16 dst, src; \
SCM a1; \
@@ -3950,11 +3968,51 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (1);
}
- VM_DEFINE_OP (187, unused_187, NULL, NOP)
- VM_DEFINE_OP (188, unused_188, NULL, NOP)
- VM_DEFINE_OP (189, unused_189, NULL, NOP)
- VM_DEFINE_OP (190, unused_190, NULL, NOP)
- VM_DEFINE_OP (191, unused_191, NULL, NOP)
+ /* br-if-f64= a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the F64 value in A is = to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (187, br_if_f64_ee, "br-if-f64-=", OP3 (X8_S24, X8_S24, B1_X7_L24))
+ {
+ BR_F64_ARITHMETIC (==);
+ }
+
+ /* br-if-f64< a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the F64 value in A is < to the value in B, add OFFSET, a signed
+ * 24-bit number, to the current instruction pointer.
+ */
+ VM_DEFINE_OP (188, br_if_f64_lt, "br-if-f64-<", OP3 (X8_S24, X8_S24, B1_X7_L24))
+ {
+ BR_F64_ARITHMETIC (<);
+ }
+
+ VM_DEFINE_OP (189, br_if_f64_le, "br-if-f64-<=", OP3 (X8_S24, X8_S24, B1_X7_L24))
+ {
+ BR_F64_ARITHMETIC (<=);
+ }
+
+ /* br-if-f64-> a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the F64 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 (190, br_if_f64_gt, "br-if-f64->", OP3 (X8_S24, X8_S24, B1_X7_L24))
+ {
+ BR_F64_ARITHMETIC (>);
+ }
+
+ /* br-if-uf4->= a:24 _:8 b:24 invert:1 _:7 offset:24
+ *
+ * If the F64 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 (191, br_if_f64_ge, "br-if-f64->=", OP3 (X8_S24, X8_S24, B1_X7_L24))
+ {
+ BR_F64_ARITHMETIC (>=);
+ }
+
VM_DEFINE_OP (192, unused_192, NULL, NOP)
VM_DEFINE_OP (193, unused_193, NULL, NOP)
VM_DEFINE_OP (194, unused_194, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index db5b8fa..a3f8ba4 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -446,7 +446,12 @@
(($ $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))))
+ (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))
+ (($ $primcall 'f64-< (a b)) (binary emit-br-if-f64-< a b))
+ (($ $primcall 'f64-<= (a b)) (binary emit-br-if-f64-<= a b))
+ (($ $primcall 'f64-= (a b)) (binary emit-br-if-f64-= a b))
+ (($ $primcall 'f64->= (a b)) (binary emit-br-if-f64->= a b))
+ (($ $primcall 'f64-> (a b)) (binary emit-br-if-f64-> a b))))
(define (compile-trunc label k exp nreq rest-var)
(define (do-call proc args emit-call)
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 9ce6585..f1833bb 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -439,6 +439,11 @@ is or might be a read or a write to the same location as A."
((u64-=-scm . _) &type-check)
((u64->=-scm . _) &type-check)
((u64->-scm . _) &type-check)
+ ((f64-= . _))
+ ((f64-< . _))
+ ((f64-> . _))
+ ((f64-<= . _))
+ ((f64->= . _))
((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 bc03c98..a3e6e38 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -99,7 +99,12 @@
(u64-=-scm . (1 . 2))
(u64->=-scm . (1 . 2))
(u64->-scm . (1 . 2))
- (logtest . (1 . 2))))
+ (logtest . (1 . 2))
+ (f64-= . (1 . 2))
+ (f64-< . (1 . 2))
+ (f64-> . (1 . 2))
+ (f64-<= . (1 . 2))
+ (f64->= . (1 . 2))))
(define (compute-prim-instructions)
(let ((table (make-hash-table)))
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm
index d9fe76c..6c8627a 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -144,6 +144,20 @@
($continue kop src
($primcall 'scm->u64 (a-u64)))))))
+(define (specialize-f64-comparison cps kf kt src op a b)
+ (let ((op (symbol-append 'f64- op)))
+ (with-cps cps
+ (letv f64-a f64-b)
+ (letk kop ($kargs ('f64-b) (f64-b)
+ ($continue kf src
+ ($branch kt ($primcall op (f64-a f64-b))))))
+ (letk kunbox-b ($kargs ('f64-a) (f64-a)
+ ($continue kop src
+ ($primcall 'scm->f64 (b)))))
+ (build-term
+ ($continue kunbox-b src
+ ($primcall 'scm->f64 (a)))))))
+
(define (sigbits-union x y)
(and x y (logior x y)))
@@ -283,6 +297,8 @@ BITS indicating the significant bits needed for a variable. BITS may be
(lambda (type min max)
(and (eqv? type &exact-integer)
(<= 0 min max #xffffffffffffffff))))))
+ (define (f64-operand? var)
+ (operand-in-range? var &flonum -inf.0 +inf.0))
(match cont
(($ $kfun)
(let ((types (infer-types cps label)))
@@ -387,20 +403,25 @@ BITS indicating the significant bits needed for a variable. BITS may be
($ $continue k src
($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
(values
- (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))
+ (cond
+ ((or (f64-operand? a) (f64-operand? b))
+ (with-cps cps
+ (let$ body (specialize-f64-comparison k kt src op a b))
+ (setk label ($kargs names vars ,body))))
+ ((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)))))
+ ((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)))))
+ (else cps))
types
sigbits))
(_ (values cps types sigbits))))
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 9459e31..a688292 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -110,6 +110,7 @@
(else (values #f #f))))
(define-branch-folder-alias u64-< <)
(define-branch-folder-alias u64-<-scm <)
+(define-branch-folder-alias f64-< <)
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -118,6 +119,7 @@
(else (values #f #f))))
(define-branch-folder-alias u64-<= <=)
(define-branch-folder-alias u64-<=-scm <=)
+(define-branch-folder-alias f64-<= <=)
(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -126,6 +128,7 @@
(else (values #f #f))))
(define-branch-folder-alias u64-= =)
(define-branch-folder-alias u64-=-scm =)
+(define-branch-folder-alias f64-= =)
(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -134,6 +137,7 @@
(else (values #f #f))))
(define-branch-folder-alias u64->= >=)
(define-branch-folder-alias u64->=-scm >=)
+(define-branch-folder-alias f64->= >=)
(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)
@@ -142,6 +146,7 @@
(else (values #f #f))))
(define-branch-folder-alias u64-> >)
(define-branch-folder-alias u64->-scm >)
+(define-branch-folder-alias f64-> >)
(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 c7e4211..b3d4b4a 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -378,6 +378,7 @@ minimum, and maximum."
(define-syntax-rule (&max/u64 x) (min (&max x) &u64-max))
(define-syntax-rule (&min/s64 x) (max (&min x) &s64-min))
(define-syntax-rule (&max/s64 x) (min (&max x) &s64-max))
+(define-syntax-rule (&max/f64 x) (min (&max x) +inf.0))
(define-syntax-rule (&max/size x) (min (&max x) *max-size-t*))
(define-syntax-rule (define-type-checker (name arg ...) body ...)
@@ -945,6 +946,35 @@ minimum, and maximum."
(define-simple-type-checker (u64-> &u64 &u64))
(define-u64-comparison-inferrer (u64-> > <=))
+(define (infer-f64-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-f64-comparison-inferrer (f64-op op inverse))
+ (define-predicate-inferrer (f64-op a b true?)
+ (call-with-values
+ (lambda ()
+ (infer-f64-comparison-ranges (if true? 'op 'inverse)
+ (&min/0 a) (&max/f64 a)
+ (&min/0 b) (&max/f64 b)))
+ (lambda (min0 max0 min1 max1)
+ (restrict! a &f64 min0 max0)
+ (restrict! b &f64 min1 max1)))))
+
+(define-simple-type-checker (f64-< &f64 &f64))
+(define-f64-comparison-inferrer (f64-< < >=))
+
+(define-simple-type-checker (f64-<= &f64 &f64))
+(define-f64-comparison-inferrer (f64-<= <= >))
+
+(define-simple-type-checker (f64->= &f64 &f64))
+(define-f64-comparison-inferrer (f64-<= >= <))
+
+(define-simple-type-checker (f64-> &f64 &f64))
+(define-f64-comparison-inferrer (f64-> > <=))
+
;; 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 2c6bf81..226a223 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -106,6 +106,11 @@
emit-br-if-u64-=-scm
emit-br-if-u64->=-scm
emit-br-if-u64->-scm
+ emit-br-if-f64-=
+ emit-br-if-f64-<
+ emit-br-if-f64-<=
+ emit-br-if-f64->
+ emit-br-if-f64->=
emit-box
emit-box-ref
emit-box-set!
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index b0867e6..b6f4f78 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -198,6 +198,8 @@ address of that offset."
'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-f64-= 'br-if-f64-< 'br-if-f64-<=
+ 'br-if-f64-> 'br-if-f64->=
'br-if-logtest) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
(('br-if-tc7 slot invert? tc7 target)
--
2.8.3
