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

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

selective profiling

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