From ff60050df86be5984256d7fb0de08a46922792c8 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 9 Feb 1990 21:06:34 +0000 Subject: [PATCH] Dump code objects in the new format. --- compiler/dump.lisp | 109 ++++++++++++++++++++++++++------------------- 1 file changed, 62 insertions(+), 47 deletions(-) diff --git a/compiler/dump.lisp b/compiler/dump.lisp index f55fbd2c8..8829fe0af 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.2 1990/02/09 18:37:21 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.3 1990/02/09 21:06:34 wlott Exp $ ;;; ;;; This file contains stuff that knows about dumping FASL files. ;;; @@ -15,10 +15,6 @@ (proclaim '(special compiler-version)) -(import '(system:%primitive system:%array-data-slot - system:%array-displacement-slot - system:%g-vector-structure-subtype)) - ;;;; Fasl dumper state: @@ -402,18 +398,29 @@ (defun dump-fixups (code-handle fixups file) (declare (type unsigned-byte code-handle) (list fixups) (type fasl-file file)) - (dump-push code-handle file) - (dolist (fixup fixups) - (let ((offset (second fixup)) - (value (third fixup))) - (ecase (first fixup) - (:miscop - (assert (symbolp value)) - (dump-object value file) - (dump-fop 'lisp::fop-user-miscop-fixup file) - (quick-dump-number offset 4 file))))) - - (dump-fop 'lisp::fop-pop-for-effect file) + (when fixups + (dump-push code-handle file) + (dolist (fixup fixups) + (let ((offset (second fixup)) + (value (third fixup))) + (ecase (first fixup) + #+nil + (:miscop + (assert (symbolp value)) + (dump-object value file) + (dump-fop 'lisp::fop-user-miscop-fixup file) + (quick-dump-number offset 4 file)) + (:foreign + (assert (symbolp value)) + (dump-fop 'lisp::fop-foreign-fixup file) + (quick-dump-number offset 4 file) + (let* ((str (symbol-name value)) + (len (length str))) + (assert (< len 256)) + (quick-dump-number len 1 file) + (dotimes (i len) + (dump-byte (char-code (schar str i))))))))) + (dump-fop 'lisp::fop-pop-for-effect file)) (undefined-value)) @@ -430,23 +437,18 @@ (declare (type entry-info entry) (type unsigned-byte code-handle) (type fasl-file file)) (let ((name (entry-info-name entry))) - (dump-push code-handle file) - (dump-object (if (entry-info-closure-p entry) - system:%function-closure-entry-subtype - system:%function-entry-subtype) - file) - - (dump-object name file) - (dump-fop 'lisp::fop-misc-trap file) - (dump-object (+ (label-location (entry-info-offset entry)) - clc::i-vector-header-size) - file) - (dump-fop 'lisp::fop-misc-trap file) - (dump-object (entry-info-arguments entry) file) - (dump-object (entry-info-type entry) file) - (dump-fop 'lisp::fop-function-entry file) - (dump-byte 6 file) - + (cond ((entry-info-closure-p entry) + ;; ### Need to fix this. + (compiler-error "Cannot dump closures. Oh no.") + (dump-fop 'lisp::fop-misc-trap file)) + (t + (dump-push code-handle file) + (dump-object name file) + (dump-object (entry-info-arguments entry) file) + (dump-object (entry-info-type entry) file) + (dump-fop 'lisp::fop-function-entry file) + (quick-dump-number (label-location (entry-info-offset entry)) + 4 file))) (let ((handle (dump-pop file))) (when (and name (symbolp name)) (dump-object name file) @@ -454,7 +456,6 @@ (dump-fop 'lisp::fop-fset file)) handle))) - ;;; Alter-Code-Object -- Internal ;;; ;;; Alter the code object referenced by Code-Handle at the specified Offset, @@ -562,6 +563,8 @@ (unless (equal-check-table x file) (dump-list x file) (equal-save-object x file))) + (structure + (dump-structure x file)) (vector (cond ((stringp x) (unless (equal-check-table x file) @@ -936,18 +939,7 @@ ;;;; Array dumping: -;;; Named G-vectors get their subtype field set at load time. - -(defun dump-vector (obj file) - (cond ((and (simple-vector-p obj) - (= (%primitive get-vector-subtype obj) - %g-vector-structure-subtype)) - (normal-dump-vector obj file) - (dump-fop 'lisp::fop-structure file)) - (t - (normal-dump-vector obj file)))) - -(defun normal-dump-vector (v file) +(defun dump-vector (v file) (note-potential-circularity v file) (do ((index 0 (1+ index)) (length (length v)) @@ -978,6 +970,12 @@ ;;; a displaced array looks like, we can fix this. ;;; (defun dump-array (array file) + (declare (ignore array file)) + (compiler-error "Can't dump arrays, bozo.") + (dump-fop 'lisp::fop-misc-trap file)) + +#| +( (unless (zerop (%primitive header-ref array %array-displacement-slot)) (compiler-error "Attempt to dump an array with a displacement, you lose big.")) @@ -988,11 +986,18 @@ (dump-fop 'lisp::fop-array file) (quick-dump-number rank 4 file))) +|# + ;;; Dump-I-Vector -- Internal ;;; ;;; Dump an I-Vector using the Guy Steele memorial fasl-operation. ;;; (defun dump-i-vector (vec file) + (declare (ignore vec file)) + (compiler-error "Can't dump i-vectors, bozo.") + (dump-fop 'lisp::fop-misc-trap file)) + +#| (let* ((len (length vec)) (ac (%primitive get-vector-access-code (if #-new-compiler (%primitive complex-array-p vec) @@ -1028,6 +1033,8 @@ (dotimes (i len) (declare (fixnum i)) (quick-dump-number (aref vec i) count file))))) +|# + ;;; Dump a character. @@ -1041,3 +1048,11 @@ (dump-byte (char-code ch) file) (dump-byte (char-bits ch) file) (dump-byte (char-font ch) file)))) + + +;;; Dump a structure. + +(defun dump-structure (obj file) + (normal-dump-vector obj file) + (dump-fop 'lisp::fop-structure file)) + -- GitLab