X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Froom.lisp;h=a5735e03cc2dbae5f7b14d42311d015b7d061da8;hb=20748f2dd7965dcd1446a1cb27e5a5af18a0e5bb;hp=15a774271a0a0e72e4af037f0037f71b83c7bec3;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git

diff --git a/src/code/room.lisp b/src/code/room.lisp
index 15a7742..a5735e0 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -10,21 +10,18 @@
 ;;;; files for more information.
 
 (in-package "SB!VM")
-
-(file-comment
-  "$Header$")
 
 ;;;; type format database
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
-    ;; The name of this type.
+    ;; the name of this type
     (name nil :type symbol)
-    ;; Kind of type (how we determine length).
-    (kind (required-argument)
+    ;; kind of type (how we determine length)
+    (kind (missing-arg)
 	  :type (member :lowtag :fixed :header :vector
 			:string :code :closure :instance))
-    ;; Length if fixed-length, shift amount for element size if :vector.
+    ;; length if fixed-length, shift amount for element size if :VECTOR
     (length nil :type (or fixnum null))))
 
 (eval-when (:compile-toplevel :execute)
@@ -32,14 +29,14 @@
 (defvar *meta-room-info* (make-array 256 :initial-element nil))
 
 (dolist (obj *primitive-objects*)
-  (let ((header (primitive-object-header obj))
+  (let ((widetag (primitive-object-widetag obj))
 	(lowtag (primitive-object-lowtag obj))
 	(name (primitive-object-name obj))
-	(variable (primitive-object-variable-length obj))
+	(variable (primitive-object-var-length obj))
 	(size (primitive-object-size obj)))
     (cond
      ((not lowtag))
-     ((not header)
+     ((not widetag)
       (let ((info (make-room-info :name name
 				  :kind :lowtag))
 	    (lowtag (symbol-value lowtag)))
@@ -48,41 +45,41 @@
 	  (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
      (variable)
      (t
-      (setf (svref *meta-room-info* (symbol-value header))
+      (setf (svref *meta-room-info* (symbol-value widetag))
 	    (make-room-info :name name
 			    :kind :fixed
 			    :length size))))))
 
-(dolist (code (list complex-string-type simple-array-type
-		    complex-bit-vector-type complex-vector-type
-		    complex-array-type))
+(dolist (code (list complex-string-widetag simple-array-widetag
+		    complex-bit-vector-widetag complex-vector-widetag
+		    complex-array-widetag))
   (setf (svref *meta-room-info* code)
 	(make-room-info :name 'array-header
 			:kind :header)))
 
-(setf (svref *meta-room-info* bignum-type)
+(setf (svref *meta-room-info* bignum-widetag)
       (make-room-info :name 'bignum
 		      :kind :header))
 
-(setf (svref *meta-room-info* closure-header-type)
+(setf (svref *meta-room-info* closure-header-widetag)
       (make-room-info :name 'closure
 		      :kind :closure))
 
-(dolist (stuff '((simple-bit-vector-type . -3)
-		 (simple-vector-type . 2)
-		 (simple-array-unsigned-byte-2-type . -2)
-		 (simple-array-unsigned-byte-4-type . -1)
-		 (simple-array-unsigned-byte-8-type . 0)
-		 (simple-array-unsigned-byte-16-type . 1)
-		 (simple-array-unsigned-byte-32-type . 2)
-		 (simple-array-signed-byte-8-type . 0)
-		 (simple-array-signed-byte-16-type . 1)
-		 (simple-array-signed-byte-30-type . 2)
-		 (simple-array-signed-byte-32-type . 2)
-		 (simple-array-single-float-type . 2)
-		 (simple-array-double-float-type . 3)
-		 (simple-array-complex-single-float-type . 3)
-		 (simple-array-complex-double-float-type . 4)))
+(dolist (stuff '((simple-bit-vector-widetag . -3)
+		 (simple-vector-widetag . 2)
+		 (simple-array-unsigned-byte-2-widetag . -2)
+		 (simple-array-unsigned-byte-4-widetag . -1)
+		 (simple-array-unsigned-byte-8-widetag . 0)
+		 (simple-array-unsigned-byte-16-widetag . 1)
+		 (simple-array-unsigned-byte-32-widetag . 2)
+		 (simple-array-signed-byte-8-widetag . 0)
+		 (simple-array-signed-byte-16-widetag . 1)
+		 (simple-array-signed-byte-30-widetag . 2)
+		 (simple-array-signed-byte-32-widetag . 2)
+		 (simple-array-single-float-widetag . 2)
+		 (simple-array-double-float-widetag . 3)
+		 (simple-array-complex-single-float-widetag . 3)
+		 (simple-array-complex-double-float-widetag . 4)))
   (let ((name (car stuff))
 	(size (cdr stuff)))
     (setf (svref *meta-room-info* (symbol-value name))
@@ -90,16 +87,16 @@
 			  :kind :vector
 			  :length size))))
 
-(setf (svref *meta-room-info* simple-string-type)
-      (make-room-info :name 'simple-string-type
+(setf (svref *meta-room-info* simple-string-widetag)
+      (make-room-info :name 'simple-string-widetag
 		      :kind :string
 		      :length 0))
 
-(setf (svref *meta-room-info* code-header-type)
+(setf (svref *meta-room-info* code-header-widetag)
       (make-room-info :name 'code
 		      :kind :code))
 
-(setf (svref *meta-room-info* instance-header-type)
+(setf (svref *meta-room-info* instance-header-widetag)
       (make-room-info :name 'instance
 		      :kind :instance))
 
@@ -110,20 +107,23 @@
 
 ;;;; MAP-ALLOCATED-OBJECTS
 
-(declaim (type fixnum *static-space-free-pointer*
-	       *read-only-space-free-pointer* ))
+;;; Since they're represented as counts of words, we should never
+;;; need bignums to represent these:
+(declaim (type fixnum
+	       *static-space-free-pointer*
+	       *read-only-space-free-pointer*))
 
 (defun space-bounds (space)
   (declare (type spaces space))
   (ecase space
     (:static
-     (values (int-sap (static-space-start))
-	     (int-sap (* *static-space-free-pointer* word-bytes))))
+     (values (int-sap static-space-start)
+	     (int-sap (* *static-space-free-pointer* n-word-bytes))))
     (:read-only
-     (values (int-sap (read-only-space-start))
-	     (int-sap (* *read-only-space-free-pointer* word-bytes))))
+     (values (int-sap read-only-space-start)
+	     (int-sap (* *read-only-space-free-pointer* n-word-bytes))))
     (:dynamic
-     (values (int-sap (current-dynamic-space-start))
+     (values (int-sap dynamic-space-start)
 	     (dynamic-space-free-pointer)))))
 
 ;;; Return the total number of bytes used in SPACE.
@@ -147,7 +147,7 @@
 		  (:string 1)))))
     (declare (type (integer -3 3) shift))
     (round-to-dualword
-     (+ (* vector-data-offset word-bytes)
+     (+ (* vector-data-offset n-word-bytes)
 	(the fixnum
 	     (if (minusp shift)
 		 (ash (the fixnum
@@ -171,34 +171,34 @@
 	    (prev nil))
 	(loop
 	  (let* ((header (sap-ref-32 current 0))
-		 (header-type (logand header #xFF))
-		 (info (svref *room-info* header-type)))
+		 (header-widetag (logand header #xFF))
+		 (info (svref *room-info* header-widetag)))
 	    (cond
 	     ((or (not info)
 		  (eq (room-info-kind info) :lowtag))
-	      (let ((size (* cons-size word-bytes)))
+	      (let ((size (* cons-size n-word-bytes)))
 		(funcall fun
 			 (make-lisp-obj (logior (sap-int current)
-						list-pointer-type))
-			 list-pointer-type
+						list-pointer-lowtag))
+			 list-pointer-lowtag
 			 size)
 		(setq current (sap+ current size))))
-	     ((eql header-type closure-header-type)
+	     ((eql header-widetag closure-header-widetag)
 	      (let* ((obj (make-lisp-obj (logior (sap-int current)
-						 function-pointer-type)))
+						 fun-pointer-lowtag)))
 		     (size (round-to-dualword
 			    (* (the fixnum (1+ (get-closure-length obj)))
-			       word-bytes))))
-		(funcall fun obj header-type size)
+			       n-word-bytes))))
+		(funcall fun obj header-widetag size)
 		(setq current (sap+ current size))))
 	     ((eq (room-info-kind info) :instance)
 	      (let* ((obj (make-lisp-obj
-			   (logior (sap-int current) instance-pointer-type)))
+			   (logior (sap-int current) instance-pointer-lowtag)))
 		     (size (round-to-dualword
-			    (* (+ (%instance-length obj) 1) word-bytes))))
+			    (* (+ (%instance-length obj) 1) n-word-bytes))))
 		(declare (fixnum size))
-		(funcall fun obj header-type size)
-		(assert (zerop (logand size lowtag-mask)))
+		(funcall fun obj header-widetag size)
+		(aver (zerop (logand size lowtag-mask)))
 		#+nil
 		(when (> size 200000) (break "implausible size, prev ~S" prev))
 		#+nil
@@ -206,28 +206,28 @@
 		(setq current (sap+ current size))))
 	     (t
 	      (let* ((obj (make-lisp-obj
-			   (logior (sap-int current) other-pointer-type)))
+			   (logior (sap-int current) other-pointer-lowtag)))
 		     (size (ecase (room-info-kind info)
 			     (:fixed
-			      (assert (or (eql (room-info-length info)
+			      (aver (or (eql (room-info-length info)
 					       (1+ (get-header-data obj)))
 					  (floatp obj)))
 			      (round-to-dualword
-			       (* (room-info-length info) word-bytes)))
+			       (* (room-info-length info) n-word-bytes)))
 			     ((:vector :string)
 			      (vector-total-size obj info))
 			     (:header
 			      (round-to-dualword
-			       (* (1+ (get-header-data obj)) word-bytes)))
+			       (* (1+ (get-header-data obj)) n-word-bytes)))
 			     (:code
 			      (+ (the fixnum
-				      (* (get-header-data obj) word-bytes))
+				      (* (get-header-data obj) n-word-bytes))
 				 (round-to-dualword
 				  (* (the fixnum (%code-code-size obj))
-				     word-bytes)))))))
+				     n-word-bytes)))))))
 		(declare (fixnum size))
