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

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

added -emit-all-import-libraries

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