diff options
-rw-r--r-- | libguile/vm-engine.c | 98 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 5 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 5 | ||||
-rw-r--r-- | module/language/cps/primitives.scm | 5 | ||||
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 30 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 5 | ||||
-rw-r--r-- | module/language/cps/types.scm | 47 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 5 | ||||
-rw-r--r-- | module/system/vm/disassembler.scm | 6 |
9 files changed, 187 insertions, 19 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 34b95fbd6..0bd3e78e9 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3640,11 +3640,99 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (170, unused_170, NULL, NOP) - VM_DEFINE_OP (171, unused_171, NULL, NOP) - VM_DEFINE_OP (172, unused_172, NULL, NOP) - VM_DEFINE_OP (173, unused_173, NULL, NOP) - VM_DEFINE_OP (174, unused_174, NULL, NOP) +#define BR_U64_SCM_COMPARISON(x, y, unboxed, boxed) \ + do { \ + scm_t_uint32 a, b; \ + scm_t_uint64 x; \ + SCM y_scm; \ + \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ + x = SP_REF_U64 (a); \ + y_scm = SP_REF (b); \ + \ + if (SCM_I_INUMP (y_scm)) \ + { \ + scm_t_signed_bits y = SCM_I_INUM (y_scm); \ + \ + if ((ip[2] & 0x1) ? !(unboxed) : (unboxed)) \ + { \ + scm_t_int32 offset = ip[2]; \ + offset >>= 8; /* Sign-extending shift. */ \ + if (offset <= 0) \ + VM_HANDLE_INTERRUPTS; \ + NEXT (offset); \ + } \ + NEXT (3); \ + } \ + else \ + { \ + SCM res; \ + SYNC_IP (); \ + res = boxed (scm_from_uint64 (x), y_scm); \ + CACHE_SP (); \ + if ((ip[2] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ + { \ + scm_t_int32 offset = ip[2]; \ + offset >>= 8; /* Sign-extending shift. */ \ + if (offset <= 0) \ + VM_HANDLE_INTERRUPTS; \ + NEXT (offset); \ + } \ + NEXT (3); \ + } \ + } while (0) + + /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 value in A is = to the SCM value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (170, br_if_u64_ee_scm, "br-if-u64-=-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y == x, scm_num_eq_p); + } + + /* br-if-u64-<-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 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 (171, br_if_u64_lt_scm, "br-if-u64-<-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y > x, scm_less_p); + } + + /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 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 (172, br_if_u64_le_scm, "br-if-u64-<=-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y >= x, scm_leq_p); + } + + /* br-if-u64->-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 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 (173, br_if_u64_gt_scm, "br-if-u64->-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y < 0 || (scm_t_uint64) y < x, scm_gr_p); + } + + /* br-if-u64->=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 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 (174, br_if_u64_ge_scm, "br-if-u64->=-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y <= 0 || (scm_t_uint64) y <= x, scm_geq_p); + } + VM_DEFINE_OP (175, unused_175, NULL, NOP) VM_DEFINE_OP (176, unused_176, NULL, NOP) VM_DEFINE_OP (177, unused_177, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index dc2894821..1cb85ad7b 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -415,6 +415,11 @@ (($ $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 '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 '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)))) (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 37fb7406d..70344a286 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -432,6 +432,11 @@ is or might be a read or a write to the same location as A." ((u64-> . _)) ((u64-<= . _)) ((u64->= . _)) + ((u64-<-scm . _) &type-check) + ((u64-<=-scm . _) &type-check) + ((u64-=-scm . _) &type-check) + ((u64->=-scm . _) &type-check) + ((u64->-scm . _) &type-check) ((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 d6488450d..bc03c983e 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -94,6 +94,11 @@ (u64-> . (1 . 2)) (u64-<= . (1 . 2)) (u64->= . (1 . 2)) + (u64-<-scm . (1 . 2)) + (u64-<=-scm . (1 . 2)) + (u64-=-scm . (1 . 2)) + (u64->=-scm . (1 . 2)) + (u64->-scm . (1 . 2)) (logtest . (1 . 2)))) (define (compute-prim-instructions) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 6546c73c7..24ce2095b 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -122,6 +122,17 @@ ($continue kunbox-b src ($primcall 'scm->u64 (a))))))) +(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm) + (let ((op (symbol-append 'u64- op '-scm))) + (with-cps cps + (letv u64) + (letk kop ($kargs ('u64) (u64) + ($continue kf src + ($branch kt ($primcall op (u64 b-scm)))))) + (build-term + ($continue kop src + ($primcall 'scm->u64 (a-u64))))))) + (define (specialize-operations cps) (define (visit-cont label cont cps types) (define (operand-in-range? var &type &min &max) @@ -235,11 +246,20 @@ ($ $continue k src ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) (values - (if (and (u64-operand? a) (u64-operand? b)) - (with-cps cps - (let$ body (specialize-u64-comparison k kt src op a b)) - (setk label ($kargs names vars ,body))) - cps) + (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)) types)) (_ (values cps types)))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index e3939e0b6..d935ea251 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -109,6 +109,7 @@ ((= >= >) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-< <) +(define-branch-folder-alias u64-<-scm <) (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -116,6 +117,7 @@ ((>) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-<= <=) +(define-branch-folder-alias u64-<=-scm <=) (define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -123,6 +125,7 @@ ((< >) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-= =) +(define-branch-folder-alias u64-=-scm =) (define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -130,6 +133,7 @@ ((<) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64->= >=) +(define-branch-folder-alias u64->=-scm >=) (define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -137,6 +141,7 @@ ((= <= <) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-> >) +(define-branch-folder-alias u64->-scm >) (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 a85617062..2c2a775d0 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -840,17 +840,20 @@ minimum, and maximum." (infer-integer-ranges) (infer-real-ranges))) +(define-syntax-rule (true-comparison-restrictions op a b a-type b-type) + (call-with-values + (lambda () + (restricted-comparison-ranges op + (&type a) (&min a) (&max a) + (&type b) (&min b) (&max b))) + (lambda (min0 max0 min1 max1) + (restrict! a a-type min0 max0) + (restrict! b b-type min1 max1)))) + (define-syntax-rule (define-comparison-inferrer (op inverse)) (define-predicate-inferrer (op a b true?) (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) - (call-with-values - (lambda () - (restricted-comparison-ranges (if true? 'op 'inverse) - (&type a) (&min a) (&max a) - (&type b) (&min b) (&max b))) - (lambda (min0 max0 min1 max1) - (restrict! a &real min0 max0) - (restrict! b &real min1 max1)))))) + (true-comparison-restrictions (if true? 'op 'inverse) a b &real &real)))) (define-simple-type-checker (< &real &real)) (define-comparison-inferrer (< >=)) @@ -872,6 +875,34 @@ minimum, and maximum." (restrict! a &u64 min max) (restrict! b &u64 min max)))) +(define-simple-type-checker (u64-=-scm &u64 &real)) +(define-predicate-inferrer (u64-=-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (let ((min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a &u64 min max) + (restrict! b &real min max)))) + +(define-simple-type-checker (u64-<-scm &u64 &real)) +(define-predicate-inferrer (u64-<-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '< a b &u64 &real))) + +(define-simple-type-checker (u64-<=-scm &u64 &real)) +(define-predicate-inferrer (u64-<=-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '<= a b &u64 &real))) + +(define-simple-type-checker (u64->=-scm &u64 &real)) +(define-predicate-inferrer (u64->=-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '>= a b &u64 &real))) + +(define-simple-type-checker (u64->-scm &u64 &real)) +(define-predicate-inferrer (u64->-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '> a b &u64 &real))) + (define (infer-u64-comparison-ranges op min0 max0 min1 max1) (match op ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index a4d5efc30..4fcf17296 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -98,6 +98,11 @@ emit-br-if-u64-= emit-br-if-u64-< emit-br-if-u64-<= + emit-br-if-u64-<-scm + emit-br-if-u64-<=-scm + emit-br-if-u64-=-scm + emit-br-if-u64->=-scm + emit-br-if-u64->-scm (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 6c21ad609..b0867e665 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -196,6 +196,8 @@ address of that offset." '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-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm + 'br-if-u64->-scm 'br-if-u64->=-scm 'br-if-logtest) _ ... target) (list "-> ~A" (vector-ref labels (- (+ offset target) start)))) (('br-if-tc7 slot invert? tc7 target) @@ -298,7 +300,9 @@ address of that offset." 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-u64-= br-if-u64-< br-if-u64-<=) + 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) (match arg ((_ ... target) (add-label! (+ offset target) "L")))) |