source: project/chicken/trunk/misc/inline.scm @ 6892

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

some currently unused files

File size: 20.5 KB
Line 
1;;; this assumes that :
2;;;    a) nothing has been evaluated yet
3;;;    b) basic syntactical correctness has been assured (so a list l starting
4;;;       with 'define-inline will have the procedure-name as (caadr l) and
5;;;       arity for all procedure calls is correct)
6;;;    c) alpha substitution has occurred so all named symbols are guaranteed
7;;;       unique across all procedures
8;;;    d) optional, keyword, and rest arguments are not allowed for inline
9;;;       procedures (although it should be possible to add them)
10
11;; beginning of the pass
12;; takes the ordered quoted list of all top-level statements
13;; ends by calling either
14;;    inline-pass:final with the input list (if no inline procedures exist) and
15;;        null, or
16;;    inline-pass:graph-inline with two lists, the inline procedures (with some
17;;        metadata) and all non-inline-procedure statements.
18(define (inline-pass:start qlst)
19    (let find-inline ((q   qlst)   ; quoted top-level statements
20                      (i   0)      ; index of inline procedure for later steps
21                      (l   '())    ; inline procedures
22                      (r   '()))   ; non-inline statements
23        (cond ((null? q)
24                  (if (= 0 i)
25                      (inline-pass:final (reverse r) '())
26                      (inline-pass:graph-inline i (reverse l) (reverse r))))
27              ((and (list? (car q)) (eq? 'define-inline (caar q)))
28                  (find-inline
29                      (cdr q)
30                      (+ 1 i)
31                      (cons (cons (caadar q)
32                                  (vector i 0 (cddar q) (cdadar q)))
33                            l)
34                      r))
35              (else
36                  (find-inline (cdr q) i l (cons (car q) r))))))
37
38
39;; walks through a list
40;; takes a list, an index vector, and the metadata inline list from above
41;; ends by returning the (possibly modified) vector
42(define (inline-pass:walk l v ilst)
43    (let walk ((l   l)
44               (t   0))
45        (cond ((null? l)
46                  v)
47              ((list? (car l))
48                  (cond ((null? (car l))
49                            (walk (cdr l) t))
50                        ((eq? 'quote (caar l))
51                            (or (= 0 t)
52                                (walk (cdar l) 3))
53                            (walk (cdr l) t))
54                        ((eq? 'quasiquote (caar l))
55                            (walk (cdar l) 2)
56                            (walk (cdr l) t))
57                        ((or (eq? 'unquote (caar l))
58                             (eq? 'unquote-splicing (caar l)))
59                            (walk (cdar l) 1)
60                            (walk (cdr l) t))
61                        (else
62                            (walk (car l) t)
63                            (walk (cdr l) t))))
64              ((pair? (car l))
65                  (walk (unfold not-pair? car cdr (car l) list) t)
66                  (walk (cdr l) t))
67              ((vector? (car l))
68                  (walk (vector->list (car l)) t)
69                  (walk (cdr l) t))
70              ((not (symbol? (car l)))
71                  (walk (cdr l) t))
72              ((> t 1)
73                  (walk (cdr l) t))
74              ((alist-ref (car l) ilst) =>
75                  (lambda (d)
76                      (vector-set! v (vector-ref d 0) #t)
77                      (walk (cdr l) t)))
78              (else
79                  (walk (cdr l) t)))))
80
81
82;; builds a graph of calls to inline procedures from inline procedures
83;; takes the inline-list-length, inline metadata list, and other statements
84;; ends by calling inline-pass:simplify1 with the graph and input args
85(define (inline-pass:graph-inline i ilst rlst)
86    (inline-pass:simplify1
87        (map
88            (lambda (iv)
89                (cons (car iv)
90                      (inline-pass:walk
91                          (vector-ref (cdr iv) 3)
92                          (make-vector i #f)
93                          ilst)))
94            ilst)
95        i ilst rlst))
96
97
98;; simplifies direct self-call, no further inline, and only-self cases
99;; takes the graph, inline list length, inline metadata list, and statements
100;; ends by calling either:
101;;    inline-pass:simplify2 with the further inline, no-further-but-self inline,
102;;        graph, inline length, all inline, and other statements, or
103;;    inline-pass:final with the statements and inlines
104(define (inline-pass:simplify1 g i ilst rlst)
105    (for-each
106        (lambda (x)
107            (and (vector-ref (cdr x) (car x))
108                 (vector-set! (cdr (list-ref ilst (car x))) 1 1)))
109        g)
110    (let simple ((h   g)      ; graph
111                 (l   ilst)   ; inline metadata
112                 (r   '())    ; no further inlines (except possibly self)
113                 (s   '()))   ; further inlining
114        (cond ((null? h)
115                  (if (null? s)
116                      (inline-pass:final rlst r)
117                      (inline-pass:simplify2 s r g i ilst rlst)))
118              ((every (lambda (x i) (or (= i (caar h)) (not x)))
119                      (vector->list (cdar h)) (iota i))
120                  (simple (cdr h) (cdr l) (cons (car l) r) s))
121              (else
122                  (simple (cdr h) (cdr l) r (cons (car l) s))))))
123
124;; substitutes in inlined procedures
125;; takes the procedure in which to do the substitution (as a list) and the
126;;     list of inlined procedures with metadata
127;; ends with the new procedure-as-list
128;; note: there are four distinct cases -
129;;       1) inline procedure in application position, no self call :
130;;          becomes a (begin ...) with the arguments set locally
131;;       2) inline procedure in application position, with self call :
132;;          becomes a (let <name> (vars ...) ...)
133;;       3) inline procedure not in application position, no self call :
134;;          becomes a (lambda (arglist) ...)
135;;       4) inline procedure not in application position, with self call :
136;;          becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
137;;          symbols generated for arglist
138(define (inline-pass:subst1 l ilst)
139    (let walk ((l   l)
140               (t   0))
141        (cond ((null? l)
142                  l)
143              ((vector? l)
144                  (list->vector (walk (vector->list l) t)))
145              ((symbol? l)
146                  (cond ((> t 1)
147                            l)
148                        ((alist-ref l ilst) =>
149                            (lambda (d)
150                                (if (= 1 (vector-ref d 1))
151                                    (let* ((a   (map
152                                                    (lambda (x) (gensym 'ia))
153                                                    (vector-ref d 2)))
154                                           (m   (map
155                                                    (lambda (a x) (list a x))
156                                                    (vector-ref d 2) a)))
157                                        `(lambda ,a (let ,l ,m
158                                                         ,@(vector-ref d 3))))
159                                    `(lambda ,(vector-ref d 2)
160                                        ,@(vector-ref d 3)))))
161                        (else
162                            l)))
163              ((not (pair? l))
164                  l)
165              ((list? (car l))
166                  (cond ((null? (car l))
167                            (cons (car l) (walk (cdr l) t)))
168                        ((not (symbol? (caar l)))
169                            (cons (walk (car l) t) (walk (cdr l) t)))
170                        ((eq? 'quote (caar l))
171                            (if (= t 0)
172                                (cons (car l) (walk (cdr l) t))
173                                (cons `(quote ,(walk (cadr l) 3))
174                                      (walk (cdr l) t))))
175                        ((eq? 'quasiquote (caar l))
176                            (cons `(quasiquote ,(walk (cadr l) 2))
177                                  (walk (cdr l) t)))
178                        ((or (eq? 'unquote (caar l))
179                             (eq? 'unquote-splicing (caar l)))
180                            (cons `(,(caar l) ,(walk (cadr l) 1))
181                                  (walk (cdr l) t)))
182                        ((> t 1)
183                            (cons (walk (car l) t) (walk (cdr l) t)))
184                        ((alist-ref (caar l) ilst) =>
185                            (lambda (d)
186                                (cons
187                                    (if (= 1 (vector-ref d 1))
188                                        (let ((m   (map
189                                                       (lambda (a x) (list a x))
190                                                       (vector-ref d 2)
191                                                       (walk (cdar l) t))))
192                                            `(let ,(caar l) ,m
193                                                  ,@(vector-ref d 3)))
194                                        `(begin
195                                            ,@(map
196                                                  (lambda (a x)
197                                                      `(set-local! ,a ,x))
198                                                  (vector-ref d 2)
199                                                  (walk (cdar l) t))
200                                            ,@(vector-ref d 3)))
201                                    (walk (cdr l) t))))
202                        (else
203                            (cons (walk (car l) t) (walk (cdr l) t)))))
204              ((pair? (car l))
205                  (cons (cons (walk (caar l) t) (walk (cdar l) t))
206                        (walk (cdr l) t)))
207              ((vector? (car l))
208                  (cons (list->vector (walk (vector->list (car l)) t))
209                        (walk (cdr l) t)))
210              ((not (symbol? (car l)))
211                  (cons (car l) (walk (cdr l) t)))
212              ((> t 1)
213                  (cons (car l) (walk (cdr l) t)))
214              ((alist-ref (car l) ilst) =>
215                  (lambda (d)
216                      (cons
217                          (if (= 1 (vector-ref d 1))
218                              (let* ((a   (map
219                                              (lambda (x) (gensym 'ia))
220                                              (vector-ref d 2)))
221                                     (m   (map
222                                              (lambda (a x) (list a x))
223                                              (vector-ref d 2) a)))
224                                  `(lambda ,a (let ,(car l) ,m
225                                                  ,@(vector-ref d 3))))
226                              `(lambda ,(vector-ref d 2) ,@(vector-ref d 3)))
227                          (walk (cdr l) t))))
228              (else
229                  (cons (car l) (walk (cdr l) t))))))
230
231
232;; substitutes in inlined procedures with further processing
233;; takes the procedure in which to do the substitution (as a list), the
234;;     list of inlined procedures with metadata, and a list of procedures to
235;;     not treat as inline
236;; ends with the new procedure-as-list
237;; note: there are four distinct cases -
238;;       1) inline procedure in application position, no self call :
239;;          becomes a (begin ...) with the arguments set locally
240;;       2) inline procedure in application position, with self call :
241;;          becomes a (let <name> (vars ...) ...)
242;;       3) inline procedure not in application position, no self call :
243;;          becomes a (lambda (arglist) ...)
244;;       4) inline procedure not in application position, with self call :
245;;          becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
246;;          symbols generated for arglist
247(define (inline-pass:subst2 l ilst nof)
248    (let walk ((l   l)
249               (n   nof)
250               (t   0))
251        (cond ((null? l)
252                  l)
253              ((vector? l)
254                  (list->vector (walk (vector->list l) t n)))
255              ((symbol? l)
256                  (cond ((> t 1)
257                            l)
258                        ((memq l n) =>
259                            (lambda (m)
260                                (let ((d   (alist-ref l ilst)))
261                                    (if (= 1 (vector-ref d 1))
262                                        l
263                                        (begin
264                                            (vector-set! d 1 1)
265                                            (if (= 1 (length m))
266                                                l
267                                                (walk l t (cdr m))))))))
268                        ((alist-ref l ilst) =>
269                            (lambda (d)
270                                (if (= 1 (vector-ref d 1))
271                                    (let* ((a   (map
272                                                    (lambda (x) (gensym 'ia))
273                                                    (vector-ref d 2)))
274                                           (m   (map
275                                                    (lambda (a x) (list a x))
276                                                    (vector-ref d 2) a)))
277                                        `(lambda ,a (let ,l ,m
278                                            ,@(walk (vector-ref d 3) t
279                                                    (cons l n)))))
280                                    `(lambda ,(vector-ref d 2)
281                                        ,@(walk (vector-ref d 3) t
282                                                (cons l n))))))
283                        (else
284                            l)))
285              ((not (pair? l))
286                  l)
287              ((list? (car l))
288                  (cond ((null? (car l))
289                            (cons (car l) (walk (cdr l) t n)))
290                        ((not (symbol? (caar l)))
291                            (cons (walk (car l) t n) (walk (cdr l) t n)))
292                        ((eq? 'quote (caar l))
293                            (if (= t 0)
294                                (cons (car l) (walk (cdr l) t n))
295                                (cons `(quote ,(walk (cadr l) 3 n))
296                                      (walk (cdr l) t n))))
297                        ((eq? 'quasiquote (caar l))
298                            (cons `(quasiquote ,(walk (cadr l) 2 n))
299                                  (walk (cdr l) t n)))
300                        ((or (eq? 'unquote (caar l))
301                             (eq? 'unquote-splicing (caar l)))
302                            (cons `(,(caar l) ,(walk (cadr l) 1 n))
303                                  (walk (cdr l) t n)))
304                        ((> t 1)
305                            (cons (walk (car l) t n) (walk (cdr l) t n)))
306                        ((memq (caar l) n) =>
307                            (lambda (m)
308                                (let ((d   (alist-ref (caar l) ilst)))
309                                    (if (= 1 (vector-ref d 1))
310                                        (cons (cons (caar l)
311                                                    (walk (cdar l) t n))
312                                              (walk (cdr l) t n))
313                                        (begin
314                                            (vector-set! d 1 1)
315                                            (if (= 1 (length m))
316                                                (cons (cons (caar l)
317                                                            (walk (cdar l) t n))
318                                                      (walk (cdr l) t n))
319                                                (walk l t
320                                                      (cdr m))))))))
321                        ((alist-ref (caar l) ilst) =>
322                            (lambda (d)
323                                (cons
324                                    (if (= 1 (vector-ref d 1))
325                                        (let ((m   (map
326                                                       (lambda (a x) (list a x))
327                                                       (vector-ref d 2)
328                                                       (walk (cdar l) t
329                                                           (cons (caar l) n)))))
330                                            `(let ,(caar l) ,m
331                                                  ,@(walk (vector-ref d 3) t
332                                                          (cons (caar l) n))))
333                                        `(begin
334                                            ,@(map
335                                                  (lambda (a x)
336                                                      `(set-local! ,a ,x))
337                                                  (vector-ref d 2)
338                                                  (walk (cdar l) t
339                                                      (cons (caar l) n)))
340                                            ,@(walk (vector-ref d 3) t
341                                                    (cons (caar l) n))))
342                                    (walk (cdr l) t n))))
343                        (else
344                            (cons (walk (car l) t n) (walk (cdr l) t n)))))
345              ((pair? (car l))
346                  (cons (cons (walk (caar l) t n) (walk (cdar l) t n))
347                        (walk (cdr l) t n)))
348              ((vector? (car l))
349                  (cons (list->vector (walk (vector->list (car l)) t n))
350                        (walk (cdr l) t n)))
351              ((not (symbol? (car l)))
352                  (cons (car l) (walk (cdr l) t n)))
353              ((> t 1)
354                  (cons (car l) (walk (cdr l) t)))
355              ((memq (car l) n) =>
356                  (lambda (m)
357                      (let ((d   (alist-ref (car l) ilst)))
358                          (if (= 1 (vector-ref d 1))
359                              (cons (car l) (walk (cdr l) t n))
360                              (begin
361                                  (vector-set! d 1 1)
362                                  (if (= 1 (length m))
363                                      (cons (car l) (walk (cdr l) t n))
364                                      (walk l t (cdr m))))))))
365              ((alist-ref (car l) ilst) =>
366                  (lambda (d)
367                      (cons
368                          (if (= 1 (vector-ref d 1))
369                              (let* ((a   (map
370                                              (lambda (x) (gensym 'ia))
371                                              (vector-ref d 2)))
372                                     (m   (map
373                                              (lambda (a x) (list a x))
374                                              (vector-ref d 2) a)))
375                                  `(lambda ,a (let ,l ,m 
376                                      ,@(walk (vector-ref d 3) t
377                                              (cons (car l) n)))))
378                              `(lambda ,(vector-ref d 2) 
379                                  ,@(walk (vector-ref d 3) t (cons (car l) n))))
380                          (walk (cdr l) t n))))
381              (else
382                  (cons (car l) (walk (cdr l) t n))))))
383
384;; finds which inlined procedures are called from non-inlined procedures
385;; performs substitutions for all inline procedures
386;; takes the further inline procedures, no further inline procedures, graph,
387;;     inlined procedures list, and statements list
388;; ends by calling inline-pass:final with the statements and inline procedures
389;;     ready for substitution
390(define (inline-pass:simplify2 fur nof g ilst rlst)
391    (for-each
392        (lambda (x)
393            (vector-set! (cdr x) 3
394                (inline-pass:subst1 (vector-ref (cdr x) 3) nof)))
395        fur)
396    (let ((v   (inline-pass:walk rlst (make-vector i #f) fur)))
397        (for-each
398            (lambda (x)
399                (vector-set! (cdr x) 3
400                    (inline-pass:subst2 (vector-ref (cdr x) 3) ilst
401                        (list (car x)))))
402            (vector-fold
403                (lambda (i r x)
404                    (if x
405                        (cons (list-ref ilst i) r)
406                        r))
407                '() v))
408        (inline-pass:final rlst ilst)))
409
410
411;; inlines all procedures
412;; takes the list of statements and the list of inline procedures with metadata
413;; returns the list of statements with all procedures inlined
414(define (inline-pass:final rlst ilst)
415    (if (null? ilst)
416        rlst
417        (inline-pass:subst1 rlst ilst)))
418
Note: See TracBrowser for help on using the repository browser.