3 ;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (define-module (language tree-il inline)
20 #:use-module (system base pmatch)
21 #:use-module (system base syntax)
22 #:use-module (language tree-il)
25 ;; Possible optimizations:
26 ;; * constant folding, propagation
27 ;; * procedure inlining
28 ;; * always when single call site
29 ;; * always for "trivial" procs
30 ;; * otherwise who knows
31 ;; * dead code elimination
32 ;; * degenerate case optimizations
35 ;; This is a completely brain-dead optimization pass whose sole claim to
36 ;; fame is ((lambda () x)) => x.
40 ((<application> src proc args)
42 ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
44 (let lp ((lcase body))
47 ((<lambda-case> req opt rest kw inits vars body alternate)
48 (if (and (= (length vars) (length req) (length args)))
49 (let ((x (make-let src req vars args body)))
53 ((<primitive-ref> name)
57 ;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
58 ;; => (let-values (((a b . c) foo)) bar)
60 ;; Note that this is a singly-binding form of let-values.
61 ;; Also note that Scheme's let-values expands into
62 ;; call-with-values, then here we reduce it to tree-il's
64 ((,producer ,consumer)
65 (guard (lambda? consumer)
66 (lambda-case? (lambda-body consumer))
67 (not (lambda-case-opt (lambda-body consumer)))
68 (not (lambda-case-kw (lambda-body consumer)))
69 (not (lambda-case-alternate (lambda-body consumer))))
72 (let ((x (make-application src producer '())))
74 (lambda-body consumer)))
79 ((,k ,l) (guard (const? l) (list? (const-exp l)))
80 (if (null? (const-exp l))
82 (let lp ((elts (const-exp l)))
83 (let ((test (make-application
85 (make-primitive-ref #f (case name
88 (else (error "what"))))
89 (list k (make-const #f (car elts))))))
90 (if (null? (cdr elts))
105 (if (null? vars) body x))
107 ((<letrec> vars body)
108 (if (null? vars) body x))
111 (if (null? vars) body x))
113 ((<lambda-case> req opt rest kw vars body alternate)
115 (define (args-compatible? args vars)
116 (let lp ((args args) (vars vars))
118 ((null? args) (null? vars))
120 ((and (lexical-ref? (car args))
121 (eq? (lexical-ref-gensym (car args)) (car vars)))
122 (lp (cdr args) (cdr vars)))
125 (and (not opt) (not kw) (not alternate)
127 ((<application> proc args)
128 ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
129 (and (primitive-ref? proc)
130 (eq? (primitive-ref-name proc) '@apply)
133 (args-compatible? (cdr args) vars)
134 (lambda-body (car args))))
138 (post-order! inline1 x))