source: project/chicken/trunk/batch-driver.scm @ 15770

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

added -emit-all-import-libraries

File size: 22.5 KB
Line 
1;;;; batch-driver.scm - Driver procedure for the compiler
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, 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(include "compiler-namespace")
33(include "tweaks")
34
35(define-constant default-profile-name "PROFILE")
36(define-constant funny-message-timeout 60000)
37
38(define user-options-pass (make-parameter #f))
39(define user-read-pass (make-parameter #f))
40(define user-preprocessor-pass (make-parameter #f))
41(define user-pass (make-parameter #f))
42(define user-post-analysis-pass (make-parameter #f))
43
44
45;;; Compile a complete source file:
46
47(define (compile-source-file filename . options)
48  (define (option-arg p)
49    (if (null? (cdr p))
50        (quit "missing argument to `-~A' option" (car p))
51        (let ([arg (cadr p)])
52          (if (symbol? arg)
53              (quit "invalid argument to `~A' option" arg)
54              arg) ) ) )
55  (initialize-compiler)
56  (set! explicit-use-flag (memq 'explicit-use options))
57  (let ([initforms `((##core#declare
58                      ,@(append
59                         default-declarations
60                         (if explicit-use-flag
61                             '()
62                             `((uses ,@units-used-by-default)) ) ) ) ) ]
63        [verbose (memq 'verbose options)]
64        [outfile (cond [(memq 'output-file options) 
65                        => (lambda (node)
66                             (let ([oname (option-arg node)])
67                               (if (symbol? oname)
68                                   (symbol->string oname)
69                                   oname) ) ) ]
70                       [(memq 'to-stdout options) #f]
71                       [else (make-pathname #f (if filename (pathname-file filename) "out") "c")] ) ]
72        [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))]
73        [opasses default-optimization-passes]
74        [time0 #f]
75        [time-breakdown #f]
76        [forms '()]
77        [cleanup-forms '(((##sys#implicit-exit-handler)))]
78        [profile (or (memq 'profile options) (memq 'accumulate-profile options) (memq 'profile-name options))]
79        [profile-name (or (and-let* ((pn (memq 'profile-name options))) (cadr pn)) default-profile-name)]
80        [hsize (memq 'heap-size options)]
81        [hisize (memq 'heap-initial-size options)]
82        [hgrowth (memq 'heap-growth options)]
83        [hshrink (memq 'heap-shrinkage options)]
84        [kwstyle (memq 'keyword-style options)]
85        [uses-units '()]
86        [uunit (memq 'unit options)]
87        [a-only (memq 'analyze-only options)]
88        [dynamic (memq 'dynamic options)]
89        [dumpnodes #f]
90        [start-time #f]
91        (upap #f)
92        [ssize (or (memq 'nursery options) (memq 'stack-size options))] )
93
94    (define (cputime) (##sys#fudge 6))
95
96    (define (dribble fstr . args)
97      (when verbose (printf "~?~%~!" fstr args)))
98
99    (define (print-header mode dbgmode)
100      (dribble "pass: ~a" mode)
101      (and (memq dbgmode debugging-chicken)
102           (begin
103             (printf "[~a]~%" mode)
104             #t) ) )
105
106    (define (print-node mode dbgmode n)
107      (when (print-header mode dbgmode)
108        (if dumpnodes
109            (dump-nodes n)
110            (pretty-print (build-expression-tree n)) ) ) )
111
112    (define (print-db mode dbgmode db pass)
113      (when (print-header mode dbgmode)
114        (printf "(iteration ~s)~%" pass)
115        (display-analysis-database db) ) )
116
117    (define (print-expr mode dbgmode xs)
118      (when (print-header mode dbgmode)
119        (for-each pretty-print xs) ) )
120
121    (define (infohook class data val)
122      (let ([data2 ((or ##sys#default-read-info-hook (lambda (a b c) b)) class data val)])
123        (when (and (eq? 'list-info class) (symbol? (car data2)))
124          (##sys#hash-table-set!
125           ##sys#line-number-database
126           (car data2)
127           (alist-cons data2 val
128                       (or (##sys#hash-table-ref ##sys#line-number-database (car data2))
129                           '() ) ) ) )
130        data2) )
131
132    (define (arg-val str)
133      (let* ((len (string-length str))
134             (len1 (- len 1)) )
135        (or (if (< len 2)
136                (string->number str)
137                (case (string-ref str len1)
138                  ((#\m #\M) (* (string->number (substring str 0 len1)) (* 1024 1024)))
139                  ((#\k #\K) (* (string->number (substring str 0 len1)) 1024))
140                  (else (string->number str)) ) )
141            (quit "invalid numeric argument ~S" str) ) ) )
142
143    (define (collect-options opt)
144      (let loop ([opts options])
145        (cond [(memq opt opts) => (lambda (p) (cons (option-arg p) (loop (cddr p))))]
146              [else '()] ) ) )
147
148    (define (begin-time)
149      (when time-breakdown (set! time0 (cputime))) )
150
151    (define (end-time pass)
152      (when time-breakdown
153        (printf "milliseconds needed for ~a: \t~s~%" pass (- (cputime) time0)) ) )
154
155    (define (read-form in)
156      (##sys#read in infohook) )
157
158    (define (analyze pass node . args)
159      (let-optionals args ((no 0) (contf #t))
160        (let ((db (analyze-expression node)))
161          (when upap
162            (upap pass db node
163                  (cut get db <> <>)
164                  (cut put! db <> <> <>)
165                  no contf) )
166          db) ) )
167
168    (when uunit
169      (set! unit-name (string->c-identifier (stringify (option-arg uunit)))) )
170    (when (or unit-name dynamic)
171      (set! standalone-executable #f))
172    (when (memq 'ignore-repository options)
173      (set! ##sys#dload-disabled #t)
174      (repository-path #f))
175    (set! debugging-chicken 
176      (append-map
177       (lambda (do)
178         (map (lambda (c) (string->symbol (string c)))
179              (string->list do) ) )
180       (collect-options 'debug) ) )
181    (set! dumpnodes (memq '|D| debugging-chicken))
182    (set! import-libraries
183      (map (lambda (il)
184             (cons (string->symbol il) 
185                   (string-append il ".import.scm")))
186           (collect-options 'emit-import-library)))
187    (when (and (memq 'emit-all-import-libraries options)
188               (not a-only))
189      (set! all-import-libraries #t))
190    (when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
191    (when (memq 'scrutinize options) (set! do-scrutinize #t))
192    (when (memq 't debugging-chicken) (##sys#start-timer))
193    (when (memq 'b debugging-chicken) (set! time-breakdown #t))
194    (when (memq 'emit-exports options)
195      (warning "deprecated compiler option: emit-exports") )
196    (when (memq 'raw options)
197      (set! explicit-use-flag #t)
198      (set! cleanup-forms '())
199      (set! initforms '()) )
200    (when (memq 'no-lambda-info options)
201      (set! emit-closure-info #f) )
202    (when (memq 'no-compiler-syntax options)
203      (set! compiler-syntax-enabled #f))
204    (when (memq 'local options)
205      (set! local-definitions #t))
206    (when (memq 'inline-global options)
207      (set! enable-inline-files #t)
208      (set! inline-locally #t)
209      (set! inline-globally #t))
210    (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
211    (when (memq 'no-warnings options) 
212      (dribble "Warnings are disabled")
213      (set! ##sys#warnings-enabled #f) )
214    (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
215    (when (memq 'unsafe options) 
216      (set! unsafe #t) )
217    (when (and dynamic (memq 'unsafe-libraries options))
218      (set! emit-unsafe-marker #t) )
219    (when (memq 'disable-interrupts options) (set! insert-timer-checks #f))
220    (when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
221    (when (memq 'block options) (set! block-compilation #t))
222    (when (memq 'emit-external-prototypes-first options)
223      (set! external-protos-first #t))
224    (when (memq 'inline options) (set! inline-locally #t))
225    (and-let* ((ifile (memq 'emit-inline-file options)))
226      (set! inline-locally #t)          ; otherwise this option makes no sense
227      (set! local-definitions #t)
228      (set! inline-output-file (option-arg ifile)))
229    (and-let* ([inlimit (memq 'inline-limit options)])
230      (set! inline-max-size 
231        (let ([arg (option-arg inlimit)])
232          (or (string->number arg)
233              (quit "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
234    (when (memq 'case-insensitive options) 
235      (dribble "Identifiers and symbols are case insensitive")
236      (register-feature! 'case-insensitive)
237      (case-sensitive #f) )
238    (when (memq 'compress-literals options)
239      (compiler-warning 'usage "`the -compress-literals' option is obsolete") )
240    (when kwstyle
241      (let ([val (option-arg kwstyle)])
242        (cond [(string=? "prefix" val) (keyword-style #:prefix)]
243              [(string=? "none" val) (keyword-style #:none)]
244              [(string=? "suffix" val) (keyword-style #:suffix)]
245              [else (quit "invalid argument to `-keyword-style' option")] ) ) )
246    (when (memq 'no-parenthesis-synonyms options)
247      (dribble "Disabled support for parenthesis synonyms")
248      (parenthesis-synonyms #f) )
249    (when (memq 'no-symbol-escape options) 
250      (dribble "Disabled support for escaped symbols")
251      (symbol-escape #f) )
252    (when (memq '("-r5rs-syntax") options)
253      (dribble "Disabled the Chicken extensions to R5RS syntax")
254      (case-sensitive #f)
255      (keyword-style #:none)
256      (parentheses-synonyms #f)
257      (symbol-escape #f) )
258    (set! verbose-mode verbose)
259    (set! ##sys#read-error-with-line-number #t)
260    (set! ##sys#include-pathnames
261      (append (map chop-separator (collect-options 'include-path))
262              ##sys#include-pathnames
263              ipath) )
264    (when (and outfile filename (string=? outfile filename))
265      (quit "source- and output-filename are the same") )
266    (set! uses-units (map string->symbol (collect-options 'uses)))
267    (when (memq 'keep-shadowed-macros options)
268      (set! undefine-shadowed-macros #f) )
269    (when (memq 'no-argc-checks options)
270      (set! no-argc-checks #t) )
271    (when (memq 'no-bound-checks options)
272      (set! no-bound-checks #t) )
273    (when (memq 'no-procedure-checks options)
274      (set! no-procedure-checks #t) )
275    (when (memq 'no-procedure-checks-for-usual-bindings options)
276      (for-each
277       (lambda (v)
278         (mark-variable v '##compiler#always-bound-to-procedure)
279         (mark-variable v '##compiler#always-bound) )
280       default-standard-bindings)
281      (for-each
282       (lambda (v)
283         (mark-variable v '##compiler#always-bound-to-procedure)
284         (mark-variable v '##compiler#always-bound) )
285       default-extended-bindings) )
286
287    ;; Handle feature options:
288    (for-each
289     register-feature!
290     (append-map (cut string-split <> ",") (collect-options 'feature)))
291
292    ;; Load extensions:
293    (set! ##sys#features (cons #:compiler-extension ##sys#features))
294    (let ([extends (collect-options 'extend)])
295      (dribble "Loading compiler extensions...")
296      (when verbose (load-verbose #t))
297      (for-each
298       (lambda (f) (load (##sys#resolve-include-filename f #f #t))) 
299       extends) )
300    (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
301
302    (set! ##sys#features (cons '#:compiling ##sys#features))
303    (set! upap (user-post-analysis-pass))
304
305    ;; Insert postponed initforms:
306    (set! initforms (append initforms postponed-initforms))
307
308    (let ((se (map string->symbol (collect-options 'static-extension))))
309      ;; Append required extensions to initforms:
310      (set! initforms
311        (append
312         initforms 
313         (map (lambda (r) `(##core#require-extension (,r) #t)) 
314              (append se (map string->symbol (collect-options 'require-extension))))))
315
316      ;; add static-extensions as used units:
317      (set! ##sys#explicit-library-modules
318        (append ##sys#explicit-library-modules se)))
319
320    (when (memq 'compile-syntax options)
321      (set! ##sys#enable-runtime-macros #t) )
322    (set! target-heap-size
323      (if hsize
324          (arg-val (option-arg hsize))
325          (and-let* ([hsize default-default-target-heap-size]
326                     [(not (zero? hsize))] )
327            hsize) ) )
328    (set! target-initial-heap-size (and hisize (arg-val (option-arg hisize))))
329    (set! target-heap-growth (and hgrowth (arg-val (option-arg hgrowth))))
330    (set! target-heap-shrinkage (and hshrink (arg-val (option-arg hshrink))))
331    (set! target-stack-size
332      (if ssize
333          (arg-val (option-arg ssize))
334          (and-let* ([ssize default-default-target-stack-size]
335                     [(not (zero? ssize))] )
336            ssize) ) )
337    (set! emit-trace-info (not (memq 'no-trace options)))
338    (set! disable-stack-overflow-checking (memq 'disable-stack-overflow-checks options))
339    (when (memq 'm debugging-chicken) (set-gc-report! #t))
340    (unless (memq 'no-usual-integrations options)
341      (set! standard-bindings default-standard-bindings)
342      (set! extended-bindings default-extended-bindings) )
343    (dribble "debugging info: ~A"
344             (if emit-trace-info
345                 "calltrace"
346                 "none") )
347    (when profile
348      (let ([acc (eq? 'accumulate-profile (car profile))])
349        (set! emit-profile #t)
350        (set! profiled-procedures 'all)
351        (set! initforms
352          (append
353           initforms
354           default-profiling-declarations
355           (if acc
356               '((set! ##sys#profile-append-mode #t))
357               '() ) ) )
358        (dribble "Generating ~aprofile" (if acc "accumulated " "")) ) )
359
360    ;;*** hardcoded "modules.db" is bad (also used in chicken-install.scm)
361    (load-identifier-database "modules.db")
362
363    (cond ((memq 'version options)
364           (print-version #t)
365           (newline) )
366          ((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
367           (print-usage))
368          ((memq 'release options)
369           (display (chicken-version)) 
370           (newline) )
371          ((not filename)
372           (print-version #t)
373           (display "\nEnter \"chicken -help\" for information on how to use it.\n") )
374          (else
375
376           ;; Display header:
377           (dribble "compiling `~a' ..." filename)
378           (set! source-filename filename)
379           (debugging 'r "options" options)
380           (debugging 'r "debugging options" debugging-chicken)
381           (debugging 'r "target heap size" target-heap-size)
382           (debugging 'r "target stack size" target-stack-size)
383           (set! start-time (cputime))
384
385           ;; Read toplevel expressions:
386           (set! ##sys#line-number-database (make-vector line-number-database-size '()))
387           (let ([prelude (collect-options 'prelude)]
388                 [postlude (collect-options 'postlude)] 
389                 [files (append
390                         (collect-options 'prologue)
391                         (list filename)
392                         (collect-options 'epilogue) ) ]  )
393
394             (let ([proc (user-read-pass)])
395               (cond [proc
396                      (dribble "User read pass...")
397                      (set! forms (proc prelude files postlude)) ]
398                     [else
399                      (do ([files files (cdr files)])
400                          ((null? files)
401                           (set! forms
402                             (append (map string->expr prelude)
403                                     (reverse forms)
404                                     (map string->expr postlude) ) ) )
405                        (let* ((f (car files))
406                               (in (check-and-open-input-file f)) )
407                          (fluid-let ((##sys#current-source-filename f))
408                            (let ((x1 (read-form in)) )
409                              (do ((x x1 (read-form in)))
410                                  ((eof-object? x) 
411                                   (close-checked-input-file in f) )
412                                (set! forms (cons x forms)) ) ) ) ) ) ] ) ) )
413
414           ;; Start compilation passes:
415           (let ([proc (user-preprocessor-pass)])
416             (when proc
417               (dribble "User preprocessing pass...")
418               (set! forms (map proc forms))))
419
420           (print-expr "source" '|1| forms)
421           (begin-time)
422           (unless (null? uses-units)
423             (set! ##sys#explicit-library-modules (append ##sys#explicit-library-modules uses-units))
424             (set! forms (cons `(declare (uses ,@uses-units)) forms)) )
425           (let* ([exps0 (map canonicalize-expression (append initforms forms))]
426                  [pvec (gensym)]
427                  [plen (length profile-lambda-list)]
428                  [exps (append
429                         (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
430                         (map (lambda (n) `(##core#callunit ,n)) used-units)
431                         (if emit-profile
432                             `((set! ,profile-info-vector-name 
433                                 (##sys#register-profile-info
434                                  ',plen
435                                  ',(if unit-name #f profile-name))))
436                             '() )
437                         (map (lambda (pl)
438                                `(##sys#set-profile-info-vector!
439                                  ,profile-info-vector-name
440                                  ',(car pl)
441                                  ',(cdr pl) ) )
442                              profile-lambda-list)
443                         exps0
444                         (if (and (not unit-name) (not dynamic))
445                             cleanup-forms
446                             '() )
447                         '((##core#undefined))) ] )
448
449             (when (and (pair? compiler-syntax-statistics)
450                        (debugging 'o "applied compiler syntax:"))
451               (for-each
452                (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
453                compiler-syntax-statistics))
454             (when (debugging '|N| "real name table:")
455               (display-real-name-table) )
456             (when (debugging 'n "line number database:")
457               (display-line-number-database) )
458
459             (when (and unit-name dynamic)
460               (compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )
461
462             (when (and unsafe (feature? 'compiling-extension))
463               (compiler-warning 
464                'style
465                "compiling extensions in unsafe mode is bad practice and should be avoided") )
466
467             (set! ##sys#line-number-database line-number-database-2)
468             (set! line-number-database-2 #f)
469
470             (end-time "canonicalization")
471             (print-expr "canonicalized" '|2| exps)
472
473             (when (memq 'check-syntax options) (exit))
474
475             (let ([proc (user-pass)])
476               (when proc
477                 (dribble "User pass...")
478                 (begin-time)
479                 (set! exps (map proc exps))
480                 (end-time "user pass") ) )
481
482             (let ((node0 (make-node
483                           'lambda '(())
484                           (list (build-node-graph
485                                  (canonicalize-begin-body exps) ) ) ) ) 
486                   (db #f))
487
488               (print-node "initial node tree" '|T| node0)
489               (initialize-analysis-database)
490
491               (when do-scrutinize
492                 ;;;*** hardcoded database file name
493                 (unless (memq 'ignore-repository options)
494                   (load-type-database "types.db"))
495                 (for-each (cut load-type-database <> #f) (collect-options 'types))
496                 (begin-time)
497                 (set! first-analysis #f)
498                 (set! db (analyze 'scrutiny node0))
499                 (print-db "analysis" '|0| db 0)
500                 (end-time "pre-analysis")
501                 (begin-time)
502                 (debugging 'p "performing scrutiny")
503                 (scrutinize node0 db)
504                 (end-time "scrutiny")
505                 (set! first-analysis #t) )
506
507               (when do-lambda-lifting
508                 (begin-time)
509                 (unless do-scrutinize  ; no need to do analysis if already done above
510                   (set! first-analysis #f)
511                   (set! db (analyze 'lift node0))
512                   (print-db "analysis" '|0| db 0)
513                   (end-time "pre-analysis (lambda-lift)"))
514                 (begin-time)
515                 (perform-lambda-lifting! node0 db)
516                 (end-time "lambda lifting")
517                 (print-node "lambda lifted" '|L| node0) 
518                 (set! first-analysis #t) )
519               
520               (let ((req (concatenate (vector->list file-requirements))))
521                 (when (debugging 'M "; requirements:")
522                   (pp req))
523                 (when enable-inline-files
524                   (for-each
525                    (lambda (id)
526                      (and-let* ((ifile (##sys#resolve-include-filename 
527                                         (make-pathname #f (symbol->string id) "inline")
528                                         #f #t))
529                                 ((file-exists? ifile)))
530                        (dribble "Loading inline file ~a ..." ifile)
531                        (load-inline-file ifile)))
532                    (concatenate (map cdr req))) )
533                 (let ((ifs (collect-options 'consult-inline-file)))
534                   (unless (null? ifs)
535                     (set! inline-globally #t)
536                     (set! inline-locally #t)
537                     (for-each
538                      (lambda (ilf)
539                        (dribble "Loading inline file ~a ..." ilf)
540                        (load-inline-file ilf) )
541                      ifs))))
542
543               (set! ##sys#line-number-database #f)
544               (set! constant-table #f)
545               (set! inline-table #f)
546               (unless unsafe
547                 (scan-toplevel-assignments (first (node-subexpressions node0))) )
548
549               (begin-time)
550               (let ([node1 (perform-cps-conversion node0)])
551                 (end-time "cps conversion")
552                 (print-node "cps" '|3| node1)
553
554                 ;; Optimization loop:
555                 (let loop ([i 1] [node2 node1] [progress #t])
556
557                   (begin-time)
558                   (let ([db (analyze 'opt node2 i progress)])
559                     (when first-analysis
560                       (when (memq 'u debugging-chicken)
561                         (dump-undefined-globals db))
562                       (when (memq 'd debugging-chicken)
563                         (dump-defined-globals db))
564                       (when (memq 'v debugging-chicken)
565                         (dump-global-refs db)) )
566                     (set! first-analysis #f)
567                     (end-time "analysis")
568                     (print-db "analysis" '|4| db i)
569
570                     (when (memq 's debugging-chicken) (print-program-statistics db))
571
572                     (cond [progress
573                            (debugging 'p "optimization pass" i)
574
575                            (begin-time)
576                            (receive (node2 progress-flag)
577                                (perform-high-level-optimizations node2 db)
578                              (end-time "optimization")
579                              (print-node "optimized-iteration" '|5| node2)
580
581                              (cond [progress-flag (loop (add1 i) node2 #t)]
582                                    [(not inline-substitutions-enabled)
583                                     (debugging 'p "rewritings enabled...")
584                                     (set! inline-substitutions-enabled #t)
585                                     (loop (add1 i) node2 #t) ]
586                                    [optimize-leaf-routines
587                                     (begin-time)
588                                     (let ([db (analyze 'leaf node2)])
589                                       (end-time "analysis")
590                                       (begin-time)
591                                       (let ([progress (transform-direct-lambdas! node2 db)])
592                                         (end-time "leaf routine optimization")
593                                         (loop (add1 i) node2 progress) ) ) ]
594                                    [else (loop (add1 i) node2 #f)] ) ) ]
595                           
596                           [else
597                            (print-node "optimized" '|7| node2)
598
599                            (when inline-output-file
600                              (let ((f inline-output-file))
601                                (dribble "Generating global inline file `~a' ..." f)
602                                (emit-global-inline-file f db) ) )
603
604                            (begin-time)
605                            (let ([node3 (perform-closure-conversion node2 db)])
606                              (end-time "closure conversion")
607                              (print-db "final-analysis" '|8| db i)
608                              (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
609                                (display "(don't worry - still compiling...)\n") )
610                              (when a-only (exit 0))
611                              (print-node "closure-converted" '|9| node3)
612
613                              (begin-time)
614                              (receive (node literals lliterals lambdas)
615                                  (prepare-for-code-generation node3 db)
616                                (end-time "preparation")
617
618                                (begin-time)
619                                (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
620                                  (dribble "generating `~A' ..." outfile)
621                                  (generate-code literals lliterals lambdas out filename dynamic db)
622                                  (when outfile (close-output-port out)))
623                                (end-time "code generation")
624                                (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
625                                (compiler-cleanup-hook)
626                                (dribble "compilation finished.") ) ) ] ) ) ) ) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.