mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-14 23:50:19 +02:00
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.
This commit is contained in:
Andy Wingo
parent
87cc8b0f97
commit
07607f66b8
8 changed files with 110 additions and 5 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue