source: project/chicken/branches/hygienic/compiler.scm @ 10745

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

module fixes, reexports, -se option for csi, some cleanups, I'm the greatest Scheme hacker on earth

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