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

Last change on this file since 12201 was 12201, checked in by felix winkelmann, 12 years ago

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