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

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