From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 csys/dump-interface.scm | 800 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 800 insertions(+)
 create mode 100644 csys/dump-interface.scm

(limited to 'csys/dump-interface.scm')

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)))
-- 
cgit v1.2.3