[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 16/16: Re-add support for logbit?
From: |
Andy Wingo |
Subject: |
[Guile-commits] 16/16: Re-add support for logbit? |
Date: |
Wed, 27 Dec 2017 10:02:50 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 108ade6b0efe6e3f720e2c89731879d0d24632d1
Author: Andy Wingo <address@hidden>
Date: Wed Dec 27 09:18:23 2017 +0100
Re-add support for logbit?
* module/language/cps/type-fold.scm (logbit?): Adapt for logbit?
continuing to $kargs.
* module/language/tree-il/cps-primitives.scm (logbit?): Declare this CPS
primitive.
---
module/language/cps/type-fold.scm | 82 ++++++++++--------------------
module/language/tree-il/cps-primitives.scm | 1 +
2 files changed, 28 insertions(+), 55 deletions(-)
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index 1fd933b..f76c82e 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -333,66 +333,38 @@
(define-binary-primcall-reducer (logbit? cps k src param
arg0 type0 min0 max0
arg1 type1 min1 max1)
- ;; FIXME: Use an unboxed number for the mask instead of a fixnum.
- (define (convert-to-logtest cps kbool)
- (define (compute-mask cps kmask src)
- (if (eq? min0 max0)
- (with-cps cps
- (build-term
- ($continue kmask src ($const (ash 1 min0)))))
- (with-cps cps
- ($ (with-cps-constants ((one 1))
- (letv n)
- (letk kn ($kargs ('n) (n)
- ($continue kmask src
- ($primcall 'lsh #f (one n)))))
- (build-term
- ($continue kn src ($primcall 'untag-fixnum #f (arg0)))))))))
+ (define (compute-mask cps kmask src)
+ (if (eq? min0 max0)
+ (with-cps cps
+ (build-term
+ ($continue kmask src ($const (ash 1 min0)))))
+ (with-cps cps
+ ($ (with-cps-constants ((one 1))
+ (letv n)
+ (letk kn ($kargs ('n) (n)
+ ($continue kmask src
+ ($primcall 'lsh #f (one n)))))
+ (build-term
+ ($continue kn src ($primcall 'untag-fixnum #f (arg0)))))))))
+ (cond
+ ((and (type<=? type0 &exact-integer)
+ (<= 0 min0 (target-most-positive-fixnum))
+ (<= 0 max0 (target-most-positive-fixnum)))
(with-cps cps
- (letv mask test)
- (letk kt ($kargs () ()
- ($continue kbool src ($const #t))))
- (letk kf ($kargs () ()
- ($continue kbool src ($const #f))))
- (let$ body (with-cps-constants ((zero 0))
- (build-term
- ($continue kt src
- ($branch kf ($primcall 'eq? #f (test zero)))))))
- (letk kand ($kargs (#f) (test)
- ,body))
+ (letv mask res u64)
+ (letk kt ($kargs () () ($continue k src ($const #t))))
+ (letk kf ($kargs () () ($continue k src ($const #f))))
+ (letk ku64 ($kargs (#f) (u64)
+ ($continue kt src
+ ($branch kf ($primcall 's64-imm-= 0 (u64))))))
+ (letk kand ($kargs (#f) (res)
+ ($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
(letk kmask ($kargs (#f) (mask)
($continue kand src
($primcall 'logand #f (mask arg1)))))
($ (compute-mask kmask src))))
- ;; Hairiness because we are converting from a primcall with unknown
- ;; arity to a branching primcall.
- (if (and (type<=? type0 &exact-integer)
- (<= 0 min0 (target-most-positive-fixnum))
- (<= 0 max0 (target-most-positive-fixnum)))
- (match (intmap-ref cps k)
- (($ $kreceive arity kargs)
- (match arity
- (($ $arity (_) () (not #f) () #f)
- (with-cps cps
- (letv bool)
- (let$ body (with-cps-constants ((nil '()))
- (build-term
- ($continue kargs src ($values (bool nil))))))
- (letk kbool ($kargs (#f) (bool) ,body))
- ($ (convert-to-logtest kbool))))
- (_
- (with-cps cps
- (letv bool)
- (letk kbool ($kargs (#f) (bool)
- ($continue k src ($primcall 'values #f (bool)))))
- ($ (convert-to-logtest kbool))))))
- (($ $ktail)
- (with-cps cps
- (letv bool)
- (letk kbool ($kargs (#f) (bool)
- ($continue k src ($values (bool)))))
- ($ (convert-to-logtest kbool)))))
- (with-cps cps #f)))
+ (else
+ (with-cps cps #f))))
(define-unary-primcall-reducer (u64->scm cps k src constant arg type min max)
(cond
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index e25d1ce..d3f36c1 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -92,6 +92,7 @@
(define-cps-primitive logior 2 1)
(define-cps-primitive logxor 2 1)
(define-cps-primitive logsub 2 1)
+(define-cps-primitive logbit? 2 1)
(define-cps-primitive make-vector 2 1)
(define-cps-primitive vector-length 1 1)
- [Guile-commits] 07/16: Refactor list->seq to make return arity apparent, (continued)
- [Guile-commits] 07/16: Refactor list->seq to make return arity apparent, Andy Wingo, 2017/12/27
- [Guile-commits] 05/16: Remove compile-bytecode cases for ephemeral primitives, Andy Wingo, 2017/12/27
- [Guile-commits] 12/16: CPS conversion avoids residualizing unknown primcalls, Andy Wingo, 2017/12/27
- [Guile-commits] 06/16: Refactor reify-primitives pass, Andy Wingo, 2017/12/27
- [Guile-commits] 08/16: Flesh out compile-bytecode for all heap objects, Andy Wingo, 2017/12/27
- [Guile-commits] 15/16: Unknown primcalls convert as calls, Andy Wingo, 2017/12/27
- [Guile-commits] 13/16: Contification also inlines "elide-values" pass, Andy Wingo, 2017/12/27
- [Guile-commits] 10/16: CPS conversion expands "list", Andy Wingo, 2017/12/27
- [Guile-commits] 11/16: Inline "elide-values" optimization into CPS conversion, Andy Wingo, 2017/12/27
- [Guile-commits] 09/16: Refactor lowering of Tree-IL primcalls to CPS, Andy Wingo, 2017/12/27
- [Guile-commits] 16/16: Re-add support for logbit?,
Andy Wingo <=
- [Guile-commits] 03/16: Refactor boxing/unboxing primcall args/results, Andy Wingo, 2017/12/27
- [Guile-commits] 02/16: Fix mismatch between CPS and Scheme "complex?" predicate, Andy Wingo, 2017/12/27
- [Guile-commits] 14/16: Remove inline-constructors pass, Andy Wingo, 2017/12/27