From b0f77a98a36d55dac0977a0708d9f86b7a4d5372 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 Jul 2019 11:19:09 -0600 Subject: [PATCH] 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. --- .../racket-test-core/tests/racket/module.rktl | 26 ++++++++ racket/src/schemify/find-definition.rkt | 2 +- racket/src/schemify/infer-known.rkt | 55 ++++++++++------ racket/src/schemify/inline.rkt | 9 ++- racket/src/schemify/schemify-demo.rkt | 45 ++++++++----- racket/src/schemify/schemify.rkt | 64 +++++++++++++------ 6 files changed, 144 insertions(+), 57 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/module.rktl b/pkgs/racket-test-core/tests/racket/module.rktl index ccf6f4fbfe..0bf8b547ad 100644 --- a/pkgs/racket-test-core/tests/racket/module.rktl +++ b/pkgs/racket-test-core/tests/racket/module.rktl @@ -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) diff --git a/racket/src/schemify/find-definition.rkt b/racket/src/schemify/find-definition.rkt index 322f81d0d6..2e97706eec 100644 --- a/racket/src/schemify/find-definition.rkt +++ b/racket/src/schemify/find-definition.rkt @@ -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 diff --git a/racket/src/schemify/infer-known.rkt b/racket/src/schemify/infer-known.rkt index e3ed9fee14..03bf910f85 100644 --- a/racket/src/schemify/infer-known.rkt +++ b/racket/src/schemify/infer-known.rkt @@ -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? @@ -69,42 +72,58 @@ (simple? rhs prim-knowns knowns imports mutated simples)) a-known-constant] [else #f])) - + ;; ---------------------------------------- -;; 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)) diff --git a/racket/src/schemify/inline.rkt b/racket/src/schemify/inline.rkt index c0f5c16868..838af3f251 100644 --- a/racket/src/schemify/inline.rkt +++ b/racket/src/schemify/inline.rkt @@ -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)])))) ;; ---------------------------------------- diff --git a/racket/src/schemify/schemify-demo.rkt b/racket/src/schemify/schemify-demo.rkt index 7c0a0914ff..a5c57368e4 100644 --- a/racket/src/schemify/schemify-demo.rkt +++ b/racket/src/schemify/schemify-demo.rkt @@ -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 diff --git a/racket/src/schemify/schemify.rkt b/racket/src/schemify/schemify.rkt index acacfa64c7..182ea74038 100644 --- a/racket/src/schemify/schemify.rkt +++ b/racket/src/schemify/schemify.rkt @@ -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))