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

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

(really) merged trunk changes till 15228 into prerelease branch

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