source: project/chicken/trunk/optimizer.scm @ 16108

Last change on this file since 16108 was 16108, checked in by felix winkelmann, 10 years ago

removed pointless internal library function; removed commented out bug in optimizer; line-break in scrutinizer error message

File size: 60.4 KB
Line 
1;;;; optimizer.scm - The CHICKEN Scheme compiler (optimizations)
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8; conditions are met:
9;
10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11;     disclaimer.
12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13;     disclaimer in the documentation and/or other materials provided with the distribution.
14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
15;     products derived from this software without specific prior written permission.
16;
17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25; POSSIBILITY OF SUCH DAMAGE.
26
27
28(declare
29  (unit optimizer)
30  (not inline ##sys#compiler-syntax-hook) )
31
32
33(include "compiler-namespace")
34(include "tweaks")
35
36(define-constant maximal-number-of-free-variables-for-liftable 16)
37
38
39;;; Scan toplevel expressions for assignments:
40
41(define (scan-toplevel-assignments node)
42  (let ([safe '()]
43        [unsafe '()] )
44
45    (define (mark v)
46      (if (not (memq v unsafe)) (set! safe (cons v safe))) )
47
48    (debugging 'p "scanning toplevel assignments...")
49    (call-with-current-continuation
50     (lambda (return)
51
52       (define (scan-each ns e)
53         (for-each (lambda (n) (scan n e)) ns) )
54
55       (define (scan n e)
56         (let ([params (node-parameters n)]
57               [subs (node-subexpressions n)] )
58           (case (node-class n)
59
60             [(##core#variable)
61              (let ([var (first params)])
62                (if (and (not (memq var e)) (not (memq var safe)))
63                    (set! unsafe (cons var unsafe)) ) ) ]
64
65             [(if ##core#cond ##core#switch)
66              (scan (first subs) e)
67              (return #f) ]
68
69             [(let)
70              (scan (first subs) e)
71              (scan (second subs) (append params e)) ]
72
73             [(lambda ##core#callunit) #f]
74
75             [(##core#call) (return #f)]
76
77             [(set!)
78              (let ([var (first params)])
79                (if (not (memq var e)) (mark var))
80                (scan (first subs) e) ) ]
81
82             [else (scan-each subs e)] ) ) )
83
84       (scan node '()) ) )
85    (debugging 'o "safe globals" safe)
86    (for-each (cut mark-variable <> '##compiler#always-bound) safe)))
87
88
89;;; Do some optimizations:
90;
91; - optimize tail recursion by replacing trivial continuations.
92; - perform beta-contraction (inline procedures called only once).
93; - remove empty 'let' nodes.
94; - evaluate constant expressions.
95; - substitute variables bound to constants with the value.
96; - remove variable-bindings which are never used (and which are not bound to side-effecting expressions).
97; - perform simple copy-propagation.
98; - remove assignments to unused variables if the assigned value is free of side-effects and the variable is
99;   not global.
100; - remove unused formal parameters from functions and change all call-sites accordingly.
101; - rewrite calls to standard bindings into more efficient forms.
102; - rewrite calls to known non-escaping procedures with rest parameter to cons up rest-list at call-site,
103;   also: change procedure's lambda-list.
104
105(define simplifications (make-vector 301 '()))
106(define simplified-ops '())
107
108(define (perform-high-level-optimizations node db)
109  (let ([removed-lets 0]
110        [removed-ifs 0]
111        [replaced-vars 0]
112        [rest-consers '()]
113        [simplified-classes '()]
114        [dirty #f] )
115
116    (define (test sym item) (get db sym item))
117    (define (constant-node? n) (eq? 'quote (node-class n)))
118    (define (node-value n) (first (node-parameters n)))
119    (define (touch) (set! dirty #t))
120
121    (define (simplify n)
122      (or (and-let* ([entry (##sys#hash-table-ref simplifications (node-class n))])
123            (any (lambda (s)
124                   (and-let* ([vars (second s)]
125                              [env (match-node n (first s) vars)] 
126                              [n2 (apply (third s) db
127                                         (map (lambda (v) (cdr (assq v env))) vars) ) ] )
128                     (let* ([name (caar s)]
129                            [counter (assq name simplified-classes)] )
130                       (if counter
131                           (set-cdr! counter (add1 (cdr counter)))
132                           (set! simplified-classes (alist-cons name 1 simplified-classes)) )
133                       (touch)
134                       (simplify n2) ) ) )
135                 entry) )
136          n) )
137
138    (define (walk n fids)
139      (if (memq n broken-constant-nodes)
140          n
141          (simplify
142           (let* ((odirty dirty)
143                  (n1 (walk1 n fids))
144                  (subs (node-subexpressions n1)) )
145             (case (node-class n1)
146
147               ((if)                    ; (This can be done by the simplificator...)
148                (cond ((constant-node? (car subs))
149                       (set! removed-ifs (+ removed-ifs 1))
150                       (touch)
151                       (walk (if (node-value (car subs))
152                                 (cadr subs)
153                                 (caddr subs) )
154                             fids) )
155                      (else n1) ) )
156
157               ((##core#call)
158                (if (eq? '##core#variable (node-class (car subs)))
159                    (let ((var (first (node-parameters (car subs)))))
160                      (if (and (intrinsic? var)
161                               (foldable? var)
162                               (every constant-node? (cddr subs)) )
163                          (let ((form (cons var (map (lambda (arg) `(quote ,(node-value arg)))
164                                                     (cddr subs) ) ) ) )
165                            (handle-exceptions ex
166                                (begin
167                                  (unless odirty (set! dirty #f))
168                                  (set! broken-constant-nodes (lset-adjoin eq? broken-constant-nodes n1))
169                                  n1)
170                              (let ((x (eval form)))
171                                (debugging 'o "folding constant expression" form)
172                                (touch)
173                                (make-node ; Build call to continuation with new result...
174                                 '##core#call
175                                 '(#t)
176                                 (list (cadr subs) (qnode x)) ) ) ) )
177                          n1) )
178                    n1) )
179
180               (else n1) ) ) ) ) )
181
182    (define (walk1 n fids)
183      (let ((subs (node-subexpressions n))
184            (params (node-parameters n)) 
185            (class (node-class n)) )
186        (case class
187
188          ((##core#variable)
189           (let replace ((var (first params)))
190             (cond ((test var 'replacable) => replace)
191                   ((test var 'collapsable)
192                    (touch)
193                    (debugging 'o "substituted constant variable" var)
194                    (qnode (car (node-parameters (test var 'value)))) )
195                   (else
196                    (if (not (eq? var (first params)))
197                        (begin
198                          (touch)
199                          (set! replaced-vars (+ replaced-vars 1)) ) )
200                    (varnode var) ) ) ) )
201
202          ((let)
203           (let ([var (first params)])
204             (cond [(or (test var 'removable)
205                        (and (test var 'contractable) (not (test var 'replacing))) )
206                    (touch)
207                    (set! removed-lets (add1 removed-lets))
208                    (walk (second subs) fids) ]
209                   [else (make-node 'let params (map (cut walk <> fids) subs))] ) ) )
210
211          ((##core#lambda)
212           (let ((llist (third params))
213                 (id (first params)))
214             (cond [(test id 'has-unused-parameters)
215                    (decompose-lambda-list
216                     llist
217                     (lambda (vars argc rest)
218                       (receive (unused used) (partition (lambda (v) (test v 'unused)) vars)
219                         (touch)
220                         (debugging 'o "removed unused formal parameters" unused)
221                         (make-node
222                          '##core#lambda
223                          (list (first params) (second params)
224                                (cond [(and rest (test id 'explicit-rest))
225                                       (debugging 'o "merged explicitly consed rest parameter" rest)
226                                       (build-lambda-list used (add1 argc) #f) ]
227                                      [else (build-lambda-list used argc rest)] )
228                                (fourth params) )
229                          (list (walk (first subs) (cons id fids))) ) ) ) ) ]
230                   [(test id 'explicit-rest)
231                    (decompose-lambda-list
232                     llist
233                     (lambda (vars argc rest)
234                       (touch)
235                       (debugging 'o "merged explicitly consed rest parameter" rest)
236                       (make-node
237                        '##core#lambda
238                        (list (first params)
239                              (second params)
240                              (build-lambda-list vars (add1 argc) #f)
241                              (fourth params) )
242                        (list (walk (first subs) (cons id fids))) ) ) ) ]
243                   [else (walk-generic n class params subs (cons id fids))] ) ) )
244
245          ((##core#call)
246           (let* ([fun (car subs)]
247                  [funclass (node-class fun)] )
248             (case funclass
249               [(##core#variable)
250                ;; Call to named procedure:
251                (let* ([var (first (node-parameters fun))]
252                       [lval (and (not (test var 'unknown)) 
253                                  (or (test var 'value)
254                                      (test var 'local-value)))]
255                       [args (cdr subs)] )
256                  (cond [(test var 'contractable)
257                         (let* ([lparams (node-parameters lval)]
258                                [llist (third lparams)] )
259                           (check-signature var args llist)
260                           (debugging 'o "contracted procedure" var)
261                           (touch)
262                           (for-each (cut put! db <> 'inline-target #t) fids)
263                           (walk
264                            (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
265                            fids) ) ]
266                        [(memq var constant-declarations)
267                         (or (and-let* ((k (car args))
268                                        ((eq? '##core#variable (node-class k)))
269                                        (kvar (first (node-parameters k)))
270                                        (lval (and (not (test kvar 'unknown)) (test kvar 'value))) 
271                                        ((eq? '##core#lambda (node-class lval)))
272                                        (llist (third (node-parameters lval)))
273                                        ((or (test (car llist) 'unused)
274                                             (and (not (test (car llist) 'references))
275                                                  (not (test (car llist) 'assigned)))))
276                                        ((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
277                               (debugging 'x "removed call to constant procedure with unused result" var)
278                               (make-node
279                                '##core#call '(#t)
280                                (list k (make-node '##core#undefined '() '())) ) ) 
281                             (walk-generic n class params subs fids)) ]
282                        [(and lval
283                              (eq? '##core#lambda (node-class lval)))
284                         (let* ([lparams (node-parameters lval)]
285                                [llist (third lparams)] )
286                           (decompose-lambda-list
287                            llist
288                            (lambda (vars argc rest)
289                              (let ([ifid (first lparams)])
290                                (cond [(and inline-locally 
291                                            (test var 'inlinable)
292                                            (not (test (first lparams) 'inline-target)) ; inlinable procedure has changed
293                                            (case (variable-mark var '##compiler#inline) 
294                                              ((yes) #t)
295                                              ((no) #f)
296                                              (else
297                                               (< (fourth lparams) inline-max-size) ) ))
298                                       (debugging 
299                                        'i
300                                        (if (node? (variable-mark var '##compiler#inline-global))
301                                            "global inlining" 
302                                            "inlining")
303                                        var ifid (fourth lparams))
304                                       (for-each (cut put! db <> 'inline-target #t) fids)
305                                       (check-signature var args llist)
306                                       (debugging 'o "inlining procedure" var)
307                                       (touch)
308                                       (walk
309                                        (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
310                                        fids) ]
311                                      [(test ifid 'has-unused-parameters)
312                                       (if (< (length args) argc) ; Expression was already optimized (should this happen?)
313                                           (walk-generic n class params subs fids)
314                                           (let loop ((vars vars) (argc argc) (args args) (used '()))
315                                             (cond [(or (null? vars) (zero? argc))
316                                                    (touch)
317                                                    (make-node
318                                                     '##core#call
319                                                     params
320                                                     (map (cut walk <> fids) (cons fun (append-reverse used args))) ) ]
321                                                   [(test (car vars) 'unused)
322                                                    (touch)
323                                                    (debugging
324                                                     'o "removed unused parameter to known procedure" 
325                                                     (car vars) var)
326                                                    (if (expression-has-side-effects? (car args) db)
327                                                        (make-node
328                                                         'let
329                                                         (list (gensym 't))
330                                                         (list (walk (car args) fids)
331                                                               (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
332                                                        (loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
333                                                   [else (loop (cdr vars)
334                                                               (sub1 argc)
335                                                               (cdr args)
336                                                               (cons (car args) used) ) ] ) ) ) ]
337                                      [(and (test ifid 'explicit-rest)
338                                            (not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
339                                       (let ([n (llist-length llist)])
340                                         (if (< (length args) n)
341                                             (walk-generic n class params subs fids)
342                                             (begin
343                                               (debugging 'o "consed rest parameter at call site" var n)
344                                               (let-values ([(args rargs) (split-at args n)])
345                                                 (let ([n2 (make-node
346                                                            '##core#call
347                                                            params
348                                                            (map (cut walk <> fids)
349                                                                 (cons fun
350                                                                       (append
351                                                                        args
352                                                                        (list
353                                                                         (if (null? rargs)
354                                                                             (qnode '())
355                                                                             (make-node
356                                                                              '##core#inline_allocate 
357                                                                              (list "C_a_i_list" (* 3 (length rargs)))
358                                                                              rargs) ) ) ) ) ) ) ] )
359                                                   (set! rest-consers (cons n2 rest-consers))
360                                                   n2) ) ) ) ) ]
361                                      [else (walk-generic n class params subs fids)] ) ) ) ) ) ]
362                        [else (walk-generic n class params subs fids)] ) ) ]
363               [(##core#lambda)
364                (if (first params)
365                    (walk-generic n class params subs fids)
366                    (make-node '##core#call (cons #t (cdr params)) (map (cut walk <> fids) subs)) ) ]
367               [else (walk-generic n class params subs fids)] ) ) )
368
369          ((set!)
370           (let ([var (first params)])
371             (cond [(or (test var 'contractable) (test var 'replacable))
372                    (touch)
373                    (make-node '##core#undefined '() '()) ]
374                   [(and (or (not (test var 'global))
375                             (not (variable-visible? var)))
376                         (not (test var 'inline-transient))
377                         (not (test var 'references)) 
378                         (not (expression-has-side-effects? (first subs) db)) )
379                    (touch)
380                    (debugging 'o "removed side-effect free assignment to unused variable" var)
381                    (make-node '##core#undefined '() '()) ]
382                   [else (make-node 'set! params (list (walk (car subs) fids)))] ) ) )
383
384          (else (walk-generic n class params subs fids)) ) ) )
385   
386    (define (walk-generic n class params subs fids)
387      (let ((subs2 (map (cut walk <> fids) subs)))
388        (if (every eq? subs subs2)
389            n
390            (make-node class params subs2) ) ) )
391
392    (if (perform-pre-optimization! node db)
393        (values node #t)
394        (begin
395          (debugging 'p "traversal phase...")
396          (set! simplified-ops '())
397          (let ((node2 (walk node '())))
398            (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
399            (when (and (pair? simplified-ops) (debugging 'o "  call simplifications:"))
400              (for-each
401               (lambda (p)
402                 (print* #\tab (car p))
403                 (if (> (cdr p) 1)
404                     (print #\tab (cdr p))
405                     (newline) ) )
406               simplified-ops) )
407            (when (> replaced-vars 0) (debugging 'o "replaced variables" replaced-vars))
408            (when (> removed-lets 0) (debugging 'o "removed binding forms" removed-lets))
409            (when (> removed-ifs 0) (debugging 'o "removed conditional forms" removed-ifs))
410            (values node2 dirty) ) ) ) ) )
411
412
413;;; Pre-optimization phase:
414;
415; - Transform expressions of the form '(if (not <x>) <y> <z>)' into '(if <x> <z> <y>)'.
416; - Transform expressions of the form '(if (<x> <y> ...) <z> <q>)' into '<z>' if <x> names a
417;   standard-binding that is never #f and if it's arguments are free of side-effects.
418
419(define (perform-pre-optimization! node db)
420  (let ((dirty #f)
421        (removed-nots 0) )
422
423    (define (touch) (set! dirty #t) #t)
424    (define (test sym prop) (get db sym prop))
425
426    (debugging 'p "pre-optimization phase...")
427
428    ;; Handle '(if (not ...) ...)':
429    (if (intrinsic? 'not)
430        (for-each
431         (lambda (site)
432           (let* ((n (cdr site))
433                  (subs (node-subexpressions n))
434                  (kont (first (node-parameters (second subs))))
435                  (lnode (and (not (test kont 'unknown)) (test kont 'value)))
436                  (krefs (get-list db kont 'references)) )
437             ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
438             ;;  that has only one use:
439             (when (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
440                        (eq? '##core#lambda (node-class lnode)) )
441               (let* ((llist (third (node-parameters lnode)))
442                      (body (first (node-subexpressions lnode))) 
443                      (bodysubs (node-subexpressions body)) )
444                 ;; Continuation has one parameter?
445                 (if (and (proper-list? llist) (null? (cdr llist)))
446                     (let* ((var (car llist))
447                            (refs (get-list db var 'references)) )
448                       ;; Parameter is only used once?
449                       (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
450                           ;; Continuation contains an 'if' node?
451                           (let ((iftest (first (node-subexpressions body))))
452                             ;; Parameter is used only once and is the test-argument?
453                             (if (and (eq? '##core#variable (node-class iftest))
454                                      (eq? var (first (node-parameters iftest))) )
455                                 ;; Modify call-site to call continuation directly and swap branches
456                                 ;;  in the conditional:
457                                 (begin
458                                   (set! removed-nots (+ removed-nots 1))
459                                   (node-parameters-set! n '(#t))
460                                   (node-subexpressions-set! n (cdr subs))
461                                   (node-subexpressions-set! 
462                                    body
463                                    (cons (car bodysubs) (reverse (cdr bodysubs))) )
464                                   (touch) ) ) ) ) ) ) ) ) ) )
465         (or (test 'not 'call-sites) '()) ) )
466   
467    (when (> removed-nots 0) (debugging 'o "Removed `not' forms" removed-nots))
468    dirty) )
469
470
471;;; Simplifications:
472
473(define (register-simplifications class . ss)
474  (##sys#hash-table-set! simplifications class ss) )
475
476
477(register-simplifications
478 '##core#call
479 ;; (<named-call> ...) -> (<primitive-call/inline> ...)
480 `((##core#call d (##core#variable (a)) b . c)
481   (a b c d)
482   ,(lambda (db a b c d)
483      (let loop ((entries (or (##sys#hash-table-ref substitution-table a) '())))
484        (cond ((null? entries) #f)
485              ((simplify-named-call db d a b (caar entries) (cdar entries) c)
486               => (lambda (r)
487                    (let ((as (assq a simplified-ops)))
488                      (if as 
489                          (set-cdr! as (add1 (cdr as)))
490                          (set! simplified-ops (alist-cons a 1 simplified-ops)) ) )
491                    r) )
492              (else (loop (cdr entries))) ) ) ) ) )
493
494
495(register-simplifications
496 'let
497
498 ;; (let ((<var1> (##core#inline <eq-inline-operator> <var0> <const1>)))
499 ;;   (if <var1> <body1>
500 ;;       (let ((<var2> (##core#inline <eq-inline-operator> <var0> <const2>)))
501 ;;         (if <var2> <body2>
502 ;;             <etc.>
503 ;; -> (##core#switch (2) <var0> <const1> <body1> <const2> <body2> <etc.>)
504 ;; - <var1> and <var2> have to be referenced once only.
505 `((let (var1) (##core#inline (op) (##core#variable (var0)) (quote (const1)))
506        (if d1 (##core#variable (var1))
507            body1
508            (let (var2) (##core#inline (op) (##core#variable (var0)) (quote (const2)))
509                 (if d2 (##core#variable (var2))
510                     body2
511                     rest) ) ) )
512   (var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
513   ,(lambda (db var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
514      (and (equal? op eq-inline-operator)
515           (immediate? const1)
516           (immediate? const2)
517           (= 1 (length (get-list db var1 'references)))
518           (= 1 (length (get-list db var2 'references)))
519           (make-node
520            '##core#switch
521            '(2)
522            (list (varnode var0)
523                  (qnode const1)
524                  body1
525                  (qnode const2)
526                  body2
527                  rest) ) ) ) )
528
529 ;; (let ((<var> (##core#inline <eq-inline-operator> <var0> <const>)))
530 ;;   (if <var>
531 ;;       <body>
532 ;;       (##core#switch <n> <var0> <const1> <body1> ... <rest>) ) )
533 ;; -> (##core#switch <n+1> <var0> <const> <body> <const1> <body1> ... <rest>)
534 ;; - <var> has to be referenced once only.
535 `((let (var) (##core#inline (op) (##core#variable (var0)) (quote (const)))
536        (if d (##core#variable (var))
537            body
538            (##core#switch (n) (##core#variable (var0)) . clauses) ) )
539   (var op var0 const d body n clauses)
540   ,(lambda (db var op var0 const d body n clauses)
541      (and (equal? op eq-inline-operator)
542           (immediate? const)
543           (= 1 (length (get-list db var 'references)))
544           (make-node
545            '##core#switch
546            (list (add1 n))
547            (cons* (varnode var0)
548                   (qnode const)
549                   body
550                   clauses) ) ) ) )
551             
552 ;; (let ((<var1> (##core#undefined)))
553 ;;   (let ((<var2> (##core#undefined)))
554 ;;     ...
555 ;;     (let ((<tmp1> (set! <var1> <x1>))
556 ;;       (let ((<tmp2> (set! <var2> <x2>)))
557 ;;         ...
558 ;;         <body>) ... )
559 ;; -> <a simpler sequence of let's>
560 ;; - <tmpI> may not be used.
561 `((let (var1) (##core#undefined ())
562        more)
563   (var1 more)
564   ,(lambda (db var1 more)
565      (let loop1 ([vars (list var1)] 
566                  [body more] )
567        (let ([c (node-class body)]
568              [params (node-parameters body)] 
569              [subs (node-subexpressions body)] )
570          (and (eq? c 'let)
571               (null? (cdr params))
572               (let* ([val (first subs)]
573                      [valparams (node-parameters val)]
574                      [valsubs (node-subexpressions val)] )
575                 (case (node-class val)
576                   [(##core#undefined) (loop1 (cons (first params) vars) (second subs))]
577                   [(set!)
578                    (let ([allvars (reverse vars)])
579                      (and (pair? allvars)
580                           (eq? (first valparams) (first allvars))
581                           (let loop2 ([vals (list (first valsubs))]
582                                       [vars (cdr allvars)] 
583                                       [body (second subs)] )
584                             (let ([c (node-class body)]
585                                   [params (node-parameters body)]
586                                   [subs (node-subexpressions body)] )
587                               (cond [(and (eq? c 'let)
588                                           (null? (cdr params))
589                                           (not (get db (first params) 'inline-transient))
590                                           (not (get db (first params) 'references))
591                                           (pair? vars)
592                                           (eq? 'set! (node-class (first subs)))
593                                           (eq? (car vars) (first (node-parameters (first subs)))) )
594                                      (loop2 (cons (first (node-subexpressions (first subs))) vals)
595                                             (cdr vars)
596                                             (second subs) ) ]
597                                     [(null? vars)
598                                      (receive (n progress) 
599                                          (reorganize-recursive-bindings allvars (reverse vals) body) 
600                                        (and progress n) ) ]
601                                     [else #f] ) ) ) ) ) ]
602                   [else #f] ) ) ) ) ) ) )
603
604 ;; (let ((<var1> <var2>))
605 ;;   (<var1> ...) )
606 ;; -> (<var2> ...)
607 ;; - <var1> used only once
608 #| this doesn't seem to work (Sven Hartrumpf):
609 `((let (var1) (##core#variable (var2))
610        (##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
611   (var1 var2 p more)
612   ,(lambda (db var1 var2 p more)
613      (and (= 1 (length (get-list db var1 'references)))
614           (make-node
615            '##core#call p
616            (cons (varnode var2) more) ) ) ) )
617 |#
618
619 ;; (let ((<var> (##core#inline <op> ...)))
620 ;;   (if <var> <x> <y>) )
621 ;; -> (if (##core#inline <op> ...) <x> <y>)
622 ;; - <op> may not be the eq-inline operator (so rewriting to "##core#switch" works).
623 ;; - <var> has to be referenced only once.
624 `((let (var) (##core#inline (op) . args)
625        (if d (##core#variable (var))
626            x
627            y) ) 
628   (var op args d x y)
629   ,(lambda (db var op args d x y)
630      (and (not (equal? op eq-inline-operator))
631           (= 1 (length (get-list db var 'references)))
632           (make-node
633            'if d
634            (list (make-node '##core#inline (list op) args)
635                  x y) ) ) ) ) )
636
637
638(register-simplifications
639 'if
640
641 ;; (if <x>
642 ;;     (<var> <y>)
643 ;;     (<var> <z>) )
644 ;; -> (<var> (##core#cond <x> <y> <z>))
645 ;; - inline-substitutions have to be enabled (so IF optimizations have already taken place).
646 `((if d1 x
647       (##core#call d2 (##core#variable (var)) y)
648       (##core#call d3 (##core#variable (var)) z) )
649   (d1 d2 d3 x y z var)
650   ,(lambda (db d1 d2 d3 x y z var)
651      (and inline-substitutions-enabled
652           (make-node
653            '##core#call d2
654            (list (varnode var)
655                  (make-node '##core#cond '() (list x y z)) ) ) ) ) )
656
657 ;; (if (##core#inline <memXXX> <x> '(<c1> ...)) ...)
658 ;; -> (let ((<var> <x>))
659 ;;      (if (##core#cond (##core#inline XXX? <var> '<c1>) #t ...) ...)
660 ;; - there is a limit on the number of items in the list of constants.
661 `((if d1 (##core#inline (op) x (quote (clist)))
662       y
663       z)
664   (d1 op x clist y z)
665   ,(lambda (db d1 op x clist y z)
666      (and-let* ([opa (assoc op membership-test-operators)]
667                 [(proper-list? clist)]
668                 [(< (length clist) membership-unfold-limit)] )
669        (let ([var (gensym)]
670              [eop (list (cdr opa))] )
671          (make-node
672           'let (list var)
673           (list
674            x
675            (make-node
676             'if d1
677             (list
678              (fold-right
679               (lambda (c rest)
680                 (make-node
681                  '##core#cond '()
682                  (list
683                   (make-node '##core#inline eop (list (varnode var) (qnode c)))
684                   (qnode #t)
685                   rest) ) )
686               (qnode #f)
687               clist)
688              y
689              z) ) ) ) ) ) ) ) )
690
691
692;;; Perform dependency-analysis and transform letrec's into simpler constructs (if possible):
693
694(define (reorganize-recursive-bindings vars vals body)
695  (let ([graph '()]
696        [valmap (map cons vars vals)] )
697
698    (define (find-path var1 var2)
699      (let find ([var var1] [traversed '()])
700        (and (not (memq var traversed))
701             (let ([arcs (cdr (assq var graph))])
702               (or (memq var2 arcs)
703                   (let ([t2 (cons var traversed)])
704                     (any (lambda (v) (find v t2)) arcs) ) ) ) ) ) )
705
706    ;; Build dependency graph:
707    (for-each
708     (lambda (var val) (set! graph (alist-cons var (scan-used-variables val vars) graph)))
709     vars vals)
710
711    ;; Compute recursive groups:
712    (let ([groups '()]
713          [done '()] )
714      (for-each
715       (lambda (var)
716         (when (not (memq var done))
717           (let ([g (filter
718                     (lambda (v) (and (not (eq? v var)) (find-path var v) (find-path v var)))
719                     vars) ] )
720             (set! groups (alist-cons (gensym) (cons var g) groups))
721             (set! done (append (list var) g done)) ) ) )
722       vars)
723
724      ;; Coalesce groups into a new graph:
725      (let ([cgraph '()])
726        (for-each
727         (lambda (g)
728           (let ([id (car g)]
729                 [deps
730                  (append-map
731                   (lambda (var) (filter (lambda (v) (find-path var v)) vars)) 
732                   (cdr g) ) ] )
733             (set! cgraph
734               (alist-cons 
735                id
736                (filter-map
737                 (lambda (g2) (and (not (eq? g2 g)) (lset<= eq? (cdr g2) deps) (car g2))) 
738                 groups)
739                cgraph) ) ) )
740         groups) 
741
742        ;; Topologically sort secondary dependency graph:
743        (let ([sgraph (topological-sort cgraph eq?)]
744              [optimized '()] )
745
746          ;; Construct new bindings:
747          (let ([n2
748                 (fold
749                  (lambda (gn body)
750                    (let* ([svars (cdr (assq gn groups))]
751                           [svar (car svars)] )
752                      (cond [(and (null? (cdr svars))
753                                  (not (memq svar (cdr (assq svar graph)))) )
754                             (set! optimized (cons svar optimized))
755                             (make-node 'let svars (list (cdr (assq svar valmap)) body)) ]
756                            [else
757                             (fold-right
758                              (lambda (var rest)
759                                (make-node
760                                 'let (list var)
761                                 (list (make-node '##core#undefined '() '()) rest) ) )
762                              (fold-right
763                               (lambda (var rest)
764                                 (make-node
765                                  'let (list (gensym))
766                                  (list (make-node 'set! (list var) (list (cdr (assq var valmap))))
767                                        rest) ) )
768                               body
769                               svars)
770                              svars) ] ) ) )
771                  body
772                  sgraph) ] )
773            (cond [(pair? optimized)
774                   (debugging 'o "eliminated assignments" optimized)
775                   (values n2 #t) ]
776                  [else (values n2 #f)] ) ) ) ) ) ) )
777
778
779;;;; Rewrite named calls to more primitive forms:
780
781(define substitution-table (make-vector 301 '()))
782
783(define (rewrite name . class-and-args)
784  (let ((old (or (##sys#hash-table-ref substitution-table name) '())))
785    (##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
786
787(define (simplify-named-call db params name cont class classargs callargs)
788  (define (test sym prop) (get db sym prop))
789  (define (defarg x)
790    (cond ((symbol? x) (varnode x))
791          ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
792          (else (qnode x))))
793
794  (case class
795
796    ;; (eq?/eqv?/equal? <var> <var>) -> (quote #t)
797    ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
798    ((1) ; classargs = (<argc> <iop>)
799     (and (intrinsic? name)
800          (or (and (= (length callargs) (first classargs))
801                   (let ((arg1 (first callargs))
802                         (arg2 (second callargs)) )
803                     (and (eq? '##core#variable (node-class arg1))
804                          (eq? '##core#variable (node-class arg2))
805                          (equal? (node-parameters arg1) (node-parameters arg2))
806                          (make-node '##core#call '(#t) (list cont (qnode #t))) ) ) )
807              (and inline-substitutions-enabled
808                   (make-node
809                    '##core#call '(#t) 
810                    (list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
811
812    ;; (<op> ...) -> (##core#inline <iop> ...)
813    ;; (<op> <rest-vector>) -> (##core#inline <iopv> <rest-vector>)
814    ((2) ; classargs = (<argc> <iop> <safe> <iopv>)
815     (and inline-substitutions-enabled
816          (= (length callargs) (first classargs))
817          (intrinsic? name)
818          (or (third classargs) unsafe)
819          (let ([arg1 (first callargs)]
820                [iopv (fourth classargs)] )
821            (make-node
822             '##core#call '(#t)
823             (list
824              cont
825              (cond [(and iopv
826                          (eq? '##core#variable (node-class arg1))
827                          (eq? 'vector (get db (first (node-parameters arg1)) 'rest-parameter)) )
828                     (make-node '##core#inline (list iopv) callargs) ]
829                    [else (make-node '##core#inline (list (second classargs)) callargs)] ) ) ) ) ) )
830
831    ;; (<op>) -> <var>
832    ((3) ; classargs = (<var>)
833     (and inline-substitutions-enabled
834          (null? callargs)
835          (intrinsic? name)
836          (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) )
837
838    ;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
839    ((4) ; classargs = (<primitiveop> <i>)
840     (and inline-substitutions-enabled
841          unsafe
842          (= 2 (length callargs))
843          (intrinsic? name)
844          (make-node '##core#call (list #f (first classargs))
845                     (list (varnode (first classargs))
846                           cont
847                           (first callargs)
848                           (qnode (second classargs))
849                           (second callargs) ) ) ) )
850
851    ;; (<op> a) -> (##core#inline <iop> a (quote <x>))
852    ((5) ; classargs = (<iop> <x> <numtype>)
853     ;; - <numtype> may be #f
854     (and inline-substitutions-enabled
855          (intrinsic? name)
856          (= 1 (length callargs))
857          (let ((ntype (third classargs)))
858            (or (not ntype) (eq? ntype number-type)) )
859          (make-node '##core#call '(#t)
860                     (list cont
861                           (make-node '##core#inline (list (first classargs))
862                                      (list (first callargs)
863                                            (qnode (second classargs)) ) ) ) ) ) )
864
865    ;; (<op> a) -> (##core#inline <iop1> (##core#inline <iop2> a))
866    ((6) ; classargs = (<iop1> <iop2> <safe>)
867      (and (or (third classargs) unsafe)
868           inline-substitutions-enabled
869           (= 1 (length callargs))
870           (intrinsic? name)
871           (make-node '##core#call '(#t)
872                      (list cont
873                            (make-node '##core#inline (list (first classargs))
874                                       (list (make-node '##core#inline (list (second classargs))
875                                                        callargs) ) ) ) ) ) )
876
877    ;; (<op> ...) -> (##core#inline <iop> ... (quote <x>))
878    ((7) ; classargs = (<argc> <iop> <x> <safe>)
879     (and (or (fourth classargs) unsafe)
880          inline-substitutions-enabled
881          (= (length callargs) (first classargs))
882          (intrinsic? name)
883          (make-node '##core#call '(#t)
884                     (list cont
885                           (make-node '##core#inline (list (second classargs))
886                                      (append callargs
887                                              (list (qnode (third classargs))) ) ) ) ) ) )
888
889    ;; (<op> ...) -> <<call procedure <proc> with <classargs>, <cont> and <callargs> >>
890    ((8) ; classargs = (<proc> ...)
891     (and inline-substitutions-enabled
892          (intrinsic? name)
893          ((first classargs) db classargs cont callargs) ) )
894
895    ;; (<op> <x1> ...) -> (##core#inline "C_and" (##core#inline <iop> <x1> <x2>) ...)
896    ;; (<op> [<x>]) -> (quote #t)
897    ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
898     (and inline-substitutions-enabled
899          (intrinsic? name)
900          (if (< (length callargs) 2)
901              (make-node '##core#call '(#t) (list cont (qnode #t)))
902              (and (or (and unsafe (not (eq? number-type 'generic)))
903                       (and (eq? number-type 'fixnum) (third classargs))
904                       (and (eq? number-type 'flonum) (fourth classargs)) )
905                   (let* ([names (map (lambda (z) (gensym)) callargs)]
906                          [vars (map varnode names)] )
907                     (fold-right
908                      (lambda (x n y) (make-node 'let (list n) (list x y)))
909                      (make-node
910                       '##core#call '(#t)
911                       (list
912                        cont
913                        (let ([op (list
914                                   (if (eq? number-type 'fixnum)
915                                       (first classargs)
916                                       (second classargs) ) ) ] )
917                          (fold-boolean
918                           (lambda (x y) (make-node '##core#inline op (list x y))) 
919                           vars) ) ) )
920                      callargs names) ) ) ) ) )
921
922    ;; (<op> a [b]) -> (<primitiveop> a (quote <i>) b)
923    ((10) ; classargs = (<primitiveop> <i> <bvar> <safe>)
924     (and inline-substitutions-enabled
925          (or (fourth classargs) unsafe)
926          (intrinsic? name)
927          (let ((n (length callargs)))
928            (and (< 0 n 3)
929                 (make-node '##core#call (list #f (first classargs))
930                            (list (varnode (first classargs))
931                                  cont
932                                  (first callargs)
933                                  (qnode (second classargs))
934                                  (if (null? (cdr callargs))
935                                      (varnode (third classargs))
936                                      (second callargs) ) ) ) ) ) ) )
937
938    ;; (<op> ...) -> (<primitiveop> ...)
939    ((11) ; classargs = (<argc> <primitiveop> <safe>)
940     ;; <argc> may be #f.
941     (and inline-substitutions-enabled
942          (or (third classargs) unsafe)
943          (intrinsic? name)
944          (let ([argc (first classargs)])
945            (and (or (not argc)
946                     (= (length callargs) (first classargs)) )
947                 (make-node '##core#call (list #t (second classargs))
948                            (cons* (varnode (second classargs))
949                                   cont
950                                   callargs) ) ) ) ) )
951
952    ;; (<op> a) -> a
953    ;; (<op> ...) -> (<primitiveop> ...)
954    ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
955     (and inline-substitutions-enabled
956          (intrinsic? name)
957          (or (second classargs) unsafe)
958          (let ((n (length callargs)))
959            (and (<= n (third classargs))
960                 (case n
961                   ((1) (make-node '##core#call '(#t) (cons cont callargs)))
962                   (else (make-node '##core#call (list #t (first classargs))
963                                    (cons* (varnode (first classargs))
964                                           cont callargs) ) ) ) ) ) ) )
965
966    ;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
967    ((13) ; classargs = (<primitiveop> <safe>)
968     (and inline-substitutions-enabled
969          (intrinsic? name)
970          (or (second classargs) unsafe)
971          (let ((pname (first classargs)))
972            (make-node '##core#call (if (pair? params) (cons #t (cdr params)) params)
973                       (cons* (make-node '##core#proc (list pname #t) '())
974                              cont callargs) ) ) ) )
975
976    ;; (<op> <x> ...) -> (##core#inline <iop-safe>/<iop-unsafe> <x> ...)
977    ((14) ; classargs = (<numtype> <argc> <iop-safe> <iop-unsafe>)
978     (and inline-substitutions-enabled
979          (= (second classargs) (length callargs))
980          (intrinsic? name)
981          (eq? number-type (first classargs))
982          (or (fourth classargs) unsafe)
983          (make-node
984           '##core#call '(#t)
985           (list cont
986                 (make-node
987                  '##core#inline
988                  (list (if unsafe (fourth classargs) (third classargs)))
989                  callargs) ) ) ) )
990
991    ;; (<op> <x>) -> (<primitiveop> <x>)   - if numtype1
992    ;;             | <x>                   - if numtype2
993    ((15) ; classargs = (<numtype1> <numtype2> <primitiveop> <safe>)
994     (and inline-substitutions-enabled
995          (= 1 (length callargs))
996          (or unsafe (fourth classargs))
997          (intrinsic? name)
998          (cond ((eq? number-type (first classargs))
999                 (make-node '##core#call (list #t (third classargs))
1000                            (cons* (varnode (third classargs)) cont callargs) ) )
1001                ((eq? number-type (second classargs))
1002                 (make-node '##core#call '(#t) (cons cont callargs)) )
1003                (else #f) ) ) )
1004
1005    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
1006    ((16) ; classargs = (<argc> <aiop> <safe> <words>)
1007     ;; - <argc> may be #f, saying that any number of arguments is allowed,
1008     ;; - <words> may be a list of one element (the number of words), meaning that
1009     ;;   the words are to be multiplied with the number of arguments.
1010     ;; - <words> may also be #t, meaning that the number of words is the same as the
1011     ;;   number of arguments plus 1.
1012     (let ([argc (first classargs)]
1013           [rargc (length callargs)]
1014           [w (fourth classargs)] )
1015       (and inline-substitutions-enabled
1016            (or (not argc) (= rargc argc))
1017            (intrinsic? name)
1018            (or (third classargs) unsafe)
1019            (make-node
1020             '##core#call '(#t)
1021             (list cont 
1022                   (make-node
1023                    '##core#inline_allocate
1024                    (list (second classargs) 
1025                          (cond [(eq? #t w) (add1 rargc)]
1026                                [(pair? w) (* rargc (car w))]
1027                                [else w] ) )
1028                    callargs) ) ) ) ) )
1029
1030    ;; (<op> ...) -> (##core#inline <iop>/<unsafe-iop> ...)
1031    ((17) ; classargs = (<argc> <iop-safe> [<iop-unsafe>])
1032     (and inline-substitutions-enabled
1033          (= (length callargs) (first classargs))
1034          (intrinsic? name)
1035          (make-node
1036           '##core#call '(#t)
1037           (list cont
1038                 (make-node '##core#inline
1039                            (list (if (and unsafe (pair? (cddr classargs)))
1040                                      (third classargs)
1041                                      (second classargs) ) )
1042                            callargs)) ) ) )
1043
1044    ;; (<op>) -> (quote <null>)
1045    ((18) ; classargs = (<null>)
1046     (and inline-substitutions-enabled
1047          (null? callargs)
1048          (intrinsic? name)
1049          (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )
1050
1051    ;; (<op>) -> <id>
1052    ;; (<op> <x>) -> <x>
1053    ;; (<op> <x1> ...) -> (##core#inline <fixop> <x1> (##core#inline <fixop> ...)) [fixnum-mode]
1054    ;; (<op> <x1> ...) -> (##core#inline <ufixop> <x1> (##core#inline <ufixop> ...)) [fixnum-mode + unsafe]
1055    ;; - Remove "<id>" from arguments.
1056    ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
1057     (and inline-substitutions-enabled
1058          (intrinsic? name)
1059          (let* ([id (first classargs)]
1060                 [fixop (if unsafe (third classargs) (second classargs))]
1061                 [callargs 
1062                  (remove
1063                   (lambda (x)
1064                     (and (eq? 'quote (node-class x))
1065                          (eq? id (first (node-parameters x))) ) ) 
1066                   callargs) ] )
1067            (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
1068                  [(null? (cdr callargs))
1069                   (make-node '##core#call '(#t) (list cont (first callargs))) ]
1070                  [(or (fourth classargs) (eq? number-type 'fixnum))
1071                   (make-node
1072                    '##core#call '(#t)
1073                    (list
1074                     cont
1075                     (fold-inner
1076                      (lambda (x y)
1077                        (make-node '##core#inline (list fixop) (list x y)) )
1078                      callargs) ) ) ]
1079                  [else #f] ) ) ) )
1080
1081    ;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
1082    ((20) ; classargs = (<argc> <iop> <x> <safe>)
1083     (let ([n (length callargs)])
1084       (and (or (fourth classargs) unsafe)
1085            inline-substitutions-enabled
1086            (= n (first classargs))
1087            (intrinsic? name)
1088            (make-node
1089             '##core#call '(#t)
1090             (list cont
1091                   (make-node 
1092                    '##core#inline (list (second classargs))
1093                    (let-values ([(head tail) (split-at callargs (sub1 n))])
1094                      (append head
1095                              (list (qnode (third classargs)))
1096                              tail) ) ) ) ) ) ) )
1097
1098    ;; (<op>) -> <id>
1099    ;; (<op> <x>) -> <x>
1100    ;; (<op> <x1> ...) -> (##core#inline_allocate (<genop> <words>) <x1> (##core#inline_allocate (<genop> <words>) ...))
1101    ;; (<op> <x1> ...) -> (##core#inline <[u]fixop> <x1> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
1102    ;; - Remove "<id>" from arguments.
1103    ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
1104     (and inline-substitutions-enabled
1105          (intrinsic? name)
1106          (let* ([id (first classargs)]
1107                 [words (fifth classargs)]
1108                 [genop (fourth classargs)]
1109                 [fixop (if unsafe (third classargs) (second classargs))]
1110                 [callargs 
1111                  (remove
1112                   (lambda (x)
1113                     (and (eq? 'quote (node-class x))
1114                          (eq? id (first (node-parameters x))) ) ) 
1115                   callargs) ] )
1116            (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
1117                  [(null? (cdr callargs))
1118                   (make-node '##core#call '(#t) (list cont (first callargs))) ]
1119                  [else
1120                   (make-node
1121                    '##core#call '(#t)
1122                    (list
1123                     cont
1124                     (fold-inner
1125                      (lambda (x y)
1126                        (if (eq? number-type 'fixnum)
1127                            (make-node '##core#inline (list fixop) (list x y))
1128                            (make-node '##core#inline_allocate (list genop words) (list x y)) ) )
1129                      callargs) ) ) ] ) ) ) )
1130
1131    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
1132    ;; (<alloc-op> ...) -> (##core#inline <fxop> ...) [fixnum mode]
1133    ((22) ; classargs = (<argc> <aiop> <safe> <words> <fxop>)
1134     (let ([argc (first classargs)]
1135           [rargc (length callargs)]
1136           [w (fourth classargs)] )
1137       (and inline-substitutions-enabled
1138            (= rargc argc)
1139            (intrinsic? name)
1140            (or (third classargs) unsafe)
1141            (make-node
1142             '##core#call '(#t)
1143             (list cont 
1144                   (if (eq? number-type 'fixnum)
1145                       (make-node
1146                        '##core#inline
1147                        (list (fifth classargs))
1148                        callargs)
1149                       (make-node
1150                        '##core#inline_allocate
1151                        (list (second classargs) w)
1152                        callargs) ) ) ) ) ) )
1153
1154    ;; (<op> <arg1> ... <argN>) -> (<primitiveop> ...)
1155    ;; (<op> <arg1> ... <argN-I> <defargN-I>) -> (<primitiveop> ...)
1156    ;; - default args in classargs should be either symbol or (optionally)
1157    ;;   quoted literal
1158    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
1159     (and inline-substitutions-enabled
1160          (intrinsic? name)
1161          (let ([argc (first classargs)])
1162            (and (>= (length callargs) (first classargs))
1163                 (make-node 
1164                  '##core#call (list #t (second classargs))
1165                  (cons*
1166                   (varnode (second classargs))
1167                   cont
1168                   (let-values (((req opt) (split-at callargs argc)))
1169                     (append
1170                      req
1171                      (let loop ((ca opt) 
1172                                 (da (cddr classargs)) )
1173                        (cond ((null? ca)
1174                               (if (null? da)
1175                                   '()
1176                                   (cons (defarg (car da)) (loop '() (cdr da))) ) )
1177                              ((null? da) '())
1178                              (else (cons (car ca) (loop (cdr ca) (cdr da))))))))))))))
1179
1180    (else (bomb "bad type (optimize)")) ) )
1181
1182
1183;;; Optimize direct leaf routines:
1184
1185(define (transform-direct-lambdas! node db)
1186  (let ([dirty #f]
1187        [inner-ks '()] 
1188        [hoistable '()] 
1189        [allocated 0] )
1190
1191    ;; Process node tree and walk lambdas that meet the following constraints:
1192    ;;  - Only external lambdas (no CPS redexes),
1193    ;;  - All calls are either to the direct continuation or (tail-) recursive calls.
1194    ;;  - No allocation, no rest parameter.
1195    ;;  - The lambda has a known container variable and all it's call-sites are known.
1196
1197    (define (walk d n dn)
1198      (let ([params (node-parameters n)]
1199            [subs (node-subexpressions n)] )
1200        (case (node-class n)
1201          [(##core#lambda)
1202           (let ([llist (third params)])
1203             (if (and d
1204                      (second params)
1205                      (not (get db d 'unknown))
1206                      (proper-list? llist)
1207                      (and-let* ([val (get db d 'value)]
1208                                 [refs (get-list db d 'references)]
1209                                 [sites (get-list db d 'call-sites)] )
1210                        (and (eq? n val)
1211                             (= (length refs) (length sites))
1212                             (scan (first subs) (first llist) d dn (cons d llist)) ) ) )
1213                 (transform n d inner-ks hoistable dn allocated) 
1214                 (walk #f (first subs) #f) ) ) ]
1215          [(set!) (walk (first params) (first subs) #f)]
1216          [(let)
1217           (walk (first params) (first subs) n)
1218           (walk #f (second subs) #f) ]
1219          [else (for-each (lambda (x) (walk #f x #f)) subs)] ) ) )
1220
1221    (define (scan n kvar fnvar destn env)
1222      (let ([closures '()]
1223            [recursive #f] )
1224        (define (rec n v vn e)
1225          (let ([params (node-parameters n)]
1226                [subs (node-subexpressions n)] )
1227            (case (node-class n)
1228              [(##core#variable)
1229               (let ([v (first params)])
1230                 (or (not (get db v 'boxed))
1231                     (not (memq v env))
1232                     (and (not recursive)
1233                          (begin
1234                            (set! allocated (+ allocated 2))
1235                            #t) ) ) ) ]
1236              [(##core#lambda)
1237               (and v
1238                    (decompose-lambda-list
1239                     (third params)
1240                     (lambda (vars argc rest)
1241                       (set! closures (cons v closures))
1242                       (rec (first subs) #f #f (append vars e)) ) ) ) ]
1243              [(##core#inline_allocate)
1244               (and (not recursive)
1245                    (begin
1246                      (set! allocated (+ allocated (second params)))
1247                      (every (lambda (x) (rec x #f #f e)) subs) ) ) ]
1248              [(##core#direct_lambda)
1249               (and vn destn
1250                    (null? (scan-used-variables (first subs) e)) 
1251                    (begin
1252                      (set! hoistable (alist-cons v vn hoistable))
1253                      #t) ) ]
1254              [(##core#inline_ref)
1255               (and (let ([n (estimate-foreign-result-size (second params))])
1256                      (or (zero? n)
1257                          (and (not recursive)
1258                               (begin
1259                                 (set! allocated (+ allocated n))
1260                                 #t) ) ) )
1261                    (every (lambda (x) (rec x #f #f e)) subs) ) ]
1262              [(##core#inline_loc_ref)
1263               (and (let ([n (estimate-foreign-result-size (first params))])
1264                      (or (zero? n)
1265                          (and (not recursive)
1266                               (begin
1267                                 (set! allocated (+ allocated n))
1268                                 #t) ) ) )
1269                    (every (lambda (x) (rec x #f #f e)) subs) ) ]
1270              [(##core#call)
1271               (let ([fn (first subs)])
1272                 (and (eq? '##core#variable (node-class fn))
1273                      (let ([v (first (node-parameters fn))])
1274                        (cond [(eq? v fnvar)
1275                               (and (zero? allocated)
1276                                    (let ([k (second subs)])
1277                                      (when (eq? '##core#variable (node-class k))
1278                                        (set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
1279                                      (set! recursive #t)
1280                                      #t) ) ]
1281                              [else (eq? v kvar)] ) )
1282                      (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) ]
1283              [(##core#direct_call)
1284               (let ([n (fourth params)])
1285                 (or (zero? n)
1286                     (and (not recursive)
1287                          (begin
1288                            (set! allocated (+ allocated n))
1289                            (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) ]
1290              [(set!) (rec (first subs) (first params) #f e)]
1291              [(let)
1292               (and (rec (first subs) (first params) n e)
1293                    (rec (second subs) #f #f (append params e)) ) ]
1294              [else (every (lambda (x) (rec x #f #f e)) subs)] ) ) )
1295        (set! inner-ks '())
1296        (set! hoistable '())
1297        (set! allocated 0)
1298        (and (rec n #f #f env)
1299             (lset= eq? closures (delete kvar inner-ks eq?)) ) ) )
1300
1301    (define (transform n fnvar ks hoistable destn allocated)
1302      (if (pair? hoistable)
1303          (debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
1304          (debugging 'o "direct leaf routine/allocation" fnvar allocated) )
1305      (set! dirty #t)
1306      (let* ([params (node-parameters n)]
1307             [argc (length (third params))]
1308             [klambdas '()] 
1309             [sites (or (get db fnvar 'call-sites) '())]
1310             [ksites '()] )
1311        (if (and (list? params) (= (length params) 4) (list? (caddr params)))
1312            (let ((id (car params))
1313                  (kvar (caaddr params))
1314                  (vars (cdaddr params)) )
1315              ;; Remove continuation argument:
1316              (set-car! (cddr params) vars)
1317           ;; Make "##core#direct_lambda":
1318           (node-class-set! n '##core#direct_lambda)
1319           ;; Transform recursive calls and remove unused continuations:
1320
1321           (let rec ([n (first (node-subexpressions n))])
1322             (let ([params (node-parameters n)]
1323                   [subs (node-subexpressions n)] )
1324               (case (node-class n)
1325                 [(##core#call)
1326                  (let* ([fn (first subs)]
1327                         [arg0 (second subs)]
1328                         [fnp (node-parameters fn)] 
1329                         [arg0p (node-parameters arg0)] )
1330                    (when (eq? '##core#variable (node-class fn))
1331                      (cond [(eq? fnvar (first fnp))
1332                             (set! ksites (alist-cons #f n ksites))
1333                             (cond [(eq? kvar (first arg0p))
1334                                    (unless (= argc (length (cdr subs)))
1335                                      (quit
1336                                       "known procedure called recursively with wrong number of arguments: `~A'" 
1337                                       fnvar) )
1338                                    (node-class-set! n '##core#recurse)
1339                                    (node-parameters-set! n (list #t id))
1340                                    (node-subexpressions-set! n (cddr subs)) ]
1341                                   [(assq (first arg0p) klambdas)
1342                                    => (lambda (a)
1343                                         (let* ([klam (cdr a)]
1344                                                [kbody (first (node-subexpressions klam))] )
1345                                           (unless (= argc (length (cdr subs)))
1346                                             (quit
1347                                              "known procedure called recursively with wrong number of arguments: `~A'" 
1348                                              fnvar) )
1349                                           (node-class-set! n 'let)
1350                                           (node-parameters-set! n (take (third (node-parameters klam)) 1))
1351                                           (node-subexpressions-set!
1352                                            n
1353                                            (list (make-node '##core#recurse (list #f id) (cddr subs)) kbody) )
1354                                           (rec kbody) ) ) ]
1355                                   [else (bomb "missing kvar" arg0p)] ) ]
1356                            [(eq? kvar (first fnp))
1357                             (node-class-set! n '##core#return)
1358                             (node-parameters-set! n '())
1359                             (node-subexpressions-set! n (cdr subs)) ]
1360                            [else (bomb "bad call (leaf)")] ) ) ) ]
1361                 [(let)
1362                  (let ([var (first params)]
1363                        [val (first subs)] )
1364                    (cond [(memq var ks)
1365                           (set! klambdas (alist-cons var val klambdas))
1366                           (copy-node! (second subs) n)
1367                           (rec n) ]
1368                          [else (for-each rec subs)] ) ) ]
1369
1370                 [else (for-each rec subs)] ) ) )
1371
1372           ;; Transform call-sites:
1373           (for-each
1374            (lambda (site)
1375              (let* ([n (cdr site)]
1376                     [nsubs (node-subexpressions n)] )
1377                (unless (= argc (length (cdr nsubs)))
1378                  (quit
1379                   "known procedure called with wrong number of arguments: `~A'"
1380                   fnvar) )
1381                (node-subexpressions-set!
1382                 n
1383                 (list (second nsubs)
1384                       (make-node
1385                        '##core#direct_call
1386                        (list #t #f id allocated)
1387                        (cons (car nsubs) (cddr nsubs)) ) ) ) ) )
1388            (lset-difference (lambda (s1 s2) (eq? (cdr s1) (cdr s2))) sites ksites) )
1389
1390           ;; Hoist direct lambdas out of container:
1391           (when (and destn (pair? hoistable))
1392             (let ([destn0 (make-node #f #f #f)])
1393               (copy-node! destn destn0) ; get copy of container binding
1394               (let ([hoisted
1395                      (fold-right       ; build cascade of bindings for each hoistable direct lambda...
1396                       (lambda (h rest)
1397                         (make-node
1398                          'let (list (car h))
1399                          (let ([dlam (first (node-subexpressions (cdr h)))])
1400                            (list (make-node (node-class dlam) (node-parameters dlam) (node-subexpressions dlam))
1401                                  rest) ) ) )
1402                       destn0
1403                       hoistable) ] )
1404                 (copy-node! hoisted destn) ; mutate container binding to hold hoistable bindings
1405                 (for-each
1406                  (lambda (h)           ; change old direct lambdas bindings to dummy ones...
1407                    (let ([vn (cdr h)])
1408                      (node-parameters-set! vn (list (gensym)))
1409                      (set-car! (node-subexpressions vn) (make-node '##core#undefined '() '())) ) )
1410                  hoistable) ) ) ) )
1411            (bomb "invalid parameter list" params))))
1412
1413    (debugging 'p "direct leaf routine optimization pass...")
1414    (walk #f node #f)
1415    dirty) )
1416
1417
1418;;; Lambda lift:
1419;
1420; - Find lambda-liftable local procedures and lift them to toplevel.
1421; - Pass free variables as extra parameters, including the free variables of
1422;   other lifted procedures. This implies that lifted procedures that call each
1423;   other have to be in the same scope.
1424; - Declare the lifted procedures (effectively) as bound-to-procedure and block-global.
1425
1426(define (perform-lambda-lifting! node db)
1427  (let ([lambda-values '()]
1428        [eliminated '()] )
1429   
1430    (define (find-lifting-candidates)
1431      ;; Collect potentially liftable procedures and return as a list of (<name> . <value>) pairs:
1432      ;; - Also build a-list that maps lambda-nodes to names.
1433      (let ([cs '()])
1434        (##sys#hash-table-for-each
1435         (lambda (sym plist)
1436           (and-let* ([val (assq 'value plist)]
1437                      [refs (assq 'references plist)]
1438                      [css (assq 'call-sites plist)] 
1439                      [nrefs (length (cdr refs))] )
1440             (when (and (not (assq 'unknown plist))
1441                        (eq? 'lambda (node-class (cdr val)))
1442                        (not (assq 'global plist)) 
1443                        #;(> nrefs 1)
1444                        (= nrefs (length (cdr css))) )
1445               (set! lambda-values (alist-cons (cdr val) sym lambda-values))
1446               (set! cs (alist-cons sym (cdr val) cs)) ) ) )
1447         db)
1448        cs) )
1449
1450    (define (build-call-graph cs)
1451      ;; Build call-graph of the form ((<name> (<free1> ...) <called1> ...) ...):
1452      (let ([g '()]
1453            [free '()]
1454            [called '()] )
1455
1456        (define (walk n env)
1457          (let ([class (node-class n)]
1458                [params (node-parameters n)]
1459                [subs (node-subexpressions n)] )
1460            (case class
1461              [(##core#variable set!)
1462               (let ([var (first params)])
1463                 (unless (or (memq var env) (get db var 'global))
1464                   (set! free (cons var free)) )
1465                 (when (assq var cs) (set! called (cons var called)))
1466                 (for-each (lambda (n) (walk n env)) subs) ) ]
1467              [(let)
1468               (let loop ([vars params] [vals subs])
1469                 (if (null? vars)
1470                     (walk (car vals) (append params env))
1471                     (let ([var (car vars)])
1472                       (walk (car vals) env)
1473                       (loop (cdr vars) (cdr vals)) ) ) ) ]
1474              [(lambda)
1475               (decompose-lambda-list
1476                (first params)
1477                (lambda (vars argc rest) (walk (first subs) (append vars env))) ) ]
1478              [else (for-each (lambda (n) (walk n env)) subs)] ) ) )
1479
1480        (for-each
1481         (lambda (cs)
1482           (let* ([here (car cs)]
1483                  [lval (cdr cs)] 
1484                  [llist (car (node-parameters lval))] )
1485             (set! free '())
1486             (set! called '())
1487             (decompose-lambda-list
1488              llist
1489              (lambda (vars arg rest)
1490                (walk (car (node-subexpressions lval)) vars) ) )
1491             (set! g (alist-cons here (cons free called) g)) ) )
1492         cs)
1493        g) )
1494
1495    (define (eliminate cs graph)
1496      ;; Eliminate all liftables that have free variables that are assigned to (and are not liftable),
1497      ;;  or that have more than N free variables (including free variables of called liftables):
1498      (remove
1499       (lambda (gn)
1500         (or (> (count-free-variables (car gn) graph) maximal-number-of-free-variables-for-liftable)
1501             (any (lambda (v) 
1502                    (and (get db v 'assigned) 
1503                         (not (assq v cs)) ) )
1504                  (second gn) ) ) )
1505       graph) )
1506
1507    (define (count-free-variables name graph)
1508      (let ([gnames (unzip1 graph)])
1509        (let count ([n name] [walked '()])
1510          (let* ([a (assq n graph)]
1511                 [cs (lset-difference eq? (cddr a) walked gnames)]
1512                 [f (length (delete-duplicates (second a) eq?))]
1513                 [w2 (cons n (append cs walked))] )
1514            (fold + f (map (lambda (c) (count c w2)) cs)) ) ) ) )
1515
1516    (define (collect-accessibles graph)
1517      ;; Collect accessible variables for each liftable into list of the form (<name> <accessible1> ...):
1518      (let ([al '()])
1519        (let walk ([n node] [vars '()])
1520          (let ([class (node-class n)]
1521                [params (node-parameters n)]
1522                [subs (node-subexpressions n)] )
1523            (case class
1524              [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
1525              [(let)
1526               (let loop ([vars2 params] [vals subs])
1527                 (if (null? vars2)
1528                     (walk (car vals) (append params vars))
1529                     (begin
1530                       (walk (car vals) vars)
1531                       (loop (cdr vars2) (cdr vals)) ) ) ) ]
1532              [(lambda)
1533               (let ([lval (assq n lambda-values)])
1534                 (when lval
1535                   (let ([name (cdr lval)])
1536                     (when (assq name graph)
1537                       (set! al (alist-cons (cdr lval) vars al))) ) ) )
1538               (decompose-lambda-list
1539                (first params)
1540                (lambda (vars2 argc rest)
1541                  (walk (car subs) (append vars2 vars)) ) ) ]
1542              [else
1543               (for-each (lambda (n) (walk n vars)) subs) ] ) ) )
1544        al) )
1545
1546    (define (eliminate2 graph al)
1547      ;; Eliminate liftables that have call-sites without access to all free variables;
1548      (remove
1549       (lambda (gn)
1550         (let* ([name (first gn)]
1551                [free (second gn)] )
1552           (any (lambda (gn2)
1553                  (and (memq name (cddr gn2)) ; callee?
1554                       (lset<= eq? (cdr (assq (car gn2) al)) free) ) )
1555                graph) ) ) 
1556       graph) )
1557
1558    (define (eliminate3 graph)
1559      ;; Eliminate liftables that call other eliminated liftables:
1560      ;; - repeat until nothing changes.
1561      (let loop ([graph graph] [n (length graph)])
1562        (let* ([g2 (filter (lambda (gn) (every (lambda (n) (assq n graph)) (cddr gn))) graph)]
1563               [n2 (length g2)] )
1564          (if (= n n2)
1565              g2
1566              (loop g2 n2) ) ) ) )
1567
1568    (define (eliminate4 graph)
1569      ;; Eliminate liftables that have unknown call-sites which do not have access to
1570      ;;  any of the free variables of all callees:
1571      (let walk ([n node] [vars '()])
1572        (let ([class (node-class n)]
1573              [params (node-parameters n)]
1574              [subs (node-subexpressions n)] )
1575          (case class
1576            [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
1577            [(let)
1578             (let loop ([vars2 params] [vals subs])
1579               (if (null? vars2)
1580                   (walk (car vals) (append params vars))
1581                   (begin
1582                     (walk (car vals) vars)
1583                     (loop (cdr vars2) (cdr vals)) ) ) ) ]
1584            [(lambda)
1585             (decompose-lambda-list
1586              (first params)
1587              (lambda (vars2 argc rest)
1588                (walk (car subs) (append vars2 vars)) ) ) ]
1589            [(##core#call)
1590             (let ([fn (first subs)])
1591               (call-with-current-continuation
1592                (lambda (return)
1593                  (when (eq? '##core#variable (node-class fn))
1594                    (let ([done '()])
1595                      (let loop ([name (first (node-parameters fn))])
1596                        (unless (memq name done)
1597                          (set! done (cons name done))
1598                          (let ([gn (assq name graph)])
1599                            (when gn
1600                              (unless (lset<= eq? (second gn) vars)
1601                                #;(print "*** " (first (node-parameters fn)) " | " name ": " vars " / " (second gn)) 
1602                                (set! graph (delete! gn graph eq?))
1603                                (return #f) )
1604                              (for-each loop (cddr gn)) ) ) ) ) ) ) ) )
1605               (for-each (lambda (n) (walk n vars)) subs) ) ]
1606            [else (for-each (lambda (n) (walk n vars)) subs)] ) ) )
1607      graph)
1608
1609    (define (compute-extra-variables graph)
1610      ;; Gather variables that have to be passed additionally:
1611      ;; - do not pass variables that are defined inside the body of a liftable.
1612      (define (defined n)
1613        (let ([defd '()])
1614          (let walk ([n n])
1615            (let ([class (node-class n)]
1616                  [params (node-parameters n)]
1617                  [subs (node-subexpressions n)] )
1618              (case class
1619                [(let)
1620                 (set! defd (append params defd))
1621                 (for-each walk subs) ]
1622                [(lambda)
1623                 (decompose-lambda-list
1624                  (first params)
1625                  (lambda (vars argc rest)
1626                    (set! defd (append vars defd))
1627                    (walk (first subs)) ) ) ]
1628                [else (for-each walk subs)] ) ) )
1629          defd) )
1630      (let ([extras (map (lambda (gn) (cons (first gn) (second gn))) graph)]
1631            [walked '()] )
1632        (define (walk gn)
1633          (let ([name (car gn)])
1634            ;; Hm. To handle liftables that are called recursively (but indirect) I use this kludge. Is it safe?
1635            (unless (> (count (cut eq? name <>) walked) 1)
1636              (set! walked (cons name walked))
1637              (let ([callees (cddr gn)])
1638                (for-each (lambda (c) (walk (assq c graph))) callees)
1639                (let ([f (assq name extras)])
1640                  (set-cdr! f (append (cdr f) (concatenate (map (lambda (n2) (cdr (assq n2 extras))) callees)))) ) ) ) ) )
1641        (for-each walk graph)
1642        (map (lambda (xt)
1643               (let* ([name (car xt)]
1644                      [defd (defined (get db name 'value))] )
1645                 (cons name
1646                       (remove 
1647                        (lambda (v)
1648                          (or (assq v graph)
1649                              (memq v defd) ) )
1650                        (delete-duplicates (cdr xt) eq?)) ) ) )
1651             extras) ) )
1652
1653    (define (reconstruct! graph extra)
1654      ;; Reconstruct node tree by adding global definitions:
1655      (node-subexpressions-set!
1656       node
1657       (list
1658        (fold-right
1659         (lambda (gn body)
1660           (let* ([name (car gn)]
1661                  [lval (get db name 'value)] )
1662             (hide-variable name)
1663             (decompose-lambda-list
1664              (first (node-parameters lval))
1665              (lambda (vars argc rest)
1666                (let* ([xvars (cdr (assq name extra))]
1667                       [xaliases (map gensym xvars)]
1668                       [xmap (map cons xvars xaliases)] )
1669                  (rename-extra-variables! (first (node-subexpressions lval)) xmap)
1670                  (make-node
1671                   'let (list (gensym 't))
1672                   (list (make-node
1673                          'set! (list name)
1674                          (list
1675                           (make-node
1676                            'lambda
1677                            (list (build-lambda-list (append xaliases vars) (+ argc (length xvars)) rest))
1678                            (node-subexpressions lval) ) ) )
1679                         body) ) ) ) ) ) )
1680         (first (node-subexpressions node))
1681         graph) ) ) )
1682
1683    (define (rename-extra-variables! node xmap)
1684      ;; Rename variables from a given map:
1685      (define (rename v)
1686        (let ([a (assq v xmap)])
1687          (if a (cdr a) v) ) )
1688      (let walk ([n node])
1689        (let ([class (node-class n)]
1690              [params (node-parameters n)]
1691              [subs (node-subexpressions n)] )
1692          (case class
1693            [(let)
1694             (node-parameters-set! n (map rename params))
1695             (for-each walk subs) ]
1696            [(##core#variable)
1697             (node-parameters-set! n (list (rename (first params)))) ]
1698            [(set!)
1699             (node-parameters-set! n (list (rename (first params))))
1700             (for-each walk subs) ]
1701            [(lambda)
1702             (decompose-lambda-list
1703              (first params)
1704              (lambda (vars argc rest)
1705                (set-car! params (build-lambda-list (map rename vars) argc rest)) 
1706                (walk (first subs)) ) ) ]
1707            [else (for-each walk subs)] ) ) ) )
1708
1709    (define (extend-call-sites! extra)
1710      ;; Change call sites by adding extra variables:
1711      (let walk ([n node])
1712        (let ([class (node-class n)]
1713              [params (node-parameters n)]
1714              [subs (node-subexpressions n)] )
1715          (case class
1716            [(##core#call)
1717             (let ([fn (first subs)])
1718               (when (eq? '##core#variable (node-class fn))
1719                 (let ([a (assq (first (node-parameters fn)) extra)])
1720                   (when a
1721                     (set-car! params #t)
1722                     (node-subexpressions-set! 
1723                      n
1724                      (cons fn (append (map varnode (cdr a)) (cdr subs))) ) ) ) )
1725               (for-each walk (node-subexpressions n)) ) ]
1726            [else (for-each walk subs)] ) ) ) )
1727
1728    (define (remove-local-bindings! graph)
1729      ;; Remove local definitions of lifted procedures:
1730      (let walk ([n node])
1731        (let ([class (node-class n)]
1732              [params (node-parameters n)]
1733              [subs (node-subexpressions n)] )
1734          (case class
1735            [(let)
1736             (for-each walk (node-subexpressions n))
1737             (let ([vars2 '()]
1738                   [vals2 '()] )
1739               (do ([vars params (cdr vars)]
1740                    [vals subs (cdr vals)] )
1741                   ((null? vars)
1742                    (cond [(null? vars2) (copy-node! (car vals) n)]
1743                          [else
1744                           (node-parameters-set! n (reverse vars2))
1745                           (node-subexpressions-set! n (append (reverse vals2) vals)) ] ) )
1746                 (unless (assq (car vars) graph)
1747                   (set! vars2 (cons (car vars) vars2))
1748                   (set! vals2 (cons (car vals) vals2)) ) ) ) ]
1749            [(set!)
1750             (for-each walk (node-subexpressions n))
1751             (when (assq (first params) graph)
1752               (node-class-set! n '##core#undefined)
1753               (node-parameters-set! n '())
1754               (node-subexpressions-set! n '()) ) ]
1755            [else (for-each walk subs)] ) ) ) )
1756
1757    (debugging 'p "gathering liftables...")
1758    (let ([cs (find-lifting-candidates)])
1759      (debugging 'p "building call graph...")
1760      (let ([g (build-call-graph cs)])
1761        (debugging 'p "eliminating non-liftables...")
1762        (let ([g2 (eliminate cs g)])
1763          (when (debugging 'l "call-graph:") (pretty-print g2))
1764          (debugging 'p "computing access-lists...")
1765          (let ([al (collect-accessibles g2)])
1766            (when (debugging 'l "accessibles:") (pretty-print al))
1767            (debugging 'p "eliminating liftables by access-lists and non-liftable callees...")
1768            (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))]) - why isn't this used?
1769              (debugging 'o "liftable local procedures" (delay (unzip1 ls)))
1770              (debugging 'p "gathering extra parameters...")
1771              (let ([extra (compute-extra-variables ls)])
1772                (when (debugging 'l "additional parameters:") (pretty-print extra))
1773                (debugging 'p "changing call sites...")
1774                (extend-call-sites! extra)
1775                (debugging 'p "removing local bindings...")
1776                (remove-local-bindings! ls)
1777                (debugging 'p "moving liftables to toplevel...")
1778                (reconstruct! ls extra) ) ) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.