mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

Re-add support for logbit?

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2017-12-27 09:18:23 +01:00
parent bc5a599cad
commit 108ade6b0e
2 changed files with 28 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

54
module/language/cps/type-fold.scm
View file

@ -333,8 +333,6 @@
(define-binary-primcall-reducer (logbit? cps k src param (define-binary-primcall-reducer (logbit? cps k src param
arg0 type0 min0 max0 arg0 type0 min0 max0
arg1 type1 min1 max1) 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) (define (compute-mask cps kmask src)
(if (eq? min0 max0) (if (eq? min0 max0)
(with-cps cps (with-cps cps
@ -348,51 +346,25 @@
($primcall 'lsh #f (one n))))) ($primcall 'lsh #f (one n)))))
(build-term (build-term
($continue kn src ($primcall 'untag-fixnum #f (arg0))))))))) ($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 (with-cps cps
(letv mask test) (letv mask res u64)
(letk kt ($kargs () () (letk kt ($kargs () () ($continue k src ($const #t))))
($continue kbool src ($const #t)))) (letk kf ($kargs () () ($continue k src ($const #f))))
(letk kf ($kargs () () (letk ku64 ($kargs (#f) (u64)
($continue kbool src ($const #f))))
(let$ body (with-cps-constants ((zero 0))
(build-term
($continue kt src ($continue kt src
($branch kf ($primcall 'eq? #f (test zero))))))) ($branch kf ($primcall 's64-imm-= 0 (u64))))))
(letk kand ($kargs (#f) (test) (letk kand ($kargs (#f) (res)
,body)) ($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
(letk kmask ($kargs (#f) (mask) (letk kmask ($kargs (#f) (mask)
($continue kand src ($continue kand src
($primcall 'logand #f (mask arg1))))) ($primcall 'logand #f (mask arg1)))))
($ (compute-mask kmask src)))) ($ (compute-mask kmask src))))
;; Hairiness because we are converting from a primcall with unknown (else
;; arity to a branching primcall. (with-cps cps #f))))
(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)))
(define-unary-primcall-reducer (u64->scm cps k src constant arg type min max) (define-unary-primcall-reducer (u64->scm cps k src constant arg type min max)
(cond (cond

1
module/language/tree-il/cps-primitives.scm
View file

@ -92,6 +92,7 @@
(define-cps-primitive logior 2 1) (define-cps-primitive logior 2 1)
(define-cps-primitive logxor 2 1) (define-cps-primitive logxor 2 1)
(define-cps-primitive logsub 2 1) (define-cps-primitive logsub 2 1)
(define-cps-primitive logbit? 2 1)
(define-cps-primitive make-vector 2 1) (define-cps-primitive make-vector 2 1)
(define-cps-primitive vector-length 1 1) (define-cps-primitive vector-length 1 1)