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

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

added TODO item

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