source: project/chicken/branches/prerelease/compiler.scm @ 15101

Last change on this file since 15101 was 15101, checked in by felix winkelmann, 10 years ago

merged trunk changes from 14491:15100 into prerelease branch

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