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

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

bumped version to 4.0.4; fixed various bugs in chicken-install; fixed name-resolution bug in compiler handling of assignment

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