schemify: improve cross-module optimization
The schemify pass collects known-value information as the first step of processing a linklet body, but the main pass to process the linklet body may simplify it in a way that exposes new information. For example, in (define (call) (values 1 2)) (define-values (x y) (call)) the main pass will inline `call` and expose the fact that `x` and `y` are always 1 and 2, respectively. Adjust schemify to inspect the simplified form of a definition and potentially add new information to known-value information, which is useful later in the ame linklet body and also as cross-module information.
This commit is contained in:
Matthew Flatt
parent
ecabcd385a
commit
b0f77a98a3
|
|
@ -2944,6 +2944,32 @@ case of module-leve bindings; it doesn't cover local bindings.
|
|||
|
||||
(err/rt-test/once (dynamic-require ''uses-a-in-define-values-before-a-is-defined #f))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Make sure that inlining doesn't duplicated a quoted list
|
||||
|
||||
(let ([e (compile
|
||||
'(module check-with-inlining-duplicates-by-using-submodules racket/base
|
||||
(provide check)
|
||||
|
||||
(module m racket/base
|
||||
(provide f)
|
||||
(define (f x) '(1 2)))
|
||||
|
||||
(module n racket/base
|
||||
(require (submod ".." m))
|
||||
(provide v)
|
||||
(define v (f 0)))
|
||||
|
||||
(require 'm 'n)
|
||||
|
||||
(define check (eq? (f 0) v))))])
|
||||
(define-values (i o) (make-pipe))
|
||||
(write e o)
|
||||
(close-output-port o)
|
||||
(eval (parameterize ([read-accept-compiled #t])
|
||||
(read i)))
|
||||
(test #t dynamic-require ''check-with-inlining-duplicates-by-using-submodules 'check))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
(optimize orig-rhs prim-knowns primitives knowns imports mutated)
|
||||
orig-rhs))
|
||||
(values
|
||||
(let ([k (infer-known rhs v #t id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
(let ([k (infer-known rhs v id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
#:primitives primitives
|
||||
#:optimize-inline? optimize?)])
|
||||
(if k
|
||||
|
|
|
|||
|
|
@ -12,19 +12,22 @@
|
|||
"optimize.rkt")
|
||||
|
||||
(provide infer-known
|
||||
can-improve-infer-known?
|
||||
lambda?)
|
||||
|
||||
;; For definitions, it's useful to infer `a-known-constant` to reflect
|
||||
;; that the variable will get a value without referencing anything
|
||||
;; too early.
|
||||
(define (infer-known rhs defn rec? id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
;; too early. If `post-schemify?`, then `rhs` has been schemified.
|
||||
(define (infer-known rhs defn id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
#:primitives [primitives #hasheq()] ; for `optimize-inline?` mode
|
||||
#:optimize-inline? [optimize-inline? #f])
|
||||
#:optimize-inline? [optimize-inline? #f]
|
||||
#:post-schemify? [post-schemify? #f])
|
||||
(cond
|
||||
[(lambda? rhs)
|
||||
(define-values (lam inlinable?) (extract-lambda rhs))
|
||||
(define arity-mask (lambda-arity-mask lam))
|
||||
(if (and inlinable?
|
||||
(not post-schemify?)
|
||||
(or (can-inline? lam)
|
||||
(wrap-property defn 'compiler-hint:cross-module-inline)))
|
||||
(let ([lam (if optimize-inline?
|
||||
|
|
@ -72,39 +75,55 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Recognize forms that produce plain procedures
|
||||
(define (can-improve-infer-known? k)
|
||||
(or (not k)
|
||||
(eq? k a-known-constant)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; Recognize forms that produce plain procedures; expression can be
|
||||
;; pre- or post-schemify
|
||||
(define (lambda? v #:simple? [simple? #f])
|
||||
(match v
|
||||
[`(lambda . ,_) #t]
|
||||
[`(case-lambda . ,_) #t]
|
||||
[`(let-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs))
|
||||
(lambda? body))]
|
||||
[`(letrec-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs))
|
||||
(lambda? body))]
|
||||
[`(let-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body)]
|
||||
[`(letrec-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body)]
|
||||
[`(let ([,id ,rhs]) ,body) (let-lambda? id rhs body)]
|
||||
[`(letrec* ([,id ,rhs]) ,body) (let-lambda? id rhs body)]
|
||||
[`(let-values ,_ ,body) (and (not simple?) (lambda? body))]
|
||||
[`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))]
|
||||
[`(begin ,body) (lambda? body)]
|
||||
[`(values ,body) (lambda? body)]
|
||||
[`,_ #f]))
|
||||
|
||||
;; Extract procedure from from forms that produce plain procedures
|
||||
(define (let-lambda? id rhs body)
|
||||
(or (and (wrap-eq? id body) (lambda? rhs))
|
||||
(lambda? body)))
|
||||
|
||||
;; Extract procedure from a form on which `lambda?` produces true
|
||||
(define (extract-lambda v)
|
||||
(match v
|
||||
[`(lambda . ,_) (values v #t)]
|
||||
[`(case-lambda . ,_) (values v #t)]
|
||||
[`(let-values ([(,id) ,rhs]) ,body)
|
||||
(if (wrap-eq? id body)
|
||||
(extract-lambda rhs)
|
||||
(extract-lambda* body))]
|
||||
[`(letrec-values ([(,id) ,rhs]) ,body)
|
||||
(if (wrap-eq? id body)
|
||||
(extract-lambda* rhs)
|
||||
(extract-lambda* body))]
|
||||
[`(let-values ([(,id) ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
|
||||
[`(letrec-values ([(,id) ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
|
||||
[`(let ([,id ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
|
||||
[`(letrec* ([,id ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
|
||||
[`(let-values ,_ ,body) (extract-lambda* body)]
|
||||
[`(letrec-values ,_ ,body) (extract-lambda* body)]
|
||||
[`(let ,_ ,body) (extract-lambda* body)]
|
||||
[`(letrec* ,_ ,body) (extract-lambda* body)]
|
||||
[`(begin ,body) (extract-lambda body)]
|
||||
[`(values ,body) (extract-lambda body)]))
|
||||
|
||||
(define (extract-let-lambda rec? id rhs body)
|
||||
(if (wrap-eq? id body)
|
||||
(if rec?
|
||||
(extract-lambda* rhs)
|
||||
(extract-lambda rhs))
|
||||
(extract-lambda* body)))
|
||||
|
||||
(define (extract-lambda* v)
|
||||
(define-values (lam inlinable?) (extract-lambda v))
|
||||
(values lam #f))
|
||||
|
|
|
|||
|
|
@ -37,7 +37,14 @@
|
|||
(cond
|
||||
[(zero? size) 0]
|
||||
[(wrap-pair? v)
|
||||
(loop (wrap-cdr v) (loop (wrap-car v) size))]
|
||||
(cond
|
||||
[(eq? (unwrap (wrap-car v)) 'quote)
|
||||
;; don't copy quoted values other than symbols
|
||||
(if (symbol? (unwrap (wrap-car (wrap-cdr v))))
|
||||
(sub1 size)
|
||||
0)]
|
||||
[else
|
||||
(loop (wrap-cdr v) (loop (wrap-car v) size))])]
|
||||
[else (sub1 size)]))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
|||
|
|
@ -14,25 +14,33 @@
|
|||
(namespace-require 'racket/unsafe/ops)
|
||||
(namespace-require 'racket/flonum)
|
||||
(namespace-require 'racket/fixnum))
|
||||
(define primitives
|
||||
(define base-primitives
|
||||
(for/hasheq ([s (in-list (namespace-mapped-symbols ns))]
|
||||
#:when (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||
(procedure? (eval s ns))))
|
||||
(values s (eval s ns))))
|
||||
(define primitives (let* ([ht base-primitives]
|
||||
[ht (hash-set ht 'eof eof)]
|
||||
[ht (hash-set ht 'null null)])
|
||||
ht))
|
||||
(values
|
||||
(for/hasheq ([(s v) (in-hash primitives)])
|
||||
(define a (procedure-arity-mask v))
|
||||
(values s (case s
|
||||
[(+ - * /)
|
||||
(known-procedure/folding a)]
|
||||
[(fx+ fxlshift)
|
||||
(known-procedure/folding/limited a 'fixnum)]
|
||||
[(expt arithmetic-shift)
|
||||
(known-procedure/folding/limited a 'expt)]
|
||||
[(unsafe-fx+)
|
||||
(known-procedure/pure/folding-unsafe a 'fx+)]
|
||||
[else
|
||||
(known-procedure a)])))
|
||||
(cond
|
||||
[(procedure? v)
|
||||
(define a (procedure-arity-mask v))
|
||||
(values s (case s
|
||||
[(+ - * / integer->char char->integer void)
|
||||
(known-procedure/folding a)]
|
||||
[(fx+ fxlshift)
|
||||
(known-procedure/folding/limited a 'fixnum)]
|
||||
[(expt arithmetic-shift)
|
||||
(known-procedure/folding/limited a 'expt)]
|
||||
[(unsafe-fx+)
|
||||
(known-procedure/pure/folding-unsafe a 'fx+)]
|
||||
[else
|
||||
(known-procedure a)]))]
|
||||
[else
|
||||
(values s (known-literal v))]))
|
||||
primitives)))
|
||||
|
||||
(define (wrap p)
|
||||
|
|
@ -60,7 +68,7 @@
|
|||
(define-values (schemified importss exports import-keys imports-abis exports-info)
|
||||
(schemify-linklet `(linklet
|
||||
()
|
||||
(x y [z ext-z] w)
|
||||
(x y [z ext-z] w c1 c2)
|
||||
.
|
||||
,(map
|
||||
wrap
|
||||
|
|
@ -77,8 +85,13 @@
|
|||
b
|
||||
(arithmetic-shift 3 1000)
|
||||
(fx+ 4 5) (fx+ 4 (expt 2 40)) (fx* (fxlshift 1 20) (fxlshift 1 20))
|
||||
(unsafe-fx+ 4 5) (unsafe-fx+ 4 (expt 2 40))))
|
||||
(define-values (done) (z)))))
|
||||
(unsafe-fx+ 4 5) (unsafe-fx+ 4 (expt 2 40))
|
||||
(integer->char 48)
|
||||
(char->integer '#\1)
|
||||
(void (void) eof-object null)))
|
||||
(define-values (done) (z))
|
||||
(define-values (call) (lambda () (values 'c1 'c2)))
|
||||
(define-values (c1 c2) (call)))))
|
||||
#;
|
||||
(call-with-input-file "regexp.rktl" read)
|
||||
#t ; serializable
|
||||
|
|
|
|||
|
|
@ -213,11 +213,13 @@
|
|||
(append (for/list ([(int-id ex) (in-hash extra-variables)])
|
||||
`(define ,(export-id ex) (make-internal-variable 'int-id)))
|
||||
l))
|
||||
;; Mutated to communicate the final `knowns`
|
||||
(define final-knowns knowns)
|
||||
;; While schemifying, add calls to install exported values in to the
|
||||
;; corresponding exported `variable` records, but delay those
|
||||
;; installs to the end, if possible
|
||||
(define schemified
|
||||
(let loop ([l l] [in-mut-l l] [accum-exprs null] [accum-ids null])
|
||||
(let loop ([l l] [in-mut-l l] [accum-exprs null] [accum-ids null] [knowns knowns])
|
||||
(define mut-l (update-mutated-state! l in-mut-l mutated))
|
||||
(define (make-set-variables)
|
||||
(for/list ([id (in-wrap-list accum-ids)]
|
||||
|
|
@ -229,9 +231,10 @@
|
|||
(for/list ([e (in-list (reverse es))])
|
||||
(make-expr-defn e))))
|
||||
(cond
|
||||
[(null? l)
|
||||
;; Finish by making sure that all pending variables in `accum-ids` are
|
||||
;; moved into their `variable` records:
|
||||
[(null? l)
|
||||
(set! final-knowns knowns)
|
||||
;; Finish by making sure that all pending variables in `accum-ids` are
|
||||
;; moved into their `variable` records:
|
||||
(define set-vars (make-set-variables))
|
||||
(cond
|
||||
[(null? set-vars)
|
||||
|
|
@ -252,17 +255,33 @@
|
|||
;; continuation or return multiple times, we can generate a
|
||||
;; simple definition:
|
||||
(define (finish-definition ids [accum-exprs accum-exprs] [accum-ids accum-ids]
|
||||
#:knowns [knowns knowns]
|
||||
#:schemified [schemified schemified]
|
||||
#:k [k #f])
|
||||
#:next-k [next-k #f])
|
||||
;; Maybe schemify made a known shape apparent:
|
||||
(define next-knowns
|
||||
(cond
|
||||
[(and (pair? ids)
|
||||
(null? (cdr ids))
|
||||
(can-improve-infer-known? (hash-ref knowns (unwrap (car ids)) #f)))
|
||||
(define id (car ids))
|
||||
(define k (match schemified
|
||||
[`(define ,id ,rhs)
|
||||
(infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode?
|
||||
#:post-schemify? #t)]))
|
||||
(if k
|
||||
(hash-set knowns (unwrap id) k)
|
||||
knowns)]
|
||||
[else knowns]))
|
||||
(append
|
||||
(make-expr-defns accum-exprs)
|
||||
(cons
|
||||
schemified
|
||||
(let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids])
|
||||
(cond
|
||||
[(wrap-null? ids) (if k
|
||||
(k accum-exprs accum-ids)
|
||||
(loop (wrap-cdr l) mut-l accum-exprs accum-ids))]
|
||||
[(wrap-null? ids) (if next-k
|
||||
(next-k accum-exprs accum-ids next-knowns)
|
||||
(loop (wrap-cdr l) mut-l accum-exprs accum-ids next-knowns))]
|
||||
[(or (or for-jitify? for-cify?)
|
||||
(via-variable-mutated-state? (hash-ref mutated (unwrap (wrap-car ids)) #f)))
|
||||
(define id (unwrap (wrap-car ids)))
|
||||
|
|
@ -291,7 +310,7 @@
|
|||
[no-prompt?
|
||||
(cons
|
||||
schemified
|
||||
(loop (wrap-cdr l) mut-l null ids))]
|
||||
(loop (wrap-cdr l) mut-l null ids knowns))]
|
||||
[else
|
||||
(define expr
|
||||
`(call-with-module-prompt
|
||||
|
|
@ -308,7 +327,7 @@
|
|||
(if for-jitify?
|
||||
expr
|
||||
(make-expr-defn expr))
|
||||
(append defns (loop (wrap-cdr l) mut-l null null)))])))
|
||||
(append defns (loop (wrap-cdr l) mut-l null null knowns)))])))
|
||||
;; Dispatch on the schemified form, distinguishing definitions
|
||||
;; from expressions:
|
||||
(match schemified
|
||||
|
|
@ -330,16 +349,17 @@
|
|||
;; too early:
|
||||
(for/and ([rhs (in-list rhss)])
|
||||
(simple? rhs prim-knowns knowns imports mutated simples)))
|
||||
(let values-loop ([ids ids] [rhss rhss] [accum-exprs accum-exprs] [accum-ids accum-ids])
|
||||
(let values-loop ([ids ids] [rhss rhss] [accum-exprs accum-exprs] [accum-ids accum-ids] [knowns knowns])
|
||||
(cond
|
||||
[(null? ids) (loop (wrap-cdr l) mut-l accum-exprs accum-ids)]
|
||||
[(null? ids) (loop (wrap-cdr l) mut-l accum-exprs accum-ids knowns)]
|
||||
[else
|
||||
(define id (car ids))
|
||||
(define rhs (car rhss))
|
||||
(finish-definition (list id) accum-exprs accum-ids
|
||||
#:schemified `(define ,id ,rhs)
|
||||
#:k (lambda (accum-exprs accum-ids)
|
||||
(values-loop (cdr ids) (cdr rhss) accum-exprs accum-ids)))]))
|
||||
#:knowns knowns
|
||||
#:schemified `(define ,id ,rhs)
|
||||
#:next-k (lambda (accum-exprs accum-ids knowns)
|
||||
(values-loop (cdr ids) (cdr rhss) accum-exprs accum-ids knowns)))]))
|
||||
(finish-definition ids))]
|
||||
[`,_ (finish-definition ids)])]
|
||||
[else
|
||||
|
|
@ -355,17 +375,17 @@
|
|||
[`,_
|
||||
(cond
|
||||
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples)
|
||||
(loop (wrap-cdr l) mut-l (cons schemified accum-exprs) accum-ids)]
|
||||
(loop (wrap-cdr l) mut-l (cons schemified accum-exprs) accum-ids knowns)]
|
||||
[else
|
||||
;; In case `schemified` triggers an error, sync exported variables
|
||||
(define set-vars (make-set-variables))
|
||||
(define expr (if no-prompt?
|
||||
schemified
|
||||
`(call-with-module-prompt (lambda () ,schemified))))
|
||||
(loop (wrap-cdr l) mut-l (cons expr (append set-vars accum-exprs)) null)])])])])))
|
||||
(loop (wrap-cdr l) mut-l (cons expr (append set-vars accum-exprs)) null knowns)])])])])))
|
||||
;; Return both schemified and known-binding information, where
|
||||
;; the later is used for cross-linklet optimization
|
||||
(values (add-extra-variables schemified) knowns mutated))
|
||||
(values (add-extra-variables schemified) final-knowns mutated))
|
||||
|
||||
(define (make-set-variable id exports knowns mutated [extra-variables #f])
|
||||
(define int-id (unwrap id))
|
||||
|
|
@ -451,13 +471,15 @@
|
|||
(define new-knowns
|
||||
(for/fold ([knowns knowns]) ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
(define k (infer-known rhs #f #f id knowns prim-knowns imports mutated simples unsafe-mode?))
|
||||
(define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode?))
|
||||
(if k
|
||||
(hash-set knowns (unwrap id) k)
|
||||
knowns)))
|
||||
(define (merely-a-copy? id)
|
||||
(define u-id (unwrap id))
|
||||
(and (known-copy? (hash-ref new-knowns u-id #f))
|
||||
(define k (hash-ref new-knowns u-id #f))
|
||||
(and (or (known-copy? k)
|
||||
(known-literal? k))
|
||||
(simple-mutated-state? (hash-ref mutated u-id #f))))
|
||||
(left-to-right/let (for/list ([id (in-list ids)]
|
||||
#:unless (merely-a-copy? id))
|
||||
|
|
@ -492,7 +514,7 @@
|
|||
(define-values (rhs-knowns body-knowns)
|
||||
(for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)]
|
||||
[rhs (in-list rhss)])
|
||||
(define k (infer-known rhs #f #t id knowns prim-knowns imports mutated simples unsafe-mode?))
|
||||
(define k (infer-known rhs #f id knowns prim-knowns imports mutated simples unsafe-mode?))
|
||||
(define u-id (unwrap id))
|
||||
(cond
|
||||
[(too-early-mutated-state? (hash-ref mutated u-id #f))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user