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

Last change on this file since 12227 was 12227, checked in by felix winkelmann, 12 years ago
  • added helpful script for testing in build dir
  • chicken-install checks for TCP timeouts and handles multiple default sources to download from
  • alias-global-hook is saved and restored when loading compiler extensions
  • making bootstrap automaticaly makes confclean
File size: 90.9 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; ([##core#]set! <variable> <exp>)
94; (##core#named-lambda <name> <llist> <body>)
95; (##core#loop-lambda <llist> <body>)
96; (##core#undefined)
97; (##core#primitive <name>)
98; (##core#inline <op> {<exp>})
99; (##core#inline_allocate (<op> <words>) {<exp>})
100; (##core#inline_ref (<name> <type>))
101; (##core#inline_update (<name> <type>) <exp>)
102; (##core#inline_loc_ref (<type>) <exp>)
103; (##core#inline_loc_update (<type>) <exp> <exp>)
104; (##core#compiletimetoo <exp>)
105; (##core#compiletimeonly <exp>)
106; (##core#elaborationtimetoo <exp>)
107; (##core#elaborationtimeonly <exp>)
108; (define-foreign-variable <symbol> <type> [<string>])
109; (define-foreign-type <symbol> <type> [<proc1> [<proc2>]])
110; (foreign-lambda <type> <string> {<type>})
111; (foreign-lambda* <type> ({(<type> <var>)})) {<string>})
112; (foreign-safe-lambda <type> <string> {<type>})
113; (foreign-safe-lambda* <type> ({(<type> <var>)})) {<string>})
114; (foreign-primitive <type> ({(<type> <var>)}) {<string>})
115; (##core#define-inline <name> <exp>)
116; (define-constant <name> <exp>)
117; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>}) <exp>)
118; (##core#define-external-variable (quote <name>) (quote <type>) (quote <bool>))
119; (##core#check <exp>)
120; (##core#require-for-syntax <exp> ...)
121; (##core#require-extension (<id> ...) <bool>)
122; (##core#app <exp> {<exp>})
123; (##coresyntax <exp>)
124; (<exp> {<exp>})
125; (define-syntax <symbol> <expr>)
126; (define-syntax (<symbol> . <llist>) <expr> ...)
127; (define-compiled-syntax <symbol> <expr>)
128; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
129; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
130;
131; - Core language:
132;
133; [##core#variable {<variable>}]
134; [if {} <exp> <exp> <exp>)]
135; [quote {<exp>}]
136; [let {<variable>} <exp-v> <exp>]
137; [##core#lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
138; [set! {<variable>} <exp>]
139; [##core#undefined {}]
140; [##core#global-ref {<variable>}]
141; [##core#primitive {<name>}]
142; [##core#inline {<op>} <exp>...]
143; [##core#inline_allocate {<op> <words>} <exp>...]
144; [##core#inline_ref {<name> <type>}]
145; [##core#inline_update {<name> <type>} <exp>]
146; [##core#inline_loc_ref {<type>} <exp>]
147; [##core#inline_loc_update {<type>} <exp> <exp>]
148; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
149; [##core#callunit {<unitname>} <exp>...]
150; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
151; [##core#cond <exp> <exp> <exp>]
152; [##core#recurse {<tail-flag>} <exp1> ...]
153; [##core#return <exp>]
154; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
155; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
156;
157; - Closure converted/prepared language:
158;
159; [if {} <exp> <exp> <exp>]
160; [quote {<exp>}]
161; [##core#bind {<count>} <exp-v>... <exp>]
162; [##core#undefined {}]
163; [##core#inline {<op>} <exp>...]
164; [##core#inline_allocate {<op <words>} <exp>...]
165; [##core#inline_ref {<name> <type>}]
166; [##core#inline_update {<name> <type>} <exp>]
167; [##core#inline_loc_ref {<type>} <exp>]
168; [##core#inline_loc_update {<type>} <exp> <exp>]
169; [##core#closure {<count>} <exp>...]
170; [##core#box {} <exp>]
171; [##core#unbox {} <exp>]
172; [##core#ref {<index>} <exp>]
173; [##core#update {<index>} <exp> <exp>]
174; [##core#updatebox {} <exp> <exp>]
175; [##core#update_i {<index>} <exp> <exp>]
176; [##core#updatebox_i {} <exp> <exp>]
177; [##core#call {<safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...]
178; [##core#callunit {<unitname>} <exp>...]
179; [##core#cond <exp> <exp> <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 (caddr x)] )
866                           (when (memq var unlikely-variables)
867                             (compiler-warning 
868                              'var
869                              "assignment to variable `~s' possibly unintended"
870                              var))
871                           (cond ((assq var foreign-variables)
872                                   => (lambda (fv)
873                                        (let ([type (second fv)]
874                                              [tmp (gensym)] )
875                                          (walk
876                                           `(let ([,tmp ,(foreign-type-convert-argument val type)])
877                                              (##core#inline_update 
878                                               (,(third fv) ,type)
879                                               ,(foreign-type-check tmp type) ) )
880                                           se #f))))
881                                 ((assq var location-pointer-map)
882                                  => (lambda (a)
883                                       (let* ([type (third a)]
884                                              [tmp (gensym)] )
885                                         (walk
886                                          `(let ([,tmp ,(foreign-type-convert-argument val type)])
887                                             (##core#inline_loc_update 
888                                              (,type)
889                                              ,(second a)
890                                              ,(foreign-type-check tmp type) ) )
891                                          se #f))))
892                                 (else
893                                  (when (eq? var var0) ; global?
894                                    (set! var (##sys#alias-global-hook var #t))
895                                    (when safe-globals-flag
896                                      (set! always-bound-to-procedure
897                                        (lset-adjoin eq? always-bound-to-procedure var))
898                                      (set! always-bound (lset-adjoin eq? always-bound var)) )
899                                    (when (macro? var)
900                                      (compiler-warning 
901                                       'var "assigned global variable `~S' is a macro ~A"
902                                       var
903                                       (if ln (sprintf "in line ~S" ln) "") )
904                                      (when undefine-shadowed-macros (undefine-macro! var) ) ) )
905                                  (when (keyword? var)
906                                    (compiler-warning 'syntax "assignment to keyword `~S'" var) )
907                                  (when (pair? var) ; macro
908                                    (syntax-error
909                                     'set! "assignment to syntactic identifier" var))
910                                  `(set! ,var ,(walk val se var0))))))
911
912                        ((##core#inline)
913                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
914
915                        ((##core#inline_allocate)
916                         `(##core#inline_allocate 
917                           ,(map (cut unquotify <> se) (second x))
918                           ,@(mapwalk (cddr x) se)))
919
920                        ((##core#inline_update)
921                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
922
923                        ((##core#inline_loc_update)
924                         `(##core#inline_loc_update 
925                           ,(cadr x) 
926                           ,(walk (caddr x) se #f)
927                           ,(walk (cadddr x) se #f)) )
928
929                        ((##core#compiletimetoo ##core#elaborationtimetoo)
930                         (let ((exp (cadr x)))
931                           (eval/meta exp)
932                           (walk exp se dest) ) )
933
934                        ((##core#compiletimeonly ##core#elaborationtimeonly)
935                         (eval/meta (cadr x))
936                         '(##core#undefined) )
937
938                        ((begin) 
939                         (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
940                         (if (pair? (cdr x))
941                             (canonicalize-begin-body
942                              (let fold ([xs (cdr x)])
943                                (let ([x (car xs)]
944                                      [r (cdr xs)] )
945                                  (if (null? r)
946                                      (list (walk x se dest))
947                                      (cons (walk x se #f) (fold r)) ) ) ) )
948                             '(##core#undefined) ) )
949
950                        ((foreign-lambda)
951                         (walk (expand-foreign-lambda x) se dest) )
952
953                        ((foreign-safe-lambda)
954                         (walk (expand-foreign-callback-lambda x) se dest) )
955
956                        ((foreign-lambda*)
957                         (walk (expand-foreign-lambda* x) se dest) )
958
959                        ((foreign-safe-lambda*)
960                         (walk (expand-foreign-callback-lambda* x) se dest) )
961
962                        ((foreign-primitive)
963                         (walk (expand-foreign-primitive x) se dest) )
964
965                        ((define-foreign-variable)
966                         (let* ([var (##sys#strip-syntax (second x))]
967                                [type (third x)]
968                                [name (if (pair? (cdddr x))
969                                          (fourth x)
970                                          (symbol->string var) ) ] )
971                           (set! foreign-variables
972                             (cons (list var type
973                                         (if (string? name)
974                                             name 
975                                             (symbol->string name)))
976                                   foreign-variables))
977                           '(##core#undefined) ) )
978
979                        ((define-foreign-type)
980                         (let ([name (second x)]
981                               [type (third x)] 
982                               [conv (cdddr x)] )
983                           (cond [(pair? conv)
984                                  (let ([arg (gensym)]
985                                        [ret (gensym)] )
986                                    (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
987                                    (set! always-bound (cons* arg ret always-bound))
988                                    (set! block-globals (cons* arg ret block-globals))
989                                    (walk
990                                     `(,(macro-alias 'begin se)
991                                        (define ,arg ,(first conv))
992                                        (define
993                                         ,ret 
994                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) ) 
995                                     se dest) ) ]
996                                 [else
997                                  (##sys#hash-table-set! foreign-type-table name type)
998                                  '(##core#undefined) ] ) ) )
999
1000                        ((define-external-variable)
1001                         (let* ([sym (second x)]
1002                                [name (symbol->string sym)]
1003                                [type (third x)] 
1004                                [exported (fourth x)]
1005                                [rname (make-random-name)] )
1006                           (unless exported (set! name (symbol->string (fifth x))))
1007                           (set! external-variables (cons (vector name type exported) external-variables))
1008                           (set! foreign-variables
1009                             (cons (list rname 'c-pointer (string-append "&" name))
1010                                   foreign-variables) )
1011                           (set! external-to-pointer (alist-cons sym rname external-to-pointer))
1012                           '(##core#undefined) ) )
1013
1014                        ((##core#let-location)
1015                         (let* ([var (second x)]
1016                                [type (third x)]
1017                                [alias (gensym)]
1018                                [store (gensym)] 
1019                                [init (and (pair? (cddddr x)) (fourth x))] )
1020                           (set-real-name! alias var)
1021                           (set! location-pointer-map
1022                             (cons (list alias store type) location-pointer-map) )
1023                           (walk
1024                            `(let (,(let ([size (words (estimate-foreign-result-location-size type))])
1025                                      ;; Add 2 words: 1 for the header, 1 for double-alignment:
1026                                      ;; Note: C_a_i_bytevector takes number of words, not bytes
1027                                      (list
1028                                       store
1029                                       `(##core#inline_allocate
1030                                         ("C_a_i_bytevector" ,(+ 2 size))
1031                                         ',size)) ) )
1032                               (,(macro-alias 'begin se)
1033                                ,@(if init
1034                                      `((##core#set! ,alias ,init))
1035                                      '() )
1036                                ,(if init (fifth x) (fourth x)) ) )
1037                            (alist-cons var alias se)
1038                            dest) ) )
1039
1040                        ((##core#define-inline)
1041                         (let* ((name (second x))
1042                                (val `(##core#lambda ,@(cdaddr x))))
1043                             (##sys#hash-table-set! inline-table name val)
1044                             (set! inline-table-used #t)
1045                             '(##core#undefined)))
1046
1047                        ((define-constant)
1048                         (let* ([name (second x)]
1049                                [valexp (third x)]
1050                                [val (handle-exceptions ex
1051                                         ;; could show line number here
1052                                         (quit "error in constant evaluation of ~S for named constant ~S" 
1053                                               valexp name)
1054                                       (if (collapsable-literal? valexp)
1055                                           valexp
1056                                           (eval
1057                                            `(,(macro-alias 'let se)
1058                                              ,defconstant-bindings ,valexp)) ) ) ] )
1059                           (set! constants-used #t)
1060                           (set! defconstant-bindings (cons (list name `',val) defconstant-bindings))
1061                           (cond [(collapsable-literal? val)
1062                                  (##sys#hash-table-set! constant-table name (list val))
1063                                  '(##core#undefined) ]
1064                                 [else
1065                                  (let ([var (gensym "constant")])
1066                                    (##sys#hash-table-set! constant-table name (list var))
1067                                    (set! mutable-constants (alist-cons var val mutable-constants))
1068                                    (set! block-globals (cons var block-globals))
1069                                    (set! always-bound (cons var always-bound))
1070                                    (walk `(define ,var ',val) se #f) ) ] ) ) )
1071
1072                        ((##core#declare)
1073                         (walk
1074                          `(,(macro-alias 'begin se)
1075                             ,@(map (lambda (d)
1076                                      (process-declaration d se))
1077                                    (cdr x) ) )
1078                          '() #f) )
1079             
1080                        ((##core#foreign-callback-wrapper)
1081                         (let-values ([(args lam) (split-at (cdr x) 4)])
1082                           (let* ([lam (car lam)]
1083                                  [name (cadr (first args))]
1084                                  [rtype (cadr (third args))]
1085                                  [atypes (cadr (fourth args))]
1086                                  [vars (second lam)] )
1087                             (if (valid-c-identifier? name)
1088                                 (set! callback-names (cons name callback-names))
1089                                 (quit "name `~S' of external definition is not a valid C identifier"
1090                                       name) )
1091                             (when (or (not (proper-list? vars)) 
1092                                       (not (proper-list? atypes))
1093                                       (not (= (length vars) (length atypes))) )
1094                               (syntax-error 
1095                                "non-matching or invalid argument list to foreign callback-wrapper"
1096                                vars atypes) )
1097                             `(##core#foreign-callback-wrapper
1098                               ,@(mapwalk args se)
1099                               ,(walk `(##core#lambda
1100                                        ,vars
1101                                        (,(macro-alias 'let se)
1102                                         ,(let loop ([vars vars] [types atypes])
1103                                            (if (null? vars)
1104                                                '()
1105                                                (let ([var (car vars)]
1106                                                      [type (car types)] )
1107                                                  (cons
1108                                                   (list
1109                                                    var
1110                                                    (foreign-type-convert-result
1111                                                     (finish-foreign-result (final-foreign-type type) var)
1112                                                     type) )
1113                                                   (loop (cdr vars) (cdr types)) ) ) ) )
1114                                         ,(foreign-type-convert-argument
1115                                           `(,(macro-alias 'let se)
1116                                             ()
1117                                             ,@(cond
1118                                                ((member
1119                                                  rtype
1120                                                  '((const nonnull-c-string) 
1121                                                    (const nonnull-unsigned-c-string)
1122                                                    nonnull-unsigned-c-string
1123                                                    nonnull-c-string))
1124                                                 `((##sys#make-c-string
1125                                                    (,(macro-alias 'let se)
1126                                                     () ,@(cddr lam)))))
1127                                                ((member
1128                                                  rtype
1129                                                  '((const c-string*)
1130                                                    (const unsigned-c-string*)
1131                                                    unsigned-c-string*
1132                                                    c-string*
1133                                                    c-string-list
1134                                                    c-string-list*))
1135                                                 (syntax-error
1136                                                  "not a valid result type for callback procedures"
1137                                                  rtype
1138                                                  name) )
1139                                                ((member
1140                                                  rtype
1141                                                  '(c-string
1142                                                    (const unsigned-c-string)
1143                                                    unsigned-c-string
1144                                                    (const c-string)) )
1145                                                 `((,(macro-alias 'let se)
1146                                                    ((r (,(macro-alias 'let se)
1147                                                         () ,@(cddr lam))))
1148                                                    (,(macro-alias 'and se)
1149                                                     r 
1150                                                     (##sys#make-c-string r)) ) ) )
1151                                                (else (cddr lam)) ) )
1152                                           rtype) ) )
1153                                      se #f) ) ) ) )
1154
1155                        (else
1156                         (let ([handle-call
1157                                (lambda ()
1158                                  (let* ([x2 (mapwalk x se)]
1159                                         [head2 (car x2)]
1160                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
1161                                    (when ln
1162                                      (##sys#hash-table-set!
1163                                       line-number-database-2
1164                                       head2
1165                                       (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
1166                                    x2) ) ] )
1167
1168                           (cond [(eq? 'location name)
1169                                  (##sys#check-syntax 'location x '(location _) #f se)
1170                                  (let ([sym (cadr x)])
1171                                    (if (symbol? sym)
1172                                        (cond [(assq (lookup sym se) location-pointer-map)
1173                                               => (lambda (a)
1174                                                    (walk
1175                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
1176                                                     se #f) ) ]
1177                                              [(assq sym external-to-pointer) 
1178                                               => (lambda (a) (walk (cdr a) se #f)) ]
1179                                              [(memq sym callback-names)
1180                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
1181                                              [else
1182                                               (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
1183                                        (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
1184                                 
1185                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
1186
1187          ((not (proper-list? x))
1188           (syntax-error "malformed expression" x) )
1189
1190          ((constant? (car x))
1191           (emit-syntax-trace-info x #f)
1192           (compiler-warning 'syntax "literal in operator position: ~S" x) 
1193           (mapwalk x se) )
1194
1195          ((and (pair? (car x)) (symbol? (caar x)) (eq? 'lambda (or (lookup (caar x) se) (caar x))))
1196           (let ([lexp (car x)]
1197                 [args (cdr x)] )
1198             (emit-syntax-trace-info x #f)
1199             (##sys#check-syntax 'lambda lexp '(lambda lambda-list . #(_ 1)) #f se)
1200             (let ([llist (cadr lexp)])
1201               (if (and (proper-list? llist) (= (length llist) (length args)))
1202                   (walk `(,(macro-alias 'let se)
1203                           ,(map list llist args) ,@(cddr lexp)) se dest)
1204                   (let ((var (gensym 't)))
1205                     (walk
1206                      `(,(macro-alias 'let se)
1207                        ((,var ,(car x)))
1208                        (,var ,@(cdr x)) )
1209                      se dest) ) ) ) ) )
1210         
1211          (else
1212           (emit-syntax-trace-info x #f)
1213           (mapwalk x se)) ) )
1214 
1215  (define (mapwalk xs se)
1216    (map (lambda (x) (walk x se #f)) xs) )
1217
1218  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
1219  (##sys#clear-trace-buffer)
1220  ;; Process visited definitions and main expression:
1221  (walk 
1222   `(,(macro-alias 'begin '())
1223      ,@(let ([p (reverse pending-canonicalizations)])
1224          (set! pending-canonicalizations '())
1225          p)
1226      ,(begin
1227         (set! extended-bindings (append internal-bindings extended-bindings))
1228         exp) )
1229   (##sys#current-environment)
1230   #f) )
1231
1232
1233(define (process-declaration spec se)   ; se unused in the moment
1234  (define (check-decl spec minlen . maxlen)
1235    (let ([n (length (cdr spec))])
1236      (if (or (< n minlen) (> n (optional maxlen 99999)))
1237          (syntax-error "invalid declaration" spec) ) ) ) 
1238  (define (stripa x)                    ; global aliasing
1239    (##sys#strip-syntax x se #t))
1240  (define (strip x)                     ; raw symbol
1241    (##sys#strip-syntax x se))
1242  (call-with-current-continuation
1243   (lambda (return)
1244     (unless (pair? spec)
1245       (syntax-error "invalid declaration specification" spec) )
1246     ;(pp `(DECLARE: ,(strip spec)))
1247     (case (##sys#strip-syntax (car spec)) ; no global aliasing
1248       ((uses)
1249        (let ((us (strip (cdr spec))))
1250          (apply register-feature! us)
1251          (when (pair? us)
1252            (##sys#hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
1253            (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
1254              (set! used-units (append used-units units)) ) ) ) )
1255       ((unit)
1256        (check-decl spec 1 1)
1257        (let* ([u (strip (cadr spec))]
1258               [un (string->c-identifier (stringify u))] )
1259          (##sys#hash-table-set! file-requirements 'unit u)
1260          (when (and unit-name (not (string=? unit-name un)))
1261            (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
1262          (set! unit-name un) ) )
1263       ((standard-bindings)
1264        (if (null? (cdr spec))
1265            (set! standard-bindings default-standard-bindings)
1266            (set! standard-bindings (append (stripa (cdr spec)) standard-bindings)) ) )
1267       ((extended-bindings)
1268        (if (null? (cdr spec))
1269            (set! extended-bindings default-extended-bindings)
1270            (set! extended-bindings (append (stripa (cdr spec)) extended-bindings)) ) )
1271       ((usual-integrations)     
1272        (cond [(null? (cdr spec))
1273               (set! standard-bindings default-standard-bindings)
1274               (set! extended-bindings default-extended-bindings) ]
1275              [else
1276               (let ([syms (stripa (cdr spec))])
1277                 (set! standard-bindings (lset-intersection eq? syms default-standard-bindings))
1278                 (set! extended-bindings (lset-intersection eq? syms default-extended-bindings)) ) ] ) )
1279       ((number-type)
1280        (check-decl spec 1 1)
1281        (set! number-type (strip (cadr spec))))
1282       ((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
1283       ((generic) (set! number-type 'generic))
1284       ((unsafe) (set! unsafe #t))
1285       ((safe) (set! unsafe #f))
1286       ((no-bound-checks) (set! no-bound-checks #t))
1287       ((no-argc-checks) (set! no-argc-checks #t))
1288       ((no-procedure-checks) (set! no-procedure-checks #t))
1289       ((interrupts-enabled) (set! insert-timer-checks #t))
1290       ((disable-interrupts) (set! insert-timer-checks #f))
1291       ((disable-warning)
1292        (set! disabled-warnings
1293          (append (strip (cdr spec)) disabled-warnings)))
1294       ((always-bound) 
1295        (set! always-bound (append (stripa (cdr spec)) always-bound)))
1296       ((safe-globals) (set! safe-globals-flag #t))
1297       ((no-procedure-checks-for-usual-bindings)
1298        (set! always-bound-to-procedure
1299          (append default-standard-bindings default-extended-bindings always-bound-to-procedure))
1300        (set! always-bound
1301          (append default-standard-bindings default-extended-bindings always-bound)) )
1302       ((bound-to-procedure)
1303        (let ((vars (stripa (cdr spec))))
1304          (set! always-bound-to-procedure (append vars always-bound-to-procedure))
1305          (set! always-bound (append vars always-bound)) ) )
1306       ((foreign-declare)
1307        (let ([fds (cdr spec)])
1308          (if (every string? fds)
1309              (set! foreign-declarations (append foreign-declarations fds))
1310              (syntax-error "invalid declaration" spec) ) ) )
1311       ((custom-declare)
1312        (if (or (not (list? spec)) (not (list? (cadr spec))) (< (length (cadr spec)) 3))
1313            (syntax-error "invalid declaration" spec)
1314            (process-custom-declaration (cadr spec) (cddr spec)) ) )
1315       ((c-options)
1316        (emit-control-file-item `(c-options ,@(strip (cdr spec)))) )
1317       ((link-options)
1318        (emit-control-file-item `(link-options ,@(strip (cdr spec))) ) )
1319       ((post-process)
1320        (emit-control-file-item
1321         (let ([file (pathname-strip-extension source-filename)])
1322           `(post-process ,@(map (cut string-substitute "\\$@" file <>) (cdr spec))) ) ) )
1323       ((block) (set! block-compilation #t))
1324       ((separate) (set! block-compilation #f))
1325       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
1326       ((unused)
1327        (set! unused-variables (append (cdr spec) unused-variables)))
1328       ((not)
1329        (check-decl spec 1)
1330        (case (##sys#strip-syntax (second spec)) ; strip all
1331          [(standard-bindings)
1332           (if (null? (cddr spec))
1333               (set! standard-bindings '())
1334               (set! standard-bindings
1335                 (lset-difference eq? default-standard-bindings
1336                                  (stripa (cddr spec))))) ]
1337          [(extended-bindings)
1338           (if (null? (cddr spec))
1339               (set! extended-bindings '())
1340               (set! extended-bindings 
1341                 (lset-difference eq? default-extended-bindings
1342                                  (stripa (cddr spec))) )) ]
1343          [(inline)
1344           (if (null? (cddr spec))
1345               (set! inline-max-size -1)
1346               (set! not-inline-list (lset-union eq? not-inline-list
1347                                                 (stripa (cddr spec)))) ) ]
1348          [(usual-integrations)     
1349           (cond [(null? (cddr spec))
1350                  (set! standard-bindings '())
1351                  (set! extended-bindings '()) ]
1352                 [else
1353                  (let ([syms (stripa (cddr spec))])
1354                    (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
1355                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
1356          [else
1357           (check-decl spec 1 1)
1358           (let ((id (strip (cadr spec))))
1359             (case id
1360               [(interrupts-enabled) (set! insert-timer-checks #f)]
1361               [(safe) (set! unsafe #t)]
1362               [else (compiler-warning 'syntax "illegal declaration specifier `~s'" id)]))]))
1363       ((compile-syntax 
1364         run-time-macros)               ; DEPRECATED
1365        (set! ##sys#enable-runtime-macros #t))
1366       ((block-global hide) 
1367        (let ([syms (stripa (cdr spec))])
1368          (when export-list 
1369            (set! export-list (lset-difference eq? export-list syms)) )
1370          (set! block-globals (lset-union eq? syms block-globals)) ) )
1371       ((export) 
1372        (let ((syms (stripa (cdr spec))))
1373          (set! block-globals (lset-difference eq? block-globals syms))
1374          (set! export-list (lset-union eq? syms (or export-list '())))))
1375       ((emit-external-prototypes-first)
1376        (set! external-protos-first #t) )
1377       ((lambda-lift) (set! do-lambda-lifting #t))
1378       ((inline)
1379        (if (null? (cdr spec))
1380            (unless (> inline-max-size -1)
1381              (set! inline-max-size default-inline-max-size) )
1382            (set! inline-list (lset-union eq? inline-list (stripa (cdr spec)))) ) )
1383       ((inline-limit)
1384        (check-decl spec 1 1)
1385        (let ([n (cadr spec)])
1386          (if (number? n)
1387              (set! inline-max-size n)
1388              (compiler-warning 
1389               'syntax
1390               "invalid argument to `inline-limit' declaration: ~s" spec) ) ) )
1391       ((constant)
1392        (let ((syms (cdr spec)))
1393          (if (every symbol? syms)
1394              (set! constant-declarations (append syms constant-declarations))
1395              (quit "invalid arguments to `constant' declaration: ~S" spec)) ) )
1396       ((emit-import-library)
1397        (set! import-libraries
1398          (append
1399           import-libraries
1400           (map (lambda (il)
1401                  (cond ((symbol? il)
1402                         (cons il (string-append (symbol->string il) ".import.scm")) )
1403                        ((and (list? il) (= 2 (length il))
1404                              (symbol? (car il)) (string (cadr il)))
1405                         (cons (car il) (cadr il))) 
1406                        (else
1407                         (compiler-warning 
1408                          'syntax
1409                          "invalid import-library specification: ~s" il))))
1410                (strip (cdr spec))))))
1411       ((profile)
1412        (set! profiled-procedures
1413          (append (stripa (cdr spec))
1414                  (or profiled-procedures '()))))
1415       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
1416     '(##core#undefined) ) ) )
1417
1418
1419;;; Expand "foreign-lambda"/"foreign-callback-lambda" forms and add item to stub-list:
1420
1421(define-record-type foreign-stub
1422  (make-foreign-stub id return-type name argument-types argument-names body cps callback)
1423  foreign-stub?
1424  (id foreign-stub-id)                  ; symbol
1425  (return-type foreign-stub-return-type)          ; type-specifier
1426  (name foreign-stub-name)                        ; string or #f
1427  (argument-types foreign-stub-argument-types) ; (type-specifier...)
1428  (argument-names foreign-stub-argument-names) ; #f or (symbol ...)
1429  (body foreign-stub-body)                     ; #f or string
1430  (cps foreign-stub-cps)                       ; boolean
1431  (callback foreign-stub-callback))            ; boolean
1432
1433(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
1434  (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
1435         [f-id (gensym 'stub)]
1436         [bufvar (gensym)] 
1437         [rsize (estimate-foreign-result-size rtype)] )
1438    (set-real-name! f-id #t)
1439    (set! foreign-lambda-stubs 
1440      (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
1441            foreign-lambda-stubs) )
1442    (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
1443          [head (if cps
1444                    `((##core#primitive ,f-id))
1445                    `(##core#inline ,f-id) ) ]
1446          [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
1447      `(lambda ,params
1448         ;; Do minor GC (if callback) to make room on stack:
1449         ,@(if callback '((##sys#gc #f)) '())
1450         ,(if (zero? rsize) 
1451              (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
1452              (let ([ft (final-foreign-type rtype)]
1453                    [ws (words rsize)] )
1454                `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)])
1455                   ,(foreign-type-convert-result
1456                     (finish-foreign-result ft (append head (cons bufvar rest)))
1457                     rtype) ) ) ) ) ) ) )
1458
1459(define (expand-foreign-lambda exp)
1460  (let* ([name (third exp)]
1461         [sname (cond ((symbol? name) (symbol->string name))
1462                      ((string? name) name)
1463                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
1464         [rtype (second exp)]
1465         [argtypes (cdddr exp)] )
1466    (create-foreign-stub rtype sname argtypes #f #f #f #f) ) )
1467
1468(define (expand-foreign-callback-lambda exp)
1469  (let* ([name (third exp)]
1470         [sname (cond ((symbol? name) (symbol->string name))
1471                      ((string? name) name)
1472                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
1473         [rtype (second exp)]
1474         [argtypes (cdddr exp)] )
1475    (create-foreign-stub rtype sname argtypes #f #f #t #t) ) )
1476
1477(define (expand-foreign-lambda* exp)
1478  (let* ([rtype (second exp)]
1479         [args (third exp)]
1480         [body (apply string-append (cdddr exp))]
1481         [argtypes (map car args)]
1482         [argnames (map cadr args)] )
1483    (create-foreign-stub rtype #f argtypes argnames body #f #f) ) )
1484
1485(define (expand-foreign-callback-lambda* exp)
1486  (let* ([rtype (second exp)]
1487         [args (third exp)]
1488         [body (apply string-append (cdddr exp))]
1489         [argtypes (map car args)]
1490         [argnames (map cadr args)] )
1491    (create-foreign-stub rtype #f argtypes argnames body #t #t) ) )
1492
1493(define (expand-foreign-primitive exp)
1494  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
1495         [rtype (if hasrtype (second exp) 'void)]
1496         [args (if hasrtype (third exp) (second exp))]
1497         [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
1498         [argtypes (map car args)]
1499         [argnames (map cadr args)] )
1500    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
1501
1502
1503;;; Traverse expression and update line-number db with all contained calls:
1504
1505(define (update-line-number-database! exp ln)
1506  (define (mapupdate xs)
1507    (let loop ((xs xs))
1508      (if (pair? xs)
1509          (begin
1510            (walk (car xs))
1511            (loop (cdr xs)) ) ) ) )
1512  (define (walk x)
1513    (cond ((not-pair? x))
1514          ((symbol? (car x))
1515           (let* ((name (car x))
1516                  (old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) )
1517             (if (not (assq x old))
1518                 (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) )
1519             (mapupdate (cdr x)) ) )
1520          (else (mapupdate x)) ) )
1521  (walk exp) )
1522
1523
1524;;; Convert canonicalized node-graph into continuation-passing-style:
1525
1526(define (perform-cps-conversion node)
1527
1528  (define (cps-lambda id llist subs k)
1529    (let ([t1 (gensym 'k)])
1530      (k (make-node
1531          '##core#lambda (list id #t (cons t1 llist) 0)
1532          (list (walk (car subs)
1533                      (lambda (r) 
1534                        (make-node '##core#call '(#t) (list (varnode t1) r)) ) ) ) ) ) ) )
1535 
1536  (define (walk n k)
1537    (let ((subs (node-subexpressions n))
1538          (params (node-parameters n)) 
1539          (class (node-class n)) )
1540      (case (node-class n)
1541        ((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n))
1542        ((if) (let* ((t1 (gensym 'k))
1543                     (t2 (gensym 'r))
1544                     (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
1545                (make-node 'let
1546                           (list t1)
1547                           (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0) 
1548                                            (list (k (varnode t2))) )
1549                                 (walk (car subs)
1550                                       (lambda (v)
1551                                         (make-node 'if '()
1552                                                    (list v
1553                                                          (walk (cadr subs) k1)
1554                                                          (walk (caddr subs) k1) ) ) ) ) ) ) ) )
1555        ((let)
1556         (let loop ((vars params) (vals subs))
1557           (if (null? vars)
1558               (walk (car vals) k)
1559               (walk (car vals)
1560                     (lambda (r) 
1561                       (make-node 'let
1562                                  (list (car vars))
1563                                  (list r (loop (cdr vars) (cdr vals))) ) ) ) ) ) )
1564        ((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
1565        ((set!) (let ((t1 (gensym 't)))
1566                  (walk (car subs)
1567                        (lambda (r)
1568                          (make-node 'let (list t1)
1569                                     (list (make-node 'set! (list (first params)) (list r))
1570                                           (k (varnode t1)) ) ) ) ) ) )
1571        ((##core#foreign-callback-wrapper)
1572         (let ([id (gensym-f-id)]
1573               [lam (first subs)] )
1574           (set! foreign-callback-stubs
1575             (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
1576           (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
1577        ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref 
1578                        ##core#inline_loc_update)
1579         (walk-inline-call class params subs k) )
1580        ((##core#call) (walk-call (car subs) (cdr subs) params k))
1581        ((##core#callunit) (walk-call-unit (first params) k))
1582        (else (bomb "bad node (cps)")) ) ) )
1583 
1584  (define (walk-call fn args params k)
1585    (let ((t0 (gensym 'k))
1586          (t3 (gensym 'r)) )
1587      (make-node
1588       'let (list t0)
1589       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) 
1590                        (list (k (varnode t3))) )
1591             (walk-arguments
1592              args
1593              (lambda (vars)
1594                (walk fn
1595                      (lambda (r) 
1596                        (make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
1597 
1598  (define (walk-call-unit unitname k)
1599    (let ((t0 (gensym 'k))
1600          (t3 (gensym 'r)) )
1601      (make-node
1602       'let (list t0)
1603       (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0) 
1604                        (list (k (varnode t3))) )
1605             (make-node '##core#callunit (list unitname)
1606                        (list (varnode t0)) ) ) ) ) )
1607
1608  (define (walk-inline-call class op args k)
1609    (walk-arguments
1610     args
1611     (lambda (vars)
1612       (k (make-node class op vars)) ) ) )
1613 
1614  (define (walk-arguments args wk)
1615    (let loop ((args args) (vars '()))
1616      (cond ((null? args) (wk (reverse vars)))
1617            ((atomic? (car args))
1618             (loop (cdr args) (cons (car args) vars)) )
1619            (else
1620             (let ((t1 (gensym 'a)))
1621               (walk (car args)
1622                     (lambda (r)
1623                       (make-node 'let (list t1)
1624                                  (list r
1625                                        (loop (cdr args) 
1626                                              (cons (varnode t1) vars) ) ) ) ) ) ) ) ) ) )
1627 
1628  (define (atomic? n)
1629    (let ((class (node-class n)))
1630      (or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref))
1631          (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update
1632                                           ##core#inline_loc_ref ##core#inline_loc_update))
1633               (every atomic? (node-subexpressions n)) ) ) ) )
1634 
1635  (walk node values) )
1636
1637
1638;;; Foreign callback stub type:
1639
1640(define-record-type foreign-callback-stub
1641  (make-foreign-callback-stub id name qualifiers return-type argument-types)
1642  foreign-callback-stub?
1643  (id foreign-callback-stub-id)         ; symbol
1644  (name foreign-callback-stub-name)     ; string
1645  (qualifiers foreign-callback-stub-qualifiers) ; string
1646  (return-type foreign-callback-stub-return-type) ; type-specifier
1647  (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)
1648
1649
1650;;; Perform source-code analysis:
1651
1652(define (analyze-expression node)
1653  (let ([db (make-vector analysis-database-size '())]
1654        [explicitly-consed '()] )
1655
1656    (define (grow n)
1657      (set! current-program-size (+ current-program-size n)) )
1658
1659    (define (walk n env localenv here call)
1660      (let ((subs (node-subexpressions n))
1661            (params (node-parameters n)) 
1662            (class (node-class n)) )
1663        (grow 1)
1664        (case class
1665          ((quote ##core#undefined ##core#proc) #f)
1666
1667          ((##core#variable)
1668           (let ((var (first params)))
1669             (ref var n)
1670             (unless (memq var localenv)
1671               (grow 1)
1672               (cond ((memq var env) (put! db var 'captured #t))
1673                     ((not (get db var 'global)) 
1674                      (put! db var 'global #t) ) ) ) ) )
1675         
1676          ((##core#global-ref)
1677           (let ((var (first params)))
1678             (ref var n)
1679             (grow 1)
1680             (put! db var 'global #t) ) )
1681         
1682          ((##core#callunit ##core#recurse)
1683           (grow 1)
1684           (walkeach subs env localenv here #f) )
1685
1686          ((##core#call)
1687           (grow 1)
1688           (let ([fun (car subs)])
1689             (if (eq? '##core#variable (node-class fun))
1690                 (let ([name (first (node-parameters fun))])
1691                   (collect! db name 'call-sites (cons here n))
1692                   ;; If call to standard-binding & optimizable rest-arg operator: decrease access count:
1693                   (if (and (get db name 'standard-binding)
1694                            (memq name optimizable-rest-argument-operators) )
1695                       (for-each
1696                        (lambda (arg)
1697                          (and-let* ([(eq? '##core#variable (node-class arg))]
1698                                     [var (first (node-parameters arg))] )
1699                            (when (get db var 'rest-parameter) (count! db var 'o-r/access-count)) ) )
1700                        (cdr subs) ) ) ) )
1701             (walk (first subs) env localenv here #t)
1702             (walkeach (cdr subs) env localenv here #f) ) )
1703
1704          ((let ##core#let)
1705           (let ([env2 (append params localenv env)])
1706             (let loop ([vars params] [vals subs])
1707               (if (null? vars)
1708                   (walk (car vals) env (append params localenv) here #f)
1709                   (let ([var (car vars)]
1710                         [val (car vals)] )
1711                     (put! db var 'home here)
1712                     (assign var val env2 here)
1713                     (walk val env localenv here #f) 
1714                     (loop (cdr vars) (cdr vals)) ) ) ) ) )
1715
1716          ((lambda)
1717           (grow 1)
1718           (decompose-lambda-list
1719            (first params)
1720            (lambda (vars argc rest)
1721              (for-each
1722               (lambda (var) (put! db var 'unknown #t))
1723               vars)
1724              (let ([tl toplevel-scope])
1725                (set! toplevel-scope #f)
1726                (walk (car subs) (append localenv env) vars #f #f)
1727                (set! toplevel-scope tl) ) ) ) )
1728
1729          ((##core#lambda ##core#direct_lambda)
1730           (grow 1)
1731           (decompose-lambda-list
1732            (third params)
1733            (lambda (vars argc rest)
1734              (let ([id (first params)]
1735                    [size0 current-program-size] )
1736                (when here
1737                  (collect! db here 'contains id)
1738                  (put! db id 'contained-in here) )
1739                (for-each
1740                 (lambda (var)
1741                   (put! db var 'home here)
1742                   (put! db var 'unknown #t) )
1743                 vars)
1744                (when rest
1745                  (put! db rest 'rest-parameter
1746                        (if (memq rest rest-parameters-promoted-to-vector)
1747                            'vector
1748                            'list) ) )
1749                (when (simple-lambda-node? n) (put! db id 'simple #t))
1750                (let ([tl toplevel-scope])
1751                  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
1752                  (when (and (second params) (not (eq? toplevel-lambda-id id)))
1753                    (set! toplevel-scope #f)) ; only if non-CPS lambda
1754                  (walk (car subs) (append localenv env) vars id #f)
1755                  (set! toplevel-scope tl)
1756                  ;; decorate ##core#call node with size
1757                  (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
1758         
1759          ((set! ##core#set!) 
1760           (let* ([var (first params)]
1761                  [val (car subs)] )
1762             (when first-analysis 
1763               (cond [(get db var 'standard-binding)
1764                      (compiler-warning 'redef "redefinition of standard binding `~S'" var) ]
1765                     [(get db var 'extended-binding)
1766                      (compiler-warning 'redef "redefinition of extended binding `~S'" var) ] )
1767               (put! db var 'potential-value val) )
1768             (when (and (not (memq var localenv)) 
1769                        (not (memq var env)) )
1770               (grow 1)
1771               (when first-analysis
1772                 (when (or block-compilation (and export-list (not (memq var export-list))))
1773                   (set! block-globals (lset-adjoin eq? block-globals var)) ) )
1774               (put! db var 'global #t) )
1775             (assign var val (append localenv env) here)
1776             (unless toplevel-scope (put! db var 'assigned-locally #t))
1777             (put! db var 'assigned #t)
1778             (walk (car subs) env localenv here #f) ) )
1779
1780          ((##core#primitive ##core#inline)
1781           (let ([id (first params)])
1782             (when (and first-analysis here (symbol? id) (##sys#hash-table-ref real-name-table id))
1783               (set-real-name! id here) )
1784             (walkeach subs env localenv here #f) ) )
1785
1786          (else (walkeach subs env localenv here #f)) ) ) )
1787
1788    (define (walkeach xs env lenv here call) 
1789      (for-each (lambda (x) (walk x env lenv here call)) xs) )
1790
1791    (define (assign var val env here)
1792      (cond ((eq? '##core#undefined (node-class val))
1793             (put! db var 'undefined #t) )
1794            ((and (eq? '##core#variable (node-class val))
1795                  (eq? var (first (node-parameters val))) ) )
1796            ((or block-compilation
1797                 (memq var env)
1798                 (get db var 'constant)
1799                 ;;(memq var inline-list)       - would be nice, but might be customized...
1800                 (memq var block-globals) )
1801             (let ((props (get-all db var 'unknown 'value))
1802                   (home (get db var 'home)) )
1803               (unless (assq 'unknown props)
1804                 (if (assq 'value props)
1805                     (put! db var 'unknown #t)
1806                     (if (or (not home) (eq? here home))
1807                         (put! db var 'value val)
1808                         (put! db var 'unknown #t) ) ) ) ) )
1809            (else (put! db var 'unknown #t)) ) )
1810   
1811    (define (ref var node)
1812      (collect! db var 'references node) )
1813
1814    (define (quick-put! plist prop val)
1815      (set-cdr! plist (alist-cons prop val (cdr plist))) )
1816
1817    ;; Return true if <id> directly or indirectly contains any of <other-ids>:
1818    (define (contains? id other-ids)
1819      (or (memq id other-ids)
1820          (let ((clist (get db id 'contains)))
1821            (and clist
1822                 (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) )
1823
1824    ;; Initialize database:
1825    (initialize-analysis-database db)
1826
1827    ;; Walk toplevel expression-node:
1828    (debugging 'p "analysis traversal phase...")
1829    (set! current-program-size 0)
1830    (walk node '() '() #f #f) 
1831
1832    ;; Complete gathered database information:
1833    (debugging 'p "analysis gathering phase...")
1834    (##sys#hash-table-for-each
1835     (lambda (sym plist)
1836       (let ([unknown #f]
1837             [value #f]
1838             [pvalue #f]
1839             [references '()]
1840             [captured #f]
1841             [call-sites '()]
1842             [assigned #f]
1843             [assigned-locally #f]
1844             [undefined #f]
1845             [global #f]
1846             [o-r/access-count 0]
1847             [rest-parameter #f] 
1848             [nreferences 0]
1849             [ncall-sites 0] )
1850
1851         (for-each
1852          (lambda (prop)
1853            (case (car prop)
1854              [(unknown) (set! unknown #t)]
1855              [(references) 
1856               (set! references (cdr prop))
1857               (set! nreferences (length references)) ]
1858              [(captured) (set! captured #t)]
1859              [(potential-value) (set! pvalue (cdr prop))]
1860              [(call-sites)
1861               (set! call-sites (cdr prop))
1862               (set! ncall-sites (length call-sites)) ]
1863              [(assigned) (set! assigned #t)]
1864              [(assigned-locally) (set! assigned-locally #t)]
1865              [(undefined) (set! undefined #t)]
1866              [(global) (set! global #t)]
1867              [(value) (set! value (cdr prop))]
1868              [(o-r/access-count) (set! o-r/access-count (cdr prop))]
1869              [(rest-parameter) (set! rest-parameter #t)] ) )
1870          plist)
1871
1872         (set! value (and (not unknown) value))
1873
1874         ;; If this is the first analysis, register known local or potentially known global lambda-value id's
1875         ;;  along with their names:
1876         (when (and first-analysis 
1877                    (eq? '##core#lambda
1878                         (and-let* ([val (or value (and global pvalue))])
1879                           (node-class val) ) ) )
1880           (set-real-name! (first (node-parameters (or value pvalue))) sym) )
1881
1882         ;; If this is the first analysis and the variable is global and has no references and we are
1883         ;;  in block mode, then issue warning:
1884         (when (and first-analysis 
1885                    global
1886                    (null? references)
1887                    (not (memq sym unused-variables)))
1888           (when assigned-locally
1889             (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )
1890           (when (and (or block-compilation
1891                          (and export-list (not (memq sym export-list))) )
1892                      (not (assq sym mutable-constants)) )
1893             (compiler-warning 'var "global variable `~S' is never used" sym) ) )
1894
1895         ;; Make 'boxed, if 'assigned & 'captured:
1896         (when (and assigned captured)
1897           (quick-put! plist 'boxed #t) )
1898
1899         ;; Make 'contractable, if it has a procedure as known value, has only one use and one call-site and
1900         ;;  if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
1901         ;;  use/call count is not 1:
1902         (when value
1903           (let ((valparams (node-parameters value)))
1904             (when (and (eq? '##core#lambda (node-class value))
1905                        (or (not (second valparams))
1906                            (every (lambda (v) (get db v 'global)) (scan-free-variables value)) ) )
1907               (if (and (= 1 nreferences) (= 1 ncall-sites))
1908                   (quick-put! plist 'contractable #t)
1909                   (quick-put! plist 'inlinable #t) ) ) ) )
1910
1911         ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only
1912         ;;  referenced once and if no assignments are made:
1913         (when (and value
1914                    ;; (not (assq 'assigned plist)) - If it has a known value, it's assigned just once!
1915                    (eq? 'quote (node-class value)) )
1916           (let ((val (first (node-parameters value))))
1917             (when (or (collapsable-literal? val)
1918                       (= 1 nreferences) )
1919               (quick-put! plist 'collapsable #t) ) ) )
1920               
1921         ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the
1922         ;;  number of references (does not escape), then make all formal parameters 'unused which are
1923         ;;  never referenced or assigned (if no rest parameter exist):
1924         ;;  - also marks the procedure as 'has-unused-parameters (if not in `callback-names')
1925         ;;  - if the procedure is internal (a continuation) do NOT mark unused parameters.
1926         ;;  - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
1927         (when value
1928           (let ([has #f])
1929             (when (and (eq? '##core#lambda (node-class value))
1930                        (= nreferences ncall-sites) )
1931               (let ([lparams (node-parameters value)])
1932                 (when (second lparams)
1933                   (decompose-lambda-list
1934                    (third lparams)
1935                    (lambda (vars argc rest)
1936                      (unless rest
1937                        (for-each
1938                         (lambda (var)
1939                           (cond [(and (not (get db var 'references))
1940                                       (not (get db var 'assigned)) )
1941                                  (put! db var 'unused #t)
1942                                  (set! has #t)
1943                                  #t]
1944                                 [else #f] ) )
1945                         vars) )
1946                      (cond [(and has (not (memq sym callback-names)))
1947                             (put! db (first lparams) 'has-unused-parameters #t) ]
1948                            [rest
1949                             (set! explicitly-consed (cons rest explicitly-consed))
1950                             (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
1951
1952         ;;  Make 'removable, if it has no references and is not assigned to, and if it has either a value that
1953         ;;    does not cause any side-effects or if it is 'undefined:
1954         (when (and (not assigned)
1955                    (null? references)
1956                    (or (and value
1957                             (or (not (eq? '##core#variable (node-class value)))
1958                                 (not (get db (first (node-parameters value)) 'global)) )
1959                             (not (expression-has-side-effects? value db)) )
1960                        undefined) )
1961           (quick-put! plist 'removable #t) )
1962
1963         ;; Make 'replacable, if it has a variable as known value and if either that variable has
1964         ;;  a known value itself, or if it is not captured and referenced only once, the target and
1965         ;;  the source are never assigned and the source is non-global or we are in block-mode:
1966         ;;  - The target-variable is not allowed to be global.
1967         ;;  - The variable that can be substituted for the current one is marked as 'replacing.
1968         ;;    This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if
1969         ;;    it was contracted).
1970         (when (and value (not global))
1971           (when (eq? '##core#variable (node-class value))
1972             (let* ([name (first (node-parameters value))]
1973                    [nrefs (get db name 'references)] )
1974               (when (or (and (not (get db name 'unknown)) (get db name 'value))
1975                         (and (not (get db name 'captured))
1976                              nrefs
1977                              (= 1 (length nrefs))
1978                              (not assigned)
1979                              (not (get db name 'assigned)) 
1980                              (or block-compilation (not (get db name 'global))) ) )
1981                 (quick-put! plist 'replacable name) 
1982                 (put! db name 'replacing #t) ) ) ) )
1983
1984         ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
1985         ;;  is an internally created procedure: (See above for 'replacing)
1986         (when (and value (eq? '##core#lambda (node-class value)))
1987           (let ([params (node-parameters value)])
1988             (when (not (second params))
1989               (let ([llist (third params)]
1990                     [body (first (node-subexpressions value))] )
1991                 (when (and (pair? llist) 
1992                            (null? (cdr llist))
1993                            (eq? '##core#call (node-class body)) )
1994                   (let ([subs (node-subexpressions body)])
1995                     (when (= 2 (length subs))
1996                       (let ([v1 (first subs)]
1997                             [v2 (second subs)] )
1998                         (when (and (eq? '##core#variable (node-class v1))
1999                                    (eq? '##core#variable (node-class v2))
2000                                    (eq? (first llist) (first (node-parameters v2))) )
2001                           (let ([kvar (first (node-parameters v1))])
2002                             (quick-put! plist 'replacable kvar)
2003                             (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) )
2004
2005         ;; If a rest-argument, convert 'rest-parameter property to 'vector, if the variable is never
2006         ;;  assigned, and the number of references is identical to the number of accesses in optimizable
2007         ;;  rest-argument operators:
2008         ;; - Add variable to "rest-parameters-promoted-to-vector", because subsequent optimization will
2009         ;;   change variables context (operators applied to it).
2010         (when (and rest-parameter
2011                    (not assigned)
2012                    (= nreferences o-r/access-count) )
2013           (set! rest-parameters-promoted-to-vector (lset-adjoin eq? rest-parameters-promoted-to-vector sym))
2014           (put! db sym 'rest-parameter 'vector) ) ) )
2015
2016     db)
2017
2018    ;; Remove explicitly consed rest parameters from promoted ones:
2019    (set! rest-parameters-promoted-to-vector
2020      (lset-difference eq? rest-parameters-promoted-to-vector explicitly-consed) )
2021
2022    ;; Set original program-size, if this is the first analysis-pass:
2023    (unless original-program-size
2024      (set! original-program-size current-program-size) )
2025    db) )
2026
2027
2028;;; Convert closures to explicit data structures (effectively flattens function-binding structure):
2029
2030(define (perform-closure-conversion node db)
2031  (let ([direct-calls 0]
2032        [customizable '()] )
2033
2034    (define (test sym item) (get db sym item))
2035 
2036    (define (register-customizable! var id)
2037      (set! customizable (lset-adjoin eq? customizable var)) 
2038      (put! db id 'customizable #t) )
2039
2040    (define (register-direct-call! id)
2041      (set! direct-calls (add1 direct-calls))
2042      (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) )
2043
2044    ;; Gather free-variable information:
2045    ;; (and: - register direct calls
2046    ;;       - update (by mutation) call information in "##core#call" nodes)
2047    (define (gather n here env)
2048      (let ((subs (node-subexpressions n))
2049            (params (node-parameters n)) )
2050        (case (node-class n)
2051
2052          ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f)
2053
2054          ((let)
2055           (receive (vals body) (split-at subs (length params))
2056             (for-each (lambda (n) (gather n here env)) vals)
2057             (gather (first body) here (append params env)) ) )
2058
2059          ((##core#call)
2060           (let* ([fn (first subs)]
2061                  [mode (first params)]
2062                  [name (and (pair? (cdr params)) (second params))]
2063                  [varfn (eq? '##core#variable (node-class fn))] )
2064             (node-parameters-set!
2065              n
2066              (cons mode
2067                    (if (or name varfn)
2068                        (cons name
2069                              (if varfn
2070                                  (let* ([varname (first (node-parameters fn))]
2071                                         [val (and (not (test varname 'unknown)) (test varname 'value))] )
2072                                    (if (and val (eq? '##core#lambda (node-class val)))
2073                                        (let* ([params (node-parameters val)]
2074                                               [llist (third params)]
2075                                               [id (first params)]
2076                                               [refs (test varname 'references)]
2077                                               [sites (test varname 'call-sites)] 
2078                                               [custom
2079                                                (and refs sites
2080                                                     (= (length refs) (length sites)) 
2081                                                     (proper-list? llist) ) ] )
2082                                          (when (and name custom (not (= (length llist) (length (cdr subs)))))
2083                                            (quit
2084                                             "known procedure called with wrong number of arguments: ~A" 
2085                                             (source-info->string name) ) )
2086                                          (register-direct-call! id)
2087                                          (when custom (register-customizable! varname id)) 
2088                                          (list id custom) )
2089                                        '() ) )
2090                                  '() ) )
2091                        '() ) ) )
2092             (for-each (lambda (n) (gather n here env)) subs) ) )
2093
2094          ((##core#lambda ##core#direct_lambda)
2095           (decompose-lambda-list
2096            (third params)
2097            (lambda (vars argc rest)
2098              (let* ([id (if here (first params) 'toplevel)]
2099                     [capturedvars (captured-variables (car subs) env)]
2100                     [csize (length capturedvars)] )
2101                (put! db id 'closure-size csize)
2102                (put! db id 'captured-variables capturedvars)
2103                (gather (car subs) id (append vars env)) ) ) ) )
2104       
2105          (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
2106
2107    ;; Create explicit closures:
2108    (define (transform n here closure)
2109      (let ((subs (node-subexpressions n))
2110            (params (node-parameters n)) 
2111            (class (node-class n)) )
2112        (case class
2113
2114          ((quote ##core#undefined ##core#proc ##core#global-ref) n)
2115
2116          ((##core#variable)
2117           (let* ((var (first params))
2118                  (val (ref-var n here closure)) )
2119             (if (test var 'boxed)
2120                 (make-node '##core#unbox '() (list val))
2121                 val) ) )
2122
2123          ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit ##core#inline_ref ##core#inline_update 
2124               ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return ##core#inline_loc_ref
2125               ##core#inline_loc_update)
2126           (make-node (node-class n) params (maptransform subs here closure)) )
2127
2128          ((let)
2129           (let* ([var (first params)]
2130                  [boxedvar (test var 'boxed)]
2131                  [boxedalias (gensym var)] )
2132             (if boxedvar
2133                 (make-node 
2134                  'let (list boxedalias)
2135                  (list (transform (first subs) here closure)
2136                        (make-node
2137                         'let (list var)
2138                         (list (make-node '##core#box '() (list (varnode boxedalias)))
2139                               (transform (second subs) here closure) ) ) ) )
2140                 (make-node
2141                  'let params
2142                  (maptransform subs here closure) ) ) ) )
2143
2144          ((##core#lambda ##core#direct_lambda)
2145           (let ([llist (third params)])
2146             (decompose-lambda-list
2147              llist
2148              (lambda (vars argc rest)
2149                (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)]
2150                       [boxedaliases (map cons boxedvars (map gensym boxedvars))]
2151                       [cvar (gensym 'c)]
2152                       [id (if here (first params) 'toplevel)]
2153                       [capturedvars (or (test id 'captured-variables) '())]
2154                       [csize (or (test id 'closure-size) 0)] 
2155                       [info (and emit-closure-info (second params) (pair? llist))] )
2156                  ;; If rest-parameter is boxed: mark it as 'boxed-rest
2157                  ;;  (if we don't do this than preparation will think the (boxed) alias
2158                  ;;  of the rest-parameter is never used)
2159                  (and-let* ([rest]
2160                             [(test rest 'boxed)]
2161                             [rp (test rest 'rest-parameter)] )
2162                    (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
2163                  (make-node
2164                   '##core#closure (list (+ csize (if info 2 1)))
2165                   (cons
2166                    (make-node
2167                     class
2168                     (list id
2169                           (second params)
2170                           (cons
2171                            cvar
2172                            (build-lambda-list
2173                             (map (lambda (v)
2174                                    (cond ((assq v boxedaliases) => cdr)
2175                                          (else v) ) )
2176                                  vars)
2177                             argc
2178                             (cond ((and rest (assq rest boxedaliases)) => cdr)
2179                                   (else rest) ) ) )
2180                           (fourth params) )
2181                     (list (let ((body (transform (car subs) cvar capturedvars)))
2182                             (if (pair? boxedvars)
2183                                 (fold-right
2184                                  (lambda (alias val body) (make-node 'let (list alias) (list val body)))
2185                                  body
2186                                  (unzip1 boxedaliases)
2187                                  (map (lambda (a) (make-node '##core#box '() (list (varnode (cdr a)))))
2188                                       boxedaliases) )
2189                                 body) ) ) )
2190                    (let ((cvars (map (lambda (v) (ref-var (varnode v) here closure))
2191                                      capturedvars) ) )
2192                      (if info
2193                          (append
2194                           cvars
2195                           (list
2196                            (qnode 
2197                             (##sys#make-lambda-info
2198                              (->string (cons (or (real-name id) '?)
2199                                              (cdr llist) )))))) ; this is not always correct, due to optimizations
2200                          cvars) ) ) ) ) ) ) ) )
2201
2202          ((set!)
2203           (let* ([var (first params)]
2204                  [val (first subs)]
2205                  [cval (node-class val)]
2206                  [immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
2207                            (eq? '##core#undefined cval) ) ] )
2208             (cond ((posq var closure)
2209                    => (lambda (i)
2210                         (if (test var 'boxed)
2211                             (make-node
2212                              (if immf '##core#updatebox_i '##core#updatebox)
2213                              '()
2214                              (list (make-node '##core#ref (list (add1 i)) (list (varnode here)))
2215                                    (transform val here closure) ) )
2216                             ;; Is the following actually used???
2217                             (make-node
2218                              (if immf '##core#update_i '##core#update)
2219                              (list (add1 i))
2220                              (list (varnode here)
2221                                    (transform val here closure) ) ) ) ) )
2222                   ((test var 'boxed)
2223                    (make-node
2224                     (if immf '##core#updatebox_i '##core#updatebox)
2225                     '()
2226                     (list (varnode var)
2227                           (transform val here closure) ) ) )
2228                   (else (make-node
2229                          'set! (list var)
2230                          (list (transform val here closure) ) ) ) ) ) )
2231
2232          ((##core#primitive) 
2233           (make-node
2234            '##core#closure (list (if emit-closure-info 2 1))
2235            (cons (make-node '##core#proc (list (car params) #t) '())
2236                  (if emit-closure-info
2237                      (list (qnode (##sys#make-lambda-info (car params))))
2238                      '() ) ) ) )
2239
2240          (else (bomb "bad node (closure2)")) ) ) )
2241
2242    (define (maptransform xs here closure)
2243      (map (lambda (x) (transform x here closure)) xs) )
2244 
2245    (define (ref-var n here closure)
2246      (let ((var (first (node-parameters n))))
2247        (cond ((posq var closure) 
2248               => (lambda (i) 
2249                    (make-node '##core#ref (list (+ i 1)) 
2250                               (list (varnode here)) ) ) )
2251              (else n) ) ) )
2252
2253    (define (captured-variables node env)
2254      (let ([vars '()])
2255        (let walk ([n node])
2256          (let ((subs (node-subexpressions n))
2257                (params (node-parameters n)) )
2258            (case (node-class n)
2259              ((##core#variable)
2260               (let ([var (first params)])
2261                 (when (memq var env)
2262                   (set! vars (lset-adjoin eq? vars var)) ) ) )
2263              ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f)
2264              ((set!) 
2265               (let ([var (first params)])
2266                 (when (memq var env) (set! vars (lset-adjoin eq? vars var)))
2267                 (walk (car subs)) ) )
2268              (else (for-each walk subs)) ) ) )
2269        vars) )
2270
2271    (debugging 'p "closure conversion gathering phase...")
2272    (gather node #f '())
2273    (debugging 'o "customizable procedures" customizable)
2274    (debugging 'p "closure conversion transformation phase...")
2275    (let ((node2 (transform node #f #f)))
2276      (unless (zero? direct-calls)
2277        (debugging 'o "calls to known targets" direct-calls (delay (length direct-call-ids))) )
2278      node2) ) )
2279
2280
2281;;; Do some preparations before code-generation can commence:
2282
2283(define-record-type lambda-literal
2284  (make-lambda-literal id external arguments argument-count rest-argument temporaries
2285                       callee-signatures allocated directly-called closure-size
2286                       looping customizable rest-argument-mode body direct)
2287  lambda-literal?
2288  (id lambda-literal-id)                               ; symbol
2289  (external lambda-literal-external)                   ; boolean
2290  (arguments lambda-literal-arguments)                 ; (symbol...)
2291  (argument-count lambda-literal-argument-count)       ; integer
2292  (rest-argument lambda-literal-rest-argument)         ; symbol | #f
2293  (temporaries lambda-literal-temporaries)             ; integer
2294  (callee-signatures lambda-literal-callee-signatures) ; (integer...)
2295  (allocated lambda-literal-allocated)                 ; integer
2296  (directly-called lambda-literal-directly-called)     ; boolean
2297  (closure-size lambda-literal-closure-size)           ; integer
2298  (looping lambda-literal-looping)                     ; boolean
2299  (customizable lambda-literal-customizable)           ; boolean
2300  (rest-argument-mode lambda-literal-rest-argument-mode) ; #f | LIST | VECTOR | UNUSED
2301  (body lambda-literal-body)                             ; expression
2302  (direct lambda-literal-direct))                        ; boolean
2303 
2304(define (prepare-for-code-generation node db)
2305  (let ([literals '()]
2306        [lambda-info-literals '()]
2307        [lambdas '()]
2308        [temporaries 0]
2309        [allocated 0]
2310        [looping 0]
2311        [signatures '()] 
2312        [fastinits 0] 
2313        [fastrefs 0] 
2314        [fastsets 0] )
2315
2316    (define (walk-var var e sf)
2317      (cond [(posq var e) => (lambda (i) (make-node '##core#local (list i) '()))]
2318            [(keyword? var) (make-node '##core#literal (list (literal var)) '())]
2319            [else (walk-global var sf)] ) )
2320
2321    (define (walk-global var sf)
2322      (let* ([safe (or sf 
2323                       no-bound-checks
2324                       unsafe
2325                       (memq var always-bound)
2326                       (get db var 'standard-binding)
2327                       (get db var 'extended-binding) ) ]
2328             [blockvar (memq var block-globals)] )
2329        (when blockvar (set! fastrefs (add1 fastrefs)))
2330        (make-node
2331         '##core#global
2332         (list (if blockvar
2333                   (blockvar-literal var)
2334                   (literal var) )
2335               safe
2336               blockvar
2337               var)
2338         '() ) ) )
2339
2340    (define (walk n e here boxes)
2341      (let ((subs (node-subexpressions n))
2342            (params (node-parameters n))
2343            (class (node-class n)) )
2344        (case class
2345
2346          ((##core#undefined ##core#proc) n)
2347
2348          ((##core#variable) 
2349           (walk-var (first params) e #f) )
2350
2351          ((##core#global-ref)
2352           (walk-global (first params) #t) )
2353
2354          ((##core#direct_call)
2355           (set! allocated (+ allocated (fourth params)))
2356           (make-node class params (mapwalk subs e here boxes)) )
2357
2358          ((##core#inline_allocate)
2359           (set! allocated (+ allocated (second params)))
2360           (make-node class params (mapwalk subs e here boxes)) )
2361
2362          ((##core#inline_ref)
2363           (set! allocated (+ allocated (words (estimate-foreign-result-size (second params)))))
2364           (make-node class params '()) )
2365
2366          ((##core#inline_loc_ref)
2367           (set! allocated (+ allocated (words (estimate-foreign-result-size (first params)))))
2368           (make-node class params (mapwalk subs e here boxes)) )
2369
2370          ((##core#closure) 
2371           (set! allocated (+ allocated (first params) 1))
2372           (make-node '##core#closure params (mapwalk subs e here boxes)) )
2373
2374          ((##core#box)
2375           (set! allocated (+ allocated 2))
2376           (make-node '##core#box params (list (walk (first subs) e here boxes))) )
2377
2378          ((##core#updatebox)
2379           (let* ([b (first subs)]
2380                  [subs (mapwalk subs e here boxes)] )
2381             (make-node
2382              (cond [(and (eq? '##core#variable (node-class b))
2383                          (memq (first (node-parameters b)) boxes) )
2384                     (set! fastinits (add1 fastinits))
2385                     '##core#updatebox_i]
2386                    [else class] )
2387              '()
2388              subs) ) )
2389
2390          ((##core#lambda ##core#direct_lambda) 
2391           (let ([temps temporaries]
2392                 [sigs signatures]
2393                 [lping looping]
2394                 [alc allocated] 
2395                 [direct (eq? class '##core#direct_lambda)] )
2396             (set! temporaries 0)
2397             (set! allocated 0)
2398             (set! signatures '())
2399             (set! looping 0)
2400             (decompose-lambda-list
2401              (third params)
2402              (lambda (vars argc rest)
2403                (let* ([id (first params)]
2404                       [rest-mode
2405                        (and rest
2406                             (let ([rrefs (get db rest 'references)])
2407                               (cond [(get db rest 'assigned) 'list]
2408                                     [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none] 
2409                                     [else (get db rest 'rest-parameter)] ) ) ) ]
2410                       [body (walk 
2411                              (car subs)
2412                              (if (eq? 'none rest-mode)
2413                                  (butlast vars)
2414                                  vars)
2415                              id
2416                              '()) ] )
2417                  (case rest-mode
2418                    [(none) (debugging 'o "unused rest argument" rest id)]
2419                    [(vector) (debugging 'o "rest argument accessed as vector" rest id)] )
2420                  (when (and direct rest)
2421                    (bomb "bad direct lambda" id allocated rest) )
2422                  (set! lambdas
2423                    (cons (make-lambda-literal
2424                           id
2425                           (second params)
2426                           vars
2427                           argc
2428                           rest
2429                           (add1 temporaries)
2430                           signatures
2431                           allocated
2432                           (or direct (memq id direct-call-ids))
2433                           (or (get db id 'closure-size) 0)
2434                           (and (not rest)
2435                                (> looping 0)
2436                                (begin
2437                                  (debugging 'o "identified direct recursive calls" id looping)
2438                                  #t) )
2439                           (or direct (get db id 'customizable))
2440                           rest-mode
2441                           body
2442                           direct)
2443                          lambdas) )
2444                  (set! looping lping)
2445                  (set! temporaries temps)
2446                  (set! allocated alc)
2447                  (set! signatures sigs)
2448                  (make-node '##core#proc (list (first params)) '()) ) ) ) ) )
2449
2450          ((let)
2451           (let* ([var (first params)]
2452                  [val (first subs)] 
2453                  [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
2454             (set! temporaries (add1 temporaries))
2455             (make-node
2456              '##core#bind (list 1)
2457              (list (walk val e here boxes)
2458                    (walk (second subs) (append e params) here (append boxvars boxes)) ) ) ) )
2459
2460          ((set!)
2461           (let ([var (first params)]
2462                 [val (first subs)] )
2463             (cond ((posq var e)
2464                    => (lambda (i) 
2465                         (make-node '##core#setlocal (list i) (list (walk val e here boxes)) ) ) )
2466                   (else
2467                    (let* ([cval (node-class val)]
2468                           [safe (not (or no-bound-checks
2469                                          unsafe
2470                                          (memq var always-bound)
2471                                          (get db var 'standard-binding)
2472                                          (get db var 'extended-binding) ) ) ]
2473                           [blockvar (memq var block-globals)]
2474                           [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
2475                                     (eq? '##core#undefined cval) ) ] )
2476                      (when blockvar (set! fastsets (add1 fastsets)))
2477                      (make-node
2478                       (if immf '##core#setglobal_i '##core#setglobal)
2479                       (list (if blockvar
2480                                 (blockvar-literal var)
2481                                 (literal var) )
2482                             blockvar
2483                             var)
2484                       (list (walk (car subs) e here boxes)) ) ) ) ) ) )
2485
2486          ((##core#call) 
2487           (let ([len (length (cdr subs))])
2488             (set! signatures (lset-adjoin = signatures len)) 
2489             (when (and (>= (length params) 3) (eq? here (third params)))
2490               (set! looping (add1 looping)) )
2491             (make-node class params (mapwalk subs e here boxes)) ) )
2492
2493          ((##core#recurse)
2494           (when (first params) (set! looping (add1 looping)))
2495           (make-node class params (mapwalk subs e here boxes)) )
2496
2497          ((quote)
2498           (let ((c (first params)))
2499             (cond ((and (fixnum? c) (not (big-fixnum? c)))
2500                    (immediate-literal c) )
2501                   ((number? c)
2502                    (cond ((eq? 'fixnum number-type)
2503                           (cond ((and (integer? c) (not (big-fixnum? c)))
2504                                  (compiler-warning 
2505                                   'type 
2506                                   "coerced inexact literal number `~S' to fixnum ~S" c (inexact->exact c))
2507                                  (immediate-literal (inexact->exact c)) )
2508                                 (else (quit "can not coerce inexact literal `~S' to fixnum" c)) ) )
2509                          (else (make-node '##core#literal (list (literal c)) '())) ) )
2510                   ((immediate? c) (immediate-literal c))
2511                   (else (make-node '##core#literal (list (literal c)) '())) ) ) )
2512
2513          ;;*** conditionals (if + ##core#cond) are missing here: allocation
2514          ;; calculation should use max of both branches, not sum.
2515
2516          (else (make-node class params (mapwalk subs e here boxes)) ) ) ) )
2517   
2518    (define (mapwalk xs e here boxes)
2519      (map (lambda (x) (walk x e here boxes)) xs) )
2520
2521    (define (literal x)
2522      (cond [(immediate? x) (immediate-literal x)]
2523            [(number? x)
2524             (or (and (inexact? x) 
2525                      (list-index (lambda (y) (and (number? y) (inexact? y) (= x y)))
2526                                  literals) )
2527                 (new-literal x)) ]
2528            ((##core#inline "C_lambdainfop" x)
2529             (let ((i (length lambda-info-literals)))
2530               (set! lambda-info-literals 
2531                 (append lambda-info-literals (list x))) ;*** see below
2532               (vector i) ) )
2533            [(posq x literals) => identity]
2534            [else (new-literal x)] ) )
2535
2536    (define (new-literal x)
2537      (let ([i (length literals)])
2538        (set! literals (append literals (list x))) ;*** could (should) be optimized
2539        i) )
2540
2541    (define (blockvar-literal var)
2542      (or (list-index
2543           (lambda (lit) 
2544             (and (block-variable-literal? lit)
2545                  (eq? var (block-variable-literal-name lit)) ) )
2546           literals)
2547          (new-literal (make-block-variable-literal var)) ) )
2548   
2549    (define (immediate-literal x)
2550      (if (eq? (void) x)
2551          (make-node '##core#undefined '() '())
2552          (make-node '##core#immediate
2553                     (cond ((fixnum? x) `(fix ,x))
2554                           ((boolean? x) `(bool ,x))
2555                           ((char? x) `(char ,x))
2556                           ((null? x) '(nil))
2557                           ((eof-object? x) '(eof))
2558                           (else (bomb "bad immediate (prepare)")) )
2559                     '() ) ) )
2560   
2561    (debugging 'p "preparation phase...")
2562    (let ((node2 (walk node '() #f '())))
2563      (debugging 'o "fast box initializations" fastinits)
2564      (debugging 'o "fast global references" fastrefs)
2565      (debugging 'o "fast global assignments" fastsets)
2566      (values node2 literals lambda-info-literals lambdas) ) ) )
Note: See TracBrowser for help on using the repository browser.