;; Compiler driver routines 
;; (c) 1996-7 Sebastian Good
;; (c) 1997-8 PLT, Rice University
;; Scheme->C compilation Overview
;; ------------------------------
;;
;; Compilation is performed in a number of phases,
;;  each of which is implemented in its own unit:
;;
;;   1) Reading/parsing - Zodiac collection
;;   2) SBA analysis (optional) - MrSpidey collection
;;   3) Prephase - prephase.ss
;;   4) A-normalization - anorm.ss
;;   5) Known-value analysis - known.ss
;;   6) Lexical analysis and inlining - analyze.ss
;;   7) Static procedure lifting - lift.ss
;;   8) Lightweight closure conversion - lightweight.ss (optional)
;;   9) Static procedure lifting after LWCC - lift.ss (optional)
;;  10) Closure conversion - closure.ss
;;  11) Closure vehicle assignment - vehicle.ss
;;  12) Representation choosing - rep.ss
;;  13) Scheme to virtual machine translation - vmphase.ss
;;  14) Optimizations on VM code - vmopt.ss
;;  15) VM to C translation - vm2c.ss
;;
;; For more information about a phase, see the file
;;  implementing that phase.
;;
;; All steps up to vmphase.ss work on a Scheme program, representated
;;  as a zodiac AST. The AST produced by zodiac is destructively
;;  modified by each phase (usually); mzc-specific information is
;;  stored in the AST as ``annotations''. At the implementation file
;;  for each phase, the annotations installed or changed by the phase
;;  are listed.
;;
;; All nodes in the AST must be unique, except for nodes representing
;;  constant values. Don't even reuse varref or binding nodes within
;;  an AST.
;;
;; C code is compiled and linked via procedures provided by the
;;  dynext collection.
;;
;; In this implementation, `var' is used for variable names in
;;  confusing and inconsistent ways. There are two different
;;  AST entities that could be called "var":
;;     1) binding instances of variables, e.g., the formal
;;        arguments of a lambda; these are always called
;;        `bindings' in Zodiac terminology
;;     2) bound instances of variables, e.g., a free variable 
;;        in a sub-expression; these are always called
;;        `varrefs' in Zodiac terminology.
;;  Almost all information about a variable is stored with a
;;   zodiac:binding AST node, and very little information is
;;   stored with a zodiac:varref AST node.
;;  To make matters worse, the name `binding' is overloaded.
;;    `zodiac:binding' is the name of a Zodiac structure
;;    type, and `binding' is also the name of the structure
;;    type for annotations attached to zodiac:binding objects.
;;  If you create a new lexical binding, note that the procedure
;;    zodiac:binding->lexical-varref will create varrefs to 
;;    the binding.

