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

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

merged scrutiny branch

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