diff options
Diffstat (limited to 'csys')
| -rw-r--r-- | csys/README | 3 | ||||
| -rw-r--r-- | csys/cache-structs.scm | 48 | ||||
| -rw-r--r-- | csys/compiler-driver.scm | 640 | ||||
| -rw-r--r-- | csys/csys.scm | 25 | ||||
| -rw-r--r-- | csys/dump-cse.scm | 182 | ||||
| -rw-r--r-- | csys/dump-flic.scm | 130 | ||||
| -rw-r--r-- | csys/dump-interface.scm | 800 | ||||
| -rw-r--r-- | csys/dump-macros.scm | 37 | ||||
| -rw-r--r-- | csys/dump-params.scm | 18 | ||||
| -rw-r--r-- | csys/magic.scm | 10 |
10 files changed, 1893 insertions, 0 deletions
diff --git a/csys/README b/csys/README new file mode 100644 index 0000000..6f9c183 --- /dev/null +++ b/csys/README @@ -0,0 +1,3 @@ +This directory contains everything relating to the compilation system, +including stuff for parsing unit files, incremental recompilation, and +reading and writing code and interface files. diff --git a/csys/cache-structs.scm b/csys/cache-structs.scm new file mode 100644 index 0000000..ba38840 --- /dev/null +++ b/csys/cache-structs.scm @@ -0,0 +1,48 @@ +;;; these structures deal with the compilation system and the unit cache. + +;;; An entry in the unit cache: + +(define-struct ucache + (slots + (ufile (type string)) ; the name of the file containing the unit definition + (cifile (type string)) ; the filename of the (compiled) interface file + (sifile (type string)) ; the filename of the (uncompiled) interface file + (cfile (type string)) ; the filename of the (compiled) output file + (sfile (type string)) ; the filename of the (uncompiled) output file + (udate (type integer)) ; the write date of ufile + (idate (type integer)) ; the time stamp of the binary interface file + (stable? (type bool)) ; the stable flag + (load-prelude? (type bool)) ; true if unit uses standard prelude + ;; status is initially available (in cache). It is set to loading when + ;; requested and loaded once all imported units are loaded. + (status (type (enum loaded loading available))) + (ifile-loaded (type bool)) ; true when interface is loaded (modules) + (code-loaded (type bool)) ; true when the associated code is in memory + (source-files (type (list string))) ; source files in the unit + (imported-units (type (list string))) ; the filenames of imported unit files + (lisp-files (type (list (tuple string string)))) ; source/binary pairs + (modules (type (list module))) + (printers-set? (type bool)) + (printers (type (list symbol))) + (optimizers-set? (type bool)) + (optimizers (type (list symbol))) + (chunk-size (type (maybe int))) + )) + + +;;; This is used to hold various flags used by the compilation system, +;;; instead of passing them all as individual arguments. + +(define-struct cflags + (slots + ;; Whether to load code for unit into core + (load-code? (type bool) (default '#t)) + ;; Whether to create an output code file. + (write-code? (type bool) (default '#t)) + ;; Affects whether write-code? creates a source or compiled file, + ;; and whether load-code? uses the interpreter or compiler. + ;; Ignored if load-code? and write-code? are both false. + (compile-code? (type bool) (default '#t)) + ;; Whether to create an output interface file. + (write-interface? (type bool) (default '#t)) + )) 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)) + + + + + diff --git a/csys/csys.scm b/csys/csys.scm new file mode 100644 index 0000000..a4683b6 --- /dev/null +++ b/csys/csys.scm @@ -0,0 +1,25 @@ +;;; csys.scm -- compilation unit definition for the compilation system + +(define-compilation-unit csys + (source-filename "$Y2/csys/") + (require global runtime flic) + (unit cache-structs + (source-filename "cache-structs.scm")) + (unit compiler-driver + (require cache-structs) + (source-filename "compiler-driver.scm")) + (unit dump-params + (require cache-structs) + (source-filename "dump-params.scm")) + (unit dump-macros + (require dump-params) + (source-filename "dump-macros.scm")) + (unit dump-interface + (require dump-macros) + (source-filename "dump-interface.scm")) + (unit dump-flic + (require dump-macros) + (source-filename "dump-flic.scm")) + (unit dump-cse + (require dump-macros) + (source-filename "dump-cse.scm"))) diff --git a/csys/dump-cse.scm b/csys/dump-cse.scm new file mode 100644 index 0000000..38ec020 --- /dev/null +++ b/csys/dump-cse.scm @@ -0,0 +1,182 @@ +;;; This file handles common subexpressions in the interface file. +;;; Common subexpressions are detected in two places: gtypes and strictness +;;; properties. + +;;; Compressing strictness signatures + +;;; A strictness is represented by a list of booleans. We do two things to +;;; compress strictnesses: all lists less than *pre-defined-strictness-size* +;;; are pre-computed in a vector and the first *pre-defined-strictness-vars* +;;; vector elements are cached in global vars. The strictness will dump as +;;; as either a global or as a vector reference into the vector. + +(define (initialize-strictness-table) + (setf (dynamic *pre-defined-strictness-table*) + (make-vector (expt 2 (1+ (dynamic *pre-defined-strictness-size*))))) + (setf (vector-ref *pre-defined-strictness-table* 1) '()) + (do ((i 1 (1+ i)) + (j 1 (* j 2)) + (k 2 (* k 2))) + ((> i *pre-defined-strictness-size*)) + (do ((l 0 (1+ l))) + ((>= l j)) + (setf (vector-ref *pre-defined-strictness-table* (+ k l)) + (cons '#f (vector-ref *pre-defined-strictness-table* (+ j l)))) + (setf (vector-ref *pre-defined-strictness-table* (+ k j l)) + (cons '#t (vector-ref *pre-defined-strictness-table* (+ j l)))))) + (set-strictness-vars)) + +(define (strictness-table-ref x) + (vector-ref (dynamic *pre-defined-strictness-table*) x)) + +(define (dump-strictness s) + (if (null? s) + ''() + (dump-strictness-1 s s 0 0))) + +(define (dump-strictness-1 s s1 n size) + (if (null? s1) + (if (> size *pre-defined-strictness-size*) + (dump-big-strictness (- size *pre-defined-strictness-size*) s) + (let ((k (+ n (expt 2 size)))) + (if (< k *pre-defined-strictness-vars*) + `(dynamic ,(vector-ref *pre-defined-strictness-names* k)) + `(strictness-table-ref ,k)))) + (dump-strictness-1 s (cdr s1) (+ (* 2 n) (if (car s1) 1 0)) (1+ size)))) + +(define (dump-big-strictness k s) + (if (= k 0) + (dump-strictness s) + `(cons ',(car s) + ,(dump-big-strictness (1- k) (cdr s))))) + +;;; This routine handles saving type signatures (gtypes). +;;; common subexpressions are detected in two places: the type body +;;; and the the contexts. + +(define (init-predefined-gtyvars) + (setf *saved-gtyvars* (make-vector *num-saved-gtyvars*)) + (dotimes (i *num-saved-gtyvars*) + (setf (vector-ref *saved-gtyvars* i) (**gtyvar i))) + (setup-gtyvar-vars)) + +(define (init-cse-structs) + (initialize-strictness-table) + (init-predefined-gtyvars)) + +(define (save-cse-value v) + (setf (vector-ref (dynamic *saved-cse-values*) (dynamic *cse-value-num*)) v) + (incf (dynamic *cse-value-num*))) + +(define (cse-init-code) + (let* ((n (length *cse-objects*)) + (init-code '())) + (do ((i (1- n) (1- i)) + (init *cse-objects* (cdr init))) + ((null? init)) + (push `(save-cse-value ,(car init)) init-code)) + `((setf *saved-cse-values* (make-vector ,n)) + (setf *cse-value-num* 0) + ,@init-code))) + +(define (remember-dumped-object init-code) + (push init-code *cse-objects*) + (incf *cse-object-num*) + *cse-object-num*) + +(define (cse-value-ref x) + (vector-ref (dynamic *saved-cse-values*) x)) + +(define (cse-ref-code n) + (cond ((eqv? n 0) + ''()) + ((<= n *num-saved-gtyvars*) + `(dynamic ,(vector-ref *saved-gtyvar-varnames* (1- n)))) + (else + `(cse-value-ref ,(- n *num-saved-gtyvars* 1))))) + +(define (dump-gtyvar g) + (let ((n (gtyvar-varnum g))) + (if (< n *num-saved-gtyvars*) + (1+ n) + (remember-dumped-object `(**gtyvar ,n))))) + +(define (dump-context-list contexts) + (if (null? contexts) + 0 + (let* ((rest (dump-context-list (cdr contexts))) + (classes (dump-class-list (car contexts))) + (t1 (assq/insert-l classes *gtype-class-index*)) + (res (assq/insert rest (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(cons ,(cse-ref-code classes) ,(cse-ref-code rest))))) + (setf (cdr res) z) + z) + (cdr res))))) + +(define (dump-class-list classes) + (if (null? classes) + 0 + (let* ((rest (dump-class-list (cdr classes))) + (class (dump-class/n (car classes))) + (t1 (assq/insert-l class *context-class-index*)) + (res (assq/insert rest (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(cons ,class ,(cse-ref-code rest))))) + (setf (cdr res) z) + z) + (cdr res))))) + +(define (dump-gtype-1 g) + (cond ((gtyvar? g) + (dump-gtyvar g)) + ((ntyvar? g) + (dump-gtype-1 (prune g))) + (else + (dump-gtycon g)))) + +(define (dump-gtycon g) + (let* ((ty (ntycon-tycon g)) + (tycon (if (algdata? ty) (dump-algdata/n ty) (dump-synonym/n ty))) + (l (dump-gtype-list (ntycon-args g))) + (t1 (assq/insert-l tycon *gtype-tycon-index*)) + (res (assq/insert l (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(**ntycon ,tycon ,(cse-ref-code l))))) + (setf (cdr res) z) + z) + (cdr res)))) + +(define (dump-gtype-list l) + (if (null? l) + 0 + (let* ((g (dump-gtype-1 (car l))) + (rest (dump-gtype-list (cdr l))) + (t1 (assq/insert-l g *gtype-list-index*)) + (res (assq/insert rest (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(cons ,(cse-ref-code g) + ,(cse-ref-code rest))))) + (setf (cdr res) z) + z) + (cdr res))))) + +(define (dump-gtype/cse g) + (cse-ref-code + (let* ((context (dump-context-list (gtype-context g))) + (type (dump-gtype-1 (gtype-type g))) + (t1 (assq/insert-l type *gtype-index*)) + (res (assq/insert context (cdr t1)))) + (if (eq? (cdr res) '#f) + (let ((z (remember-dumped-object + `(**gtype ,(cse-ref-code context) + ,(cse-ref-code type))))) + (setf (cdr res) z) + z) + (cdr res))))) + + diff --git a/csys/dump-flic.scm b/csys/dump-flic.scm new file mode 100644 index 0000000..0fc654d --- /dev/null +++ b/csys/dump-flic.scm @@ -0,0 +1,130 @@ +;;; dump-flic.scm -- general dump functions for flic structures +;;; +;;; author : Sandra Loosemore +;;; date : 24 Feb 1993 +;;; +;;; +;;; This stuff is used to write inline expansions to the interface file. +;;; + + +(define-flic-walker dump-flic (object var-renamings)) + +(define (dump-flic-list objects var-renamings) + (let ((result '())) + (dolist (o objects) + (push (dump-flic o var-renamings) result)) + `(list ,@(nreverse result)))) + +(define (dump-flic-top object) + (dump-flic object '())) + + +(define (make-temp-bindings-for-dump oldvars var-renamings) + (let ((vars '()) + (bindings '())) + (dolist (v oldvars) + (let ((var (def-name v)) + (temp (gensym))) + (push temp vars) + (push `(,temp (create-temp-var ',var)) bindings) + (push (cons v temp) var-renamings))) + (setf bindings (nreverse bindings)) + (setf vars (nreverse vars)) + (values vars bindings var-renamings))) + +(define-dump-flic flic-lambda (object var-renamings) + (multiple-value-bind (vars bindings var-renamings) + (make-temp-bindings-for-dump (flic-lambda-vars object) var-renamings) + `(let ,bindings + (make-flic-lambda + (list ,@vars) + ,(dump-flic (flic-lambda-body object) var-renamings))) + )) + +(define-dump-flic flic-let (object var-renamings) + (multiple-value-bind (vars bindings var-renamings) + (make-temp-bindings-for-dump (flic-let-bindings object) var-renamings) + `(let ,bindings + ,@(map (lambda (temp v) + `(setf (var-value ,temp) + ,(dump-flic (var-value v) var-renamings))) + vars + (flic-let-bindings object)) + (make-flic-let + (list ,@vars) + ,(dump-flic (flic-let-body object) var-renamings) + ',(flic-let-recursive? object))) + )) + +(define-dump-flic flic-app (object var-renamings) + `(make-flic-app + ,(dump-flic (flic-app-fn object) var-renamings) + ,(dump-flic-list (flic-app-args object) var-renamings) + ',(flic-app-saturated? object))) + +(define-dump-flic flic-ref (object var-renamings) + (let* ((var (flic-ref-var object)) + (entry (assq var var-renamings))) + (if entry + `(make-flic-ref ,(cdr entry)) + `(make-flic-ref ,(dump-object var))))) + +(define-dump-flic flic-const (object var-renamings) + (declare (ignore var-renamings)) + `(make-flic-const ',(flic-const-value object))) + +(define-dump-flic flic-pack (object var-renamings) + (declare (ignore var-renamings)) + `(make-flic-pack ,(dump-object (flic-pack-con object)))) + +(define-dump-flic flic-case-block (object var-renamings) + `(make-flic-case-block + ',(flic-case-block-block-name object) + ,(dump-flic-list (flic-case-block-exps object) var-renamings))) + +(define-dump-flic flic-return-from (object var-renamings) + `(make-flic-return-from + ',(flic-return-from-block-name object) + ,(dump-flic (flic-return-from-exp object) var-renamings))) + +(define-dump-flic flic-and (object var-renamings) + `(make-flic-and + ,(dump-flic-list (flic-and-exps object) var-renamings))) + +(define-dump-flic flic-if (object var-renamings) + `(make-flic-if + ,(dump-flic (flic-if-test-exp object) var-renamings) + ,(dump-flic (flic-if-then-exp object) var-renamings) + ,(dump-flic (flic-if-else-exp object) var-renamings))) + +(define-dump-flic flic-sel (object var-renamings) + `(make-flic-sel + ,(dump-object (flic-sel-con object)) + ,(flic-sel-i object) + ,(dump-flic (flic-sel-exp object) var-renamings))) + +(define-dump-flic flic-is-constructor (object var-renamings) + `(make-flic-is-constructor + ,(dump-object (flic-is-constructor-con object)) + ,(dump-flic (flic-is-constructor-exp object) var-renamings))) + +(define-dump-flic flic-con-number (object var-renamings) + `(make-flic-con-number + ,(dump-object (flic-con-number-type object)) + ,(dump-flic (flic-con-number-exp object) var-renamings))) + +(define-dump-flic flic-void (object var-renamings) + (declare (ignore object var-renamings)) + `(make-flic-void)) + + + + + + + + + + + diff --git a/csys/dump-interface.scm b/csys/dump-interface.scm new file mode 100644 index 0000000..37b3bbd --- /dev/null +++ b/csys/dump-interface.scm @@ -0,0 +1,800 @@ +;;; dump-interface.scm -- interface file writer/loader +;;; +;;; author : John & Sandra +;;; date : 8 Jul 1992 +;;; +;;; This writes binary interface files. A binary interface file is just +;;; a lisp (mumble) source file which directly builds the ast structure +;;; created by a compilation. These files could be stored in either +;;; source or binary (compiled lisp) form. + +;;; An interface may reference entities defined in other interfaces. +;;; To ensure consistancy between when an interface is written and +;;; when it is read back in, a stamp is assigned to all interface files +;;; which serves as a unique id. The stamps of all imported units are +;;; saved and examined at load time. + + + +;;;================================================================== +;;; Interface to compilation system +;;;================================================================== + + +;;; For compiled code, don't actually write out all the source code. +;;; Use a magic macro to memoize the form to be compiled. + +(define *form-to-compile* '#f) +(define *magic-file-to-compile* "$HASKELL/bin/magic.scm") + + +;;; The output from compiling the prelude can completely overwhelm +;;; the Lisp compiler. If this variable is a number, it specifies +;;; a "reasonable" number of top-level forms which can be compiled +;;; and write-compiled-code-file will try to break up the input +;;; code automagically. + +(define *magic-chunk-size* '#f) + + +;;; This is called to write both the code file and the interface file. + +(define (write-compiled-code-file filename code code-quality chunk-size) + (let ((phase-start-time (get-run-time)) + (forms (flatten-forms code))) + (dynamic-let ((*magic-chunk-size* + (or chunk-size (dynamic *magic-chunk-size*))) + (*code-quality* + (or code-quality (dynamic *code-quality*)))) + (if (or (not (dynamic *magic-chunk-size*)) + (<= (the fixnum (length forms)) + (the fixnum (dynamic *magic-chunk-size*)))) + (write-compiled-code-file-aux filename `(begin ,@forms)) + (with-compilation-unit () + (write-compiled-code-file-aux + filename + `(begin + ,@(map (lambda (f) `(load ,f)) + (write-compiled-code-file-split filename forms))) + )))) + (when (memq 'phase-time *printers*) + (let* ((current-time (get-run-time)) + (elapsed-time (- current-time phase-start-time))) + (format '#t "Lisp compilation complete: ~A seconds~%" elapsed-time))) + )) + +(define (write-compiled-code-file-split filename forms) + (let ((place (filename-place filename)) + (name (filename-name filename)) + (type (filename-type filename)) + (result '())) + (do ((i 0 (1+ i))) + ((null? forms)) + (multiple-value-bind (head tail) + (split-list forms (dynamic *magic-chunk-size*)) + (let ((fname + (assemble-filename + place (format '#f "~a-part~a" name i) type))) + (push fname result) + (write-compiled-code-file-aux fname `(begin ,@head)) + (setf forms tail)))) + (nreverse result))) + +(define (flatten-forms code) + (if (and (pair? code) (eq? (car code) 'begin)) + (nreverse (flatten-forms-aux (cdr code) '())) + (list code))) + +(define (flatten-forms-aux forms result) + (dolist (f forms) + (if (and (pair? f) (eq? (car f) 'begin)) + (setf result (flatten-forms-aux (cdr f) result)) + (push f result))) + result) + + +(define (write-compiled-code-file-aux filename code) + (dynamic-let ((*form-to-compile* code)) + (compile-file (dynamic *magic-file-to-compile*) filename))) + +(define-syntax (magic-form-to-compile) + (dynamic *form-to-compile*)) + + +;;; Writing source code is good for debugging purposes, but slow. +;;; The *print-circle* and *print-shared* flags have to be set because +;;; the code printed out may contain gensyms, and this will ensure +;;; that the code can be read in again. + +(define (write-interpreted-code-file filename code hairy?) + (dynamic-let ((*print-circle* '#t) + (*print-shared* '#t)) + (call-with-output-file + filename + (lambda (port) + (if hairy? + (pprint-flatten code port) + (print-flatten code port)))))) + + +;;; This attempts to read a compiled interface for a unit. This is +;;; done whenever the unit file is newer than the source file. If +;;; imported units have changed, the load will fail and recompilation +;;; will be attempted. +;;; The caller is responsible for making sure that the interface file exists +;;; and for making sure that the interface file is up-to-date with +;;; respect to imported modules and that all the imported modules are +;;; known. + +;;; These variables are assigned by the code in the dump file. + +(define *modules-loaded* '()) +(define *modules-imported* '()) +(define *defs-referenced* '()) +(define *saved-cse-values* '()) +(define *writer-version* '()) + +(define (read-binary-interface unit) + (dynamic-let ((*modules-loaded* '()) + (*modules-imported* '()) + (*defs-referenced* '()) + (*saved-cse-values* '()) + (*writer-version* '())) + (let ((file-date + (load-more-recent-file (ucache-cifile unit) (ucache-sifile unit)))) + (cond ((string=? *writer-version* *haskell-compiler-version*) + (setf (ucache-idate unit) file-date) + (setf (ucache-modules unit) (vector->list *modules-loaded*)) + (setf (ucache-ifile-loaded unit) '#t) + '#t) + (else + (signal-incompatible-interface-file (ucache-cifile unit)) + '#f))))) + +(define (signal-incompatible-interface-file filename) + (fatal-error 'incompatible-interface-file + "File ~A~%~ + was written by a different version of the Haskell system.~%~ + You must remove it and recompile." + filename)) + + +(define (load-more-recent-file cfile sfile) + (cond ((file-exists? cfile) + (if (or (not (file-exists? sfile)) + (> (file-write-date cfile) + (file-write-date sfile))) + (load-compiled-interface-file cfile) + (load-interpreted-interface-file sfile))) + ((file-exists? sfile) + (load-interpreted-interface-file sfile)) + (else + (signal-file-not-found cfile)))) + +(define (load-interpreted-interface-file file) + (load file) + (file-write-date file)) + +(define (load-compiled-interface-file file) + (load file) + (file-write-date file)) + + +;;;================================================================== +;;; Dump code generator +;;;================================================================== + +;;; Globals + +(define *dump-defs* '()) +(define *dump-slot-init-code* '()) +(define *dump-def-counter* 0) +(define *dump-def-code-table* (make-table)) +(define *cse-objects* '()) +(define *cse-value-num* 0) +(define *cse-object-num* '()) +(define *gtype-class-index* '()) +(define *context-class-index* '()) +(define *gtype-tycon-index* '()) +(define *gtype-list-index* '()) +(define *gtype-index* '()) +(define *number-vars-dumped* 0) + + +(define-syntax (def-dump-code def) + `(table-entry *dump-def-code-table* ,def)) + +;;; This saves slot initialization code. + +(define (add-dump-init code) + (push code *dump-slot-init-code*)) + + +;;; Here is the top-level call. + +(define (create-dump-code unit modules load-prelude?) + (dynamic-let ((*unit* (module-unit (car modules))) + (*dump-defs* '()) + (*dump-slot-init-code* '()) + (*dump-def-counter* 0) + (*dump-def-code-table* (make-table)) + (*cse-objects* '()) + (*cse-object-num* *num-saved-gtyvars*) + (*gtype-class-index* '()) + (*context-class-index* '()) + (*gtype-tycon-index* '()) + (*gtype-list-index* '()) + (*gtype-index* '()) + (*number-vars-dumped* 0) + (*number-types-dumped* 0) + (*number-classes-dumped* 0)) + (let ((res (create-dump-code-aux unit modules load-prelude?))) + (when (memq 'dumper (dynamic *printers*)) + (pprint* res)) + (when (memq 'dump-stat (dynamic *printers*)) + (format '#t + "~&Dumped ~A definitions, ~A type objects, and ~A classes.~%" + *number-vars-dumped* *number-types-dumped* + *number-classes-dumped*) + (format '#t "Used ~A definitions and ~A type cells.~%" + *dump-def-counter* (length *cse-objects*))) + res))) + +;;; This assumes all modules are in the same compilation unit and that +;;; *unit* is set to that unit. +;;; imod-code establishes local bindings for all the imported modules. +;;; dmod-code establishes local bindings for all the modules defined in +;;; this compilation unit. + +(define (create-dump-code-aux unit modules load-prelude?) + (let* ((imod-counter 0) + (imod-alist '()) + (explicit-imports (collect-all-imported-modules unit)) + (all-imports (if load-prelude? + (append (collect-prelude-modules) explicit-imports) + explicit-imports)) + (imod-code (map (lambda (m) + (push (cons (module-name m) imod-counter) + imod-alist) + (incf imod-counter) + `(locate-module ',(module-name m))) + all-imports)) + (dmod-counter 0) + (dmod-alist '()) + (dmod-code (map (lambda (m) + (push (cons (module-name m) dmod-counter) + dmod-alist) + (incf dmod-counter) + `(make module + (unit ',(module-unit m)) + (name ',(module-name m)) + (type ',(module-type m)))) + modules))) + ;; This actually does most of the work. It dumps the module asts by + ;; placing inits for each slot into *dump-slot-init-code*. A list of + ;; definitions referenced is maintained in *dump-defs*. + (dolist (m modules) + (dump-module m (cdr (assq (module-name m) dmod-alist)))) + ;; This creates the final code + `(begin + (setf *writer-version* ',*haskell-compiler-version*) + (setf *modules-imported* (vector ,@imod-code)) + (setf *modules-loaded* (vector ,@dmod-code)) + ;; This sets the elements individually instead of using the vector + ;; function, because the vector may be longer than + ;; call-arguments-limit. + (setf *defs-referenced* + (make-vector ,(dynamic *dump-def-counter*))) + ,@(map (lambda (d) + `(setf ,(def-dump-code d) + ,(make-def-init-code d imod-alist dmod-alist))) + *dump-defs*) + ,@(cse-init-code) + ,@(dynamic *dump-slot-init-code*) + ) + )) + + +;;; Runtime support + +(define-syntax (lookup-imported-mod i) + `(vector-ref *modules-imported* ,i)) + +(define-syntax (lookup-defined-mod i) + `(vector-ref *modules-loaded* ,i)) + +(define (set-export-from-def-vector table key index) + (setf (table-entry table key) + (list (cons key (vector-ref *defs-referenced* index))))) + +(define (set-export-from-def table key def) + (setf (table-entry table key) + (list (cons key def)))) + +(define (set-symtab-from-def-vector table key index) + (setf (table-entry table key) + (vector-ref *defs-referenced* index))) + +(define (init-variable-slots var exported? toplevel? type simple? strict?) + (setf (def-exported? var) exported?) + (setf (var-toplevel? var) toplevel?) + (setf (var-type var) type) + (setf (var-simple? var) simple?) + (setf (var-strict? var) strict?) + var) + +(define (init-function-slots var exported? toplevel? type simple? strict? + arity strictness opt-entry) + (setf (def-exported? var) exported?) + (setf (var-toplevel? var) toplevel?) + (setf (var-type var) type) + (setf (var-simple? var) simple?) + (setf (var-strict? var) strict?) + (setf (var-arity var) arity) + (setf (var-strictness var) strictness) + (setf (var-optimized-entry var) opt-entry) + var) + +(define (init-method-var-slots var class default method-signature) + (setf (method-var-class var) class) + (setf (method-var-default var) default) + (setf (method-var-method-signature var) method-signature) + var) + +(define (init-constructor-slots + con arity types signature tag alg fixity infix?) + (setf (con-arity con) arity) + (setf (con-types con) types) + (setf (con-signature con) signature) + (setf (con-tag con) tag) + (setf (con-alg con) alg) + (setf (con-fixity con) fixity) + (setf (con-infix? con) infix?) + (dotimes (i arity) + (push '#f (con-slot-strict? con))) + con) + +(define (make-new-instance algdata tyvars class context gcontext dictionary m) + (make instance + (algdata algdata) + (tyvars tyvars) + (class class) + (context context) + (gcontext gcontext) + (dictionary dictionary) + (methods m) + (ok? '#t))) + + +;;; This computes the transitive closure of all modules available to +;;; a unit. + +(define (collect-all-imported-modules unit) + (collect-all-modules-1 (ucache-imported-units unit) '() '())) + +(define (collect-all-modules-1 units mods-so-far units-seen) + (cond ((null? units) + mods-so-far) + ((mem-string (car units) units-seen) + (collect-all-modules-1 (cdr units) mods-so-far units-seen)) + (else + (let ((u (lookup-compilation-unit (car units)))) + (collect-all-modules-1 + (append (ucache-imported-units u) (cdr units)) + (append (ucache-modules u) mods-so-far) + (cons (ucache-ufile u) units-seen)))) + )) + +(define (collect-prelude-modules) + (let ((prelude-unit (lookup-compilation-unit *prelude-unit-filename*))) + (append (ucache-modules prelude-unit) + (collect-all-imported-modules prelude-unit)))) + +(define (def->core-name-string def) + (if (con? def) + (remove-con-prefix (symbol->string (def-name def))) + (symbol->string (def-name def)))) + +;;; This code returns the load time definition for an object. When the +;;; object is a core symbol or in a different unit, previously +;;; created definitions are returned. Otherwise, a new definition is +;;; created. + +(define (make-def-init-code d imod-alist dmod-alist) + (declare (ignore dmod-alist)) + (cond ((def-core? d) + `(core-symbol ,(def->core-name-string d))) + ((eq? (def-unit d) *unit*) + `(create-definition/inner + ',(def-module d) + ',(def-name d) + ',(cond ((method-var? d) 'method-var) + ((var? d) 'var) + ((con? d) 'con) + ((synonym? d) 'synonym) + ((algdata? d) 'algdata) + ((class? d) 'class)))) + ((is-tuple-constructor? d) + `(tuple-constructor ,(tuple-constructor-arity d))) + ((is-tuple-tycon? d) + `(tuple-tycon ,(tuple-constructor-arity (car (algdata-constrs d))))) + (else + (let ((m (assq (def-module d) imod-alist))) + ;; This is a bogus error message. The problem is that nothing + ;; so far ensures units are closed under import/export: some + ;; modules may be referenced that are accidentally in the symbol + ;; table. The unif file for the current module needs to be + ;; updated when this happens. + (when (eq? m '#f) + (fatal-error 'symbol-not-in-unit + "Reference to symbol ~A in module ~A: not in compilation unit.~%" + (def-name d) (def-module d))) + `(table-entry + (module-symbol-table + (lookup-imported-mod ,(tuple-2-2 m))) + ',(def-name d)))) + )) + + +;;; Once a module has been compiled, most of its slots are useless. +;;; All we really need to save are the identifying information, +;;; symbol table, and export table. +;;; Instances also need to be dumped here instead of with class objects; +;;; this is because links can go across compilation unit boundaries. +;;; They are fixed up when pulling units out of the cache. +;;; The identifying info is stored when the module variable is bound. + + +(define (dump-module module index) + (let ((mod-exp `(lookup-defined-mod ,index)) + (save-all-symbols (or (eq? (module-type module) 'standard) + (eq? (module-name module) '|Prelude|)))) + ;; Dump symbol table entries only for defs for which this is + ;; the "home" module. (In other words, ignore imported defs.) + ;; The purpose of this is to allow references from other + ;; interface files to be resolved; see make-def-init-code. + ;; Jcp: we need to save the complete symbol table for incremental + ;; compilation to work. + (let ((code '())) + (table-for-each + (lambda (key val) + (when (or save-all-symbols + (eq? (def-module val) (module-name module))) + (let ((def (dump-object val))) + (push + (if (and (pair? def) + (eq? (car def) 'vector-ref) + (eq? (cadr def) '*defs-referenced*)) + `(set-symtab-from-def-vector table ',key ,(caddr def)) + `(setf (table-entry table ',key) ,def)) + code)))) + (module-symbol-table module)) + (add-dump-init `(setf (module-symbol-table ,mod-exp) + (let ((table (make-table))) ,@code table)))) + ;; dump the fixity table - needed by the incremental compiler + (when save-all-symbols + (let ((code '())) + (table-for-each + (lambda (key val) + (push `(setf (table-entry table ',key) + (make-fixity ',(fixity-associativity val) + ',(fixity-precedence val))) + code)) + (module-fixity-table module)) + (add-dump-init `(setf (module-fixity-table ,mod-exp) + (let ((table (make-table))) ,@code table))))) + ;; Dump all export table entries. This is used by the import/export + ;; phase to resolve references. + (let ((code '())) + (table-for-each + (lambda (key val) + ;; val is an a-list of (sym . def) pairs. + ;; Look for shortcut to reduce size of generated code. + (push + (if (and (null? (cdr val)) + (eq? (car (car val)) key)) + (let ((def (dump-object (cdr (car val))))) + (if (and (pair? def) + (eq? (car def) 'vector-ref) + (eq? (cadr def) '*defs-referenced*)) + `(set-export-from-def-vector table ',key ,(caddr def)) + `(set-export-from-def table ',key ,def))) + `(setf (table-entry table ',key) ,(dump-object val))) + code)) + (module-export-table module)) + (add-dump-init `(setf (module-export-table ,mod-exp) + (let ((table (make-table))) ,@code table)))) + ;; Dump the instances. + (add-dump-init `(setf (module-instance-defs ,mod-exp) + ,(dump-object (module-instance-defs module)))) + (add-dump-init `(setf (module-default ,mod-exp) + ,(dump-object (module-default module)))) + (add-dump-init `(setf (module-uses-standard-prelude? ,mod-exp) + ,(dump-object + (module-uses-standard-prelude? module)))) + )) + +(define (make-fixity a p) + (make fixity (associativity a) (precedence p))) + + +;;;================================================================== +;;; Dump structure traversal +;;;================================================================== + +;;; This is the general object dumper. It recognizes the basic Lisp +;;; objects and dumps them. Given an object, this generates lisp code +;;; to recreate the object at load time. + +(define (dump-object x) + (cond ((struct? x) + (dump x)) + ((or (symbol? x) (null? x)) + ;; Symbols and lists must be quoted. + `',x) + ((or (number? x) + (eq? x '#t) + (eq? x '#f) + (string? x) ; This makes dumped strings immutable. + (char? x)) + ;; These objects are self-evaluating. + x) + ((list? x) + ;; True lists + `(list ,@(map (function dump-object) x))) + ((pair? x) + `(cons ,(dump-object (car x)) + ,(dump-object (cdr x)))) + ((vector? x) + `(vector ,@(map (function dump-object) (vector->list x)))) + ((table? x) + `(list->table ,@(dump-object (table->list x)))) + (else + (error "Don't know how to dump ~A." x)))) + + +;;; *** Should install the walker in the type descriptor. + +(define-walker dump) + +(define (dump x) + (call-walker dump x)) + + + +;;;================================================================== +;;; Dumpers for defs +;;;================================================================== + + +;;; All walkers for def structures should call this macro. The body +;;; is invoked only if the def belongs to the current compilation unit +;;; and hasn't already been traversed. Within the body, the +;;; variable "v" is bound to a form that will evaluate to the +;;; corresponding def structure at run time. This is also +;;; the return value from the macro. + +(define-local-syntax (with-new-def (v d stat-var) . body) + (let ((temp (gensym)) + (expvar (gensym))) + `(let ((,temp ,d) + (,expvar '#f)) + (if (not (def-dump-code ,temp)) + (begin + (cond ((not (def-core? ,temp)) + (setf ,expvar + (list 'vector-ref + '*defs-referenced* + (dynamic *dump-def-counter*))) + (incf (dynamic *dump-def-counter*)) + (push ,temp *dump-defs*)) + (else + (setf ,expvar + (make-core-symbol-name + (def->core-name-string ,temp))))) + (setf (def-dump-code ,temp) ,expvar) + (when (eq? (def-unit ,temp) *unit*) + (incf (dynamic ,stat-var)) + (let ((,v ,expvar)) + ,@body)) + ,expvar) + (def-dump-code ,temp))))) + + +;;; This macro is used to save the value of a structure slot in the +;;; initforms of the dump. + +(define-local-syntax (dump-def-slots obj-var type dexp slots) + `(add-dump-init + (list 'update-slots ',type ,dexp + ,@(map (lambda (s) + `(list ',s + (dump-object (struct-slot ',type ',s ,obj-var)))) + slots))) + ) + + + +(define-walker-method dump var (var) + (dump-var/n var)) + +(define (dump-var/n var) + (with-new-def (dexp var *number-vars-dumped*) + (do-dump-var dexp var '#f))) + +(define (do-dump-var dexp var method-var?) + (let ((code '()) + (exported? (def-exported? var)) + (toplevel? (var-toplevel? var)) + (type (var-type var)) + (simple? (var-simple? var)) + (strict? (var-strict? var)) + (arity (var-arity var)) + (strictness (var-strictness var)) + (opt-entry (var-optimized-entry var)) + (complexity (var-complexity var)) + (fixity (var-fixity var)) + (value (var-value var)) + (inline-value (var-inline-value var)) + (sel? (var-selector-fn? var))) + ;; Some slots are useless for vars that don't name functions. + (if (eqv? arity 0) + (push `(init-variable-slots var + ',exported? + ',toplevel? + ,(dump-object type) + ',simple? + ',strict?) + code) + (push `(init-function-slots var + ',exported? + ',toplevel? + ,(dump-object type) + ',simple? + ',strict? + ',arity + ,(dump-strictness strictness) + ',opt-entry) + code)) + ;; These slots rarely need to be tweaked from the default. + (when sel? + (push `(setf (var-selector-fn? var) '#t) code)) + (when complexity + (push `(setf (var-complexity var) ,complexity) code)) + (when fixity + (push `(setf (var-fixity var) ,(dump-object fixity)) code)) + ;; Save values of simple variables to permit inlining. + ;; Save values of structured constants to permit folding of flic-sel + ;; operations -- this is necessary to optimize dictionary lookups. + (when (or simple? sel? + (and value + (is-type? 'flic-app value) + (structured-constant-app? + (flic-app-fn value) (flic-app-args value)))) + (push `(setf (var-value var) ,(dump-flic-top value)) code)) + (when inline-value + (push `(setf (var-inline-value var) ,(dump-flic-top inline-value)) code)) + ;; Save extra stuff for method vars + (when method-var? + (push `(init-method-var-slots var + ,(dump-object (method-var-class var)) + ,(dump-object (method-var-default var)) + ,(dump-object (method-var-method-signature var))) + code)) + ;; Push the whole mess onto the init code. + (add-dump-init `(let ((var ,dexp)) ,@(nreverse code))))) + + +(define-walker-method dump method-var (var) + (dump-method-var/n var)) + +(define (dump-method-var/n var) + (with-new-def (dexp var *number-vars-dumped*) + (do-dump-var dexp var '#t))) + +(define-walker-method dump con (con) + (dump-con/n con)) + +(define (dump-con/n con) + (with-new-def (dexp con *number-types-dumped*) + (add-dump-init + `(let ((con (init-constructor-slots + ,dexp + ,(con-arity con) + ,(dump-object (con-types con)) + ,(dump-object (con-signature con)) + ,(con-tag con) + ,(dump-object (con-alg con)) + ,(dump-object (con-fixity con)) + ',(con-infix? con)))) + ,@(if (memq '#t (con-slot-strict? con)) + `((setf (con-slot-strict? con) ',(con-slot-strict? con))) + '()) + ,@(if (eq? (con-lisp-fns con) '()) + '() + `((setf (con-lisp-fns con) ',(con-lisp-fns con)))) + con)))) + +;;; *** Could define similar init functions for other defs instead +;;; *** of setting slots inline, but I'm lazy and they don't show up +;;; *** nearly as often as the others. + +(define-walker-method dump algdata (alg) + (dump-algdata/n alg)) + +(define (dump-algdata/n alg) + (with-new-def (dexp alg *number-types-dumped*) + (dump-def-slots alg algdata dexp + (arity n-constr constrs context tyvars signature + enum? tuple? real-tuple? implemented-by-lisp?)))) + +(define-walker-method dump synonym (syn) + (dump-synonym/n syn)) + +(define (dump-synonym/n syn) + (with-new-def (dexp syn *number-types-dumped*) + (dump-def-slots syn synonym dexp (arity args body)))) + +(define-walker-method dump class (class) + (dump-class/n class)) + +(define (dump-class/n class) + (with-new-def (dexp class *number-classes-dumped*) + (dump-def-slots class class dexp + (super super* tyvar method-vars selectors kind + n-methods dict-size)))) + + +;;;================================================================== +;;; Dumpers for non-def AST structs +;;;================================================================== + +;;; This section contains dumpers to handle type-related structs that +;;; are referenced by the various def guys. + + +(define-walker-method dump instance (o) + (if (not (instance-ok? o)) + (error "Attempt to dump instance that's not ok!")) + `(make-new-instance + ,(dump-object (instance-algdata o)) + ,(dump-object (instance-tyvars o)) + ,(dump-object (instance-class o)) + ,(dump-object (instance-context o)) + ,(dump-object (instance-gcontext o)) + ,(dump-object (instance-dictionary o)) + ,(dump-object (instance-methods o)))) + + + +(define-walker-method dump gtype (o) + (dump-gtype/cse o)) + +(define-walker-method dump fixity (o) + `(**fixity ',(fixity-associativity o) ',(fixity-precedence o))) + +(define-walker-method dump tyvar (o) + `(**tyvar ',(tyvar-name o))) + +(define-walker-method dump class-ref (o) + `(**class/def ,(dump-object (class-ref-class o)))) + +(define-walker-method dump context (o) + `(**context ,(dump-object (context-class o)) + ,(dump-object (context-tyvar o)))) + +(define-walker-method dump tycon (o) + `(**tycon/def ,(dump-object (tycon-def o)) + ,(dump-object (tycon-args o)))) + +(define-walker-method dump default-decl (o) + `(make default-decl (types ,(dump-object (default-decl-types o))))) + +(define-walker-method dump signature (o) + `(make signature (context ,(dump-object (signature-context o))) + (type ,(dump-object (signature-type o))))) + +;;; All ntyvars should be instantiated at this point + +; (define-walker-method dump ntyvar (o) +; (dump-object (prune o))) diff --git a/csys/dump-macros.scm b/csys/dump-macros.scm new file mode 100644 index 0000000..404adf8 --- /dev/null +++ b/csys/dump-macros.scm @@ -0,0 +1,37 @@ +(define-syntax (set-strictness-vars) + (let ((res '())) + (dotimes (i *pre-defined-strictness-vars*) + (push `(setf (dynamic ,(vector-ref *pre-defined-strictness-names* i)) + (vector-ref *pre-defined-strictness-table* ',i)) + res)) + `(begin ,@res))) + +(define-syntax (setup-gtyvar-vars) + (let ((res '())) + (dotimes (i *num-saved-gtyvars*) + (push `(setf (dynamic ,(vector-ref *saved-gtyvar-varnames* i)) + (vector-ref *saved-gtyvars* ',i)) + res)) + `(begin ,@res))) + +(define-syntax (assq/insert x table) + `(let ((res (assq ,x ,table))) + (if (eqv? res '#f) + (begin + (let ((new-pair (cons ,x '#f))) + (push new-pair ,table) + new-pair)) + res))) + +(define-syntax (assq/insert-l x table) + `(let ((res (assq ,x ,table))) + (if (eqv? res '#f) + (begin + (let ((new-pair (cons ,x '()))) + (push new-pair ,table) + new-pair)) + res))) + + + + diff --git a/csys/dump-params.scm b/csys/dump-params.scm new file mode 100644 index 0000000..cabbfd0 --- /dev/null +++ b/csys/dump-params.scm @@ -0,0 +1,18 @@ +(define *num-saved-gtyvars* 19) +(define *pre-defined-strictness-size* 7) ; length of max strictness list +(define *pre-defined-strictness-table* '()) +(define *pre-defined-strictness-vars* 32) ; number of global vars +(define *pre-defined-strictness-names* + (make-vector *pre-defined-strictness-vars*)) + +(dotimes (i *pre-defined-strictness-vars*) + (setf (vector-ref *pre-defined-strictness-names* i) + (string->symbol (format '#f "SAVED-STRICTNESS-~A" i)))) + +(define *saved-gtyvars* '()) +(define *saved-gtyvar-varnames* (make-vector *num-saved-gtyvars*)) +(dotimes (i *num-saved-gtyvars*) + (setf (vector-ref *saved-gtyvar-varnames* i) + (string->symbol (format '#f "SAVED-GTYVAR-NAME~A" i)))) + + diff --git a/csys/magic.scm b/csys/magic.scm new file mode 100644 index 0000000..999e8b0 --- /dev/null +++ b/csys/magic.scm @@ -0,0 +1,10 @@ +;;; magic.scm -- magic support file for dumping compiled code files. +;;; +;;; author : Sandra Loosemore +;;; date : 8 Jul 1992 +;;; +;;; This file is used to dump compiled code files. The macro call below +;;; expands into the code being dumped. See dump-interface.scm for more +;;; details. + +(magic-form-to-compile) |