mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

Add unboxed floating point comparison instructions.

Browse source 
* 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.
* doc/ref/vm.texi ("Unboxed Floating-Point Arithmetic"): Document them.
* 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/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.
This commit is contained in:
David Thompson 2016-12-12 22:46:08 -05:00 • committed by David Thompson
parent 63bf6ffa0d
commit 35a9059250
9 changed files with 145 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

10
doc/ref/vm.texi
View file

@ -1674,3 +1674,13 @@ the operands as unboxed IEEE double floating-point numbers, and producing
the same.
@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

73
libguile/vm-engine.c
View file

@ -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; \
@ -3935,11 +3953,56 @@ 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 F64 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 F64 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 (<);
}
/* br-if-f64-<= a:24 _:8 b:24 invert:1 _:7 offset:24
*
* If the F64 value in A is <= than the F64 value in B, add OFFSET, a
* signed 24-bit number, to the current instruction pointer.
*/
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 F64 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 F64 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)

7
module/language/cps/compile-bytecode.scm
View file

@ -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)

5
module/language/cps/effects-analysis.scm
View file

@ -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)

7
module/language/cps/primitives.scm
View file

@ -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)))

52
module/language/cps/specialize-numbers.scm
View file

@ -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)))
@ -287,6 +301,11 @@ 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)
(call-with-values (lambda ()
(lookup-pre-type types label var))
(lambda (type min max)
(and (eqv? type &flonum)))))
(match cont
(($ $kfun)
(let ((types (infer-types cps label)))
@ -391,20 +410,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))))

5
module/language/cps/type-fold.scm
View file

@ -110,6 +110,11 @@
(else (values #f #f))))
(define-branch-folder-alias u64-< <)
(define-branch-folder-alias u64-<-scm <)
;; We currently cannot define branch folders for floating point
;; comparison ops like the commented one below because we can't prove
;; there are no nans involved.
;;
;; (define-branch-folder-alias f64-< <)
(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
(case (compare-ranges type0 min0 max0 type1 min1 max1)

5
module/system/vm/assembler.scm
View file

@ -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!

2
module/system/vm/disassembler.scm
View file

@ -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)