diff options
Diffstat (limited to 'module/language/tree-il/inline.scm')
-rw-r--r-- | module/language/tree-il/inline.scm | 201 |
1 files changed, 3 insertions, 198 deletions
diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm index 67441eaaf..5a2d9af55 100644 --- a/module/language/tree-il/inline.scm +++ b/module/language/tree-il/inline.scm @@ -17,204 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (language tree-il inline) - #:use-module (system base pmatch) - #:use-module (system base syntax) - #:use-module (language tree-il) #:export (inline!)) -;; Possible optimizations: -;; * constant folding, propagation -;; * procedure inlining -;; * always when single call site -;; * always for "trivial" procs -;; * otherwise who knows -;; * dead code elimination -;; * degenerate case optimizations -;; * "fixing letrec" - -(define (boolean-value x) - (let ((src (tree-il-src x))) - (record-case x - ((<void>) - (make-const src #t)) - - ;; FIXME: This is redundant with what the partial evaluator does. - ((<conditional> test consequent alternate) - (record-case (boolean-value test) - ((<const> exp) - (case exp - ((#t) (boolean-value consequent)) - ((#f) (boolean-value alternate)) - (else x))) - (else x))) - - ((<application> src proc args) - (record-case proc - ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) - ((<primitive-ref> name) - (case name - ((memq memv) - (pmatch args - ((,k ,l) (guard (const? l) (list? (const-exp l))) - (cond - ((null? (const-exp l)) - (make-const #f #f)) - ((const? k) - (make-const #f (->bool ((case name - ((memq) memq) - ((memv) memv) - (else (error "unexpected member func" name))) - (const-exp k) (const-exp l))))) - (else - (let lp ((elts (const-exp l))) - (let ((test (make-application - #f - (make-primitive-ref #f (case name - ((memq) 'eq?) - ((memv) 'eqv?) - (else (error "what")))) - (list k (make-const #f (car elts)))))) - (if (null? (cdr elts)) - test - (make-conditional - src - test - (make-const #f #t) - (lp (cdr elts))))))))) - - (else x))) - - (else x))) - - (else x))) - - ((<lambda> meta body) - (make-const src #t)) - - ((<const> exp) - (make-const src (not (not exp)))) - - (else - x)))) - -;; This is a completely brain-dead optimization pass whose sole claim to -;; fame is ((lambda () x)) => x. (define (inline! x) - (define (inline1 x) - (record-case x - ((<application> src proc args) - (record-case proc - ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) - ((<lambda> body) - (let lp ((lcase body)) - (and lcase - (record-case lcase - ((<lambda-case> req opt rest kw inits gensyms body alternate) - (if (and (= (length gensyms) (length req) (length args))) - (let ((x (make-let src req gensyms args body))) - (or (inline1 x) x)) - (lp alternate))))))) - - ((<primitive-ref> name) - (case name - ((@call-with-values) - (pmatch args - ;; (call-with-values (lambda () foo) (lambda (a b . c) bar)) - ;; => (let-values (((a b . c) foo)) bar) - ;; - ;; Note that this is a singly-binding form of let-values. - ;; Also note that Scheme's let-values expands into - ;; call-with-values, then here we reduce it to tree-il's - ;; let-values. - ((,producer ,consumer) - (guard (lambda? consumer) - (lambda-case? (lambda-body consumer)) - (not (lambda-case-opt (lambda-body consumer))) - (not (lambda-case-kw (lambda-body consumer))) - (not (lambda-case-alternate (lambda-body consumer)))) - (make-let-values - src - (let ((x (make-application src producer '()))) - (or (inline1 x) x)) - (lambda-body consumer))) - (else #f))) - - (else #f))) - - (else #f))) - - ((<conditional> test consequent alternate) - (let ((btest (boolean-value test))) - (or (record-case btest - ((<const> exp) - (case exp - ((#t) consequent) - ((#f) alternate) - (else #f))) - (else #f)) - (if (eq? test btest) - x - (make-conditional (conditional-src x) - btest consequent alternate))))) - - ((<let> gensyms body) - (if (null? gensyms) body x)) - - ((<letrec> gensyms body) - (if (null? gensyms) body x)) - - ((<fix> gensyms body) - (if (null? gensyms) body x)) - - ((<lambda-case> req opt rest kw gensyms body alternate) - (define (args-compatible? args gensyms) - (let lp ((args args) (gensyms gensyms)) - (cond - ((null? args) (null? gensyms)) - ((null? gensyms) #f) - ((and (lexical-ref? (car args)) - (eq? (lexical-ref-gensym (car args)) (car gensyms))) - (lp (cdr args) (cdr gensyms))) - (else #f)))) - - (and (not opt) (not kw) rest (not alternate) - (record-case body - ((<application> proc args) - ;; (lambda args (apply (lambda ...) args)) => (lambda ...) - (and (primitive-ref? proc) - (eq? (primitive-ref-name proc) '@apply) - (pair? args) - (lambda? (car args)) - (args-compatible? (cdr args) gensyms) - (lambda-body (car args)))) - (else #f)))) - - ;; Actually the opposite of inlining -- if the prompt cannot be proven to - ;; be escape-only, ensure that its body is the application of a thunk. - ((<prompt> src tag body handler) - (define (escape-only? handler) - (and (pair? (lambda-case-req handler)) - (let ((cont (car (lambda-case-gensyms handler)))) - (tree-il-fold (lambda (leaf escape-only?) - (and escape-only? - (not - (and (lexical-ref? leaf) - (eq? (lexical-ref-gensym leaf) cont))))) - (lambda (down escape-only?) escape-only?) - (lambda (up escape-only?) escape-only?) - #t - (lambda-case-body handler))))) - (define (make-thunk body) - (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f))) - - (if (or (and (application? body) - (lambda? (application-proc body)) - (null? (application-args body))) - (escape-only? handler)) - x - (make-prompt src tag - (make-application #f (make-thunk body) '()) - handler))) - - (else #f))) - (post-order! inline1 x)) + (issue-deprecation-warning + "`inline!' is deprecated. Use (language tree-il peval) instead.") + x) |