3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
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)
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.
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.
22 (define-module (language tree-il optimize)
23 #:use-module (system base syntax)
24 #:use-module (language tree-il)
25 #:export (resolve-primitives!))
27 ;; Possible optimizations:
28 ;; * constant folding, propagation
29 ;; * procedure inlining
30 ;; * always when single call site
31 ;; * always for "trivial" procs
32 ;; * otherwise who knows
33 ;; * dead code elimination
34 ;; * degenerate case optimizations
37 (define (post-order! f x)
40 ((<application> proc args)
41 (set! (application-proc x) (lp proc))
42 (set! (application-args x) (map lp args))
45 ((<conditional> test then else)
46 (set! (conditional-test x) (lp test))
47 (set! (conditional-then x) (lp then))
48 (set! (conditional-else x) (lp else))
51 ((<primitive-ref> name)
54 ((<lexical-ref> name gensym)
57 ((<lexical-set> name gensym exp)
58 (set! (lexical-set-exp x) (lp exp))
61 ((<module-ref> mod name public?)
64 ((<module-set> mod name public? exp)
65 (set! (module-set-exp x) (lp exp))
68 ((<toplevel-ref> name)
71 ((<toplevel-set> name exp)
72 (set! (toplevel-set-exp x) (lp exp))
75 ((<toplevel-define> name exp)
76 (set! (toplevel-define-exp x) (lp exp))
79 ((<lambda> vars meta body)
80 (set! (lambda-body x) (lp body))
87 (set! (sequence-exps x) (map lp exps))
90 ((<let> vars vals exp)
91 (set! (let-vals x) (map lp vals))
92 (set! (let-exp x) (lp exp))
95 ((<letrec> vars vals exp)
96 (set! (letrec-vals x) (map lp vals))
97 (set! (letrec-exp x) (lp exp))
100 (define *interesting-primitive-names*
102 call-with-values @call-with-values
103 call-with-current-continuation @call-with-current-continuation
105 ;; compile-time-environment
108 + * - / 1- 1+ quotient remainder modulo
110 pair? null? list? acons cons cons*
117 caaar caadr cadar caddr cdaar cdadr cddar cdddr
119 caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
120 cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
122 (define *interesting-primitive-vars*
123 (let ((h (make-hash-table)))
124 (for-each (lambda (x)
125 (hashq-set! h (module-variable the-root-module x) x))
126 *interesting-primitive-names*)
129 (define (resolve-primitives! x mod)
133 ((<toplevel-ref> src name)
134 (and (hashq-ref *interesting-primitive-vars*
135 (module-variable mod name))
136 (make-primitive-ref src name)))
137 ((<module-ref> mod name public?)
138 (let ((m (if public? (resolve-interface mod) (resolve-module mod))))
139 (and m (hashq-ref *interesting-primitive-vars*
140 (module-variable m name))
141 (make-primitive-ref src name))))