-		(funcall fun obj header-type size)
-		(assert (zerop (logand size lowtag-mask)))
+		(funcall fun obj header-widetag size)
+		(aver (zerop (logand size lowtag-mask)))
 		#+nil
 		(when (> size 200000)
 		  (break "Implausible size, prev ~S" prev))
@@ -235,7 +235,7 @@
 		(setq prev current)
 		(setq current (sap+ current size))))))
 	  (unless (sap< current end)
-	    (assert (sap= current end))
+	    (aver (sap= current end))
 	    (return)))
 
 	#+nil
@@ -352,16 +352,16 @@
     (format t "  ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
 	    total-bytes total-objects (car space-total))))
 
+;;; Print information about the heap memory in use. PRINT-SPACES is a
+;;; list of the spaces to print detailed information for.
+;;; COUNT-SPACES is a list of the spaces to scan. For either one, T
+;;; means all spaces (i.e. :STATIC, :DYNAMIC and :READ-ONLY.) If
+;;; PRINT-SUMMARY is true, then summary information will be printed.
+;;; The defaults print only summary information for dynamic space. If
+;;; true, CUTOFF is a fraction of the usage in a report below which
+;;; types will be combined as OTHER.
 (defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
 			  (print-summary t) cutoff)
-  #!+sb-doc
-  "Print out information about the heap memory in use. :Print-Spaces is a list
-  of the spaces to print detailed information for. :Count-Spaces is a list of
-  the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
-  and :Read-Only.)  If :Print-Summary is true, then summary information will be
-  printed. The defaults print only summary information for dynamic space.
-  If true, Cutoff is a fraction of the usage in a report below which types will
-  be combined as OTHER."
   (declare (type (or single-float null) cutoff))
   (let* ((spaces (if (eq count-spaces t)
 		     '(:static :dynamic :read-only)
@@ -379,9 +379,8 @@
 
   (values))
 
+;;; Print info about how much code and no-ops there are in SPACE.
 (defun count-no-ops (space)
-  #!+sb-doc
-  "Print info about how much code and no-ops there are in Space."
   (declare (type spaces space))
   (let ((code-words 0)
 	(no-ops 0)
@@ -391,14 +390,14 @@
     (map-allocated-objects
      #'(lambda (obj type size)
  	 (declare (fixnum size) (optimize (safety 0)))
-	 (when (eql type code-header-type)
+	 (when (eql type code-header-widetag)
 	   (incf total-bytes size)
 	   (let ((words (truly-the fixnum (%code-code-size obj)))
 		 (sap (truly-the system-area-pointer
 				 (%primitive code-instructions obj))))
 	     (incf code-words words)
 	     (dotimes (i words)
-	       (when (zerop (sap-ref-32 sap (* i sb!vm:word-bytes)))
+	       (when (zerop (sap-ref-32 sap (* i n-word-bytes)))
 		 (incf no-ops))))))
      space)
 
@@ -421,52 +420,52 @@
        #'(lambda (obj type size)
 	   (declare (fixnum size) (optimize (safety 0)))
 	   (case type
-	     (#.code-header-type
+	     (#.code-header-widetag
 	      (let ((inst-words (truly-the fixnum (%code-code-size obj))))
 		(declare (type fixnum inst-words))
-		(incf non-descriptor-bytes (* inst-words word-bytes))
+		(incf non-descriptor-bytes (* inst-words n-word-bytes))
 		(incf descriptor-words
-		      (- (truncate size word-bytes) inst-words))))
-	     ((#.bignum-type
-	       #.single-float-type
-	       #.double-float-type
-	       #.simple-string-type
-	       #.simple-bit-vector-type
-	       #.simple-array-unsigned-byte-2-type
-	       #.simple-array-unsigned-byte-4-type
-	       #.simple-array-unsigned-byte-8-type
-	       #.simple-array-unsigned-byte-16-type
-	       #.simple-array-unsigned-byte-32-type
-	       #.simple-array-signed-byte-8-type
-	       #.simple-array-signed-byte-16-type
-	       #.simple-array-signed-byte-30-type
-	       #.simple-array-signed-byte-32-type
-	       #.simple-array-single-float-type
-	       #.simple-array-double-float-type
-	       #.simple-array-complex-single-float-type
-	       #.simple-array-complex-double-float-type)
+		      (- (truncate size n-word-bytes) inst-words))))
+	     ((#.bignum-widetag
+	       #.single-float-widetag
+	       #.double-float-widetag
+	       #.simple-string-widetag
+	       #.simple-bit-vector-widetag
+	       #.simple-array-unsigned-byte-2-widetag
+	       #.simple-array-unsigned-byte-4-widetag
+	       #.simple-array-unsigned-byte-8-widetag
+	       #.simple-array-unsigned-byte-16-widetag
+	       #.simple-array-unsigned-byte-32-widetag
+	       #.simple-array-signed-byte-8-widetag
+	       #.simple-array-signed-byte-16-widetag
+	       #.simple-array-signed-byte-30-widetag
+	       #.simple-array-signed-byte-32-widetag
+	       #.simple-array-single-float-widetag
+	       #.simple-array-double-float-widetag
+	       #.simple-array-complex-single-float-widetag
+	       #.simple-array-complex-double-float-widetag)
 	      (incf non-descriptor-headers)
-	      (incf non-descriptor-bytes (- size word-bytes)))
-	     ((#.list-pointer-type
-	       #.instance-pointer-type
-	       #.ratio-type
-	       #.complex-type
-	       #.simple-array-type
-	       #.simple-vector-type
-	       #.complex-string-type
-	       #.complex-bit-vector-type
-	       #.complex-vector-type
-	       #.complex-array-type
-	       #.closure-header-type
-	       #.funcallable-instance-header-type
-	       #.value-cell-header-type
-	       #.symbol-header-type
-	       #.sap-type
-	       #.weak-pointer-type
-	       #.instance-header-type)
-	      (incf descriptor-words (truncate size word-bytes)))
+	      (incf non-descriptor-bytes (- size n-word-bytes)))
+	     ((#.list-pointer-lowtag
+	       #.instance-pointer-lowtag
+	       #.ratio-widetag
+	       #.complex-widetag
+	       #.simple-array-widetag
+	       #.simple-vector-widetag
+	       #.complex-string-widetag
+	       #.complex-bit-vector-widetag
+	       #.complex-vector-widetag
+	       #.complex-array-widetag
+	       #.closure-header-widetag
+	       #.funcallable-instance-header-widetag
+	       #.value-cell-header-widetag
+	       #.symbol-header-widetag
+	       #.sap-widetag
+	       #.weak-pointer-widetag
+	       #.instance-header-widetag)
+	      (incf descriptor-words (truncate size n-word-bytes)))
 	     (t
-	      (error "Bogus type: ~D" type))))
+	      (error "bogus type: ~D" type))))
        space))
     (format t "~:D words allocated for descriptor objects.~%"
 	    descriptor-words)
@@ -474,12 +473,11 @@
 	    non-descriptor-bytes non-descriptor-headers)
     (values)))
 
