source: project/chicken/tags/0.1071/optimizer.scm @ 17995

Last change on this file since 17995 was 17995, checked in by felix winkelmann, 9 years ago

imported historic version of chicken (0.1071)

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