source: project/chicken/branches/release/compiler.scm @ 7276

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

merged trunk

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