source: project/chicken/branches/inlining/optimizer.scm @ 15323

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

more intelligent inlining; standard-extension procedure in setup-api

File size: 65.6 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 fid)
139      (if (memq n broken-constant-nodes)
140          n
141          (simplify
142           (let* ((odirty dirty)
143                  (n1 (walk1 n fid))
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                             fid) )
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 fid)
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 'replacable)
205                        (test var 'removable)
206                        (and (test var 'contractable) (not (test var 'replacing))) )
207                    (touch)
208                    (set! removed-lets (add1 removed-lets))
209                    (walk (second subs) fid) ]
210                   [else (make-node 'let params (map (cut walk <> fid) subs))] ) ) )
211
212          ((##core#lambda)
213           (let ((llist (third params))
214                 (id (first params)))
215             (cond [(test id 'has-unused-parameters)
216                    (decompose-lambda-list
217                     llist
218                     (lambda (vars argc rest)
219                       (receive (unused used) (partition (lambda (v) (test v 'unused)) vars)
220                         (touch)
221                         (debugging 'o "removed unused formal parameters" unused)
222                         (make-node
223                          '##core#lambda
224                          (list (first params) (second params)
225                                (cond [(and rest (test id 'explicit-rest))
226                                       (debugging 'o "merged explicitly consed rest parameter" rest)
227                                       (build-lambda-list used (add1 argc) #f) ]
228                                      [else (build-lambda-list used argc rest)] )
229                                (fourth params) )
230                          (list (walk (first subs) id)) ) ) ) ) ]
231                   [(test id 'explicit-rest)
232                    (decompose-lambda-list
233                     llist
234                     (lambda (vars argc rest)
235                       (touch)
236                       (debugging 'o "merged explicitly consed rest parameter" rest)
237                       (make-node
238                        '##core#lambda
239                        (list (first params)
240                              (second params)
241                              (build-lambda-list vars (add1 argc) #f)
242                              (fourth params) )
243                        (list (walk (first subs) id)) ) ) ) ]
244                   [else (walk-generic n class params subs id)] ) ) )
245
246          ((##core#call)
247           (let* ([fun (car subs)]
248                  [funclass (node-class fun)] )
249             (case funclass
250               [(##core#variable)
251                ;; Call to named procedure:
252                (let* ([var (first (node-parameters fun))]
253                       [lval (and (not (test var 'unknown)) 
254                                  (or (test var 'value)
255                                      (test var 'local-value)))]
256                       [args (cdr subs)] )
257                  (cond [(test var 'contractable)
258                         (let* ([lparams (node-parameters lval)]
259                                [llist (third lparams)] )
260                           (check-signature var args llist)
261                           (debugging 'o "contracted procedure" var)
262                           (touch)
263                           (when fid (put! db fid 'inline-target #t))
264                           (walk
265                            (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
266                            fid) ) ]
267                        [(memq var constant-declarations)
268                         (or (and-let* ((k (car args))
269                                        ((eq? '##core#variable (node-class k)))
270                                        (kvar (first (node-parameters k)))
271                                        (lval (and (not (test kvar 'unknown)) (test kvar 'value))) 
272                                        ((eq? '##core#lambda (node-class lval)))
273                                        (llist (third (node-parameters lval)))
274                                        ((or (test (car llist) 'unused)
275                                             (and (not (test (car llist) 'references))
276                                                  (not (test (car llist) 'assigned)))))
277                                        ((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
278                               (debugging 'x "removed call to constant procedure with unused result" var)
279                               (make-node
280                                '##core#call '(#t)
281                                (list k (make-node '##core#undefined '() '())) ) ) 
282                             (walk-generic n class params subs fid)) ]
283                        [(and lval
284                              (eq? '##core#lambda (node-class lval)))
285                         (let* ([lparams (node-parameters lval)]
286                                [llist (third lparams)] )
287                           (decompose-lambda-list
288                            llist
289                            (lambda (vars argc rest)
290                              (let ([ifid (first lparams)])
291                                (cond [(and inline-locally 
292                                            (test var 'inlinable)
293                                            (not (test (first lparams) 'inline-target)) ; inlinable procedure has changed
294                                            (case (variable-mark var '##compiler#inline) 
295                                              ((yes) #t)
296                                              ((no) #f)
297                                              (else
298                                               (< (fourth lparams) inline-max-size) ) ))
299                                       (debugging 
300                                        'i
301                                        (if (node? (variable-mark var '##compiler#inline-global))
302                                            "global inlining" 
303                                            "inlining")
304                                        var ifid (fourth lparams))
305                                       (when fid (put! db fid 'inline-target #t))
306                                       (check-signature var args llist)
307                                       (debugging 'o "inlining procedure" var)
308                                       (touch)
309                                       (walk
310                                        (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
311                                        fid) ]
312                                      [(test ifid 'has-unused-parameters)
313                                       (if (< (length args) argc) ; Expression was already optimized (should this happen?)
314                                           (walk-generic n class params subs fid)
315                                           (let loop ((vars vars) (argc argc) (args args) (used '()))
316                                             (cond [(or (null? vars) (zero? argc))
317                                                    (touch)
318                                                    (make-node
319                                                     '##core#call
320                                                     params
321                                                     (map (cut walk <> fid) (cons fun (append-reverse used args))) ) ]
322                                                   [(test (car vars) 'unused)
323                                                    (touch)
324                                                    (debugging
325                                                     'o "removed unused parameter to known procedure" 
326                                                     (car vars) var)
327                                                    (if (expression-has-side-effects? (car args) db)
328                                                        (make-node
329                                                         'let
330                                                         (list (gensym 't))
331                                                         (list (walk (car args) fid)
332                                                               (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
333                                                        (loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
334                                                   [else (loop (cdr vars)
335                                                               (sub1 argc)
336                                                               (cdr args)
337                                                               (cons (car args) used) ) ] ) ) ) ]
338                                      [(and (test ifid 'explicit-rest)
339                                            (not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
340                                       (let ([n (llist-length llist)])
341                                         (if (< (length args) n)
342                                             (walk-generic n class params subs fid)
343                                             (begin
344                                               (debugging 'o "consed rest parameter at call site" var n)
345                                               (let-values ([(args rargs) (split-at args n)])
346                                                 (let ([n2 (make-node
347                                                            '##core#call
348                                                            params
349                                                            (map (cut walk <> fid)
350                                                                 (cons fun
351                                                                       (append
352                                                                        args
353                                                                        (list
354                                                                         (if (null? rargs)
355                                                                             (qnode '())
356                                                                             (make-node
357                                                                              '##core#inline_allocate 
358                                                                              (list "C_a_i_list" (* 3 (length rargs)))
359                                                                              rargs) ) ) ) ) ) ) ] )
360                                                   (set! rest-consers (cons n2 rest-consers))
361                                                   n2) ) ) ) ) ]
362                                      [else (walk-generic n class params subs fid)] ) ) ) ) ) ]
363                        [else (walk-generic n class params subs fid)] ) ) ]
364               [(##core#lambda)
365                (if (first params)
366                    (walk-generic n class params subs fid)
367                    (make-node '##core#call (cons #t (cdr params)) (map (cut walk <> fid) subs)) ) ]
368               [else (walk-generic n class params subs fid)] ) ) )
369
370          ((set!)
371           (let ([var (first params)])
372             (cond [(or (test var 'contractable) (test var 'replacable))
373                    (touch)
374                    (make-node '##core#undefined '() '()) ]
375                   [(and (or (not (test var 'global))
376                             (not (variable-visible? var)))
377                         (not (test var 'inline-transient))
378                         (not (test var 'references)) 
379                         (not (expression-has-side-effects? (first subs) db)) )
380                    (touch)
381                    (debugging 'o "removed side-effect free assignment to unused variable" var)
382                    (make-node '##core#undefined '() '()) ]
383                   [else (make-node 'set! params (list (walk (car subs) fid)))] ) ) )
384
385          (else (walk-generic n class params subs fid)) ) ) )
386   
387    (define (walk-generic n class params subs fid)
388      (let ((subs2 (map (cut walk <> fid) subs)))
389        (if (every eq? subs subs2)
390            n
391            (make-node class params subs2) ) ) )
392
393    (if (perform-pre-optimization! node db)
394        (values node #t)
395        (begin
396          (debugging 'p "traversal phase...")
397          (set! simplified-ops '())
398          (let ((node2 (walk node #f)))
399            (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
400            (when (and (pair? simplified-ops) (debugging 'o "  call simplifications:"))
401              (for-each
402               (lambda (p)
403                 (print* #\tab (car p))
404                 (if (> (cdr p) 1)
405                     (print #\tab (cdr p))
406                     (newline) ) )
407               simplified-ops) )
408            (when (> replaced-vars 0) (debugging 'o "replaced variables" replaced-vars))
409            (when (> removed-lets 0) (debugging 'o "removed binding forms" removed-lets))
410            (when (> removed-ifs 0) (debugging 'o "removed conditional forms" removed-ifs))
411            (values node2 dirty) ) ) ) ) )
412
413
414;;; Pre-optimization phase:
415;
416; - Transform expressions of the form '(if (not <x>) <y> <z>)' into '(if <x> <z> <y>)'.
417; - Transform expressions of the form '(if (<x> <y> ...) <z> <q>)' into '<z>' if <x> names a
418;   standard-binding that is never #f and if it's arguments are free of side-effects.
419
420(define (perform-pre-optimization! node db)
421  (let ((dirty #f)
422        (removed-nots 0) )
423
424    (define (touch) (set! dirty #t) #t)
425    (define (test sym prop) (get db sym prop))
426
427    (debugging 'p "pre-optimization phase...")
428
429    ;; Handle '(if (not ...) ...)':
430    (if (intrinsic? 'not)
431        (for-each
432         (lambda (site)
433           (let* ((n (cdr site))
434                  (subs (node-subexpressions n))
435                  (kont (first (node-parameters (second subs))))
436                  (lnode (and (not (test kont 'unknown)) (test kont 'value)))
437                  (krefs (get-list db kont 'references)) )
438             ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
439             ;;  that has only one use:
440             (when (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
441                        (eq? '##core#lambda (node-class lnode)) )
442               (let* ((llist (third (node-parameters lnode)))
443                      (body (first (node-subexpressions lnode))) 
444                      (bodysubs (node-subexpressions body)) )
445                 ;; Continuation has one parameter?
446                 (if (and (proper-list? llist) (null? (cdr llist)))
447                     (let* ((var (car llist))
448                            (refs (get-list db var 'references)) )
449                       ;; Parameter is only used once?
450                       (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
451                           ;; Continuation contains an 'if' node?
452                           (let ((iftest (first (node-subexpressions body))))
453                             ;; Parameter is used only once and is the test-argument?
454                             (if (and (eq? '##core#variable (node-class iftest))
455                                      (eq? var (first (node-parameters iftest))) )
456                                 ;; Modify call-site to call continuation directly and swap branches
457                                 ;;  in the conditional:
458                                 (begin
459                                   (set! removed-nots (+ removed-nots 1))
460                                   (node-parameters-set! n '(#t))
461                                   (node-subexpressions-set! n (cdr subs))
462                                   (node-subexpressions-set! 
463                                    body
464                                    (cons (car bodysubs) (reverse (cdr bodysubs))) )
465                                   (touch) ) ) ) ) ) ) ) ) ) )
466         (or (test 'not 'call-sites) '()) ) )
467   
468    (when (> removed-nots 0) (debugging 'o "Removed `not' forms" removed-nots))
469    dirty) )
470
471
472;;; Simplifications:
473
474(define (register-simplifications class . ss)
475  (##sys#hash-table-set! simplifications class ss) )
476
477
478(register-simplifications
479 '##core#call
480 ;; (<named-call> ...) -> (<primitive-call/inline> ...)
481 `((##core#call d (##core#variable (a)) b . c)
482   (a b c d)
483   ,(lambda (db a b c d)
484      (let loop ((entries (or (##sys#hash-table-ref substitution-table a) '())))
485        (cond ((null? entries) #f)
486              ((simplify-named-call db d a b (caar entries) (cdar entries) c)
487               => (lambda (r)
488                    (let ((as (assq a simplified-ops)))
489                      (if as 
490                          (set-cdr! as (add1 (cdr as)))
491                          (set! simplified-ops (alist-cons a 1 simplified-ops)) ) )
492                    r) )
493              (else (loop (cdr entries))) ) ) ) ) )
494
495
496(register-simplifications
497 'let
498
499 ;; (let ((<var1> (##core#inline <eq-inline-operator> <var0> <const1>)))
500 ;;   (if <var1> <body1>
501 ;;       (let ((<var2> (##core#inline <eq-inline-operator> <var0> <const2>)))
502 ;;         (if <var2> <body2>
503 ;;             <etc.>
504 ;; -> (##core#switch (2) <var0> <const1> <body1> <const2> <body2> <etc.>)
505 ;; - <var1> and <var2> have to be referenced once only.
506 `((let (var1) (##core#inline (op) (##core#variable (var0)) (quote (const1)))
507        (if d1 (##core#variable (var1))
508            body1
509            (let (var2) (##core#inline (op) (##core#variable (var0)) (quote (const2)))
510                 (if d2 (##core#variable (var2))
511                     body2
512                     rest) ) ) )
513   (var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
514   ,(lambda (db var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
515      (and (equal? op eq-inline-operator)
516           (immediate? const1)
517           (immediate? const2)
518           (= 1 (length (get-list db var1 'references)))
519           (= 1 (length (get-list db var2 'references)))
520           (make-node
521            '##core#switch
522            '(2)
523            (list (varnode var0)
524                  (qnode const1)
525                  body1
526                  (qnode const2)
527                  body2
528                  rest) ) ) ) )
529
530 ;; (let ((<var> (##core#inline <eq-inline-operator> <var0> <const>)))
531 ;;   (if <var>
532 ;;       <body>
533 ;;       (##core#switch <n> <var0> <const1> <body1> ... <rest>) ) )
534 ;; -> (##core#switch <n+1> <var0> <const> <body> <const1> <body1> ... <rest>)
535 ;; - <var> has to be referenced once only.
536 `((let (var) (##core#inline (op) (##core#variable (var0)) (quote (const)))
537        (if d (##core#variable (var))
538            body
539            (##core#switch (n) (##core#variable (var0)) . clauses) ) )
540   (var op var0 const d body n clauses)
541   ,(lambda (db var op var0 const d body n clauses)
542      (and (equal? op eq-inline-operator)
543           (immediate? const)
544           (= 1 (length (get-list db var 'references)))
545           (make-node
546            '##core#switch
547            (list (add1 n))
548            (cons* (varnode var0)
549                   (qnode const)
550                   body
551                   clauses) ) ) ) )
552             
553 ;; (let ((<var1> (##core#undefined)))
554 ;;   (let ((<var2> (##core#undefined)))
555 ;;     ...
556 ;;     (let ((<tmp1> (set! <var1> <x1>))
557 ;;       (let ((<tmp2> (set! <var2> <x2>)))
558 ;;         ...
559 ;;         <body>) ... )
560 ;; -> <a simpler sequence of let's>
561 ;; - <tmpI> may not be used.
562 `((let (var1) (##core#undefined ())
563        more)
564   (var1 more)
565   ,(lambda (db var1 more)
566      (let loop1 ([vars (list var1)] 
567                  [body more] )
568        (let ([c (node-class body)]
569              [params (node-parameters body)] 
570              [subs (node-subexpressions body)] )
571          (and (eq? c 'let)
572               (null? (cdr params))
573               (let* ([val (first subs)]
574                      [valparams (node-parameters val)]
575                      [valsubs (node-subexpressions val)] )
576                 (case (node-class val)
577                   [(##core#undefined) (loop1 (cons (first params) vars) (second subs))]
578                   [(set!)
579                    (let ([allvars (reverse vars)])
580                      (and (pair? allvars)
581                           (eq? (first valparams) (first allvars))
582                           (let loop2 ([vals (list (first valsubs))]
583                                       [vars (cdr allvars)] 
584                                       [body (second subs)] )
585                             (let ([c (node-class body)]
586                                   [params (node-parameters body)]
587                                   [subs (node-subexpressions body)] )
588                               (cond [(and (eq? c 'let)
589                                           (null? (cdr params))
590                                           (not (get db (first params) 'inline-transient))
591                                           (not (get db (first params) 'references))
592                                           (pair? vars)
593                                           (eq? 'set! (node-class (first subs)))
594                                           (eq? (car vars) (first (node-parameters (first subs)))) )
595                                      (loop2 (cons (first (node-subexpressions (first subs))) vals)
596                                             (cdr vars)
597                                             (second subs) ) ]
598                                     [(null? vars)
599                                      (receive (n progress) 
600                                          (reorganize-recursive-bindings allvars (reverse vals) body) 
601                                        (and progress n) ) ]
602                                     [else #f] ) ) ) ) ) ]
603                   [else #f] ) ) ) ) ) ) )
604
605 ;; (let ((<var1> <var2>))
606 ;;   (<var1> ...) )
607 ;; -> (<var2> ...)
608 ;; - <var1> used only once
609 #| this doesn't seem to work (Sven Hartrumpf):
610 `((let (var1) (##core#variable (var2))
611        (##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
612   (var1 var2 p more)
613   ,(lambda (db var1 var2 p more)
614      (and (= 1 (length (get-list db var1 'references)))
615           (make-node
616            '##core#call p
617            (cons (varnode var2) more) ) ) ) )
618 |#
619
620 ;; (let ((<var> (##core#inline <op> ...)))
621 ;;   (if <var> <x> <y>) )
622 ;; -> (if (##core#inline <op> ...) <x> <y>)
623 ;; - <op> may not be the eq-inline operator (so rewriting to "##core#switch" works).
624 ;; - <var> has to be referenced only once.
625 `((let (var) (##core#inline (op) . args)
626        (if d (##core#variable (var))
627            x
628            y) ) 
629   (var op args d x y)
630   ,(lambda (db var op args d x y)
631      (and (not (equal? op eq-inline-operator))
632           (= 1 (length (get-list db var 'references)))
633           (make-node
634            'if d
635            (list (make-node '##core#inline (list op) args)
636                  x y) ) ) ) ) )
637
638
639(register-simplifications
640 'if
641
642 ;; (if <x>
643 ;;     (<var> <y>)
644 ;;     (<var> <z>) )
645 ;; -> (<var> (##core#cond <x> <y> <z>))
646 ;; - inline-substitutions have to be enabled (so IF optimizations have already taken place).
647 `((if d1 x
648       (##core#call d2 (##core#variable (var)) y)
649       (##core#call d3 (##core#variable (var)) z) )
650   (d1 d2 d3 x y z var)
651   ,(lambda (db d1 d2 d3 x y z var)
652      (and inline-substitutions-enabled
653           (make-node
654            '##core#call d2
655            (list (varnode var)
656                  (make-node '##core#cond '() (list x y z)) ) ) ) ) )
657
658 ;; (if (##core#inline <memXXX> <x> '(<c1> ...)) ...)
659 ;; -> (let ((<var> <x>))
660 ;;      (if (##core#cond (##core#inline XXX? <var> '<c1>) #t ...) ...)
661 ;; - there is a limit on the number of items in the list of constants.
662 `((if d1 (##core#inline (op) x (quote (clist)))
663       y
664       z)
665   (d1 op x clist y z)
666   ,(lambda (db d1 op x clist y z)
667      (and-let* ([opa (assoc op membership-test-operators)]
668                 [(proper-list? clist)]
669                 [(< (length clist) membership-unfold-limit)] )
670        (let ([var (gensym)]
671              [eop (list (cdr opa))] )
672          (make-node
673           'let (list var)
674           (list
675            x
676            (make-node
677             'if d1
678             (list
679              (fold-right
680               (lambda (c rest)
681                 (make-node
682                  '##core#cond '()
683                  (list
684                   (make-node '##core#inline eop (list (varnode var) (qnode c)))
685                   (qnode #t)
686                   rest) ) )
687               (qnode #f)
688               clist)
689              y
690              z) ) ) ) ) ) ) ) )
691
692
693;;; Perform dependency-analysis and transform letrec's into simpler constructs (if possible):
694
695(define (reorganize-recursive-bindings vars vals body)
696  (let ([graph '()]
697        [valmap (map cons vars vals)] )
698
699    (define (find-path var1 var2)
700      (let find ([var var1] [traversed '()])
701        (and (not (memq var traversed))
702             (let ([arcs (cdr (assq var graph))])
703               (or (memq var2 arcs)
704                   (let ([t2 (cons var traversed)])
705                     (any (lambda (v) (find v t2)) arcs) ) ) ) ) ) )
706
707    ;; Build dependency graph:
708    (for-each
709     (lambda (var val) (set! graph (alist-cons var (scan-used-variables val vars) graph)))
710     vars vals)
711
712    ;; Compute recursive groups:
713    (let ([groups '()]
714          [done '()] )
715      (for-each
716       (lambda (var)
717         (when (not (memq var done))
718           (let ([g (filter
719                     (lambda (v) (and (not (eq? v var)) (find-path var v) (find-path v var)))
720                     vars) ] )
721             (set! groups (alist-cons (gensym) (cons var g) groups))
722             (set! done (append (list var) g done)) ) ) )
723       vars)
724
725      ;; Coalesce groups into a new graph:
726      (let ([cgraph '()])
727        (for-each
728         (lambda (g)
729           (let ([id (car g)]
730                 [deps
731                  (append-map
732                   (lambda (var) (filter (lambda (v) (find-path var v)) vars)) 
733                   (cdr g) ) ] )
734             (set! cgraph
735               (alist-cons 
736                id
737                (filter-map
738                 (lambda (g2) (and (not (eq? g2 g)) (lset<= eq? (cdr g2) deps) (car g2))) 
739                 groups)
740                cgraph) ) ) )
741         groups) 
742
743        ;; Topologically sort secondary dependency graph:
744        (let ([sgraph (topological-sort cgraph eq?)]
745              [optimized '()] )
746
747          ;; Construct new bindings:
748          (let ([n2
749                 (fold
750                  (lambda (gn body)
751                    (let* ([svars (cdr (assq gn groups))]
752                           [svar (car svars)] )
753                      (cond [(and (null? (cdr svars))
754                                  (not (memq svar (cdr (assq svar graph)))) )
755                             (set! optimized (cons svar optimized))
756                             (make-node 'let svars (list (cdr (assq svar valmap)) body)) ]
757                            [else
758                             (fold-right
759                              (lambda (var rest)
760                                (make-node
761                                 'let (list var)
762                                 (list (make-node '##core#undefined '() '()) rest) ) )
763                              (fold-right
764                               (lambda (var rest)
765                                 (make-node
766                                  'let (list (gensym))
767                                  (list (make-node 'set! (list var) (list (cdr (assq var valmap))))
768                                        rest) ) )
769                               body
770                               svars)
771                              svars) ] ) ) )
772                  body
773                  sgraph) ] )
774            (cond [(pair? optimized)
775                   (debugging 'o "eliminated assignments" optimized)
776                   (values n2 #t) ]
777                  [else (values n2 #f)] ) ) ) ) ) ) )
778
779
780;;;; Rewrite named calls to more primitive forms:
781
782(define substitution-table (make-vector 301 '()))
783
784(define (rewrite name . class-and-args)
785  (let ((old (or (##sys#hash-table-ref substitution-table name) '())))
786    (##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
787
788(define (simplify-named-call db params name cont class classargs callargs)
789  (define (test sym prop) (get db sym prop))
790  (define (defarg x)
791    (cond ((symbol? x) (varnode x))
792          ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
793          (else (qnode x))))
794
795  (case class
796
797    ;; (eq?/eqv?/equal? <var> <var>) -> (quote #t)
798    ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
799    ((1) ; classargs = (<argc> <iop>)
800     (and (intrinsic? name)
801          (or (and (= (length callargs) (first classargs))
802                   (let ((arg1 (first callargs))
803                         (arg2 (second callargs)) )
804                     (and (eq? '##core#variable (node-class arg1))
805                          (eq? '##core#variable (node-class arg2))
806                          (equal? (node-parameters arg1) (node-parameters arg2))
807                          (make-node '##core#call '(#t) (list cont (qnode #t))) ) ) )
808              (and inline-substitutions-enabled
809                   (make-node
810                    '##core#call '(#t) 
811                    (list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
812
813    ;; (<op> ...) -> (##core#inline <iop> ...)
814    ;; (<op> <rest-vector>) -> (##core#inline <iopv> <rest-vector>)
815    ((2) ; classargs = (<argc> <iop> <safe> <iopv>)
816     (and inline-substitutions-enabled
817          (= (length callargs) (first classargs))
818          (intrinsic? name)
819          (or (third classargs) unsafe)
820          (let ([arg1 (first callargs)]
821                [iopv (fourth classargs)] )
822            (make-node
823             '##core#call '(#t)
824             (list
825              cont
826              (cond [(and iopv
827                          (eq? '##core#variable (node-class arg1))
828                          (eq? 'vector (get db (first (node-parameters arg1)) 'rest-parameter)) )
829                     (make-node '##core#inline (list iopv) callargs) ]
830                    [else (make-node '##core#inline (list (second classargs)) callargs)] ) ) ) ) ) )
831
832    ;; (<op>) -> <var>
833    ((3) ; classargs = (<var>)
834     (and inline-substitutions-enabled
835          (null? callargs)
836          (intrinsic? name)
837          (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) )
838
839    ;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
840    ((4) ; classargs = (<primitiveop> <i>)
841     (and inline-substitutions-enabled
842          unsafe
843          (= 2 (length callargs))
844          (intrinsic? name)
845          (make-node '##core#call (list #f (first classargs))
846                     (list (varnode (first classargs))
847                           cont
848                           (first callargs)
849                           (qnode (second classargs))
850                           (second callargs) ) ) ) )
851
852    ;; (<op> a) -> (##core#inline <iop> a (quote <x>))
853    ((5) ; classargs = (<iop> <x> <numtype>)
854     ;; - <numtype> may be #f
855     (and inline-substitutions-enabled
856          (intrinsic? name)
857          (= 1 (length callargs))
858          (let ((ntype (third classargs)))
859            (or (not ntype) (eq? ntype number-type)) )
860          (make-node '##core#call '(#t)
861                     (list cont
862                           (make-node '##core#inline (list (first classargs))
863                                      (list (first callargs)
864                                            (qnode (second classargs)) ) ) ) ) ) )
865
866    ;; (<op> a) -> (##core#inline <iop1> (##core#inline <iop2> a))
867    ((6) ; classargs = (<iop1> <iop2> <safe>)
868      (and (or (third classargs) unsafe)
869           inline-substitutions-enabled
870           (= 1 (length callargs))
871           (intrinsic? name)
872           (make-node '##core#call '(#t)
873                      (list cont
874                            (make-node '##core#inline (list (first classargs))
875                                       (list (make-node '##core#inline (list (second classargs))
876                                                        callargs) ) ) ) ) ) )
877
878    ;; (<op> ...) -> (##core#inline <iop> ... (quote <x>))
879    ((7) ; classargs = (<argc> <iop> <x> <safe>)
880     (and (or (fourth classargs) unsafe)
881          inline-substitutions-enabled
882          (= (length callargs) (first classargs))
883          (intrinsic? name)
884          (make-node '##core#call '(#t)
885                     (list cont
886                           (make-node '##core#inline (list (second classargs))
887                                      (append callargs
888                                              (list (qnode (third classargs))) ) ) ) ) ) )
889
890    ;; (<op> ...) -> <<call procedure <proc> with <classargs>, <cont> and <callargs> >>
891    ((8) ; classargs = (<proc> ...)
892     (and inline-substitutions-enabled
893          (intrinsic? name)
894          ((first classargs) db classargs cont callargs) ) )
895
896    ;; (<op> <x1> ...) -> (##core#inline "C_and" (##core#inline <iop> <x1> <x2>) ...)
897    ;; (<op> [<x>]) -> (quote #t)
898    ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
899     (and inline-substitutions-enabled
900          (intrinsic? name)
901          (if (< (length callargs) 2)
902              (make-node '##core#call '(#t) (list cont (qnode #t)))
903              (and (or (and unsafe (not (eq? number-type 'generic)))
904                       (and (eq? number-type 'fixnum) (third classargs))
905                       (and (eq? number-type 'flonum) (fourth classargs)) )
906                   (let* ([names (map (lambda (z) (gensym)) callargs)]
907                          [vars (map varnode names)] )
908                     (fold-right
909                      (lambda (x n y) (make-node 'let (list n) (list x y)))
910                      (make-node
911                       '##core#call '(#t)
912                       (list
913                        cont
914                        (let ([op (list
915                                   (if (eq? number-type 'fixnum)
916                                       (first classargs)
917                                       (second classargs) ) ) ] )
918                          (fold-boolean
919                           (lambda (x y) (make-node '##core#inline op (list x y))) 
920                           vars) ) ) )
921                      callargs names) ) ) ) ) )
922
923    ;; (<op> a [b]) -> (<primitiveop> a (quote <i>) b)
924    ((10) ; classargs = (<primitiveop> <i> <bvar> <safe>)
925     (and inline-substitutions-enabled
926          (or (fourth classargs) unsafe)
927          (intrinsic? name)
928          (let ((n (length callargs)))
929            (and (< 0 n 3)
930                 (make-node '##core#call (list #f (first classargs))
931                            (list (varnode (first classargs))
932                                  cont
933                                  (first callargs)
934                                  (qnode (second classargs))
935                                  (if (null? (cdr callargs))
936                                      (varnode (third classargs))
937                                      (second callargs) ) ) ) ) ) ) )
938
939    ;; (<op> ...) -> (<primitiveop> ...)
940    ((11) ; classargs = (<argc> <primitiveop> <safe>)
941     ;; <argc> may be #f.
942     (and inline-substitutions-enabled
943          (or (third classargs) unsafe)
944          (intrinsic? name)
945          (let ([argc (first classargs)])
946            (and (or (not argc)
947                     (= (length callargs) (first classargs)) )
948                 (make-node '##core#call (list #t (second classargs))
949                            (cons* (varnode (second classargs))
950                                   cont
951                                   callargs) ) ) ) ) )
952
953    ;; (<op> a) -> a
954    ;; (<op> ...) -> (<primitiveop> ...)
955    ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
956     (and inline-substitutions-enabled
957          (intrinsic? name)
958          (or (second classargs) unsafe)
959          (let ((n (length callargs)))
960            (and (<= n (third classargs))
961                 (case n
962                   ((1) (make-node '##core#call '(#t) (cons cont callargs)))
963                   (else (make-node '##core#call (list #t (first classargs))
964                                    (cons* (varnode (first classargs))
965                                           cont callargs) ) ) ) ) ) ) )
966
967    ;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
968    ((13) ; classargs = (<primitiveop> <safe>)
969     (and inline-substitutions-enabled
970          (intrinsic? name)
971          (or (second classargs) unsafe)
972          (let ((pname (first classargs)))
973            (make-node '##core#call (if (pair? params) (cons #t (cdr params)) params)
974                       (cons* (make-node '##core#proc (list pname #t) '())
975                              cont callargs) ) ) ) )
976
977    ;; (<op> <x> ...) -> (##core#inline <iop-safe>/<iop-unsafe> <x> ...)
978    ((14) ; classargs = (<numtype> <argc> <iop-safe> <iop-unsafe>)
979     (and inline-substitutions-enabled
980          (= (second classargs) (length callargs))
981          (intrinsic? name)
982          (eq? number-type (first classargs))
983          (or (fourth classargs) unsafe)
984          (make-node
985           '##core#call '(#t)
986           (list cont
987                 (make-node
988                  '##core#inline
989                  (list (if unsafe (fourth classargs) (third classargs)))
990                  callargs) ) ) ) )
991
992    ;; (<op> <x>) -> (<primitiveop> <x>)   - if numtype1
993    ;;             | <x>                   - if numtype2
994    ((15) ; classargs = (<numtype1> <numtype2> <primitiveop> <safe>)
995     (and inline-substitutions-enabled
996          (= 1 (length callargs))
997          (or unsafe (fourth classargs))
998          (intrinsic? name)
999          (cond ((eq? number-type (first classargs))
1000                 (make-node '##core#call (list #t (third classargs))
1001                            (cons* (varnode (third classargs)) cont callargs) ) )
1002                ((eq? number-type (second classargs))
1003                 (make-node '##core#call '(#t) (cons cont callargs)) )
1004                (else #f) ) ) )
1005
1006    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
1007    ((16) ; classargs = (<argc> <aiop> <safe> <words>)
1008     ;; - <argc> may be #f, saying that any number of arguments is allowed,
1009     ;; - <words> may be a list of one element (the number of words), meaning that
1010     ;;   the words are to be multiplied with the number of arguments.
1011     ;; - <words> may also be #t, meaning that the number of words is the same as the
1012     ;;   number of arguments plus 1.
1013     (let ([argc (first classargs)]
1014           [rargc (length callargs)]
1015           [w (fourth classargs)] )
1016       (and inline-substitutions-enabled
1017            (or (not argc) (= rargc argc))
1018            (intrinsic? name)
1019            (or (third classargs) unsafe)
1020            (make-node
1021             '##core#call '(#t)
1022             (list cont 
1023                   (make-node
1024                    '##core#inline_allocate
1025                    (list (second classargs) 
1026                          (cond [(eq? #t w) (add1 rargc)]
1027                                [(pair? w) (* rargc (car w))]
1028                                [else w] ) )
1029                    callargs) ) ) ) ) )
1030
1031    ;; (<op> ...) -> (##core#inline <iop>/<unsafe-iop> ...)
1032    ((17) ; classargs = (<argc> <iop-safe> [<iop-unsafe>])
1033     (and inline-substitutions-enabled
1034          (= (length callargs) (first classargs))
1035          (intrinsic? name)
1036          (make-node
1037           '##core#call '(#t)
1038           (list cont
1039                 (make-node '##core#inline
1040                            (list (if (and unsafe (pair? (cddr classargs)))
1041                                      (third classargs)
1042                                      (second classargs) ) )
1043                            callargs)) ) ) )
1044
1045    ;; (<op>) -> (quote <null>)
1046    ((18) ; classargs = (<null>)
1047     (and inline-substitutions-enabled
1048          (null? callargs)
1049          (intrinsic? name)
1050          (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )
1051
1052    ;; (<op>) -> <id>
1053    ;; (<op> <x>) -> <x>
1054    ;; (<op> <x1> ...) -> (##core#inline <fixop> <x1> (##core#inline <fixop> ...)) [fixnum-mode]
1055    ;; (<op> <x1> ...) -> (##core#inline <ufixop> <x1> (##core#inline <ufixop> ...)) [fixnum-mode + unsafe]
1056    ;; - Remove "<id>" from arguments.
1057    ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
1058     (and inline-substitutions-enabled
1059          (intrinsic? name)
1060          (let* ([id (first classargs)]
1061                 [fixop (if unsafe (third classargs) (second classargs))]
1062                 [callargs 
1063                  (remove
1064                   (lambda (x)
1065                     (and (eq? 'quote (node-class x))
1066                          (eq? id (first (node-parameters x))) ) ) 
1067                   callargs) ] )
1068            (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
1069                  [(null? (cdr callargs))
1070                   (make-node '##core#call '(#t) (list cont (first callargs))) ]
1071                  [(or (fourth classargs) (eq? number-type 'fixnum))
1072                   (make-node
1073                    '##core#call '(#t)
1074                    (list
1075                     cont
1076                     (fold-inner
1077                      (lambda (x y)
1078                        (make-node '##core#inline (list fixop) (list x y)) )
1079                      callargs) ) ) ]
1080                  [else #f] ) ) ) )
1081
1082    ;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
1083    ((20) ; classargs = (<argc> <iop> <x> <safe>)
1084     (let ([n (length callargs)])
1085       (and (or (fourth classargs) unsafe)
1086            inline-substitutions-enabled
1087            (= n (first classargs))
1088            (intrinsic? name)
1089            (make-node
1090             '##core#call '(#t)
1091             (list cont
1092                   (make-node 
1093                    '##core#inline (list (second classargs))
1094                    (let-values ([(head tail) (split-at callargs (sub1 n))])
1095                      (append head
1096                              (list (qnode (third classargs)))
1097                              tail) ) ) ) ) ) ) )
1098
1099    ;; (<op>) -> <id>
1100    ;; (<op> <x>) -> <x>
1101    ;; (<op> <x1> ...) -> (##core#inline_allocate (<genop> <words>) <x1> (##core#inline_allocate (<genop> <words>) ...))
1102    ;; (<op> <x1> ...) -> (##core#inline <[u]fixop> <x1> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
1103    ;; - Remove "<id>" from arguments.
1104    ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
1105     (and inline-substitutions-enabled
1106          (intrinsic? name)
1107          (let* ([id (first classargs)]
1108                 [words (fifth classargs)]
1109                 [genop (fourth classargs)]
1110                 [fixop (if unsafe (third classargs) (second classargs))]
1111                 [callargs 
1112                  (remove
1113                   (lambda (x)
1114                     (and (eq? 'quote (node-class x))
1115                          (eq? id (first (node-parameters x))) ) ) 
1116                   callargs) ] )
1117            (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
1118                  [(null? (cdr callargs))
1119                   (make-node '##core#call '(#t) (list cont (first callargs))) ]
1120                  [else
1121                   (make-node
1122                    '##core#call '(#t)
1123                    (list
1124                     cont
1125                     (fold-inner
1126                      (lambda (x y)
1127                        (if (eq? number-type 'fixnum)
1128                            (make-node '##core#inline (list fixop) (list x y))
1129                            (make-node '##core#inline_allocate (list genop words) (list x y)) ) )
1130                      callargs) ) ) ] ) ) ) )
1131
1132    ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
1133    ;; (<alloc-op> ...) -> (##core#inline <fxop> ...) [fixnum mode]
1134    ((22) ; classargs = (<argc> <aiop> <safe> <words> <fxop>)
1135     (let ([argc (first classargs)]
1136           [rargc (length callargs)]
1137           [w (fourth classargs)] )
1138       (and inline-substitutions-enabled
1139            (= rargc argc)
1140            (intrinsic? name)
1141            (or (third classargs) unsafe)
1142            (make-node
1143             '##core#call '(#t)
1144             (list cont 
1145                   (if (eq? number-type 'fixnum)
1146                       (make-node
1147                        '##core#inline
1148                        (list (fifth classargs))
1149                        callargs)
1150                       (make-node
1151                        '##core#inline_allocate
1152                        (list (second classargs) w)
1153                        callargs) ) ) ) ) ) )
1154
1155    ;; (<op> <arg1> ... <argN>) -> (<primitiveop> ...)
1156    ;; (<op> <arg1> ... <argN-I> <defargN-I>) -> (<primitiveop> ...)
1157    ;; - default args in classargs should be either symbol or (optionally)
1158    ;;   quoted literal
1159    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
1160     (and inline-substitutions-enabled
1161          (intrinsic? name)
1162          (let ([argc (first classargs)])
1163            (and (>= (length callargs) (first classargs))
1164                 (make-node 
1165                  '##core#call (list #t (second classargs))
1166                  (cons*
1167                   (varnode (second classargs))
1168                   cont
1169                   (let-values (((req opt) (split-at callargs argc)))
1170                     (append
1171                      req
1172                      (let loop ((ca opt) 
1173                                 (da (cddr classargs)) )
1174                        (cond ((null? ca)
1175                               (if (null? da)
1176                                   '()
1177                                   (cons (defarg (car da)) (loop '() (cdr da))) ) )
1178                              ((null? da) '())
1179                              (else (cons (car ca) (loop (cdr ca) (cdr da))))))))))))))
1180
1181    (else (bomb "bad type (optimize)")) ) )
1182
1183
1184;;; Optimize direct leaf routines:
1185
1186(define (transform-direct-lambdas! node db)
1187  (let ([dirty #f]
1188        [inner-ks '()] 
1189        [hoistable '()] 
1190        [allocated 0] )
1191
1192    ;; Process node tree and walk lambdas that meet the following constraints:
1193    ;;  - Only external lambdas (no CPS redexes),
1194    ;;  - All calls are either to the direct continuation or (tail-) recursive calls.
1195    ;;  - No allocation, no rest parameter.
1196    ;;  - The lambda has a known container variable and all it's call-sites are known.
1197
1198    (define (walk d n dn)
1199      (let ([params (node-parameters n)]
1200            [subs (node-subexpressions n)] )
1201        (case (node-class n)
1202          [(##core#lambda)
1203           (let ([llist (third params)])
1204             (if (and d
1205                      (second params)
1206                      (not (get db d 'unknown))
1207                      (proper-list? llist)
1208                      (and-let* ([val (get db d 'value)]
1209                                 [refs (get-list db d 'references)]
1210                                 [sites (get-list db d 'call-sites)] )
1211                        (and (eq? n val)
1212                             (= (length refs) (length sites))
1213                             (scan (first subs) (first llist) d dn (cons d llist)) ) ) )
1214                 (transform n d inner-ks hoistable dn allocated) 
1215                 (walk #f (first subs) #f) ) ) ]
1216          [(set!) (walk (first params) (first subs) #f)]
1217          [(let)
1218           (walk (first params) (first subs) n)
1219           (walk #f (second subs) #f) ]
1220          [else (for-each (lambda (x) (walk #f x #f)) subs)] ) ) )
1221
1222    (define (scan n kvar fnvar destn env)
1223      (let ([closures '()]
1224            [recursive #f] )
1225        (define (rec n v vn e)
1226          (let ([params (node-parameters n)]
1227                [subs (node-subexpressions n)] )
1228            (case (node-class n)
1229              [(##core#variable)
1230               (let ([v (first params)])
1231                 (or (not (get db v 'boxed))
1232                     (not (memq v env))
1233                     (and (not recursive)
1234                          (begin
1235                            (set! allocated (+ allocated 2))
1236                            #t) ) ) ) ]
1237              [(##core#lambda)
1238               (and v
1239                    (decompose-lambda-list
1240                     (third params)
1241                     (lambda (vars argc rest)
1242                       (set! closures (cons v closures))
1243                       (rec (first subs) #f #f (append vars e)) ) ) ) ]
1244              [(##core#inline_allocate)
1245               (and (not recursive)
1246                    (begin
1247                      (set! allocated (+ allocated (second params)))
1248                      (every (lambda (x) (rec x #f #f e)) subs) ) ) ]
1249              [(##core#direct_lambda)
1250               (and vn destn
1251                    (null? (scan-used-variables (first subs) e)) 
1252                    (begin
1253                      (set! hoistable (alist-cons v vn hoistable))
1254                      #t) ) ]
1255              [(##core#inline_ref)
1256               (and (let ([n (estimate-foreign-result-size (second params))])
1257                      (or (zero? n)
1258                          (and (not recursive)
1259                               (begin
1260                                 (set! allocated (+ allocated n))
1261                                 #t) ) ) )
1262                    (every (lambda (x) (rec x #f #f e)) subs) ) ]
1263              [(##core#inline_loc_ref)
1264               (and (let ([n (estimate-foreign-result-size (first params))])
1265                      (or (zero? n)
1266                          (and (not recursive)
1267                               (begin
1268                                 (set! allocated (+ allocated n))
1269                                 #t) ) ) )
1270                    (every (lambda (x) (rec x #f #f e)) subs) ) ]
1271              [(##core#call)
1272               (let ([fn (first subs)])
1273                 (and (eq? '##core#variable (node-class fn))
1274                      (let ([v (first (node-parameters fn))])
1275                        (cond [(eq? v fnvar)
1276                               (and (zero? allocated)
1277                                    (let ([k (second subs)])
1278                                      (when (eq? '##core#variable (node-class k))
1279                                        (set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
1280                                      (set! recursive #t)
1281                                      #t) ) ]
1282                              [else (eq? v kvar)] ) )
1283                      (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) ]
1284              [(##core#direct_call)
1285               (let ([n (fourth params)])
1286                 (or (zero? n)
1287                     (and (not recursive)
1288                          (begin
1289                            (set! allocated (+ allocated n))
1290                            (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) ]
1291              [(set!) (rec (first subs) (first params) #f e)]
1292              [(let)
1293               (and (rec (first subs) (first params) n e)
1294                    (rec (second subs) #f #f (append params e)) ) ]
1295              [else (every (lambda (x) (rec x #f #f e)) subs)] ) ) )
1296        (set! inner-ks '())
1297        (set! hoistable '())
1298        (set! allocated 0)
1299        (and (rec n #f #f env)
1300             (lset= eq? closures (delete kvar inner-ks eq?)) ) ) )
1301
1302    (define (transform n fnvar ks hoistable destn allocated)
1303      (if (pair? hoistable)
1304          (debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
1305          (debugging 'o "direct leaf routine/allocation" fnvar allocated) )
1306      (set! dirty #t)
1307      (let* ([params (node-parameters n)]
1308             [argc (length (third params))]
1309             [klambdas '()] 
1310             [sites (get db fnvar 'call-sites)] 
1311             [ksites '()] )
1312        (if (and (list? params) (= (length params) 4) (list? (caddr params)))
1313            (let ((id (car params))
1314                  (kvar (caaddr params))
1315                  (vars (cdaddr params)) )
1316              ;; Remove continuation argument:
1317              (set-car! (cddr params) vars)
1318           ;; Make "##core#direct_lambda":
1319           (node-class-set! n '##core#direct_lambda)
1320           ;; Transform recursive calls and remove unused continuations:
1321
1322           (let rec ([n (first (node-subexpressions n))])
1323             (let ([params (node-parameters n)]
1324                   [subs (node-subexpressions n)] )
1325               (case (node-class n)
1326                 [(##core#call)
1327                  (let* ([fn (first subs)]
1328                         [arg0 (second subs)]
1329                         [fnp (node-parameters fn)] 
1330                         [arg0p (node-parameters arg0)] )
1331                    (when (eq? '##core#variable (node-class fn))
1332                      (cond [(eq? fnvar (first fnp))
1333                             (set! ksites (alist-cons #f n ksites))
1334                             (cond [(eq? kvar (first arg0p))
1335                                    (unless (= argc (length (cdr subs)))
1336                                      (quit
1337                                       "known procedure called recursively with wrong number of arguments: `~A'" 
1338                                       fnvar) )
1339                                    (node-class-set! n '##core#recurse)
1340                                    (node-parameters-set! n (list #t id))
1341                                    (node-subexpressions-set! n (cddr subs)) ]
1342                                   [(assq (first arg0p) klambdas)
1343                                    => (lambda (a)
1344                                         (let* ([klam (cdr a)]
1345                                                [kbody (first (node-subexpressions klam))] )
1346                                           (unless (= argc (length (cdr subs)))
1347                                             (quit
1348                                              "known procedure called recursively with wrong number of arguments: `~A'" 
1349                                              fnvar) )
1350                                           (node-class-set! n 'let)
1351                                           (node-parameters-set! n (take (third (node-parameters klam)) 1))
1352                                           (node-subexpressions-set!
1353                                            n
1354                                            (list (make-node '##core#recurse (list #f id) (cddr subs)) kbody) )
1355                                           (rec kbody) ) ) ]
1356                                   [else (bomb "missing kvar" arg0p)] ) ]
1357                            [(eq? kvar (first fnp))
1358                             (node-class-set! n '##core#return)
1359                             (node-parameters-set! n '())
1360                             (node-subexpressions-set! n (cdr subs)) ]
1361                            [else (bomb "bad call (leaf)")] ) ) ) ]
1362                 [(let)
1363                  (let ([var (first params)]
1364                        [val (first subs)] )
1365                    (cond [(memq var ks)
1366                           (set! klambdas (alist-cons var val klambdas))
1367                           (copy-node! (second subs) n)
1368                           (rec n) ]
1369                          [else (for-each rec subs)] ) ) ]
1370
1371                 [else (for-each rec subs)] ) ) )
1372
1373           ;; Transform call-sites:
1374           (for-each
1375            (lambda (site)
1376              (let* ([n (cdr site)]
1377                     [nsubs (node-subexpressions n)] )
1378                (unless (= argc (length (cdr nsubs)))
1379                  (quit
1380                   "known procedure called with wrong number of arguments: `~A'"
1381                   fnvar) )
1382                (node-subexpressions-set!
1383                 n
1384                 (list (second nsubs)
1385                       (make-node
1386                        '##core#direct_call
1387                        (list #t #f id allocated)
1388                        (cons (car nsubs) (cddr nsubs)) ) ) ) ) )
1389            (lset-difference (lambda (s1 s2) (eq? (cdr s1) (cdr s2))) sites ksites) )
1390
1391           ;; Hoist direct lambdas out of container:
1392           (when (and destn (pair? hoistable))
1393             (let ([destn0 (make-node #f #f #f)])
1394               (copy-node! destn destn0) ; get copy of container binding
1395               (let ([hoisted
1396                      (fold-right       ; build cascade of bindings for each hoistable direct lambda...
1397                       (lambda (h rest)
1398                         (make-node
1399                          'let (list (car h))
1400                          (let ([dlam (first (node-subexpressions (cdr h)))])
1401                            (list (make-node (node-class dlam) (node-parameters dlam) (node-subexpressions dlam))
1402                                  rest) ) ) )
1403                       destn0
1404                       hoistable) ] )
1405                 (copy-node! hoisted destn) ; mutate container binding to hold hoistable bindings
1406                 (for-each
1407                  (lambda (h)           ; change old direct lambdas bindings to dummy ones...
1408                    (let ([vn (cdr h)])
1409                      (node-parameters-set! vn (list (gensym)))
1410                      (set-car! (node-subexpressions vn) (make-node '##core#undefined '() '())) ) )
1411                  hoistable) ) ) ) )
1412            (bomb "invalid parameter list" params))))
1413
1414    (debugging 'p "direct leaf routine optimization pass...")
1415    (walk #f node #f)
1416    dirty) )
1417
1418
1419;;; Lambda lift:
1420;
1421; - Find lambda-liftable local procedures and lift them to toplevel.
1422; - Pass free variables as extra parameters, including the free variables of
1423;   other lifted procedures. This implies that lifted procedures that call each
1424;   other have to be in the same scope.
1425; - Declare the lifted procedures (effectively) as bound-to-procedure and block-global.
1426
1427(define (perform-lambda-lifting! node db)
1428  (let ([lambda-values '()]
1429        [eliminated '()] )
1430   
1431    (define (find-lifting-candidates)
1432      ;; Collect potentially liftable procedures and return as a list of (<name> . <value>) pairs:
1433      ;; - Also build a-list that maps lambda-nodes to names.
1434      (let ([cs '()])
1435        (##sys#hash-table-for-each
1436         (lambda (sym plist)
1437           (and-let* ([val (assq 'value plist)]
1438                      [refs (assq 'references plist)]
1439                      [css (assq 'call-sites plist)] 
1440                      [nrefs (length (cdr refs))] )
1441             (when (and (not (assq 'unknown plist))
1442                        (eq? 'lambda (node-class (cdr val)))
1443                        (not (assq 'global plist)) 
1444                        #;(> nrefs 1)
1445                        (= nrefs (length (cdr css))) )
1446               (set! lambda-values (alist-cons (cdr val) sym lambda-values))
1447               (set! cs (alist-cons sym (cdr val) cs)) ) ) )
1448         db)
1449        cs) )
1450
1451    (define (build-call-graph cs)
1452      ;; Build call-graph of the form ((<name> (<free1> ...) <called1> ...) ...):
1453      (let ([g '()]
1454            [free '()]
1455            [called '()] )
1456
1457        (define (walk n env)
1458          (let ([class (node-class n)]
1459                [params (node-parameters n)]
1460                [subs (node-subexpressions n)] )
1461            (case class
1462              [(##core#variable set!)
1463               (let ([var (first params)])
1464                 (unless (or (memq var env) (get db var 'global))
1465                   (set! free (cons var free)) )
1466                 (when (assq var cs) (set! called (cons var called)))
1467                 (for-each (lambda (n) (walk n env)) subs) ) ]
1468              [(let)
1469               (let loop ([vars params] [vals subs])
1470                 (if (null? vars)
1471                     (walk (car vals) (append params env))
1472                     (let ([var (car vars)])
1473                       (walk (car vals) env)
1474                       (loop (cdr vars) (cdr vals)) ) ) ) ]
1475              [(lambda)
1476               (decompose-lambda-list
1477                (first params)
1478                (lambda (vars argc rest) (walk (first subs) (append vars env))) ) ]
1479              [else (for-each (lambda (n) (walk n env)) subs)] ) ) )
1480
1481        (for-each
1482         (lambda (cs)
1483           (let* ([here (car cs)]
1484                  [lval (cdr cs)] 
1485                  [llist (car (node-parameters lval))] )
1486             (set! free '())
1487             (set! called '())
1488             (decompose-lambda-list
1489              llist
1490              (lambda (vars arg rest)
1491                (walk (car (node-subexpressions lval)) vars) ) )
1492             (set! g (alist-cons here (cons free called) g)) ) )
1493         cs)
1494        g) )
1495
1496    (define (eliminate cs graph)
1497      ;; Eliminate all liftables that have free variables that are assigned to (and are not liftable),
1498      ;;  or that have more than N free variables (including free variables of called liftables):
1499      (remove
1500       (lambda (gn)
1501         (or (> (count-free-variables (car gn) graph) maximal-number-of-free-variables-for-liftable)
1502             (any (lambda (v) 
1503                    (and (get db v 'assigned) 
1504                         (not (assq v cs)) ) )
1505                  (second gn) ) ) )
1506       graph) )
1507
1508    (define (count-free-variables name graph)
1509      (let ([gnames (unzip1 graph)])
1510        (let count ([n name] [walked '()])
1511          (let* ([a (assq n graph)]
1512                 [cs (lset-difference eq? (cddr a) walked gnames)]
1513                 [f (length (delete-duplicates (second a) eq?))]
1514                 [w2 (cons n (append cs walked))] )
1515            (fold + f (map (lambda (c) (count c w2)) cs)) ) ) ) )
1516
1517    (define (collect-accessibles graph)
1518      ;; Collect accessible variables for each liftable into list of the form (<name> <accessible1> ...):
1519      (let ([al '()])
1520        (let walk ([n node] [vars '()])
1521          (let ([class (node-class n)]
1522                [params (node-parameters n)]
1523                [subs (node-subexpressions n)] )
1524            (case class
1525              [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
1526              [(let)
1527               (let loop ([vars2 params] [vals subs])
1528                 (if (null? vars2)
1529                     (walk (car vals) (append params vars))
1530                     (begin
1531                       (walk (car vals) vars)
1532                       (loop (cdr vars2) (cdr vals)) ) ) ) ]
1533              [(lambda)
1534               (let ([lval (assq n lambda-values)])
1535                 (when lval
1536                   (let ([name (cdr lval)])
1537                     (when (assq name graph)
1538                       (set! al (alist-cons (cdr lval) vars al))) ) ) )
1539               (decompose-lambda-list
1540                (first params)
1541                (lambda (vars2 argc rest)
1542                  (walk (car subs) (append vars2 vars)) ) ) ]
1543              [else
1544               (for-each (lambda (n) (walk n vars)) subs) ] ) ) )
1545        al) )
1546
1547    (define (eliminate2 graph al)
1548      ;; Eliminate liftables that have call-sites without access to all free variables;
1549      (remove
1550       (lambda (gn)
1551         (let* ([name (first gn)]
1552                [free (second gn)] )
1553           (any (lambda (gn2)
1554                  (and (memq name (cddr gn2)) ; callee?
1555                       (lset<= eq? (cdr (assq (car gn2) al)) free) ) )
1556                graph) ) ) 
1557       graph) )
1558
1559    (define (eliminate3 graph)
1560      ;; Eliminate liftables that call other eliminated liftables:
1561      ;; - repeat until nothing changes.
1562      (let loop ([graph graph] [n (length graph)])
1563        (let* ([g2 (filter (lambda (gn) (every (lambda (n) (assq n graph)) (cddr gn))) graph)]
1564               [n2 (length g2)] )
1565          (if (= n n2)
1566              g2
1567              (loop g2 n2) ) ) ) )
1568
1569    (define (eliminate4 graph)
1570      ;; Eliminate liftables that have unknown call-sites which do not have access to
1571      ;;  any of the free variables of all callees:
1572      (let walk ([n node] [vars '()])
1573        (let ([class (node-class n)]
1574              [params (node-parameters n)]
1575              [subs (node-subexpressions n)] )
1576          (case class
1577            [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
1578            [(let)
1579             (let loop ([vars2 params] [vals subs])
1580               (if (null? vars2)
1581                   (walk (car vals) (append params vars))
1582                   (begin
1583                     (walk (car vals) vars)
1584                     (loop (cdr vars2) (cdr vals)) ) ) ) ]
1585            [(lambda)
1586             (decompose-lambda-list
1587              (first params)
1588              (lambda (vars2 argc rest)
1589                (walk (car subs) (append vars2 vars)) ) ) ]
1590            [(##core#call)
1591             (let ([fn (first subs)])
1592               (call-with-current-continuation
1593                (lambda (return)
1594                  (when (eq? '##core#variable (node-class fn))
1595                    (let ([done '()])
1596                      (let loop ([name (first (node-parameters fn))])
1597                        (unless (memq name done)
1598                          (set! done (cons name done))
1599                          (let ([gn (assq name graph)])
1600                            (when gn
1601                              (unless (lset<= eq? (second gn) vars)
1602                                #;(print "*** " (first (node-parameters fn)) " | " name ": " vars " / " (second gn)) 
1603                                (set! graph (delete! gn graph eq?))
1604                                (return #f) )
1605                              (for-each loop (cddr gn)) ) ) ) ) ) ) ) )
1606               (for-each (lambda (n) (walk n vars)) subs) ) ]
1607            [else (for-each (lambda (n) (walk n vars)) subs)] ) ) )
1608      graph)
1609
1610    (define (compute-extra-variables graph)
1611      ;; Gather variables that have to be passed additionally:
1612      ;; - do not pass variables that are defined inside the body of a liftable.
1613      (define (defined n)
1614        (let ([defd '()])
1615          (let walk ([n n])
1616            (let ([class (node-class n)]
1617                  [params (node-parameters n)]
1618                  [subs (node-subexpressions n)] )
1619              (case class
1620                [(let)
1621                 (set! defd (append params defd))
1622                 (for-each walk subs) ]
1623                [(lambda)
1624                 (decompose-lambda-list
1625                  (first params)
1626                  (lambda (vars argc rest)
1627                    (set! defd (append vars defd))
1628                    (walk (first subs)) ) ) ]
1629                [else (for-each walk subs)] ) ) )
1630          defd) )
1631      (let ([extras (map (lambda (gn) (cons (first gn) (second gn))) graph)]
1632            [walked '()] )
1633        (define (walk gn)
1634          (let ([name (car gn)])
1635            ;; Hm. To handle liftables that are called recursively (but indirect) I use this kludge. Is it safe?
1636            (unless (> (count (cut eq? name <>) walked) 1)
1637              (set! walked (cons name walked))
1638              (let ([callees (cddr gn)])
1639                (for-each (lambda (c) (walk (assq c graph))) callees)
1640                (let ([f (assq name extras)])
1641                  (set-cdr! f (append (cdr f) (concatenate (map (lambda (n2) (cdr (assq n2 extras))) callees)))) ) ) ) ) )
1642        (for-each walk graph)
1643        (map (lambda (xt)
1644               (let* ([name (car xt)]
1645                      [defd (defined (get db name 'value))] )
1646                 (cons name
1647                       (remove 
1648                        (lambda (v)
1649                          (or (assq v graph)
1650                              (memq v defd) ) )
1651                        (delete-duplicates (cdr xt) eq?)) ) ) )
1652             extras) ) )
1653
1654    (define (reconstruct! graph extra)
1655      ;; Reconstruct node tree by adding global definitions:
1656      (node-subexpressions-set!
1657       node
1658       (list
1659        (fold-right
1660         (lambda (gn body)
1661           (let* ([name (car gn)]
1662                  [lval (get db name 'value)] )
1663             (hide-variable name)
1664             (decompose-lambda-list
1665              (first (node-parameters lval))
1666              (lambda (vars argc rest)
1667                (let* ([xvars (cdr (assq name extra))]
1668                       [xaliases (map gensym xvars)]
1669                       [xmap (map cons xvars xaliases)] )
1670                  (rename-extra-variables! (first (node-subexpressions lval)) xmap)
1671                  (make-node
1672                   'let (list (gensym 't))
1673                   (list (make-node
1674                          'set! (list name)
1675                          (list
1676                           (make-node
1677                            'lambda
1678                            (list (build-lambda-list (append xaliases vars) (+ argc (length xvars)) rest))
1679                            (node-subexpressions lval) ) ) )
1680                         body) ) ) ) ) ) )
1681         (first (node-subexpressions node))
1682         graph) ) ) )
1683
1684    (define (rename-extra-variables! node xmap)
1685      ;; Rename variables from a given map:
1686      (define (rename v)
1687        (let ([a (assq v xmap)])
1688          (if a (cdr a) v) ) )
1689      (let walk ([n node])
1690        (let ([class (node-class n)]
1691              [params (node-parameters n)]
1692              [subs (node-subexpressions n)] )
1693          (case class
1694            [(let)
1695             (node-parameters-set! n (map rename params))
1696             (for-each walk subs) ]
1697            [(##core#variable)
1698             (node-parameters-set! n (list (rename (first params)))) ]
1699            [(set!)
1700             (node-parameters-set! n (list (rename (first params))))
1701             (for-each walk subs) ]
1702            [(lambda)
1703             (decompose-lambda-list
1704              (first params)
1705              (lambda (vars argc rest)
1706                (set-car! params (build-lambda-list (map rename vars) argc rest)) 
1707                (walk (first subs)) ) ) ]
1708            [else (for-each walk subs)] ) ) ) )
1709
1710    (define (extend-call-sites! extra)
1711      ;; Change call sites by adding extra variables:
1712      (let walk ([n node])
1713        (let ([class (node-class n)]
1714              [params (node-parameters n)]
1715              [subs (node-subexpressions n)] )
1716          (case class
1717            [(##core#call)
1718             (let ([fn (first subs)])
1719               (when (eq? '##core#variable (node-class fn))
1720                 (let ([a (assq (first (node-parameters fn)) extra)])
1721                   (when a
1722                     (set-car! params #t)
1723                     (node-subexpressions-set! 
1724                      n
1725                      (cons fn (append (map varnode (cdr a)) (cdr subs))) ) ) ) )
1726               (for-each walk (node-subexpressions n)) ) ]
1727            [else (for-each walk subs)] ) ) ) )
1728
1729    (define (remove-local-bindings! graph)
1730      ;; Remove local definitions of lifted procedures:
1731      (let walk ([n node])
1732        (let ([class (node-class n)]
1733              [params (node-parameters n)]
1734              [subs (node-subexpressions n)] )
1735          (case class
1736            [(let)
1737             (for-each walk (node-subexpressions n))
1738             (let ([vars2 '()]
1739                   [vals2 '()] )
1740               (do ([vars params (cdr vars)]
1741                    [vals subs (cdr vals)] )
1742                   ((null? vars)
1743                    (cond [(null? vars2) (copy-node! (car vals) n)]
1744                          [else
1745                           (node-parameters-set! n (reverse vars2))
1746                           (node-subexpressions-set! n (append (reverse vals2) vals)) ] ) )
1747                 (unless (assq (car vars) graph)
1748                   (set! vars2 (cons (car vars) vars2))
1749                   (set! vals2 (cons (car vals) vals2)) ) ) ) ]
1750            [(set!)
1751             (for-each walk (node-subexpressions n))
1752             (when (assq (first params) graph)
1753               (node-class-set! n '##core#undefined)
1754               (node-parameters-set! n '())
1755               (node-subexpressions-set! n '()) ) ]
1756            [else (for-each walk subs)] ) ) ) )
1757
1758    (debugging 'p "gathering liftables...")
1759    (let ([cs (find-lifting-candidates)])
1760      (debugging 'p "building call graph...")
1761      (let ([g (build-call-graph cs)])
1762        (debugging 'p "eliminating non-liftables...")
1763        (let ([g2 (eliminate cs g)])
1764          (when (debugging 'l "call-graph:") (pretty-print g2))
1765          (debugging 'p "computing access-lists...")
1766          (let ([al (collect-accessibles g2)])
1767            (when (debugging 'l "accessibles:") (pretty-print al))
1768            (debugging 'p "eliminating liftables by access-lists and non-liftable callees...")
1769            (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))]) - why isn't this used?
1770              (debugging 'o "liftable local procedures" (delay (unzip1 ls)))
1771              (debugging 'p "gathering extra parameters...")
1772              (let ([extra (compute-extra-variables ls)])
1773                (when (debugging 'l "additional parameters:") (pretty-print extra))
1774                (debugging 'p "changing call sites...")
1775                (extend-call-sites! extra)
1776                (debugging 'p "removing local bindings...")
1777                (remove-local-bindings! ls)
1778                (debugging 'p "moving liftables to toplevel...")
1779                (reconstruct! ls extra) ) ) ) ) ) ) ) )
1780
1781
1782;;; Compiler macros (that operate in the expansion phase)
1783
1784(define compiler-syntax-statistics '())
1785
1786(set! ##sys#compiler-syntax-hook
1787  (lambda (name result)
1788    (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
1789      (set! compiler-syntax-statistics
1790        (alist-update! name (add1 a) compiler-syntax-statistics)))))
1791
1792(define (r-c-s names transformer #!optional (se '()))
1793  (let ((t (cons (##sys#er-transformer transformer) se)))
1794    (for-each
1795     (lambda (name)
1796       (##sys#put! name '##compiler#compiler-syntax t) )
1797     (if (symbol? names) (list names) names) ) ) )
1798
1799(r-c-s 
1800 '(for-each ##sys#for-each #%for-each)
1801 (lambda (x r c)
1802   (let ((%let (r 'let))
1803         (%if (r 'if))
1804         (%loop (r 'loop))
1805         (%lst (r 'lst))
1806         (%begin (r 'begin))
1807         (%pair? (r 'pair?)))
1808     (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus
1809              (= 3 (length x)))                  ; intrinsic marks) isn't set up yet
1810         `(,%let ,%loop ((,%lst ,(caddr x)))
1811                 (,%if (,%pair? ,%lst)
1812                       (,%begin
1813                        (,(cadr x) (##sys#slot ,%lst 0))
1814                        (##core#app ,%loop (##sys#slot ,%lst 1))) ) )
1815         x)))
1816 `((pair? . ,(##sys#primitive-alias 'pair?))))
1817
1818(r-c-s
1819 '(o #%o)
1820 (lambda (x r c)
1821   (if (and (fx> (length x) 1)
1822            (memq 'o extended-bindings) )
1823       (let ((%tmp (r 'tmp)))
1824         `(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x))))
1825       x)))
1826
1827(let ((env `((display . ,(##sys#primitive-alias 'display)) ;XXX clean this up
1828             (write . ,(##sys#primitive-alias 'write))
1829             (fprintf . ,(##sys#primitive-alias 'fprintf))
1830             (number->string . ,(##sys#primitive-alias 'number->string))
1831             (write-char . ,(##sys#primitive-alias 'write-char))
1832             (open-output-string . ,(##sys#primitive-alias 'open-output-string))
1833             (get-output-string . ,(##sys#primitive-alias 'get-output-string)) ) ) )
1834  (r-c-s
1835   '(sprintf #%sprintf format #%format)
1836   (lambda (x r c)
1837     (let* ((out (gensym 'out))
1838            (code (compile-format-string 
1839                   (if (memq (car x) '(sprintf #%sprintf))
1840                       'sprintf
1841                       'format)
1842                   out 
1843                   x
1844                   (cdr x)
1845                   r c)))
1846       (if code
1847           `(,(r 'let) ((,out (,(r 'open-output-string))))
1848             ,code
1849             (,(r 'get-output-string) ,out))
1850           x)))
1851   env)
1852  (r-c-s
1853   '(fprintf #%fprintf)
1854   (lambda (x r c)
1855     (if (>= (length x) 3)
1856         (let ((code (compile-format-string 
1857                      'fprintf (cadr x) 
1858                      x (cddr x)
1859                      r c)))
1860           (if code
1861               code
1862               x))
1863         x))
1864   env)
1865  (r-c-s
1866   '(printf #%printf)
1867   (lambda (x r c)
1868     (let ((code (compile-format-string 
1869                  'printf '##sys#standard-output
1870                  x (cdr x)
1871                  r c)))
1872       (if code
1873           code
1874           x)))
1875   env))
1876
1877(define (compile-format-string func out x args r c)
1878  (call/cc
1879   (lambda (return)
1880     (and (>= (length args) 1)
1881          (memq func extended-bindings) ; s.a.
1882          (or (string? (car args))
1883              (and (list? (car args))
1884                   (c (r 'quote) (caar args))
1885                   (string? (cadar args))))
1886          (let ((fstr (if (string? (car args)) (car args) (cadar args)))
1887                (args (cdr args)))
1888            (define (fail ret? msg . args)
1889              (let ((ln (get-line x)))
1890                (compiler-warning 
1891                 'syntax
1892                 "(~a) in format string ~s~a, ~?" 
1893                 func fstr 
1894                 (if ln (sprintf " in line ~a" ln) "")
1895                 msg args) ) 
1896              (when ret? (return #f)))
1897            (let ((code '())
1898                  (index 0)
1899                  (len (string-length fstr)) 
1900                  (%display (r 'display))
1901                  (%write (r 'write))
1902                  (%write-char (r 'write-char))
1903                  (%out (r 'out))
1904                  (%fprintf (r 'fprintf))
1905                  (%let (r 'let))
1906                  (%number->string (r 'number->string)))
1907              (define (fetch)
1908                (let ((c (string-ref fstr index)))
1909                  (set! index (fx+ index 1))
1910                  c) )
1911              (define (next)
1912                (if (null? args)
1913                    (fail #t "too few arguments to formatted output procedure")
1914                    (let ((x (car args)))
1915                      (set! args (cdr args))
1916                      x) ) )
1917              (define (endchunk chunk)
1918                (when (pair? chunk)
1919                  (push 
1920                   (if (= 1 (length chunk))
1921                       `(,%write-char ,(car chunk) ,%out)
1922                       `(,%display ,(reverse-list->string chunk) ,%out)))))
1923              (define (push exp)
1924                (set! code (cons exp code)))
1925              (let loop ((chunk '()))
1926                (cond ((>= index len)
1927                       (unless (null? args)
1928                         (fail #f "too many arguments to formatted output procedure"))
1929                       (endchunk chunk)
1930                       `(,%let ((,%out ,out))
1931                               ,@(reverse code)))
1932                      (else
1933                       (let ((c (fetch)))
1934                         (if (eq? c #\~)
1935                             (let ((dchar (fetch)))
1936                               (endchunk chunk)
1937                               (case (char-upcase dchar)
1938                                 ((#\S) (push `(,%write ,(next) ,%out)))
1939                                 ((#\A) (push `(,%display ,(next) ,%out)))
1940                                 ((#\C) (push `(,%write-char ,(next) ,%out)))
1941                                 ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
1942                                 ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
1943                                 ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
1944                                 ((#\!) (push `(##sys#flush-output ,%out)))
1945                                 ((#\?)
1946                                  (let* ([fstr (next)]
1947                                         [lst (next)] )
1948                                    (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
1949                                 ((#\~) (push `(,write-char #\~ ,%out)))
1950                                 ((#\% #\N) (push `(,%write-char #\newline ,%out)))
1951                                 (else
1952                                  (if (char-whitespace? dchar)
1953                                      (let skip ((c (fetch)))
1954                                        (if (char-whitespace? c)
1955                                            (skip (fetch))
1956                                            (set! index (sub1 index))))
1957                                      (fail #t "illegal format-string character `~c'" dchar) ) ) )
1958                               (loop '()) )
1959                             (loop (cons c chunk)))))))))))))
Note: See TracBrowser for help on using the repository browser.