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

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

added support for alternative define-syntax syntax

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