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

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

working mini-setup; csi describe and report tweaks; wrong handling of require-extension with core libs (import case)

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