source: project/chicken/trunk/compiler.scm @ 12301

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

merged changes from cmi branch

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