summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
blob: 14460ebab35716f5bf097e998a1c6e46c88efa27 (plain)
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
;;; Tree-il optimizer

;; Copyright (C) 2009 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; This program 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 General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(define-module (language tree-il optimize)
  #:use-module (system base syntax)
  #:use-module (language tree-il)
  #:use-module (language tree-il inline)
  #:export (optimize!))

(define (env-module e)
  (if e (car e) (current-module)))

(define (optimize! x env opts)
  (expand-primitives! (resolve-primitives! x (env-module env))))

;; 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 *interesting-primitive-names* 
  '(apply @apply
    call-with-values @call-with-values
    call-with-current-continuation @call-with-current-continuation
    values
    ;; compile-time-environment
    eq? eqv? equal?
    = < > <= >= zero?
    + * - / 1- 1+ quotient remainder modulo
    not
    pair? null? list? acons cons cons*

    car cdr
    set-car! set-cdr!

    caar cadr cdar cddr

    caaar caadr cadar caddr cdaar cdadr cddar cdddr

    caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
    cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))

(define *interesting-primitive-vars*
  (let ((h (make-hash-table)))
    (for-each (lambda (x)
                (hashq-set! h (module-variable the-root-module x) x))
              *interesting-primitive-names*)
    h))

(define (resolve-primitives! x mod)
  (post-order!
   (lambda (x)
     (record-case x
       ((<toplevel-ref> src name)
        (and (hashq-ref *interesting-primitive-vars*
                        (module-variable mod name))
             (make-primitive-ref src name)))
       ((<module-ref> mod name public?)
        (let ((m (if public? (resolve-interface mod) (resolve-module mod))))
          (and m (hashq-ref *interesting-primitive-vars*
                            (module-variable m name))
               (make-primitive-ref src name))))
       (else #f)))
   x))