source: project/chicken/branches/inlining/batch-driver.scm @ 15323

Last change on this file since 15323 was 15323, checked in by felix winkelmann, 10 years ago

more intelligent inlining; standard-extension procedure in setup-api

File size: 22.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-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 (memq 'lambda-lift options) (set! do-lambda-lifting #t))
188    (when (memq 'scrutinize options) (set! do-scrutinize #t))
189    (when (memq 't debugging-chicken) (##sys#start-timer))
190    (when (memq 'b debugging-chicken) (set! time-breakdown #t))
191    (when (memq 'emit-exports options)
192      (warning "deprecated compiler option: emit-exports") )
193    (when (memq 'raw options)
194      (set! explicit-use-flag #t)
195      (set! cleanup-forms '())
196      (set! initforms '()) )
197    (when (memq 'no-lambda-info options)
198      (set! emit-closure-info #f) )
199    (when (memq 'no-compiler-syntax options)
200      (set! compiler-syntax-enabled #f))
201    (when (memq 'local options)
202      (set! local-definitions #t))
203    (when (memq 'inline-global options)
204      (set! enable-inline-files #t)
205      (set! inline-locally #t)
206      (set! inline-globally #t))
207    (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
208    (when (memq 'no-warnings options) 
209      (dribble "Warnings are disabled")
210      (set! ##sys#warnings-enabled #f) )
211    (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
212    (when (memq 'unsafe options) 
213      (set! unsafe #t) )
214    (when (and dynamic (memq 'unsafe-libraries options))
215      (set! emit-unsafe-marker #t) )
216    (when (memq 'disable-interrupts options) (set! insert-timer-checks #f))
217    (when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
218    (when (memq 'block options) (set! block-compilation #t))
219    (when (memq 'emit-external-prototypes-first options)
220      (set! external-protos-first #t))
221    (when (memq 'inline options) (set! inline-locally #t))
222    (and-let* ((ifile (memq 'emit-inline-file options)))
223      (set! inline-locally #t)          ; otherwise this option makes no sense
224      (set! local-definitions #t)
225      (set! inline-output-file (option-arg ifile)))
226    (and-let* ([inlimit (memq 'inline-limit options)])
227      (set! inline-max-size 
228        (let ([arg (option-arg inlimit)])
229          (or (string->number arg)
230              (quit "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
231    (when (memq 'case-insensitive options) 
232      (dribble "Identifiers and symbols are case insensitive")
233      (register-feature! 'case-insensitive)
234      (case-sensitive #f) )
235    (when (memq 'compress-literals options)
236      (compiler-warning 'usage "`the -compress-literals' option is obsolete") )
237    (when kwstyle
238      (let ([val (option-arg kwstyle)])
239        (cond [(string=? "prefix" val) (keyword-style #:prefix)]
240              [(string=? "none" val) (keyword-style #:none)]
241              [(string=? "suffix" val) (keyword-style #:suffix)]
242              [else (quit "invalid argument to `-keyword-style' option")] ) ) )
243    (when (memq 'no-parenthesis-synonyms options)
244      (dribble "Disabled support for parenthesis synonyms")
245      (parenthesis-synonyms #f) )
246    (when (memq 'no-symbol-escape options) 
247      (dribble "Disabled support for escaped symbols")
248      (symbol-escape #f) )
249    (when (memq '("-r5rs-syntax") options)
250      (dribble "Disabled the Chicken extensions to R5RS syntax")
251      (case-sensitive #f)
252      (keyword-style #:none)
253      (parentheses-synonyms #f)
254      (symbol-escape #f) )
255    (set! verbose-mode verbose)
256    (set! ##sys#read-error-with-line-number #t)
257    (set! ##sys#include-pathnames
258      (append (map chop-separator (collect-options 'include-path))
259              ##sys#include-pathnames
260              ipath) )
261    (when (and outfile filename (string=? outfile filename))
262      (quit "source- and output-filename are the same") )
263    (set! uses-units (map string->symbol (collect-options 'uses)))
264    (when (memq 'keep-shadowed-macros options)
265      (set! undefine-shadowed-macros #f) )
266    (when (memq 'no-argc-checks options)
267      (set! no-argc-checks #t) )
268    (when (memq 'no-bound-checks options)
269      (set! no-bound-checks #t) )
270    (when (memq 'no-procedure-checks options)
271      (set! no-procedure-checks #t) )
272    (when (memq 'no-procedure-checks-for-usual-bindings options)
273      (for-each
274       (lambda (v)
275         (mark-variable v '##compiler#always-bound-to-procedure)
276         (mark-variable v '##compiler#always-bound) )
277       default-standard-bindings)
278      (for-each
279       (lambda (v)
280         (mark-variable v '##compiler#always-bound-to-procedure)
281         (mark-variable v '##compiler#always-bound) )
282       default-extended-bindings) )
283
284    ;; Handle feature options:
285    (for-each
286     register-feature!
287     (append-map (cut string-split <> ",") (collect-options 'feature)))
288
289    ;; Load extensions:
290    (set! ##sys#features (cons #:compiler-extension ##sys#features))
291    (let ([extends (collect-options 'extend)])
292      (dribble "Loading compiler extensions...")
293      (when verbose (load-verbose #t))
294      (for-each
295       (lambda (f) (load (##sys#resolve-include-filename f #f #t))) 
296       extends) )
297    (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
298
299    (set! ##sys#features (cons '#:compiling ##sys#features))
300    (set! upap (user-post-analysis-pass))
301
302    ;; Insert postponed initforms:
303    (set! initforms (append initforms postponed-initforms))
304
305    (let ((se (map string->symbol (collect-options 'static-extension))))
306      ;; Append required extensions to initforms:
307      (set! initforms
308        (append
309         initforms 
310         (map (lambda (r) `(##core#require-extension (,r) #t)) 
311              (append se (map string->symbol (collect-options 'require-extension))))))
312
313      ;; add static-extensions as used units:
314      (set! ##sys#explicit-library-modules
315        (append ##sys#explicit-library-modules se)))
316
317    (when (memq 'compile-syntax options)
318      (set! ##sys#enable-runtime-macros #t) )
319    (set! target-heap-size
320      (if hsize
321          (arg-val (option-arg hsize))
322          (and-let* ([hsize default-default-target-heap-size]
323                     [(not (zero? hsize))] )
324            hsize) ) )
325    (set! target-initial-heap-size (and hisize (arg-val (option-arg hisize))))
326    (set! target-heap-growth (and hgrowth (arg-val (option-arg hgrowth))))
327    (set! target-heap-shrinkage (and hshrink (arg-val (option-arg hshrink))))
328    (set! target-stack-size
329      (if ssize
330          (arg-val (option-arg ssize))
331          (and-let* ([ssize default-default-target-stack-size]
332                     [(not (zero? ssize))] )
333            ssize) ) )
334    (set! emit-trace-info (not (memq 'no-trace options)))
335    (set! disable-stack-overflow-checking (memq 'disable-stack-overflow-checks options))
336    (when (memq 'm debugging-chicken) (set-gc-report! #t))
337    (unless (memq 'no-usual-integrations options)
338      (set! standard-bindings default-standard-bindings)
339      (set! extended-bindings default-extended-bindings) )
340    (dribble "debugging info: ~A"
341             (if emit-trace-info
342                 "calltrace"
343                 "none") )
344    (when profile
345      (let ([acc (eq? 'accumulate-profile (car profile))])
346        (set! emit-profile #t)
347        (set! profiled-procedures 'all)
348        (set! initforms
349          (append
350           initforms
351           default-profiling-declarations
352           (if acc
353               '((set! ##sys#profile-append-mode #t))
354               '() ) ) )
355        (dribble "Generating ~aprofile" (if acc "accumulated " "")) ) )
356
357    ;;*** hardcoded "modules.db" is bad (also used in chicken-install.scm)
358    (load-identifier-database "modules.db")
359
360    (cond ((memq 'version options)
361           (print-version #t)
362           (newline) )
363          ((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
364           (print-usage))
365          ((memq 'release options)
366           (display (chicken-version)) 
367           (newline) )
368          ((not filename)
369           (print-version #t)
370           (display "\nEnter \"chicken -help\" for information on how to use it.\n") )
371          (else
372
373           ;; Display header:
374           (dribble "compiling `~a' ..." filename)
375           (set! source-filename filename)
376           (debugging 'r "options" options)
377           (debugging 'r "debugging options" debugging-chicken)
378           (debugging 'r "target heap size" target-heap-size)
379           (debugging 'r "target stack size" target-stack-size)
380           (set! start-time (cputime))
381
382           ;; Read toplevel expressions:
383           (set! ##sys#line-number-database (make-vector line-number-database-size '()))
384           (let ([prelude (collect-options 'prelude)]
385                 [postlude (collect-options 'postlude)] 
386                 [files (append
387                         (collect-options 'prologue)
388                         (list filename)
389                         (collect-options 'epilogue) ) ]  )
390
391             (let ([proc (user-read-pass)])
392               (cond [proc
393                      (dribble "User read pass...")
394                      (set! forms (proc prelude files postlude)) ]
395                     [else
396                      (do ([files files (cdr files)])
397                          ((null? files)
398                           (set! forms
399                             (append (map string->expr prelude)
400                                     (reverse forms)
401                                     (map string->expr postlude) ) ) )
402                        (let* ((f (car files))
403                               (in (check-and-open-input-file f)) )
404                          (fluid-let ((##sys#current-source-filename f))
405                            (let ((x1 (read-form in)) )
406                              (do ((x x1 (read-form in)))
407                                  ((eof-object? x) 
408                                   (close-checked-input-file in f) )
409                                (set! forms (cons x forms)) ) ) ) ) ) ] ) ) )
410
411           ;; Start compilation passes:
412           (let ([proc (user-preprocessor-pass)])
413             (when proc
414               (dribble "User preprocessing pass...")
415               (set! forms (map proc forms))))
416
417           (print-expr "source" '|1| forms)
418           (begin-time)
419           (unless (null? uses-units)
420             (set! ##sys#explicit-library-modules (append ##sys#explicit-library-modules uses-units))
421             (set! forms (cons `(declare (uses ,@uses-units)) forms)) )
422           (let* ([exps0 (map canonicalize-expression (append initforms forms))]
423                  [pvec (gensym)]
424                  [plen (length profile-lambda-list)]
425                  [exps (append
426                         (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
427                         (map (lambda (n) `(##core#callunit ,n)) used-units)
428                         (if emit-profile
429                             `((set! ,profile-info-vector-name 
430                                 (##sys#register-profile-info
431                                  ',plen
432                                  ',(if unit-name #f profile-name))))
433                             '() )
434                         (map (lambda (pl)
435                                `(##sys#set-profile-info-vector!
436                                  ,profile-info-vector-name
437                                  ',(car pl)
438                                  ',(cdr pl) ) )
439                              profile-lambda-list)
440                         exps0
441                         (if (and (not unit-name) (not dynamic))
442                             cleanup-forms
443                             '() )
444                         '((##core#undefined))) ] )
445
446             (when (and (pair? compiler-syntax-statistics)
447                        (debugging 'o "applied compiler syntax:"))
448               (for-each
449                (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
450                compiler-syntax-statistics))
451             (when (debugging '|N| "real name table:")
452               (display-real-name-table) )
453             (when (debugging 'n "line number database:")
454               (display-line-number-database) )
455
456             (when (and unit-name dynamic)
457               (compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )
458
459             (when (and unsafe (feature? 'compiling-extension))
460               (compiler-warning 
461                'style
462                "compiling extensions in unsafe mode is bad practice and should be avoided") )
463
464             (set! ##sys#line-number-database line-number-database-2)
465             (set! line-number-database-2 #f)
466
467             (end-time "canonicalization")
468             (print-expr "canonicalized" '|2| exps)
469
470             (when (memq 'check-syntax options) (exit))
471
472             (let ([proc (user-pass)])
473               (when proc
474                 (dribble "User pass...")
475                 (begin-time)
476                 (set! exps (map proc exps))
477                 (end-time "user pass") ) )
478
479             (let ((node0 (make-node
480                           'lambda '(())
481                           (list (build-node-graph
482                                  (canonicalize-begin-body exps) ) ) ) ) 
483                   (db #f))
484
485               (print-node "initial node tree" '|T| node0)
486               (initialize-analysis-database)
487
488               (when do-scrutinize
489                 ;;;*** hardcoded database file name
490                 (unless (memq 'ignore-repository options)
491                   (load-type-database "types.db"))
492                 (for-each (cut load-type-database <> #f) (collect-options 'types))
493                 (begin-time)
494                 (set! first-analysis #f)
495                 (set! db (analyze 'scrutiny node0))
496                 (print-db "analysis" '|0| db 0)
497                 (end-time "pre-analysis")
498                 (begin-time)
499                 (debugging 'p "performing scrutiny")
500                 (scrutinize node0 db)
501                 (end-time "scrutiny")
502                 (set! first-analysis #t) )
503
504               (when do-lambda-lifting
505                 (begin-time)
506                 (unless do-scrutinize  ; no need to do analysis if already done above
507                   (set! first-analysis #f)
508                   (set! db (analyze 'lift node0))
509                   (print-db "analysis" '|0| db 0)
510                   (end-time "pre-analysis (lambda-lift)"))
511                 (begin-time)
512                 (perform-lambda-lifting! node0 db)
513                 (end-time "lambda lifting")
514                 (print-node "lambda lifted" '|L| node0) 
515                 (set! first-analysis #t) )
516               
517               (let ((req (concatenate (vector->list file-requirements))))
518                 (when (debugging 'M "; requirements:")
519                   (pp req))
520                 (when enable-inline-files
521                   (for-each
522                    (lambda (id)
523                      (and-let* ((ifile (##sys#resolve-include-filename 
524                                         (make-pathname #f (symbol->string id) "inline")
525                                         #f #t))
526                                 ((file-exists? ifile)))
527                        (dribble "Loading inline file ~a ..." ifile)
528                        (load-inline-file ifile)))
529                    (concatenate (map cdr req))) )
530                 (let ((ifs (collect-options 'consult-inline-file)))
531                   (unless (null? ifs)
532                     (set! inline-globally #t)
533                     (set! inline-locally #t)
534                     (for-each
535                      (lambda (ilf)
536                        (dribble "Loading inline file ~a ..." ilf)
537                        (load-inline-file ilf) )
538                      ifs))))
539
540               (set! ##sys#line-number-database #f)
541               (set! constant-table #f)
542               (set! inline-table #f)
543               (unless unsafe
544                 (scan-toplevel-assignments (first (node-subexpressions node0))) )
545
546               (begin-time)
547               (let ([node1 (perform-cps-conversion node0)])
548                 (end-time "cps conversion")
549                 (print-node "cps" '|3| node1)
550
551                 ;; Optimization loop:
552                 (let loop ([i 1] [node2 node1] [progress #t])
553
554                   (begin-time)
555                   (let ([db (analyze 'opt node2 i progress)])
556                     (when first-analysis
557                       (when (memq 'u debugging-chicken)
558                         (dump-undefined-globals db))
559                       (when (memq 'd debugging-chicken)
560                         (dump-defined-globals db))
561                       (when (memq 'v debugging-chicken)
562                         (dump-global-refs db)) )
563                     (set! first-analysis #f)
564                     (end-time "analysis")
565                     (print-db "analysis" '|4| db i)
566
567                     (when (memq 's debugging-chicken) (print-program-statistics db))
568
569                     (cond [progress
570                            (debugging 'p "optimization pass" i)
571
572                            (begin-time)
573                            (receive (node2 progress-flag)
574                                (perform-high-level-optimizations node2 db)
575                              (end-time "optimization")
576                              (print-node "optimized-iteration" '|5| node2)
577
578                              (cond [progress-flag (loop (add1 i) node2 #t)]
579                                    [(not inline-substitutions-enabled)
580                                     (debugging 'p "rewritings enabled...")
581                                     (set! inline-substitutions-enabled #t)
582                                     (loop (add1 i) node2 #t) ]
583                                    [optimize-leaf-routines
584                                     (begin-time)
585                                     (let ([db (analyze 'leaf node2)])
586                                       (end-time "analysis")
587                                       (begin-time)
588                                       (let ([progress (transform-direct-lambdas! node2 db)])
589                                         (end-time "leaf routine optimization")
590                                         (loop (add1 i) node2 progress) ) ) ]
591                                    [else (loop (add1 i) node2 #f)] ) ) ]
592                           
593                           [else
594                            (print-node "optimized" '|7| node2)
595
596                            (when inline-output-file
597                              (let ((f inline-output-file))
598                                (dribble "Generating global inline file `~a' ..." f)
599                                (emit-global-inline-file f db) ) )
600
601                            (begin-time)
602                            (let ([node3 (perform-closure-conversion node2 db)])
603                              (end-time "closure conversion")
604                              (print-db "final-analysis" '|8| db i)
605                              (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
606                                (display "(don't worry - still compiling...)\n") )
607                              (when a-only (exit 0))
608                              (print-node "closure-converted" '|9| node3)
609
610                              (begin-time)
611                              (receive (node literals lliterals lambdas)
612                                  (prepare-for-code-generation node3 db)
613                                (end-time "preparation")
614
615                                (begin-time)
616                                (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
617                                  (dribble "generating `~A' ..." outfile)
618                                  (generate-code literals lliterals lambdas out filename dynamic db)
619                                  (when outfile (close-output-port out)))
620                                (end-time "code generation")
621                                (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
622                                (compiler-cleanup-hook)
623                                (dribble "compilation finished.") ) ) ] ) ) ) ) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.