source: project/chicken/trunk/misc/inl.scm @ 12088

Last change on this file since 12088 was 12088, checked in by felix winkelmann, 12 years ago

fixes in inl.scm

File size: 2.4 KB
Line 
1;;;; collect cross-module inlining candidates
2
3
4(define (node->sexpr n)
5  (let walk ((n n))
6    `(,(node-class n)
7      ,(node-parameters n)
8      ,@(map walk (node-subexpressions n)))))
9
10
11(define (collect-cmi-candidates node db)
12  (let ((collected '()))
13    (define (exported? var)
14      (and (##compiler#get db var 'global)
15           (not (##compiler#get db var 'standard-binding))
16           (not (##compiler#get db var 'extended-binding))
17           (or (memq var ##compiler#export-list)
18               (not (memq var ##compiler#block-globals)))))
19    (define (walk n e le k dest)
20      (let ((params (node-parameters n))
21            (subs (node-subexpressions n)))
22        ;(pp `(WALK: ,(node-class n) ,e ,le))
23        (case (node-class n)
24          ((##core#variable) 
25           (let ((var (car params)))
26             (cond ((memq var e) #t)
27                   ((memq var le) 1)    ; references lexical variable
28                   ((exported? var) #t)
29                   (else #f))))
30          ((let)
31           (let* ((r (walk (car subs) e le k #f))
32                  (r2 (walk (cadr subs) (cons (car params) e) le k dest)))
33             (cond ((eq? r 1) (and r2 1))
34                   (r r2)
35                   (else #f))))
36          ((##core#lambda)
37           (##compiler#decompose-lambda-list
38            (third params)
39            (lambda (vars argc rest)
40              (let ((k (and (pair? vars) (car vars))))
41                (cond ((walk (car subs) vars (append e le) k #f) =>
42                       (lambda (r)
43                         ;; if lambda doesn't refer to outer lexicals, collect
44                         (when (and dest
45                                    (not (eq? 1 r))
46                                    (not (memq dest ##compiler#not-inline-list))
47                                    (or (memq dest ##compiler#not-inline-list)
48                                        (<= (fourth params) ##compiler#inline-max-size)))
49                           (set! collected (alist-cons dest n collected)))
50                         #t))
51                      (else #f))))))
52          ((set!)
53           (let ((var (car params)))
54             (walk (car subs) e le k (and (exported? var) var))))
55          ((##core#callunit) #f)
56          ((##core#call)
57           ;; only allow continuation-calls (i.e. returns) and self-recursion
58           (and (eq? '##core#variable (node-class (car subs)))
59                (let ((var (car (node-parameters (car subs)))))
60                  (or (eq? var k)
61                      (eq? var dest)))
62                (every (cut walk <> e le k #f) subs)))
63          ((if)
64           (and (walk (first subs) e le k #f)
65                (walk (second subs) e le k dest)
66                (walk (third subs) e le k dest)))
67          (else (every (cut walk <> e le k #f) subs)))))
68    (walk node '() '() #f #f)
69    (for-each
70     (lambda (p)
71       (display "#,")
72       (pp `(node ,(car p) ,(node->sexpr (cdr p))))
73       (newline))
74     collected)))
75
76(user-post-optimization-pass collect-cmi-candidates)
Note: See TracBrowser for help on using the repository browser.