[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-75-g9243902
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-75-g9243902 |
|
Date: |
Fri, 04 Jul 2014 12:31:04 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=9243902a9dec3696e4a6a280b72927be4cf5d508
The branch, master has been updated
via 9243902a9dec3696e4a6a280b72927be4cf5d508 (commit)
via 74fe7fae00d49d76f39d06e58a68446bda0290a3 (commit)
via 42b544ebbcef4f6801af9bcc2048b982836526b4 (commit)
via 384d1ec3b21265b145cb297edd16ca5c28f8f9c4 (commit)
via c7b71b1fdd53fbc1753006e0201ce26a16b61f9a (commit)
via d613ccaaa06df510bc2078ae5d57c8470ffb8b95 (commit)
via 8c6206f319971fc61df9a7362ad0253bb47349bd (commit)
via 8006d2d6eb8eee0fd08a6d29cf48484f64552c29 (commit)
from 5ded849813ade42854e06cfcc3b78c89ee96e03e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 9243902a9dec3696e4a6a280b72927be4cf5d508
Author: Andy Wingo <address@hidden>
Date: Fri Jul 4 12:05:31 2014 +0200
logbit? strength reduction
* module/language/cps/type-fold.scm (fold-and-reduce): Don't require
types to check out; it could be that the reduced expression can
exhibit the same type-check effects. Reduce for all continuations,
even $kreceive. Pass dfg to reducer.
(mul): Check types.
(logbit?): New reducer.
commit 74fe7fae00d49d76f39d06e58a68446bda0290a3
Author: Andy Wingo <address@hidden>
Date: Fri Jul 4 11:54:03 2014 +0200
Fix logand range analysis.
* module/language/cps/types.scm (logand): Fix range analysis.
commit 42b544ebbcef4f6801af9bcc2048b982836526b4
Author: Andy Wingo <address@hidden>
Date: Fri Jul 4 11:14:16 2014 +0200
Fix range analysis for mul and div
* module/language/cps/types.scm (mul): Avoid producing nans in the
resulting range.
(div): Fix range analysis.
commit 384d1ec3b21265b145cb297edd16ca5c28f8f9c4
Author: Andy Wingo <address@hidden>
Date: Fri Jul 4 10:46:31 2014 +0200
Type-driven strength reduction
* module/language/cps/type-fold.scm (*primcall-reducers*):
(define-primcall-reducer, define-unary-primcall-reducer):
(define-binary-primcall-reducer, mul): Beginnings of strength
reduction.
(fold-and-reduce): Rename from compute-folded.
(fold-constants*): Adapt.
commit c7b71b1fdd53fbc1753006e0201ce26a16b61f9a
Author: Andy Wingo <address@hidden>
Date: Fri Jul 4 09:18:36 2014 +0200
Small type-fold cleanup
* module/language/cps/type-fold.scm (fold-constants*): Remove stale
branches that were there when we only type folded on limited-size
branches.
commit d613ccaaa06df510bc2078ae5d57c8470ffb8b95
Author: Andy Wingo <address@hidden>
Date: Thu Jul 3 15:03:40 2014 +0200
Compiler emits br-if-logtest
* module/language/cps/compile-bytecode.scm (compile-fun):
* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/language/cps/type-fold.scm (logtest):
* module/language/cps/types.scm (logtest):
* module/system/vm/assembler.scm (system):
* module/system/vm/disassembler.scm (compute-labels): Add backend
support for the logtest instruction.
commit 8c6206f319971fc61df9a7362ad0253bb47349bd
Author: Andy Wingo <address@hidden>
Date: Thu Jul 3 14:50:50 2014 +0200
Add br-if-logtest opcode
* libguile/vm-engine.c (br-if-logtest): New opcode.
* module/system/vm/disassembler.scm (code-annotation): Add branch
annotation support.
commit 8006d2d6eb8eee0fd08a6d29cf48484f64552c29
Author: Andy Wingo <address@hidden>
Date: Thu Jul 3 14:45:12 2014 +0200
Optimizer support for logtest and logbit?
* module/language/cps/effects-analysis.scm: Add entries for logtest and
logbit?.
* module/language/cps/types.scm (logtest, logbit?): New checkers and
inferrers.
* module/language/tree-il/peval.scm (peval): Convert (zero? (logand a
b)) to (logtest a b), in anticipation of opcode support for logtest.
*
module/language/tree-il/primitives.scm (*interesting-primitive-names*):
(*effect-free-primitives*): Add logtest and logbit?.
-----------------------------------------------------------------------
Summary of changes:
libguile/vm-engine.c | 15 ++-
module/language/cps/compile-bytecode.scm | 3 +-
module/language/cps/effects-analysis.scm | 2 +
module/language/cps/primitives.scm | 3 +-
module/language/cps/type-fold.scm | 228 ++++++++++++++++++++++++++----
module/language/cps/types.scm | 74 ++++++++---
module/language/tree-il/peval.scm | 14 ++
module/language/tree-il/primitives.scm | 4 +-
module/system/vm/assembler.scm | 1 +
module/system/vm/disassembler.scm | 5 +-
10 files changed, 297 insertions(+), 52 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index c405b2b..d92910a 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3095,7 +3095,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8))
BV_FLOAT_SET (f64, ieee_double, double, 8);
- VM_DEFINE_OP (128, unused_128, NULL, NOP)
+ /* br-if-logtest a:12 b:12 invert:1 _:7 offset:24
+ *
+ * If the exact integer in A has any bits in common with the exact
+ * integer in B, add OFFSET, a signed 24-bit number, to the current
+ * instruction pointer.
+ */
+ VM_DEFINE_OP (128, br_if_logtest, "br-if-logtest", OP2 (U8_U12_U12,
B1_X7_L24))
+ {
+ BR_BINARY (x, y,
+ ((SCM_I_INUMP (x) && SCM_I_INUMP (y))
+ ? (SCM_UNPACK (x) & SCM_UNPACK (y) & ~scm_tc2_int)
+ : scm_is_true (scm_logtest (x, y))));
+ }
+
VM_DEFINE_OP (129, unused_129, NULL, NOP)
VM_DEFINE_OP (130, unused_130, NULL, NOP)
VM_DEFINE_OP (131, unused_131, NULL, NOP)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 25626a3..e04eb6c 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/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index b1e2cc8..d59283c 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -417,6 +417,8 @@ is or might be a read or a write to the same location as A."
((logior . _) &type-check)
((logxor . _) &type-check)
((lognot . _) &type-check)
+ ((logtest a b) &type-check)
+ ((logbit? a b) &type-check)
((sqrt _) &type-check)
((abs _) &type-check))
diff --git a/module/language/cps/primitives.scm
b/module/language/cps/primitives.scm
index 4c6287a..a095fce 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 3dc2155..b7649df 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -29,8 +29,14 @@
#:use-module (language cps dfg)
#:use-module (language cps renumber)
#:use-module (language cps types)
+ #:use-module (system base target)
#:export (type-fold))
+
+
+
+;; Branch folders.
+
(define &scalar-types
(logior &exact-integer &flonum &char &unspecified &boolean &nil &null))
@@ -123,7 +129,147 @@
((= <= <) (values #t #f))
(else (values #f #f))))
-(define (compute-folded fun dfg min-label min-var)
+(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)))
+
+
+
+
+;; Strength reduction.
+
+(define *primcall-reducers* (make-hash-table))
+
+(define-syntax-rule (define-primcall-reducer name f)
+ (hashq-set! *primcall-reducers* 'name f))
+
+(define-syntax-rule (define-unary-primcall-reducer (name dfg k src
+ arg type min max)
+ body ...)
+ (define-primcall-reducer name
+ (lambda (dfg k src arg type min max) body ...)))
+
+(define-syntax-rule (define-binary-primcall-reducer (name dfg k src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ body ...)
+ (define-primcall-reducer name
+ (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
+
+(define-binary-primcall-reducer (mul dfg k src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ (define (negate arg)
+ (let-fresh (kzero) (zero)
+ (build-cps-term
+ ($letk ((kzero ($kargs (#f) (zero)
+ ($continue k src ($primcall 'sub (zero arg))))))
+ ($continue kzero src ($const 0))))))
+ (define (zero)
+ (build-cps-term ($continue k src ($const 0))))
+ (define (identity arg)
+ (build-cps-term ($continue k src ($values (arg)))))
+ (define (double arg)
+ (build-cps-term ($continue k src ($primcall 'add (arg arg)))))
+ (define (power-of-two constant arg)
+ (let ((n (let lp ((bits 0) (constant constant))
+ (if (= constant 1) bits (lp (1+ bits) (ash constant -1))))))
+ (let-fresh (kbits) (bits)
+ (build-cps-term
+ ($letk ((kbits ($kargs (#f) (bits)
+ ($continue k src ($primcall 'ash (arg bits))))))
+ ($continue kbits src ($const n)))))))
+ (define (mul/constant constant constant-type arg arg-type)
+ (and (or (= constant-type &exact-integer) (= constant-type arg-type))
+ (case constant
+ ;; (* arg -1) -> (- 0 arg)
+ ((-1) (negate arg))
+ ;; (* arg 0) -> 0 if arg is not a flonum or complex
+ ((0) (and (= constant-type &exact-integer)
+ (zero? (logand arg-type
+ (lognot (logior &flonum &complex))))
+ (zero)))
+ ;; (* arg 1) -> arg
+ ((1) (identity arg))
+ ;; (* arg 2) -> (+ arg arg)
+ ((2) (double arg))
+ (else (and (= constant-type arg-type &exact-integer)
+ (positive? constant)
+ (zero? (logand constant (1- constant)))
+ (power-of-two constant arg))))))
+ (cond
+ ((logtest (logior type0 type1) (lognot &number)) #f)
+ ((= min0 max0) (mul/constant min0 type0 arg1 type1))
+ ((= min1 max1) (mul/constant min1 type1 arg0 type0))
+ (else #f)))
+
+(define-binary-primcall-reducer (logbit? dfg k src
+ arg0 type0 min0 max0
+ arg1 type1 min1 max1)
+ (define (convert-to-logtest bool-term)
+ (let-fresh (kt kf kmask kbool) (mask bool)
+ (build-cps-term
+ ($letk ((kt ($kargs () ()
+ ($continue kbool src ($const #t))))
+ (kf ($kargs () ()
+ ($continue kbool src ($const #f))))
+ (kbool ($kargs (#f) (bool)
+ ,(bool-term bool)))
+ (kmask ($kargs (#f) (mask)
+ ($continue kf src
+ ($branch kt ($primcall 'logtest (mask arg1)))))))
+ ,(if (eq? min0 max0)
+ ($continue kmask src ($const (ash 1 min0)))
+ (let-fresh (kone) (one)
+ (build-cps-term
+ ($letk ((kone ($kargs (#f) (one)
+ ($continue kmask src
+ ($primcall 'ash (one arg0))))))
+ ($continue kone src ($const 1))))))))))
+ ;; Hairiness because we are converting from a primcall with unknown
+ ;; arity to a branching primcall.
+ (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3)))
+ (and (= type0 &exact-integer)
+ (<= 0 min0 positive-fixnum-bits)
+ (<= 0 max0 positive-fixnum-bits)
+ (match (lookup-cont k dfg)
+ (($ $kreceive arity kargs)
+ (match arity
+ (($ $arity (_) () (not #f) () #f)
+ (convert-to-logtest
+ (lambda (bool)
+ (let-fresh (knil) (nil)
+ (build-cps-term
+ ($letk ((knil ($kargs (#f) (nil)
+ ($continue kargs src
+ ($values (bool nil))))))
+ ($continue knil src ($const '()))))))))
+ (_
+ (convert-to-logtest
+ (lambda (bool)
+ (build-cps-term
+ ($continue k src ($primcall 'values (bool)))))))))
+ (($ $ktail)
+ (convert-to-logtest
+ (lambda (bool)
+ (build-cps-term
+ ($continue k src ($primcall 'return (bool)))))))))))
+
+
+
+
+;;
+
+(define (fold-and-reduce fun dfg min-label min-var)
(define (scalar-value type val)
(cond
((eqv? type &exact-integer) val)
@@ -139,19 +285,42 @@
(lambda (k cont label-count) (1+ label-count))
fun 0))
(folded? (make-bitvector label-count #f))
- (folded-values (make-vector label-count #f)))
+ (folded-values (make-vector label-count #f))
+ (reduced-terms (make-vector label-count #f)))
(define (label->idx label) (- label min-label))
(define (var->idx var) (- var min-var))
+ (define (maybe-reduce-primcall! label k src name args)
+ (let* ((reducer (hashq-ref *primcall-reducers* name)))
+ (when reducer
+ (vector-set!
+ reduced-terms
+ (label->idx label)
+ (match args
+ ((arg0)
+ (call-with-values (lambda () (lookup-pre-type typev label arg0))
+ (lambda (type0 min0 max0)
+ (reducer dfg k src arg0 type0 min0 max0))))
+ ((arg0 arg1)
+ (call-with-values (lambda () (lookup-pre-type typev label arg0))
+ (lambda (type0 min0 max0)
+ (call-with-values (lambda () (lookup-pre-type typev label
arg1))
+ (lambda (type1 min1 max1)
+ (reducer dfg k src arg0 type0 min0 max0
+ arg1 type1 min1 max1))))))
+ (_ #f))))))
(define (maybe-fold-value! label name def)
(call-with-values (lambda () (lookup-post-type typev label def 0))
(lambda (type min max)
- (when (and (not (zero? type))
- (zero? (logand type (1- type)))
- (zero? (logand type (lognot &scalar-types)))
- (eqv? min max))
+ (cond
+ ((and (not (zero? type))
+ (zero? (logand type (1- type)))
+ (zero? (logand type (lognot &scalar-types)))
+ (eqv? min max))
(bitvector-set! folded? (label->idx label) #t)
(vector-set! folded-values (label->idx label)
- (scalar-value type min))))))
+ (scalar-value type min))
+ #t)
+ (else #f)))))
(define (maybe-fold-unary-branch! label name arg)
(let* ((folder (hashq-ref *branch-folders* name)))
(when folder
@@ -193,8 +362,10 @@
(match (lookup-cont k dfg)
(($ $kargs (_) (def))
;(pk 'maybe-fold-value src name args)
- (maybe-fold-value! label name def))
- (_ #f)))
+ (unless (maybe-fold-value! label name def)
+ (maybe-reduce-primcall! label k src name args)))
+ (_
+ (maybe-reduce-primcall! label k src name args))))
(($ $continue kf src ($ $branch kt ($ $primcall name args)))
;; We might be able to fold primcalls that branch.
;(pk 'maybe-fold-branch label src name args)
@@ -208,13 +379,13 @@
(match fun
(($ $cont kfun ($ $kfun src meta self tail clause))
(visit-cont clause))))
- (values folded? folded-values)))
+ (values folded? folded-values reduced-terms)))
(define (fold-constants* fun dfg)
(match fun
(($ $cont min-label ($ $kfun _ _ min-var))
- (call-with-values (lambda () (compute-folded fun dfg min-label min-var))
- (lambda (folded? folded-values)
+ (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var))
+ (lambda (folded? folded-values reduced-terms)
(define (label->idx label) (- label min-label))
(define (var->idx var) (- var min-var))
(define (visit-cont cont)
@@ -235,23 +406,24 @@
,(visit-term body label)))
(($ $continue k src (and fun ($ $fun)))
($continue k src ,(visit-fun fun)))
- (($ $continue k src (and primcall ($ $primcall)))
- ,(if (and folded?
- (bitvector-ref folded? (label->idx label)))
- (let ((val (vector-ref folded-values (label->idx label))))
- ;; Uncomment for debugging.
- ;; (pk 'folded src primcall val)
- (let-fresh (k*) (v*)
- ;; Rely on DCE to elide this expression, if
- ;; possible.
- (build-cps-term
- ($letk ((k* ($kargs (#f) (v*)
- ($continue k src ($const val)))))
- ($continue k* src ,primcall)))))
- term))
+ (($ $continue k src (and primcall ($ $primcall name args)))
+ ,(cond
+ ((bitvector-ref folded? (label->idx label))
+ (let ((val (vector-ref folded-values (label->idx label))))
+ ;; Uncomment for debugging.
+ ;; (pk 'folded src primcall val)
+ (let-fresh (k*) (v*)
+ ;; Rely on DCE to elide this expression, if
+ ;; possible.
+ (build-cps-term
+ ($letk ((k* ($kargs (#f) (v*)
+ ($continue k src ($const val)))))
+ ($continue k* src ,primcall))))))
+ (else
+ (or (vector-ref reduced-terms (label->idx label))
+ term))))
(($ $continue kf src ($ $branch kt ($ $primcall)))
- ,(if (and folded?
- (bitvector-ref folded? (label->idx label)))
+ ,(if (bitvector-ref folded? (label->idx label))
;; Folded branch.
(let ((val (vector-ref folded-values (label->idx label))))
(build-cps-term
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 0bd2812..677f542 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -799,13 +799,30 @@ minimum, and maximum."
(define-type-inferrer (mul a b result)
(let ((min-a (&min a)) (max-a (&max a))
(min-b (&min b)) (max-b (&max b)))
- (let ((-- (* min-a min-b))
- (-+ (* min-a max-b))
- (++ (* max-a max-b))
- (+- (* max-a min-b)))
- (define-binary-result! a b result #t
- (if (eqv? a b) 0 (min -- -+ ++ +-))
- (max -- -+ ++ +-)))))
+ (define (nan* a b)
+ ;; We only really get +inf.0 at runtime for flonums and compnums.
+ ;; If we have inferred that the arguments are not flonums and not
+ ;; compnums, then the result of (* +inf.0 0) at range inference
+ ;; time is 0 and not +nan.0.
+ (if (or (and (inf? a) (zero? b))
+ (and (zero? a) (inf? b))
+ (not (logtest (logior (&type a) (&type b))
+ (logior &flonum &complex))))
+ 0
+ (* a b)))
+ (let ((-- (nan* min-a min-b))
+ (-+ (nan* min-a max-b))
+ (++ (nan* max-a max-b))
+ (+- (nan* max-a min-b)))
+ (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-))))
+ (define-binary-result! a b result #t
+ (cond
+ ((eqv? a b) 0)
+ (has-nan? -inf.0)
+ (else (min -- -+ ++ +-)))
+ (if has-nan?
+ +inf.0
+ (max -- -+ ++ +-)))))))
(define-type-checker (div a b)
(and (check-type a &number -inf.0 +inf.0)
@@ -824,12 +841,18 @@ minimum, and maximum."
(values -inf.0 +inf.0)
;; Otherwise min-b and max-b have the same sign, and cannot both
;; be infinity.
- (let ((-- (if (inf? min-b) 0 (* min-a min-b)))
- (-+ (if (inf? max-b) 0 (* min-a max-b)))
- (++ (if (inf? max-b) 0 (* max-a max-b)))
- (+- (if (inf? min-b) 0 (* max-a min-b))))
- (values (min -- -+ ++ +-)
- (max -- -+ ++ +-)))))
+ (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b)))
+ (-+- (if (inf? max-b) 0 (floor/ min-a max-b)))
+ (++- (if (inf? max-b) 0 (floor/ max-a max-b)))
+ (+-- (if (inf? min-b) 0 (floor/ max-a min-b)))
+ (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b)))
+ (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b)))
+ (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b)))
+ (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b))))
+ (values (min (min --- -+- ++- +--)
+ (min --+ -++ +++ +-+))
+ (max (max --- -+- ++- +--)
+ (max --+ -++ +++ +-+))))))
(lambda (min max)
(define-binary-result! a b result #f min max)))))
@@ -968,13 +991,13 @@ minimum, and maximum."
(define-simple-type-checker (logand &exact-integer &exact-integer))
(define-type-inferrer (logand a b result)
(define (logand-min a b)
- (if (< a b 0)
+ (if (and (negative? a) (negative? b))
(min a b)
0))
(define (logand-max a b)
- (if (< a b 0)
- 0
- (max a b)))
+ (if (and (positive? a) (positive? b))
+ (min a b)
+ 0))
(restrict! a &exact-integer -inf.0 +inf.0)
(restrict! b &exact-integer -inf.0 +inf.0)
(define! result &exact-integer
@@ -1012,6 +1035,23 @@ minimum, and maximum."
(- -1 (&max a))
(- -1 (&min a))))
+(define-simple-type-checker (logtest &exact-integer &exact-integer))
+(define-predicate-inferrer (logtest a b true?)
+ (restrict! a &exact-integer -inf.0 +inf.0)
+ (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)
+ (let ((a-min (&min a))
+ (a-max (&max a))
+ (b-min (&min b))
+ (b-max (&max b)))
+ (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min))
+ (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min)))
+ (let ((res (if (logbit? a-min b-min) 1 0)))
+ (define! result &boolean res res))
+ (define! result &boolean 0 1))))
+
;; Flonums.
(define-simple-type-checker (sqrt &number))
(define-type-inferrer (sqrt x result)
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index 3331291..f70d3b1 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1334,6 +1334,20 @@ top-level bindings from ENV and return the resulting
expression."
($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym))
(for-tail (make-const #f #t)))
+ (('= ($ <primcall> src2 'logand (a b)) ($ <const> _ 0))
+ (let ((src (or src src2)))
+ (make-primcall src 'not
+ (list (make-primcall src 'logtest (list a b))))))
+
+ (('logbit? ($ <const> src2
+ (? (lambda (bit)
+ (and (exact-integer? bit) (not (negative? bit))))
+ bit))
+ val)
+ (fold-constants src 'logtest
+ (list (make-const (or src2 src) (ash 1 bit)) val)
+ ctx))
+
(((? effect-free-primitive?) . args)
(fold-constants src name args ctx))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index a959df2..e4e6104 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -47,7 +47,7 @@
memq memv
= < > <= >= zero? positive? negative?
+ * - / 1- 1+ quotient remainder modulo
- ash logand logior logxor lognot
+ ash logand logior logxor lognot logtest logbit?
sqrt abs
not
pair? null? list? symbol? vector? string? struct? number? char? nil?
@@ -165,7 +165,7 @@
`(values
eq? eqv? equal?
= < > <= >= zero? positive? negative?
- ash logand logior logxor lognot
+ ash logand logior logxor lognot logtest logbit?
+ * - / 1- 1+ sqrt abs quotient remainder modulo
not
pair? null? nil? list?
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 787273e..e944e68 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 3d8de82..adacf1b 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -205,7 +205,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-eq 'br-if-eqv 'br-if-equal
- 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
+ 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
+ 'br-if-logtest) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
(('br-if-tc7 slot invert? tc7 target)
(list "~A -> ~A"
@@ -295,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"))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-75-g9243902,
Andy Wingo <=