source: project/chicken/trunk/compiler.scm @ 5982

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

calls to known procedures with mismatching arglists trigger error instead of warning

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