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

schemify: improve cross-module optimization

Browse Source 
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 2019-07-01 11:19:09 -06:00
parent ecabcd385a
commit b0f77a98a3
6 changed files with 144 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkgs/racket-test-core/tests/racket/module.rktl
View File

@ -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)) (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) (report-errs)

2
racket/src/schemify/find-definition.rkt
View File

@ -20,7 +20,7 @@
(optimize orig-rhs prim-knowns primitives knowns imports mutated) (optimize orig-rhs prim-knowns primitives knowns imports mutated)
orig-rhs)) orig-rhs))
(values (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 #:primitives primitives
#:optimize-inline? optimize?)]) #:optimize-inline? optimize?)])
(if k (if k

53
racket/src/schemify/infer-known.rkt
View File

@ -12,19 +12,22 @@
"optimize.rkt") "optimize.rkt")
(provide infer-known (provide infer-known
can-improve-infer-known?
lambda?) lambda?)
;; For definitions, it's useful to infer `a-known-constant` to reflect ;; For definitions, it's useful to infer `a-known-constant` to reflect
;; that the variable will get a value without referencing anything ;; that the variable will get a value without referencing anything
;; too early. ;; too early. If `post-schemify?`, then `rhs` has been schemified.
(define (infer-known rhs defn rec? id knowns prim-knowns imports mutated simples unsafe-mode? (define (infer-known rhs defn id knowns prim-knowns imports mutated simples unsafe-mode?
#:primitives [primitives #hasheq()] ; for `optimize-inline?` mode #:primitives [primitives #hasheq()] ; for `optimize-inline?` mode
#:optimize-inline? [optimize-inline? #f]) #:optimize-inline? [optimize-inline? #f]
#:post-schemify? [post-schemify? #f])
(cond (cond
[(lambda? rhs) [(lambda? rhs)
(define-values (lam inlinable?) (extract-lambda rhs)) (define-values (lam inlinable?) (extract-lambda rhs))
(define arity-mask (lambda-arity-mask lam)) (define arity-mask (lambda-arity-mask lam))
(if (and inlinable? (if (and inlinable?
(not post-schemify?)
(or (can-inline? lam) (or (can-inline? lam)
(wrap-property defn 'compiler-hint:cross-module-inline))) (wrap-property defn 'compiler-hint:cross-module-inline)))
(let ([lam (if optimize-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]) (define (lambda? v #:simple? [simple? #f])
(match v (match v
[`(lambda . ,_) #t] [`(lambda . ,_) #t]
[`(case-lambda . ,_) #t] [`(case-lambda . ,_) #t]
[`(let-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs)) [`(let-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body)]
(lambda? body))] [`(letrec-values ([(,id) ,rhs]) ,body) (let-lambda? id rhs body)]
[`(letrec-values ([(,id) ,rhs]) ,body) (or (and (wrap-eq? id body) (lambda? rhs)) [`(let ([,id ,rhs]) ,body) (let-lambda? id rhs body)]
(lambda? body))] [`(letrec* ([,id ,rhs]) ,body) (let-lambda? id rhs body)]
[`(let-values ,_ ,body) (and (not simple?) (lambda? body))] [`(let-values ,_ ,body) (and (not simple?) (lambda? body))]
[`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))] [`(letrec-values ,_ ,body) (and (not simple?) (lambda? body))]
[`(begin ,body) (lambda? body)] [`(begin ,body) (lambda? body)]
[`(values ,body) (lambda? body)] [`(values ,body) (lambda? body)]
[`,_ #f])) [`,_ #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) (define (extract-lambda v)
(match v (match v
[`(lambda . ,_) (values v #t)] [`(lambda . ,_) (values v #t)]
[`(case-lambda . ,_) (values v #t)] [`(case-lambda . ,_) (values v #t)]
[`(let-values ([(,id) ,rhs]) ,body) [`(let-values ([(,id) ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
(if (wrap-eq? id body) [`(letrec-values ([(,id) ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
(extract-lambda rhs) [`(let ([,id ,rhs]) ,body) (extract-let-lambda #f id rhs body)]
(extract-lambda* body))] [`(letrec* ([,id ,rhs]) ,body) (extract-let-lambda #t id rhs body)]
[`(letrec-values ([(,id) ,rhs]) ,body)
(if (wrap-eq? id body)
(extract-lambda* rhs)
(extract-lambda* body))]
[`(let-values ,_ ,body) (extract-lambda* body)] [`(let-values ,_ ,body) (extract-lambda* body)]
[`(letrec-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)] [`(begin ,body) (extract-lambda body)]
[`(values ,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 (extract-lambda* v)
(define-values (lam inlinable?) (extract-lambda v)) (define-values (lam inlinable?) (extract-lambda v))
(values lam #f)) (values lam #f))

9
racket/src/schemify/inline.rkt
View File

@ -37,7 +37,14 @@
(cond (cond
[(zero? size) 0] [(zero? size) 0]
[(wrap-pair? v) [(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)])))) [else (sub1 size)]))))
;; ---------------------------------------- ;; ----------------------------------------

25
racket/src/schemify/schemify-demo.rkt
View File

@ -14,16 +14,22 @@
(namespace-require 'racket/unsafe/ops) (namespace-require 'racket/unsafe/ops)
(namespace-require 'racket/flonum) (namespace-require 'racket/flonum)
(namespace-require 'racket/fixnum)) (namespace-require 'racket/fixnum))
(define primitives (define base-primitives
(for/hasheq ([s (in-list (namespace-mapped-symbols ns))] (for/hasheq ([s (in-list (namespace-mapped-symbols ns))]
#:when (with-handlers ([exn:fail? (lambda (x) #f)]) #:when (with-handlers ([exn:fail? (lambda (x) #f)])
(procedure? (eval s ns)))) (procedure? (eval s ns))))
(values s (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 (values
(for/hasheq ([(s v) (in-hash primitives)]) (for/hasheq ([(s v) (in-hash primitives)])
(cond
[(procedure? v)
(define a (procedure-arity-mask v)) (define a (procedure-arity-mask v))
(values s (case s (values s (case s
[(+ - * /) [(+ - * / integer->char char->integer void)
(known-procedure/folding a)] (known-procedure/folding a)]
[(fx+ fxlshift) [(fx+ fxlshift)
(known-procedure/folding/limited a 'fixnum)] (known-procedure/folding/limited a 'fixnum)]
@ -32,7 +38,9 @@
[(unsafe-fx+) [(unsafe-fx+)
(known-procedure/pure/folding-unsafe a 'fx+)] (known-procedure/pure/folding-unsafe a 'fx+)]
[else [else
(known-procedure a)]))) (known-procedure a)]))]
[else
(values s (known-literal v))]))
primitives))) primitives)))
(define (wrap p) (define (wrap p)
@ -60,7 +68,7 @@
(define-values (schemified importss exports import-keys imports-abis exports-info) (define-values (schemified importss exports import-keys imports-abis exports-info)
(schemify-linklet `(linklet (schemify-linklet `(linklet
() ()
(x y [z ext-z] w) (x y [z ext-z] w c1 c2)
. .
,(map ,(map
wrap wrap
@ -77,8 +85,13 @@
b b
(arithmetic-shift 3 1000) (arithmetic-shift 3 1000)
(fx+ 4 5) (fx+ 4 (expt 2 40)) (fx* (fxlshift 1 20) (fxlshift 1 20)) (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)))) (unsafe-fx+ 4 5) (unsafe-fx+ 4 (expt 2 40))
(define-values (done) (z))))) (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) (call-with-input-file "regexp.rktl" read)
#t ; serializable #t ; serializable

56
racket/src/schemify/schemify.rkt
View File

@ -213,11 +213,13 @@
(append (for/list ([(int-id ex) (in-hash extra-variables)]) (append (for/list ([(int-id ex) (in-hash extra-variables)])
`(define ,(export-id ex) (make-internal-variable 'int-id))) `(define ,(export-id ex) (make-internal-variable 'int-id)))
l)) l))
;; Mutated to communicate the final `knowns`
(define final-knowns knowns)
;; While schemifying, add calls to install exported values in to the ;; While schemifying, add calls to install exported values in to the
;; corresponding exported `variable` records, but delay those ;; corresponding exported `variable` records, but delay those
;; installs to the end, if possible ;; installs to the end, if possible
(define schemified (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 mut-l (update-mutated-state! l in-mut-l mutated))
(define (make-set-variables) (define (make-set-variables)
(for/list ([id (in-wrap-list accum-ids)] (for/list ([id (in-wrap-list accum-ids)]
@ -230,6 +232,7 @@
(make-expr-defn e)))) (make-expr-defn e))))
(cond (cond
[(null? l) [(null? l)
(set! final-knowns knowns)
;; Finish by making sure that all pending variables in `accum-ids` are ;; Finish by making sure that all pending variables in `accum-ids` are
;; moved into their `variable` records: ;; moved into their `variable` records:
(define set-vars (make-set-variables)) (define set-vars (make-set-variables))
@ -252,17 +255,33 @@
;; continuation or return multiple times, we can generate a ;; continuation or return multiple times, we can generate a
;; simple definition: ;; simple definition:
(define (finish-definition ids [accum-exprs accum-exprs] [accum-ids accum-ids] (define (finish-definition ids [accum-exprs accum-exprs] [accum-ids accum-ids]
#:knowns [knowns knowns]
#:schemified [schemified schemified] #: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 (append
(make-expr-defns accum-exprs) (make-expr-defns accum-exprs)
(cons (cons
schemified schemified
(let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids]) (let id-loop ([ids ids] [accum-exprs null] [accum-ids accum-ids])
(cond (cond
[(wrap-null? ids) (if k [(wrap-null? ids) (if next-k
(k accum-exprs accum-ids) (next-k accum-exprs accum-ids next-knowns)
(loop (wrap-cdr l) mut-l accum-exprs accum-ids))] (loop (wrap-cdr l) mut-l accum-exprs accum-ids next-knowns))]
[(or (or for-jitify? for-cify?) [(or (or for-jitify? for-cify?)
(via-variable-mutated-state? (hash-ref mutated (unwrap (wrap-car ids)) #f))) (via-variable-mutated-state? (hash-ref mutated (unwrap (wrap-car ids)) #f)))
(define id (unwrap (wrap-car ids))) (define id (unwrap (wrap-car ids)))
@ -291,7 +310,7 @@
[no-prompt? [no-prompt?
(cons (cons
schemified schemified
(loop (wrap-cdr l) mut-l null ids))] (loop (wrap-cdr l) mut-l null ids knowns))]
[else [else
(define expr (define expr
`(call-with-module-prompt `(call-with-module-prompt
@ -308,7 +327,7 @@
(if for-jitify? (if for-jitify?
expr expr
(make-expr-defn 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 ;; Dispatch on the schemified form, distinguishing definitions
;; from expressions: ;; from expressions:
(match schemified (match schemified
@ -330,16 +349,17 @@
;; too early: ;; too early:
(for/and ([rhs (in-list rhss)]) (for/and ([rhs (in-list rhss)])
(simple? rhs prim-knowns knowns imports mutated simples))) (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 (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 [else
(define id (car ids)) (define id (car ids))
(define rhs (car rhss)) (define rhs (car rhss))
(finish-definition (list id) accum-exprs accum-ids (finish-definition (list id) accum-exprs accum-ids
#:knowns knowns
#:schemified `(define ,id ,rhs) #:schemified `(define ,id ,rhs)
#:k (lambda (accum-exprs accum-ids) #:next-k (lambda (accum-exprs accum-ids knowns)
(values-loop (cdr ids) (cdr rhss) accum-exprs accum-ids)))])) (values-loop (cdr ids) (cdr rhss) accum-exprs accum-ids knowns)))]))
(finish-definition ids))] (finish-definition ids))]
[`,_ (finish-definition ids)])] [`,_ (finish-definition ids)])]
[else [else
@ -355,17 +375,17 @@
[`,_ [`,_
(cond (cond
[(simple? #:pure? #f schemified prim-knowns knowns imports mutated simples) [(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 [else
;; In case `schemified` triggers an error, sync exported variables ;; In case `schemified` triggers an error, sync exported variables
(define set-vars (make-set-variables)) (define set-vars (make-set-variables))
(define expr (if no-prompt? (define expr (if no-prompt?
schemified schemified
`(call-with-module-prompt (lambda () ,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 ;; Return both schemified and known-binding information, where
;; the later is used for cross-linklet optimization ;; 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 (make-set-variable id exports knowns mutated [extra-variables #f])
(define int-id (unwrap id)) (define int-id (unwrap id))
@ -451,13 +471,15 @@
(define new-knowns (define new-knowns
(for/fold ([knowns knowns]) ([id (in-list ids)] (for/fold ([knowns knowns]) ([id (in-list ids)]
[rhs (in-list rhss)]) [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 (if k
(hash-set knowns (unwrap id) k) (hash-set knowns (unwrap id) k)
knowns))) knowns)))
(define (merely-a-copy? id) (define (merely-a-copy? id)
(define u-id (unwrap 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)))) (simple-mutated-state? (hash-ref mutated u-id #f))))
(left-to-right/let (for/list ([id (in-list ids)] (left-to-right/let (for/list ([id (in-list ids)]
#:unless (merely-a-copy? id)) #:unless (merely-a-copy? id))
@ -492,7 +514,7 @@
(define-values (rhs-knowns body-knowns) (define-values (rhs-knowns body-knowns)
(for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)] (for/fold ([rhs-knowns knowns] [body-knowns knowns]) ([id (in-list ids)]
[rhs (in-list rhss)]) [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)) (define u-id (unwrap id))
(cond (cond
[(too-early-mutated-state? (hash-ref mutated u-id #f)) [(too-early-mutated-state? (hash-ref mutated u-id #f))