source: project/chicken/branches/prerelease/compiler.scm @ 11958

Last change on this file since 11958 was 11958, checked in by Ivan Raikov, 11 years ago

Merged trunk and prerelease.

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