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

Last change on this file since 10439 was 10439, checked in by felix winkelmann, 13 years ago

painfully slowly debugging compiler

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