diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 25626a372..e04eb6cb8 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -438,7 +438,8 @@ (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) (($ $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 '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) (define (compile-trunc label k exp nreq rest-var nlocals) (define (do-call proc args emit-call) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 4c6287a91..a095fce33 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -86,7 +86,8 @@ (< . (1 . 2)) (> . (1 . 2)) (<= . (1 . 2)) - (>= . (1 . 2)))) + (>= . (1 . 2)) + (logtest . (1 . 2)))) (define (compute-prim-instructions) (let ((table (make-hash-table))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index 3dc21552b..6fc48c452 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -123,6 +123,19 @@ ((= <= <) (values #t #f)) (else (values #f #f)))) +(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) + (define (logand-min a b) + (if (< a b 0) + (min a b) + 0)) + (define (logand-max a b) + (if (< a b 0) + 0 + (max a b))) + (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer)) + (values #t (logtest min0 min1)) + (values #f #f))) + (define (compute-folded fun dfg min-label min-var) (define (scalar-value type val) (cond diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 87cfe1719..d3125bd74 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1013,23 +1013,9 @@ minimum, and maximum." (- -1 (&min a)))) (define-simple-type-checker (logtest &exact-integer &exact-integer)) -(define-type-inferrer (logtest a b result) - (define (logand-min a b) - (if (< a b 0) - (min a b) - 0)) - (define (logand-max a b) - (if (< a b 0) - 0 - (max a b))) +(define-predicate-inferrer (logtest a b true?) (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (let ((min (logand-min (&min a) (&min b))) - (max (logand-max (&max a) (&max b)))) - (if (and (= min max) (not (inf? min))) - (let ((res (if (zero? min) 0 1))) - (define! result &boolean res res)) - (define! result &exact-integer 0 1)))) + (restrict! b &exact-integer -inf.0 +inf.0)) (define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer)) (define-type-inferrer (logbit? a b result) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 787273eb7..e944e6818 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -95,6 +95,7 @@ (emit-br-if-=* . emit-br-if-=) (emit-br-if-<* . emit-br-if-<) (emit-br-if-<=* . emit-br-if-<=) + (emit-br-if-logtest* . emit-br-if-logtest) (emit-mov* . emit-mov) (emit-box* . emit-box) (emit-box-ref* . emit-box-ref) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index d41c2c1c6..adacf1b4b 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -296,7 +296,7 @@ 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-equal - br-if-= br-if-< br-if-<= br-if-> br-if->=) + br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest) (match arg ((_ ... target) (add-label! (+ offset target) "L"))))