+;;; Print a breakdown by instance type of all the instances allocated
+;;; in SPACE. If TOP-N is true, print only information for the the
+;;; TOP-N types with largest usage.
 (defun instance-usage (space &key (top-n 15))
   (declare (type spaces space) (type (or fixnum null) top-n))
-  #!+sb-doc
-  "Print a breakdown by instance type of all the instances allocated in
-  Space. If TOP-N is true, print only information for the the TOP-N types with
-  largest usage."
   (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
   (let ((totals (make-hash-table :test 'eq))
 	(total-objects 0)
@@ -488,7 +486,7 @@
     (map-allocated-objects
      #'(lambda (obj type size)
 	 (declare (fixnum size) (optimize (speed 3) (safety 0)))
-	 (when (eql type instance-header-type)
+	 (when (eql type instance-header-widetag)
 	   (incf total-objects)
 	   (incf total-bytes size)
 	   (let* ((class (layout-class (%instance-ref obj 0)))
@@ -523,7 +521,7 @@
 	(let ((residual-objects (- total-objects printed-objects))
 	      (residual-bytes (- total-bytes printed-bytes)))
 	  (unless (zerop residual-objects)
-	    (format t "  Other types: ~:D bytes, ~D: object~:P.~%"
+	    (format t "  Other types: ~:D bytes, ~D object~:P.~%"
 		    residual-bytes residual-objects))))
 
       (format t "  ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
@@ -562,9 +560,9 @@
 (defun print-allocated-objects (space &key (percent 0) (pages 5)
 				      type larger smaller count
 				      (stream *standard-output*))
-  (declare (type (integer 0 99) percent) (type sb!c::index pages)
+  (declare (type (integer 0 99) percent) (type index pages)
 	   (type stream stream) (type spaces space)
-	   (type (or sb!c::index null) type larger smaller count))
+	   (type (or index null) type larger smaller count))
   (multiple-value-bind (start-sap end-sap) (space-bounds space)
     (let* ((space-start (sap-int start-sap))
 	   (space-end (sap-int end-sap))
@@ -593,12 +591,15 @@
 		   (return-from print-allocated-objects (values)))
 
 		 (unless count
-		   (let ((this-page (* (the (unsigned-byte 32)
-					    (truncate addr pagesize))
+		   (let ((this-page (* (the (values (unsigned-byte 32) t)
+                                         (truncate addr pagesize))
 				       pagesize)))
 		     (declare (type (unsigned-byte 32) this-page))
 		     (when (/= this-page last-page)
 		       (when (< pages-so-far pages)
+			 ;; FIXME: What is this? (ERROR "Argh..")? or
+			 ;; a warning? or code that can be removed
+			 ;; once the system is stable? or what?
 			 (format stream "~2&**** Page ~D, address ~X:~%"
 				 pages-so-far addr))
 		       (setq last-page this-page)
@@ -609,15 +610,15 @@
 			    (or (not larger) (>= size larger)))
 		   (incf count-so-far)
 		   (case type
-		     (#.code-header-type
+		     (#.code-header-widetag
 		      (let ((dinfo (%code-debug-info obj)))
 			(format stream "~&Code object: ~S~%"
 				(if dinfo
 				    (sb!c::compiled-debug-info-name dinfo)
 				    "No debug info."))))
-		     (#.symbol-header-type
+		     (#.symbol-header-widetag
 		      (format stream "~&~S~%" obj))
-		     (#.list-pointer-type
+		     (#.list-pointer-lowtag
 		      (unless (gethash obj printed-conses)
 			(note-conses obj)
 			(let ((*print-circle* t)
@@ -628,7 +629,7 @@
 		      (fresh-line stream)
 		      (let ((str (write-to-string obj :level 5 :length 10
 						  :pretty nil)))
-			(unless (eql type instance-header-type)
+			(unless (eql type instance-header-widetag)
 			  (format stream "~S: " (type-of obj)))
 			(format stream "~A~%"
 				(subseq str 0 (min (length str) 60))))))))))
@@ -648,7 +649,7 @@
 (defun list-allocated-objects (space &key type larger smaller count
 				     test)
   (declare (type spaces space)
-	   (type (or sb!c::index null) larger smaller type count)
+	   (type (or index null) larger smaller type count)
 	   (type (or function null) test)
 	   (inline map-allocated-objects))
   (unless *ignore-after* (setq *ignore-after* (cons 1 2)))