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

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

slight change in semantics for define-compiler-syntax, some testing

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