source: project/chicken/branches/beyond-hope/compiler.scm @ 10359

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

low-level module attempt; converted some more macros

File size: 86.4 KB
Line 
1;;;; compiler.scm - The CHICKEN Scheme compiler
2;
3;
4;
5; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR."
6;
7;
8;-----------------------------------------------------------------------------------------------------------
9; Copyright (c) 2000-2007, Felix L. Winkelmann
10; Copyright (c) 2008, The Chicken Team
11; All rights reserved.
12;
13; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
14; conditions are met:
15;
16;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
17;     disclaimer.
18;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
19;     disclaimer in the documentation and/or other materials provided with the distribution.
20;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
21;     products derived from this software without specific prior written permission.
22;
23; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
24; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
25; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
26; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
28; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
30; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31; POSSIBILITY OF SUCH DAMAGE.
32;
33;
34; Supported syntax:
35;
36; - Declaration specifiers:
37;
38; (unit <unitname>)
39; (uses {<unitname>})
40; ([not] standard-bindings {<name>})
41; ([not] usual-integrations {<name>})
42; ([not] extended-bindings (<name>})
43; ([number-type] <type>)
44; (fixnum-arithmetic)
45; (unsafe)
46; ([not] safe)
47; ([not] interrupts-enabled)
48; (no-bound-checks)
49; (no-argc-checks)
50; (no-procedure-checks)
51; (no-procedure-checks-for-usual-bindings)
52; (block-global {<name>})
53; (lambda-lift)
54; (hide {<name>})
55; (disable-interrupts)
56; (disable-warning <class> ...)
57; (always-bound {<name>})
58; (foreign-declare {<string>})
59; (block)
60; (separate)
61; (run-time-macros)
62; (export {<name>})
63; (safe-globals)
64; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...)
65; (data <tag1> <exp1> ...)
66; (post-process <string> ...)
67; (emit-exports <string>)
68; (keep-shadowed-macros)
69; (import <symbol-or-string> ...)
70; (unused <symbol> ...)
71;
72;   <type> = fixnum | generic
73;
74; - Source language:
75;
76; <variable>
77; <constant>
78; (##core#declare {(quote <spec>)})
79; (##core#immutable <exp>)
80; (##core#global-ref <variable>)
81; (quote <exp>)
82; (if <exp> <exp> [<exp>])
83; (let ({(<variable> <exp>)}) <body>)
84; (##core#let-location (quote <symbol>) (quote <type>) [<init>] <exp>)
85; (lambda <variable> <body>)
86; (lambda ({<variable>}+ [. <variable>]) <body>)
87; (set! <variable> <exp>)
88; (##core#set! <variable> <exp>)
89; (##core#named-lambda <name> <llist> <body>)
90; (##core#loop-lambda <llist> <body>)
91; (##core#undefined)
92; (##core#primitive <name>)
93; (##core#inline <op> {<exp>})
94; (##core#inline_allocate (<op> <words>) {<exp>})
95; (##core#inline_ref (<name> <type>))
96; (##core#inline_update (<name> <type>) <exp>)
97; (##core#inline_loc_ref (<type>) <exp>)
98; (##core#inline_loc_update (<type>) <exp> <exp>)
99; (##core#compiletimetoo <exp>)
100; (##core#compiletimeonly <exp>)
101; (##core#elaborationtimetoo <exp>)
102; (##core#elaborationtimeonly <exp>)
103; (##core#define-foreign-variable (quote <symbol>) (quote <type>) [(quote <string>)])
104; (##core#define-foreign-type (quote <symbol>) (quote <type>) [<proc1> [<proc2>]])
105; (##core#foreign-lambda (quote <type>) (quote <string>) {(quote <type>)})
106; (##core#foreign-lambda* (quote <type>) (quote ({(<type> <var>)})) {(quote <string>)})
107; (##core#foreign-callback-lambda (quote <type>) (quote <string>) {(quote <type>)})
108; (##core#foreign-callback-lambda* (quote <type>) (quote ({(<type> <var>)})) {(quote <string>)})
109; (##core#foreign-primitive (quote <type>) (quote ({(<type> <var>)})) {(quote <string>)})
110; (##core#define-inline (quote <name>) <exp>)
111; (##core#define-constant (quote <name>) <exp>)
112; (##core#foreign-callback-wrapper (quote <name>) (quote <qualifiers>) (quote <type>) (quote {<type>}) <exp>)
113; (##core#define-external-variable (quote <name>) (quote <type>) (quote <bool>))
114; (##core#check <exp>)
115; (##core#require-for-syntax <exp> ...)
116; (##core#require-extension '<id> ...)
117; (##core#app <exp> {<exp>})
118; (##coresyntax <exp>)
119; (<exp> {<exp>})
120;
121; - Core language:
122;
123; [##core#variable {<variable>}]
124; [if {} <exp> <exp> <exp>)]
125; [quote {<exp>}]
126; [let {<variable>} <exp-v> <exp>]
127; [##core#lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
128; [set! {<variable>} <exp>]
129; [##core#undefined {}]
130; [##core#global-ref {<variable>}]
131; [##core#primitive {<name>}]
132; [##core#inline {<op>} <exp>...]
133; [##core#inline_allocate {<op> <words>} <exp>...]
134; [##core#inline_ref {<name> <type>}]
135; [##core#inline_update {<name> <type>} <exp>]
136; [##core#inline_loc_ref {<type>} <exp>]
137; [##core#inline_loc_update {<type>} <exp> <exp>]
138; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
139; [##core#callunit {<unitname>} <exp>...]
140; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
141; [##core#cond <exp> <exp> <exp>]
142; [##core#recurse {<tail-flag>} <exp1> ...]
143; [##core#return <exp>]
144; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
145; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
146;
147; - Closure converted/prepared language:
148;
149; [if {} <exp> <exp> <exp>]
150; [quote {<exp>}]
151; [##core#bind {<count>} <exp-v>... <exp>]
152; [##core#undefined {}]
153; [##core#inline {<op>} <exp>...]
154; [##core#inline_allocate {<op <words>} <exp>...]
155; [##core#inline_ref {<name> <type>}]
156; [##core#inline_update {<name> <type>} <exp>]
157; [##core#inline_loc_ref {<type>} <exp>]
158; [##core#inline_loc_update {<type>} <exp> <exp>]
159; [##core#closure {<count>} <exp>...]
160; [##core#box {} <exp>]
161; [##core#unbox {} <exp>]
162; [##core#ref {<index>} <exp>]
163; [##core#update {<index>} <exp> <exp>]
164; [##core#updatebox {} <exp> <exp>]
165; [##core#update_i {<index>} <exp> <exp>]
166; [##core#updatebox_i {} <exp> <exp>]
167; [##core#call {<safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...]
168; [##core#callunit {<unitname>} <exp>...]
169; [##core#local {<index>}]
170; [##core#setlocal {<index>} <exp>]
171; [##core#global {<literal> <safe-flag> <block-mode> [<name>]}]
172; [##core#setglobal {<literal> <block-mode>} <exp>]
173; [##core#setglobal_i {<literal> <block-mode>} <exp>]
174; [##core#literal {<literal>}]
175; [##core#immediate {<type> [<immediate>]}]     - type: bool/fix/nil/char
176; [##core#proc {<name> [<non-internal>]}]
177; [##core#recurse {<tail-flag> <call-id>} <exp1> ...]
178; [##core#return <exp>]
179; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
180;
181;
182; Analysis database entries:
183;
184; <variable>:
185;
186;   captured -> <boolean>                    If true: variable is used outside it's home-scope
187;   global -> <boolean>                      If true: variable does not occur in any lambda-list
188;   call-sites -> ((<lambda-id> <node>) ...) Known call-nodes of a named procedure
189;   home -> <lambda-id>                      Procedure which introduces this variable
190;   unknown -> <boolean>                     If true: variable can not have a known value
191;   assigned -> <boolean>                    If true: variable is assigned somewhere
192;   assigned-locally -> <boolean>            If true: variable has been assigned inside user lambda
193;   undefined -> <boolean>                   If true: variable is unknown yet but can be known later
194;   value -> <node>                          Variable has a known value
195;   potential-value -> <node>                Global variable was assigned this value
196;   references -> (<node> ...)               Nodes that are accesses of this variable (##core#variable nodes)
197;   side-effecting -> <boolean>              If true: variable names side-effecting standard-binding
198;   foldable -> <boolean>                    If true: variable names foldable standard-binding
199;   boxed -> <boolean>                       If true: variable has to be boxed after closure-conversion
200;   contractable -> <boolean>                If true: variable names contractable procedure
201;   inlinable -> <boolean>                   If true: variable names potentially inlinable procedure
202;   collapsable -> <boolean>                 If true: variable refers to collapsable constant
203;   removable -> <boolean>                   If true: variable is not used
204;   replacable -> <variable>                 Variable can be replaced by another variable
205;   replacing -> <boolean>                   If true: variable can replace another variable (don't remove)
206;   standard-binding -> <boolean>            If true: variable names a standard binding
207;   extended-binding -> <boolean>            If true: variable names an extended binding
208;   unused -> <boolean>                      If true: variable is a formal parameter that is never used
209;   rest-parameter -> #f | 'vector | 'list   If true: variable holds rest-argument list mode
210;   o-r/access-count -> <n>                  Contains number of references as arguments of optimizable rest operators
211;   constant -> <boolean>                    If true: variable has fixed value
212;
213; <lambda-id>:
214;
215;   contains -> (<lambda-id> ...)            Procedures contained in this lambda
216;   contained-in -> <lambda-id>              Procedure containing this lambda
217;   has-unused-parameters -> <boolean>       If true: procedure has unused formal parameters
218;   use-expr -> (<lambda-id> ...)            Marks non-direct use-sites of common subexpression
219;   closure-size -> <integer>                Number of free variables stored in a closure
220;   customizable -> <boolean>                If true: all call sites are known, procedure does not escape
221;   simple -> <boolean>                      If true: procedure only calls its continuation
222;   explicit-rest -> <boolean>               If true: procedure is called with consed rest list
223;   captured-variables -> (<var> ...)        List of closed over variables
224
225
226(declare
227 (unit compiler)
228 (disable-warning var) )
229
230#>
231#ifndef C_INSTALL_SHARE_HOME
232# define C_INSTALL_SHARE_HOME NULL
233#endif
234
235#ifndef C_DEFAULT_TARGET_STACK_SIZE
236# define C_DEFAULT_TARGET_STACK_SIZE 0
237#endif
238
239#ifndef C_DEFAULT_TARGET_HEAP_SIZE
240# define C_DEFAULT_TARGET_HEAP_SIZE 0
241#endif
242<#
243
244
245(private compiler
246  compiler-arguments process-command-line explicit-use-flag inline-list not-inline-list
247  default-standard-bindings default-extended-bindings side-effecting-standard-bindings
248  non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
249  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
250  installation-home decompose-lambda-list external-to-pointer defconstant-bindings constant-declarations
251  copy-node! error-is-extended-binding toplevel-scope toplevel-lambda-id
252  unit-name insert-timer-checks used-units external-variables require-imports-flag custom-declare-alist
253  profile-info-vector-name finish-foreign-result pending-canonicalizations
254  foreign-declarations emit-trace-info block-compilation line-number-database-size
255  always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name
256  target-heap-size target-stack-size valid-c-identifier?
257  target-initial-heap-size internal-bindings source-filename dump-nodes source-info->string
258  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
259  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
260  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
261  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
262  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
263  direct-call-ids foreign-type-table first-analysis callback-names disabled-warnings
264  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
265  compiler-warning import-table use-import-table compiler-macro-table compiler-macros-enabled
266  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
267  reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size
268  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub 
269  expand-foreign-lambda* data-declarations emit-control-file-item expand-foreign-primitive
270  process-declaration external-protos-first basic-literal?
271  transform-direct-lambdas! expand-foreign-callback-lambda* debugging emit-unsafe-marker
272  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
273  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
274  collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
275  put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode 
276  build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
277  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list 
278  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
279  topological-sort print-version print-usage initialize-analysis-database export-list csc-control-file
280  estimate-foreign-result-location-size unused-variables
281  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
282  units-used-by-default words-per-flonum disable-stack-overflow-checking
283  parameter-limit eq-inline-operator optimizable-rest-argument-operators postponed-initforms
284  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
285  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
286  location-pointer-map
287  lookup-exports-file undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
288  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
289  process-custom-declaration do-lambda-lifting file-requirements emit-closure-info export-file-name
290  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result
291  big-fixnum?)
292
293(eval-when (compile eval)
294  (match-error-control #:fail) )
295
296
297(include "tweaks")
298
299
300(define-inline (gensym-f-id) (gensym 'f_))
301
302(eval-when (eval)
303  (define installation-home #f)
304  (define default-target-heap-size #f)
305  (define default-target-stack-size #f) )
306
307(eval-when (load)
308  (define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
309  (define-foreign-variable default-target-heap-size int "C_DEFAULT_TARGET_HEAP_SIZE")
310  (define-foreign-variable default-target-stack-size int "C_DEFAULT_TARGET_STACK_SIZE") )
311
312(define user-options-pass (make-parameter #f))
313(define user-read-pass (make-parameter #f))
314(define user-preprocessor-pass (make-parameter #f))
315(define user-pass (make-parameter #f))
316(define user-pass-2 (make-parameter #f))
317(define user-post-analysis-pass (make-parameter #f))
318
319(define-constant foreign-type-table-size 301)
320(define-constant analysis-database-size 3001)
321(define-constant default-line-number-database-size 997)
322(define-constant inline-table-size 301)
323(define-constant constant-table-size 301)
324(define-constant real-name-table-size 997)
325(define-constant import-table-size 997)
326(define-constant default-inline-max-size 10)
327
328
329;;; Global variables containing compilation parameters:
330
331(define unit-name #f)
332(define number-type 'generic)
333(define standard-bindings '())
334(define extended-bindings '())
335(define insert-timer-checks #t)
336(define used-units '())
337(define unsafe #f)
338(define always-bound '())
339(define always-bound-to-procedure '())
340(define foreign-declarations '())
341(define emit-trace-info #f)
342(define block-compilation #f)
343(define line-number-database-size default-line-number-database-size)
344(define target-heap-size #f)
345(define target-initial-heap-size #f)
346(define target-stack-size #f)
347(define optimize-leaf-routines #f)
348(define emit-profile #f)
349(define no-bound-checks #f)
350(define no-argc-checks #f)
351(define no-procedure-checks #f)
352(define block-globals '())
353(define source-filename #f)
354(define export-list #f)
355(define safe-globals-flag #f)
356(define explicit-use-flag #f)
357(define disable-stack-overflow-checking #f)
358(define require-imports-flag #f)
359(define emit-unsafe-marker #f)
360(define external-protos-first #f)
361(define do-lambda-lifting #f)
362(define inline-max-size -1)
363(define emit-closure-info #t)
364(define export-file-name #f)
365(define import-table #f)
366(define use-import-table #f)
367(define undefine-shadowed-macros #t)
368(define constant-declarations '())
369
370
371;;; These are here so that the backend can access them:
372
373(define default-default-target-heap-size default-target-heap-size)
374(define default-default-target-stack-size default-target-stack-size)
375
376
377;;; Other global variables:
378
379(define verbose-mode #f)
380(define original-program-size #f)
381(define current-program-size 0)
382(define line-number-database-2 #f)
383(define immutable-constants '())
384(define rest-parameters-promoted-to-vector '())
385(define inline-table #f)
386(define inline-table-used #f)
387(define constant-table #f)
388(define constants-used #f)
389(define mutable-constants '())
390(define broken-constant-nodes '())
391(define inline-substitutions-enabled #f)
392(define direct-call-ids '())
393(define first-analysis #t)
394(define foreign-type-table #f)
395(define foreign-variables '())
396(define foreign-lambda-stubs '())
397(define foreign-callback-stubs '())
398(define external-variables '())
399(define loop-lambda-names '())
400(define profile-lambda-list '())
401(define profile-lambda-index 0)
402(define profile-info-vector-name #f)
403(define external-to-pointer '())
404(define error-is-extended-binding #f)
405(define real-name-table #f)
406(define location-pointer-map '())
407(define pending-canonicalizations '())
408(define defconstant-bindings '())
409(define callback-names '())
410(define toplevel-scope #t)
411(define toplevel-lambda-id #f)
412(define custom-declare-alist '())
413(define csc-control-file #f)
414(define data-declarations '())
415(define inline-list '())
416(define not-inline-list '())
417(define file-requirements #f)
418(define postponed-initforms '())
419(define unused-variables '())
420(define compiler-macro-table #f)
421(define compiler-macros-enabled #t)
422
423
424;;; Initialize globals:
425
426(define (initialize-compiler)
427  (if line-number-database-2
428      (vector-fill! line-number-database-2 '())
429      (set! line-number-database-2 (make-vector line-number-database-size '())) )
430  (if inline-table
431      (vector-fill! inline-table '())
432      (set! inline-table (make-vector inline-table-size '())) )
433  (if constant-table
434      (vector-fill! constant-table '())
435      (set! constant-table (make-vector constant-table-size '())) )
436  (set! profile-info-vector-name (make-random-name 'profile-info))
437  (set! real-name-table (make-vector real-name-table-size '()))
438  (set! file-requirements (make-hash-table eq?))
439  (if import-table
440      (vector-fill! import-table '())
441      (set! import-table (make-vector import-table-size '())) )
442  (if foreign-type-table
443      (vector-fill! foreign-type-table '())
444      (set! foreign-type-table (make-vector foreign-type-table-size '())) ) )
445
446
447;;; Expand macros and canonicalize expressions:
448
449(define (canonicalize-expression exp)
450
451  (define (find-id id se)               ; ignores macro bindings
452    (cond ((null? se) #f)
453          ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
454          (else (find-id id (cdr se)))))
455
456  (define (lookup id se)
457    (cond ((find-id id se))
458          ((##sys#get id '##sys#macro-alias))
459          (else id)))
460
461  (define (macro-alias var se)
462    (let ((alias (gensym var)))
463      (##sys#put! alias '##sys#macro-alias (lookup var se))
464      alias) )
465
466  (define (set-real-names! as ns)
467    (for-each (lambda (a n) (set-real-name! a n)) as ns) )
468
469  (define (write-to-string x)
470    (let ([out (open-output-string)])
471      (write x out)
472      (get-output-string out) ) )
473
474  (define (unquotify x se)
475    (if (and (list? x) 
476             (= 2 (length x))
477             (symbol? (car x))
478             (eq? 'quote (lookup (car x) se)))
479        (cadr x)
480        x) )
481
482  (define (resolve-variable x se dest)
483    (cond [(and constants-used (##sys#hash-table-ref constant-table x)) 
484           => (lambda (val) (walk (car val) se dest)) ]
485          [(and inline-table-used (##sys#hash-table-ref inline-table x))
486           => (lambda (val) (walk val se dest)) ]
487          [(assq x foreign-variables)
488           => (lambda (fv) 
489                (let* ([t (second fv)]
490                       [ft (final-foreign-type t)] 
491                       [body `(##core#inline_ref (,(third fv) ,t))] )
492                  (foreign-type-convert-result
493                   (finish-foreign-result ft body)
494                   t) ) ) ]
495          [(assq x location-pointer-map)
496           => (lambda (a)
497                (let* ([t (third a)]
498                       [ft (final-foreign-type t)] 
499                       [body `(##core#inline_loc_ref (,t) ,(second a))] )
500                  (foreign-type-convert-result
501                   (finish-foreign-result ft body)
502                   t) ) ) ]
503          [else
504           (let ((x2 (lookup x se)))
505             (if (symbol? x2)
506                 x2
507                 (##sys#rename-global x se)))]))
508
509  (define (walk x se dest)
510    (cond ((symbol? x)
511           (resolve-variable x se dest))
512          ((not-pair? x)
513           (if (constant? x)
514               `(quote ,x)
515               (syntax-error "illegal atomic form" x)))
516          ((symbol? (car x))
517           (let ([ln (get-line x)])
518             (emit-syntax-trace-info x #f)
519             (unless (proper-list? x)
520               (if ln
521                   (syntax-error (sprintf "(in line ~s) - malformed expression" ln) x)
522                   (syntax-error "malformed expression" x)))
523             (set! ##sys#syntax-error-culprit x)
524             (let ((name (lookup (car x) se))
525                   (xexpanded (##sys#expand x se)))
526               (cond ((not (eq? x xexpanded))
527                      (walk xexpanded se dest))
528                     
529                     [(and inline-table-used (##sys#hash-table-ref inline-table name))
530                      => (lambda (val)
531                           (walk (cons val (cdr x)) se dest)) ]
532                     
533                     [else
534                      (when ln (update-line-number-database! xexpanded ln))
535                      (case name
536                       
537                        ((if)
538                         (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
539                         `(if
540                           ,(walk (cadr x) se #f)
541                           ,(walk (caddr x) se #f)
542                           ,(if (null? (cdddr x)) 
543                                '(##core#undefined)
544                                (walk (cadddr x) se #f) ) ) )
545
546                        ((quote ##core#syntax)
547                         (##sys#check-syntax 'quote x '(_ _) #f se)
548                         `(quote ,(##sys#strip-syntax (cadr x))))
549
550                        ((##core#check)
551                         (if unsafe
552                             ''#t
553                             (walk (cadr x) se dest) ) )
554
555                        ((##core#immutable)
556                         (let ((c (cadadr x)))
557                           (cond [(assoc c immutable-constants) => cdr]
558                                 [else
559                                  (let ([var (gensym 'c)])
560                                    (set! immutable-constants (alist-cons c var immutable-constants))
561                                    (set! always-bound (cons var always-bound))
562                                    (set! block-globals (cons var block-globals))
563                                    var) ] ) ) )
564
565                        ((##core#undefined ##core#callunit ##core#primitive ##core#inline_ref 
566                                           ##core#inline_loc_ref) x)
567
568                        ((##core#require-for-syntax)
569                         (let ([ids (map eval (cdr x))])
570                           (apply ##sys#require ids)
571                           (hash-table-update! 
572                            file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
573                            (lambda () ids) )
574                           '(##core#undefined) ) )
575
576                        ((##core#require-extension)
577                         (walk
578                          (let loop ([ids (cdr x)])
579                            (if (null? ids)
580                                '(##core#undefined)
581                                (let ([id (cadar ids)])
582                                  (let-values ([(exp f) (##sys#do-the-right-thing id #t)])
583                                    (if (not (or f 
584                                                 (and (symbol? id)
585                                                     (or (feature? id)
586                                                         (##sys#find-extension
587                                                          (##sys#canonicalize-extension-path 
588                                                           id 'require-extension) #f)) ) ) )
589                                        (compiler-warning 
590                                         'ext "extension `~A' is currently not installed" id)
591                                        (unless (and-let* (use-import-table
592                                                           ((symbol? id))
593                                                           (info (##sys#extension-information id #f)) 
594                                                           (exps (assq 'exports info)) )
595                                                  (for-each
596                                                   (cut ##sys#hash-table-set! import-table <> id)
597                                                   (cdr exps) )
598                                                  #t)
599                                          (lookup-exports-file id) ) )
600                                    `(begin ,exp ,(loop (cdr ids))) ) ) ) )
601                          se dest) )
602
603                        ((let)
604                         (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f se)
605                         (let* ([bindings (cadr x)]
606                                [vars (unzip1 bindings)]
607                                [aliases (map gensym vars)] 
608                                (se2 (append (map cons vars aliases) se)) )
609                           (set-real-names! aliases vars)
610                           `(let
611                             ,(map (lambda (alias b)
612                                     (list alias (walk (cadr b) se (car b))) )
613                                   aliases bindings)
614                             ,(walk (##sys#canonicalize-body (cddr x) se2)
615                                    se2 dest) ) ) )
616
617                        ((lambda ##core#internal-lambda)
618                         (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
619                         (let ([llist (cadr x)]
620                               [obody (cddr x)] )
621                           (when (##sys#extended-lambda-list? llist)
622                             (set!-values 
623                              (llist obody) 
624                              (##sys#expand-extended-lambda-list 
625                               llist obody ##sys#error se) ) )
626                           (decompose-lambda-list
627                            llist
628                            (lambda (vars argc rest)
629                              (let* ((aliases (map gensym vars))
630                                     (se2 (append (map cons vars aliases) se))
631                                     (body0 (##sys#canonicalize-body obody se2))
632                                     (body (walk body0 se2 #f))
633                                     (llist2 
634                                      (build-lambda-list
635                                       aliases argc
636                                       (and rest (list-ref aliases (posq rest vars))) ) )
637                                     (l `(lambda ,llist2 ,body)) )
638                                (set-real-names! aliases vars)
639                                (cond ((or (not dest) 
640                                           (not (assq dest se))) ; global?
641                                       l)
642                                      ((and emit-profile (eq? 'lambda name))
643                                       (expand-profile-lambda dest llist2 body) )
644                                      (else
645                                       (match body0
646                                         (((? (lambda (s)
647                                                (eq? 'begin (lookup s se))))
648                                           (or (? string? doc)
649                                               ((? (lambda (s) (eq? 'quote (lookup s se))))
650                                                doc)) _ . more)
651                                          (process-lambda-documentation
652                                           dest doc l) )
653                                         (_ l) ) ) ) ) ) ) ) )
654                       
655                        ((let-syntax)
656                         (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
657                         (let ((se2 (append
658                                     (map (lambda (b)
659                                            (list
660                                             (car b)
661                                             se
662                                             (##sys#er-transformer
663                                              ((##sys#compile-to-closure
664                                                (cadr b)
665                                                '() (##sys#current-meta-environment))
666                                               '()) ) ) )
667                                          (cadr x) )
668                                     se) ) )
669                           (walk
670                            (##sys#canonicalize-body (cddr x) se2)
671                            se2
672                            dest) ) )
673                               
674                       ((letrec-syntax)
675                        (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
676                        (let* ((ms (map (lambda (b)
677                                          (list
678                                           (car b)
679                                           #f
680                                           (##sys#er-transformer
681                                            ((##sys#compile-to-closure
682                                              (cadr b)
683                                              '() se)
684                                             '()) ) ) )
685                                        (cadr x) ) )
686                               (se2 (append ms se)) )
687                          (for-each
688                           (lambda (sb)
689                             (set-car! (cdr sb) se2) )
690                           ms)
691                          (walk
692                           (##sys#canonicalize-body (cddr x) se2)
693                           se2 dest)))
694                               
695                        ((##core#named-lambda)
696                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
697
698                        ((##core#loop-lambda)
699                         (let* ([vars (cadr x)]
700                                [obody (cddr x)]
701                                [aliases (map gensym vars)]
702                                (se2 (append (map cons vars aliases) se))
703                                [body 
704                                 (walk 
705                                  (##sys#canonicalize-body obody se2)
706                                  se2 #f) ] )
707                           (set-real-names! aliases vars)
708                           `(lambda ,aliases ,body) ) )
709
710                        ((set! ##core#set!) 
711                         (##sys#check-syntax 'set! x '(_ variable _) #f se)
712                         (let* ([var0 (cadr x)]
713                                [var (lookup var0 se)]
714                                [ln (get-line x)]
715                                [val (walk (caddr x) se var0)] )
716                           (when (eq? var var0) ; global?
717                             (set! var (##sys#rename-global var se))
718                             (when safe-globals-flag
719                               (set! always-bound-to-procedure
720                                 (lset-adjoin eq? always-bound-to-procedure var))
721                               (set! always-bound (lset-adjoin eq? always-bound var)) )
722                             (when (macro? var)
723                               (compiler-warning 
724                                'var "assigned global variable `~S' is a macro ~A"
725                                var
726                                (if ln (sprintf "in line ~S" ln) "") )
727                               (when undefine-shadowed-macros (undefine-macro! var) ) ) )
728                           (when (keyword? var)
729                             (compiler-warning 'syntax "assignment to keyword `~S'" var) )
730                           (when (pair? var) ; macro
731                             (syntax-error
732                              'set! "assignment to syntactic identifier" var))
733                           (cond ((assq var foreign-variables)
734                                   => (lambda (fv)
735                                        (let ([type (second fv)]
736                                              [tmp (gensym)] )
737                                          `(let ([,tmp ,(foreign-type-convert-argument val type)])
738                                             (##core#inline_update 
739                                              (,(third fv) ,type)
740                                              ,(foreign-type-check tmp type) ) ) ) ) )
741                                 ((assq var location-pointer-map)
742                                  => (lambda (a)
743                                       (let* ([type (third a)]
744                                              [tmp (gensym)] )
745                                         `(let ([,tmp ,(foreign-type-convert-argument val type)])
746                                            (##core#inline_loc_update 
747                                             (,type)
748                                             ,(second a)
749                                             ,(foreign-type-check tmp type) ) ) ) ) )
750                                 (else `(set! ,var ,val)))))
751
752                        ((##core#inline)
753                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
754
755                        ((##core#inline_allocate)
756                         `(##core#inline_allocate 
757                           ,(map (cut unquotify <> se) (second x))
758                           ,@(mapwalk (cddr x) se)))
759
760                        ((##core#inline_update)
761                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
762
763                        ((##core#inline_loc_update)
764                         `(##core#inline_loc_update 
765                           ,(cadr x) 
766                           ,(walk (caddr x) se #f)
767                           ,(walk (cadddr x) se #f)) )
768
769                        ((##core#compiletimetoo ##core#elaborationtimetoo)
770                         (let ((exp (cadr x)))
771                           (eval exp)
772                           (walk exp se dest) ) )
773
774                        ((##core#compiletimeonly ##core#elaborationtimeonly)
775                         (eval (cadr x))
776                         '(##core#undefined) )
777
778                        ((begin) 
779                         (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
780                         (if (pair? (cdr x))
781                             (canonicalize-begin-body
782                              (let fold ([xs (cdr x)])
783                                (let ([x (car xs)]
784                                      [r (cdr xs)] )
785                                  (if (null? r)
786                                      (list (walk x se dest))
787                                      (cons (walk x se #f) (fold r)) ) ) ) )
788                             '(##core#undefined) ) )
789
790                        ((##core#foreign-lambda)
791                         (walk (expand-foreign-lambda x) se dest) )
792
793                        ((##core#foreign-callback-lambda)
794                         (walk (expand-foreign-callback-lambda x) se dest) )
795
796                        ((##core#foreign-lambda*)
797                         (walk (expand-foreign-lambda* x) se dest) )
798
799                        ((##core#foreign-callback-lambda*)
800                         (walk (expand-foreign-callback-lambda* x) se dest) )
801
802                        ((##core#foreign-primitive)
803                         (walk (expand-foreign-primitive x) se dest) )
804
805                        ((##core#define-foreign-variable)
806                         (let* ([var (cadr (second x))]
807                                [type (cadr (third x))]
808                                [name (if (pair? (cdddr x))
809                                          (cadr (fourth x))
810                                          (symbol->string var) ) ] )
811                           (set! foreign-variables
812                             (cons (list var type (if (string? name) name (symbol->string name)))
813                                   foreign-variables))
814                           '(##core#undefined) ) )
815
816                        ((##core#define-foreign-type)
817                         (let ([name (cadr (second x))]
818                               [type (cadr (third x))] 
819                               [conv (cdddr x)] )
820                           (cond [(pair? conv)
821                                  (let ([arg (gensym)]
822                                        [ret (gensym)] )
823                                    (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
824                                    (set! always-bound (cons* arg ret always-bound))
825                                    (set! block-globals (cons* arg ret block-globals))
826                                    (walk
827                                     `(,(macro-alias 'begin se)
828                                        (##core#set! ,arg ,(first conv))
829                                        (##core#set!
830                                         ,ret 
831                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) ) 
832                                     se dest) ) ]
833                                 [else
834                                  (##sys#hash-table-set! foreign-type-table name type)
835                                  '(##core#undefined) ] ) ) )
836
837                        ((##core#define-external-variable)
838                         (let* ([sym (cadr (second x))]
839                                [name (symbol->string sym)]
840                                [type (cadr (third x))] 
841                                [exported (cadr (fourth x))]
842                                [rname (make-random-name)] )
843                           (unless exported (set! name (symbol->string (cadr (fifth x)))))
844                           (set! external-variables (cons (vector name type exported) external-variables))
845                           (set! foreign-variables
846                             (cons (list rname 'c-pointer (string-append "&" name))
847                                   foreign-variables) )
848                           (set! external-to-pointer (alist-cons sym rname external-to-pointer))
849                           '(##core#undefined) ) )
850
851                        ((##core#let-location)
852                         (let* ([var (cadr (second x))]
853                                [type (cadr (third x))]
854                                [alias (gensym)]
855                                [store (gensym)] 
856                                [init (and (pair? (cddddr x)) (fourth x))] )
857                           (set-real-name! alias var)
858                           (set! location-pointer-map
859                             (cons (list alias store type) location-pointer-map) )
860                           `(let (,(let ([size (words (estimate-foreign-result-location-size type))])
861                                     ;; Add 2 words: 1 for the header, 1 for double-alignment:
862                                     ;; Note: C_a_i_bytevector takes number of words, not bytes
863                                     (list
864                                      store
865                                      `(##core#inline_allocate
866                                        ("C_a_i_bytevector" ,(+ 2 size))
867                                        ',size)) ) )
868                              ,(walk
869                                `(,(macro-alias 'begin se)
870                                   ,@(if init
871                                         `((##core#set! ,alias ,init))
872                                         '() )
873                                   ,(,(macro-alias 'if se) init (fifth x) (fourth x)) )
874                                (alist-cons var alias se)
875                                dest) ) ) )
876
877                        ((##core#define-inline)
878                         (let* ([name (cadr (second x))]
879                                [val (third x)] )
880                           (receive (val2 mlist)
881                               (extract-mutable-constants
882                                (walk (cons '##core#internal-lambda (cdr val)) se name) )
883                             (##sys#hash-table-set! inline-table name val2)
884                             (set! always-bound (append (unzip1 mlist) always-bound))
885                             (set! inline-table-used #t)
886                             (walk
887                              `(,(macro-alias 'begin se)
888                                ,@(map (lambda (m)
889                                         `(##core#set! ,(car m) ',(cdr m))) mlist))
890                              se #f) ) ) )
891
892                        ((##core#define-constant)
893                         (let* ([name (cadr (second x))]
894                                [valexp (third x)]
895                                [val (handle-exceptions ex
896                                         ;; could show line number here
897                                         (quit "error in constant evaluation of ~S for named constant ~S" 
898                                               valexp name)
899                                       (if (collapsable-literal? valexp)
900                                           valexp
901                                           (eval
902                                            `(,(macro-alias 'let se)
903                                              ,defconstant-bindings ,valexp)) ) ) ] )
904                           (set! constants-used #t)
905                           (set! defconstant-bindings (cons (list name `',val) defconstant-bindings))
906                           (cond [(collapsable-literal? val)
907                                  (##sys#hash-table-set! constant-table name (list val))
908                                  '(##core#undefined) ]
909                                 [else
910                                  (let ([var (gensym "constant")])
911                                    (##sys#hash-table-set! constant-table name (list var))
912                                    (set! mutable-constants (alist-cons var val mutable-constants))
913                                    (set! block-globals (cons var block-globals))
914                                    (set! always-bound (cons var always-bound))
915                                    (walk `(##core#set! ,var ',val) se #f) ) ] ) ) )
916
917                        ((##core#declare)
918                         (walk
919                          `(,(macro-alias 'begin se)
920                             ,@(map (lambda (d)
921                                      (process-declaration 
922                                       (##sys#strip-syntax (second d))
923                                       se))
924                                    (cdr x) ) )
925                          '() #f) )
926             
927                        ((##core#foreign-callback-wrapper)
928                         (let-values ([(args lam) (split-at (cdr x) 4)])
929                           (let* ([lam (car lam)]
930                                  [name (first args)]
931                                  [rtype (cadr (third args))]
932                                  [atypes (cadr (fourth args))]
933                                  [vars (second lam)] )
934                             (let ([name (cadr name)])
935                               (if (valid-c-identifier? name)
936                                   (set! callback-names (cons name callback-names))
937                                   (quit "name `~S' of external definition is not a valid C identifier"
938                                         name) ) )
939                             (when (or (not (proper-list? vars)) 
940                                       (not (proper-list? atypes))
941                                       (not (= (length vars) (length atypes))) )
942                               (syntax-error 
943                                "non-matching or invalid argument list to foreign callback-wrapper"
944                                vars atypes) )
945                             `(##core#foreign-callback-wrapper
946                               ,@(mapwalk args se)
947                               ,(walk `(##core#internal-lambda 
948                                        ,vars
949                                        (,(macro-alias 'let se)
950                                         ,(let loop ([vars vars] [types atypes])
951                                            (if (null? vars)
952                                                '()
953                                                (let ([var (car vars)]
954                                                      [type (car types)] )
955                                                  (cons
956                                                   (list
957                                                    var
958                                                    (foreign-type-convert-result
959                                                     (finish-foreign-result (final-foreign-type type) var)
960                                                     type) )
961                                                   (loop (cdr vars) (cdr types)) ) ) ) )
962                                         ,(foreign-type-convert-argument
963                                           `(,(macro-alias 'let se)
964                                             ()
965                                               ,@(match rtype
966                                                   ((or '(const nonnull-c-string) 
967                                                        '(const nonnull-unsigned-c-string)
968                                                        'nonnull-unsigned-c-string
969                                                        'nonnull-c-string)
970                                                    `((##sys#make-c-string
971                                                       (,(macro-alias 'let se)
972                                                        () ,@(cddr lam)))))
973                                                   ((or '(const c-string*)
974                                                        '(const unsigned-c-string*)
975                                                        'unsigned-c-string*
976                                                        'c-string*
977                                                        'c-string-list
978                                                        'c-string-list*)
979                                                    (syntax-error
980                                                     "not a valid result type for callback procedures"
981                                                     rtype
982                                                     name) )
983                                                   ((or 'c-string
984                                                        '(const unsigned-c-string)
985                                                        'unsigned-c-string
986                                                        '(const c-string))
987                                                    `((,(macro-alias 'let se)
988                                                       ((r (,(macro-alias 'let se)
989                                                            () ,@(cddr lam))))
990                                                       (,(macro-alias 'and se)
991                                                        r 
992                                                        (##sys#make-c-string r)) ) ) )
993                                                   (_ (cddr lam)) ) )
994                                           rtype) ) )
995                                      se #f) ) ) ) )
996
997                        (else
998                         (let ([handle-call
999                                (lambda ()
1000                                  (let* ([x2 (mapwalk x se)]
1001                                         [head2 (car x2)]
1002                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
1003                                    (when ln
1004                                      (##sys#hash-table-set!
1005                                       line-number-database-2
1006                                       head2
1007                                       (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
1008                                    x2) ) ] )
1009
1010                           (cond [(eq? 'location name)
1011                                  (##sys#check-syntax 'location x '(location _) #f se)
1012                                  (let ([sym (cadr x)])
1013                                    (if (symbol? sym)
1014                                        (cond [(assq (lookup sym se) location-pointer-map)
1015                                               => (lambda (a)
1016                                                    (walk
1017                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
1018                                                     se #f) ) ]
1019                                              [(assq sym external-to-pointer) 
1020                                               => (lambda (a) (walk (cdr a) se #f)) ]
1021                                              [(memq sym callback-names)
1022                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
1023                                              [else
1024                                               (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
1025                                        (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
1026                                 
1027                                 ((and compiler-macros-enabled
1028                                       compiler-macro-table
1029                                       (##sys#hash-table-ref compiler-macro-table name)) =>
1030                                  (lambda (cm)
1031                                    (let ((cx (cm x)))
1032                                      (if (equal? cx x)
1033                                          (handle-call)
1034                                          (walk cx se dest)))))
1035                                 
1036                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
1037
1038          ((not (proper-list? x))
1039           (syntax-error "malformed expression" x) )
1040
1041          ((constant? (car x))
1042           (emit-syntax-trace-info x #f)
1043           (compiler-warning 'syntax "literal in operator position: ~S" x) 
1044           (mapwalk x se) )
1045
1046          ((and (pair? (car x)) (eq? 'lambda (caar x)))
1047           (let ([lexp (car x)]
1048                 [args (cdr x)] )
1049             (emit-syntax-trace-info x #f)
1050             (##sys#check-syntax 'lambda lexp '(lambda lambda-list . #(_ 1)) #f se)
1051             (let ([llist (cadr lexp)])
1052               (if (and (proper-list? llist) (= (length llist) (length args)))
1053                   (walk `(,(macro-alias 'let se)
1054                           ,(map list llist args) ,@(cddr lexp)) se dest)
1055                   (let ((var (gensym 't)))
1056                     (walk
1057                      `(,(macro-alias 'let se)
1058                        ((,var ,(car x)))
1059                        (,var ,@(cdr x)) )
1060                      se dest) ) ) ) ) )
1061         
1062          (else
1063           (emit-syntax-trace-info x #f)
1064           (mapwalk x se)) ) )
1065 
1066  (define (mapwalk xs se)
1067    (map (lambda (x) (walk x se #f)) xs) )
1068
1069  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
1070  (##sys#clear-trace-buffer)
1071  ;; Process visited definitions and main expression:
1072  (walk 
1073   `(,(macro-alias 'begin '())
1074      ,@(let ([p (reverse pending-canonicalizations)])
1075          (set! pending-canonicalizations '())
1076          p)
1077      ,(let ([exp (##sys#compiler-toplevel-macroexpand-hook exp)])
1078         (set! extended-bindings (append internal-bindings extended-bindings))
1079         exp) )
1080   '() #f) )
1081
1082
1083(define (process-declaration spec se)   ; se unused in the moment
1084  (define (check-decl spec minlen . maxlen)
1085    (let ([n (length (cdr spec))])
1086      (if (or (< n minlen) (> n (optional maxlen 99999)))
1087          (syntax-error "invalid declaration" spec) ) ) ) 
1088  (call-with-current-continuation
1089   (lambda (return)
1090     (unless (pair? spec)
1091       (syntax-error "invalid declaration specification" spec) )
1092     (case (car spec)
1093       ((uses)
1094        (let ((us (cdr spec)))
1095          (apply register-feature! us)
1096          (when use-import-table
1097            (for-each lookup-exports-file us) )
1098          (when (pair? us)
1099            (hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
1100            (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
1101              (set! used-units (append used-units units)) ) ) ) )
1102       ((unit)
1103        (check-decl spec 1 1)
1104        (let* ([u (cadr spec)]
1105               [un (string->c-identifier (stringify u))] )
1106          (hash-table-set! file-requirements 'unit u)
1107          (when (and unit-name (not (string=? unit-name un)))
1108            (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
1109          (set! unit-name un) ) )
1110       ((standard-bindings)
1111        (if (null? (cdr spec))
1112            (set! standard-bindings default-standard-bindings)
1113            (set! standard-bindings (append (cdr spec) standard-bindings)) ) )
1114       ((extended-bindings)
1115        (if (null? (cdr spec))
1116            (set! extended-bindings default-extended-bindings)
1117            (set! extended-bindings (append (cdr spec) extended-bindings)) ) )
1118       ((usual-integrations)     
1119        (cond [(null? (cdr spec))
1120               (set! standard-bindings default-standard-bindings)
1121               (set! extended-bindings default-extended-bindings) ]
1122              [else
1123               (let ([syms (cdr spec)])
1124                 (set! standard-bindings (lset-intersection eq? syms default-standard-bindings))
1125                 (set! extended-bindings (lset-intersection eq? syms default-extended-bindings)) ) ] ) )
1126       ((number-type)
1127        (check-decl spec 1 1)
1128        (set! number-type (cadr spec)))
1129       ((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
1130       ((generic) (set! number-type 'generic))
1131       ((unsafe)
1132        (set! unsafe #t)
1133        (##match#set-error-control #:unspecified) )
1134       ((safe) (set! unsafe #f))
1135       ((no-bound-checks) (set! no-bound-checks #t))
1136       ((no-argc-checks) (set! no-argc-checks #t))
1137       ((no-procedure-checks) (set! no-procedure-checks #t))
1138       ((interrupts-enabled) (set! insert-timer-checks #t))
1139       ((disable-interrupts) (set! insert-timer-checks #f))
1140       ((disable-warning)
1141        (set! disabled-warnings
1142          (append (cdr spec) disabled-warnings)))
1143       ((always-bound) 
1144        (set! always-bound (append (cdr spec) always-bound)))
1145       ((safe-globals) (set! safe-globals-flag #t))
1146       ((no-procedure-checks-for-usual-bindings)
1147        (set! always-bound-to-procedure
1148          (append default-standard-bindings default-extended-bindings always-bound-to-procedure))
1149        (set! always-bound
1150          (append default-standard-bindings default-extended-bindings always-bound)) )
1151       ((bound-to-procedure)
1152        (let ((vars (cdr spec)))
1153          (set! always-bound-to-procedure (append vars always-bound-to-procedure))
1154          (set! always-bound (append vars always-bound)) ) )
1155       ((foreign-declare)
1156        (let ([fds (cdr spec)])
1157          (if (every string? fds)
1158              (set! foreign-declarations (append foreign-declarations fds))
1159              (syntax-error "invalid declaration" spec) ) ) )
1160       ((custom-declare)
1161        (if (or (not (list? spec)) (not (list? (cadr spec))) (< (length (cadr spec)) 3))
1162            (syntax-error "invalid declaration" spec)
1163            (process-custom-declaration (cadr spec) (cddr spec)) ) )
1164       ((c-options)
1165        (emit-control-file-item `(c-options ,@(cdr spec))) )
1166       ((link-options)
1167        (emit-control-file-item `(link-options ,@(cdr spec))) )
1168       ((post-process)
1169        (emit-control-file-item
1170         (let ([file (pathname-strip-extension source-filename)])
1171           `(post-process ,@(map (cut string-substitute "\\$@" file <>) (cdr spec))) ) ) )
1172       ((block) (set! block-compilation #t))
1173       ((separate) (set! block-compilation #f))
1174       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
1175       ((unused)
1176        (set! unused-variables (append (cdr spec) unused-variables)))
1177       ((not)
1178        (check-decl spec 1)
1179        (case (second spec)
1180          [(standard-bindings)
1181           (if (null? (cddr spec))
1182               (set! standard-bindings '())
1183               (set! standard-bindings
1184                 (lset-difference eq? default-standard-bindings
1185                                  (cddr spec)))) ]
1186          [(extended-bindings)
1187           (if (null? (cddr spec))
1188               (set! extended-bindings '())
1189               (set! extended-bindings 
1190                 (lset-difference eq? default-extended-bindings
1191                                  (cddr spec)) )) ]
1192          [(inline)
1193           (if (null? (cddr spec))
1194               (set! inline-max-size -1)
1195               (set! not-inline-list (lset-union eq? not-inline-list
1196                                                 (cddr spec))) ) ]
1197          [(usual-integrations)     
1198           (cond [(null? (cddr spec))
1199                  (set! standard-bindings '())
1200                  (set! extended-bindings '()) ]
1201                 [else
1202                  (let ([syms (cddr spec)])
1203                    (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
1204                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
1205          [else
1206           (check-decl spec 1 1)
1207           (let ((id (cadr spec)))
1208             (case id
1209               [(interrupts-enabled) (set! insert-timer-checks #f)]
1210               [(safe) 
1211                (set! unsafe #t)
1212                (##match#set-error-control #:unspecified) ]
1213               [else (compiler-warning 'syntax "illegal declaration specifier `~s'" id)]))]))
1214       ((run-time-macros) (set! ##sys#enable-runtime-macros #t))
1215       ((block-global hide) 
1216        (let ([syms (cdr spec)])
1217          (when export-list 
1218            (set! export-list (lset-difference eq? export-list syms)) )
1219          (set! block-globals (lset-union eq? syms block-globals)) ) )
1220       ((export) 
1221        (let ((syms (cdr spec)))
1222          (set! block-globals (lset-difference eq? block-globals syms))
1223          (set! export-list (lset-union eq? syms (or export-list '())))))
1224       ((emit-exports)
1225        (cond ((null? (cdr spec))
1226               (quit "invalid `emit-exports' declaration" spec) )
1227              ((not export-file-name) 
1228               (set! export-file-name (cadr spec))) ) )
1229       ((emit-external-prototypes-first)
1230        (set! external-protos-first #t) )
1231       ((lambda-lift) (set! do-lambda-lifting #t))
1232       ((inline)
1233        (if (null? (cdr spec))
1234            (unless (> inline-max-size -1)
1235              (set! inline-max-size default-inline-max-size) )
1236            (set! inline-list (lset-union eq? inline-list (cdr spec)))) ) 
1237       ((inline-limit)
1238        (check-decl spec 1 1)
1239        (set! inline-max-size
1240          (let ([n (cadr spec)])
1241            (if (number? n)
1242                n
1243                (quit "invalid argument to `inline-limit' declaration" spec) ) ) ) )
1244       ((constant)
1245        (let ((syms (cdr spec)))
1246          (if (every symbol? syms)
1247              (set! constant-declarations (append syms constant-declarations))
1248              (quit "invalid arguments to `constant' declaration: ~S" spec)) ) )
1249       ((import)
1250        (let-values (((syms strs) 
1251                      (partition
1252                       (lambda (x)
1253                         (cond ((symbol? x) #t)
1254                               ((string? x) #f)
1255                               (else (quit "argument to `import' declaration is not a string or symbol" x)) ) )
1256                       (cdr spec) ) ) )
1257          (set! use-import-table #t)
1258          (for-each
1259           (cut ##sys#hash-table-set! import-table <> "<here>") 
1260           syms)
1261          (for-each lookup-exports-file strs) ) )
1262       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
1263     '(##core#undefined) ) ) )
1264
1265
1266;;; Expand "foreign-lambda"/"foreign-callback-lambda" forms and add item to stub-list:
1267
1268(define-record-type foreign-stub
1269  (make-foreign-stub id return-type name argument-types argument-names body cps callback)
1270  foreign-stub?
1271  (id foreign-stub-id)                  ; symbol
1272  (return-type foreign-stub-return-type)          ; type-specifier
1273  (name foreign-stub-name)                        ; string or #f
1274  (argument-types foreign-stub-argument-types) ; (type-specifier...)
1275  (argument-names foreign-stub-argument-names) ; #f or (symbol ...)
1276  (body foreign-stub-body)                     ; #f or string
1277  (cps foreign-stub-cps)                       ; boolean
1278  (callback foreign-stub-callback))            ; boolean
1279
1280(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
1281  (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
1282         [f-id (gensym 'stub)]
1283         [bufvar (gensym)] 
1284         [rsize (estimate-foreign-result-size rtype)] )
1285    (set-real-name! f-id #t)
1286    (set! foreign-lambda-stubs 
1287      (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
1288            foreign-lambda-stubs) )
1289    (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
1290          [head (if cps
1291                    `((##core#primitive ,f-id))
1292                    `(##core#inline ,f-id) ) ]
1293          [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
1294      `(lambda ,params
1295         ;; Do minor GC (if callback) to make room on stack:
1296         ,@(if callback '((##sys#gc #f)) '())
1297         ,(if (zero? rsize) 
1298              (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
1299              (let ([ft (final-foreign-type rtype)]
1300                    [ws (words rsize)] )
1301                `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)])
1302                   ,(foreign-type-convert-result
1303                     (finish-foreign-result ft (append head (cons bufvar rest)))
1304                     rtype) ) ) ) ) ) ) )
1305
1306(define (expand-foreign-lambda exp)
1307  (let* ([name (cadr (third exp))]
1308         [sname (cond ((symbol? name) (symbol->string name))
1309                      ((string? name) name)
1310                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
1311         [rtype (cadr (second exp))]
1312         [argtypes (map second (cdddr exp))] )
1313    (create-foreign-stub rtype sname argtypes #f #f #f #f) ) )
1314
1315(define (expand-foreign-callback-lambda exp)
1316  (let* ([name (cadr (third exp))]
1317         [sname (cond ((symbol? name) (symbol->string name))
1318                      ((string? name) name)
1319                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
1320         [rtype (cadr (second exp))]
1321         [argtypes (map second (cdddr exp))] )
1322    (create-foreign-stub rtype sname argtypes #f #f #t #t) ) )
1323
1324(define (expand-foreign-lambda* exp)
1325  (let* ([rtype (cadr (second exp))]
1326         [args (cadr (third exp))]
1327         [body (apply string-append (map cadr (cdddr exp)))]
1328         [argtypes (map car args)]
1329         [argnames (map cadr args)] )
1330    (create-foreign-stub rtype #f argtypes argnames body #f #f) ) )
1331
1332(define (expand-foreign-callback-lambda* exp)
1333  (let* ([rtype (cadr (second exp))]
1334         [args (cadr (third exp))]
1335         [body (apply string-append (map cadr (cdddr exp)))]
1336         [argtypes (map car args)]
1337         [argnames (map cadr args)] )
1338    (create-foreign-stub rtype #f argtypes argnames body #t #t) ) )
1339
1340(define (expand-foreign-primitive exp)
1341  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (cadr (caddr exp)))))]
1342         [rtype (if hasrtype (cadr (second exp)) 'void)]
1343         [args (if hasrtype (cadr (third exp)) (cadr (second exp)))]
1344         [body (apply string-append (map cadr (if hasrtype (cdddr exp) (cddr exp))))]
1345         [argtypes (map car args)]
1346         [argnames (map cadr args)] )
1347    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
1348
1349
1350;;; Traverse expression and update line-number db with all contained calls:
1351
1352(define (update-line-number-database! exp ln)
1353  (define (mapupdate xs)
1354    (let loop ((xs xs))
1355      (if (pair? xs)
1356          (begin
1357            (walk (car xs))
1358            (loop (cdr xs)) ) ) ) )
1359  (define (walk x)
1360    (cond ((not-pair? x))
1361          ((symbol? (car x))
1362           (let* ((name (car x))
1363                  (old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) )
1364             (if (not (assq x old))
1365                 (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) )
1366             (mapupdate (cdr x)) ) )
1367          (else (mapupdate x)) ) )
1368  (walk exp) )
1369
1370
1371;;; Convert canonicalized node-graph into continuation-passing-style:
1372
1373(define (perform-cps-conversion node)
1374
1375  (define (cps-lambda id llist subs k)
1376    (let ([t1 (gensym 'k)])
1377      (k (make-node
1378          '##core#lambda (list id #t (cons t1 llist) 0)
1379          (list (walk (car subs)
1380                      (lambda (r) 
1381                        (make-node '##core#call '(#t) (list (varnode t1) r)) ) ) ) ) ) ) )
1382 
1383  (define (walk n k)
1384    (let ((subs (node-subexpressions n))
1385          (params (node-parameters n)) 
1386          (class (node-class n)) )
1387      (case (node-class n)
1388        ((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n))
1389        ((if) (let* ((t1 (gensym 'k))
1390                     (t2 (gensym 'r))
1391                     (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
1392                (make-node 'let
1393                           (list t1)
1394                           (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0) 
1395                                            (list (k (varnode t2))) )
1396                                 (walk (car subs)
1397                                       (lambda (v)
1398                                         (make-node 'if '()
1399                                                    (list v
1400                                                          (walk (cadr subs) k1)
1401                                                          (walk (caddr subs) k1) ) ) ) ) ) ) ) )
1402        ((let) (let loop ((vars params) (vals subs))
1403                 (if (null? vars)
1404                     (walk (car vals) k)
1405                     (walk (car vals)
1406                           (lambda (r) 
1407                             (make-node 'let
1408                                        (list (car vars))
1409                                        (list r (loop (cdr vars) (cdr vals))) ) ) ) ) ) )
1410        ((lambda) (cps-lambda (gensym-f-id) (first params) subs k))
1411        ((set!) (let ((t1 (gensym 't)))
1412                  (walk (car subs)
1413                        (lambda (r)
1414                          (make-node 'let (list t1)
1415                                     (list (make-node 'set! (list (first params)) (list r))
1416                                           (k (varnode t1)) ) ) ) ) ) )
1417        ((##core#foreign-callback-wrapper)
1418         (let ([id (gensym-f-id)]
1419               [lam (first subs)] )
1420           (set! foreign-callback-stubs
1421             (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
1422           (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
1423        ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref 
1424                        ##core#inline_loc_update)
1425         (walk-inline-call class params subs k) )
1426        ((##core#call) (walk-call (car subs) (cdr subs) params k))
1427        ((##core#callunit) (walk-call-unit (first params) k))
1428        (else (bomb "bad node (cps)")) ) ) )
1429 
1430  (define (walk-call fn args params k)
1431    (let ((t0 (gensym 'k))
1432          (t3 (gensym 'r)) )
1433      (make-node
1434       'let (list t0)
1435       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) 
1436                        (list (k (varnode t3))) )
1437             (walk-arguments
1438              args
1439              (lambda (vars)
1440                (walk fn
1441                      (lambda (r) 
1442                        (make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
1443 
1444  (define (walk-call-unit unitname k)
1445    (let ((t0 (gensym 'k))
1446          (t3 (gensym 'r)) )
1447      (make-node
1448       'let (list t0)
1449       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) 
1450                        (list (k (varnode t3))) )
1451             (make-node '##core#callunit (list unitname)
1452                        (list (varnode t0)) ) ) ) ) )
1453
1454  (define (walk-inline-call class op args k)
1455    (walk-arguments
1456     args
1457     (lambda (vars)
1458       (k (make-node class op vars)) ) ) )
1459 
1460  (define (walk-arguments args wk)
1461    (let loop ((args args) (vars '()))
1462      (cond ((null? args) (wk (reverse vars)))
1463            ((atomic? (car args))
1464             (loop (cdr args) (cons (car args) vars)) )
1465            (else
1466             (let ((t1 (gensym 'a)))
1467               (walk (car args)
1468                     (lambda (r)
1469                       (make-node 'let (list t1)
1470                                  (list r
1471                                        (loop (cdr args) 
1472                                              (cons (varnode t1) vars) ) ) ) ) ) ) ) ) ) )
1473 
1474  (define (atomic? n)
1475    (let ((class (node-class n)))
1476      (or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref))
1477          (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update
1478                                           ##core#inline_loc_ref ##core#inline_loc_update))
1479               (every atomic? (node-subexpressions n)) ) ) ) )
1480 
1481  (walk node values) )
1482
1483
1484;;; Foreign callback stub type:
1485
1486(define-record-type foreign-callback-stub
1487  (make-foreign-callback-stub id name qualifiers return-type argument-types)
1488  foreign-callback-stub?
1489  (id foreign-callback-stub-id)         ; symbol
1490  (name foreign-callback-stub-name)     ; string
1491  (qualifiers foreign-callback-stub-qualifiers) ; string
1492  (return-type foreign-callback-stub-return-type) ; type-specifier
1493  (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)
1494
1495
1496;;; Perform source-code analysis:
1497
1498(define (analyze-expression node)
1499  (let ([db (make-vector analysis-database-size '())]
1500        [explicitly-consed '()] )
1501
1502    (define (grow n)
1503      (set! current-program-size (+ current-program-size n)) )
1504
1505    (define (walk n env localenv here call)
1506      (let ((subs (node-subexpressions n))
1507            (params (node-parameters n)) 
1508            (class (node-class n)) )
1509        (grow 1)
1510        (case class
1511          ((quote ##core#undefined ##core#proc) #f)
1512
1513          ((##core#variable)
1514           (let ((var (first params)))
1515             (ref var n)
1516             (unless (memq var localenv)
1517               (grow 1)
1518               (cond ((memq var env) (put! db var 'captured #t))
1519                     ((not (get db var 'global)) (put! db var 'global #t) ) ) ) ) )
1520         
1521          ((##core#global-ref)
1522           (let ((var (first params)))
1523             (ref var n)
1524             (grow 1)
1525             (put! db var 'global #t) ) )
1526         
1527          ((##core#callunit ##core#recurse)
1528           (grow 1)
1529           (walkeach subs env localenv here #f) )
1530
1531          ((##core#call)
1532           (grow 1)
1533           (let ([fun (car subs)])
1534             (if (eq? '##core#variable (node-class fun))
1535                 (let ([name (first (node-parameters fun))])
1536                   (collect! db name 'call-sites (cons here n))
1537                   ;; If call to standard-binding & optimizable rest-arg operator: decrease access count:
1538                   (if (and (get db name 'standard-binding)
1539                            (memq name optimizable-rest-argument-operators) )
1540                       (for-each
1541                        (lambda (arg)
1542                          (and-let* ([(eq? '##core#variable (node-class arg))]
1543                                     [var (first (node-parameters arg))] )
1544                            (when (get db var 'rest-parameter) (count! db var 'o-r/access-count)) ) )
1545                        (cdr subs) ) ) ) )
1546             (walk (first subs) env localenv here #t)
1547             (walkeach (cdr subs) env localenv here #f) ) )
1548
1549          ((let)
1550           (let ([env2 (append params localenv env)])
1551             (let loop ([vars params] [vals subs])
1552               (if (null? vars)
1553                   (walk (car vals) env (append params localenv) here #f)
1554                   (let ([var (car vars)]
1555                         [val (car vals)] )
1556                     (put! db var 'home here)
1557                     (assign var val env2 here)
1558                     (walk val env localenv here #f) 
1559                     (loop (cdr vars) (cdr vals)) ) ) ) ) )
1560
1561          ((lambda)                     ; will this actually be ever used? aren't all lambdas now ##core#lambdas?
1562           (grow 1)
1563           (decompose-lambda-list
1564            (first params)
1565            (lambda (vars argc rest)
1566              (for-each
1567               (lambda (var) (put! db var 'unknown #t))
1568               vars)
1569              (let ([tl toplevel-scope])
1570                (set! toplevel-scope #f)
1571                (walk (car subs) (append localenv env) vars #f #f)
1572                (set! toplevel-scope tl) ) ) ) )
1573
1574          ((##core#lambda ##core#direct_lambda)
1575           (grow 1)
1576           (decompose-lambda-list
1577            (third params)
1578            (lambda (vars argc rest)
1579              (let ([id (first params)]
1580                    [size0 current-program-size] )
1581                (when here
1582                  (collect! db here 'contains id)
1583                  (put! db id 'contained-in here) )
1584                (for-each
1585                 (lambda (var)
1586                   (put! db var 'home here)
1587                   (put! db var 'unknown #t) )
1588                 vars)
1589                (when rest
1590                  (put! db rest 'rest-parameter
1591                        (if (memq rest rest-parameters-promoted-to-vector)
1592                            'vector
1593                            'list) ) )
1594                (when (simple-lambda-node? n) (put! db id 'simple #t))
1595                (let ([tl toplevel-scope])
1596                  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
1597                  (when (and (second params) (not (eq? toplevel-lambda-id id)))
1598                    (set! toplevel-scope #f)) ; only if non-CPS lambda
1599                  (walk (car subs) (append localenv env) vars id #f)
1600                  (set! toplevel-scope tl)
1601                  (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
1602         
1603          ((set!) 
1604           (let* ([var (first params)]
1605                  [val (car subs)] )
1606             (when first-analysis 
1607               (cond [(get db var 'standard-binding)
1608                      (compiler-warning 'redef "redefinition of standard binding `~S'" var) ]
1609                     [(get db var 'extended-binding)
1610                      (compiler-warning 'redef "redefinition of extended binding `~S'" var) ] )
1611               (put! db var 'potential-value val) )
1612             (when (and (not (memq var localenv)) 
1613                        (not (memq var env)) )
1614               (grow 1)
1615               (when first-analysis
1616                 (when (or block-compilation (and export-list (not (memq var export-list))))
1617                   (set! block-globals (lset-adjoin eq? block-globals var)) ) )
1618               (put! db var 'global #t) )
1619             (assign var val (append localenv env) here)
1620             (unless toplevel-scope (put! db var 'assigned-locally #t))
1621             (put! db var 'assigned #t)
1622             (walk (car subs) env localenv here #f) ) )
1623
1624          ((##core#primitive ##core#inline)
1625           (let ([id (first params)])
1626             (when (and first-analysis here (symbol? id) (##sys#hash-table-ref real-name-table id))
1627               (set-real-name! id here) )
1628             (walkeach subs env localenv here #f) ) )
1629
1630          (else (walkeach subs env localenv here #f)) ) ) )
1631
1632    (define (walkeach xs env lenv here call) 
1633      (for-each (lambda (x) (walk x env lenv here call)) xs) )
1634
1635    (define (assign var val env here)
1636      (cond ((eq? '##core#undefined (node-class val))
1637             (put! db var 'undefined #t) )
1638            ((and (eq? '##core#variable (node-class val))
1639                  (eq? var (first (node-parameters val))) ) )
1640            ((or block-compilation
1641                 (memq var env)
1642                 (get db var 'constant)
1643                 ;;(memq var inline-list)       - would be nice, but might be customized...
1644                 (memq var block-globals) )
1645             (let ((props (get-all db var 'unknown 'value))
1646                   (home (get db var 'home)) )
1647               (unless (assq 'unknown props)
1648                 (if (assq 'value props)
1649                     (put! db var 'unknown #t)
1650                     (if (or (not home) (eq? here home))
1651                         (put! db var 'value val)
1652                         (put! db var 'unknown #t) ) ) ) ) )
1653            (else (put! db var 'unknown #t)) ) )
1654   
1655    (define (ref var node)
1656      (collect! db var 'references node) )
1657
1658    (define (quick-put! plist prop val)
1659      (set-cdr! plist (alist-cons prop val (cdr plist))) )
1660
1661    ;; Return true if <id> directly or indirectly contains any of <other-ids>:
1662    (define (contains? id other-ids)
1663      (or (memq id other-ids)
1664          (let ((clist (get db id 'contains)))
1665            (and clist
1666                 (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) )
1667
1668    ;; Initialize database:
1669    (initialize-analysis-database db)
1670
1671    ;; Walk toplevel expression-node:
1672    (debugging 'p "analysis traversal phase...")
1673    (set! current-program-size 0)
1674    (walk node '() '() #f #f) 
1675
1676    ;; Complete gathered database information:
1677    (debugging 'p "analysis gathering phase...")
1678    (##sys#hash-table-for-each
1679     (lambda (sym plist)
1680       (let ([unknown #f]
1681             [value #f]
1682             [pvalue #f]
1683             [references '()]
1684             [captured #f]
1685             [call-sites '()]
1686             [assigned #f]
1687             [assigned-locally #f]
1688             [undefined #f]
1689             [global #f]
1690             [o-r/access-count 0]
1691             [rest-parameter #f] 
1692             [nreferences 0]
1693             [ncall-sites 0] )
1694
1695         (for-each
1696          (lambda (prop)
1697            (case (car prop)
1698              [(unknown) (set! unknown #t)]
1699              [(references) 
1700               (set! references (cdr prop))
1701               (set! nreferences (length references)) ]
1702              [(captured) (set! captured #t)]
1703              [(potential-value) (set! pvalue (cdr prop))]
1704              [(call-sites)
1705               (set! call-sites (cdr prop))
1706               (set! ncall-sites (length call-sites)) ]
1707              [(assigned) (set! assigned #t)]
1708              [(assigned-locally) (set! assigned-locally #t)]
1709              [(undefined) (set! undefined #t)]
1710              [(global) (set! global #t)]
1711              [(value) (set! value (cdr prop))]
1712              [(o-r/access-count) (set! o-r/access-count (cdr prop))]
1713              [(rest-parameter) (set! rest-parameter #t)] ) )
1714          plist)
1715
1716         (set! value (and (not unknown) value))
1717
1718         ;; If this is the first analysis, register known local or potentially known global lambda-value id's
1719         ;;  along with their names:
1720         (when (and first-analysis 
1721                    (eq? '##core#lambda
1722                         (and-let* ([val (or value (and global pvalue))])
1723                           (node-class val) ) ) )
1724           (set-real-name! (first (node-parameters (or value pvalue))) sym) )
1725
1726         ;; If this is the first analysis and the variable is global and has no references and we are
1727         ;;  in block mode, then issue warning:
1728         (when (and first-analysis 
1729                    global
1730                    (null? references)
1731                    (not (memq sym unused-variables)))
1732           (when assigned-locally
1733             (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )
1734           (when (and (or block-compilation
1735                          (and export-list (not (memq sym export-list))) )
1736                      (not (assq sym mutable-constants)) )
1737             (compiler-warning 'var "global variable `~S' is never used" sym) ) )
1738
1739         ;; Make 'boxed, if 'assigned & 'captured:
1740         (when (and assigned captured)
1741           (quick-put! plist 'boxed #t) )
1742
1743         ;; Make 'contractable, if it has a procedure as known value, has only one use and one call-site and
1744         ;;  if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
1745         ;;  use/call count is not 1:
1746         (when value
1747           (let ((valparams (node-parameters value)))
1748             (when (and (eq? '##core#lambda (node-class value))
1749                        (or (not (second valparams))
1750                            (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) )
1751               (if (and (= 1 nreferences) (= 1 ncall-sites))
1752                   (quick-put! plist 'contractable #t)
1753                   (quick-put! plist 'inlinable #t) ) ) ) )
1754
1755         ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only
1756         ;;  referenced once and if no assignments are made:
1757         (when (and value
1758                    ;; (not (assq 'assigned plist)) - If it has a known value, it's assigned just once!
1759                    (eq? 'quote (node-class value)) )
1760           (let ((val (first (node-parameters value))))
1761             (when (or (collapsable-literal? val)
1762                       (= 1 nreferences) )
1763               (quick-put! plist 'collapsable #t) ) ) )
1764               
1765         ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the
1766         ;;  number of references (does not escape), then make all formal parameters 'unused which are
1767         ;;  never referenced or assigned (if no rest parameter exist):
1768         ;;  - also marks the procedure as 'has-unused-parameters (if not in `callback-names')
1769         ;;  - if the procedure is internal (a continuation) do NOT mark unused parameters.
1770         ;;  - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
1771         (when value
1772           (let ([has #f])
1773             (when (and (eq? '##core#lambda (node-class value))
1774                        (= nreferences ncall-sites) )
1775               (let ([lparams (node-parameters value)])
1776                 (when (second lparams)
1777                   (decompose-lambda-list
1778                    (third lparams)
1779                    (lambda (vars argc rest)
1780                      (unless rest
1781                        (for-each
1782                         (lambda (var)
1783                           (cond [(and (not (get db var 'references))
1784                                       (not (get db var 'assigned)) )
1785                                  (put! db var 'unused #t)
1786                                  (set! has #t)
1787                                  #t]
1788                                 [else #f] ) )
1789                         vars) )
1790                      (cond [(and has (not (memq sym callback-names)))
1791                             (put! db (first lparams) 'has-unused-parameters #t) ]
1792                            [rest
1793                             (set! explicitly-consed (cons rest explicitly-consed))
1794                             (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
1795
1796         ;;  Make 'removable, if it has no references and is not assigned to, and if it has either a value that
1797         ;;    does not cause any side-effects or if it is 'undefined:
1798         (when (and (not assigned)
1799                    (null? references)
1800                    (or (and value
1801                             (or (not (eq? '##core#variable (node-class value)))
1802                                 (not (get db (first (node-parameters value)) 'global)) )
1803                             (not (expression-has-side-effects? value db)) )
1804                        undefined) )
1805           (quick-put! plist 'removable #t) )
1806
1807         ;; Make 'replacable, if it has a variable as known value and if either that variable has
1808         ;;  a known value itself, or if it is not captured and referenced only once, the target and
1809         ;;  the source are never assigned and the source is non-global or we are in block-mode:
1810         ;;  - The target-variable is not allowed to be global.
1811         ;;  - The variable that can be substituted for the current one is marked as 'replacing.
1812         ;;    This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if
1813         ;;    it was contracted).
1814         (when (and value (not global))
1815           (when (eq? '##core#variable (node-class value))
1816             (let* ([name (first (node-parameters value))]
1817                    [nrefs (get db name 'references)] )
1818               (when (or (and (not (get db name 'unknown)) (get db name 'value))
1819                         (and (not (get db name 'captured))
1820                              nrefs
1821                              (= 1 (length nrefs))
1822                              (not assigned)
1823                              (not (get db name 'assigned)) 
1824                              (or block-compilation (not (get db name 'global))) ) )
1825                 (quick-put! plist 'replacable name) 
1826                 (put! db name 'replacing #t) ) ) ) )
1827
1828         ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
1829         ;;  is an internally created procedure: (See above for 'replacing)
1830         (when (and value (eq? '##core#lambda (node-class value)))
1831           (let ([params (node-parameters value)])
1832             (when (not (second params))
1833               (let ([llist (third params)]
1834                     [body (first (node-subexpressions value))] )
1835                 (when (and (pair? llist) 
1836                            (null? (cdr llist))
1837                            (eq? '##core#call (node-class body)) )
1838                   (let ([subs (node-subexpressions body)])
1839                     (when (= 2 (length subs))
1840                       (let ([v1 (first subs)]
1841                             [v2 (second subs)] )
1842                         (when (and (eq? '##core#variable (node-class v1))
1843                                    (eq? '##core#variable (node-class v2))
1844                                    (eq? (first llist) (first (node-parameters v2))) )
1845                           (let ([kvar (first (node-parameters v1))])
1846                             (quick-put! plist 'replacable kvar)
1847                             (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) )
1848
1849         ;; If a rest-argument, convert 'rest-parameter property to 'vector, if the variable is never
1850         ;;  assigned, and the number of references is identical to the number of accesses in optimizable
1851         ;;  rest-argument operators:
1852         ;; - Add variable to "rest-parameters-promoted-to-vector", because subsequent optimization will
1853         ;;   change variables context (operators applied to it).
1854         (when (and rest-parameter
1855                    (not assigned)
1856                    (= nreferences o-r/access-count) )
1857           (set! rest-parameters-promoted-to-vector (lset-adjoin eq? rest-parameters-promoted-to-vector sym))
1858           (put! db sym 'rest-parameter 'vector) ) ) )
1859
1860     db)
1861
1862    ;; Remove explicitly consed rest parameters from promoted ones:
1863    (set! rest-parameters-promoted-to-vector
1864      (lset-difference eq? rest-parameters-promoted-to-vector explicitly-consed) )
1865
1866    ;; Set original program-size, if this is the first analysis-pass:
1867    (unless original-program-size
1868      (set! original-program-size current-program-size) )
1869    db) )
1870
1871
1872;;; Convert closures to explicit data structures (effectively flattens function-binding structure):
1873
1874(define (perform-closure-conversion node db)
1875  (let ([direct-calls 0]
1876        [customizable '()] )
1877
1878    (define (test sym item) (get db sym item))
1879 
1880    (define (register-customizable! var id)
1881      (set! customizable (lset-adjoin eq? customizable var)) 
1882      (put! db id 'customizable #t) )
1883
1884    (define (register-direct-call! id)
1885      (set! direct-calls (add1 direct-calls))
1886      (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) )
1887
1888    ;; Gather free-variable information:
1889    ;; (and: - register direct calls
1890    ;;       - update (by mutation) call information in "##core#call" nodes)
1891    (define (gather n here env)
1892      (let ((subs (node-subexpressions n))
1893            (params (node-parameters n)) )
1894        (case (node-class n)
1895
1896          ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f)
1897
1898          ((let)
1899           (receive (vals body) (split-at subs (length params))
1900             (for-each (lambda (n) (gather n here env)) vals)
1901             (gather (first body) here (append params env)) ) )
1902
1903          ((##core#call)
1904           (let* ([fn (first subs)]
1905                  [mode (first params)]
1906                  [name (and (pair? (cdr params)) (second params))]
1907                  [varfn (eq? '##core#variable (node-class fn))] )
1908             (node-parameters-set!
1909              n
1910              (cons mode
1911                    (if (or name varfn)
1912                        (cons name
1913                              (if varfn
1914                                  (let* ([varname (first (node-parameters fn))]
1915                                         [val (and (not (test varname 'unknown)) (test varname 'value))] )
1916                                    (if (and val (eq? '##core#lambda (node-class val)))
1917                                        (let* ([params (node-parameters val)]
1918                                               [llist (third params)]
1919                                               [id (first params)]
1920                                               [refs (test varname 'references)]
1921                                               [sites (test varname 'call-sites)] 
1922                                               [custom
1923                                                (and refs sites
1924                                                     (= (length refs) (length sites)) 
1925                                                     (proper-list? llist) ) ] )
1926                                          (when (and name custom (not (= (length llist) (length (cdr subs)))))
1927                                            (quit
1928                                             "known procedure called with wrong number of arguments: ~A" 
1929                                             (source-info->string name) ) )
1930                                          (register-direct-call! id)
1931                                          (when custom (register-customizable! varname id)) 
1932                                          (list id custom) )
1933                                        '() ) )
1934                                  '() ) )
1935                        '() ) ) )
1936             (for-each (lambda (n) (gather n here env)) subs) ) )
1937
1938          ((##core#lambda ##core#direct_lambda)
1939           (decompose-lambda-list
1940            (third params)
1941            (lambda (vars argc rest)
1942              (let* ([id (if here (first params) 'toplevel)]
1943                     [capturedvars (captured-variables (car subs) env)]
1944                     [csize (length capturedvars)] )
1945                (put! db id 'closure-size csize)
1946                (put! db id 'captured-variables capturedvars)
1947                (gather (car subs) id (append vars env)) ) ) ) )
1948       
1949          (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
1950
1951    ;; Create explicit closures:
1952    (define (transform n here closure)
1953      (let ((subs (node-subexpressions n))
1954            (params (node-parameters n)) 
1955            (class (node-class n)) )
1956        (case class
1957
1958          ((quote ##core#undefined ##core#proc ##core#global-ref) n)
1959
1960          ((##core#variable)
1961           (let* ((var (first params))
1962                  (val (ref-var n here closure)) )
1963             (if (test var 'boxed)
1964                 (make-node '##core#unbox '() (list val))
1965                 val) ) )
1966
1967          ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit ##core#inline_ref ##core#inline_update 
1968               ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return ##core#inline_loc_ref
1969               ##core#inline_loc_update)
1970           (make-node (node-class n) params (maptransform subs here closure)) )
1971
1972          ((let)
1973           (let* ([var (first params)]
1974                  [boxedvar (test var 'boxed)]
1975                  [boxedalias (gensym var)] )
1976             (if boxedvar
1977                 (make-node 
1978                  'let (list boxedalias)
1979                  (list (transform (first subs) here closure)
1980                        (make-node
1981                         'let (list var)
1982                         (list (make-node '##core#box '() (list (varnode boxedalias)))
1983                               (transform (second subs) here closure) ) ) ) )
1984                 (make-node
1985                  'let params
1986                  (maptransform subs here closure) ) ) ) )
1987
1988          ((##core#lambda ##core#direct_lambda)
1989           (let ([llist (third params)])
1990             (decompose-lambda-list
1991              llist
1992              (lambda (vars argc rest)
1993                (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)]
1994                       [boxedaliases (map cons boxedvars (map gensym boxedvars))]
1995                       [cvar (gensym 'c)]
1996                       [id (if here (first params) 'toplevel)]
1997                       [capturedvars (or (test id 'captured-variables) '())]
1998                       [csize (or (test id 'closure-size) 0)] 
1999                       [info (and emit-closure-info (second params) (pair? llist))] )
2000                  ;; If rest-parameter is boxed: mark it as 'boxed-rest
2001                  ;;  (if we don't do this than preparation will think the (boxed) alias
2002                  ;;  of the rest-parameter is never used)
2003                  (and-let* ([rest]
2004                             [(test rest 'boxed)]
2005                             [rp (test rest 'rest-parameter)] )
2006                    (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
2007                  (make-node
2008                   '##core#closure (list (+ csize (if info 2 1)))
2009                   (cons
2010                    (make-node
2011                     class
2012                     (list id
2013                           (second params)
2014                           (cons
2015                            cvar
2016                            (build-lambda-list
2017                             (map (lambda (v)
2018                                    (cond ((assq v boxedaliases) => cdr)
2019                                          (else v) ) )
2020                                  vars)
2021                             argc
2022                             (cond ((and rest (assq rest boxedaliases)) => cdr)
2023                                   (else rest) ) ) )
2024                           (fourth params) )
2025                     (list (let ((body (transform (car subs) cvar capturedvars)))
2026                             (if (pair? boxedvars)
2027                                 (fold-right
2028                                  (lambda (alias val body) (make-node 'let (list alias) (list val body)))
2029                                  body
2030                                  (unzip1 boxedaliases)
2031                                  (map (lambda (a) (make-node '##core#box '() (list (varnode (cdr a)))))
2032                                       boxedaliases) )
2033                                 body) ) ) )
2034                    (let ((cvars (map (lambda (v) (ref-var (varnode v) here closure))
2035                                      capturedvars) ) )
2036                      (if info
2037                          (append
2038                           cvars
2039                           (list
2040                            (qnode 
2041                             (##sys#make-lambda-info
2042                              (->string (cons (or (real-name id) '?)
2043                                              (cdr llist) )))))) ; this is not always correct, due to optimizations
2044                          cvars) ) ) ) ) ) ) ) )
2045
2046          ((set!)
2047           (let* ([var (first params)]
2048                  [val (first subs)]
2049                  [cval (node-class val)]
2050                  [immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
2051                            (eq? '##core#undefined cval) ) ] )
2052             (cond ((posq var closure)
2053                    => (lambda (i)
2054                         (if (test var 'boxed)
2055                             (make-node
2056                              (if immf '##core#updatebox_i '##core#updatebox)
2057                              '()
2058                              (list (make-node '##core#ref (list (add1 i)) (list (varnode here)))
2059                                    (transform val here closure) ) )
2060                             ;; Is the following actually used???
2061                             (make-node
2062                              (if immf '##core#update_i '##core#update)
2063                              (list (add1 i))
2064                              (list (varnode here)
2065                                    (transform val here closure) ) ) ) ) )
2066                   ((test var 'boxed)
2067                    (make-node
2068                     (if immf '##core#updatebox_i '##core#updatebox)
2069                     '()
2070                     (list (varnode var)
2071                           (transform val here closure) ) ) )
2072                   (else (make-node
2073                          'set! (list var)
2074                          (list (transform val here closure) ) ) ) ) ) )
2075
2076          ((##core#primitive) 
2077           (make-node
2078            '##core#closure (list (if emit-closure-info 2 1))
2079            (cons (make-node '##core#proc (list (car params) #t) '())
2080                  (if emit-closure-info
2081                      (list (qnode (##sys#make-lambda-info (car params))))
2082                      '() ) ) ) )
2083
2084          (else (bomb "bad node (closure2)")) ) ) )
2085
2086    (define (maptransform xs here closure)
2087      (map (lambda (x) (transform x here closure)) xs) )
2088 
2089    (define (ref-var n here closure)
2090      (let ((var (first (node-parameters n))))
2091        (cond ((posq var closure) 
2092               => (lambda (i) 
2093                    (make-node '##core#ref (list (+ i 1)) 
2094                               (list (varnode here)) ) ) )
2095              (else n) ) ) )
2096
2097    (define (captured-variables node env)
2098      (let ([vars '()])
2099        (let walk ([n node])
2100          (let ((subs (node-subexpressions n))
2101                (params (node-parameters n)) )
2102            (case (node-class n)
2103              ((##core#variable)
2104               (let ([var (first params)])
2105                 (when (memq var env)
2106                   (set! vars (lset-adjoin eq? vars var)) ) ) )
2107              ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f)
2108              ((set!) 
2109               (let ([var (first params)])
2110                 (when (memq var env) (set! vars (lset-adjoin eq? vars var)))
2111                 (walk (car subs)) ) )
2112              (else (for-each walk subs)) ) ) )
2113        vars) )
2114
2115    (debugging 'p "closure conversion gathering phase...")
2116    (gather node #f '())
2117    (debugging 'o "customizable procedures" customizable)
2118    (debugging 'p "closure conversion transformation phase...")
2119    (let ((node2 (transform node #f #f)))
2120      (unless (zero? direct-calls)
2121        (debugging 'o "calls to known targets" direct-calls (delay (length direct-call-ids))) )
2122      node2) ) )
2123
2124
2125;;; Do some preparations before code-generation can commence:
2126
2127(define-record-type lambda-literal
2128  (make-lambda-literal id external arguments argument-count rest-argument temporaries
2129                       callee-signatures allocated directly-called closure-size
2130                       looping customizable rest-argument-mode body direct)
2131  lambda-literal?
2132  (id lambda-literal-id)                               ; symbol
2133  (external lambda-literal-external)                   ; boolean
2134  (arguments lambda-literal-arguments)                 ; (symbol...)
2135  (argument-count lambda-literal-argument-count)       ; integer
2136  (rest-argument lambda-literal-rest-argument)         ; symbol | #f
2137  (temporaries lambda-literal-temporaries)             ; integer
2138  (callee-signatures lambda-literal-callee-signatures) ; (integer...)
2139  (allocated lambda-literal-allocated)                 ; integer
2140  (directly-called lambda-literal-directly-called)     ; boolean
2141  (closure-size lambda-literal-closure-size)           ; integer
2142  (looping lambda-literal-looping)                     ; boolean
2143  (customizable lambda-literal-customizable)           ; boolean
2144  (rest-argument-mode lambda-literal-rest-argument-mode) ; #f | LIST | VECTOR | UNUSED
2145  (body lambda-literal-body)                             ; expression
2146  (direct lambda-literal-direct))                        ; boolean
2147 
2148(define (prepare-for-code-generation node db)
2149  (let ([literals '()]
2150        [lambda-info-literals '()]
2151        [lambdas '()]
2152        [temporaries 0]
2153        [allocated 0]
2154        [looping 0]
2155        [signatures '()] 
2156        [fastinits 0] 
2157        [fastrefs 0] 
2158        [fastsets 0] )
2159
2160    (define (walk-var var e sf)
2161      (cond [(posq var e) => (lambda (i) (make-node '##core#local (list i) '()))]
2162            [(keyword? var) (make-node '##core#literal (list (literal var)) '())]
2163            [else (walk-global var sf)] ) )
2164
2165    (define (walk-global var sf)
2166      (let* ([safe (or sf 
2167                       no-bound-checks
2168                       unsafe
2169                       (memq var always-bound)
2170                       (get db var 'standard-binding)
2171                       (get db var 'extended-binding) ) ]
2172             [blockvar (memq var block-globals)] )
2173        (when blockvar (set! fastrefs (add1 fastrefs)))
2174        (make-node
2175         '##core#global
2176         (list (if blockvar
2177                   (blockvar-literal var)
2178                   (literal var) )
2179               safe
2180               blockvar
2181               var)
2182         '() ) ) )
2183
2184    (define (walk n e here boxes)
2185      (let ((subs (node-subexpressions n))
2186            (params (node-parameters n))
2187            (class (node-class n)) )
2188        (case class
2189
2190          ((##core#undefined ##core#proc) n)
2191
2192          ((##core#variable) 
2193           (walk-var (first params) e #f) )
2194
2195          ((##core#global-ref)
2196           (walk-global (first params) #t) )
2197
2198          ((##core#direct_call)
2199           (set! allocated (+ allocated (fourth params)))
2200           (make-node class params (mapwalk subs e here boxes)) )
2201
2202          ((##core#inline_allocate)
2203           (set! allocated (+ allocated (second params)))
2204           (make-node class params (mapwalk subs e here boxes)) )
2205
2206          ((##core#inline_ref)
2207           (set! allocated (+ allocated (words (estimate-foreign-result-size (second params)))))
2208           (make-node class params '()) )
2209
2210          ((##core#inline_loc_ref)
2211           (set! allocated (+ allocated (words (estimate-foreign-result-size (first params)))))
2212           (make-node class params (mapwalk subs e here boxes)) )
2213
2214          ((##core#closure) 
2215           (set! allocated (+ allocated (first params) 1))
2216           (make-node '##core#closure params (mapwalk subs e here boxes)) )
2217
2218          ((##core#box)
2219           (set! allocated (+ allocated 2))
2220           (make-node '##core#box params (list (walk (first subs) e here boxes))) )
2221
2222          ((##core#updatebox)
2223           (let* ([b (first subs)]
2224                  [subs (mapwalk subs e here boxes)] )
2225             (make-node
2226              (cond [(and (eq? '##core#variable (node-class b))
2227                          (memq (first (node-parameters b)) boxes) )
2228                     (set! fastinits (add1 fastinits))
2229                     '##core#updatebox_i]
2230                    [else class] )
2231              '()
2232              subs) ) )
2233
2234          ((##core#lambda ##core#direct_lambda) 
2235           (let ([temps temporaries]
2236                 [sigs signatures]
2237                 [lping looping]
2238                 [alc allocated] 
2239                 [direct (eq? class '##core#direct_lambda)] )
2240             (set! temporaries 0)
2241             (set! allocated 0)
2242             (set! signatures '())
2243             (set! looping 0)
2244             (decompose-lambda-list
2245              (third params)
2246              (lambda (vars argc rest)
2247                (let* ([id (first params)]
2248                       [rest-mode
2249                        (and rest
2250                             (let ([rrefs (get db rest 'references)])
2251                               (cond [(get db rest 'assigned) 'list]
2252                                     [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none] 
2253                                     [else (get db rest 'rest-parameter)] ) ) ) ]
2254                       [body (walk 
2255                              (car subs)
2256                              (if (eq? 'none rest-mode)
2257                                  (butlast vars)
2258                                  vars)
2259                              id
2260                              '()) ] )
2261                  (case rest-mode
2262                    [(none) (debugging 'o "unused rest argument" rest id)]
2263                    [(vector) (debugging 'o "rest argument accessed as vector" rest id)] )
2264                  (when (and direct rest)
2265                    (bomb "bad direct lambda" id allocated rest) )
2266                  (set! lambdas
2267                    (cons (make-lambda-literal
2268                           id
2269                           (second params)
2270                           vars
2271                           argc
2272                           rest
2273                           (add1 temporaries)
2274                           signatures
2275                           allocated
2276                           (or direct (memq id direct-call-ids))
2277                           (or (get db id 'closure-size) 0)
2278                           (and (not rest)
2279                                (> looping 0)
2280                                (begin
2281                                  (debugging 'o "identified direct recursive calls" id looping)
2282                                  #t) )
2283                           (or direct (get db id 'customizable))
2284                           rest-mode
2285                           body
2286                           direct)
2287                          lambdas) )
2288                  (set! looping lping)
2289                  (set! temporaries temps)
2290                  (set! allocated alc)
2291                  (set! signatures sigs)
2292                  (make-node '##core#proc (list (first params)) '()) ) ) ) ) )
2293
2294          ((let)
2295           (let* ([var (first params)]
2296                  [val (first subs)] 
2297                  [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
2298             (set! temporaries (add1 temporaries))
2299             (make-node
2300              '##core#bind (list 1)
2301              (list (walk val e here boxes)
2302                    (walk (second subs) (append e params) here (append boxvars boxes)) ) ) ) )
2303
2304          ((set!)
2305           (let ([var (first params)]
2306                 [val (first subs)] )
2307             (cond ((posq var e)
2308                    => (lambda (i) 
2309                         (make-node '##core#setlocal (list i) (list (walk val e here boxes)) ) ) )
2310                   (else
2311                    (let* ([cval (node-class val)]
2312                           [safe (not (or no-bound-checks
2313                                          unsafe
2314                                          (memq var always-bound)
2315                                          (get db var 'standard-binding)
2316                                          (get db var 'extended-binding) ) ) ]
2317                           [blockvar (memq var block-globals)]
2318                           [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
2319                                     (eq? '##core#undefined cval) ) ] )
2320                      (when blockvar (set! fastsets (add1 fastsets)))
2321                      (make-node
2322                       (if immf '##core#setglobal_i '##core#setglobal)
2323                       (list (if blockvar
2324                                 (blockvar-literal var)
2325                                 (literal var) )
2326                             blockvar)
2327                       (list (walk (car subs) e here boxes)) ) ) ) ) ) )
2328
2329          ((##core#call) 
2330           (let ([len (length (cdr subs))])
2331             (set! signatures (lset-adjoin = signatures len)) 
2332             (when (and (>= (length params) 3) (eq? here (third params)))
2333               (set! looping (add1 looping)) )
2334             (make-node class params (mapwalk subs e here boxes)) ) )
2335
2336          ((##core#recurse)
2337           (when (first params) (set! looping (add1 looping)))
2338           (make-node class params (mapwalk subs e here boxes)) )
2339
2340          ((quote)
2341           (let ((c (first params)))
2342             (cond ((and (fixnum? c) (not (big-fixnum? c)))
2343                    (immediate-literal c) )
2344                   ((number? c)
2345                    (cond ((eq? 'fixnum number-type)
2346                           (cond ((and (integer? c) (not (big-fixnum? c)))
2347                                  (compiler-warning 
2348                                   'type 
2349                                   "coerced inexact literal number `~S' to fixnum ~S" c (inexact->exact c))
2350                                  (immediate-literal (inexact->exact c)) )
2351                                 (else (quit "can not coerce inexact literal `~S' to fixnum" c)) ) )
2352                          (else (make-node '##core#literal (list (literal c)) '())) ) )
2353                   ((immediate? c) (immediate-literal c))
2354                   (else (make-node '##core#literal (list (literal c)) '())) ) ) )
2355
2356          (else (make-node class params (mapwalk subs e here boxes)) ) ) ) )
2357   
2358    (define (mapwalk xs e here boxes)
2359      (map (lambda (x) (walk x e here boxes)) xs) )
2360
2361    (define (literal x)
2362      (cond [(immediate? x) (immediate-literal x)]
2363            [(number? x)
2364             (or (and (inexact? x) 
2365                      (list-index (lambda (y) (and (number? y) (inexact? y) (= x y)))
2366                                  literals) )
2367                 (new-literal x)) ]
2368            ((##core#inline "C_lambdainfop" x)
2369             (let ((i (length lambda-info-literals)))
2370               (set! lambda-info-literals 
2371                 (append lambda-info-literals (list x))) ;*** see below
2372               (vector i) ) )
2373            [(posq x literals) => identity]
2374            [else (new-literal x)] ) )
2375
2376    (define (new-literal x)
2377      (let ([i (length literals)])
2378        (set! literals (append literals (list x))) ;*** could (should) be optimized
2379        i) )
2380
2381    (define (blockvar-literal var)
2382      (or (list-index
2383           (lambda (lit) 
2384             (and (block-variable-literal? lit)
2385                  (eq? var (block-variable-literal-name lit)) ) )
2386           literals)
2387          (new-literal (make-block-variable-literal var)) ) )
2388   
2389    (define (immediate-literal x)
2390      (if (eq? (void) x)
2391          (make-node '##core#undefined '() '())
2392          (make-node '##core#immediate
2393                     (cond ((fixnum? x) `(fix ,x))
2394                           ((boolean? x) `(bool ,x))
2395                           ((char? x) `(char ,x))
2396                           ((null? x) '(nil))
2397                           ((eof-object? x) '(eof))
2398                           (else (bomb "bad immediate (prepare)")) )
2399                     '() ) ) )
2400   
2401    (debugging 'p "preparation phase...")
2402    (let ((node2 (walk node '() #f '())))
2403      (debugging 'o "fast box initializations" fastinits)
2404      (debugging 'o "fast global references" fastrefs)
2405      (debugging 'o "fast global assignments" fastsets)
2406      (values node2 literals lambda-info-literals lambdas) ) ) )
Note: See TracBrowser for help on using the repository browser.