diff options
Diffstat (limited to 'csys/compiler-driver.scm')
| -rw-r--r-- | csys/compiler-driver.scm | 640 |
1 files changed, 640 insertions, 0 deletions
diff --git a/csys/compiler-driver.scm b/csys/compiler-driver.scm new file mode 100644 index 0000000..5ce5a71 --- /dev/null +++ b/csys/compiler-driver.scm @@ -0,0 +1,640 @@ +;;; 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)) + + + + + |