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

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

strip unit names (if unit-name equals symbol in se); include windows.h and define WINAPI, when needed

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