source: project/chicken/branches/hygienic/compiler.scm @ 11646

Last change on this file since 11646 was 11646, checked in by felix winkelmann, 12 years ago

merged with trunk rev. 11635; compiler bugfix; added files import lib

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