suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve cp0 single-value detection, epsecially for loops

Browse Source 
Compute some simple fixpoints so that `+`, `*`, etc. can be inferred
to be single-valued.

original commit: f6b6f034016936f9dde49bea5c66ea0f4a7f7676
This commit is contained in:
Matthew Flatt 2019-01-22 16:38:55 -07:00
parent 9d40161eb3
commit 75d6219a99
2 changed files with 107 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

129
s/cp0.ss
View File

@ -803,7 +803,7 @@
(define make-nontail (define make-nontail
(lambda (ctxt e) (lambda (ctxt e)
(if (context-case ctxt (if (context-case ctxt
[(tail) (single-valued-nontail? e)] [(tail) (single-valued-without-inspecting-continuation? e)]
[(ignored) (single-valued? e)] [(ignored) (single-valued? e)]
[else #t]) [else #t])
e e
@ -933,25 +933,44 @@
((ids->do-clause '()) clause) ((ids->do-clause '()) clause)
#t)))) #t))))
(module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued? single-valued? single-valued-nontail?) (module (pure? ivory? ivory1? simple? simple1? simple/profile? simple/profile1? boolean-valued?
single-valued? single-valued single-valued-join single-valued-reduce?
single-valued-without-inspecting-continuation?)
;; The memoization table has, for each key, either a flags integer
;; or a pair of a flags integer and a value. The value corresponds to
;; a use of `(with-memoize () ....)`, while uses of the flags integer
;; are `(with-memoize (flag-known flag) ....)`.
(define-syntax make-$memoize (define-syntax make-$memoize
(syntax-rules () (syntax-rules ()
[(_ flag-known flag) [(_ flag-known flag)
(lambda (e pred?) (lambda (e pred?)
(let ([a (eq-hashtable-cell cp0-info-hashtable e 0)]) (let ([a (eq-hashtable-cell cp0-info-hashtable e 0)])
(let ([flags (cdr a)]) (let ([flags (let ([val (cdr a)]) (if (pair? val) (cdr val) val))])
(if (all-set? (cp0-info-mask flag-known) flags) (if (all-set? (cp0-info-mask flag-known) flags)
(all-set? (cp0-info-mask flag) flags) (all-set? (cp0-info-mask flag) flags)
(let ([bool (pred?)]) (let ([bool (pred?)])
(set-cdr! a (set-flags (if bool (cp0-info-mask flag-known flag) (cp0-info-mask flag-known)) flags)) (set-cdr! (let ([val (cdr a)]) (if (pair? val) val a))
bool)))))])) (set-flags (if bool (cp0-info-mask flag-known flag) (cp0-info-mask flag-known))
flags))
bool)))))]
[(_)
(lambda (e pred?)
(let ([a (eq-hashtable-cell cp0-info-hashtable e 0)])
(let ([val (cdr a)])
(if (pair? val)
(car val)
(let ([r (pred?)])
(set-cdr! a (cons r (cdr a)))
r)))))]))
(define-syntax with-memoize (define-syntax with-memoize
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
[(k (flag-known flag) ?e e* ...) [(k (flag-info ...) ?e e* ...)
(with-implicit (k memoize) (with-implicit (k memoize)
#'(let ([$memoize (make-$memoize flag-known flag)] [e ?e]) #'(let ([$memoize (make-$memoize flag-info ...)] [e ?e])
(define-syntax memoize (define-syntax memoize
(syntax-rules () (syntax-rules ()
[(_ e1 e2 (... ...)) ($memoize e (lambda () e1 e2 (... ...)))])) [(_ e1 e2 (... ...)) ($memoize e (lambda () e1 e2 (... ...)))]))
@ -1244,36 +1263,59 @@
[(pariah) #f] [(pariah) #f]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
(define-who single-valued? ;; Returns #t, #f, or a prelex for lambda that needs to be
;; single-valued to imply #t. The prelex case is useful to
;; detect a loop.
(define-who single-valued
(lambda (e) (lambda (e)
(with-memoize (single-valued-known single-valued) e (with-memoize () e
; known to produce a single value ; known to produce a single value
(nanopass-case (Lsrc Expr) e (nanopass-case (Lsrc Expr) e
[(quote ,d) #t] [(quote ,d) #t]
[(call ,preinfo ,e ,e* ...) [(call ,preinfo ,e ,e* ...)
(let procedure-single-valued? ([e e] [e* e*]) (let procedure-single-valued ([e e] [e* e*])
(nanopass-case (Lsrc Expr) (result-exp e) (nanopass-case (Lsrc Expr) (result-exp e)
[,pr [,pr
(or (all-set? (prim-mask single-valued) (primref-flags pr)) (or (all-set? (prim-mask single-valued) (primref-flags pr))
(and e* (and e*
(let ([proc-e (extract-called-procedure pr e*)]) (let ([proc-e (extract-called-procedure pr e*)])
(and proc-e (and proc-e
(memoize (procedure-single-valued? proc-e #f))))))] (memoize (procedure-single-valued proc-e #f))))))]
[(case-lambda ,preinfo ,cl* ...) [(case-lambda ,preinfo ,cl* ...)
(memoize (andmap (lambda (cl) (memoize (fold-left (lambda (r cl)
(nanopass-case (Lsrc CaseLambdaClause) cl (and r
[(clause (,x* ...) ,interface ,body) (nanopass-case (Lsrc CaseLambdaClause) cl
(single-valued? body)])) [(clause (,x* ...) ,interface ,body)
cl*))] (single-valued-join r (single-valued body))])))
#t
cl*))]
[(ref ,maybe-src ,x)
(let ([v (and (not (prelex-was-assigned x))
(let ([opnd (prelex-operand x)])
(and opnd
(operand-exp opnd))))])
(and v
(nanopass-case (Lsrc Expr) v
[(case-lambda ,preinfo ,cl* ...)
;; Don't recur into the clauses, since that
;; could send us into a loop for a `letrec`
;; binding. But use the preinfo as a summary
;; or a way to tie a loop:
(preinfo->single-valued preinfo)]
[else #f])))]
;; Recognize call to a loop, and use the loop's preinfo in that case:
[(letrec ([,x1 (case-lambda ,preinfo ,cl* ...)]) (ref ,maybe-src ,x2))
(and (eq? x1 x2)
(preinfo->single-valued preinfo))]
[else #f]))] [else #f]))]
[(ref ,maybe-src ,x) #t] [(ref ,maybe-src ,x) #t]
[(case-lambda ,preinfo ,cl* ...) #t] [(case-lambda ,preinfo ,cl* ...) #t]
[(if ,e1 ,e2 ,e3) (memoize (and (single-valued? e2) (single-valued? e3)))] [(if ,e1 ,e2 ,e3) (memoize (single-valued-join (single-valued e2) (single-valued e3)))]
[(seq ,e1 ,e2) (memoize (single-valued? e2))] [(seq ,e1 ,e2) (memoize (single-valued e2))]
[(set! ,maybe-src ,x ,e) #t] [(set! ,maybe-src ,x ,e) #t]
[(immutable-list (,e* ...) ,e) #t] [(immutable-list (,e* ...) ,e) #t]
[(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued? body))] [(letrec ([,x* ,e*] ...) ,body) (memoize (single-valued body))]
[(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued? body))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (single-valued body))]
[,pr #t] [,pr #t]
[(record-cd ,rcd ,rtd-expr ,e) #t] [(record-cd ,rcd ,rtd-expr ,e) #t]
[(record-ref ,rtd ,type ,index ,e) #t] [(record-ref ,rtd ,type ,index ,e) #t]
@ -1283,12 +1325,43 @@
[(record ,rtd ,rtd-expr ,e* ...) #t] [(record ,rtd ,rtd-expr ,e* ...) #t]
[(pariah) #t] [(pariah) #t]
[(profile ,src) #t] [(profile ,src) #t]
[(cte-optimization-loc ,box ,e) (memoize (single-valued? e))] [(cte-optimization-loc ,box ,e) (memoize (single-valued e))]
[(moi) #t] [(moi) #t]
[(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t] [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t]
[else ($oops who "unrecognized record ~s" e)])))) [else ($oops who "unrecognized record ~s" e)]))))
(define-who single-valued-nontail? (define (preinfo->single-valued preinfo)
;; If the single-valued flag is set, simplify to #t,
;; otherwise return the preinfo to mean "single-valued
;; of this lambda is "single-valued".
(or (all-set? (constant code-flag-single-valued)
(preinfo-lambda-flags preinfo))
preinfo))
(define single-valued-join
(lambda (a b)
(cond
[(eq? a b) a]
[(eq? a #t) b]
[(eq? b #t) a]
;; If `a` and `b` are different preinfos, we currently give
;; up, because a preinfo is used only to find a
;; single-function fixpoint.
[else #f])))
(define-who single-valued?
(lambda (e)
(single-valued-reduce? (single-valued e))))
(define single-valued-reduce?
(lambda (r)
(cond
[(eq? r #t) #t]
[(eq? r #f) #f]
[else (all-set? (constant code-flag-single-valued)
(preinfo-lambda-flags r))])))
(define-who single-valued-without-inspecting-continuation?
(lambda (e) (lambda (e)
;; Single-valued and does not observe or affect the ;; Single-valued and does not observe or affect the
;; immediate continuation frame (so removing (an enclosing ;; immediate continuation frame (so removing (an enclosing
@ -4737,10 +4810,12 @@
[(value tail) [(value tail)
(bump sc 1) (bump sc 1)
`(case-lambda ,preinfo `(case-lambda ,preinfo
,(let f ([cl* cl*] [mask 0] [known-single-valued? #t]) ,(let f ([cl* cl*] [mask 0] [known-single-valued #t])
(if (null? cl*) (if (null? cl*)
(begin (begin
(when known-single-valued? (when (or (single-valued-reduce? known-single-valued)
;; Detect simple loop:
(eq? known-single-valued preinfo))
(preinfo-lambda-flags-set! preinfo (fxior (preinfo-lambda-flags preinfo) (preinfo-lambda-flags-set! preinfo (fxior (preinfo-lambda-flags preinfo)
(constant code-flag-single-valued)))) (constant code-flag-single-valued))))
'()) '())
@ -4748,12 +4823,14 @@
[(clause (,x* ...) ,interface ,body) [(clause (,x* ...) ,interface ,body)
(let ([new-mask (logor mask (if (fx< interface 0) (ash -1 (fx- -1 interface)) (ash 1 interface)))]) (let ([new-mask (logor mask (if (fx< interface 0) (ash -1 (fx- -1 interface)) (ash 1 interface)))])
(if (= new-mask mask) (if (= new-mask mask)
(f (cdr cl*) new-mask known-single-valued?) (f (cdr cl*) new-mask known-single-valued)
(with-extended-env ((env x*) (env x* #f)) (with-extended-env ((env x*) (env x* #f))
(let ([body (cp0 body 'tail env sc wd #f name)]) (let ([body (cp0 body 'tail env sc wd #f name)])
(cons `(clause (,x* ...) ,interface ,body) (cons `(clause (,x* ...) ,interface ,body)
(f (cdr cl*) new-mask (f (cdr cl*) new-mask
(and known-single-valued? (single-valued? body))))))))]))) (and known-single-valued
(single-valued-join known-single-valued
(single-valued body)))))))))])))
...)] ...)]
[(effect ignored) void-rec] [(effect ignored) void-rec]
[(test) true-rec] [(test) true-rec]

6
s/prims.ss
View File

@ -223,8 +223,10 @@
(define-who procedure-known-single-valued? (define-who procedure-known-single-valued?
(lambda (x) (lambda (x)
(unless (procedure? x) ($oops who "~s is not a procedure" x)) (unless (procedure? x) ($oops who "~s is not a procedure" x))
(let ([c ($closure-code x)]) (if (wrapper-procedure? x)
($code-single-valued? c)))) (procedure-known-single-valued? ($closure-ref x 0))
(let ([c ($closure-code x)])
($code-single-valued? c)))))
(let () (let ()
(define-syntax frob-proc (define-syntax frob-proc