(unit/sig compiler:driver^
  (import (compiler:option : compiler:option^)
	  compiler:library^
	  compiler:cstructs^
	  (zodiac : zodiac:system^)
	  compiler:zlayer^
	  compiler:prephase^
	  compiler:anorm^
	  compiler:known^
	  compiler:analyze^
	  compiler:const^
	  compiler:lift^
	  compiler:lightweight^
	  compiler:closure^
	  compiler:vehicle^
	  compiler:rep^
	  compiler:vmstructs^
	  compiler:vmphase^
	  compiler:vmopt^
	  compiler:vm2c^
	  compiler:top-level^
	  dynext:compile^
	  dynext:link^
	  dynext:file^
	  mzlib:function^
	  mzlib:pretty-print^
	  (mrspidey : compiler:mrspidey^))
  (rename (compile-extension* compile-extension))

  (define debug:file "dump.txt")
  (define debug:port #f)
  (define debug
    (lambda x
      (when (and (compiler:option:debug) debug:port)
	(apply fprintf (cons debug:port x))
	(flush-output debug:port))))
  
;;----------------------------------------------------------------------------
;; FILE PROCESSING FUNCTIONS
;;

; takes an input-name from the compile command and returns 4 values
; 1) an input path
; 2) a C output path
; 3) a constant pool output path
; 4) an obj output path
; 5) a dll output path
; 6) a scheme_setup suffix
(define s:process-filenames
  (lambda (input-name dest-dir from-c? tmp-c? tmp-o?)
    (let-values ([(basedir file dir?) (split-path input-name)])
		(let* ([sbase (extract-base-filename/ss file (if from-c? #f 'mzc))]
		       [cbase (extract-base-filename/c file (if from-c? 'mzc #f))]
		       [base (or sbase cbase)]
		       [c-dir (if tmp-c?
				  (find-system-path 'temp-dir)
				  dest-dir)]
		       [c-prefix (if tmp-c?
				     (lambda (s) (string-append "mzcTMP" s))
				     values)]
		       [o-dir (if tmp-o?
				  (find-system-path 'temp-dir)
				  dest-dir)]
		       [o-prefix (if tmp-o?
				     (lambda (s) (string-append "mzcTMP" s))
				     values)])
		  (unless base
			  (error 'mzc "not a Scheme or C file: ~a" input-name))
		  (values (if sbase 
			      input-name
			      #f)
			  (if cbase 
			      input-name 
			      (build-path c-dir (c-prefix (append-c-suffix base))))
			  (build-path o-dir (o-prefix (append-constant-pool-suffix base)))
			  (build-path o-dir (o-prefix (append-object-suffix base)))
			  (build-path dest-dir (append-extension-suffix base))
			  (string-append (compiler:clean-string (compiler:option:setup-prefix)) "_" (compiler:clean-string base)))))))

(define elaboration-exn-handler
  (lambda (exn)
    (compiler:fatal-error 
     #f
     (format "Error at elaboration time: ~a" 
	     (if (exn? exn)
		 (exn-message exn)
		 exn)))
    (raise exn)))

(define top-level-exn-handler
  (lambda (exn)
    (set! compiler:messages (reverse! compiler:messages))
    (compiler:report-messages! #t)
    (exit 1)))
  
  (define load-prefix-file
    (lambda (prefix)
      (printf " Prefix: loading \"~a\"~n" prefix)
      (let-values ([(base file dir?) (split-path prefix)]
		   ; [(start) (current-process-milliseconds)]
		   [(p) (open-input-file prefix 'text)])
	(let* ([results
		(s:expand-top-level-expressions! 
		 (path->complete-path
		  (if (eq? 'relative base)
		      (build-path 'same)
		      base))
		 (zodiac:read p (zodiac:make-location 1 1 0 prefix))
		 #f
		 #f
		 (lambda (expr)
		   (if (void? expr)
		       expr
		       (let ([r (zodiac:parsed->raw expr)])
			 (call-with-values
			  (lambda () 
			    (eval r))
			  list)))))])
	  (close-input-port p)
	  ; (printf "~a~n" (- (current-process-milliseconds) start))
	  (apply values (car (last-pair results)))))))
  
  (define s:expand-top-level-expressions!
    (lambda (input-directory reader vocab verbose? r-eval)
      (when verbose? (printf "~n Zodiac: reading... ") (flush-output))
      ; During reads, syntax errors are truly fatal
      (let ([exprs (begin ; time
		     (let loop ([n 1])
		       (let ([sexp (let loop () 
				     ; This loop handles the case where
				     ; the reader is really unhappy after
				     ; it encounters an error
				     (with-handlers ([void (lambda (x) (loop))])
						    (reader)))])
			 (if (zodiac:eof? sexp)
			     null
			     (begin 
			       (when (compiler:option:debug)
				     (debug "~a[~a.~a]_"
					    n
					    (zodiac:location-line
					     (zodiac:zodiac-start sexp))
					    (zodiac:location-column
					     (zodiac:zodiac-start sexp))))
			       (cons sexp (loop (+ n 1))))))))])
	(unless (null? compiler:messages) (when (compiler:option:verbose) (newline)))
	(compiler:report-messages! #t)
	(when verbose? (printf " expanding...~n"))
	(parameterize ([current-load-relative-directory input-directory]
		       [current-load load-prefix-file]
		       [zodiac:elaboration-evaluator
			(lambda (expr p->r phase)
			  (if (void? expr)
			      (void)
			      (eval (p->r expr))))]
		       [zodiac:user-macro-body-evaluator
			(lambda (f . args) (apply f args))])
	  (map (lambda (expr) (r-eval (zodiac:scheme-expand expr 'previous vocab)))
	       exprs)))))

  (define elaborate-namespace (make-namespace))

  (define (eval-compile-prefix prefix)
    (with-handlers ([void top-level-exn-handler])
      (with-handlers ([void elaboration-exn-handler])
	(parameterize ([current-namespace elaborate-namespace]
		       [use-compiled-file-kinds 'none]
		       [compiler:escape-on-error #t]
		       [current-load load-prefix-file])
	  (eval prefix))
	(compiler:report-messages! #t))))

  ;;----------------------------------------------------------------------
  ;; Misc utils

  ; takes a list of a-normalized expressions and analyzes them
  ; returns the analyzed code, a list of local variable lists, 
  ; used variable lists, and captured variable lists
  (define s:analyze-source-list
    (lambda (source)
      (let loop ([sexps source] [source-acc null] 
				[locals-acc null] [globals-acc null] [used-acc null] [captured-acc null]
				[children-acc null]
				[max-arity 0])
	(if (null? sexps)
	    (values (reverse! source-acc)
		    (map (lambda (loc glob used cap children)
			   (let ([c (make-code empty-set
					       loc
					       glob
					       used
					       cap
					       #f
					       #f
					       children)])
			     (for-each (lambda (child) (set-code-parent! child c)) children)
			     c))
			 (reverse! locals-acc)
			 (reverse! globals-acc)
			 (reverse! used-acc)
			 (reverse! captured-acc)
			 (reverse! children-acc))
		    max-arity)
	    (let-values ([(exp free-vars local-vars global-vars used-vars captured-vars children new-max-arity multi)
			  (analyze-expression! (car sexps) empty-set null (null? (cdr sexps)))])
	      (loop (cdr sexps) 
		    (cons exp source-acc) 
		    (cons local-vars locals-acc)
		    (cons global-vars globals-acc)
		    (cons used-vars used-acc)
		    (cons captured-vars captured-acc)
		    (cons children children-acc)
		    (max max-arity new-max-arity)))))))

  ;; Lift static procedures
  (define s:lift
    (lambda ()
      (compiler:init-lifted-lambda-list!)
      (compiler:init-once-closure-lists!)

      (let ([l (map lift-lambdas! (block-source s:file-block) (block-codes s:file-block))]
	    [reset-globals (lambda (code globals)
			     (set-code-global-vars! code globals)
			     code)])
	
	;; Splice lifted lambda definitions between statics and per-load statics;
	;; Add par-load-lifted after static lifted
	(let loop ([n number-of-true-constants]
		   [l l][c (block-codes s:file-block)]
		   [l-acc null][c-acc null])
	  (if (zero? n)
	      (begin
		(set-block-source! 
		 s:file-block
		 (append (reverse l-acc) compiler:lifted-lambdas compiler:once-closures-list (map car l)))
		(set-block-codes!
		 s:file-block 
		 (append (reverse c-acc) 
			 (map
			  (lambda (ll)
			    (make-code empty-set
				       empty-set
				       empty-set ; no globals
				       empty-set
				       empty-set
				       #f #f
				       (list 
					(get-annotation 
					 (zodiac:define-values-form-val ll)))))
			  compiler:lifted-lambdas)
			 (map (lambda (ll globs) 
				(make-code empty-set
					   empty-set
					   globs
					   empty-set
					   empty-set
					   #f #f
					   (list
					    (get-annotation 
					     (zodiac:define-values-form-val ll)))))
			      compiler:once-closures-list
			      compiler:once-closures-globals-list)
			 (map reset-globals c (map cdr l)))))
	      (loop (sub1 n) (cdr l) (cdr c) 
		    (cons (caar l) l-acc) (cons (reset-globals (car c) (cdar l)) c-acc)))))
      
      ;; Lifted lambdas are true constants:
      (set! number-of-true-constants (+ number-of-true-constants
					(length compiler:lifted-lambdas)))))

  (define s:append-block-sources!
    (lambda (file-block l)
      (set-block-codes!
       file-block
       (append!
	(map
	 (lambda (glob)
	   (make-code empty-set
		      empty-set
		      empty-set
		      empty-set
		      empty-set
		      #f #f null))
	 l)
	(block-codes file-block)))
      (set-block-source! 
       file-block
       (append! l (block-source file-block)))))

  ;;-------------------------------------------------------------------------------
  ;; MrSpidey Per-unit analysis
  (define (wrap-unit-for-mrspidey expr)
    ;; Wrap the unit in an expression that drives to unknown all of the imports
    ;;  and arguments to exported functions.
    (let* ([imports (zodiac:unit-form-imports expr)]
	   [exports (map zodiac:read-object (map cdr (zodiac:unit-form-exports expr)))]
	   [dummies (map (lambda (x) (gensym)) imports)]	   
	   [my-expr `(let ([u u] 
			   ,@(map (lambda (d) `(,d (#%read))) dummies))
		       (invoke-unit
			(compound-unit 
			 (import ,@dummies)
			 (link [U (u ,@dummies)]
			       [O ((unit (import ,@exports)
					 (export)
					 ,@(map (lambda (x) `(#%apply ,x (#%read))) exports))
				   (U ,@exports))])
			 (export))
			,@dummies))]
	   [wrapper (let-values ([(in out) (make-pipe)])
		      (write my-expr out)
		      (close-output-port out)
		      (car (s:expand-top-level-expressions!
			    (current-directory)
			    (zodiac:read in (zodiac:make-location 1 1 0 "wrapper"))
			    #f
			    #f
			    identity)))])
      (set-car!
       (zodiac:let-values-form-vals wrapper)
       expr)
      wrapper))

  (define (analyze-units! expr)
    ;; Call spidey on units that are obviously closed because they're not in
    ;; the scope of any lexical variables
    (cond
     [(zodiac:unit-form? expr)
      (mrspidey:analyze-program-sexps 
       (list (wrap-unit-for-mrspidey expr))
       (current-directory))]
     [(zodiac:case-lambda-form? expr)
      (let ([argses (zodiac:case-lambda-form-args expr)]
	    [bodies (zodiac:case-lambda-form-bodies expr)])
	(for-each
	 (lambda (args body)
	   (when (null? args) ; no ew lexical variables? Ok!
	     (analyze-units! body)))
	 argses bodies))]
     [(zodiac:let-values-form? expr)
      ;; Only RHSes
      (for-each analyze-units! (zodiac:let-values-form-vals expr))]
     [(zodiac:app? expr)
      (let* ([exprs (cons (zodiac:app-fun expr) (zodiac:app-args expr))])
	(for-each analyze-units! exprs))]
     [(zodiac:if-form? expr)
      (analyze-units! (zodiac:if-form-test expr))
      (analyze-units! (zodiac:if-form-then expr))
      (analyze-units! (zodiac:if-form-else expr))]
     [(zodiac:begin-form? expr)
      (for-each analyze-units! (zodiac:begin-form-bodies expr))]
     [(zodiac:begin0-form? expr)
      (for-each analyze-units! (zodiac:begin0-form-bodies expr))]
     [(zodiac:set!-form? expr)
      (analyze-units! (zodiac:set!-form-val expr))]
     [(zodiac:define-values-form? expr)
      (analyze-units! (zodiac:define-values-form-val expr))]
     [(zodiac:compound-unit-form? expr)
      (for-each (lambda (link)
		  (analyze-units! (cadr link)))
		(zodiac:compound-unit-form-links expr))]
     [(zodiac:invoke-unit-form? expr)
      (analyze-units! (zodiac:invoke-unit-form-unit expr))]
     [(zodiac:struct-form? expr)
      (analyze-units! (zodiac:struct-form-super expr))]
     [(zodiac:class*/names-form? expr)
      (analyze-units! (zodiac:class*/names-form-super-expr expr))
      (for-each analyze-units! (zodiac:class*/names-form-interfaces expr))]
     [(zodiac::-form? expr)
      (analyze-units! (zodiac::-form-exp expr))]
     [(zodiac:poly-form? expr)
      (analyze-units! (zodiac:poly-form-exp expr))]
     [else (void)]))

  ;;-------------------------------------------------------------------------------
  ;; ERROR/WARNING REPORTING/HANDLING ROUTINES
  ;;
  (define compiler:messages null)
  (define compiler:make-message
    (lambda (constructor)
      (lambda (ast message)
	(set! compiler:messages (cons (constructor ast message)
				      compiler:messages)))))
  (define compiler:error (compiler:make-message make-compiler:fatal-error))
  (define compiler:fatal-error compiler:error)
  (define compiler:internal-error
    (case-lambda
     [(ast message)
      (set! compiler:messages 
	    (reverse! (cons (make-compiler:internal-error ast message)
			    compiler:messages)))
      (compiler:report-messages! #t)]
     [(ast fmt . args)
      (compiler:internal-error ast (apply format fmt args))]))

  (define compiler:warning (compiler:make-message make-compiler:warning))

  (define compiler:report-messages!
    (lambda (stop-on-errors?)
      (let ([error-count 0]
	    [fatal-error-count 0]
	    [msgs (reverse! compiler:messages)])
	(set! compiler:messages null)
	(for-each (lambda (message)
		    (when (compiler:error? message) 
		      (set! error-count (add1 error-count)))
		    (when (or (compiler:fatal-error? message) 
			      (compiler:internal-error? message))
		      (set! fatal-error-count (add1 fatal-error-count)))

		    (let* ([ast (compiler:message-ast message)]
			   [string (compiler:message-message message)])
		      (zodiac:print-start! (current-output-port) ast)
		      (printf 
		       "~a: ~a~n"
		       (cond
			[(compiler:error? message) "Error"]
			[(compiler:warning? message) "Warning"]
			[(compiler:fatal-error? message) "Error"]
			[(compiler:internal-error? message) "INTERNAL ERROR"]
			[else (error 'report-messages "internal error")])
		       string)
		      (when (compiler:internal-error? message)
			(printf 
			 (string-append
			  " please report the bug at http://www.cs.rice.edu/CS/PLT/Bugs/~n"
			  "  (or, as a last resort, send mail to plt-bugs@cs.rice.edu)~n"
			  "  and include a transcript in verbose mode~n")))))
		  
		  msgs)
	(when (and stop-on-errors?
		   (or (positive? error-count)
		       (positive? fatal-error-count)))
	  (error "Errors encountered.  Compilation aborted.")))))

  (define total-cpu-time 0)
  (define total-real-time 0)
  (define verbose-time
    (lambda (thunk)
      (let-values ([(vals cpu real gc) (time-apply thunk null)])
	(set! total-cpu-time (+ total-cpu-time cpu))
	(set! total-real-time (+ total-real-time real))
	(when (compiler:option:verbose)
	  (printf "      [cpu: ~ams, real: ~ams, gc: ~ams]~n" cpu real gc))
	(apply values vals))))

  ;;-----------------------------------------------------------------------------
  ;; File-level Block information

  (define s:file-block (make-empty-block))
  (define s:max-arity 0) ; compilation-wide max
  (define s:register-max-arity!
    (lambda (n) (set! s:max-arity (max s:max-arity n))))

  (define number-of-true-constants 0)

  (define s:unit-list null) ; list of units in the code

  (define compiler:setup-suffix "")

  ;;-----------------------------------------------------------------------------
  ;; THE MAIN DRIVING ROUTINE

  (define (compile-extension* input-name dest-directory)
    (s:compile #f #f #f input-name dest-directory))
  (define (compile-extension-to-c input-name dest-directory)
    (s:compile #t #f #f input-name dest-directory))
  (define (compile-c-extension input-name dest-directory)
    (s:compile #f #f #t input-name dest-directory))

  (define (compile-extension-part input-name dest-directory)
    (s:compile #f #t #f input-name dest-directory))
  (define (compile-extension-part-to-c input-name dest-directory)
    (s:compile #t #t #f input-name dest-directory))
  (define (compile-c-extension-part input-name dest-directory)
    (s:compile #f #t #t input-name dest-directory))

  (define compiler:multi-o-constant-pool? #f)

  (define s:compile
    (lambda (c-only? multi-o? from-c? input-name dest-directory)
      (define input-directory 
	(let-values ([(base file dir?)
		      (split-path (path->complete-path input-name))])
	  base))
      (set! compiler:multi-o-constant-pool? multi-o?)
      (set! s:file-block (make-empty-block))
      (set! s:max-arity 0)
      (set! total-cpu-time 0)
      (set! total-real-time 0)
      (random-seed (compiler:option:seed))
      (set! compiler:messages null)
      (const:init-tables!)
      (compiler:init-closure-lists!)
      ; process the input string - try to open the input file
      (let-values ([(input-path c-output-path constant-pool-output-path obj-output-path dll-output-path setup-suffix)
		    (s:process-filenames input-name dest-directory from-c? 
					 (and (compiler:option:clean-intermediate-files) (not c-only?))
					 (and (compiler:option:clean-intermediate-files) (not multi-o?)))])
	(unless (or (not input-path) (file-exists? input-path))
	  (error 's:compile "could not open ~a for input" input-path))
	(set! compiler:setup-suffix
	      (if multi-o?
		  setup-suffix
		  ""))

	(for-each (lambda (path)
		    (when (file-exists? path) (delete-file path)))
		  (list (if input-path c-output-path obj-output-path) 
			(if input-path constant-pool-output-path obj-output-path) 
			obj-output-path dll-output-path))
	
	(when (compiler:option:debug)
	  (when (file-exists? debug:file) (delete-file debug:file))
	  (set! debug:port (open-output-file debug:file 'text)))
	
	(when input-path 
	  (parameterize ([main-source-file input-path])
	    (let ([input-port (open-input-file input-path 'text)])
	      
	      ;;-----------------------------------------------------------------------
	      ;; read all top-level s-expressions
	      ;;
	      
	      (printf "\"~a\": " input-path)
	      (unless (compiler:option:verbose) (newline))
	      (let ([read-thunk
		     (lambda ()
		       (with-handlers ([void top-level-exn-handler])
			 (with-handlers ([void elaboration-exn-handler])
			   (parameterize ([current-namespace elaborate-namespace]
					  [use-compiled-file-kinds 'none]
					  [compiler:escape-on-error #t])
			     (set-block-source! 
			      s:file-block
			      (s:expand-top-level-expressions! 
			       input-directory
			       (zodiac:read input-port 
					    (zodiac:make-location 1 1 0 input-path))
			       (if (compiler:option:use-mrspidey)
				   zodiac:mrspidey-vocabulary
				   #f)
			       (compiler:option:verbose)
			       identity))))))])
		(verbose-time read-thunk)	
		(close-input-port input-port)
		(set! input-port #f)
		
		(compiler:report-messages! #t))
	
	      ; (print-struct #t) (map (lambda (ast) (pretty-print ast)) (block-source s:file-block))

	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ; (print-graph #t) (display (car (block-source s:file-block))) (newline)

	      ;;-----------------------------------------------------------------------
	      ;; MrSpidey analyze
	      
	      ; -- whole-program analysis? ----------------------------------------
	      (when (compiler:option:use-mrspidey)
		(when (compiler:option:verbose) (printf " MrSpidey: analyzing~n"))
		(let ([spidey-thunk
		       (lambda ()
			 (set-block-source! 
			  s:file-block
			  (with-handlers ([void 
					   (lambda (x)
					     (compiler:fatal-error
					      #f
					      (format "analysis died: ~a"
						      (if (exn? x)
							  (exn-message x)
							  x))))])
					 (mrspidey:analyze-program-sexps (block-source s:file-block)
									 input-directory))))])
		  (verbose-time spidey-thunk)	
		  (compiler:report-messages! #t)))
		  
	      ; -- per-unit analysis? ----------------------------------------
	      (when (compiler:option:use-mrspidey-for-units)
		(when (compiler:option:verbose) (printf " MrSpidey: analyzing units~n"))
		(let ([spidey-unit-thunk
		       (lambda ()
			 (with-handlers ([void (lambda (x)
						 (compiler:fatal-error
						  #f
						  (format "analysis died: ~a"
							  (if (exn? x)
							      (exn-message x)
							      x))))])
			   (for-each analyze-units! (block-source s:file-block))))])
		  (verbose-time spidey-unit-thunk)
		  (compiler:report-messages! #t)))

	      ; (print-struct #t)
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; Run a preprocessing phase on the input
	      ;;
	      
	      (when (compiler:option:verbose) (printf " pre-processing and scanning for errors~n"))
	      (when (compiler:option:debug) (debug " = PREPHASE =~n"))
	      
	      (let ([prephase-thunk 
		     (lambda () 
		       (set-block-source! 
			s:file-block
			(let loop ([source (block-source s:file-block)]
				   [errors compiler:messages])
			  (if (null? source)
			      source
			      (let ([ast (prephase! (car source) #f (null? (cdr source)) #f)])
				(if (eq? errors compiler:messages)
				    ; no errors here
				    (cons ast (loop (cdr source) errors))
				    ; error, drop this one
				    (loop (cdr source) compiler:messages)))))))])
		(verbose-time prephase-thunk))
	      (compiler:report-messages! (not (compiler:option:test)))
	      (when (compiler:option:test)
		(printf "skipping over top-level expressions with errors...~n"))
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; A-normalize input
	      ;;
	      
	      (when (compiler:option:verbose) (printf " transforming to a-normal form~n"))
	      (when (compiler:option:debug) (debug " = ANORM =~n"))
	      
	      (let ([anorm-thunk
		     (lambda ()
		       (set-block-source! 
			s:file-block 
			(map (lambda (s) (a-normalize s identity)) 
			     (block-source s:file-block))))])
		(verbose-time anorm-thunk))
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; known-value analysis
	      ;;

	      (when (compiler:option:verbose) 
		(printf " determining known bindings~n"))
	      (when (compiler:option:debug)
		(debug " = KNOWN =~n"))

	      ; analyze top level expressions
	      (let ([known-thunk
		     (lambda ()
		       (set-block-source! 
			s:file-block 
			(map (lambda (s) (analyze-knowns! s)) 
			     (block-source s:file-block))))])
		(verbose-time known-thunk))

	      (compiler:report-messages! #t)
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; B-form transformation and analysis
	      ;;

	      (when (compiler:option:verbose) 
		(printf " transforming to b-normal form, analyzing, and inlining~n"))
	      (when (compiler:option:debug)
		(debug " = ANALYZE =~n"))

	      ; analyze top level expressions, cataloguing local variables
	      (compiler:init-define-lists!)
	      (let ([bnorm-thunk
		     (lambda ()
		       (let-values ([(new-source new-codes max-arity)
				     (s:analyze-source-list 
				      (block-source s:file-block))])
			 (set-block-source! s:file-block new-source)
			 (set-block-codes! s:file-block new-codes)
			 (block:register-max-arity! s:file-block max-arity)
			 (s:register-max-arity! max-arity))
		       
		       ; take constant construction code and place it in front of the 
		       ; previously generated code. True constants first.
		       (set! number-of-true-constants (length compiler:define-list))
		       (s:append-block-sources! s:file-block 
						(append
						 compiler:define-list
						 compiler:per-load-define-list)))])
		(verbose-time bnorm-thunk))
	      (compiler:report-messages! #t)
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; List static procedures
	      ;;

	      (when (compiler:option:verbose) 
		(printf " finding static procedures~n"))
	      (when (compiler:option:debug)
		(debug " = LIFT =~n"))

	      (let ([lift-thunk s:lift])
		(verbose-time lift-thunk))
	      (compiler:report-messages! #t)
	      
	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; Lightweight closure transformation
	      ;;

	      (when (compiler:option:lightweight)

		(when (compiler:option:verbose) 
		  (printf " lightweight closure transformation~n"))
		
		(let ([lightweight-thunk
		       (lambda ()
			 (lightweight-analyze-and-transform 
			  (block-source s:file-block)))])
		  (verbose-time lightweight-thunk)
		  (compiler:report-messages! #t))

		(when (compiler:option:verbose) 
		      (printf " finding static procedures again~n"))
		(when (compiler:option:debug)
		      (debug " = LIFT =~n"))

		(let ([lift-thunk s:lift])
		  (verbose-time lift-thunk))
		(compiler:report-messages! #t))

	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; Closure conversion and explicit control transformation
	      ;;
	      
	      (when (compiler:option:verbose) 
		(printf " closure conversion and explicit control transformation~n"))
	      
	      (let ([closure-thunk
		     (lambda ()
		       (set-block-source! 
			s:file-block
			(map closure-expression! (block-source s:file-block))))])
		(verbose-time closure-thunk))

	      ;;-----------------------------------------------------------------------
	      ;; Vehicle assignment
	      ;;
	      ;; Set export list offset for units at the same time
	      ;;
	      
	      (when (compiler:option:verbose)
		(printf " closure->vehicle mapping~n"))
	      
	      (when (eq? (compiler:option:vehicles) 'vehicles:automatic)
		(for-each 
		 (lambda (L)
		   (when (zodiac:case-lambda-form? L)
		     (map (lambda (body)
			    (relate-lambdas! L body))
			  (zodiac:case-lambda-form-bodies L))))
		 compiler:closure-list))
	      
	      (when (eq? (compiler:option:vehicles) 'vehicles:units)
		(compiler:fatal-error 
		 #f 
		 "unit-wise vehicle mapping not currently supported~n"))
	      (let ([vehicle-thunk
		     (lambda ()
		       (compiler:init-vehicles!)
		       (compiler:reset-label-number!)
		       (choose-vehicles!))])
		(verbose-time vehicle-thunk))

	      ;;-----------------------------------------------------------------------
	      ;; Representation Choosing 
	      ;;    From this stage, we have to work with separate code bodies, as well
	      ;;    as the list of top-level expressions.
	      
	      (when (compiler:option:verbose) 
		(printf 
		 " choosing data representations~n"))
	      
	      (let ([rep-thunk
		     (lambda ()
		       (compiler:init-structs!)
		       ; top-level
		       (map
			(lambda (c)
			  (choose-binding-representations! 
			   (code-local-vars c)
			   (code-global-vars c)
			   (code-used-vars c)
			   (code-captured-vars c)))
			(block-codes s:file-block))
		       ; code-bodies
		       (for-each (lambda (L)
				   (let* ([code (get-annotation L)]
					  [locals (code-local-vars code)]
					  [globals (code-global-vars code)]
					  [used (code-used-vars code)]
					  [captured (code-captured-vars code)])
				     (choose-binding-representations! locals globals used captured)
				     (choose-closure-representation! code)))
				 compiler:closure-list))])
		(verbose-time rep-thunk))

	      ; (map (lambda (ast) (pretty-print (zodiac->sexp/annotate ast))) (block-source s:file-block))
	      
	      ;;-----------------------------------------------------------------------
	      ;; Virtual Machine Scheme translation
	      ;;   Here we turn our code into VM Scheme as we enter the arena of
	      ;;    low level transformations and optimizations.
	      ;;   This transformation may create new local variables, so
	      ;;    we have to update the local variable set for each top-level
	      ;;    expression or code body.
	      
	      (when (compiler:option:verbose) (printf " transforming to Virtual Machine form~n"))
	      (when (compiler:option:debug) (debug " = VMPHASE =~n"))
	      
	      (let ([vmphase-thunk
		     (lambda ()
		       ; top-level.  The last expression will be in tail position and should
		       ; return its value
		       (let loop ([s (block-source s:file-block)]
				  [l (block-codes s:file-block)])
			 (unless (null? s)
			   (let-values ([(vm new-locals)
					 (vm-phase (car s) 
						   #t
						   #f
						   (if (null? (cdr s)) 
						       (lambda (ast)
							 (make-vm:return 
							  (zodiac:zodiac-origin ast)
							  (zodiac:zodiac-start ast)
							  (zodiac:zodiac-finish ast)
							  ast))
						       (lambda (ast)
							 (make-vm:void
							  (zodiac:zodiac-origin ast)
							  (zodiac:zodiac-start ast)
							  (zodiac:zodiac-finish ast)
							  ast)))
						   (null? (cdr s)))])
			     (set-car! s vm)
			     (add-code-local+used-vars! (car l) new-locals))
			   (loop (cdr s) (cdr l))))
		       ; code-bodies
		       (for-each 
			(lambda (L)
			  (let* ([code (get-annotation L)]
				 [tail-pos (lambda (ast)
					     (make-vm:return 
					      (zodiac:zodiac-origin ast)
					      (zodiac:zodiac-start ast)
					      (zodiac:zodiac-finish ast)
					      ast))]
				 [new-locals
				  (cond
				   [(zodiac:case-lambda-form? L)
				    (let-values ([(vms new-locals)
						  (let loop ([l (zodiac:case-lambda-form-bodies L)]
							     [case-codes (procedure-code-case-codes 
									  (get-annotation L))]
							     [vms null])
						    (if (null? l)
							(values (reverse! vms) 
								; empty: already added via case
								empty-set) 
							(let-values ([(vm new-locals)
								      (vm-phase (car l) #t #f tail-pos #t)])
							  (add-code-local+used-vars! 
							   (car case-codes)
							   new-locals )
							  (loop (cdr l)
								(cdr case-codes)
								(cons vm vms)))))])
				      (zodiac:set-case-lambda-form-bodies! L vms)
				      new-locals)]
				   [(zodiac:unit-form? L)
				    (let-values ([(vm new-locals)
						  (vm-phase (car (zodiac:unit-form-clauses L)) 
							    #t #f tail-pos #t)])
				      (zodiac:set-unit-form-clauses! L (list vm))
				      new-locals)]
				   [(zodiac:class*/names-form? L)
				    (let ([new-locals empty-set])
				      (let ([s (zodiac:sequence-clause-exprs
						(car (zodiac:class*/names-form-inst-clauses L)))])
					(let-values ([(vm new-locs) (vm-phase (car s) #t #f #f #f)])
					  (set-car! s vm)
					  (set! new-locals (set-union new-locs new-locals))))
				      (class-init-defaults-map! 
				       L
				       (lambda (var ast)
					 (let-values ([(vm new-locs)
						       (vm-phase ast
								 #f
								 (lambda (ast)
								   (list
								    (make-vm:set! 
								     #f #f #f
								     (list
								      (cons 
								       target-type:lexical
								       (vm:convert-bound-varref 
									(zodiac:binding->lexical-varref
									 var))))
								     ast
								     #f)))
								 identity #f)])
					   (set! new-locals (set-union new-locs new-locals))
					   vm)))
				      new-locals)]
				   [else (compiler:internal-error
					  L
					  "vmphase: unknown closure type")])])
			    (add-code-local+used-vars! code new-locals)))
			compiler:closure-list))])
		(verbose-time vmphase-thunk))

	      (compiler:report-messages! #t)

	      ; (print-struct #t)
	      ; (map (lambda (ast) (pretty-print ast)) (block-source s:file-block))

	      ;;-----------------------------------------------------------------------
	      ;; Virtual Machine Optimization Pass
	      ;;
	      ;;  As in the previous phase, new local variables may be created.
	      
	      (when (compiler:option:verbose) (printf " optimizing Virtual Machine code~n"))
	      
	      (let ([vmopt-thunk
		     (lambda ()
		       ; top-level
		       (let loop ([bl (block-source s:file-block)]
				  [cl (block-codes s:file-block)])
			 (unless (null? bl)
			   (let-values ([(b new-locs) ((vm-optimize! #f #f) (car bl))])
			     (set-car! bl b)
			     (add-code-local+used-vars! (car cl) new-locs))
			   (loop (cdr bl) (cdr cl))))
		       
		       ; code-bodies
		       (for-each (lambda (L)
				   (let ([code (get-annotation L)])
				     (cond
				      [(zodiac:case-lambda-form? L)
				       (let loop ([bodies (zodiac:case-lambda-form-bodies L)]
						  [case-codes (procedure-code-case-codes code)]
						  [i 0])
					 (unless (null? bodies)
					   (let-values ([(new-body new-locs) ((vm-optimize! L i) (car bodies))])
					     (set-car! bodies new-body)
					     (add-code-local+used-vars! (car case-codes)
									new-locs)
					     (loop (cdr bodies)
						   (cdr case-codes)
						   (add1 i)))))]
				      [(zodiac:unit-form? L)
				       (let-values ([(new-clauses new-locs)
						     ((vm-optimize! L 0) (car (zodiac:unit-form-clauses L)))])
					 (set-car! (zodiac:unit-form-clauses L) new-clauses)
					 (add-code-local+used-vars! code new-locs))]
				      [(zodiac:class*/names-form? L)
				       (let ([s (zodiac:sequence-clause-exprs
						 (car (zodiac:class*/names-form-inst-clauses L)))])
					 (let-values ([(new-clauses new-locs) ((vm-optimize! L 0) (car s))])
					   (set-car! s new-clauses)
					   (add-code-local+used-vars! code new-locs)))
				       (class-init-defaults-map!
					L
					(lambda (var ast)
					  (let-values ([(new-expr new-locs) ((vm-optimize! L 0) ast)])
					    (add-code-local+used-vars! code new-locs)
					    new-expr)))]
				      [else (compiler:internal-error
					     L
					     "vmopt: unknown closure type")])))
				 compiler:closure-list))])
		(verbose-time vmopt-thunk))
		 
	      (compiler:report-messages! #t)
			  
	      ;;-----------------------------------------------------------------------
	      ;; Virtual Machine -> ANSI C translation
	      ;;
	      (when (compiler:option:verbose)
		(printf " [emitting ~a C to \"~a\"]~n" 
			"ANSI"
			c-output-path))
	
	      (let ([vm2c-thunk
		     (lambda ()
		       ;; set up bucket names - adds new symbols
		       (vm->c:make-bucket-names! (hash-table-map compiler:global-symbols
								 (lambda (x y) x)))
		       
		       (let ([c-port #f])
			 (dynamic-wind 
			  ;pre
			  (lambda () (set! c-port (open-output-file c-output-path)))
			  
			  ;value
			  (lambda ()
			    (fprintf c-port "#define MZC_SRC_FILE ~s~n" input-name)
			    (when (compiler:option:unsafe) (fprintf c-port "#define MZC_UNSAFE 1~n"))
			    (when (compiler:option:disable-interrupts) (fprintf c-port "#define MZC_DISABLE_INTERRUPTS 1~n"))
			    (when (compiler:option:fixnum-arithmetic) (fprintf c-port "#define MZC_FIXNUM 1~n"))
			    
			    (fprintf c-port "~n#include \"~ascheme.h\"~n"
				     (if (compiler:option:compile-for-embedded)
					 ""
					 "e"))
			    (fprintf c-port "#include \"mzc.h\"~n~n")
			    (vm->c:emit-struct-definitions! compiler:structs c-port)
			    (vm->c:emit-symbol-declarations! c-port)
			    (vm->c:emit-inexact-declarations! c-port)
			    (vm->c:emit-prim-ref-declarations! c-port)
			    (vm->c:emit-static-declarations! c-port)
			    
			    (let loop ([n 0])
			      (unless (= n compiler:total-vehicles)
				(vm->c:emit-vehicle-declaration c-port n)
				(loop (+ n 1))))
			    (newline c-port)
			    
			    (unless compiler:multi-o-constant-pool?
			      (fprintf c-port "~nstatic void make_symbols()~n{~n")
			      (vm->c:emit-symbol-definitions! c-port)
			      (fprintf c-port "}~n"))
			    
			    (unless (zero? const:inexact-counter)
			      (fprintf c-port "~nstatic void make_inexacts()~n{~n")
			      (vm->c:emit-inexact-definitions! c-port)
			      (fprintf c-port "}~n"))

			    (fprintf c-port "~nstatic void make_export_symbols()~n{~n")
			    (vm->c:emit-export-symbol-definitions! c-port)
			    (fprintf c-port "}~n")

			    (fprintf c-port "~nstatic void gc_registration()~n{~n")
			    (vm->c:emit-registration! c-port)
			    (fprintf c-port "}~n")

			    (fprintf c-port "~nstatic void init_prims(Scheme_Env * env)~n{~n")
			    (vm->c:emit-prim-ref-definitions! c-port)
			    (fprintf c-port "}~n")
			    
			    (unless (null? compiler:case-lambdas)
			      (fprintf c-port "~nstatic void init_cases_arities()~n{~n")
			      (vm->c:emit-case-arities-definitions! c-port)
			      (fprintf c-port "}~n"))
			    (newline c-port)

			    (unless (null? compiler:compounds)
			      (fprintf c-port "~nstatic void init_compounds(Scheme_Env * env)~n{~n")
			      (vm->c:emit-compound-definitions! c-port)
			      (fprintf c-port "}~n"))
			    
			    (unless (null? compiler:classes)
			      (fprintf c-port "~nstatic void init_classes(Scheme_Env * env)~n{~n")
			      (vm->c:emit-class-definitions! c-port)
			      (fprintf c-port "}~n"))
			    (newline c-port)

			    (unless (null? compiler:interfaces)
			      (fprintf c-port "~nstatic void init_interfaces()~n{~n")
			      (vm->c:emit-interface-definitions! c-port)
			      (fprintf c-port "}~n"))
			    (newline c-port)

			    (let* ([codes (block-codes s:file-block)]
				   [locals (map code-local-vars codes)]
				   [globals (map code-global-vars codes)]
				   [init-constants-count
				   (if (zero? number-of-true-constants)
				       -1
				       (vm->c:emit-top-levels! "init_constants" #f #f number-of-true-constants
							       (block-source s:file-block)
							       locals globals
							       (block-max-arity s:file-block)
							       c-port))]
				  [top-level-count
				   (vm->c:emit-top-levels! "top_level" #t #t -1
							   (list-tail (block-source s:file-block) number-of-true-constants)
							   (list-tail locals number-of-true-constants)
							   (list-tail globals number-of-true-constants)
							   (block-max-arity s:file-block)
							   c-port)])
			      (fprintf c-port
				       "Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n"
				       compiler:setup-suffix)
			      (fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n"
				       vm->c:indent-spaces)
			      (fprintf c-port 
				       "~aPLS = (Scheme_Per_Load_Statics *)scheme_malloc(sizeof(Scheme_Per_Load_Statics));~n"
				       vm->c:indent-spaces)
			      (let loop ([c 0])
				(fprintf c-port "~a~atop_level_~a(env, PLS);~n" 
					 vm->c:indent-spaces 
					 (if (= c top-level-count) "return " "")
					 c)
				(unless (= c top-level-count)
				  (loop (add1 c))))
			      (fprintf c-port 
				       "}~n~n")

			      (fprintf c-port
				       "~nvoid scheme_setup~a(Scheme_Env * env)~n{~n"
				       compiler:setup-suffix)
			      (fprintf c-port
				       "~ascheme_set_tail_buffer_size(~a);~n"
				       vm->c:indent-spaces
				       s:max-arity)
			      (fprintf c-port "~agc_registration();~n"
				       vm->c:indent-spaces)
			      (unless compiler:multi-o-constant-pool?
				(fprintf c-port "~amake_symbols();~n"
					 vm->c:indent-spaces))
			      (unless (zero? const:inexact-counter)
				(fprintf c-port "~amake_inexacts();~n"
					 vm->c:indent-spaces))
			      (fprintf c-port "~amake_export_symbols();~n"
				       vm->c:indent-spaces)
			      (fprintf c-port "~ainit_prims(env);~n"
				       vm->c:indent-spaces)
			      (unless (null? compiler:case-lambdas)
				(fprintf c-port "~ainit_cases_arities();~n"
					 vm->c:indent-spaces))		       

			      (let loop ([c 0])
				(unless (> c init-constants-count)
				  (fprintf c-port "~ainit_constants_~a(env);~n" 
					   vm->c:indent-spaces
					   c)
				  (loop (add1 c))))

			      (unless (null? compiler:compounds)
				(fprintf c-port "~ainit_compounds(env);~n"
					 vm->c:indent-spaces))
			      (unless (null? compiler:classes)
				(fprintf c-port "~ainit_classes(env);~n"
					 vm->c:indent-spaces))
			      (unless (null? compiler:interfaces)
				(fprintf c-port "~ainit_interfaces();~n"
					 vm->c:indent-spaces))

			      (fprintf c-port 
				       "}~n~n")
			      
			      (when (string=? "" compiler:setup-suffix)
				(fprintf c-port
					 "~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n")
				(fprintf c-port "~ascheme_setup(env);~n"
					 vm->c:indent-spaces)
				(fprintf c-port "~areturn scheme_reload(env);~n"
					 vm->c:indent-spaces)
				(fprintf c-port 
					 "}~n~n")))

			    (let emit-vehicles ([vehicle-number 0])
			      (unless (= vehicle-number compiler:total-vehicles)
				(let* ([vehicle (get-vehicle vehicle-number)]
				       [lambda-list (vehicle-lambdas vehicle)])
				  
				  (vm->c:emit-vehicle-header c-port vehicle-number)
				  (vm->c:emit-vehicle-prologue c-port vehicle)
				  
				  ; get the lambdas that appear in this vehicle
				  
				  ; sort the functions by index to get an optimal case statement
				  ; even for stupid compilers
				  (set! lambda-list
					(quicksort lambda-list
						   (lambda (l1 l2)
						     (< (closure-code-label (get-annotation l1))
							(closure-code-label (get-annotation l2))))))
				  (for-each (lambda (L)
					      (let ([code (get-annotation L)]
						    [start (zodiac:zodiac-start L)])
						(fprintf c-port "~a/* code body ~a ~a [~a,~a] */~n"
							 vm->c:indent-spaces (closure-code-label code)
							 (let ([n (closure-code-name code)])
							   (if n
							       (protect-comment 
								(vm->c:extract-inferred-name n))
							       ""))
							 (zodiac:location-line start)
							 (zodiac:location-column start))
						(cond
						 [(zodiac:case-lambda-form? L)
						  (let-values ([(count suffix?) 
								(vm->c:emit-function-prologue L c-port)])
						    (let loop ([i 0])
						      (unless (= i count)
							(let* ([indent
								(string-append
								 vm->c:indent-spaces vm->c:indent-spaces
								 (if suffix?  vm->c:indent-spaces ""))]
							       [undefines
								(vm->c:emit-case-prologue L i
											  (lambda ()
											    (if suffix?
												(fprintf c-port "~a~a/* begin case ~a */~n~a~a{~n" 
													 vm->c:indent-spaces vm->c:indent-spaces i
													 vm->c:indent-spaces vm->c:indent-spaces)
												(when (zero? i)
												  (fprintf c-port "~a{~n" vm->c:indent-spaces))))
											  (if suffix? (format "c~a" i) "")
											  indent
											  c-port)])
							  (vm->c-expression (list-ref (zodiac:case-lambda-form-bodies L) i)
									    code
									    c-port
									    (* (if suffix? 3 2) vm->c:indent-by)
									    #f)
							  (vm->c:emit-case-epilogue L i undefines indent c-port)
							  (when suffix?
							    (fprintf c-port "~a~a} /* end case ~a */~n" 
								     vm->c:indent-spaces 
								     vm->c:indent-spaces i)))
							
							(loop (add1 i))))
						    (vm->c:emit-function-epilogue code 
										  (if suffix? "" "}")
										  c-port))]
						 [(zodiac:unit-form? L)
						  (let* ([indent (string-append vm->c:indent-spaces)] 
							 [undefines (vm->c:emit-unit-prologue L indent c-port)])
						    (vm->c-expression (car (zodiac:unit-form-clauses L))
								      code
								      c-port
								      vm->c:indent-by
								      #f)
						    (vm->c:emit-unit-epilogue L undefines indent c-port))]
						 [(zodiac:class*/names-form? L)
						  (let* ([indent (string-append vm->c:indent-spaces)] 
							 [undefines (vm->c:emit-class-prologue L indent c-port)])
						    (vm->c-expression 
						     (car (zodiac:sequence-clause-exprs
							   (car (zodiac:class*/names-form-inst-clauses L))))
						     code
						     c-port
						     vm->c:indent-by
						     #f)

						    (vm->c:emit-class-epilogue L undefines indent c-port))]
						 [else
						  (compiler:internal-error
						   L
						   "vm2c: unknown closure type")])
						(newline c-port)))
					    lambda-list))
				
				(vm->c:emit-vehicle-epilogue c-port vehicle-number)
				(newline c-port)
				(emit-vehicles (+ 1 vehicle-number)))))
		   
			  ;post (dynamic wind cleanup)
			  (lambda ()  (close-output-port c-port)))))])
		(with-handlers ([void (lambda (exn)
					(delete-file c-output-path)
					(raise exn))])
		  (verbose-time vm2c-thunk)))
	      
	      (compiler:report-messages! #t)
	      
	      ;; Write out symbols for multi-o constant pool
	      (when compiler:multi-o-constant-pool?
		(call-with-output-file constant-pool-output-path
		  (lambda (port)
		    (fprintf port "(~s~n (symbols~n" compiler:setup-suffix)
		    (vm->c:emit-symbol-list! port "")
		    (fprintf port "  )~n )~n")))))))

	;;--------------------------------------------------------------------
	;; COMPILATION TO NATIVE CODE
	;;
	
	(if c-only?
	    (printf " [output to \"~a\"]~n" c-output-path)
	    
	    (begin
	      (unless input-path
		(printf "\"~a\": ~n" c-output-path))
	      
	      (when (compiler:option:verbose) (printf " [compiling native code to \"~a\"]~n"
						      obj-output-path))
	      
	      ;; Compile
	      (let ([compile-thunk
		     (lambda ()
		       (with-handlers
			   ([void (lambda (exn)
				    (compiler:fatal-error
				     #f
				     (string-append
				      " C compiler did not complete successfully"
				      (string #\newline)
				      (exn-message exn)))
				    (compiler:report-messages! #t))])
			 (compile-extension (not (compiler:option:verbose)) 
					    c-output-path obj-output-path
					    (list (collection-path "compiler")))))])
		(verbose-time compile-thunk))
	      
	      ;; clean-up
	      (when (and (compiler:option:clean-intermediate-files)
			 input-path)
		(delete-file c-output-path))
	      
	      (if multi-o?
		  (printf " [output to \"~a\"]~n" obj-output-path)
		  
		  (begin
		    ;; Link
		    (when (compiler:option:verbose) (printf " [linking to \"~a\"]~n"
							    dll-output-path))
		    (let ([link-thunk
			   (lambda ()
			     (with-handlers
				 ([void (lambda (exn)
					  (compiler:fatal-error 
					   #f 
					   (string-append 
					    " linker did not link successfully"
					    (string #\newline)
					    (exn-message exn)))
					  (compiler:report-messages! #t))])
			       (link-extension (not (compiler:option:verbose)) (list obj-output-path) dll-output-path)))])
		      (verbose-time link-thunk))
		    
		    ;; clean-up
		    (when (compiler:option:clean-intermediate-files)
		      (delete-file obj-output-path))
		    
		    (printf " [output to \"~a\"]~n" dll-output-path)))))
	
	(when debug:port
	  (close-output-port debug:port))
	
	;; clean up for the garbage collector
	(compiler:init-define-lists!)
	(const:init-tables!)
	(compiler:init-closure-lists!)
	(compiler:init-structs!)
	(set! s:file-block #f)
	(when (compiler:option:verbose)
	  (printf " finished [cpu ~a, real ~a].~n"
		  total-cpu-time
		  total-real-time))))))
