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

logbit? strength reduction

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2014-07-04 12:05:31 +02:00
parent 74fe7fae00
commit 9243902a9d
1 changed files with 69 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -29,6 +29,7 @@
#:use-module (language cps dfg) #:use-module (language cps dfg)
#:use-module (language cps renumber) #:use-module (language cps renumber)
#:use-module (language cps types) #:use-module (language cps types)
#:use-module (system base target)
#:export (type-fold)) #:export (type-fold))
@ -151,20 +152,20 @@
(define-syntax-rule (define-primcall-reducer name f) (define-syntax-rule (define-primcall-reducer name f)
(hashq-set! *primcall-reducers* 'name f)) (hashq-set! *primcall-reducers* 'name f))
(define-syntax-rule (define-unary-primcall-reducer (name k src (define-syntax-rule (define-unary-primcall-reducer (name dfg k src
arg type min max) arg type min max)
body ...) body ...)
(define-primcall-reducer name (define-primcall-reducer name
(lambda (k src arg type min max) body ...))) (lambda (dfg k src arg type min max) body ...)))
(define-syntax-rule (define-binary-primcall-reducer (name k src (define-syntax-rule (define-binary-primcall-reducer (name dfg k src
arg0 type0 min0 max0 arg0 type0 min0 max0
arg1 type1 min1 max1) arg1 type1 min1 max1)
body ...) body ...)
(define-primcall-reducer name (define-primcall-reducer name
(lambda (k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...))) (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...)))
(define-binary-primcall-reducer (mul k src (define-binary-primcall-reducer (mul dfg k src
arg0 type0 min0 max0 arg0 type0 min0 max0
arg1 type1 min1 max1) arg1 type1 min1 max1)
(define (negate arg) (define (negate arg)
@ -206,10 +207,63 @@
(zero? (logand constant (1- constant))) (zero? (logand constant (1- constant)))
(power-of-two constant arg)))))) (power-of-two constant arg))))))
(cond (cond
((logtest (logior type0 type1) (lognot &number)) #f)
((= min0 max0) (mul/constant min0 type0 arg1 type1)) ((= min0 max0) (mul/constant min0 type0 arg1 type1))
((= min1 max1) (mul/constant min1 type1 arg0 type0)) ((= min1 max1) (mul/constant min1 type1 arg0 type0))
(else #f))) (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)))))))))))
@ -237,8 +291,7 @@
(define (var->idx var) (- var min-var)) (define (var->idx var) (- var min-var))
(define (maybe-reduce-primcall! label k src name args) (define (maybe-reduce-primcall! label k src name args)
(let* ((reducer (hashq-ref *primcall-reducers* name))) (let* ((reducer (hashq-ref *primcall-reducers* name)))
(when (and reducer (when reducer
(primcall-types-check? typev label name args))
(vector-set! (vector-set!
reduced-terms reduced-terms
(label->idx label) (label->idx label)
@ -246,13 +299,13 @@
((arg0) ((arg0)
(call-with-values (lambda () (lookup-pre-type typev label arg0)) (call-with-values (lambda () (lookup-pre-type typev label arg0))
(lambda (type0 min0 max0) (lambda (type0 min0 max0)
(reducer k src arg0 type0 min0 max0)))) (reducer dfg k src arg0 type0 min0 max0))))
((arg0 arg1) ((arg0 arg1)
(call-with-values (lambda () (lookup-pre-type typev label arg0)) (call-with-values (lambda () (lookup-pre-type typev label arg0))
(lambda (type0 min0 max0) (lambda (type0 min0 max0)
(call-with-values (lambda () (lookup-pre-type typev label arg1)) (call-with-values (lambda () (lookup-pre-type typev label arg1))
(lambda (type1 min1 max1) (lambda (type1 min1 max1)
(reducer k src arg0 type0 min0 max0 (reducer dfg k src arg0 type0 min0 max0
arg1 type1 min1 max1)))))) arg1 type1 min1 max1))))))
(_ #f)))))) (_ #f))))))
(define (maybe-fold-value! label name def) (define (maybe-fold-value! label name def)
@ -265,15 +318,9 @@
(eqv? min max)) (eqv? min max))
(bitvector-set! folded? (label->idx label) #t) (bitvector-set! folded? (label->idx label) #t)
(vector-set! folded-values (label->idx label) (vector-set! folded-values (label->idx label)
(scalar-value type min))) (scalar-value type min))
(else #t)
(match (lookup-cont label dfg) (else #f)))))
(($ $kargs _ _ body)
(match (find-call body)
(($ $continue k src ($ $primcall name args))
(maybe-reduce-primcall! label k src name args))
(_ #f)))
(_ #f)))))))
(define (maybe-fold-unary-branch! label name arg) (define (maybe-fold-unary-branch! label name arg)
(let* ((folder (hashq-ref *branch-folders* name))) (let* ((folder (hashq-ref *branch-folders* name)))
(when folder (when folder
@ -315,8 +362,10 @@
(match (lookup-cont k dfg) (match (lookup-cont k dfg)
(($ $kargs (_) (def)) (($ $kargs (_) (def))
;(pk 'maybe-fold-value src name args) ;(pk 'maybe-fold-value src name args)
(maybe-fold-value! label name def)) (unless (maybe-fold-value! label name def)
(_ #f))) (maybe-reduce-primcall! label k src name args)))
(_
(maybe-reduce-primcall! label k src name args))))
(($ $continue kf src ($ $branch kt ($ $primcall name args))) (($ $continue kf src ($ $branch kt ($ $primcall name args)))
;; We might be able to fold primcalls that branch. ;; We might be able to fold primcalls that branch.
;(pk 'maybe-fold-branch label src name args) ;(pk 'maybe-fold-branch label src name args)