source: project/chicken/branches/prerelease/optimizer.scm @ 15844

Last change on this file since 15844 was 15844, checked in by Ivan Raikov, 10 years ago

Merged trunk r15734 into the prerelease branch.

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