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

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

foreign types are strip-syntax'ed (should fix #17), reported by Shawn Rutledge

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