~ chicken-core (chicken-5) /batch-driver.scm

  1;;;; batch-driver.scm - Driver procedure for the compiler
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  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 batch-driver)
 30  (uses extras data-structures pathname expand
 31	support compiler-syntax compiler optimizer internal
 32	;; TODO: Backend should be configurable
 33	scrutinizer lfa2 c-platform c-backend user-pass))
 34
 35(module chicken.compiler.batch-driver
 36    (compile-source-file)
 37
 38(import scheme
 39	chicken.base
 40        chicken.file
 41	chicken.fixnum
 42	chicken.format
 43	chicken.gc
 44	chicken.internal
 45	chicken.load
 46	chicken.pathname
 47	chicken.platform
 48	chicken.pretty-print
 49	chicken.process-context
 50        chicken.process-context.posix
 51	chicken.string
 52	chicken.syntax
 53        chicken.port
 54	chicken.time
 55        chicken.condition
 56	chicken.compiler.support
 57	chicken.compiler.compiler-syntax
 58	chicken.compiler.core
 59	chicken.compiler.optimizer
 60	chicken.compiler.scrutinizer
 61	chicken.compiler.lfa2
 62	chicken.compiler.c-platform
 63	chicken.compiler.c-backend
 64	chicken.compiler.user-pass)
 65
 66(include "tweaks")
 67(include "mini-srfi-1.scm")
 68
 69(define-constant funny-message-timeout 60000)
 70
 71;;; Emit collected information from various statistics about the program
 72
 73(define (print-program-statistics db)
 74  (receive
 75   (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
 76   (when (debugging 's "program statistics:")
 77     (printf ";   program size: \t~s \toriginal program size: \t~s\n" size osize)
 78     (printf ";   variables with known values: \t~s\n" kvars)
 79     (printf ";   known procedures: \t~s\n" kprocs)
 80     (printf ";   global variables: \t~s\n" globs)
 81     (printf ";   known call sites: \t~s\n" sites) 
 82     (printf ";   database entries: \t~s\n" entries) ) ) )
 83
 84;;; Initialize analysis database:
 85;;
 86;; - Simply marks the symbols directly in the plist.
 87;; - Does nothing after the first invocation, but we leave it this way to
 88;;    have the option to add default entries for each new db.
 89
 90(define initialize-analysis-database
 91  (let ((initial #t))
 92    (lambda ()
 93      (when initial
 94	(for-each
 95	 (lambda (s)
 96	   (mark-variable s '##compiler#intrinsic 'standard))
 97	 standard-bindings)
 98	(for-each
 99	 (lambda (s)
100	   (mark-variable s '##compiler#intrinsic 'extended))
101	 extended-bindings)
102	(for-each
103	 (lambda (s)
104	   (mark-variable s '##compiler#intrinsic 'internal))
105	 internal-bindings))
106      (set! initial #f))))
107
108;;; Display analysis database:
109
110(define display-analysis-database
111  (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo)
112		 (assigned-locally . stl)
113		 (contractable . con) (standard-binding . stb) (simple . sim)
114		 (inlinable . inl)
115		 (collapsable . col) (removable . rem) (constant . con)
116		 (inline-target . ilt) (inline-transient . itr)
117		 (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
118		 (inline-export . ilx) (hidden-refs . hrf)
119		 (value-ref . vvf)
120		 (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) ) 
121	(omit #f))
122    (lambda (db)
123      (unless omit
124	(set! omit 
125	  (append default-standard-bindings
126		  default-extended-bindings
127		  internal-bindings) ) )
128      (hash-table-for-each
129       (lambda (sym plist)
130	 (let ((val #f)
131	       (lval #f)
132	       (pvals #f)
133	       (csites '())
134	       (refs '())
135	       (derived-rvars '()))
136	   (unless (memq sym omit)
137	     (write sym)
138	     (let loop ((es plist))
139	       (if (pair? es)
140		   (begin
141		     (case (caar es)
142		       ((captured assigned boxed global contractable standard-binding assigned-locally
143				  collapsable removable undefined replacing unused simple inlinable inline-export
144				  has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
145			(printf "\t~a" (cdr (assq (caar es) names))) )
146		       ((unknown)
147			(set! val 'unknown) )
148		       ((value)
149			(unless (eq? val 'unknown) (set! val (cdar es))) )
150		       ((local-value)
151			(unless (eq? val 'unknown) (set! lval (cdar es))) )
152		       ((potential-values)
153			(set! pvals (cdar es)))
154		       ((replacable home contains contained-in use-expr closure-size rest-parameter
155				    captured-variables explicit-rest rest-cdr rest-null? consed-rest-arg)
156			(printf "\t~a=~s" (caar es) (cdar es)) )
157		       ((derived-rest-vars)
158			(set! derived-rvars (cdar es)))
159		       ((references)
160			(set! refs (cdar es)) )
161		       ((call-sites)
162			(set! csites (cdar es)) )
163		       (else (bomb "Illegal property" (car es))) )
164		     (loop (cdr es)) ) ) )
165	     (when (pair? refs) (printf "\trefs=~s" (length refs)))
166	     (when (pair? derived-rvars) (printf "\tdrvars=~s" (length derived-rvars)))
167	     (when (pair? csites) (printf "\tcss=~s" (length csites)))
168	     (cond [(and val (not (eq? val 'unknown)))
169		    (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
170		   [(and lval (not (eq? val 'unknown)))
171		    (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval)))])
172	     (when (pair? pvals)
173	       (for-each
174		(lambda (pval)
175		  (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval))))
176		pvals))
177	     (newline) ) ) )
178       db) ) ) )
179
180;;; Compile a complete source file:
181
182(define (compile-source-file filename user-supplied-options . options)
183  (define (option-arg p)
184    (if (null? (cdr p))
185	(quit-compiling "missing argument to `-~A' option" (car p))
186	(let ([arg (cadr p)])
187	  (if (symbol? arg)
188	      (quit-compiling "invalid argument to `~A' option" arg)
189	      arg) ) ) )
190  (initialize-compiler)
191  (set! explicit-use-flag (memq 'explicit-use options))
192  (set! emit-debug-info (memq 'debug-info options))
193  (when (memq 'module-registration options)
194    (set! compile-module-registration 'yes))
195  (when (memq 'no-module-registration options)
196    (set! compile-module-registration 'no))
197  (when (memq 'static options)
198    (set! static-extensions #t)
199    (register-feature! 'chicken-compile-static))
200  (let* ((dynamic (memq 'dynamic options))
201	(unit (memq 'unit options))
202	(init-forms `((##core#declare
203		      ,@(append 
204			 default-declarations
205			 (if emit-debug-info
206			     '((uses debugger-client))
207			     '())
208			 (if explicit-use-flag
209			     '()
210			     `((uses ,@default-units)))
211			 (if (and static-extensions
212				  (not dynamic)
213				  (not unit)
214				  (not explicit-use-flag)
215				  (or (not compile-module-registration)
216				      (eq? compile-module-registration 'yes)))
217			     '((uses eval-modules))
218			     '())))))
219	(import-forms `((import-for-syntax ,@default-syntax-imports)
220			,@(if explicit-use-flag
221			      '()
222			      `((import-syntax ,@default-imports)))))
223	(cleanup-forms '(((chicken.base#implicit-exit-handler))))
224	(outfile (cond ((memq 'output-file options)
225			=> (lambda (node)
226			     (let ((oname (option-arg node)))
227			       (if (symbol? oname)
228				   (symbol->string oname)
229				   oname) ) ) )
230		       ((memq 'to-stdout options) #f)
231		       (else (make-pathname #f (if filename (pathname-file filename) "out") "c")) ) )
232        ;; Create a temporary file to receive the C code, so that it
233        ;; can atomically be renamed to the actual output file after
234        ;; the C generation.
235        (tmp-outfile (and outfile
236                          (conc outfile ".tmp." (current-process-id) (current-seconds))))
237	(opasses (default-optimization-passes))
238	(time0 #f)
239	(time-breakdown #f)
240	(forms '())
241	(inline-output-file #f)
242	(profile (or (memq 'profile options)
243		     (memq 'accumulate-profile options)
244		     (memq 'profile-name options)))
245	(profile-name
246	 (and-let* ((pn (memq 'profile-name options))) (cadr pn)))
247	(hsize (memq 'heap-size options))
248	(kwstyle (memq 'keyword-style options))
249	(loop/dispatch (memq 'clustering options))
250	(a-only (memq 'analyze-only options))
251	(do-scrutinize #t)
252	(do-lfa2 (memq 'lfa2 options))
253	(dumpnodes #f)
254	(start-time #f)
255	(upap #f)
256	(ssize (or (memq 'nursery options) (memq 'stack-size options)))
257	(module-name
258	 (and-let* ((m (memq 'module options)))
259	   (option-arg m))))
260
261    (define (cputime) (current-process-milliseconds))
262
263    (define (dribble fstr . args)
264      (debugging 'p (apply sprintf fstr args)))
265
266    (define (print-header mode dbgmode)
267      (debugging 'p "pass" mode)
268      (and (memq dbgmode debugging-chicken)
269	   (begin
270	     (printf "[~a]~%" mode)
271	     #t) ) )
272
273    (define (print-node mode dbgmode n)
274      (when (print-header mode dbgmode)
275	(if dumpnodes
276	    (dump-nodes n)
277	    (pretty-print (build-expression-tree n)) ) ) )
278
279    (define (print-db mode dbgmode db pass)
280      (when (print-header mode dbgmode)
281	(printf "(iteration ~s)~%" pass)
282	(display-analysis-database db) ) )
283
284    (define (print-expr mode dbgmode xs)
285      (when (print-header mode dbgmode)
286	(for-each 
287	 (lambda (x) 
288	   (pretty-print x)
289	   (newline))
290	 xs) ) )
291
292    (define (string-trim str)
293      (let loop ((front 0)
294		 (back (string-length str)))
295	(cond ((= front back) "")
296	      ((char-whitespace? (string-ref str front))
297	       (loop (add1 front) back))
298	      ((char-whitespace? (string-ref str (sub1 back)))
299	       (loop front (sub1 back)))
300	      (else (substring str front back)))))
301       
302    (define (string->extension-name str)
303      (let ((str (string-trim str)))
304        (if (and (positive? (string-length str))
305                 (char=? #\( (string-ref str 0)))
306            (handle-exceptions ex 
307              (##sys#error "invalid import specification" str)
308              (with-input-from-string str read))
309            (string->symbol str))))
310
311    (define (arg-val str)
312      (let* ((len (string-length str))
313	     (len1 (- len 1)) )
314	(or (if (< len 2)
315		(string->number str)
316		(case (string-ref str len1)
317		  ((#\m #\M) (* (string->number (substring str 0 len1)) (* 1024 1024)))
318		  ((#\k #\K) (* (string->number (substring str 0 len1)) 1024))
319		  (else (string->number str)) ) )
320	    (quit-compiling "invalid numeric argument ~S" str) ) ) )
321
322    (define (collect-options opt)
323      (let loop ([opts options])
324	(cond [(memq opt opts) => (lambda (p) (cons (option-arg p) (loop (cddr p))))]
325	      [else '()] ) ) )
326
327    (define (begin-time)
328      (when time-breakdown (set! time0 (cputime))) )
329
330    (define (end-time pass)
331      (when time-breakdown
332	(printf "milliseconds needed for ~a: \t~s~%" 
333	  pass
334	  (inexact->exact (round (- (cputime) time0)) ) )))
335
336    (define (analyze pass node . args)
337      (let-optionals args ((no 0) (contf #t))
338        (let ((db (analyze-expression node)))
339	  (when upap
340	    (upap pass db node
341		  (cut db-get db <> <>)
342		  (cut db-put! db <> <> <>)
343		  no contf) )
344	  db) ) )
345
346    (define (chop-separator str)
347      (let ((len (sub1 (string-length str))))
348        (if (and (> len 0)
349                 (memq (string-ref str len) '(#\\ #\/)))
350            (substring str 0 len)
351            str) ) )
352
353    (when unit
354      (set! unit-name (string->symbol (option-arg unit))))
355    (when (or unit-name dynamic)
356      (set! standalone-executable #f))
357    (when (memq 'ignore-repository options)
358      (set! ##sys#dload-disabled #t)
359      (repository-path #f))
360    (set! enable-specialization (memq 'specialize options))
361    (set! debugging-chicken
362      (append-map
363       (lambda (do)
364	 (map (lambda (c) (string->symbol (string c)))
365	      (string->list do) ) )
366       (collect-options 'debug) ) )
367    (when (memq 'h debugging-chicken)
368      (print-debug-options)
369      (exit))
370    (set! dumpnodes (memq '|D| debugging-chicken))
371    (set! import-libraries
372      (map (lambda (il)
373	     (cons (string->symbol il) 
374		   (string-append il ".import.scm")))
375	   (collect-options 'emit-import-library)))
376    (when (and (memq 'emit-all-import-libraries options)
377	       (not a-only))
378      (set! all-import-libraries #t))
379    (when enable-specialization
380      (set! do-scrutinize #t))
381    (when (memq 't debugging-chicken) (##sys#start-timer))
382    (when (memq 'b debugging-chicken) (set! time-breakdown #t))
383    (when (memq 'raw options)
384      (set! explicit-use-flag #t)
385      (set! init-forms '())
386      (set! import-forms '())
387      (set! cleanup-forms '()))
388    (when (memq 'no-lambda-info options)
389      (set! emit-closure-info #f) )
390    (when (memq 'no-compiler-syntax options)
391      (set! compiler-syntax-enabled #f))
392    (when (memq 'local options)
393      (set! local-definitions #t))
394    (when (memq 'inline-global options)
395      (set! enable-inline-files #t)
396      (set! inline-locally #t))
397    (when (memq 'verbose options)
398      (set! verbose-mode #t)
399      (set! ##sys#notices-enabled #t))
400    (when (memq 'strict-types options)
401      (set! strict-variable-types #t)
402      (set! enable-specialization #t))
403    (when (memq 'no-warnings options) 
404      (dribble "Warnings are disabled")
405      (set! ##sys#warnings-enabled #f) 
406      (set! do-scrutinize #f))		; saves some processing time
407    (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
408    (when (memq 'unsafe options) 
409      (set! unsafe #t) )
410    (when (memq 'setup-mode options)
411      (set! ##sys#setup-mode #t))
412    (when (memq 'regenerate-import-libraries options)
413      (set! preserve-unchanged-import-libraries #f))
414    (when (memq 'disable-interrupts options) (set! insert-timer-checks #f))
415    (when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
416    (when (memq 'block options) (set! block-compilation #t))
417    (when (memq 'emit-external-prototypes-first options)
418      (set! external-protos-first #t))
419    (when (memq 'inline options) (set! inline-locally #t))
420    (and-let* ((elf (memq 'emit-link-file options)))
421      (set! emit-link-file (option-arg elf)))
422    (and-let* ((ifile (memq 'emit-inline-file options)))
423      (set! inline-locally #t)		; otherwise this option makes no sense
424      (set! local-definitions #t)
425      (set! inline-output-file (option-arg ifile)))
426    (and-let* ((tfile (memq 'emit-types-file options)))
427      (set! types-output-file (option-arg tfile)))
428    (and-let* ([inlimit (memq 'inline-limit options)])
429      (set! inline-max-size 
430	(let ([arg (option-arg inlimit)])
431	  (or (string->number arg)
432	      (quit-compiling
433	       "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
434    (and-let* ((ulimit (memq 'unroll-limit options)))
435      (set! unroll-limit
436	(let ((arg (option-arg ulimit)))
437	  (or (string->number arg)
438	      (quit-compiling
439	       "invalid argument to `-unroll-limit' option: `~A'" arg) ) ) ) )
440    (when (memq 'case-insensitive options) 
441      (dribble "Identifiers and symbols are case insensitive")
442      (register-feature! 'case-insensitive)
443      (case-sensitive #f) )
444    (when kwstyle
445      (let ([val (option-arg kwstyle)])
446	(cond [(string=? "prefix" val) (keyword-style #:prefix)]
447	      [(string=? "none" val) (keyword-style #:none)]
448	      [(string=? "suffix" val) (keyword-style #:suffix)]
449	      [else (quit-compiling
450		     "invalid argument to `-keyword-style' option")] ) ) )
451    (when (memq 'no-parentheses-synonyms options)
452      (dribble "Disabled support for parentheses synonyms")
453      (parentheses-synonyms #f) )
454    (when (memq 'no-symbol-escape options) 
455      (dribble "Disabled support for escaped symbols")
456      (symbol-escape #f) )
457    (when (memq 'r5rs-syntax options)
458      (dribble "Disabled the CHICKEN extensions to R5RS syntax")
459      (case-sensitive #f)
460      (keyword-style #:none)
461      (parentheses-synonyms #f)
462      (symbol-escape #f) )
463    (set! ##sys#read-error-with-line-number #t)
464    (set! ##sys#include-pathnames
465      (append (map chop-separator (collect-options 'include-path))
466	      ##sys#include-pathnames) )
467    (when (and outfile filename (string=? outfile filename))
468      (quit-compiling "source- and output-filename are the same") )
469    (when (memq 'keep-shadowed-macros options)
470      (set! undefine-shadowed-macros #f) )
471    (when (memq 'no-argc-checks options)
472      (set! no-argc-checks #t) )
473    (when (memq 'no-bound-checks options)
474      (set! no-bound-checks #t) )
475    (when (memq 'no-procedure-checks options)
476      (set! no-procedure-checks #t) )
477    (when (memq 'no-procedure-checks-for-toplevel-bindings options)
478      (set! no-global-procedure-checks #t) )
479    (when (memq 'no-procedure-checks-for-usual-bindings options)
480      (for-each 
481       (lambda (v)
482         (mark-variable v '##compiler#always-bound-to-procedure)
483         (mark-variable v '##compiler#always-bound) )
484       default-standard-bindings)
485      (for-each 
486       (lambda (v)
487         (mark-variable v '##compiler#always-bound-to-procedure)
488         (mark-variable v '##compiler#always-bound) )
489       default-extended-bindings) )
490    (when (memq 'p debugging-chicken) (load-verbose #t))
491
492    ;; Handle feature options:
493    (for-each 
494     register-feature!
495     (append-map (cut string-split <> ", ") (collect-options 'feature)))
496    (for-each 
497     unregister-feature!
498     (append-map (cut string-split <> ",") (collect-options 'no-feature)))
499
500    ;; Load extensions:
501    (set! ##sys#features (cons #:compiler-extension ##sys#features))
502    (let ([extends (collect-options 'extend)])
503      (dribble "Loading compiler extensions...")
504      (for-each
505       (lambda (e)
506	 (let ((f (##sys#resolve-include-filename e #f #t #f)))
507	   (when (not f) (quit-compiling "cannot load extension: ~a" e))
508	   (load f)))
509       extends) )
510    (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
511    (set! ##sys#features (cons '#:compiling ##sys#features))
512    (set! upap (user-post-analysis-pass))
513
514    ;; Handle units added with the "-uses" flag.
515    (let ((uses (append-map
516		 (lambda (u) (map string->symbol (string-split u ", ")))
517		 (collect-options 'uses))))
518      (unless (null? uses)
519	(set! init-forms
520	  (append init-forms `((##core#declare (uses . ,uses)))))))
521
522    ;; Mark linked libraries so they will be compiled as unit dependencies.
523    (let ((link (append-map
524		 (lambda (l) (map string->symbol (string-split l ", ")))
525		 (collect-options 'link))))
526      (set! linked-libraries (lset-union/eq? linked-libraries link)))
527
528    ;; Append required extensions to imports:
529    (set! import-forms
530      (append
531       import-forms
532       (map (lambda (r) `(import ,(string->extension-name r)))
533	    (collect-options 'require-extension))))
534
535    (when (memq 'compile-syntax options)
536      (set! ##sys#enable-runtime-macros #t) )
537    (set! target-heap-size
538      (and hsize
539	   (arg-val (option-arg hsize))))
540    (set! target-stack-size
541      (and ssize
542	   (arg-val (option-arg ssize))))
543    (set! emit-trace-info (not (memq 'no-trace options)))
544    (set! disable-stack-overflow-checking (memq 'disable-stack-overflow-checks options))
545    (set! bootstrap-mode (feature? #:chicken-bootstrap))
546    (when (memq 'm debugging-chicken) (set-gc-report! #t))
547    (cond ((memq 'no-usual-integrations options)
548	   (set! do-scrutinize #f))
549	  (else
550	   (set! standard-bindings default-standard-bindings)
551	   (set! extended-bindings default-extended-bindings) ))
552    (dribble "debugging info: ~A"
553	     (if emit-trace-info
554		 "calltrace"
555		 "none") )
556    (when profile
557      (let ((acc (eq? 'accumulate-profile (car profile))))
558	(when (and acc (not profile-name))
559	  (quit-compiling
560	   "you need to specify -profile-name if using accumulated profiling runs"))
561	(set! emit-profile #t)
562	(set! profiled-procedures 'all)
563	(set! init-forms
564	  (append
565	   init-forms
566	   default-profiling-declarations
567	   (if acc
568	       '((set! ##sys#profile-append-mode #t))
569	       '() ) ) )
570	(dribble "generating ~aprofiled code" (if acc "accumulative " "")) ))
571
572    ;;XXX hardcoded "modules.db" is bad (also used in chicken-install.scm)
573    (load-identifier-database "modules.db")
574
575    (cond ((memq 'version options)
576	   (print-version #t)
577	   (newline) )
578	  ((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
579	   (print-usage))
580	  ((memq 'release options)
581	   (display (chicken-version)) 
582	   (newline) )
583	  ((not filename)
584	   (print-version #t)
585	   (display "\nEnter `chicken -help' for information on how to use the compiler,\n")
586	   (display "or try `csc' for a more convenient interface.\n")
587	   (display "\nRun `csi' to start the interactive interpreter.\n"))
588	  (else
589
590	   ;; Display header:
591	   (dribble "compiling `~a' ..." filename)
592	   (debugging 'r "options" options)
593	   (debugging 'r "debugging options" debugging-chicken)
594	   (debugging 'r "target heap size" target-heap-size)
595	   (debugging 'r "target stack size" target-stack-size)
596	   (set! start-time (cputime))
597
598	   ;; Read toplevel expressions:
599	   (set! ##sys#line-number-database (make-vector line-number-database-size '()))
600	   (let ([prelude (collect-options 'prelude)]
601		 [postlude (collect-options 'postlude)] 
602		 [files (append 
603			 (collect-options 'prologue)
604			 (list filename)
605			 (collect-options 'epilogue) ) ]  )
606
607	     (let ([proc (user-read-pass)])
608	       (cond [proc
609		      (dribble "User read pass...")
610		      (set! forms (proc prelude files postlude)) ]
611		     [else
612		      (do ([files files (cdr files)])
613			  ((null? files)
614			   (set! forms
615			     (append (map string->expr prelude)
616				     (reverse forms)
617				     (map string->expr postlude) ) ) )
618			(let* ((f (car files))
619			       (in (check-and-open-input-file f)) )
620			  (fluid-let ((##sys#current-source-filename f))
621			    (let loop ()
622			      (let ((x (chicken.syntax#read-with-source-info in))) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
623
624				(cond ((eof-object? x) 
625				       (close-checked-input-file in f) )
626				      (else
627				       (set! forms (cons x forms))
628				       (loop)))))))) ] ) ) )
629
630	   ;; Start compilation passes:
631	   (let ([proc (user-preprocessor-pass)])
632	     (when proc
633	       (dribble "User preprocessing pass...")
634	       (set! forms (map proc forms))))
635
636	   (print-expr "source" '|1| forms)
637	   (begin-time)
638	   ;; Canonicalize s-expressions
639	   (let* ((init0 (map canonicalize-expression init-forms))
640		  (exps0 (map (lambda (x)
641				(fluid-let ((##sys#current-source-filename filename))
642				  (canonicalize-expression x)))
643			      (let ((forms (append import-forms forms)))
644				(if (not module-name)
645				    forms
646				    `((##core#module
647				       ,(string->symbol module-name) ()
648				       ,@forms))))))
649		  (uses0 (map (lambda (u)
650				(canonicalize-expression `(##core#require ,u)))
651			      (##sys#fast-reverse used-libraries)))
652		  (exps (append
653			 (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
654			 init0
655			 uses0
656			 (if unit-name `((##core#provide ,unit-name)) '())
657			 (if emit-profile
658			     (profiling-prelude-exps (and (not unit-name)
659							  (or profile-name #t)))
660			     '() )
661			 exps0
662			 (if standalone-executable
663			     cleanup-forms
664			     '((##core#undefined))))))
665
666	     (unless (null? import-libraries)
667	       (quit-compiling
668		"No module definition found for import libraries to emit: ~A"
669		;; ~S would be confusing: separate with a comma
670		(string-intersperse
671		 (map (lambda (il) (->string (car il)))
672		      import-libraries) ", ")))
673
674	     (when (pair? compiler-syntax-statistics)
675	       (with-debugging-output
676		'S
677		(lambda ()
678		  (print "applied compiler syntax:")
679		  (for-each 
680		   (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
681		   compiler-syntax-statistics))))
682   	     (when (debugging '|N| "real name table:")
683	       (display-real-name-table) )
684	     (when (debugging 'n "line number database:")
685	       (##sys#display-line-number-database) )
686
687	     (set! ##sys#line-number-database line-number-database-2)
688	     (set! line-number-database-2 #f)
689
690	     (end-time "canonicalization")
691	     (print-expr "canonicalized" '|2| exps)
692
693	     (when (memq 'check-syntax options) (exit))
694
695	     ;; User-defined pass (s-expressions)
696	     (let ([proc (user-pass)])
697	       (when proc
698		 (dribble "User pass...")
699		 (begin-time)
700		 (set! exps (map proc exps))
701		 (end-time "user pass") ) )
702
703	     ;; Convert s-expressions to node tree
704	     (let ((node0 (build-toplevel-procedure
705			   (build-node-graph
706			    (canonicalize-begin-body exps))))
707		   (db #f))
708	       (print-node "initial node tree" '|T| node0)
709	       (initialize-analysis-database)
710
711	       ;; collect requirements and load inline files
712	       (let ((extensions required-extensions))
713		 (when enable-inline-files
714		   (for-each
715		    (lambda (id)
716		      (and-let* ((ifile (##sys#resolve-include-filename
717					 (symbol->string id) '(".inline") #t #f)))
718			(dribble "Loading inline file ~a ..." ifile)
719			(load-inline-file ifile)))
720		    extensions))
721		 (let ((ifs (collect-options 'consult-inline-file)))
722		   (unless (null? ifs)
723		     (set! inline-locally #t)
724		     (for-each 
725		      (lambda (ilf)
726			(dribble "Loading inline file ~a ..." ilf)
727			(load-inline-file ilf) )
728		      ifs)))
729		 ;; Perform scrutiny and optionally specialization
730		 (when (or do-scrutinize enable-specialization)
731		   ;;XXX hardcoded database file name
732		   (unless (memq 'ignore-repository options)
733		     (unless (load-type-database "types.db"
734						 enable-specialization)
735		       (quit-compiling
736			"default type-database `types.db' not found")))
737		   (for-each 
738		    (lambda (fn)
739		      (or (load-type-database fn enable-specialization #f)
740			  (quit-compiling "type-database `~a' not found" fn)))
741		    (collect-options 'consult-types-file))
742		   (for-each
743		    (lambda (id)
744		      (load-type-database
745		       (make-pathname #f (symbol->string id) "types")
746		       enable-specialization))
747		    extensions)
748		   (begin-time)
749		   (set! first-analysis #f)
750		   (set! db (analyze 'scrutiny node0))
751		   (print-db "analysis" '|0| db 0)
752		   (end-time "pre-analysis (scrutiny)")
753		   (begin-time)
754		   (debugging 'p "performing scrutiny")
755		   (scrutinize node0 db
756			       do-scrutinize enable-specialization
757			       strict-variable-types block-compilation)
758		   (end-time "scrutiny")
759		   (when enable-specialization
760		     (print-node "specialization" '|P| node0))
761		   (set! first-analysis #t) ) )
762
763	       ;; TODO: Move this so that we don't need to export these
764	       (set! ##sys#line-number-database #f)
765	       (set! constant-table #f)
766	       (set! inline-table #f)
767	       ;; Analyze toplevel assignments
768	       (unless unsafe
769		 (scan-toplevel-assignments (first (node-subexpressions node0))) )
770
771	       (begin-time)
772	       ;; Convert to CPS
773	       (let ([node1 (perform-cps-conversion node0)])
774		 (end-time "cps conversion")
775		 (print-node "cps" '|3| node1)
776
777		 ;; Optimization loop:
778		 (let loop ((i 1)
779			    (node2 node1)
780			    (progress #t)
781			    (l/d #f)
782			    (l/d-done #f))
783		   (begin-time)
784		   ;; Analyze node tree for optimization
785		   (let ([db (analyze 'opt node2 i progress)])
786		     (when first-analysis
787		       (when (memq 'u debugging-chicken)
788			 (dump-undefined-globals db))
789		       (when (memq 'd debugging-chicken)
790			 (dump-defined-globals db))
791		       (when (memq 'v debugging-chicken)
792			 (dump-global-refs db))
793		       ;; do this here, because we must make sure we have a db
794		       (and-let* ((tfile (or (and (eq? types-output-file #t)
795						  (pathname-replace-extension filename "types"))
796					     (and (string? types-output-file)
797						  types-output-file))))
798			 (dribble "generating type file `~a' ..." tfile)
799			 (emit-types-file filename tfile db block-compilation)))
800		     (set! first-analysis #f)
801		     (end-time "analysis")
802		     (print-db "analysis" '|4| db i)
803
804		     (when (memq 's debugging-chicken) 
805		       (print-program-statistics db))
806
807		     ;; Optimize (once)
808		     (cond (progress
809			    (debugging 'p "optimization pass" i)
810			    (begin-time)
811			    (receive (node2 progress-flag)
812				(if l/d
813				    (determine-loop-and-dispatch node2 db)
814				    (perform-high-level-optimizations
815				     node2 db block-compilation
816				     inline-locally inline-max-size
817                                     unroll-limit
818				     inline-substitutions-enabled))
819			      (end-time "optimization")
820			      (print-node "optimized-iteration" '|5| node2)
821			      (cond (progress-flag
822				     (loop (add1 i) node2 #t #f l/d))
823				    ((and (not l/d-done) loop/dispatch)
824				     (debugging 'p "clustering enabled")
825				     (loop (add1 i) node2 #t #t #t))
826				    ((not inline-substitutions-enabled)
827				     (debugging 'p "rewritings enabled")
828				     (set! inline-substitutions-enabled #t)
829				     (loop (add1 i) node2 #t #f l/d-done) )
830				    (optimize-leaf-routines
831				     (begin-time)
832				     (let ([db (analyze 'leaf node2)])
833				       (end-time "analysis")
834				       (begin-time)
835				       (let ((progress
836					      (transform-direct-lambdas! node2 db)))
837					 (end-time "leaf routine optimization")
838					 (loop (add1 i) 
839					       node2
840					       progress
841					       #f
842					       l/d-done) ) ) )
843				    (else
844				     (loop (add1 i) node2 #f #f l/d-done)) ) ) )
845			   
846			   (else
847			    ;; Secondary flow-analysis
848			    (when do-lfa2
849			      (begin-time)
850			      (debugging 'p "doing lfa2")
851                              (let ((floatvars (perform-secondary-flow-analysis node2 db)))
852  			        (end-time "secondary flow analysis")
853                                (unless (null? floatvars)
854                                  (begin-time)
855                                  (debugging 'p "doing unboxing")
856                                  (set! node2 (perform-unboxing node2 floatvars)))
857    			          (end-time "unboxing")))
858			    (print-node "optimized" '|7| node2)
859			    ;; inlining into a file with interrupts enabled would
860			    ;; change semantics
861			    (when (and inline-output-file insert-timer-checks)
862			      (let ((f inline-output-file))
863				(dribble "generating global inline file `~a' ..." f)
864				(emit-global-inline-file
865				 filename f db block-compilation
866				 inline-max-size
867				 (map foreign-stub-id foreign-lambda-stubs)) ) )
868			    (begin-time)
869			    ;; Closure conversion
870			    (set! node2 (perform-closure-conversion node2 db))
871			    (end-time "closure conversion")
872			    (print-db "final-analysis" '|8| db i)
873			    (when (and ##sys#warnings-enabled
874				       (> (- (cputime) start-time) funny-message-timeout))
875			      (display "(don't worry - still compiling...)\n") )
876			    (print-node "closure-converted" '|9| node2)
877			    (when a-only (exit 0))
878			    (begin-time)
879			    ;; Preparation
880			    (receive (node literals lliterals lambda-table dbg-info)
881				(prepare-for-code-generation node2 db)
882			      (end-time "preparation")
883			      (begin-time)
884
885                              ;; generate link file
886			      (when emit-link-file
887				(let ((exts required-extensions))
888				  (dribble "generating link file `~a' ..." emit-link-file)
889				  (with-output-to-file emit-link-file (cut pp exts))))
890
891                               ;; Code generation
892			      (let ((out (if tmp-outfile
893                                             (open-output-file tmp-outfile)
894                                             (current-output-port))) )
895                                (when tmp-outfile
896                                  (dribble "generating `~A' ..." tmp-outfile))
897				(generate-code literals lliterals lambda-table out filename
898					       user-supplied-options dynamic db dbg-info)
899				(when tmp-outfile
900                                  (close-output-port out)
901                                  (rename-file tmp-outfile outfile #t)))
902			      (end-time "code generation")
903			      (when (memq 't debugging-chicken)
904				(##sys#display-times (##sys#stop-timer)))
905			      (compiler-cleanup-hook)
906			      (dribble "compilation finished.") ) ) ) ) ) ) ) ) ) ) ) )
907)