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

Last change on this file since 15057 was 15057, checked in by felix winkelmann, 11 years ago

fix for begin-capturing bug (#47), removed uses of define-macro

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