1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
;;; a simple inliner
;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; 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"
;; 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 vars body else)
(if (and (= (length vars) (length req) (length args)))
(let ((x (make-let src req vars args body)))
(or (inline1 x) x))
(lp else)))))))
;; (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.
((<primitive-ref> name)
(and (eq? name '@call-with-values)
(pmatch args
((,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-else (lambda-body consumer))))
(make-let-values
src
(let ((x (make-application src producer '())))
(or (inline1 x) x))
(lambda-body consumer)))
(else #f))))
(else #f)))
((<let> vars body)
(if (null? vars) body x))
((<letrec> vars body)
(if (null? vars) body x))
((<fix> vars body)
(if (null? vars) body x))
(else #f)))
(post-order! inline1 x))
|