From 07607f66b81f644077fc734b591da2aa84af10e2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Nov 2015 22:49:54 +0100 Subject: [PATCH] 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. --- libguile/vm-engine.c | 47 ++++++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 5 +++ module/language/cps/effects-analysis.scm | 5 +++ module/language/cps/primitives.scm | 5 +++ module/language/cps/type-fold.scm | 9 ++++- module/language/cps/types.scm | 37 +++++++++++++++++++ module/system/vm/assembler.scm | 3 ++ module/system/vm/disassembler.scm | 4 +- 8 files changed, 110 insertions(+), 5 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 2839763cb..e7994cd32 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -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) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 9e659e261..2a6370c25 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -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) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 5b5bf1720..fc8229386 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 80c01f0e2..3628b5cf7 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -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) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index c3703064c..e3939e0b6 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -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) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 857a3724d..81d2eb1eb 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8155ebe3a..0ee391822 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index d90c88505..b0712540c 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -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"))))