mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +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

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

@ -333,66 +333,38 @@
(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 (compute-mask cps kmask src)
(define (convert-to-logtest cps kbool) (if (eq? min0 max0)
(define (compute-mask cps kmask src) (with-cps cps
(if (eq? min0 max0) (build-term
(with-cps cps ($continue kmask src ($const (ash 1 min0)))))
(build-term (with-cps cps
($continue kmask src ($const (ash 1 min0))))) ($ (with-cps-constants ((one 1))
(with-cps cps (letv n)
($ (with-cps-constants ((one 1)) (letk kn ($kargs ('n) (n)
(letv n) ($continue kmask src
(letk kn ($kargs ('n) (n) ($primcall 'lsh #f (one n)))))
($continue kmask src (build-term
($primcall 'lsh #f (one n))))) ($continue kn src ($primcall 'untag-fixnum #f (arg0)))))))))
(build-term (cond
($continue kn src ($primcall 'untag-fixnum #f (arg0))))))))) ((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)))) ($continue kt src
(let$ body (with-cps-constants ((zero 0)) ($branch kf ($primcall 's64-imm-= 0 (u64))))))
(build-term (letk kand ($kargs (#f) (res)
($continue kt src ($continue ku64 src ($primcall 'untag-fixnum #f (res)))))
($branch kf ($primcall 'eq? #f (test zero)))))))
(letk kand ($kargs (#f) (test)
,body))
(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)