Context Navigation

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

Last change on this file since 10788 was 10788, checked in by felix winkelmann, 13 years ago
added remaining import libraries csi uses srfi-69 now to avoid bootstrapping problem csi: renamed "-se" to "-sx" global assigns get variable name in comment in generated C code import libs are compiled to .so's (likely to be not complete for windoze builds - that would be too easy) removed a lot of deprecated stuff it really seems to work...
File size: 88.7 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: