source: project/chicken/branches/dsssl-delegate/compiler.scm @ 16107

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

delegation function argument for ##sys#expand-extended-lambda-list

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