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

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

added test-case for declarations in modules

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