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

Last change on this file since 14236 was 14236, checked in by felix winkelmann, 11 years ago

added er-macro-transformer

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