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

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

quasiquote fixes; uses srfi-9 for all records; disabled define-record; some more hygienic 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-atom 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                 x))]))
508
509  (define (walk x se dest)
510    (cond ((symbol? x)
511           (##sys#alias-global-hook (resolve-atom 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)
547                         (##sys#check-syntax 'quote x '(quote _) #f se)
548                         `(quote ,(##sys#strip-syntax (cadr x))))
549
550                        ((##core#syntax)
551                         `(quote ,(cadr x)))
552
553                        ((##core#check)
554                         (if unsafe
555                             ''#t
556                             (walk (cadr x) se dest) ) )
557
558                        ((##core#immutable)
559                         (let ((c (cadadr x)))
560                           (cond [(assoc c immutable-constants) => cdr]
561                                 [else
562                                  (let ([var (gensym 'c)])
563                                    (set! immutable-constants (alist-cons c var immutable-constants))
564                                    (set! always-bound (cons var always-bound))
565                                    (set! block-globals (cons var block-globals))
566                                    var) ] ) ) )
567
568                        ((##core#undefined ##core#callunit ##core#primitive ##core#inline_ref 
569                                           ##core#inline_loc_ref) x)
570
571                        ((##core#require-for-syntax)
572                         (let ([ids (map eval (cdr x))])
573                           (apply ##sys#require ids)
574                           (hash-table-update! 
575                            file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
576                            (lambda () ids) )
577                           '(##core#undefined) ) )
578
579                        ((##core#require-extension)
580                         (walk
581                          (let loop ([ids (cdr x)])
582                            (if (null? ids)
583                                '(##core#undefined)
584                                (let ([id (cadar ids)])
585                                  (let-values ([(exp f) (##sys#do-the-right-thing id #t)])
586                                    (if (not (or f 
587                                                 (and (symbol? id)
588                                                     (or (feature? id)
589                                                         (##sys#find-extension
590                                                          (##sys#canonicalize-extension-path 
591                                                           id 'require-extension) #f)) ) ) )
592                                        (compiler-warning 
593                                         'ext "extension `~A' is currently not installed" id)
594                                        (unless (and-let* (use-import-table
595                                                           ((symbol? id))
596                                                           (info (##sys#extension-information id #f)) 
597                                                           (exps (assq 'exports info)) )
598                                                  (for-each
599                                                   (cut ##sys#hash-table-set! import-table <> id)
600                                                   (cdr exps) )
601                                                  #t)
602                                          (lookup-exports-file id) ) )
603                                    `(begin ,exp ,(loop (cdr ids))) ) ) ) )
604                          se dest) )
605
606                        ((let)
607                         (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f se)
608                         (let* ([bindings (cadr x)]
609                                [vars (unzip1 bindings)]
610                                [aliases (map gensym vars)] 
611                                (se2 (append (map cons vars aliases) se)) )
612                           (set-real-names! aliases vars)
613                           `(let
614                             ,(map (lambda (alias b)
615                                     (list alias (walk (cadr b) se (car b))) )
616                                   aliases bindings)
617                             ,(walk (##sys#canonicalize-body (cddr x) se2)
618                                    se2 dest) ) ) )
619
620                        ((lambda ##core#internal-lambda)
621                         (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
622                         (let ([llist (cadr x)]
623                               [obody (cddr x)] )
624                           (when (##sys#extended-lambda-list? llist)
625                             (set!-values 
626                              (llist obody) 
627                              (##sys#expand-extended-lambda-list 
628                               llist obody ##sys#error se) ) )
629                           (decompose-lambda-list
630                            llist
631                            (lambda (vars argc rest)
632                              (let* ((aliases (map gensym vars))
633                                     (se2 (append (map cons vars aliases) se))
634                                     (body0 (##sys#canonicalize-body obody se2))
635                                     (body (walk body0 se2 #f))
636                                     (llist2 
637                                      (build-lambda-list
638                                       aliases argc
639                                       (and rest (list-ref aliases (posq rest vars))) ) )
640                                     (l `(lambda ,llist2 ,body)) )
641                                (set-real-names! aliases vars)
642                                (cond ((or (not dest) 
643                                           (not (assq dest se))) ; global?
644                                       l)
645                                      ((and emit-profile (eq? 'lambda name))
646                                       (expand-profile-lambda dest llist2 body) )
647                                      (else
648                                       (match body0
649                                         (((? (lambda (s)
650                                                (eq? 'begin (lookup s se))))
651                                           (or (? string? doc)
652                                               ((? (lambda (s) (eq? 'quote (lookup s se))))
653                                                doc)) _ . more)
654                                          (process-lambda-documentation
655                                           dest doc l) )
656                                         (_ l) ) ) ) ) ) ) ) )
657                       
658                        ((let-syntax)
659                         (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
660                         (let ((se2 (append
661                                     (map (lambda (b)
662                                            (list
663                                             (car b)
664                                             se
665                                             (##sys#er-transformer
666                                              ((##sys#compile-to-closure
667                                                (cadr b)
668                                                '() (##sys#current-meta-environment))
669                                               '()) ) ) )
670                                          (cadr x) )
671                                     se) ) )
672                           (walk
673                            (##sys#canonicalize-body (cddr x) se2)
674                            se2
675                            dest) ) )
676                               
677                       ((letrec-syntax)
678                        (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
679                        (let* ((ms (map (lambda (b)
680                                          (list
681                                           (car b)
682                                           #f
683                                           (##sys#er-transformer
684                                            ((##sys#compile-to-closure
685                                              (cadr b)
686                                              '() se)
687                                             '()) ) ) )
688                                        (cadr x) ) )
689                               (se2 (append ms se)) )
690                          (for-each
691                           (lambda (sb)
692                             (set-car! (cdr sb) se2) )
693                           ms)
694                          (walk
695                           (##sys#canonicalize-body (cddr x) se2)
696                           se2 dest)))
697                               
698                        ((##core#named-lambda)
699                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
700
701                        ((##core#loop-lambda)
702                         (let* ([vars (cadr x)]
703                                [obody (cddr x)]
704                                [aliases (map gensym vars)]
705                                (se2 (append (map cons vars aliases) se))
706                                [body 
707                                 (walk 
708                                  (##sys#canonicalize-body obody se2)
709                                  se2 #f) ] )
710                           (set-real-names! aliases vars)
711                           `(lambda ,aliases ,body) ) )
712
713                        ((set! ##core#set!) 
714                         (##sys#check-syntax 'set! x '(_ variable _) #f se)
715                         (let* ([var0 (cadr x)]
716                                [var (lookup var0 se)]
717                                [ln (get-line x)]
718                                [val (walk (caddr x) se var0)] )
719                           (when (eq? var var0) ; global?
720                             (set! var (##sys#alias-global-hook var))
721                             (when safe-globals-flag
722                               (set! always-bound-to-procedure
723                                 (lset-adjoin eq? always-bound-to-procedure var))
724                               (set! always-bound (lset-adjoin eq? always-bound var)) )
725                             (when (macro? var)
726                               (compiler-warning 
727                                'var "assigned global variable `~S' is a macro ~A"
728                                var
729                                (if ln (sprintf "in line ~S" ln) "") )
730                               (when undefine-shadowed-macros (undefine-macro! var) ) ) )
731                           (when (keyword? var)
732                             (compiler-warning 'syntax "assignment to keyword `~S'" var) )
733                           (when (pair? var) ; macro
734                             (syntax-error
735                              'set! "assignment to syntactic identifier" var))
736                           (cond ((assq var foreign-variables)
737                                   => (lambda (fv)
738                                        (let ([type (second fv)]
739                                              [tmp (gensym)] )
740                                          `(let ([,tmp ,(foreign-type-convert-argument val type)])
741                                             (##core#inline_update 
742                                              (,(third fv) ,type)
743                                              ,(foreign-type-check tmp type) ) ) ) ) )
744                                 ((assq var location-pointer-map)
745                                  => (lambda (a)
746                                       (let* ([type (third a)]
747                                              [tmp (gensym)] )
748                                         `(let ([,tmp ,(foreign-type-convert-argument val type)])
749                                            (##core#inline_loc_update 
750                                             (,type)
751                                             ,(second a)
752                                             ,(foreign-type-check tmp type) ) ) ) ) )
753                                 (else `(set! ,var ,val)))))
754
755                        ((##core#inline)
756                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
757
758                        ((##core#inline_allocate)
759                         `(##core#inline_allocate 
760                           ,(map (cut unquotify <> se) (second x))
761                           ,@(mapwalk (cddr x) se)))
762
763                        ((##core#inline_update)
764                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
765
766                        ((##core#inline_loc_update)
767                         `(##core#inline_loc_update 
768                           ,(cadr x) 
769                           ,(walk (caddr x) se #f)
770                           ,(walk (cadddr x) se #f)) )
771
772                        ((##core#compiletimetoo ##core#elaborationtimetoo)
773                         (let ((exp (cadr x)))
774                           (eval exp)
775                           (walk exp se dest) ) )
776
777                        ((##core#compiletimeonly ##core#elaborationtimeonly)
778                         (eval (cadr x))
779                         '(##core#undefined) )
780
781                        ((begin) 
782                         (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
783                         (if (pair? (cdr x))
784                             (canonicalize-begin-body
785                              (let fold ([xs (cdr x)])
786                                (let ([x (car xs)]
787                                      [r (cdr xs)] )
788                                  (if (null? r)
789                                      (list (walk x se dest))
790                                      (cons (walk x se #f) (fold r)) ) ) ) )
791                             '(##core#undefined) ) )
792
793                        ((##core#foreign-lambda)
794                         (walk (expand-foreign-lambda x) se dest) )
795
796                        ((##core#foreign-callback-lambda)
797                         (walk (expand-foreign-callback-lambda x) se dest) )
798
799                        ((##core#foreign-lambda*)
800                         (walk (expand-foreign-lambda* x) se dest) )
801
802                        ((##core#foreign-callback-lambda*)
803                         (walk (expand-foreign-callback-lambda* x) se dest) )
804
805                        ((##core#foreign-primitive)
806                         (walk (expand-foreign-primitive x) se dest) )
807
808                        ((##core#define-foreign-variable)
809                         (let* ([var (cadr (second x))]
810                                [type (cadr (third x))]
811                                [name (if (pair? (cdddr x))
812                                          (cadr (fourth x))
813                                          (symbol->string var) ) ] )
814                           (set! foreign-variables
815                             (cons (list var type (if (string? name) name (symbol->string name)))
816                                   foreign-variables))
817                           '(##core#undefined) ) )
818
819                        ((##core#define-foreign-type)
820                         (let ([name (cadr (second x))]
821                               [type (cadr (third x))] 
822                               [conv (cdddr x)] )
823                           (cond [(pair? conv)
824                                  (let ([arg (gensym)]
825                                        [ret (gensym)] )
826                                    (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
827                                    (set! always-bound (cons* arg ret always-bound))
828                                    (set! block-globals (cons* arg ret block-globals))
829                                    (walk
830                                     `(,(macro-alias 'begin se)
831                                        (##core#set! ,arg ,(first conv))
832                                        (##core#set!
833                                         ,ret 
834                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) ) 
835                                     se dest) ) ]
836                                 [else
837                                  (##sys#hash-table-set! foreign-type-table name type)
838                                  '(##core#undefined) ] ) ) )
839
840                        ((##core#define-external-variable)
841                         (let* ([sym (cadr (second x))]
842                                [name (symbol->string sym)]
843                                [type (cadr (third x))] 
844                                [exported (cadr (fourth x))]
845                                [rname (make-random-name)] )
846                           (unless exported (set! name (symbol->string (cadr (fifth x)))))
847                           (set! external-variables (cons (vector name type exported) external-variables))
848                           (set! foreign-variables
849                             (cons (list rname 'c-pointer (string-append "&" name))
850                                   foreign-variables) )
851                           (set! external-to-pointer (alist-cons sym rname external-to-pointer))
852                           '(##core#undefined) ) )
853
854                        ((##core#let-location)
855                         (let* ([var (cadr (second x))]
856                                [type (cadr (third x))]
857                                [alias (gensym)]
858                                [store (gensym)] 
859                                [init (and (pair? (cddddr x)) (fourth x))] )
860                           (set-real-name! alias var)
861                           (set! location-pointer-map
862                             (cons (list alias store type) location-pointer-map) )
863                           `(let (,(let ([size (words (estimate-foreign-result-location-size type))])
864                                     ;; Add 2 words: 1 for the header, 1 for double-alignment:
865                                     ;; Note: C_a_i_bytevector takes number of words, not bytes
866                                     (list
867                                      store
868                                      `(##core#inline_allocate
869                                        ("C_a_i_bytevector" ,(+ 2 size))
870                                        ',size)) ) )
871                              ,(walk
872                                `(,(macro-alias 'begin se)
873                                   ,@(if init
874                                         `((##core#set! ,alias ,init))
875                                         '() )
876                                   ,(,(macro-alias 'if se) init (fifth x) (fourth x)) )
877                                (alist-cons var alias se)
878                                dest) ) ) )
879
880                        ((##core#define-inline)
881                         (let* ([name (cadr (second x))]
882                                [val (third x)] )
883                           (receive (val2 mlist)
884                               (extract-mutable-constants
885                                (walk (cons '##core#internal-lambda (cdr val)) se name) )
886                             (##sys#hash-table-set! inline-table name val2)
887                             (set! always-bound (append (unzip1 mlist) always-bound))
888                             (set! inline-table-used #t)
889                             (walk
890                              `(,(macro-alias 'begin se)
891                                ,@(map (lambda (m)
892                                         `(##core#set! ,(car m) ',(cdr m))) mlist))
893                              se #f) ) ) )
894
895                        ((##core#define-constant)
896                         (let* ([name (cadr (second x))]
897                                [valexp (third x)]
898                                [val (handle-exceptions ex
899                                         ;; could show line number here
900                                         (quit "error in constant evaluation of ~S for named constant ~S" 
901                                               valexp name)
902                                       (if (collapsable-literal? valexp)
903                                           valexp
904                                           (eval
905                                            `(,(macro-alias 'let se)
906                                              ,defconstant-bindings ,valexp)) ) ) ] )
907                           (set! constants-used #t)
908                           (set! defconstant-bindings (cons (list name `',val) defconstant-bindings))
909                           (cond [(collapsable-literal? val)
910                                  (##sys#hash-table-set! constant-table name (list val))
911                                  '(##core#undefined) ]
912                                 [else
913                                  (let ([var (gensym "constant")])
914                                    (##sys#hash-table-set! constant-table name (list var))
915                                    (set! mutable-constants (alist-cons var val mutable-constants))
916                                    (set! block-globals (cons var block-globals))
917                                    (set! always-bound (cons var always-bound))
918                                    (walk `(##core#set! ,var ',val) se #f) ) ] ) ) )
919
920                        ((##core#declare)
921                         (walk
922                          `(,(macro-alias 'begin se)
923                             ,@(map (lambda (d)
924                                      (process-declaration 
925                                       (##sys#strip-syntax (second d))
926                                       se))
927                                    (cdr x) ) )
928                          '() #f) )
929             
930                        ((##core#foreign-callback-wrapper)
931                         (let-values ([(args lam) (split-at (cdr x) 4)])
932                           (let* ([lam (car lam)]
933                                  [name (first args)]
934                                  [rtype (cadr (third args))]
935                                  [atypes (cadr (fourth args))]
936                                  [vars (second lam)] )
937                             (let ([name (cadr name)])
938                               (if (valid-c-identifier? name)
939                                   (set! callback-names (cons name callback-names))
940                                   (quit "name `~S' of external definition is not a valid C identifier"
941                                         name) ) )
942                             (when (or (not (proper-list? vars)) 
943                                       (not (proper-list? atypes))
944                                       (not (= (length vars) (length atypes))) )
945                               (syntax-error 
946                                "non-matching or invalid argument list to foreign callback-wrapper"
947                                vars atypes) )
948                             `(##core#foreign-callback-wrapper
949                               ,@(mapwalk args se)
950                               ,(walk `(##core#internal-lambda 
951                                        ,vars
952                                        (,(macro-alias 'let se)
953                                         ,(let loop ([vars vars] [types atypes])
954                                            (if (null? vars)
955                                                '()
956                                                (let ([var (car vars)]
957                                                      [type (car types)] )
958                                                  (cons
959                                                   (list
960                                                    var
961                                                    (foreign-type-convert-result
962                                                     (finish-foreign-result (final-foreign-type type) var)
963                                                     type) )
964                                                   (loop (cdr vars) (cdr types)) ) ) ) )
965                                         ,(foreign-type-convert-argument
966                                           `(,(macro-alias 'let se)
967                                             ()
968                                               ,@(match rtype
969                                                   ((or '(const nonnull-c-string) 
970                                                        '(const nonnull-unsigned-c-string)
971                                                        'nonnull-unsigned-c-string
972                                                        'nonnull-c-string)
973                                                    `((##sys#make-c-string
974                                                       (,(macro-alias 'let se)
975                                                        () ,@(cddr lam)))))
976                                                   ((or '(const c-string*)
977                                                        '(const unsigned-c-string*)
978                                                        'unsigned-c-string*
979                                                        'c-string*
980                                                        'c-string-list
981                                                        'c-string-list*)
982                                                    (syntax-error
983                                                     "not a valid result type for callback procedures"
984                                                     rtype
985                                                     name) )
986                                                   ((or 'c-string
987                                                        '(const unsigned-c-string)
988                                                        'unsigned-c-string
989                                                        '(const c-string))
990                                                    `((,(macro-alias 'let se)
991                                                       ((r (,(macro-alias 'let se)
992                                                            () ,@(cddr lam))))
993                                                       (,(macro-alias 'and se)
994                                                        r 
995                                                        (##sys#make-c-string r)) ) ) )
996                                                   (_ (cddr lam)) ) )
997                                           rtype) ) )
998                                      se #f) ) ) ) )
999
1000                        (else
1001                         (let ([handle-call
1002                                (lambda ()
1003                                  (let* ([x2 (mapwalk x se)]
1004                                         [head2 (car x2)]
1005                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
1006                                    (when ln
1007                                      (##sys#hash-table-set!
1008                                       line-number-database-2
1009                                       head2
1010                                       (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
1011                                    x2) ) ] )
1012
1013                           (cond [(eq? 'location name)
1014                                  (##sys#check-syntax 'location x '(location _) #f se)
1015                                  (let ([sym (cadr x)])
1016                                    (if (symbol? sym)
1017                                        (cond [(assq (lookup sym se) location-pointer-map)
1018                                               => (lambda (a)
1019                                                    (walk
1020                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
1021                                                     se #f) ) ]
1022                                              [(assq sym external-to-pointer) 
1023                                               => (lambda (a) (walk (cdr a) se #f)) ]
1024                                              [(memq sym callback-names)
1025                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
1026                                              [else
1027                                               (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
1028                                        (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
1029                                 
1030                                 ((and compiler-macros-enabled
1031                                       compiler-macro-table
1032                                       (##sys#hash-table-ref compiler-macro-table name)) =>
1033                                  (lambda (cm)
1034                                    (let ((cx (cm x)))
1035                                      (if (equal? cx x)
1036                                          (handle-call)
1037                                          (walk cx se dest)))))
1038                                 
1039                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
1040
1041          ((not (proper-list? x))
1042           (syntax-error "malformed expression" x) )
1043
1044          ((constant? (car x))
1045           (emit-syntax-trace-info x #f)
1046           (compiler-warning 'syntax "literal in operator position: ~S" x) 
1047           (mapwalk x se) )
1048
1049          ((and (pair? (car x)) (eq? 'lambda (caar x)))
1050           (let ([lexp (car x)]
1051                 [args (cdr x)] )
1052             (emit-syntax-trace-info x #f)
1053             (##sys#check-syntax 'lambda lexp '(lambda lambda-list . #(_ 1)) #f se)
1054             (let ([llist (cadr lexp)])
1055               (if (and (proper-list? llist) (= (length llist) (length args)))
1056                   (walk `(,(macro-alias 'let se)
1057                           ,(map list llist args) ,@(cddr lexp)) se dest)
1058                   (let ((var (gensym 't)))
1059                     (walk
1060                      `(,(macro-alias 'let se)
1061                        ((,var ,(car x)))
1062                        (,var ,@(cdr x)) )
1063                      se dest) ) ) ) ) )
1064         
1065          (else
1066           (emit-syntax-trace-info x #f)
1067           (mapwalk x se)) ) )
1068 
1069  (define (mapwalk xs se)
1070    (map (lambda (x) (walk x se #f)) xs) )
1071
1072  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
1073  (##sys#clear-trace-buffer)
1074  ;; Process visited definitions and main expression:
1075  (walk 
1076   `(,(macro-alias 'begin '())
1077      ,@(let ([p (reverse pending-canonicalizations)])
1078          (set! pending-canonicalizations '())
1079          p)
1080      ,(let ([exp (##sys#compiler-toplevel-macroexpand-hook exp)])
1081         (set! extended-bindings (append internal-bindings extended-bindings))
1082         exp) )
1083   '() #f) )
1084
1085
1086(define (process-declaration spec se)   ; se unused in the moment
1087  (define (check-decl spec minlen . maxlen)
1088    (let ([n (length (cdr spec))])
1089      (if (or (< n minlen) (> n (optional maxlen 99999)))
1090          (syntax-error "invalid declaration" spec) ) ) ) 
1091  (call-with-current-continuation
1092   (lambda (return)
1093     (unless (pair? spec)
1094       (syntax-error "invalid declaration specification" spec) )
1095     (case (car spec)
1096       ((uses)
1097        (let ((us (cdr spec)))
1098          (apply register-feature! us)
1099          (when use-import-table
1100            (for-each lookup-exports-file us) )
1101          (when (pair? us)
1102            (hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
1103            (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
1104              (set! used-units (append used-units units)) ) ) ) )
1105       ((unit)
1106        (check-decl spec 1 1)
1107        (let* ([u (cadr spec)]
1108               [un (string->c-identifier (stringify u))] )
1109          (hash-table-set! file-requirements 'unit u)
1110          (when (and unit-name (not (string=? unit-name un)))
1111            (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
1112          (set! unit-name un) ) )
1113       ((standard-bindings)
1114        (if (null? (cdr spec))
1115            (set! standard-bindings default-standard-bindings)
1116            (set! standard-bindings (append (cdr spec) standard-bindings)) ) )
1117       ((extended-bindings)
1118        (if (null? (cdr spec))
1119            (set! extended-bindings default-extended-bindings)
1120            (set! extended-bindings (append (cdr spec) extended-bindings)) ) )
1121       ((usual-integrations)     
1122        (cond [(null? (cdr spec))
1123               (set! standard-bindings default-standard-bindings)
1124               (set! extended-bindings default-extended-bindings) ]
1125              [else
1126               (let ([syms (cdr spec)])
1127                 (set! standard-bindings (lset-intersection eq? syms default-standard-bindings))
1128                 (set! extended-bindings (lset-intersection eq? syms default-extended-bindings)) ) ] ) )
1129       ((number-type)
1130        (check-decl spec 1 1)
1131        (set! number-type (cadr spec)))
1132       ((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
1133       ((generic) (set! number-type 'generic))
1134       ((unsafe)
1135        (set! unsafe #t)
1136        (##match#set-error-control #:unspecified) )
1137       ((safe) (set! unsafe #f))
1138       ((no-bound-checks) (set! no-bound-checks #t))
1139       ((no-argc-checks) (set! no-argc-checks #t))
1140       ((no-procedure-checks) (set! no-procedure-checks #t))
1141       ((interrupts-enabled) (set! insert-timer-checks #t))
1142       ((disable-interrupts) (set! insert-timer-checks #f))
1143       ((disable-warning)
1144        (set! disabled-warnings
1145          (append (cdr spec) disabled-warnings)))
1146       ((always-bound) 
1147        (set! always-bound (append (cdr spec) always-bound)))
1148       ((safe-globals) (set! safe-globals-flag #t))
1149       ((no-procedure-checks-for-usual-bindings)
1150        (set! always-bound-to-procedure
1151          (append default-standard-bindings default-extended-bindings always-bound-to-procedure))
1152        (set! always-bound
1153          (append default-standard-bindings default-extended-bindings always-bound)) )
1154       ((bound-to-procedure)
1155        (let ((vars (cdr spec)))
1156          (set! always-bound-to-procedure (append vars always-bound-to-procedure))
1157          (set! always-bound (append vars always-bound)) ) )
1158       ((foreign-declare)
1159        (let ([fds (cdr spec)])
1160          (if (every string? fds)
1161              (set! foreign-declarations (append foreign-declarations fds))
1162              (syntax-error "invalid declaration" spec) ) ) )
1163       ((custom-declare)
1164        (if (or (not (list? spec)) (not (list? (cadr spec))) (< (length (cadr spec)) 3))
1165            (syntax-error "invalid declaration" spec)
1166            (process-custom-declaration (cadr spec) (cddr spec)) ) )
1167       ((c-options)
1168        (emit-control-file-item `(c-options ,@(cdr spec))) )
1169       ((link-options)
1170        (emit-control-file-item `(link-options ,@(cdr spec))) )
1171       ((post-process)
1172        (emit-control-file-item
1173         (let ([file (pathname-strip-extension source-filename)])
1174           `(post-process ,@(map (cut string-substitute "\\$@" file <>) (cdr spec))) ) ) )
1175       ((block) (set! block-compilation #t))
1176       ((separate) (set! block-compilation #f))
1177       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
1178       ((unused)
1179        (set! unused-variables (append (cdr spec) unused-variables)))
1180       ((not)
1181        (check-decl spec 1)
1182        (case (second spec)
1183          [(standard-bindings)
1184           (if (null? (cddr spec))
1185               (set! standard-bindings '())
1186               (set! standard-bindings
1187                 (lset-difference eq? default-standard-bindings
1188                                  (cddr spec)))) ]
1189          [(extended-bindings)
1190           (if (null? (cddr spec))
1191               (set! extended-bindings '())
1192               (set! extended-bindings 
1193                 (lset-difference eq? default-extended-bindings
1194                                  (cddr spec)) )) ]
1195          [(inline)
1196           (if (null? (cddr spec))
1197               (set! inline-max-size -1)
1198               (set! not-inline-list (lset-union eq? not-inline-list
1199                                                 (cddr spec))) ) ]
1200          [(usual-integrations)     
1201           (cond [(null? (cddr spec))
1202                  (set! standard-bindings '())
1203                  (set! extended-bindings '()) ]
1204                 [else
1205                  (let ([syms (cddr spec)])
1206                    (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
1207                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
1208          [else
1209           (check-decl spec 1 1)
1210           (let ((id (cadr spec)))
1211             (case id
1212               [(interrupts-enabled) (set! insert-timer-checks #f)]
1213               [(safe) 
1214                (set! unsafe #t)
1215                (##match#set-error-control #:unspecified) ]
1216               [else (compiler-warning 'syntax "illegal declaration specifier `~s'" id)]))]))
1217       ((run-time-macros) (set! ##sys#enable-runtime-macros #t))
1218       ((block-global hide) 
1219        (let ([syms (cdr spec)])
1220          (when export-list 
1221            (set! export-list (lset-difference eq? export-list syms)) )
1222          (set! block-globals (lset-union eq? syms block-globals)) ) )
1223       ((export) 
1224        (let ((syms (cdr spec)))
1225          (set! block-globals (lset-difference eq? block-globals syms))
1226          (set! export-list (lset-union eq? syms (or export-list '())))))
1227       ((emit-exports)
1228        (cond ((null? (cdr spec))
1229               (quit "invalid `emit-exports' declaration" spec) )
1230              ((not export-file-name) 
1231               (set! export-file-name (cadr spec))) ) )
1232       ((emit-external-prototypes-first)
1233        (set! external-protos-first #t) )
1234       ((lambda-lift) (set! do-lambda-lifting #t))
1235       ((inline)
1236        (if (null? (cdr spec))
1237            (unless (> inline-max-size -1)
1238              (set! inline-max-size default-inline-max-size) )
1239            (set! inline-list (lset-union eq? inline-list (cdr spec)))) ) 
1240       ((inline-limit)
1241        (check-decl spec 1 1)
1242        (set! inline-max-size
1243          (let ([n (cadr spec)])
1244            (if (number? n)
1245                n
1246                (quit "invalid argument to `inline-limit' declaration" spec) ) ) ) )
1247       ((constant)
1248        (let ((syms (cdr spec)))
1249          (if (every symbol? syms)
1250              (set! constant-declarations (append syms constant-declarations))
1251              (quit "invalid arguments to `constant' declaration: ~S" spec)) ) )
1252       ((import)
1253        (let-values (((syms strs) 
1254                      (partition
1255                       (lambda (x)
1256                         (cond ((symbol? x) #t)
1257                               ((string? x) #f)
1258                               (else (quit "argument to `import' declaration is not a string or symbol" x)) ) )
1259                       (cdr spec) ) ) )
1260          (set! use-import-table #t)
1261          (for-each
1262           (cut ##sys#hash-table-set! import-table <> "<here>") 
1263           syms)
1264          (for-each lookup-exports-file strs) ) )
1265       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
1266     '(##core#undefined) ) ) )
1267
1268
1269;;; Expand "foreign-lambda"/"foreign-callback-lambda" forms and add item to stub-list:
1270
1271(define-record-type foreign-stub
1272  (make-foreign-stub id return-type name argument-types argument-names body cps callback)
1273  foreign-stub?
1274  (id foreign-stub-id)                  ; symbol
1275  (return-type foreign-stub-return-type)          ; type-specifier
1276  (name foreign-stub-name)                        ; string or #f
1277  (argument-types foreign-stub-argument-types) ; (type-specifier...)
1278  (argument-names foreign-stub-argument-names) ; #f or (symbol ...)
1279  (body foreign-stub-body)                     ; #f or string
1280  (cps foreign-stub-cps)                       ; boolean
1281  (callback foreign-stub-callback))            ; boolean
1282
1283(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
1284  (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
1285         [f-id (gensym 'stub)]
1286         [bufvar (gensym)] 
1287         [rsize (estimate-foreign-result-size rtype)] )
1288    (set-real-name! f-id #t)
1289    (set! foreign-lambda-stubs 
1290      (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
1291            foreign-lambda-stubs) )
1292    (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
1293          [head (if cps
1294                    `((##core#primitive ,f-id))
1295                    `(##core#inline ,f-id) ) ]
1296          [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
1297      `(lambda ,params
1298         ;; Do minor GC (if callback) to make room on stack:
1299         ,@(if callback '((##sys#gc #f)) '())
1300         ,(if (zero? rsize) 
1301              (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
1302              (let ([ft (final-foreign-type rtype)]
1303                    [ws (words rsize)] )
1304                `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)])
1305                   ,(foreign-type-convert-result
1306                     (finish-foreign-result ft (append head (cons bufvar rest)))
1307                     rtype) ) ) ) ) ) ) )
1308
1309(define (expand-foreign-lambda exp)
1310  (let* ([name (cadr (third exp))]
1311         [sname (cond ((symbol? name) (symbol->string name))
1312                      ((string? name) name)
1313                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
1314         [rtype (cadr (second exp))]
1315         [argtypes (map second (cdddr exp))] )
1316    (create-foreign-stub rtype sname argtypes #f #f #f #f) ) )
1317
1318(define (expand-foreign-callback-lambda exp)
1319  (let* ([name (cadr (third exp))]
1320         [sname (cond ((symbol? name) (symbol->string name))
1321                      ((string? name) name)
1322                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
1323         [rtype (cadr (second exp))]
1324         [argtypes (map second (cdddr exp))] )
1325    (create-foreign-stub rtype sname argtypes #f #f #t #t) ) )
1326
1327(define (expand-foreign-lambda* exp)
1328  (let* ([rtype (cadr (second exp))]
1329         [args (cadr (third exp))]
1330         [body (apply string-append (map cadr (cdddr exp)))]
1331         [argtypes (map car args)]
1332         [argnames (map cadr args)] )
1333    (create-foreign-stub rtype #f argtypes argnames body #f #f) ) )
1334
1335(define (expand-foreign-callback-lambda* exp)
1336  (let* ([rtype (cadr (second exp))]
1337         [args (cadr (third exp))]
1338         [body (apply string-append (map cadr (cdddr exp)))]
1339         [argtypes (map car args)]
1340         [argnames (map cadr args)] )
1341    (create-foreign-stub rtype #f argtypes argnames body #t #t) ) )
1342
1343(define (expand-foreign-primitive exp)
1344  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (cadr (caddr exp)))))]
1345         [rtype (if hasrtype (cadr (second exp)) 'void)]
1346         [args (if hasrtype (cadr (third exp)) (cadr (second exp)))]
1347         [body (apply string-append (map cadr (if hasrtype (cdddr exp) (cddr exp))))]
1348         [argtypes (map car args)]
1349         [argnames (map cadr args)] )
1350    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
1351
1352
1353;;; Traverse expression and update line-number db with all contained calls:
1354
1355(define (update-line-number-database! exp ln)
1356  (define (mapupdate xs)
1357    (let loop ((xs xs))
1358      (if (pair? xs)
1359          (begin
1360            (walk (car xs))
1361            (loop (cdr xs)) ) ) ) )
1362  (define (walk x)
1363    (cond ((not-pair? x))
1364          ((symbol? (car x))
1365           (let* ((name (car x))
1366                  (old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) )
1367             (if (not (assq x old))
1368                 (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) )
1369             (mapupdate (cdr x)) ) )
1370          (else (mapupdate x)) ) )
1371  (walk exp) )
1372
1373
1374;;; Convert canonicalized node-graph into continuation-passing-style:
1375
1376(define (perform-cps-conversion node)
1377
1378  (define (cps-lambda id llist subs k)
1379    (let ([t1 (gensym 'k)])
1380      (k (make-node
1381          '##core#lambda (list id #t (cons t1 llist) 0)
1382          (list (walk (car subs)
1383                      (lambda (r) 
1384                        (make-node '##core#call '(#t) (list (varnode t1) r)) ) ) ) ) ) ) )
1385 
1386  (define (walk n k)
1387    (let ((subs (node-subexpressions n))
1388          (params (node-parameters n)) 
1389          (class (node-class n)) )
1390      (case (node-class n)
1391        ((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n))
1392        ((if) (let* ((t1 (gensym 'k))
1393                     (t2 (gensym 'r))
1394                     (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
1395                (make-node 'let
1396                           (list t1)
1397                           (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0) 
1398                                            (list (k (varnode t2))) )
1399                                 (walk (car subs)
1400                                       (lambda (v)
1401                                         (make-node 'if '()
1402                                                    (list v
1403                                                          (walk (cadr subs) k1)
1404                                                          (walk (caddr subs) k1) ) ) ) ) ) ) ) )
1405        ((let) (let loop ((vars params) (vals subs))
1406                 (if (null? vars)
1407                     (walk (car vals) k)
1408                     (walk (car vals)
1409                           (lambda (r) 
1410                             (make-node 'let
1411                                        (list (car vars))
1412                                        (list r (loop (cdr vars) (cdr vals))) ) ) ) ) ) )
1413        ((lambda) (cps-lambda (gensym-f-id) (first params) subs k))
1414        ((set!) (let ((t1 (gensym 't)))
1415                  (walk (car subs)
1416                        (lambda (r)
1417                          (make-node 'let (list t1)
1418                                     (list (make-node 'set! (list (first params)) (list r))
1419                                           (k (varnode t1)) ) ) ) ) ) )
1420        ((##core#foreign-callback-wrapper)
1421         (let ([id (gensym-f-id)]
1422               [lam (first subs)] )
1423           (set! foreign-callback-stubs
1424             (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
1425           (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
1426        ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref 
1427                        ##core#inline_loc_update)
1428         (walk-inline-call class params subs k) )
1429        ((##core#call) (walk-call (car subs) (cdr subs) params k))
1430        ((##core#callunit) (walk-call-unit (first params) k))
1431        (else (bomb "bad node (cps)")) ) ) )
1432 
1433  (define (walk-call fn args params k)
1434    (let ((t0 (gensym 'k))
1435          (t3 (gensym 'r)) )
1436      (make-node
1437       'let (list t0)
1438       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) 
1439                        (list (k (varnode t3))) )
1440             (walk-arguments
1441              args
1442              (lambda (vars)
1443                (walk fn
1444                      (lambda (r) 
1445                        (make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
1446 
1447  (define (walk-call-unit unitname k)
1448    (let ((t0 (gensym 'k))
1449          (t3 (gensym 'r)) )
1450      (make-node
1451       'let (list t0)
1452       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) 
1453                        (list (k (varnode t3))) )
1454             (make-node '##core#callunit (list unitname)
1455                        (list (varnode t0)) ) ) ) ) )
1456
1457  (define (walk-inline-call class op args k)
1458    (walk-arguments
1459     args
1460     (lambda (vars)
1461       (k (make-node class op vars)) ) ) )
1462 
1463  (define (walk-arguments args wk)
1464    (let loop ((args args) (vars '()))
1465      (cond ((null? args) (wk (reverse vars)))
1466            ((atomic? (car args))
1467             (loop (cdr args) (cons (car args) vars)) )
1468            (else
1469             (let ((t1 (gensym 'a)))
1470               (walk (car args)
1471                     (lambda (r)
1472                       (make-node 'let (list t1)
1473                                  (list r
1474                                        (loop (cdr args) 
1475                                              (cons (varnode t1) vars) ) ) ) ) ) ) ) ) ) )
1476 
1477  (define (atomic? n)
1478    (let ((class (node-class n)))
1479      (or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref))
1480          (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update
1481                                           ##core#inline_loc_ref ##core#inline_loc_update))
1482               (every atomic? (node-subexpressions n)) ) ) ) )
1483 
1484  (walk node values) )
1485
1486
1487;;; Foreign callback stub type:
1488
1489(define-record-type foreign-callback-stub
1490  (make-foreign-callback-stub id name qualifiers return-type argument-types)
1491  foreign-callback-stub?
1492  (id foreign-callback-stub-id)         ; symbol
1493  (name foreign-callback-stub-name)     ; string
1494  (qualifiers foreign-callback-stub-qualifiers) ; string
1495  (return-type foreign-callback-stub-return-type) ; type-specifier
1496  (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)
1497
1498
1499;;; Perform source-code analysis:
1500
1501(define (analyze-expression node)
1502  (let ([db (make-vector analysis-database-size '())]
1503        [explicitly-consed '()] )
1504
1505    (define (grow n)
1506      (set! current-program-size (+ current-program-size n)) )
1507
1508    (define (walk n env localenv here call)
1509      (let ((subs (node-subexpressions n))
1510            (params (node-parameters n)) 
1511            (class (node-class n)) )
1512        (grow 1)
1513        (case class
1514          ((quote ##core#undefined ##core#proc) #f)
1515
1516          ((##core#variable)
1517           (let ((var (first params)))
1518             (ref var n)
1519             (unless (memq var localenv)
1520               (grow 1)
1521               (cond ((memq var env) (put! db var 'captured #t))
1522                     ((not (get db var 'global)) (put! db var 'global #t) ) ) ) ) )
1523         
1524          ((##core#global-ref)
1525           (let ((var (first params)))
1526             (ref var n)
1527             (grow 1)
1528             (put! db var 'global #t) ) )
1529         
1530          ((##core#callunit ##core#recurse)
1531           (grow 1)
1532           (walkeach subs env localenv here #f) )
1533
1534          ((##core#call)
1535           (grow 1)
1536           (let ([fun (car subs)])
1537             (if (eq? '##core#variable (node-class fun))
1538                 (let ([name (first (node-parameters fun))])
1539                   (collect! db name 'call-sites (cons here n))
1540                   ;; If call to standard-binding & optimizable rest-arg operator: decrease access count:
1541                   (if (and (get db name 'standard-binding)
1542                            (memq name optimizable-rest-argument-operators) )
1543                       (for-each
1544                        (lambda (arg)
1545                          (and-let* ([(eq? '##core#variable (node-class arg))]
1546                                     [var (first (node-parameters arg))] )
1547                            (when (get db var 'rest-parameter) (count! db var 'o-r/access-count)) ) )
1548                        (cdr subs) ) ) ) )
1549             (walk (first subs) env localenv here #t)
1550             (walkeach (cdr subs) env localenv here #f) ) )
1551
1552          ((let)
1553           (let ([env2 (append params localenv env)])
1554             (let loop ([vars params] [vals subs])
1555               (if (null? vars)
1556                   (walk (car vals) env (append params localenv) here #f)
1557                   (let ([var (car vars)]
1558                         [val (car vals)] )
1559                     (put! db var 'home here)
1560                     (assign var val env2 here)
1561                     (walk val env localenv here #f) 
1562                     (loop (cdr vars) (cdr vals)) ) ) ) ) )
1563
1564          ((lambda)                     ; will this actually be ever used? aren't all lambdas now ##core#lambdas?
1565           (grow 1)
1566           (decompose-lambda-list
1567            (first params)
1568            (lambda (vars argc rest)
1569              (for-each
1570               (lambda (var) (put! db var 'unknown #t))
1571               vars)
1572              (let ([tl toplevel-scope])
1573                (set! toplevel-scope #f)
1574                (walk (car subs) (append localenv env) vars #f #f)
1575                (set! toplevel-scope tl) ) ) ) )
1576
1577          ((##core#lambda ##core#direct_lambda)
1578           (grow 1)
1579           (decompose-lambda-list
1580            (third params)
1581            (lambda (vars argc rest)
1582              (let ([id (first params)]
1583                    [size0 current-program-size] )
1584                (when here
1585                  (collect! db here 'contains id)
1586                  (put! db id 'contained-in here) )
1587                (for-each
1588                 (lambda (var)
1589                   (put! db var 'home here)
1590                   (put! db var 'unknown #t) )
1591                 vars)
1592                (when rest
1593                  (put! db rest 'rest-parameter
1594                        (if (memq rest rest-parameters-promoted-to-vector)
1595                            'vector
1596                            'list) ) )
1597                (when (simple-lambda-node? n) (put! db id 'simple #t))
1598                (let ([tl toplevel-scope])
1599                  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
1600                  (when (and (second params) (not (eq? toplevel-lambda-id id)))
1601                    (set! toplevel-scope #f)) ; only if non-CPS lambda
1602                  (walk (car subs) (append localenv env) vars id #f)
1603                  (set! toplevel-scope tl)
1604                  (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
1605         
1606          ((set!) 
1607           (let* ([var (first params)]
1608                  [val (car subs)] )
1609             (when first-analysis 
1610               (cond [(get db var 'standard-binding)
1611                      (compiler-warning 'redef "redefinition of standard binding `~S'" var) ]
1612                     [(get db var 'extended-binding)
1613                      (compiler-warning 'redef "redefinition of extended binding `~S'" var) ] )
1614               (put! db var 'potential-value val) )
1615             (when (and (not (memq var localenv)) 
1616                        (not (memq var env)) )
1617               (grow 1)
1618               (when first-analysis
1619                 (when (or block-compilation (and export-list (not (memq var export-list))))
1620                   (set! block-globals (lset-adjoin eq? block-globals var)) ) )
1621               (put! db var 'global #t) )
1622             (assign var val (append localenv env) here)
1623             (unless toplevel-scope (put! db var 'assigned-locally #t))
1624             (put! db var 'assigned #t)
1625             (walk (car subs) env localenv here #f) ) )
1626
1627          ((##core#primitive ##core#inline)
1628           (let ([id (first params)])
1629             (when (and first-analysis here (symbol? id) (##sys#hash-table-ref real-name-table id))
1630               (set-real-name! id here) )
1631             (walkeach subs env localenv here #f) ) )
1632
1633          (else (walkeach subs env localenv here #f)) ) ) )
1634
1635    (define (walkeach xs env lenv here call) 
1636      (for-each (lambda (x) (walk x env lenv here call)) xs) )
1637
1638    (define (assign var val env here)
1639      (cond ((eq? '##core#undefined (node-class val))
1640             (put! db var 'undefined #t) )
1641            ((and (eq? '##core#variable (node-class val))
1642                  (eq? var (first (node-parameters val))) ) )
1643            ((or block-compilation
1644                 (memq var env)
1645                 (get db var 'constant)
1646                 ;;(memq var inline-list)       - would be nice, but might be customized...
1647                 (memq var block-globals) )
1648             (let ((props (get-all db var 'unknown 'value))
1649                   (home (get db var 'home)) )
1650               (unless (assq 'unknown props)
1651                 (if (assq 'value props)
1652                     (put! db var 'unknown #t)
1653                     (if (or (not home) (eq? here home))
1654                         (put! db var 'value val)
1655                         (put! db var 'unknown #t) ) ) ) ) )
1656            (else (put! db var 'unknown #t)) ) )
1657   
1658    (define (ref var node)
1659      (collect! db var 'references node) )
1660
1661    (define (quick-put! plist prop val)
1662      (set-cdr! plist (alist-cons prop val (cdr plist))) )
1663
1664    ;; Return true if <id> directly or indirectly contains any of <other-ids>:
1665    (define (contains? id other-ids)
1666      (or (memq id other-ids)
1667          (let ((clist (get db id 'contains)))
1668            (and clist
1669                 (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) )
1670
1671    ;; Initialize database:
1672    (initialize-analysis-database db)
1673
1674    ;; Walk toplevel expression-node:
1675    (debugging 'p "analysis traversal phase...")
1676    (set! current-program-size 0)
1677    (walk node '() '() #f #f) 
1678
1679    ;; Complete gathered database information:
1680    (debugging 'p "analysis gathering phase...")
1681    (##sys#hash-table-for-each
1682     (lambda (sym plist)
1683       (let ([unknown #f]
1684             [value #f]
1685             [pvalue #f]
1686             [references '()]
1687             [captured #f]
1688             [call-sites '()]
1689             [assigned #f]
1690             [assigned-locally #f]
1691             [undefined #f]
1692             [global #f]
1693             [o-r/access-count 0]
1694             [rest-parameter #f] 
1695             [nreferences 0]
1696             [ncall-sites 0] )
1697
1698         (for-each
1699          (lambda (prop)
1700            (case (car prop)
1701              [(unknown) (set! unknown #t)]
1702              [(references) 
1703               (set! references (cdr prop))
1704               (set! nreferences (length references)) ]
1705              [(captured) (set! captured #t)]
1706              [(potential-value) (set! pvalue (cdr prop))]
1707              [(call-sites)
1708               (set! call-sites (cdr prop))
1709               (set! ncall-sites (length call-sites)) ]
1710              [(assigned) (set! assigned #t)]
1711              [(assigned-locally) (set! assigned-locally #t)]
1712              [(undefined) (set! undefined #t)]
1713              [(global) (set! global #t)]
1714              [(value) (set! value (cdr prop))]
1715              [(o-r/access-count) (set! o-r/access-count (cdr prop))]
1716              [(rest-parameter) (set! rest-parameter #t)] ) )
1717          plist)
1718
1719         (set! value (and (not unknown) value))
1720
1721         ;; If this is the first analysis, register known local or potentially known global lambda-value id's
1722         ;;  along with their names:
1723         (when (and first-analysis 
1724                    (eq? '##core#lambda
1725                         (and-let* ([val (or value (and global pvalue))])
1726                           (node-class val) ) ) )
1727           (set-real-name! (first (node-parameters (or value pvalue))) sym) )
1728
1729         ;; If this is the first analysis and the variable is global and has no references and we are
1730         ;;  in block mode, then issue warning:
1731         (when (and first-analysis 
1732                    global
1733                    (null? references)
1734                    (not (memq sym unused-variables)))
1735           (when assigned-locally
1736             (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )
1737           (when (and (or block-compilation
1738                          (and export-list (not (memq sym export-list))) )
1739                      (not (assq sym mutable-constants)) )
1740             (compiler-warning 'var "global variable `~S' is never used" sym) ) )
1741
1742         ;; Make 'boxed, if 'assigned & 'captured:
1743         (when (and assigned captured)
1744           (quick-put! plist 'boxed #t) )
1745
1746         ;; Make 'contractable, if it has a procedure as known value, has only one use and one call-site and
1747         ;;  if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
1748         ;;  use/call count is not 1:
1749         (when value
1750           (let ((valparams (node-parameters value)))
1751             (when (and (eq? '##core#lambda (node-class value))
1752                        (or (not (second valparams))
1753                            (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) )
1754               (if (and (= 1 nreferences) (= 1 ncall-sites))
1755                   (quick-put! plist 'contractable #t)
1756                   (quick-put! plist 'inlinable #t) ) ) ) )
1757
1758         ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only
1759         ;;  referenced once and if no assignments are made:
1760         (when (and value
1761                    ;; (not (assq 'assigned plist)) - If it has a known value, it's assigned just once!
1762                    (eq? 'quote (node-class value)) )
1763           (let ((val (first (node-parameters value))))
1764             (when (or (collapsable-literal? val)
1765                       (= 1 nreferences) )
1766               (quick-put! plist 'collapsable #t) ) ) )
1767               
1768         ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the
1769         ;;  number of references (does not escape), then make all formal parameters 'unused which are
1770         ;;  never referenced or assigned (if no rest parameter exist):
1771         ;;  - also marks the procedure as 'has-unused-parameters (if not in `callback-names')
1772         ;;  - if the procedure is internal (a continuation) do NOT mark unused parameters.
1773         ;;  - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
1774         (when value
1775           (let ([has #f])
1776             (when (and (eq? '##core#lambda (node-class value))
1777                        (= nreferences ncall-sites) )
1778               (let ([lparams (node-parameters value)])
1779                 (when (second lparams)
1780                   (decompose-lambda-list
1781                    (third lparams)
1782                    (lambda (vars argc rest)
1783                      (unless rest
1784                        (for-each
1785                         (lambda (var)
1786                           (cond [(and (not (get db var 'references))
1787                                       (not (get db var 'assigned)) )
1788                                  (put! db var 'unused #t)
1789                                  (set! has #t)
1790                                  #t]
1791                                 [else #f] ) )
1792                         vars) )
1793                      (cond [(and has (not (memq sym callback-names)))
1794                             (put! db (first lparams) 'has-unused-parameters #t) ]
1795                            [rest
1796                             (set! explicitly-consed (cons rest explicitly-consed))
1797                             (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
1798
1799         ;;  Make 'removable, if it has no references and is not assigned to, and if it has either a value that
1800         ;;    does not cause any side-effects or if it is 'undefined:
1801         (when (and (not assigned)
1802                    (null? references)
1803                    (or (and value
1804                             (or (not (eq? '##core#variable (node-class value)))
1805                                 (not (get db (first (node-parameters value)) 'global)) )
1806                             (not (expression-has-side-effects? value db)) )
1807                        undefined) )
1808           (quick-put! plist 'removable #t) )
1809
1810         ;; Make 'replacable, if it has a variable as known value and if either that variable has
1811         ;;  a known value itself, or if it is not captured and referenced only once, the target and
1812         ;;  the source are never assigned and the source is non-global or we are in block-mode:
1813         ;;  - The target-variable is not allowed to be global.
1814         ;;  - The variable that can be substituted for the current one is marked as 'replacing.
1815         ;;    This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if
1816         ;;    it was contracted).
1817         (when (and value (not global))
1818           (when (eq? '##core#variable (node-class value))
1819             (let* ([name (first (node-parameters value))]
1820                    [nrefs (get db name 'references)] )
1821               (when (or (and (not (get db name 'unknown)) (get db name 'value))
1822                         (and (not (get db name 'captured))
1823                              nrefs
1824                              (= 1 (length nrefs))
1825                              (not assigned)
1826                              (not (get db name 'assigned)) 
1827                              (or block-compilation (not (get db name 'global))) ) )
1828                 (quick-put! plist 'replacable name) 
1829                 (put! db name 'replacing #t) ) ) ) )
1830
1831         ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
1832         ;;  is an internally created procedure: (See above for 'replacing)
1833         (when (and value (eq? '##core#lambda (node-class value)))
1834           (let ([params (node-parameters value)])
1835             (when (not (second params))
1836               (let ([llist (third params)]
1837                     [body (first (node-subexpressions value))] )
1838                 (when (and (pair? llist) 
1839                            (null? (cdr llist))
1840                            (eq? '##core#call (node-class body)) )
1841                   (let ([subs (node-subexpressions body)])
1842                     (when (= 2 (length subs))
1843                       (let ([v1 (first subs)]
1844                             [v2 (second subs)] )
1845                         (when (and (eq? '##core#variable (node-class v1))
1846                                    (eq? '##core#variable (node-class v2))
1847                                    (eq? (first llist) (first (node-parameters v2))) )
1848                           (let ([kvar (first (node-parameters v1))])
1849                             (quick-put! plist 'replacable kvar)
1850                             (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) )
1851
1852         ;; If a rest-argument, convert 'rest-parameter property to 'vector, if the variable is never
1853         ;;  assigned, and the number of references is identical to the number of accesses in optimizable
1854         ;;  rest-argument operators:
1855         ;; - Add variable to "rest-parameters-promoted-to-vector", because subsequent optimization will
1856         ;;   change variables context (operators applied to it).
1857         (when (and rest-parameter
1858                    (not assigned)
1859                    (= nreferences o-r/access-count) )
1860           (set! rest-parameters-promoted-to-vector (lset-adjoin eq? rest-parameters-promoted-to-vector sym))
1861           (put! db sym 'rest-parameter 'vector) ) ) )
1862
1863     db)
1864
1865    ;; Remove explicitly consed rest parameters from promoted ones:
1866    (set! rest-parameters-promoted-to-vector
1867      (lset-difference eq? rest-parameters-promoted-to-vector explicitly-consed) )
1868
1869    ;; Set original program-size, if this is the first analysis-pass:
1870    (unless original-program-size
1871      (set! original-program-size current-program-size) )
1872    db) )
1873
1874
1875;;; Convert closures to explicit data structures (effectively flattens function-binding structure):
1876
1877(define (perform-closure-conversion node db)
1878  (let ([direct-calls 0]
1879        [customizable '()] )
1880
1881    (define (test sym item) (get db sym item))
1882 
1883    (define (register-customizable! var id)
1884      (set! customizable (lset-adjoin eq? customizable var)) 
1885      (put! db id 'customizable #t) )
1886
1887    (define (register-direct-call! id)
1888      (set! direct-calls (add1 direct-calls))
1889      (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) )
1890
1891    ;; Gather free-variable information:
1892    ;; (and: - register direct calls
1893    ;;       - update (by mutation) call information in "##core#call" nodes)
1894    (define (gather n here env)
1895      (let ((subs (node-subexpressions n))
1896            (params (node-parameters n)) )
1897        (case (node-class n)
1898
1899          ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f)
1900
1901          ((let)
1902           (receive (vals body) (split-at subs (length params))
1903             (for-each (lambda (n) (gather n here env)) vals)
1904             (gather (first body) here (append params env)) ) )
1905
1906          ((##core#call)
1907           (let* ([fn (first subs)]
1908                  [mode (first params)]
1909                  [name (and (pair? (cdr params)) (second params))]
1910                  [varfn (eq? '##core#variable (node-class fn))] )
1911             (node-parameters-set!
1912              n
1913              (cons mode
1914                    (if (or name varfn)
1915                        (cons name
1916                              (if varfn
1917                                  (let* ([varname (first (node-parameters fn))]
1918                                         [val (and (not (test varname 'unknown)) (test varname 'value))] )
1919                                    (if (and val (eq? '##core#lambda (node-class val)))
1920                                        (let* ([params (node-parameters val)]
1921                                               [llist (third params)]
1922                                               [id (first params)]
1923                                               [refs (test varname 'references)]
1924                                               [sites (test varname 'call-sites)] 
1925                                               [custom
1926                                                (and refs sites
1927                                                     (= (length refs) (length sites)) 
1928                                                     (proper-list? llist) ) ] )
1929                                          (when (and name custom (not (= (length llist) (length (cdr subs)))))
1930                                            (quit
1931                                             "known procedure called with wrong number of arguments: ~A" 
1932                                             (source-info->string name) ) )
1933                                          (register-direct-call! id)
1934                                          (when custom (register-customizable! varname id)) 
1935                                          (list id custom) )
1936                                        '() ) )
1937                                  '() ) )
1938                        '() ) ) )
1939             (for-each (lambda (n) (gather n here env)) subs) ) )
1940
1941          ((##core#lambda ##core#direct_lambda)
1942           (decompose-lambda-list
1943            (third params)
1944            (lambda (vars argc rest)
1945              (let* ([id (if here (first params) 'toplevel)]
1946                     [capturedvars (captured-variables (car subs) env)]
1947                     [csize (length capturedvars)] )
1948                (put! db id 'closure-size csize)
1949                (put! db id 'captured-variables capturedvars)
1950                (gather (car subs) id (append vars env)) ) ) ) )
1951       
1952          (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
1953
1954    ;; Create explicit closures:
1955    (define (transform n here closure)
1956      (let ((subs (node-subexpressions n))
1957            (params (node-parameters n)) 
1958            (class (node-class n)) )
1959        (case class
1960
1961          ((quote ##core#undefined ##core#proc ##core#global-ref) n)
1962
1963          ((##core#variable)
1964           (let* ((var (first params))
1965                  (val (ref-var n here closure)) )
1966             (if (test var 'boxed)
1967                 (make-node '##core#unbox '() (list val))
1968                 val) ) )
1969
1970          ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit ##core#inline_ref ##core#inline_update 
1971               ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return ##core#inline_loc_ref
1972               ##core#inline_loc_update)
1973           (make-node (node-class n) params (maptransform subs here closure)) )
1974
1975          ((let)
1976           (let* ([var (first params)]
1977                  [boxedvar (test var 'boxed)]
1978                  [boxedalias (gensym var)] )
1979             (if boxedvar
1980                 (make-node 
1981                  'let (list boxedalias)
1982                  (list (transform (first subs) here closure)
1983                        (make-node
1984                         'let (list var)
1985                         (list (make-node '##core#box '() (list (varnode boxedalias)))
1986                               (transform (second subs) here closure) ) ) ) )
1987                 (make-node
1988                  'let params
1989                  (maptransform subs here closure) ) ) ) )
1990
1991          ((##core#lambda ##core#direct_lambda)
1992           (let ([llist (third params)])
1993             (decompose-lambda-list
1994              llist
1995              (lambda (vars argc rest)
1996                (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)]
1997                       [boxedaliases (map cons boxedvars (map gensym boxedvars))]
1998                       [cvar (gensym 'c)]
1999                       [id (if here (first params) 'toplevel)]
2000                       [capturedvars (or (test id 'captured-variables) '())]
2001                       [csize (or (test id 'closure-size) 0)] 
2002                       [info (and emit-closure-info (second params) (pair? llist))] )
2003                  ;; If rest-parameter is boxed: mark it as 'boxed-rest
2004                  ;;  (if we don't do this than preparation will think the (boxed) alias
2005                  ;;  of the rest-parameter is never used)
2006                  (and-let* ([rest]
2007                             [(test rest 'boxed)]
2008                             [rp (test rest 'rest-parameter)] )
2009                    (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
2010                  (make-node
2011                   '##core#closure (list (+ csize (if info 2 1)))
2012                   (cons
2013                    (make-node
2014                     class
2015                     (list id
2016                           (second params)
2017                           (cons
2018                            cvar
2019                            (build-lambda-list
2020                             (map (lambda (v)
2021                                    (cond ((assq v boxedaliases) => cdr)
2022                                          (else v) ) )
2023                                  vars)
2024                             argc
2025                             (cond ((and rest (assq rest boxedaliases)) => cdr)
2026                                   (else rest) ) ) )
2027                           (fourth params) )
2028                     (list (let ((body (transform (car subs) cvar capturedvars)))
2029                             (if (pair? boxedvars)
2030                                 (fold-right
2031                                  (lambda (alias val body) (make-node 'let (list alias) (list val body)))
2032                                  body
2033                                  (unzip1 boxedaliases)
2034                                  (map (lambda (a) (make-node '##core#box '() (list (varnode (cdr a)))))
2035                                       boxedaliases) )
2036                                 body) ) ) )
2037                    (let ((cvars (map (lambda (v) (ref-var (varnode v) here closure))
2038                                      capturedvars) ) )
2039                      (if info
2040                          (append
2041                           cvars
2042                           (list
2043                            (qnode 
2044                             (##sys#make-lambda-info
2045                              (->string (cons (or (real-name id) '?)
2046                                              (cdr llist) )))))) ; this is not always correct, due to optimizations
2047                          cvars) ) ) ) ) ) ) ) )
2048
2049          ((set!)
2050           (let* ([var (first params)]
2051                  [val (first subs)]
2052                  [cval (node-class val)]
2053                  [immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
2054                            (eq? '##core#undefined cval) ) ] )
2055             (cond ((posq var closure)
2056                    => (lambda (i)
2057                         (if (test var 'boxed)
2058                             (make-node
2059                              (if immf '##core#updatebox_i '##core#updatebox)
2060                              '()
2061                              (list (make-node '##core#ref (list (add1 i)) (list (varnode here)))
2062                                    (transform val here closure) ) )
2063                             ;; Is the following actually used???
2064                             (make-node
2065                              (if immf '##core#update_i '##core#update)
2066                              (list (add1 i))
2067                              (list (varnode here)
2068                                    (transform val here closure) ) ) ) ) )
2069                   ((test var 'boxed)
2070                    (make-node
2071                     (if immf '##core#updatebox_i '##core#updatebox)
2072                     '()
2073                     (list (varnode var)
2074                           (transform val here closure) ) ) )
2075                   (else (make-node
2076                          'set! (list var)
2077                          (list (transform val here closure) ) ) ) ) ) )
2078
2079          ((##core#primitive) 
2080           (make-node
2081            '##core#closure (list (if emit-closure-info 2 1))
2082            (cons (make-node '##core#proc (list (car params) #t) '())
2083                  (if emit-closure-info
2084                      (list (qnode (##sys#make-lambda-info (car params))))
2085                      '() ) ) ) )
2086
2087          (else (bomb "bad node (closure2)")) ) ) )
2088
2089    (define (maptransform xs here closure)
2090      (map (lambda (x) (transform x here closure)) xs) )
2091 
2092    (define (ref-var n here closure)
2093      (let ((var (first (node-parameters n))))
2094        (cond ((posq var closure) 
2095               => (lambda (i) 
2096                    (make-node '##core#ref (list (+ i 1)) 
2097                               (list (varnode here)) ) ) )
2098              (else n) ) ) )
2099
2100    (define (captured-variables node env)
2101      (let ([vars '()])
2102        (let walk ([n node])
2103          (let ((subs (node-subexpressions n))
2104                (params (node-parameters n)) )
2105            (case (node-class n)
2106              ((##core#variable)
2107               (let ([var (first params)])
2108                 (when (memq var env)
2109                   (set! vars (lset-adjoin eq? vars var)) ) ) )
2110              ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f)
2111              ((set!) 
2112               (let ([var (first params)])
2113                 (when (memq var env) (set! vars (lset-adjoin eq? vars var)))
2114                 (walk (car subs)) ) )
2115              (else (for-each walk subs)) ) ) )
2116        vars) )
2117
2118    (debugging 'p "closure conversion gathering phase...")
2119    (gather node #f '())
2120    (debugging 'o "customizable procedures" customizable)
2121    (debugging 'p "closure conversion transformation phase...")
2122    (let ((node2 (transform node #f #f)))
2123      (unless (zero? direct-calls)
2124        (debugging 'o "calls to known targets" direct-calls (delay (length direct-call-ids))) )
2125      node2) ) )
2126
2127
2128;;; Do some preparations before code-generation can commence:
2129
2130(define-record-type lambda-literal
2131  (make-lambda-literal id external arguments argument-count rest-argument temporaries
2132                       callee-signatures allocated directly-called closure-size
2133                       looping customizable rest-argument-mode body direct)
2134  lambda-literal?
2135  (id lambda-literal-id)                               ; symbol
2136  (external lambda-literal-external)                   ; boolean
2137  (arguments lambda-literal-arguments)                 ; (symbol...)
2138  (argument-count lambda-literal-argument-count)       ; integer
2139  (rest-argument lambda-literal-rest-argument)         ; symbol | #f
2140  (temporaries lambda-literal-temporaries)             ; integer
2141  (callee-signatures lambda-literal-callee-signatures) ; (integer...)
2142  (allocated lambda-literal-allocated)                 ; integer
2143  (directly-called lambda-literal-directly-called)     ; boolean
2144  (closure-size lambda-literal-closure-size)           ; integer
2145  (looping lambda-literal-looping)                     ; boolean
2146  (customizable lambda-literal-customizable)           ; boolean
2147  (rest-argument-mode lambda-literal-rest-argument-mode) ; #f | LIST | VECTOR | UNUSED
2148  (body lambda-literal-body)                             ; expression
2149  (direct lambda-literal-direct))                        ; boolean
2150 
2151(define (prepare-for-code-generation node db)
2152  (let ([literals '()]
2153        [lambda-info-literals '()]
2154        [lambdas '()]
2155        [temporaries 0]
2156        [allocated 0]
2157        [looping 0]
2158        [signatures '()] 
2159        [fastinits 0] 
2160        [fastrefs 0] 
2161        [fastsets 0] )
2162
2163    (define (walk-var var e sf)
2164      (cond [(posq var e) => (lambda (i) (make-node '##core#local (list i) '()))]
2165            [(keyword? var) (make-node '##core#literal (list (literal var)) '())]
2166            [else (walk-global var sf)] ) )
2167
2168    (define (walk-global var sf)
2169      (let* ([safe (or sf 
2170                       no-bound-checks
2171                       unsafe
2172                       (memq var always-bound)
2173                       (get db var 'standard-binding)
2174                       (get db var 'extended-binding) ) ]
2175             [blockvar (memq var block-globals)] )
2176        (when blockvar (set! fastrefs (add1 fastrefs)))
2177        (make-node
2178         '##core#global
2179         (list (if blockvar
2180                   (blockvar-literal var)
2181                   (literal var) )
2182               safe
2183               blockvar
2184               var)
2185         '() ) ) )
2186
2187    (define (walk n e here boxes)
2188      (let ((subs (node-subexpressions n))
2189            (params (node-parameters n))
2190            (class (node-class n)) )
2191        (case class
2192
2193          ((##core#undefined ##core#proc) n)
2194
2195          ((##core#variable) 
2196           (walk-var (first params) e #f) )
2197
2198          ((##core#global-ref)
2199           (walk-global (first params) #t) )
2200
2201          ((##core#direct_call)
2202           (set! allocated (+ allocated (fourth params)))
2203           (make-node class params (mapwalk subs e here boxes)) )
2204
2205          ((##core#inline_allocate)
2206           (set! allocated (+ allocated (second params)))
2207           (make-node class params (mapwalk subs e here boxes)) )
2208
2209          ((##core#inline_ref)
2210           (set! allocated (+ allocated (words (estimate-foreign-result-size (second params)))))
2211           (make-node class params '()) )
2212
2213          ((##core#inline_loc_ref)
2214           (set! allocated (+ allocated (words (estimate-foreign-result-size (first params)))))
2215           (make-node class params (mapwalk subs e here boxes)) )
2216
2217          ((##core#closure) 
2218           (set! allocated (+ allocated (first params) 1))
2219           (make-node '##core#closure params (mapwalk subs e here boxes)) )
2220
2221          ((##core#box)
2222           (set! allocated (+ allocated 2))
2223           (make-node '##core#box params (list (walk (first subs) e here boxes))) )
2224
2225          ((##core#updatebox)
2226           (let* ([b (first subs)]
2227                  [subs (mapwalk subs e here boxes)] )
2228             (make-node
2229              (cond [(and (eq? '##core#variable (node-class b))
2230                          (memq (first (node-parameters b)) boxes) )
2231                     (set! fastinits (add1 fastinits))
2232                     '##core#updatebox_i]
2233                    [else class] )
2234              '()
2235              subs) ) )
2236
2237          ((##core#lambda ##core#direct_lambda) 
2238           (let ([temps temporaries]
2239                 [sigs signatures]
2240                 [lping looping]
2241                 [alc allocated] 
2242                 [direct (eq? class '##core#direct_lambda)] )
2243             (set! temporaries 0)
2244             (set! allocated 0)
2245             (set! signatures '())
2246             (set! looping 0)
2247             (decompose-lambda-list
2248              (third params)
2249              (lambda (vars argc rest)
2250                (let* ([id (first params)]
2251                       [rest-mode
2252                        (and rest
2253                             (let ([rrefs (get db rest 'references)])
2254                               (cond [(get db rest 'assigned) 'list]
2255                                     [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none] 
2256                                     [else (get db rest 'rest-parameter)] ) ) ) ]
2257                       [body (walk 
2258                              (car subs)
2259                              (if (eq? 'none rest-mode)
2260                                  (butlast vars)
2261                                  vars)
2262                              id
2263                              '()) ] )
2264                  (case rest-mode
2265                    [(none) (debugging 'o "unused rest argument" rest id)]
2266                    [(vector) (debugging 'o "rest argument accessed as vector" rest id)] )
2267                  (when (and direct rest)
2268                    (bomb "bad direct lambda" id allocated rest) )
2269                  (set! lambdas
2270                    (cons (make-lambda-literal
2271                           id
2272                           (second params)
2273                           vars
2274                           argc
2275                           rest
2276                           (add1 temporaries)
2277                           signatures
2278                           allocated
2279                           (or direct (memq id direct-call-ids))
2280                           (or (get db id 'closure-size) 0)
2281                           (and (not rest)
2282                                (> looping 0)
2283                                (begin
2284                                  (debugging 'o "identified direct recursive calls" id looping)
2285                                  #t) )
2286                           (or direct (get db id 'customizable))
2287                           rest-mode
2288                           body
2289                           direct)
2290                          lambdas) )
2291                  (set! looping lping)
2292                  (set! temporaries temps)
2293                  (set! allocated alc)
2294                  (set! signatures sigs)
2295                  (make-node '##core#proc (list (first params)) '()) ) ) ) ) )
2296
2297          ((let)
2298           (let* ([var (first params)]
2299                  [val (first subs)] 
2300                  [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
2301             (set! temporaries (add1 temporaries))
2302             (make-node
2303              '##core#bind (list 1)
2304              (list (walk val e here boxes)
2305                    (walk (second subs) (append e params) here (append boxvars boxes)) ) ) ) )
2306
2307          ((set!)
2308           (let ([var (first params)]
2309                 [val (first subs)] )
2310             (cond ((posq var e)
2311                    => (lambda (i) 
2312                         (make-node '##core#setlocal (list i) (list (walk val e here boxes)) ) ) )
2313                   (else
2314                    (let* ([cval (node-class val)]
2315                           [safe (not (or no-bound-checks
2316                                          unsafe
2317                                          (memq var always-bound)
2318                                          (get db var 'standard-binding)
2319                                          (get db var 'extended-binding) ) ) ]
2320                           [blockvar (memq var block-globals)]
2321                           [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
2322                                     (eq? '##core#undefined cval) ) ] )
2323                      (when blockvar (set! fastsets (add1 fastsets)))
2324                      (make-node
2325                       (if immf '##core#setglobal_i '##core#setglobal)
2326                       (list (if blockvar
2327                                 (blockvar-literal var)
2328                                 (literal var) )
2329                             blockvar)
2330                       (list (walk (car subs) e here boxes)) ) ) ) ) ) )
2331
2332          ((##core#call) 
2333           (let ([len (length (cdr subs))])
2334             (set! signatures (lset-adjoin = signatures len)) 
2335             (when (and (>= (length params) 3) (eq? here (third params)))
2336               (set! looping (add1 looping)) )
2337             (make-node class params (mapwalk subs e here boxes)) ) )
2338
2339          ((##core#recurse)
2340           (when (first params) (set! looping (add1 looping)))
2341           (make-node class params (mapwalk subs e here boxes)) )
2342
2343          ((quote)
2344           (let ((c (first params)))
2345             (cond ((and (fixnum? c) (not (big-fixnum? c)))
2346                    (immediate-literal c) )
2347                   ((number? c)
2348                    (cond ((eq? 'fixnum number-type)
2349                           (cond ((and (integer? c) (not (big-fixnum? c)))
2350                                  (compiler-warning 
2351                                   'type 
2352                                   "coerced inexact literal number `~S' to fixnum ~S" c (inexact->exact c))
2353                                  (immediate-literal (inexact->exact c)) )
2354                                 (else (quit "can not coerce inexact literal `~S' to fixnum" c)) ) )
2355                          (else (make-node '##core#literal (list (literal c)) '())) ) )
2356                   ((immediate? c) (immediate-literal c))
2357                   (else (make-node '##core#literal (list (literal c)) '())) ) ) )
2358
2359          (else (make-node class params (mapwalk subs e here boxes)) ) ) ) )
2360   
2361    (define (mapwalk xs e here boxes)
2362      (map (lambda (x) (walk x e here boxes)) xs) )
2363
2364    (define (literal x)
2365      (cond [(immediate? x) (immediate-literal x)]
2366            [(number? x)
2367             (or (and (inexact? x) 
2368                      (list-index (lambda (y) (and (number? y) (inexact? y) (= x y)))
2369                                  literals) )
2370                 (new-literal x)) ]
2371            ((##core#inline "C_lambdainfop" x)
2372             (let ((i (length lambda-info-literals)))
2373               (set! lambda-info-literals 
2374                 (append lambda-info-literals (list x))) ;*** see below
2375               (vector i) ) )
2376            [(posq x literals) => identity]
2377            [else (new-literal x)] ) )
2378
2379    (define (new-literal x)
2380      (let ([i (length literals)])
2381        (set! literals (append literals (list x))) ;*** could (should) be optimized
2382        i) )
2383
2384    (define (blockvar-literal var)
2385      (or (list-index
2386           (lambda (lit) 
2387             (and (block-variable-literal? lit)
2388                  (eq? var (block-variable-literal-name lit)) ) )
2389           literals)
2390          (new-literal (make-block-variable-literal var)) ) )
2391   
2392    (define (immediate-literal x)
2393      (if (eq? (void) x)
2394          (make-node '##core#undefined '() '())
2395          (make-node '##core#immediate
2396                     (cond ((fixnum? x) `(fix ,x))
2397                           ((boolean? x) `(bool ,x))
2398                           ((char? x) `(char ,x))
2399                           ((null? x) '(nil))
2400                           ((eof-object? x) '(eof))
2401                           (else (bomb "bad immediate (prepare)")) )
2402                     '() ) ) )
2403   
2404    (debugging 'p "preparation phase...")
2405    (let ((node2 (walk node '() #f '())))
2406      (debugging 'o "fast box initializations" fastinits)
2407      (debugging 'o "fast global references" fastrefs)
2408      (debugging 'o "fast global assignments" fastsets)
2409      (values node2 literals lambda-info-literals lambdas) ) ) )
Note: See TracBrowser for help on using the repository browser.