source: project/chicken/branches/lazy-gensyms/compiler.scm @ 12629

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

support for lazy gensyms; some refactoring in get/put\!

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