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

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

-debug e; added set-file-position! again

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