mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Implement cross-module inlining

Browse source 
* module/language/tree-il/optimize.scm (make-optimizer): Pass
cross-module-inlining? to peval.
* module/language/tree-il/peval.scm (peval): Add cross-module-inlining?
kwarg.  Try to inline public module-ref.
This commit is contained in:
Andy Wingo 2021-04-05 20:58:03 +02:00
parent c4a4c330f3
commit 4da276de16
2 changed files with 138 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/language/tree-il/optimize.scm
View file

@ -44,6 +44,7 @@
(expand (lookup #:expand-primitives? primitives expand-primitives)) (expand (lookup #:expand-primitives? primitives expand-primitives))
(letrectify (lookup #:letrectify? letrectify)) (letrectify (lookup #:letrectify? letrectify))
(seal? (assq-ref opts #:seal-private-bindings?)) (seal? (assq-ref opts #:seal-private-bindings?))
(xinline? (assq-ref opts #:cross-module-inlining?))
(peval (lookup #:partial-eval? peval)) (peval (lookup #:partial-eval? peval))
(eta-expand (lookup #:eta-expand? eta-expand)) (eta-expand (lookup #:eta-expand? eta-expand))
(inlinables (lookup #:inlinable-exports? inlinable-exports))) (inlinables (lookup #:inlinable-exports? inlinable-exports)))
@ -56,7 +57,7 @@
(run-pass! (expand exp)) (run-pass! (expand exp))
(run-pass! (letrectify exp #:seal-private-bindings? seal?)) (run-pass! (letrectify exp #:seal-private-bindings? seal?))
(run-pass! (fix-letrec exp)) (run-pass! (fix-letrec exp))
(run-pass! (peval exp env)) (run-pass! (peval exp env #:cross-module-inlining? xinline?))
(run-pass! (eta-expand exp)) (run-pass! (eta-expand exp))
(run-pass! (inlinables exp)) (run-pass! (inlinables exp))
exp))) exp)))

194
module/language/tree-il/peval.scm
View file

@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator ;;; Tree-IL partial evaluator
;; Copyright (C) 2011-2014, 2017, 2019, 2020 Free Software Foundation, Inc. ;; Copyright (C) 2011-2014, 2017, 2019, 2020, 2021 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -368,7 +368,8 @@
(operand-size-limit 20) (operand-size-limit 20)
(value-size-limit 10) (value-size-limit 10)
(effort-limit 500) (effort-limit 500)
(recursive-effort-limit 100)) (recursive-effort-limit 100)
(cross-module-inlining? #f))
"Partially evaluate EXP in compilation environment CENV, with "Partially evaluate EXP in compilation environment CENV, with
top-level bindings from ENV and return the resulting expression." top-level bindings from ENV and return the resulting expression."
@ -431,14 +432,54 @@ top-level bindings from ENV and return the resulting expression."
(define (lexical-refcount sym) (define (lexical-refcount sym)
(var-refcount (lookup-var sym))) (var-refcount (lookup-var sym)))
(define (splice-expression exp)
(define vars (make-hash-table))
(define (rename! old*)
(match old*
(() '())
((old . old*)
(cons (let ((new (gensym "t")))
(hashq-set! vars old new)
new)
(rename! old*)))))
(define (new-name old) (hashq-ref vars old))
(define renamed
(pre-order
(match-lambda
(($ <lexical-ref> src name gensym)
(make-lexical-ref src name (new-name gensym)))
(($ <lexical-set> src name gensym exp)
(make-lexical-set src name (new-name gensym) exp))
(($ <lambda-case> src req opt rest kw init gensyms body alt)
(let ((gensyms (rename! gensyms)))
(make-lambda-case src req opt rest
(match kw
((aok? (kw name sym) ...)
(cons aok?
(map (lambda (kw name sym)
(list kw name (new-name sym)))
kw name sym)))
(#f #f))
init gensyms body alt)))
(($ <let> src names gensyms vals body)
(make-let src names (rename! gensyms) vals body))
(($ <letrec>)
(error "unexpected letrec"))
(($ <fix> src names gensyms vals body)
(make-fix src names (rename! gensyms) vals body))
(exp exp))
exp))
(set! store (build-var-table renamed store))
renamed)
(define (with-temporaries src exps refcount can-copy? k) (define (with-temporaries src exps refcount can-copy? k)
(let* ((pairs (map (match-lambda (let* ((pairs (map (match-lambda
((and exp (? can-copy?)) ((and exp (? can-copy?))
(cons #f exp)) (cons #f exp))
(exp (exp
(let ((sym (gensym "tmp "))) (let ((sym (gensym "tmp ")))
(record-new-temporary! 'tmp sym refcount) (record-new-temporary! 'tmp sym refcount)
(cons sym exp)))) (cons sym exp))))
exps)) exps))
(tmps (filter car pairs))) (tmps (filter car pairs)))
(match tmps (match tmps
@ -449,9 +490,9 @@ top-level bindings from ENV and return the resulting expression."
(map car tmps) (map car tmps)
(map cdr tmps) (map cdr tmps)
(k (map (match-lambda (k (map (match-lambda
((#f . val) val) ((#f . val) val)
((sym . _) ((sym . _)
(make-lexical-ref #f 'tmp sym))) (make-lexical-ref #f 'tmp sym)))
pairs))))))) pairs)))))))
(define (make-begin0 src first second) (define (make-begin0 src first second)
@ -506,14 +547,14 @@ top-level bindings from ENV and return the resulting expression."
(define (apply-primitive name args) (define (apply-primitive name args)
;; todo: further optimize commutative primitives ;; todo: further optimize commutative primitives
(catch #t (catch #t
(lambda () (lambda ()
(call-with-values (call-with-values
(lambda () (lambda ()
(apply (module-ref the-scm-module name) args)) (apply (module-ref the-scm-module name) args))
(lambda results (lambda results
(values #t results)))) (values #t results))))
(lambda _ (lambda _
(values #f '())))) (values #f '()))))
(define (make-values src values) (define (make-values src values)
(match values (match values
((single) single) ; 1 value ((single) single) ; 1 value
@ -1027,8 +1068,45 @@ top-level bindings from ENV and return the resulting expression."
(make-primitive-ref src name) (make-primitive-ref src name)
exp)) exp))
exp))) exp)))
(($ <module-ref>) (($ <module-ref> src module name public?)
exp) (cond
((and cross-module-inlining?
public?
(and=> (resolve-interface module)
(lambda (module)
(and=> (module-inlinable-exports module)
(lambda (proc) (proc name))))))
=> (lambda (inlined)
;; Similar logic to lexical-ref, but we can't enumerate
;; uses, and don't know about aliases.
(log 'begin-xm-copy exp inlined)
(cond
((eq? ctx 'effect)
(log 'xm-effect)
(make-void #f))
((eq? ctx 'call)
;; Don't propagate copies if we are residualizing a call.
(log 'residualize-xm-call exp)
exp)
((or (const? inlined) (void? inlined) (primitive-ref? inlined))
;; Always propagate simple values that cannot lead to
;; code bloat.
(log 'copy-xm-const)
(for-tail inlined))
;; Inline in operator position if it's a lambda that's
;; small enough. Normally the inlinable-exports pass
;; will only make small lambdas available for inlining,
;; but you never know.
((and (eq? ctx 'operator) (lambda? inlined)
(small-expression? inlined operator-size-limit))
(log 'copy-xm-operator exp inlined)
(splice-expression inlined))
(else
(log 'xm-copy-failed)
;; Could copy small lambdas in value context. Something
;; to revisit.
exp))))
(else exp)))
(($ <module-set> src mod name public? exp) (($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (for-value exp))) (make-module-set src mod name public? (for-value exp)))
(($ <toplevel-define> src mod name exp) (($ <toplevel-define> src mod name exp)
@ -1146,55 +1224,55 @@ top-level bindings from ENV and return the resulting expression."
(with-temporaries (with-temporaries
src (list w u) 2 constant-expression? src (list w u) 2 constant-expression?
(match-lambda (match-lambda
((w u) ((w u)
(make-seq
src
(make-seq (make-seq
src src
(make-conditional (make-seq
src src
;; fixme: introduce logic to fold thunk? (make-conditional
(make-primcall src 'thunk? (list u)) src
(make-call src w '()) ;; fixme: introduce logic to fold thunk?
(make-primcall (make-primcall src 'thunk? (list u))
src 'throw (make-call src w '())
(list (make-primcall
(make-const #f 'wrong-type-arg) src 'throw
(make-const #f "dynamic-wind") (list
(make-const #f "Wrong type (expecting thunk): ~S") (make-const #f 'wrong-type-arg)
(make-primcall #f 'list (list u)) (make-const #f "dynamic-wind")
(make-primcall #f 'list (list u))))) (make-const #f "Wrong type (expecting thunk): ~S")
(make-primcall src 'wind (list w u))) (make-primcall #f 'list (list u))
(make-begin0 src (make-primcall #f 'list (list u)))))
(make-call src thunk '()) (make-primcall src 'wind (list w u)))
(make-seq src (make-begin0 src
(make-primcall src 'unwind '()) (make-call src thunk '())
(make-call src u '()))))))))) (make-seq src
(make-primcall src 'unwind '())
(make-call src u '())))))))))
(($ <primcall> src 'with-fluid* (f v thunk)) (($ <primcall> src 'with-fluid* (f v thunk))
(for-tail (for-tail
(with-temporaries (with-temporaries
src (list f v thunk) 1 constant-expression? src (list f v thunk) 1 constant-expression?
(match-lambda (match-lambda
((f v thunk) ((f v thunk)
(make-seq src (make-seq src
(make-primcall src 'push-fluid (list f v)) (make-primcall src 'push-fluid (list f v))
(make-begin0 src (make-begin0 src
(make-call src thunk '()) (make-call src thunk '())
(make-primcall src 'pop-fluid '())))))))) (make-primcall src 'pop-fluid '()))))))))
(($ <primcall> src 'with-dynamic-state (state thunk)) (($ <primcall> src 'with-dynamic-state (state thunk))
(for-tail (for-tail
(with-temporaries (with-temporaries
src (list state thunk) 1 constant-expression? src (list state thunk) 1 constant-expression?
(match-lambda (match-lambda
((state thunk) ((state thunk)
(make-seq src (make-seq src
(make-primcall src 'push-dynamic-state (list state)) (make-primcall src 'push-dynamic-state (list state))
(make-begin0 src (make-begin0 src
(make-call src thunk '()) (make-call src thunk '())
(make-primcall src 'pop-dynamic-state (make-primcall src 'pop-dynamic-state
'())))))))) '()))))))))
(($ <primcall> src 'values exps) (($ <primcall> src 'values exps)
(cond (cond
@ -1379,7 +1457,7 @@ top-level bindings from ENV and return the resulting expression."
(((? equality-primitive?) (and a ($ <const>)) b) (((? equality-primitive?) (and a ($ <const>)) b)
(for-tail (make-primcall src name (list b a)))) (for-tail (make-primcall src name (list b a))))
(((? equality-primitive?) ($ <lexical-ref> _ _ sym) (((? equality-primitive?) ($ <lexical-ref> _ _ sym)
($ <lexical-ref> _ _ sym)) ($ <lexical-ref> _ _ sym))
(for-tail (make-const src #t))) (for-tail (make-const src #t)))
(('logbit? ($ <const> src2 (('logbit? ($ <const> src2
@ -1660,8 +1738,8 @@ top-level bindings from ENV and return the resulting expression."
($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f)) ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f))
(not (tree-il-any (not (tree-il-any
(match-lambda (match-lambda
(($ <lexical-ref> _ _ (? (cut eq? <> k))) #t) (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t)
(_ #f)) (_ #f))
body))) body)))
(else #f))) (else #f)))
(if (and (not escape-only?) (escape-only-handler? handler)) (if (and (not escape-only?) (escape-only-handler? handler))