Context Navigation

source: project/chicken/branches/hygienic/batch-driver.scm @ 11646

Last change on this file since 11646 was 11646, checked in by felix winkelmann, 12 years ago
merged with trunk rev. 11635; compiler bugfix; added files import lib
File size: 23.4 KB

Line
1	;;;; batch-driver.scm - Driver procedure for the compiler
2	;
3	; Copyright (c) 2000-2007, Felix L. Winkelmann
4	; Copyright (c) 2008, The Chicken Team
5	; All rights reserved.
6	;
7	; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8	; conditions are met:
9	;
10	; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11	; disclaimer.
12	; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13	; disclaimer in the documentation and/or other materials provided with the distribution.
14	; Neither the name of the author nor the names of its contributors may be used to endorse or promote
15	; products derived from this software without specific prior written permission.
16	;
17	; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18	; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19	; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20	; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21	; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22	; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23	; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24	; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25	; POSSIBILITY OF SUCH DAMAGE.
26
27
28	(declare
29	(unit driver)
30	(disable-warning var))
31
32
33	(private
34	compiler
35	compiler-arguments process-command-line dump-nodes dump-undefined-globals
36	default-standard-bindings default-extended-bindings side-effecting-standard-bindings
37	non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
38	standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
39	compiler-cleanup-hook disabled-warnings
40	file-io-only undefine-shadowed-macros profiled-procedures
41	unit-name insert-timer-checks used-units inline-max-size
42	debugging perform-lambda-lifting! disable-stack-overflow-checking
43	foreign-declarations emit-trace-info block-compilation line-number-database-size
44	target-heap-size target-stack-size target-heap-growth target-heap-shrinkage
45	default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
46	target-initial-heap-size postponed-initforms
47	current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
48	rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
49	broken-constant-nodes inline-substitutions-enabled compiler-macros-enabled
50	emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
51	direct-call-ids foreign-type-table first-analysis emit-closure-info
52	initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments
53	perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
54	reorganize-recursive-bindings substitution-table simplify-named-call emit-unsafe-marker
55	perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
56	transform-direct-lambdas! source-filename standalone-executable
57	debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
58	string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
59	collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all
60	put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode
61	build-node-graph build-expression-tree fold-boolean inline-lambda-bindings match-node expression-has-side-effects?
62	simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list external-protos-first
63	pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
64	topological-sort print-version print-usage initialize-analysis-database dump-exported-globals
65	default-declarations units-used-by-default words-per-flonum default-debugging-declarations
66	default-profiling-declarations default-optimization-passes
67	inline-max-size file-requirements import-libraries
68	foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
69	membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
70	chop-separator chop-extension display-real-name-table display-line-number-database explicit-use-flag
71	generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
72	export-list do-lambda-lifting compiler-warning export-file-name
73	foreign-argument-conversion foreign-result-conversion)
74
75
76	(include "tweaks")
77
78	(define-constant default-profile-name "PROFILE")
79	(define-constant default-inline-max-size 10)
80	(define-constant funny-message-timeout 60000)
81
82
83	;;; Compile a complete source file:
84
85	(define (compile-source-file filename . options)
86	(define (option-arg p)
87	(if (null? (cdr p))
88	(quit "missing argument to `-~A' option" (car p))
89	(let ([arg (cadr p)])
90	(if (symbol? arg)
91	(quit "invalid argument to `~A' option" arg)
92	arg) ) ) )
93	(initialize-compiler)
94	(set! explicit-use-flag (memq 'explicit-use options))
95	(let ([initforms `((##core#declare
96	,@(append
97	default-declarations
98	(if explicit-use-flag
99	'()
100	`((uses ,@units-used-by-default)) ) ) ) ) ]
101	[verbose (memq 'verbose options)]
102	[outfile (cond [(memq 'output-file options)
103	=> (lambda (node)
104	(let ([oname (option-arg node)])
105	(if (symbol? oname)
106	(symbol->string oname)
107	oname) ) ) ]
108	[(memq 'to-stdout options) #f]
109	[else (make-pathname #f (if filename (pathname-file filename) "out") "c")] ) ]
110	[ipath (map chop-separator (string-split (or (getenv "CHICKEN_INCLUDE_PATH") "") ";"))]
111	[opasses default-optimization-passes]
112	[time0 #f]
113	[time-breakdown #f]
114	[forms '()]
115	[cleanup-forms '(((##sys#implicit-exit-handler)))]
116	[profile (or (memq 'profile options) (memq 'accumulate-profile options) (memq 'profile-name options))]
117	[profile-name (or (and-let* ((pn (memq 'profile-name options))) (cadr pn)) default-profile-name)]
118	[hsize (memq 'heap-size options)]
119	[hisize (memq 'heap-initial-size options)]
120	[hgrowth (memq 'heap-growth options)]
121	[hshrink (memq 'heap-shrinkage options)]
122	[kwstyle (memq 'keyword-style options)]
123	[uses-units '()]
124	[uunit (memq 'unit options)]
125	[a-only (memq 'analyze-only options)]
126	[dynamic (memq 'dynamic options)]
127	[dumpnodes #f]
128	[quiet (memq 'quiet options)]
129	[start-time #f]
130	(upap #f)
131	[ssize (or (memq 'nursery options) (memq 'stack-size options))] )
132
133	(define (cputime) (##sys#fudge 6))
134
135	(define (print-header mode dbgmode)
136	(when verbose (printf "pass: ~a~%~!" mode))
137	(and (memq dbgmode debugging-chicken)
138	(begin
139	(printf "[~a]~%" mode)
140	#t) ) )
141
142	(define (print-node mode dbgmode n)
143	(when (print-header mode dbgmode)
144	(if dumpnodes
145	(dump-nodes n)
146	(pretty-print (build-expression-tree n)) ) ) )
147
148	(define (print-db mode dbgmode db pass)
149	(when (print-header mode dbgmode)
150	(printf "(iteration ~s)~%" pass)
151	(display-analysis-database db) ) )
152
153	(define (print-expr mode dbgmode xs)
154	(when (print-header mode dbgmode)
155	(for-each pretty-print xs) ) )
156
157	(define (infohook class data val)
158	(let ([data2 ((or ##sys#default-read-info-hook (lambda (a b c) b)) class data val)])
159	(when (and (eq? 'list-info class) (symbol? (car data2)))
160	(##sys#hash-table-set!
161	##sys#line-number-database
162	(car data2)
163	(alist-cons data2 val
164	(or (##sys#hash-table-ref ##sys#line-number-database (car data2))
165	'() ) ) ) )
166	data2) )
167
168	(define (arg-val str)
169	(let* ((len (string-length str))
170	(len1 (- len 1)) )
171	(or (if (< len 2)
172	(string->number str)
173	(case (string-ref str len1)
174	((#\m #\M) (* (string->number (substring str 0 len1)) (* 1024 1024)))
175	((#\k #\K) (* (string->number (substring str 0 len1)) 1024))
176	(else (string->number str)) ) )
177	(quit "invalid numeric argument ~S" str) ) ) )
178
179	(define (collect-options opt)
180	(let loop ([opts options])
181	(cond [(memq opt opts) => (lambda (p) (cons (option-arg p) (loop (cddr p))))]
182	[else '()] ) ) )
183
184	(define (begin-time)
185	(when time-breakdown (set! time0 (cputime))) )
186
187	(define (end-time pass)
188	(when time-breakdown
189	(printf "milliseconds needed for ~a: \t~s~%" pass (- (cputime) time0)) ) )
190
191	(define (read-form in)
192	(##sys#read in infohook) )
193
194	(define (analyze pass node . args)
195	(let-optionals args ((no 0) (contf #t))
196	(let ((db (analyze-expression node)))
197	(when upap
198	(upap pass db node
199	(cut get db <> <>)
200	(cut put! db <> <> <>)
201	no contf) )
202	db) ) )
203
204	(when uunit
205	(set! unit-name (string->c-identifier (stringify (option-arg uunit)))) )
206	(when (or unit-name dynamic)
207	(set! standalone-executable #f))
208	(set! debugging-chicken
209	(append-map
210	(lambda (do)
211	(map (lambda (c) (string->symbol (string c)))
212	(string->list do) ) )
213	(collect-options 'debug) ) )
214	(set! dumpnodes (memq '\|D\| debugging-chicken))
215	(set! import-libraries
216	(map (lambda (il)
217	(cons (string->symbol il)
218	(string-append il ".import.scm")))
219	(collect-options 'emit-import-library)))
220	(when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
221	(when (memq 'disable-compiler-macros options) (set! compiler-macros-enabled #f))
222	(when (memq 't debugging-chicken) (##sys#start-timer))
223	(when (memq 'b debugging-chicken) (set! time-breakdown #t))
224	(when (memq 'emit-exports options)
225	(warning "deprecated compiler option: emit-exports") )
226	(when (memq 'raw options)
227	(set! explicit-use-flag #t)
228	(set! cleanup-forms '())
229	(set! initforms '()) )
230	(when (memq 'no-lambda-info options)
231	(set! emit-closure-info #f) )
232	(when (memq 'check-imports options)
233	(compiler-warning 'usage "deprecated compiler option: -check-imports"))
234	(when (memq 'import options)
235	(compiler-warning 'usage "deprecated compiler option: -import"))
236	(set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
237	(when (memq 'no-warnings options)
238	(when verbose (printf "Warnings are disabled~%~!"))
239	(set! ##sys#warnings-enabled #f) )
240	(when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
241	(when (memq 'unsafe options)
242	(set! unsafe #t) )
243	(when (and dynamic (memq 'unsafe-libraries options))
244	(set! emit-unsafe-marker #t) )
245	(when (memq 'disable-interrupts options) (set! insert-timer-checks #f))
246	(when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
247	(when (memq 'block options) (set! block-compilation #t))
248	(when (memq 'emit-external-prototypes-first options) (set! external-protos-first #t))
249	(when (memq 'inline options) (set! inline-max-size default-inline-max-size))
250	(and-let* ([inlimit (memq 'inline-limit options)])
251	(set! inline-max-size
252	(let ([arg (option-arg inlimit)])
253	(or (string->number arg)
254	(quit "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
255	(when (memq 'case-insensitive options)
256	(when verbose (printf "Identifiers and symbols are case insensitive~%~!"))
257	(register-feature! 'case-insensitive)
258	(case-sensitive #f) )
259	(when (memq 'compress-literals options)
260	(compiler-warning 'usage "`the -compress-literals' option is obsolete") )
261	(when kwstyle
262	(let ([val (option-arg kwstyle)])
263	(cond [(string=? "prefix" val) (keyword-style #:prefix)]
264	[(string=? "none" val) (keyword-style #:none)]
265	[(string=? "suffix" val) (keyword-style #:suffix)]
266	[else (quit "invalid argument to `-keyword-style' option")] ) ) )
267	(set! verbose-mode verbose)
268	(set! ##sys#read-error-with-line-number #t)
269	(set! ##sys#include-pathnames
270	(append (map chop-separator (collect-options 'include-path))
271	##sys#include-pathnames
272	ipath) )
273	(when (and outfile filename (string=? outfile filename))
274	(quit "source- and output-filename are the same") )
275	(set! uses-units
276	(map string->symbol
277	(append-map
278	(cut string-split <> ",")
279	(collect-options 'uses))))
280	(when (memq 'keep-shadowed-macros options)
281	(set! undefine-shadowed-macros #f) )
282
283	;; Handle feature options:
284	(for-each
285	register-feature!
286	(append-map (cut string-split <> ",") (collect-options 'feature)))
287
288	;; Load extensions:
289	(set! ##sys#features (cons #:compiler-extension ##sys#features))
290	(let ([extends (collect-options 'extend)])
291	(when verbose
292	(printf "Loading compiler extensions...~%~!")
293	(load-verbose #t) )
294	(for-each (lambda (f) (load (##sys#resolve-include-filename f #f #t))) extends) )
295	(set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
296
297	(set! ##sys#features (cons '#:compiling ##sys#features))
298	(set! upap (user-post-analysis-pass))
299
300	;; Insert postponed initforms:
301	(set! initforms (append initforms postponed-initforms))
302
303	;; Handle `-extension' options:
304	(when (memq 'extension options)
305	(set! initforms
306	(append
307	initforms
308	`((define-extension
309	,(string->symbol
310	(cond (outfile (pathname-file outfile))
311	(filename (pathname-file filename))
312	(else (quit "no filename available for `-extension' option")) ) ) ) ) ) ) )
313
314	;; Append required extensions to initforms:
315	(let ()
316	(define (ids opt)
317	(lset-difference
318	eq?
319	(map string->symbol
320	(append-map
321	(cut string-split <> ",")
322	(collect-options opt)))
323	uses-units))
324	(set! initforms
325	(append
326	initforms
327	(map (lambda (r) `(##core#require-extension (,r) #t))
328	(ids 'require-extension))))
329
330	(when (memq 'compile-syntax options)
331	(set! ##sys#enable-runtime-macros #t) )
332	(set! target-heap-size
333	(if hsize
334	(arg-val (option-arg hsize))
335	(and-let* ([hsize default-default-target-heap-size]
336	[(not (zero? hsize))] )
337	hsize) ) )
338	(set! target-initial-heap-size (and hisize (arg-val (option-arg hisize))))
339	(set! target-heap-growth (and hgrowth (arg-val (option-arg hgrowth))))
340	(set! target-heap-shrinkage (and hshrink (arg-val (option-arg hshrink))))
341	(set! target-stack-size
342	(if ssize
343	(arg-val (option-arg ssize))
344	(and-let* ([ssize default-default-target-stack-size]
345	[(not (zero? ssize))] )
346	ssize) ) )
347	(set! emit-trace-info (not (memq 'no-trace options)))
348	(set! disable-stack-overflow-checking (memq 'disable-stack-overflow-checks options))
349	(when (memq 'm debugging-chicken) (set-gc-report! #t))
350	(unless (memq 'no-usual-integrations options)
351	(set! standard-bindings default-standard-bindings)
352	(set! extended-bindings default-extended-bindings) )
353	(when verbose
354	(printf "debugging info: ~A~%~!"
355	(if emit-trace-info
356	"stacktrace"
357	"none") ) )
358	(when profile
359	(let ([acc (eq? 'accumulate-profile (car profile))])
360	(set! emit-profile #t)
361	(set! profiled-procedures #f)
362	(set! initforms
363	(append
364	initforms
365	default-profiling-declarations
366	(if acc
367	'((set! ##sys#profile-append-mode #t))
368	'() ) ) )
369	(when verbose
370	(printf "Generating ~aprofile~%~!" (if acc "accumulated " "")) ) ) )
371
372	(cond ((memq 'version options)
373	(print-version #t)
374	(newline) )
375	((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
376	(print-usage))
377	((memq 'release options)
378	(display (chicken-version))
379	(newline) )
380	((not filename)
381	(unless quiet
382	(print-version #t)
383	(display "\nEnter \"chicken -help\" for information on how to use it.\n") ) )
384	(else
385
386	;; Display header:
387	(unless quiet
388	(printf "compiling `~a' ...~%" filename) )
389	(set! source-filename filename)
390	(debugging 'r "options" options)
391	(debugging 'r "debugging options" debugging-chicken)
392	(debugging 'r "target heap size" target-heap-size)
393	(debugging 'r "target stack size" target-stack-size)
394	(set! start-time (cputime))
395
396	;; Read toplevel expressions:
397	(set! ##sys#line-number-database (make-vector line-number-database-size '()))
398	(let ([prelude (collect-options 'prelude)]
399	[postlude (collect-options 'postlude)]
400	[files (append
401	(collect-options 'prologue)
402	(list filename)
403	(collect-options 'epilogue) ) ] )
404
405	(let ([proc (user-read-pass)])
406	(cond [proc
407	(when verbose (printf "User read pass...~%~!"))
408	(set! forms (proc prelude files postlude)) ]
409	[else
410	(do ([files files (cdr files)])
411	((null? files)
412	(set! forms
413	(append (map string->expr prelude)
414	(reverse forms)
415	(map string->expr postlude) ) ) )
416	(let* ((f (car files))
417	(in (check-and-open-input-file f)) )
418	(fluid-let ((##sys#current-source-filename f))
419	(let ((x1 (read-form in)) )
420	(do ((x x1 (read-form in)))
421	((eof-object? x)
422	(close-checked-input-file in f) )
423	(set! forms (cons x forms)) ) ) ) ) ) ] ) ) )
424
425	;; Start compilation passes:
426	(let ([proc (user-preprocessor-pass)])
427	(when proc
428	(when verbose (printf "User preprocessing pass...~%~!"))
429	(set! forms (map proc forms))))
430
431	(print-expr "source" '\|1\| forms)
432	(begin-time)
433	(unless (null? uses-units)
434	(set! ##sys#explicit-library-modules (append ##sys#explicit-library-modules uses-units))
435	(set! forms (cons `(declare (uses ,@uses-units)) forms)) )
436	(let* ([exps0 (map canonicalize-expression (append initforms forms))]
437	[pvec (gensym)]
438	[plen (length profile-lambda-list)]
439	[exps (append
440	(map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
441	(map (lambda (n) `(##core#callunit ,n)) used-units)
442	(if emit-profile
443	`((set! ,profile-info-vector-name
444	(##sys#register-profile-info
445	',plen
446	',(if unit-name #f profile-name))))
447	'() )
448	(map (lambda (pl)
449	`(##sys#set-profile-info-vector!
450	,profile-info-vector-name
451	',(car pl)
452	',(cdr pl) ) )
453	profile-lambda-list)
454	exps0
455	(if (and (not unit-name) (not dynamic))
456	cleanup-forms
457	'() )
458	'((##core#undefined))) ] )
459
460	(when (debugging '\|N\| "real name table:")
461	(display-real-name-table) )
462	(when (debugging 'n "line number database:")
463	(display-line-number-database) )
464
465	(when (and block-compilation unit-name)
466	(compiler-warning
467	'usage
468	"compilation of library unit `~a' in block-mode - globals may not be accessible outside this unit"
469	unit-name) )
470
471	(when (and unit-name dynamic)
472	(compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )
473
474	(when (and unsafe (feature? 'compiling-extension))
475	(compiler-warning
476	'style
477	"compiling extensions in unsafe mode is bad practice and should be avoided as it may be surprising to an unsuspecting user") )
478
479	(set! ##sys#line-number-database line-number-database-2)
480	(set! line-number-database-2 #f)
481
482	(end-time "canonicalization")
483	(print-expr "canonicalized" '\|2\| exps)
484
485	(when (memq 'check-syntax options) (exit))
486
487	(let ([proc (user-pass)])
488	(when proc
489	(when verbose (printf "User pass...~%~!"))
490	(begin-time)
491	(set! exps (map proc exps))
492	(end-time "user pass") ) )
493
494	(let* ([node0 (make-node
495	'lambda '(())
496	(list (build-node-graph
497	(canonicalize-begin-body exps) ) ) ) ]
498	[proc (user-pass-2)] )
499	(when (debugging 'M "; requirements:")
500	(pretty-print (##sys#hash-table->alist file-requirements)))
501	(when proc
502	(when verbose (printf "Secondary user pass...~%"))
503	(begin-time)
504	(set! first-analysis #f)
505	(let ([db (analyze 'user node0)])
506	(print-db "analysis (u)" '\|0\| db 0)
507	(end-time "pre-analysis (u)")
508	(begin-time)
509	(proc node0)
510	(end-time "secondary user pass")
511	(print-node "secondary user pass" '\|U\| node0) )
512	(set! first-analysis #t) )
513
514	(when do-lambda-lifting
515	(begin-time)
516	(set! first-analysis #f)
517	(let ([db (analyze 'lift node0)])
518	(print-db "analysis" '\|0\| db 0)
519	(end-time "pre-analysis")
520	(begin-time)
521	(perform-lambda-lifting! node0 db)
522	(end-time "lambda lifting")
523	(print-node "lambda lifted" '\|L\| node0) )
524	(set! first-analysis #t) )
525
526	(set! ##sys#line-number-database #f)
527	(set! constant-table #f)
528	(set! inline-table #f)
529	(unless unsafe
530	(scan-toplevel-assignments (first (node-subexpressions node0))) )
531
532	(begin-time)
533	(let ([node1 (perform-cps-conversion node0)])
534	(end-time "cps conversion")
535	(print-node "cps" '\|3\| node1)
536
537	;; Optimization loop:
538	(let loop ([i 1] [node2 node1] [progress #t])
539
540	(begin-time)
541	(let ([db (analyze 'opt node2 i progress)])
542	(when first-analysis
543	(when (memq 'u debugging-chicken)
544	(dump-undefined-globals db)) )
545	(set! first-analysis #f)
546	(end-time "analysis")
547	(print-db "analysis" '\|4\| db i)
548
549	(when (memq 's debugging-chicken) (print-program-statistics db))
550
551	(cond [progress
552	(debugging 'p "optimization pass" i)
553
554	(begin-time)
555	(receive (node2 progress-flag) (perform-high-level-optimizations node2 db)
556	(end-time "optimization")
557	(print-node "optimized-iteration" '\|5\| node2)
558
559	(cond [progress-flag (loop (add1 i) node2 #t)]
560	[(not inline-substitutions-enabled)
561	(debugging 'p "rewritings enabled...")
562	(set! inline-substitutions-enabled #t)
563	(loop (add1 i) node2 #t) ]
564	[optimize-leaf-routines
565	(begin-time)
566	(let ([db (analyze 'leaf node2)])
567	(end-time "analysis")
568	(begin-time)
569	(let ([progress (transform-direct-lambdas! node2 db)])
570	(end-time "leaf routine optimization")
571	(loop (add1 i) node2 progress) ) ) ]
572	[else (loop (add1 i) node2 #f)] ) ) ]
573
574	[else
575	(print-node "optimized" '\|7\| node2)
576
577	(begin-time)
578	(let ([node3 (perform-closure-conversion node2 db)])
579	(end-time "closure conversion")
580	(print-db "final-analysis" '\|8\| db i)
581	(when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
582	(display "(do not worry - still compiling...)\n") )
583	(when a-only (exit 0))
584	(print-node "closure-converted" '\|9\| node3)
585
586	(begin-time)
587	(receive (node literals lliterals lambdas)
588	(prepare-for-code-generation node3 db)
589	(end-time "preparation")
590
591	(begin-time)
592	(let ((out (if outfile (open-output-file outfile) (current-output-port))) )
593	(unless quiet
594	(printf "generating `~A' ...~%" outfile) )
595	(generate-code literals lliterals lambdas out filename dynamic db)
596	(when outfile (close-output-port out)))
597	(end-time "code generation")
598	(when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
599	(compiler-cleanup-hook)
600	(when verbose
601	(printf "compilation finished.~%~!") ) ) ) ] ) ) ) ) ) ) ) ) ) ) )

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

Download in other formats: