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

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

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