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