From 7d8017812a77489f362c2b9b97ee0988e5d3d7bc Mon Sep 17 00:00:00 2001 From: David Thompson 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