source: project/chicken/branches/scrutiny/compiler.scm @ 13965

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

merged trunk rev. 13953

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