Commit | Line | Data |
---|---|---|
9efc833d AW |
1 | ;;; Tree-il optimizer |
2 | ||
3 | ;; Copyright (C) 2009 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
9 | ;; | |
10 | ;; This program 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 | |
13 | ;; GNU General Public License for more details. | |
14 | ;; | |
15 | ;; You should have received a copy of the GNU General Public License | |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language tree-il optimize) | |
23 | #:use-module (system base syntax) | |
24 | #:use-module (language tree-il) | |
073bb617 AW |
25 | #:use-module (language tree-il inline) |
26 | #:export (optimize!)) | |
27 | ||
28 | (define (env-module e) | |
29 | (if e (car e) (current-module))) | |
30 | ||
31 | (define (optimize! x env opts) | |
32 | (expand-primitives! (resolve-primitives! x (env-module env)))) | |
9efc833d AW |
33 | |
34 | ;; Possible optimizations: | |
35 | ;; * constant folding, propagation | |
36 | ;; * procedure inlining | |
37 | ;; * always when single call site | |
38 | ;; * always for "trivial" procs | |
39 | ;; * otherwise who knows | |
40 | ;; * dead code elimination | |
41 | ;; * degenerate case optimizations | |
42 | ;; * "fixing letrec" | |
43 | ||
9efc833d AW |
44 | (define *interesting-primitive-names* |
45 | '(apply @apply | |
46 | call-with-values @call-with-values | |
47 | call-with-current-continuation @call-with-current-continuation | |
48 | values | |
49 | ;; compile-time-environment | |
50 | eq? eqv? equal? | |
51 | = < > <= >= zero? | |
52 | + * - / 1- 1+ quotient remainder modulo | |
53 | not | |
54 | pair? null? list? acons cons cons* | |
55 | ||
56 | car cdr | |
57 | set-car! set-cdr! | |
58 | ||
59 | caar cadr cdar cddr | |
60 | ||
61 | caaar caadr cadar caddr cdaar cdadr cddar cdddr | |
62 | ||
63 | caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr | |
64 | cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) | |
65 | ||
66 | (define *interesting-primitive-vars* | |
67 | (let ((h (make-hash-table))) | |
68 | (for-each (lambda (x) | |
69 | (hashq-set! h (module-variable the-root-module x) x)) | |
70 | *interesting-primitive-names*) | |
71 | h)) | |
72 | ||
73 | (define (resolve-primitives! x mod) | |
74 | (post-order! | |
75 | (lambda (x) | |
76 | (record-case x | |
77 | ((<toplevel-ref> src name) | |
78 | (and (hashq-ref *interesting-primitive-vars* | |
79 | (module-variable mod name)) | |
80 | (make-primitive-ref src name))) | |
a1a482e0 | 81 | ((<module-ref> src mod name public?) |
ce09ee19 AW |
82 | ;; for the moment, we're disabling primitive resolution for |
83 | ;; public refs because resolve-interface can raise errors. | |
84 | (let ((m (and (not public?) (resolve-module mod)))) | |
9efc833d AW |
85 | (and m (hashq-ref *interesting-primitive-vars* |
86 | (module-variable m name)) | |
87 | (make-primitive-ref src name)))) | |
88 | (else #f))) | |
89 | x)) |