;;; compiler-driver.scm -- compilation unit management
;;;
;;; author :  John & Sandra
;;;
;;;


;;; Flags for controlling various low-level behaviors of the compiler.
;;; You might want to tweak these in the system-building scripts for
;;; different Lisps, but users don't normally need to mess with them.

(define *compile-interface* '#f)
(define *interface-code-quality* 2)
(define *interface-chunk-size* '#f)
(define *default-code-quality* 2)
(define *optimized-code-quality* 3)
(define *code-chunk-size* 300)



;;;=====================================================================
;;; Main entry point
;;;=====================================================================

;;; This is the top level driver for the compiler.  It takes a file name
;;; and output controls.  It returns '#f if compilation fails.

(define *codefile-cache* '())

(define (haskell-compile filename cflags)
  (initialize-haskell-system)
  (let/cc abort-compile
    (dynamic-let ((*abort-compilation*
		   (lambda () (funcall abort-compile '#f))))
     (initialize-compilation)
     (let ((unit (find-cunit-name filename)))
       (let ((res (load-compilation-unit unit cflags)))
	 (map (lambda (x) (module-name x)) (ucache-modules res)))))))

;;; this is the initialization code that occurs at the start of compilation.

(define (initialize-compilation)
  (initialize-module-table)
  (for-each-unit
   (lambda (u)
     (setf (ucache-status u) 'available))))



;;;=====================================================================
;;; Filename utilities
;;;=====================================================================

;;; File extensions

(define *source-file-extensions* '(".hs" ".lhs"))
(define *unit-file-extension* ".hu")
(define *interface-file-extension* ".hi")
(define *lisp-file-extensions* '(".lisp" ".scm"))

(define (source-extension? x)
  (mem-string x *source-file-extensions*))

(define (unit-extension? x)
  (string=? x *unit-file-extension*))

(define (interface-extension? x)
  (string=? x *interface-file-extension*))

(define (lisp-extension? x)
  (mem-string x *lisp-file-extensions*))


;;; Build file names.

(define (make-cifilename filename)
  (let ((place  (filename-place filename))
	(name   (string-append (filename-name filename) "-hci")))
    (assemble-filename place name binary-file-type)))

(define (make-sifilename filename)
  (let ((place  (filename-place filename))
	(name   (string-append (filename-name filename) "-hci")))
    (assemble-filename place name source-file-type)))

(define (make-cfilename filename)
  (add-extension filename binary-file-type))

(define (make-sfilename filename)
  (add-extension filename source-file-type))


;;; This take a file name (extension ignored) & searches for a unit file.

(define (locate-existing-cunit name)
  (locate-extension name (list *unit-file-extension*)))

;;; This take a file name (extension ignored) & searches for a source file.

(define (locate-existing-source-file name)
  (locate-extension name *source-file-extensions*))

(define (locate-extension name extensions)
  (if (null? extensions)
      '#f
      (let ((name-1 (add-extension name (car extensions))))
	(if (file-exists? name-1)
	    name-1
	    (locate-extension name (cdr extensions))))))


;;; This delivers the name of a compilation unit.  The extension of the name
;;; is ignored & a test for the presence of a compilation unit with 
;;; the same name is done.  If none is found, signal an error.

(define (find-cunit-name name)
  (or (locate-existing-cunit name)
      (locate-existing-source-file name)
      (signal-file-not-found name)))



;;;=====================================================================
;;; Compilation unit file parsing
;;;=====================================================================

;;; This parses a unit file.  The file simply contains a list of file names.
;;; The files are sorted into two catagories: other compilation units and
;;; source files in the current unit.  When a file has no extension, the system
;;; checks for a unit file first and then a source file.

(define (parse-compilation-unit filename)
 (let ((unit-type (filename-type filename)))
  (if (or (source-extension? unit-type) (interface-extension? unit-type))
      (create-ucache filename filename (list filename) '() '() '#f '#t
		     '#f '() '#f '() '#f)
      (parse-compilation-unit-aux
        filename
	(call-with-input-file filename (function gather-file-names))))))

(define (create-ucache filename output-filename
		       source-files imports lisp-files
		       stable? load-prelude?
		       printers-set? printers optimizers-set? optimizers
		       chunk-size)
  (let* ((cifilename
	  (make-cifilename output-filename))
	 (sifilename
	  (make-sifilename output-filename))
	 (all-imports
	  (if load-prelude?
	      (cons *prelude-unit-filename* imports)
	      imports))
	 (cache-entry
	  (make ucache
		(ufile filename)
		(sifile sifilename)
		(cifile cifilename)
		(sfile (make-sfilename output-filename))
		(cfile (make-cfilename output-filename))
		(udate (current-date))
		(idate (get-latest-ifiledate cifilename sifilename))
		(stable? stable?)
		(load-prelude? load-prelude?)
		(status 'loading)
		(ifile-loaded '#f)
		(code-loaded '#f)
		(source-files source-files)
		(imported-units all-imports)
		(lisp-files lisp-files)
		(modules '())
		(printers-set? printers-set?)
		(printers printers)
		(optimizers-set? optimizers-set?)
		(optimizers optimizers)
		(chunk-size chunk-size))))
    (install-compilation-unit filename cache-entry)
    cache-entry))

(define (get-latest-ifiledate cifilename sifilename)
  (max (or (and (file-exists? cifilename)
		(file-write-date cifilename))
	   0)
       (or (and (file-exists? sifilename)
		(file-write-date sifilename))
	   0)))


;;; This returns a list of strings.  Blank lines and lines starting in -
;;; are ignored.

(define (gather-file-names port)
  (let ((char (peek-char port)))
    (cond ((eof-object? char)
	   '())
	  ((or (char=? char '#\newline) (char=? char '#\-))
	   (read-line port)
	   (gather-file-names port))
	  (else
	   (let ((line (read-line port)))
	     (cons line (gather-file-names port)))))))


;;; Actually parse contents of the unit file.

;;; These are in the command-interface stuff.
(predefine (set-printers args mode))
(predefine (set-optimizers args mode))
(predefine (parse-command-args string start next end))

(define (parse-compilation-unit-aux filename strings)
  (let ((input-defaults   filename)
	(output-defaults  filename)
	(import-defaults  filename)
	(stable?          '#f)
	(load-prelude?    '#t)
	(filenames        '())
	(imports          '())
	(sources          '())
	(lisp-files       '())
	(printers         '())
	(printers-set?    '#f)
	(optimizers       '())
	(optimizers-set?  '#f)
	(chunk-size       '#f)
	(temp             '#f))
    ;;; First look for magic flags.
    (dolist (s strings)
      (cond ((setf temp (string-match-prefix ":input" s))
	     (setf input-defaults (merge-file-defaults temp filename)))
	    ((setf temp (string-match-prefix ":output" s))
	     (setf output-defaults (merge-file-defaults temp filename)))
	    ((setf temp (string-match-prefix ":import" s))
	     (setf import-defaults (merge-file-defaults temp filename)))
	    ((string=? ":stable" s)
	     (setf stable? '#t))
	    ((string=? ":prelude" s)
	     (setf load-prelude? '#f))
	    ((setf temp (string-match-prefix ":p=" s))
	     (setf printers-set? '#t)
	     (setf printers
		   (set-printers
		      (parse-command-args temp 0 0 (string-length temp))
		      '=)))
	    ((setf temp (string-match-prefix ":o=" s))
	     (setf optimizers-set? '#t)
	     (setf optimizers
		   (set-optimizers
                      (parse-command-args temp 0 0 (string-length temp))
		      '=)))
	    ((setf temp (string-match-prefix ":chunk-size" s))
	     (setf chunk-size (string->number temp)))
	    (else
	     (push s filenames))))
    ;;; Next sort filenames into imports and source files.
    (dolist (s filenames)
      (let ((type    (filename-type s))
	    (fname   '#f))
	(cond ((string=? type "")  ; punt for now on this issue
	       (signal-extension-needed s))
;	      ((cond ((setf fname 
;			    (locate-existing-cunit
;			      (merge-file-defaults s import-defaults)))
;		      (push fname imports))
;		     ((setf fname
;			    (locate-existing-source-file
;			      (merge-file-defaults s input-defaults)))
;		      (push fname sources))
;		     (else
;		      (signal-unit-not-found s))))
	      ((unit-extension? type)
	       (setf fname  (merge-file-defaults s import-defaults))
	       (if (file-exists? fname)
		   (push fname imports)
		   (signal-unit-not-found fname)))
	      ((or (source-extension? type) (interface-extension? type))
	       (setf fname  (merge-file-defaults s input-defaults))
	       (if (file-exists? fname)
		   (push fname sources)
		   (signal-unit-not-found fname)))
	      ((lisp-extension? type)
	       (setf fname (merge-file-defaults s input-defaults))
	       (if (file-exists? fname)
		   (push (cons fname
			       (add-extension
			         (merge-file-defaults s output-defaults)
				 binary-file-type))
			 lisp-files)
		   (signal-unit-not-found fname)))
	      (else
	       (signal-unknown-file-type s)))))
    ;; Finally create the unit object.
    (create-ucache filename output-defaults
		   sources imports lisp-files
		   stable? load-prelude?
		   printers-set? printers optimizers-set? optimizers
		   chunk-size)))


;;; Helper functions for the above.

(define (string-match-prefix prefix s)
  (let ((prefix-length  (string-length prefix))
	(s-length       (string-length s)))
    (if (>= s-length prefix-length)
	(string-match-prefix-aux prefix s prefix-length s-length 0)
	'#f)))

(define (string-match-prefix-aux prefix s prefix-length s-length i)
  (cond ((eqv? i prefix-length)
	 (string-match-prefix-aux-aux s s-length i))
	((not (char=? (string-ref s i) (string-ref prefix i)))
	 '#f)
	(else
	 (string-match-prefix-aux prefix s prefix-length s-length (1+ i)))))

(define (string-match-prefix-aux-aux s s-length i)
  (cond ((eqv? i s-length)
	 "")
	((let ((ch  (string-ref s i)))
	   (or (char=? ch '#\space) (char=? ch #\tab)))
	 (string-match-prefix-aux-aux s s-length (1+ i)))
	(else
	 (substring s i s-length))))

(define (merge-file-defaults filename defaults)
  (let ((place  (filename-place filename))
	(name   (filename-name filename))
	(type   (filename-type filename)))
    (assemble-filename
      (if (string=? place "") defaults place)
      (if (string=? name "") defaults name)
      (if (string=? type "") defaults type))))
    
    
;;;=====================================================================
;;; Guts
;;;=====================================================================


;;; This is the main entry to the compilation system.  This causes a
;;; unit to be compiled and/or loaded.

(define (load-compilation-unit filename cflags)
  (let ((cunit (lookup-compilation-unit filename)))
    (cond ((eq? cunit '#f)
	   ;; Unit not found in cache.
	   (load-compilation-unit-aux
	     (parse-compilation-unit filename) cflags))
	  ((eq? (ucache-status cunit) 'loaded)
	   ;; Already loaded earlier in this compile.
	   cunit)
	  ((eq? (ucache-status cunit) 'loading)
	   (signal-circular-unit filename))
	  (else
	   (load-compilation-unit-aux cunit cflags))
	  )))


(define (load-compilation-unit-aux c cflags)
  (setf (ucache-status c) 'loading)
  (load-imported-units c cflags)
  (if (unit-valid? c cflags)
      (load-compiled-unit c (cflags-load-code? cflags))
      (locally-compile c cflags))
  (setf (ucache-status c) 'loaded)
  ;; Hack, hack.  When loading the prelude, make sure magic symbol
  ;; table stuff is initialized.
  (when (string=? (ucache-ufile c) *prelude-unit-filename*)
    (init-prelude-globals))
  c)

(define (load-compiled-unit c load-code?)
  (when (and load-code? (not (ucache-code-loaded c)))
    (when (memq 'loading *printers*)
      (format '#t "~&Loading unit ~s.~%" (ucache-ufile c))
      (force-output))
    (load-lisp-files (ucache-lisp-files c))
    (load-more-recent-file (ucache-cfile c) (ucache-sfile c))
    (setf (ucache-code-loaded c) '#t))
  (when (not (ucache-ifile-loaded c))
     (read-binary-interface c))
  (dolist (m (ucache-modules c))
      (add-module-to-symbol-table m))
  (link-instances (ucache-modules c)))


;;; These globals save the Prelude symbol table to avoid copying it
;;; into all modules which use the Prelude.

;;; Danger!  This assumes that every local symbol in the Prelude is
;;; exported.

(define *prelude-initialized* '#f)

(define (init-prelude-globals)
  (when (not *prelude-initialized*)
    (let ((pmod (locate-module '|Prelude|)))
      (setf *prelude-symbol-table* (module-symbol-table pmod))
      (setf *prelude-fixity-table* (module-fixity-table pmod))
      (when (eq? (module-inverted-symbol-table pmod) '#f)
	(let ((table (make-table)))
	  (table-for-each (lambda (name def)
			    (setf (table-entry table def) name))
			  *prelude-symbol-table*)
	  (setf (module-inverted-symbol-table pmod) table)))
      (setf *prelude-inverted-symbol-table*
	    (module-inverted-symbol-table pmod)))
    (setf *prelude-initialized* '#t)))


;;; This recursively loads all units imported by a given unit.

(define (load-imported-units c cflags)
  (dolist (filename (ucache-imported-units c))
    (load-compilation-unit filename cflags)))



;;; Load or compile lisp files.

(define (load-lisp-files lisp-files)
  (dolist (f lisp-files)
    (load-more-recent-file (cdr f) (car f))))

(define (compile-lisp-files lisp-files)
  (dolist (f lisp-files)
    (let ((source  (car f))
	  (binary  (cdr f)))
      (when (not (lisp-binary-current source binary))
	(compile-file source binary))
      (load binary))))



;;; This determines whether a unit is valid.

(define (unit-valid? c cflags)
  (and (or (ucache-stable? c)
	   ;; If the unit is not stable, make sure its source files
	   ;; haven't changed.
	   (and (all-imports-current (ucache-imported-units c)
				     (ucache-idate c))
		(all-sources-current (ucache-source-files c)
				     (ucache-idate c))
		(all-lisp-sources-current (ucache-lisp-files c)
					  (ucache-idate c))))
       (or (ucache-ifile-loaded c)
	   ;; If the interface hasn't been loaded already, make sure
	   ;; that the interface file exists.
	   (file-exists? (ucache-cifile c))
	   (file-exists? (ucache-sifile c)))
       (or (not (cflags-load-code? cflags))
	   ;; If we're going to load code, make sure that the code file
	   ;; exists.
	   (ucache-code-loaded c)
	   (file-exists? (ucache-cfile c))
	   (file-exists? (ucache-sfile c)))
       (or (not (cflags-write-code? cflags))
	   ;; If we need to produce a code file, make sure this has
	   ;; already been done.
	   ;; Don't write files for stable units which have already
	   ;; been loaded, regardless of whether or not the file exists.
	   (and (ucache-stable? c) (ucache-code-loaded c))
	   (file-exists? (ucache-cfile c))
	   (and (not (cflags-compile-code? cflags))
		(file-exists? (ucache-sfile c))))
       (or (not (cflags-compile-code? cflags))
	   ;; If we need to compile the lisp files, make sure this has
	   ;; already been done.
	   ;; Don't do this for stable units which have already
	   ;; been loaded.
	   (and (ucache-stable? c) (ucache-code-loaded c))
	   (all-lisp-binaries-current (ucache-lisp-files c)))
       (or (not (cflags-write-interface? cflags))
	   ;; If we need to produce an interface file, make sure this has
	   ;; already been done.
	   ;; Don't write files for stable units which have already
	   ;; been loaded, regardless of whether or not the file exists.
	   (and (ucache-stable? c) (ucache-ifile-loaded c))
	   (file-exists? (ucache-cifile c))
	   (and (not *compile-interface*)
		(file-exists? (ucache-sifile c))))
       ))

(define (all-sources-current sources unit-write-date)
  (every (lambda (s)
	   (let ((d  (file-write-date s)))
	     (and d (> unit-write-date d))))
	 sources))

(define (all-imports-current imports unit-write-date)
  (every (lambda (s) (> unit-write-date
			(ucache-idate (lookup-compilation-unit s))))
	 imports))

(define (all-lisp-sources-current lisp-files unit-write-date)
  (every (lambda (s)
	   (let ((d  (file-write-date (car s))))
	     (and d (> unit-write-date d))))
	 lisp-files))

(define (all-lisp-binaries-current lisp-files)
  (every (lambda (s)
	   (lisp-binary-current (car s) (cdr s)))
	 lisp-files))

(define (lisp-binary-current source binary)
  (and (file-exists? binary)
       (let ((sd  (file-write-date source))
	     (bd  (file-write-date binary)))
	 (and sd bd (> bd sd)))))


;;; This does the actual job of compilation.

(define (locally-compile c cflags)
  (dynamic-let ((*printers*
		  (if (ucache-printers-set? c)
		      (ucache-printers c)
		      (dynamic *printers*)))
		(*optimizers*
		  (if (ucache-optimizers-set? c)
		      (ucache-optimizers c)
		      (dynamic *optimizers*))))
    (when (memq 'compiling *printers*)
       (format '#t "~&Compiling unit ~s.~%Optimizers: ~A~%"
	       (ucache-ufile c)
	       *optimizers*)
	       (force-output))
    (if (cflags-compile-code? cflags)
	(compile-lisp-files (ucache-lisp-files c))
	(load-lisp-files (ucache-lisp-files c)))
    (multiple-value-bind (mods code)
	(compile-haskell-files (ucache-source-files c))
      ;; General bookkeeping to update module interface in cache.
      (setf (ucache-modules c) mods)
      (setf (ucache-idate c) (current-date))
      (setf (ucache-ifile-loaded c) '#t)
      ;; Write interface file if necessary.
      (when (cflags-write-interface? cflags)
	(let ((phase-start-time (get-run-time))
	      (icode  (create-dump-code c mods (ucache-load-prelude? c))))
	  (if (dynamic *compile-interface*)
	      (write-compiled-code-file
	        (ucache-cifile c)
		icode
		(dynamic *interface-code-quality*)
		(dynamic *interface-chunk-size*))
	      (write-interpreted-code-file (ucache-sifile c) icode '#f))
	  (when (memq 'phase-time *printers*)
	    (let* ((current-time (get-run-time))
		   (elapsed-time (- current-time phase-start-time)))
	      (format '#t "Interface complete: ~A seconds~%" elapsed-time)
	      (force-output)))))
      ;; Write code file if necessary.
      (when (cflags-write-code? cflags)
	(if (cflags-compile-code? cflags)
	    (write-compiled-code-file
	      (ucache-cfile c)
	      code
	      (if (memq 'lisp (dynamic *optimizers*))
		  (dynamic *optimized-code-quality*)
		  (dynamic *default-code-quality*))
	      (or (ucache-chunk-size c) (dynamic *code-chunk-size*)))
	    (write-interpreted-code-file (ucache-sfile c) code '#t)))
      ;; Load or evaluate code if necessary.
      ;; If we just wrote a compiled code file, load that; otherwise
      ;; do eval or in-core compilation.
      (when (cflags-load-code? cflags)
	(if (and (cflags-write-code? cflags)
		 (cflags-compile-code? cflags))
	    (load (ucache-cfile c))
	    (eval code (cflags-compile-code? cflags)))
	(setf (ucache-code-loaded c) '#t))
      )))



;;;=====================================================================
;;; Cache manager
;;;=====================================================================

;;; This is the cache manager for compilation units.  We use an alist at
;;; the moment.

(define *unit-cache* '())

(define (reset-unit-cache)
  (setf *unit-cache* '()))


;;; This checks to make sure that the compilation unit it finds
;;; in the cache has not been made out-of-date by updates to the unit file.

(define (lookup-compilation-unit name)
  (let ((r (ass-string name *unit-cache*)))
    (if r
	(let ((c  (cdr r)))
	 (if (or (ucache-stable? c)
		 (> (ucache-udate c)
		    (or (file-write-date (ucache-ufile c)) 0)))
	     c
	     '#f))
	'#f)))

(define (install-compilation-unit name c)
  (let ((r (ass-string name *unit-cache*)))
    (if (eq? r '#f)
	(push (cons name c) *unit-cache*)
	(setf (cdr r) c))))

(define (for-each-unit proc)
  (dolist (c *unit-cache*)
     (funcall proc (cdr c))))


;;;=====================================================================
;;; Error utilities
;;;=====================================================================

(define (signal-circular-unit filename)
  (fatal-error 'circular-unit
    "The compilation unit ~a has a circular dependency."
    filename))

(define (signal-unit-not-found filename)
  (fatal-error 'unit-not-found
    "The compilation unit file ~a was not found."
    filename))

(define (signal-extension-needed filename)
  (fatal-error 'extension-needed
    "You must provide an extension on the filename ~a in the .hu file."
     filename))