source: project/chicken/branches/beyond-hope/compiler.scm @ 10426

Last change on this file since 10426 was 10426, checked in by felix winkelmann, 13 years ago

removed current module crap and made compiler run again; fixed several bugs introduced by decruftification; I'm still the boss here.

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