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

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

merged trunk changes from 14491:15100 into prerelease branch

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