path: root/csys/dump-interface.scm

;;; 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)))