diff --git a/compiler/dump.lisp b/compiler/dump.lisp index 4ad2f33fc98baca70570726042334a324240ec3e..4f2c17ab0fcf51e13f09bd9614ce18e256e2a0de 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.lisp @@ -7,11 +7,11 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.33 1991/03/20 03:02:05 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.34 1991/11/24 23:00:39 wlott Exp $") ;;; ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.33 1991/03/20 03:02:05 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.34 1991/11/24 23:00:39 wlott Exp $ ;;; ;;; This file contains stuff that knows about dumping FASL files. ;;; @@ -225,7 +225,7 @@ (* n vm:byte-bits)) (setf (fasl-file-buffer-index file) n)))))) (undefined-value)) - + ;;; Dump-FOP -- Internal ;;; @@ -452,11 +452,8 @@ (t (patches (cons info i)) (dump-fop 'lisp::fop-misc-trap file))))) - #+nil - (:label - (dump-object (+ (label-position (cdr entry)) - clc::i-vector-header-size) - file)))) + (:load-time-value + (dump-push (cdr entry) file)))) (null (dump-fop 'lisp::fop-misc-trap file))))) @@ -677,26 +674,7 @@ (dump-structure x file) (eq-save-object x file)) (array - (cond - ((array-header-p x) - (dump-array x file) - (eq-save-object x file)) - (t - (typecase x - (simple-base-string - (unless (equal-check-table x file) - (dump-simple-string x file) - (equal-save-object x file))) - (simple-vector - (dump-simple-vector x file) - (eq-save-object x file)) - ((or (simple-array single-float (*)) - (simple-array double-float (*))) - (dump-simple-vector (coerce x 'simple-vector) file) - (eq-save-object x file)) - (t - (dump-i-vector x file) - (eq-save-object x file)))))) + (dump-array x file)) (number (unless (equal-check-table x file) (etypecase x @@ -726,12 +704,9 @@ ;;; (defun sub-dump-object (x file) (cond ((listp x) - (cond ((null x) (dump-fop 'lisp::fop-empty-list file)) - #| - ((eq (car x) '%eval-at-load-time) (load-time-eval x)) - |# - (t - (dump-non-immediate-object x file)))) + (if x + (dump-non-immediate-object x file) + (dump-fop 'lisp::fop-empty-list file))) ((symbolp x) (if (eq x t) (dump-fop 'lisp::fop-truth file) @@ -794,20 +769,42 @@ (sub-dump-object x file))) -#| -;;; Load-Time-Eval -- Internal -;;; -;;; This guy deals with the magical %Eval-At-Load-Time marker that -;;; #, turns into when the *compiler-is-reading* and a fasl file is being -;;; written. -;;; -(defun load-time-eval (x file) - (when *compile-to-lisp* - (error "#,~S in a bad place." (third x))) - (assemble-one-lambda (cadr x)) - (dump-fop 'lisp::fop-funcall file) - (dump-byte 0 file)) -|# +;;;; Load-time-value and make-load-form support. + +;;; FASL-DUMP-LOAD-TIME-VALUE-LAMBDA -- interface. +;;; +;;; Emit a funcall of the function and return the handle for the result. +;;; +(defun fasl-dump-load-time-value-lambda (fun file) + (declare (type clambda fun) (type fasl-file file)) + (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) + (assert handle) + (dump-push handle file) + (dump-fop 'lisp::fop-funcall file) + (dump-byte 0 file)) + (dump-pop file)) + +;;; FASL-CONSTANT-ALREADY-DUMPED -- interface. +;;; +;;; Return T iff CONSTANT has not already been dumped. It's been dumped +;;; if it's in the EQ table. +;;; +(defun fasl-constant-already-dumped (constant file) + (if (gethash constant (fasl-file-eq-table file)) t nil)) + +;;; FASL-NOTE-HANDLE-FOR-CONSTANT -- interface. +;;; +;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been +;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA. +;;; +(defun fasl-note-handle-for-constant (constant handle file) + (let ((table (fasl-file-eq-table file))) + (when (gethash constant table) + (error "~S already dumped?" constant)) + (setf (gethash constant table) handle)) + (undefined-value)) + + ;;;; Number Dumping: @@ -1029,6 +1026,41 @@ ;;;; Array dumping: +;;; DUMP-ARRAY -- Internal. +;;; +;;; Dump the array thing. +;;; +(defun dump-array (x file) + (if (vectorp x) + (dump-vector x file) + (dump-multi-dim-array x file))) + +;;; DUMP-VECTOR -- Internal. +;;; +;;; Dump the vector object. If it's not simple, then actually dump a simple +;;; version of it. But we enter the original in the EQ or EQUAL tables. +;;; +(defun dump-vector (x file) + (let ((simple-version (if (array-header-p x) + (coerce x 'simple-array) + x))) + (typecase simple-version + (simple-base-string + (unless (equal-check-table x file) + (dump-simple-string simple-version file) + (equal-save-object x file))) + (simple-vector + (dump-simple-vector simple-version file) + (eq-save-object x file)) + ((simple-array single-float (*)) + (dump-single-float-vector simple-version file) + (eq-save-object x file)) + ((simple-array double-float (*)) + (dump-double-float-vector simple-version file) + (eq-save-object x file)) + (t + (dump-i-vector simple-version file) + (eq-save-object x file))))) ;;; DUMP-SIMPLE-VECTOR -- Internal ;;; @@ -1052,7 +1084,6 @@ (t (sub-dump-object obj file)))))) - ;;; DUMP-SIMPLE-STRING -- Internal ;;; ;;; Dump a SIMPLE-BASE-STRING. @@ -1064,29 +1095,6 @@ (dump-bytes s length file)) (undefined-value)) - -;;; Dump-Array -- Internal -;;; -;;; Dump a multi-dimensional array. Someday when we figure out what -;;; a displaced array looks like, we can fix this. -;;; -(defun dump-array (array file) - (unless #-new-compiler (zerop (%primitive header-ref - array %array-displacement-slot)) - #+new-compiler (not (lisp::%array-displaced-p array)) - (error "Attempt to dump an array with a displacement, you lose big.")) - (let ((rank (array-rank array))) - (dotimes (i rank) - (dump-integer (array-dimension array i) file)) - (sub-dump-object #-new-compiler - (%primitive header-ref array %array-data-slot) - #+new-compiler - (lisp::%array-data-vector array) - file) - (dump-fop 'lisp::fop-array file) - (dump-unsigned-32 rank file))) - - ;;; DUMP-I-VECTOR -- Internal ;;; ;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size @@ -1098,10 +1106,7 @@ ;;; (defun dump-i-vector (vec file &optional data-only) (declare (type (simple-array * (*)) vec)) - (let* ((ac #-new-compiler - (%primitive get-vector-access-code vec) - #+new-compiler - (etypecase vec + (let* ((ac (etypecase vec (simple-bit-vector 0) ((simple-array (unsigned-byte 2) (*)) 1) ((simple-array (unsigned-byte 4) (*)) 2) @@ -1112,72 +1117,119 @@ (size (ash 1 ac)) (bytes (ash (+ (the index (ash len ac)) 7) -3))) (declare (type index ac len size bytes)) - (unless data-only (dump-fop 'lisp::fop-int-vector file) (dump-unsigned-32 len file) (dump-byte size file)) - (cond ((or (eq (backend-byte-order *backend*) - (backend-byte-order *native-backend*)) - (= size 8)) - (dump-bytes vec bytes file)) - ((> size 8) - (ecase (backend-byte-order *backend*) - (:little-endian - (dotimes (i len) - (let ((int (aref vec i))) - (dump-var-signed int (ash size -3) file)))) - (:big-endian - (dotimes (i len) - (declare (type index i)) - (let ((int (aref vec i))) - (declare (type (unsigned-byte 32) int)) - (do ((shift (- 8 size) (+ shift 8))) - ((plusp shift)) - (declare (type fixnum shift)) - (dump-byte (logand (the (unsigned-byte 32) - (ash int shift)) - #xFF) - file))))))) - (t - (macrolet ((frob (initial step done) - `(let ((shift ,initial) - (byte 0)) - (declare (type fixnum shift byte)) - (dotimes (i len) - (let ((int (aref vec i))) - (declare (type (unsigned-byte 8) int)) - (setq byte - (logior byte - (the (unsigned-byte 8) - (ash int shift)))) - (,step shift size)) - (when ,done - (dump-byte byte file) - (setq shift ,initial byte 0))) - (unless (= shift ,initial) (dump-byte byte file))))) - (ecase (backend-byte-order *backend*) - (:little-endian - (frob 0 incf (= shift 8))) - (:big-endian - (let ((initial-shift (- 8 size))) - (frob initial-shift decf (minusp shift)))))))))) + (dump-data-maybe-byte-swapping vec bytes size file))) + +;;; DUMP-SINGLE-FLOAT-VECTOR -- internal. +;;; +(defun dump-single-float-vector (vec file) + (let ((length (length vec))) + (dump-fop 'lisp::fop-single-float-vector file) + (dump-unsigned-32 length file) + (dump-data-maybe-byte-swapping vec (* length vm:word-bytes) + vm:word-bytes file))) + +;;; DUMP-DOUBLE-FLOAT-VECTOR -- internal. +;;; +(defun dump-double-float-vector (vec file) + (let ((length (length vec))) + (dump-fop 'lisp::fop-double-float-vector file) + (dump-unsigned-32 length file) + (dump-data-maybe-byte-swapping vec (* length vm:word-bytes 2) + (* vm:word-bytes 2) file))) + +;;; DUMP-DATA-BITS-MAYBE-BYTE-SWAPPING -- internal. +;;; +;;; Dump BYTES of data from DATA-VECTOR (which much some unboxed vector) +;;; byte-swapping if necessary. +;;; +(defun dump-data-maybe-byte-swapping (data-vector bytes element-size file) + (declare (type (simple-array * (*)) data-vector) + (type unsigned-byte bytes) + (type (integer 1) element-size)) + (cond ((or (eq (backend-byte-order *backend*) + (backend-byte-order *native-backend*)) + (= element-size vm:byte-bits)) + (dump-bytes data-vector bytes file)) + ((>= element-size vm:word-bits) + (let ((words-per-element (/ element-size vm:word-bits)) + (result (make-array bytes :element-type '(unsigned-byte 8)))) + (declare (type (integer 1 #.most-positive-fixnum) + words-per-element)) + (dotimes (index (the integer (/ bytes words-per-element))) + (dotimes (offset words-per-element) + (let ((word (%raw-bits data-vector + (+ (* index words-per-element) + vm:vector-data-offset + (1- words-per-element) + (- offset))))) + (setf (%raw-bits result (+ (* index words-per-element) + vm:vector-data-offset + offset)) + (logior (ash (ldb (byte 8 0) word) 24) + (ash (ldb (byte 8 8) word) 16) + (ash (ldb (byte 8 16) word) 8) + (ldb (byte 8 24) word)))))) + (dump-bytes result bytes file))) + ((> element-size vm:byte-bits) + (let* ((bytes-per-element (/ element-size vm:byte-bits)) + (elements (/ bytes bytes-per-element)) + (result (make-array elements + :element-type + `(unsigned-byte ,element-size)))) + (declare (type (integer 1 #.most-positive-fixnum) + bytes-per-element) + (type unsigned-byte elements)) + (dotimes (index elements) + (let ((element (aref data-vector index)) + (new-element 0)) + (dotimes (i bytes-per-element) + (setf new-element + (logior (ash new-element vm:byte-bits) + (ldb (byte vm:byte-bits 0) element))) + (setf element (ash element (- vm:byte-bits)))) + (setf (aref result index) new-element))) + (dump-bytes result bytes file))) + (t + (let* ((elements-per-byte (/ vm:byte-bits element-size)) + (elements (* bytes elements-per-byte)) + (result (make-array elements + :element-type + `(unsigned-byte ,element-size)))) + (dotimes (index elements) + (multiple-value-bind (byte-index additional) + (truncate index elements-per-byte) + (setf (aref result index) + (aref data-vector + (+ byte-index + (- elements-per-byte additional 1)))))) + (dump-bytes result bytes file))))) + +;;; Dump-Multi-Dim-Array -- Internal +;;; +;;; Dump a multi-dimensional array. Note: any displacements are folded out. +;;; +(defun dump-multi-dim-array (array file) + (let ((rank (array-rank array))) + (dotimes (i rank) + (dump-integer (array-dimension array i) file)) + (lisp::with-array-data ((vector array) (start) (end)) + (if (and (= start 0) (= end (length vector))) + (sub-dump-object vector file) + (sub-dump-object (subseq vector start end) file))) + (dump-fop 'lisp::fop-array file) + (dump-unsigned-32 rank file) + (eq-save-object array file))) ;;; Dump a character. (defun dump-character (ch file) - (cond - (#+new-compiler t - #-new-compiler (string-char-p ch) - (dump-fop 'lisp::fop-short-character file) - (dump-byte (char-code ch) file)) - #-new-compiler - (t - (dump-fop 'lisp::fop-character file) - (dump-byte (char-code ch) file) - (dump-byte (char-bits ch) file) - (dump-byte (char-font ch) file)))) + (dump-fop 'lisp::fop-short-character file) + (dump-byte (char-code ch) file)) ;;; Dump a structure.