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

Last change on this file since 5616 was 5616, checked in by felix winkelmann, 12 years ago

added warning when extension is compiled in unsafe mode

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