X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdump.lisp;h=3ec637703215521d38597087cc806e0fcf84c9d5;hb=f9d6d21a7f54638292214ceb9886edc03b99d545;hp=ba1aaa29e3e8e3f89be8ddd089f99d2de96b197e;hpb=aa2dc9529460ea0d9c99998dc87283fc1a43e808;p=sbcl.git

diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp
index ba1aaa2..3ec6377 100644
--- a/src/compiler/dump.lisp
+++ b/src/compiler/dump.lisp
@@ -28,7 +28,7 @@
 				      s))))
 	    (:copier nil))
   ;; the stream we dump to
-  (stream (required-argument) :type stream)
+  (stream (missing-arg) :type stream)
   ;; hashtables we use to keep track of dumped constants so that we
   ;; can get them from the table rather than dumping them again. The
   ;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
@@ -43,11 +43,11 @@
   ;; an alist (PACKAGE . OFFSET) of the table offsets for each package
   ;; we have currently located.
   (packages () :type list)
-  ;; a table mapping from the Entry-Info structures for dumped XEPs to
+  ;; a table mapping from the ENTRY-INFO structures for dumped XEPs to
   ;; the table offsets of the corresponding code pointers
   (entry-table (make-hash-table :test 'eq) :type hash-table)
   ;; a table holding back-patching info for forward references to XEPs.
-  ;; The key is the Entry-Info structure for the XEP, and the value is
+  ;; The key is the ENTRY-INFO structure for the XEP, and the value is
   ;; a list of conses (<code-handle> . <offset>), where <code-handle>
   ;; is the offset in the table of the code object needing to be
   ;; patched, and <offset> is the offset that must be patched.
@@ -72,11 +72,11 @@
 ;;; This structure holds information about a circularity.
 (defstruct (circularity (:copier nil))
   ;; the kind of modification to make to create circularity
-  (type (required-argument) :type (member :rplaca :rplacd :svset :struct-set))
+  (type (missing-arg) :type (member :rplaca :rplacd :svset :struct-set))
   ;; the object containing circularity
   object
   ;; index in object for circularity
-  (index (required-argument) :type index)
+  (index (missing-arg) :type index)
   ;; the object to be stored at INDEX in OBJECT. This is that the key
   ;; that we were using when we discovered the circularity.
   value
@@ -86,7 +86,7 @@
   enclosing-object)
 
 ;;; a list of the CIRCULARITY structures for all of the circularities
-;;; detected in the current top-level call to DUMP-OBJECT. Setting
+;;; detected in the current top level call to DUMP-OBJECT. Setting
 ;;; this lobotomizes circularity detection as well, since circular
 ;;; dumping uses the table.
 (defvar *circularities-detected*)
@@ -251,7 +251,7 @@
 ;;; the source code is given by the string WHERE. If BYTE-P is true,
 ;;; this file will contain no native code, and is thus largely
 ;;; implementation independent.
-(defun open-fasl-output (name where &optional byte-p)
+(defun open-fasl-output (name where)
   (declare (type pathname name))
   (let* ((stream (open name
 		       :direction :output
@@ -282,9 +282,7 @@
 
     ;; Finish the header by outputting fasl file implementation and
     ;; version in machine-readable form.
-    (let ((implementation (if byte-p
-			      (backend-byte-fasl-file-implementation)
-			      +backend-fasl-file-implementation+)))
+    (let ((implementation +backend-fasl-file-implementation+))
       (dump-unsigned-32 (length (symbol-name implementation)) res)
       (dotimes (i (length (symbol-name implementation)))
 	(dump-byte (char-code (aref (symbol-name implementation) i)) res)))
@@ -340,7 +338,7 @@
 	      ;;   take a little more care while dumping these.
 	      ;; So if better list coalescing is needed, start here.
 	      ;; -- WHN 2000-11-07
-              (if (circular-list-p x)
+              (if (cyclic-list-p x)
 		  (progn
 		    (dump-list x file)
 		    (eq-save-object x file))
@@ -382,7 +380,7 @@
 ;;;
 ;;; This is the function used for recursive calls to the fasl dumper.
 ;;; We don't worry about creating circularities here, since it is
-;;; assumed that there is a top-level call to DUMP-OBJECT.
+;;; assumed that there is a top level call to DUMP-OBJECT.
 (defun sub-dump-object (x file)
   (cond ((listp x)
 	 (if x
@@ -433,10 +431,7 @@
 ;;; We peek at the object type so that we only pay the circular
 ;;; detection overhead on types of objects that might be circular.
 (defun dump-object (x file)
-  (if (or (array-header-p x)
-	  (simple-vector-p x)
-	  (consp x)
-	  (typep x 'instance))
+  (if (compound-object-p x)
       (let ((*circularities-detected* ())
 	    (circ (fasl-output-circularity-table file)))
 	(clrhash circ)
@@ -544,8 +539,12 @@
        (declare (double-float im))
        (dump-unsigned-32 (double-float-low-bits im) file)
        (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)))
-    #!+(and long-float (not sb-xc))
+    #!+long-float
     ((complex long-float)
+     ;; (There's no easy way to mix #!+LONG-FLOAT and #-SB-XC-HOST
+     ;; conditionalization at read time, so we do this SB-XC-HOST
+     ;; conditional at runtime instead.)
+     #+sb-xc-host (error "can't dump COMPLEX-LONG-FLOAT in cross-compiler")
      (dump-fop 'fop-complex-long-float file)
      (dump-long-float (realpart x) file)
      (dump-long-float (imagpart x) file))
@@ -899,18 +898,9 @@
     ;; argument and the number of bytes actually written. I added this
     ;; assertion while trying to debug portable genesis. -- WHN 19990902
     (unless (= code-length nwritten)
-      (error "internal error, code-length=~D, nwritten=~D"
+      (error "internal error, code-length=~W, nwritten=~W"
 	     code-length
 	     nwritten)))
-  ;; KLUDGE: It's not clear what this is trying to do, but it looks as
-  ;; though it's an implicit undocumented dependence on a 4-byte
-  ;; wordsize which could be painful in porting. Note also that there
-  ;; are other undocumented modulo-4 things scattered throughout the
-  ;; code and conditionalized with GENGC, and I don't know what those
-  ;; do either. -- WHN 19990323
-  #!+gengc (unless (zerop (logand code-length 3))
-	     (dotimes (i (- 4 (logand code-length 3)))
-	       (dump-byte 0 fasl-output)))
   (values))
 
 ;;; Dump all the fixups. Currently there are three flavors of fixup:
@@ -997,27 +987,16 @@
 
     (collect ((patches))
 
-      ;; Dump the debug info.
-      #!+gengc
-      (let ((info (sb!c::debug-info-for-component component))
-	    (*dump-only-valid-structures* nil))
-	(dump-object info fasl-output)
-	(let ((info-handle (dump-pop fasl-output)))
-	  (dump-push info-handle fasl-output)
-	  (push info-handle (fasl-output-debug-info fasl-output))))
-
       ;; Dump the offset of the trace table.
       (dump-object code-length fasl-output)
       ;; FIXME: As long as we don't have GENGC, the trace table is
-      ;; hardwired to be empty. So we might be able to get rid of
-      ;; trace tables? However, we should probably wait for the first
-      ;; port to a system where CMU CL uses GENGC to see whether GENGC
-      ;; is really gone. (I.e. maybe other non-X86 ports will want to
-      ;; use it, just as in CMU CL.)
-
-      ;; Dump the constants, noting any :entries that have to be fixed up.
-      (do ((i sb!vm:code-constants-offset (1+ i)))
-	  ((>= i header-length))
+      ;; hardwired to be empty. And SBCL doesn't have GENGC (and as
+      ;; far as I know no modern CMU CL does either -- WHN
+      ;; 2001-10-05). So might we be able to get rid of trace tables?
+
+      ;; Dump the constants, noting any :ENTRY constants that have to
+      ;; be patched.
+      (loop for i from sb!vm:code-constants-offset below header-length do
 	(let ((entry (aref constants i)))
 	  (etypecase entry
 	    (constant
@@ -1029,10 +1008,19 @@
 		       (handle (gethash info
 					(fasl-output-entry-table
 					 fasl-output))))
+		  (declare (type sb!c::entry-info info))
 		  (cond
 		   (handle
 		    (dump-push handle fasl-output))
 		   (t
+
+		    ;; REMOVEME after fixing bug 138b.
+		    #|
+		    (unless (member info (sb!c::ir2-component-entries 2comp))
+		      (format t "~&i=~S~%" i)
+		      (error "bogus FASL-OUTPUT-PATCH-TABLE value ~S" info))
+                    |#
+
 		    (patches (cons info i))
 		    (dump-fop 'fop-misc-trap fasl-output)))))
 	       (:load-time-value
@@ -1044,7 +1032,6 @@
 	     (dump-fop 'fop-misc-trap fasl-output)))))
 
       ;; Dump the debug info.
-      #!-gengc
       (let ((info (sb!c::debug-info-for-component component))
 	    (*dump-only-valid-structures* nil))
 	(dump-object info fasl-output)
@@ -1052,12 +1039,7 @@
 	  (dump-push info-handle fasl-output)
 	  (push info-handle (fasl-output-debug-info fasl-output))))
 
-      (let ((num-consts #!+gengc (- header-length
-				    sb!vm:code-debug-info-slot)
-			#!-gengc (- header-length
-				    sb!vm:code-trace-table-offset-slot))
-	    (total-length #!+gengc (ceiling total-length 4)
-			  #!-gengc total-length))
+      (let ((num-consts (- header-length sb!vm:code-trace-table-offset-slot)))
 	(cond ((and (< num-consts #x100) (< total-length #x10000))
 	       (dump-fop 'fop-small-code fasl-output)
 	       (dump-byte num-consts fasl-output)
@@ -1078,6 +1060,7 @@
       (dump-fixups fixups fasl-output)
 
       (dump-fop 'fop-sanctify-for-execution fasl-output)
+
       (let ((handle (dump-pop fasl-output)))
 	(dolist (patch (patches))
 	  (push (cons handle (cdr patch))
@@ -1087,9 +1070,7 @@
 
 (defun dump-assembler-routines (code-segment length fixups routines file)
   (dump-fop 'fop-assembler-code file)
-  (dump-unsigned-32 #!+gengc (ceiling length 4)
-		    #!-gengc length
-		    file)
+  (dump-unsigned-32 length file)
   (write-segment-contents code-segment (fasl-output-stream file))
   (dolist (routine routines)
     (dump-fop 'fop-normal-load file)
@@ -1105,10 +1086,6 @@
 ;;; Dump a function-entry data structure corresponding to ENTRY to
 ;;; FILE. CODE-HANDLE is the table offset of the code object for the
 ;;; component.
-;;;
-;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the
-;;; cold loader can instantiate the definition at cold-load time,
-;;; allowing forward references to functions in top-level forms.
 (defun dump-one-entry (entry code-handle file)
   (declare (type sb!c::entry-info entry) (type index code-handle)
 	   (type fasl-output file))
@@ -1119,12 +1096,7 @@
     (dump-object (sb!c::entry-info-type entry) file)
     (dump-fop 'fop-function-entry file)
     (dump-unsigned-32 (label-position (sb!c::entry-info-offset entry)) file)
-    (let ((handle (dump-pop file)))
-      (when (and name (or (symbolp name) (listp name)))
-	(dump-object name file)
-	(dump-push handle file)
-	(dump-fop 'fop-fset file))
-      handle)))
+    (dump-pop file)))
 
 ;;; Alter the code object referenced by CODE-HANDLE at the specified
 ;;; OFFSET, storing the object referenced by ENTRY-HANDLE.
@@ -1168,12 +1140,7 @@
     (dolist (entry (sb!c::ir2-component-entries 2comp))
       (let ((entry-handle (dump-one-entry entry code-handle file)))
 	(setf (gethash entry (fasl-output-entry-table file)) entry-handle)
-
 	(let ((old (gethash entry (fasl-output-patch-table file))))
-	  ;; FIXME: All this code is shared with
-	  ;; FASL-DUMP-BYTE-COMPONENT, and should probably be gathered
-	  ;; up into a named function (DUMP-PATCHES?) called from both
-	  ;; functions.
 	  (when old
 	    (dolist (patch old)
 	      (dump-alter-code-object (car patch)
@@ -1183,148 +1150,51 @@
 	    (remhash entry (fasl-output-patch-table file)))))))
   (values))
 
-(defun dump-byte-code-object (segment code-length constants file)
-  (declare (type sb!assem:segment segment)
-	   (type index code-length)
-	   (type vector constants)
-	   (type fasl-output file))
-  (collect ((entry-patches))
-
-    ;; Dump the debug info.
-    #!+gengc
-    (let ((info (sb!c::make-debug-info
-		 :name (sb!c::component-name *component-being-compiled*)))
-	  (*dump-only-valid-structures* nil))
-      (dump-object info file)
-      (let ((info-handle (dump-pop file)))
-	(dump-push info-handle file)
-	(push info-handle (fasl-output-debug-info file))))
-
-    ;; The "trace table" is initialized by loader to hold a list of
-    ;; all byte functions in this code object (for debug info.)
-    (dump-object nil file)
-
-    ;; Dump the constants.
-    (dotimes (i (length constants))
-      (let ((entry (aref constants i)))
-	(etypecase entry
-	  (constant
-	   (dump-object (sb!c::constant-value entry) file))
-	  (null
-	   (dump-fop 'fop-misc-trap file))
-	  (list
-	   (ecase (car entry)
-	     (:entry
-	      (let* ((info (sb!c::leaf-info (cdr entry)))
-		     (handle (gethash info
-				      (fasl-output-entry-table file))))
-		(cond
-		 (handle
-		  (dump-push handle file))
-		 (t
-		  (entry-patches (cons info
-				       (+ i sb!vm:code-constants-offset)))
-		  (dump-fop 'fop-misc-trap file)))))
-	     (:load-time-value
-	      (dump-push (cdr entry) file))
-	     (:fdefinition
-	      (dump-object (cdr entry) file)
-	      (dump-fop 'fop-fdefinition file))
-	     (:type-predicate
-	      (dump-object 'load-type-predicate file)
-	      (let ((*unparse-function-type-simplify* t))
-		(dump-object (type-specifier (cdr entry)) file))
-	      (dump-fop 'fop-funcall file)
-	      (dump-byte 1 file)))))))
-
-    ;; Dump the debug info.
-    #!-gengc
-    (let ((info (sb!c::make-debug-info :name
-				       (sb!c::component-name
-					*component-being-compiled*)))
-	  (*dump-only-valid-structures* nil))
-      (dump-object info file)
-      (let ((info-handle (dump-pop file)))
-	(dump-push info-handle file)
-	(push info-handle (fasl-output-debug-info file))))
-
-    (let ((num-consts #!+gengc (+ (length constants) 2)
-		      #!-gengc (1+ (length constants)))
-	  (code-length #!+gengc (ceiling code-length 4)
-		       #!-gengc code-length))
-      (cond ((and (< num-consts #x100) (< code-length #x10000))
-	     (dump-fop 'fop-small-code file)
-	     (dump-byte num-consts file)
-	     (dump-integer-as-n-bytes code-length 2 file))
-	    (t
-	     (dump-fop 'fop-code file)
-	     (dump-unsigned-32 num-consts file)
-	     (dump-unsigned-32 code-length file))))
-    (dump-segment segment code-length file)
-    (let ((code-handle (dump-pop file))
-	  (patch-table (fasl-output-patch-table file)))
-      (dolist (patch (entry-patches))
-	(push (cons code-handle (cdr patch))
-	      (gethash (car patch) patch-table)))
-      code-handle)))
-
-;;; Dump a byte-component. This is similar to FASL-DUMP-COMPONENT, but
-;;; different.
-(defun fasl-dump-byte-component (segment length constants xeps file)
-  (declare (type sb!assem:segment segment)
-	   (type index length)
-	   (type vector constants)
-	   (type list xeps)
-	   (type fasl-output file))
-
-  (let ((code-handle (dump-byte-code-object segment length constants file)))
-    (dolist (noise xeps)
-      (let* ((lambda (car noise))
-	     (info (sb!c::lambda-info lambda))
-	     (xep (cdr noise)))
-	(dump-byte-function xep code-handle file)
-	(let* ((entry-handle (dump-pop file))
-	       (patch-table (fasl-output-patch-table file))
-	       (old (gethash info patch-table)))
-	  (setf (gethash info (fasl-output-entry-table file))
-		entry-handle)
-	  (when old
-	    (dolist (patch old)
-	      (dump-alter-code-object (car patch)
-				      (cdr patch)
-				      entry-handle
-				      file))
-	    (remhash info patch-table))))))
+(defun dump-push-previously-dumped-fun (fun fasl-output)
+  (declare (type sb!c::clambda fun))
+  (let ((handle (gethash (sb!c::leaf-info fun)
+			 (fasl-output-entry-table fasl-output))))
+    (aver handle)
+    (dump-push handle fasl-output))
   (values))
 
-;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at
+;;; Dump a FOP-FUNCALL to call an already-dumped top level lambda at
 ;;; load time.
-(defun fasl-dump-top-level-lambda-call (fun file)
-  (declare (type sb!c::clambda fun) (type fasl-output file))
-  (let ((handle (gethash (sb!c::leaf-info fun)
-			 (fasl-output-entry-table file))))
-    (aver handle)
-    (dump-push handle file)
-    (dump-fop 'fop-funcall-for-effect file)
-    (dump-byte 0 file))
+(defun fasl-dump-toplevel-lambda-call (fun fasl-output)
+  (declare (type sb!c::clambda fun))
+  (dump-push-previously-dumped-fun fun fasl-output)
+  (dump-fop 'fop-funcall-for-effect fasl-output)
+  (dump-byte 0 fasl-output)
   (values))
 
+;;; Dump a FOP-FSET to arrange static linkage (at cold init) between
+;;; FUN-NAME and the already-dumped function whose dump handle is
+;;; FUN-DUMP-HANDLE.
+#+sb-xc-host
+(defun fasl-dump-cold-fset (fun-name fun-dump-handle fasl-output)
+  (declare (type fixnum fun-dump-handle))
+  (aver (legal-fun-name-p fun-name))
+  (dump-non-immediate-object fun-name fasl-output)
+  (dump-push fun-dump-handle fasl-output)
+  (dump-fop 'fop-fset fasl-output)
+  (values))
+    
 ;;; Compute the correct list of DEBUG-SOURCE structures and backpatch
 ;;; all of the dumped DEBUG-INFO structures. We clear the
 ;;; FASL-OUTPUT-DEBUG-INFO, so that subsequent components with
 ;;; different source info may be dumped.
-(defun fasl-dump-source-info (info file)
-  (declare (type sb!c::source-info info) (type fasl-output file))
+(defun fasl-dump-source-info (info fasl-output)
+  (declare (type sb!c::source-info info))
   (let ((res (sb!c::debug-source-for-info info))
 	(*dump-only-valid-structures* nil))
-    (dump-object res file)
-    (let ((res-handle (dump-pop file)))
-      (dolist (info-handle (fasl-output-debug-info file))
-	(dump-push res-handle file)
-	(dump-fop 'fop-structset file)
-	(dump-unsigned-32 info-handle file)
-	(dump-unsigned-32 2 file))))
-  (setf (fasl-output-debug-info file) nil)
+    (dump-object res fasl-output)
+    (let ((res-handle (dump-pop fasl-output)))
+      (dolist (info-handle (fasl-output-debug-info fasl-output))
+	(dump-push res-handle fasl-output)
+	(dump-fop 'fop-structset fasl-output)
+	(dump-unsigned-32 info-handle fasl-output)
+	(dump-unsigned-32 2 fasl-output))))
+  (setf (fasl-output-debug-info fasl-output) nil)
   (values))
 
 ;;;; dumping structures