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

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

merged trunk rev. 14940 into prerelease branch

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