diff --git a/code/room.lisp b/code/room.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..3e382f276d068169256ee29b4366266aca50e34e
--- /dev/null
+++ b/code/room.lisp
@@ -0,0 +1,439 @@
+;;; -*- Mode: Lisp; Package: VM -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the Spice Lisp project at
+;;; Carnegie-Mellon University, and has been placed in the public domain.
+;;; Spice Lisp is currently incomplete and under active development.
+;;; If you want to use this code or any part of Spice Lisp, please contact
+;;; Scott Fahlman (Scott.Fahlman@CS.CMU.EDU). 
+;;; **********************************************************************
+;;;
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/room.lisp,v 1.1 1990/09/19 00:12:05 ram Exp $
+;;; 
+;;; Heap grovelling memory usage stuff.
+;;; 
+(in-package "VM")
+(use-package "SYSTEM")
+(in-package "C")
+(import '(function-code-header make-lisp-obj dynamic-space-free-pointer
+	  code-code-size vector-length)
+	"VM")
+(in-package "LISP")
+(import '(
+	  dynamic-0-space-start dynamic-1-space-start read-only-space-start
+	  static-space-start current-dynamic-space-start
+	  *static-space-free-pointer* *read-only-space-free-pointer*)
+	"VM")
+(in-package "VM")
+
+
+;;;; Type format database.
+
+(defstruct room-info
+  ;;
+  ;; The name of this type.
+  (name nil :type symbol)
+  ;;
+  ;; Kind of type (how we determine length).
+  (kind nil :type (member :lowtag :fixed :header :vector :code :closure))
+  ;;
+  ;; Length if fixed-length, shift amount for element size if :vector.
+  (length nil :type (or fixnum null)))
+
+(defvar *room-info* (make-array 256 :initial-element nil))
+
+
+(dolist (obj *primitive-objects*)
+  (let ((header (primitive-object-header obj))
+	(lowtag (primitive-object-lowtag obj))
+	(name (primitive-object-name obj))
+	(variable (primitive-object-variable-length obj))
+	(size (primitive-object-size obj)))
+    (cond
+     ((not lowtag))
+     ((not header)
+      (let ((info (make-room-info :name name  :kind :lowtag))
+	    (lowtag (symbol-value lowtag)))
+	(declare (fixnum lowtag))
+	(dotimes (i 32)
+	  (setf (svref *room-info* (logior lowtag (ash i 3))) info))))
+     (variable)
+     (t
+      (setf (svref *room-info* (symbol-value header))
+	    (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))
+  (setf (svref *room-info* code)
+	(make-room-info :name 'array-header  :kind :header)))
+
+(setf (svref *room-info* bignum-type)
+      (make-room-info :name 'bignum  :kind :header))
+
+(setf (svref *room-info* closure-header-type)
+      (make-room-info :name 'closure  :kind :closure))
+
+(dolist (stuff '((simple-string-type . 0)
+		 (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-single-float-type . 2)
+		 (simple-array-double-float-type . 3)))
+  (let ((name (car stuff))
+	(size (cdr stuff)))
+    (setf (svref *room-info* (symbol-value name))
+	  (make-room-info :name name  :kind :vector  :length size))))
+
+(setf (svref *room-info* code-header-type)
+      (make-room-info :name 'code  :kind :code))
+
+(deftype spaces () '(member :static :dynamic :read-only))
+
+
+;;;; MAP-ALLOCATED-OBJECTS:
+
+(proclaim '(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))))
+    (:read-only
+     (values (int-sap (read-only-space-start))
+	     (int-sap (* *read-only-space-free-pointer* word-bytes))))
+    (:dynamic
+     (values (int-sap (current-dynamic-space-start))
+	     (dynamic-space-free-pointer)))))
+
+
+;;; ROUND-TO-DUALWORD  --  Internal
+;;;
+;;;    Round Size (in bytes) up to the next dualword (eight byte) boundry.
+;;;
+(proclaim '(inline round-to-dualword))
+(defun round-to-dualword (size)
+  (declare (fixnum size))
+  (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
+
+
+;;; VECTOR-TOTAL-SIZE  --  Internal
+;;;
+;;;    Return the total size of a vector in bytes, including any pad.
+;;;
+(proclaim '(inline vector-total-size))
+(defun vector-total-size (obj info)
+  (let ((shift (room-info-length info))
+	(len (vector-length obj)))
+    (declare (type (integer -3 3) shift))
+    (round-to-dualword
+     (+ (* vector-data-offset word-bytes)
+	(the fixnum
+	     (if (minusp shift)
+		 (ash (the fixnum
+			   (+ len (the fixnum
+				       (1- (the fixnum (ash 1 (- shift)))))))
+		      shift)
+		 (ash len shift)))))))
+
+
+;;; MAP-ALLOCATED-OBJECTS  --  Interface
+;;;
+;;;    Iterate over all the objects allocated in Space, calling Fun with the
+;;; object, the object's type code, and the objects total size in bytes,
+;;; including any header and padding.
+;;;
+(proclaim '(maybe-inline map-allocated-objects))
+(defun map-allocated-objects (fun space)
+  (declare (type function fun) (type spaces space))
+  (multiple-value-bind (start end)
+		       (space-bounds space)
+    (declare (optimize (speed 3) (safety 0)))
+    (let ((current start)
+	  (prev nil))
+      (loop
+	(let* ((header (sap-ref-32 current 0))
+	       (header-type (logand header #xFF))
+	       (info (svref *room-info* header-type)))
+	  (cond
+	   ((or (not info)
+		(eq (room-info-kind info) :lowtag))
+	    (let ((size (* cons-size word-bytes)))
+	      (funcall fun
+		       (make-lisp-obj (logior (sap-int current)
+					      list-pointer-type))
+		       list-pointer-type
+		       size)
+	      (setq current (sap+ current size))))
+	   ((eql header-type closure-header-type)
+	    (let* ((obj (make-lisp-obj (logior (sap-int current)
+					       function-pointer-type)))
+		   (size (round-to-dualword
+			  (* (the fixnum (1+ (get-closure-length obj)))
+			     word-bytes))))
+	      (funcall fun obj header-type size)
+	      (setq current (sap+ current size))))
+	   (t
+	    (let* ((obj (make-lisp-obj
+			 (logior (sap-int current) other-pointer-type)))
+		   (size (ecase (room-info-kind info)
+			   (:fixed
+			    (assert (or (eql (room-info-length info)
+					     (1+ (get-header-data obj)))
+					(floatp obj)))
+			    (round-to-dualword
+			     (* (room-info-length info) word-bytes)))
+			   (:vector
+			    (vector-total-size obj info))
+			   (:header
+			    (round-to-dualword
+			     (* (1+ (get-header-data obj)) word-bytes)))
+			   (:code
+			    (+ (the fixnum
+				    (* (get-header-data obj) word-bytes))
+			       (round-to-dualword
+				(* (the fixnum
+					(%primitive code-code-size obj))
+				   word-bytes)))))))
+	      (declare (fixnum size))
+	      (funcall fun obj header-type size)
+	      (assert (zerop (logand size lowtag-mask)))
+	      (when (> size 200000) (break "Implausible size, prev ~S" prev))
+	      (setq prev current)
+	      (setq current (sap+ current size))))))
+	(unless (pointer< current end)
+	  (assert (not (pointer> current end)))
+	  (return)))
+
+      prev)))
+
+
+;;;; MEMORY-USAGE:
+
+;;; TYPE-BREAKDOWN  --  Interface
+;;;
+;;;    Return a list of 3-lists (bytes object type-name) for the objects
+;;; allocated in Space.
+;;;
+(defun type-breakdown (space)
+  (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
+	(counts (make-array 256 :initial-element 0 :element-type 'fixnum))
+	(structure-count 0)
+	(structure-size 0))
+    (declare (fixnum structure-size structure-count))
+    (map-allocated-objects
+     #'(lambda (obj type size)
+	 (declare (fixnum size) (optimize (speed 3) (safety 0)))
+	 (cond ((and (eql type simple-vector-type)
+		     (eql (get-header-data obj) vector-structure-subtype))
+		(incf structure-count)
+		(incf structure-size size))
+	       (t
+		(incf (aref sizes type) size)
+		(incf (aref counts type)))))
+     space)
+
+    (let ((totals (make-hash-table :test #'eq)))
+      (dotimes (i 256)
+	(let ((total-count (aref counts i)))
+	  (unless (zerop total-count)
+	    (let* ((total-size (aref sizes i))
+		   (name (room-info-name (aref *room-info* i)))
+		   (found (gethash name totals)))
+	      (cond (found
+		     (incf (first found) total-size)
+		     (incf (second found) total-count))
+		    (t
+		     (setf (gethash name totals)
+			   (list total-size total-count name))))))))
+
+      (collect ((totals-list))
+	(maphash #'(lambda (k v)
+		     (declare (ignore k))
+		     (totals-list v))
+		 totals)
+	(totals-list (list structure-size structure-count 'structure))
+	(sort (totals-list) #'> :key #'first)))))
+
+
+;;; PRINT-SUMMARY  --  Internal
+;;;
+;;;    Handle the summary printing for MEMORY-USAGE.  Totals is a list of lists
+;;; (space-name . totals-for-space), where totals-for-space is the list
+;;; returned by TYPE-BREAKDOWN.
+;;;
+(defun print-summary (spaces totals)
+  (let ((summary (make-hash-table :test #'eq)))
+    (dolist (space-total totals)
+      (dolist (total (cdr space-total))
+	(push (cons (car space-total) total)
+	      (gethash (third total) summary))))
+
+    (collect ((summary-totals))
+      (maphash #'(lambda (k v)
+		   (declare (ignore k))
+		   (let ((sum 0))
+		     (declare (fixnum sum))
+		     (dolist (space-total v)
+		       (incf sum (first (cdr space-total))))
+		     (summary-totals (cons sum v))))
+	       summary)
+      
+      (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
+      (let ((summary-total-bytes 0)
+	    (summary-total-objects 0))
+	(declare (fixnum summary-total-bytes summary-total-objects))
+	(dolist (space-totals
+		 (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
+	  (let ((total-objects 0)
+		(total-bytes 0)
+		name)
+	    (declare (fixnum total-objects total-bytes))
+	    (collect ((spaces))
+	      (dolist (space-total space-totals)
+		(let ((total (cdr space-total)))
+		  (setq name (third total))
+		  (incf total-bytes (first total))
+		  (incf total-objects (second total))
+		  (spaces (cons (car space-total) (first total)))))
+	      (format t "~%~A:~%    ~:D bytes, ~:D object~:P"
+		      name total-bytes total-objects)
+	      (dolist (space (spaces))
+		(format t ", ~D% ~(~A~)"
+			(round (* (cdr space) 100) total-bytes)
+			(car space)))
+	      (format t ".~%")
+	      (incf summary-total-bytes total-bytes)
+	      (incf summary-total-objects total-objects))))
+	(format t "~%Summary total:~%    ~:D bytes, ~:D objects.~%"
+		summary-total-bytes summary-total-objects)))))
+
+
+;;; MEMORY-USAGE  --  Public
+;;;
+(defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
+			  (print-summary t))
+  "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."
+  (let* ((spaces (if (eq count-spaces t)
+		     '(:static :dynamic :read-only)
+		     count-spaces))
+	 (totals (mapcar #'(lambda (space)
+			     (cons space (type-breakdown space)))
+			 spaces)))
+
+    (dolist (space-total totals)
+      (when (or (eq print-spaces t)
+		(member (car space-total) print-spaces))
+	(format t "~2&Breakdown for ~(~A~) space:~2%" (car space-total))
+	(let ((total-objects 0)
+	      (total-bytes 0))
+	  (declare (fixnum total-objects total-bytes))
+	  (dolist (total (cdr space-total))
+	    (incf total-bytes (first total))
+	    (incf total-objects (second total))
+	    (format t "~%~A:~%    ~:D bytes, ~:D object~:P.~%"
+		    (third total) (first total) (second total)))
+	  (format t "~%Space total:~%    ~:D bytes, ~:D object~:P.~%"
+		  total-bytes total-objects))))
+
+    (when print-summary (print-summary spaces totals)))
+
+  (values))
+
+
+;;; COUNT-NO-OPS  --  Public
+;;;
+(defun count-no-ops (space)
+  "Print info about how much code and no-ops there are in Space."
+  (declare (type spaces space))
+  (let ((code-words 0)
+	(no-ops 0)
+	(total-bytes 0))
+    (declare (fixnum code-words no-ops))
+    (map-allocated-objects
+     #'(lambda (obj type size)
+ 	 (declare (fixnum size) (optimize (speed 3) (safety 0)))
+	 (when (eql type code-header-type)
+	   (incf total-bytes size)
+	   (let ((words (truly-the fixnum (%primitive 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)) (incf no-ops))))))
+     space)
+    
+    (format t
+	    "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
+	    total-bytes code-words no-ops
+	    (round (* no-ops 100) code-words)))
+  
+  (values))
+
+
+;;; STRUCTURE-USAGE  --  Public
+;;;
+(defun structure-usage (space &key (top-n 15))
+  (declare (type spaces space) (type (or fixnum null) top-n))
+  "Print a breakdown by structure type of all the structures allocated in
+  Space.  If TOP-N is true, print only information for the the TOP-N types with
+  largest usage."
+  (let ((totals (make-hash-table :test #'eq))
+	(total-objects 0)
+	(total-bytes 0))
+    (declare (fixnum total-objects total-bytes))
+    (map-allocated-objects
+     #'(lambda (obj type size)
+	 (declare (fixnum size) (optimize (speed 3) (safety 0)))
+	 (when (and (eql type simple-vector-type)
+		    (eql (get-header-data obj) vector-structure-subtype))
+	   (incf total-objects)
+	   (incf total-bytes size)
+	   (let* ((name (svref obj 0))
+		  (found (gethash name totals)))
+	     (cond (found
+		    (incf (the fixnum (car found)))
+		    (incf (the fixnum (cdr found)) size))
+		   (t
+		    (setf (gethash name totals) (cons 1 size)))))))
+     space)
+
+    (collect ((totals-list))
+      (maphash #'(lambda (name what)
+		   (totals-list (cons name what)))
+	       totals)
+      (let ((sorted (sort (totals-list) #'> :key #'cddr))
+	    (printed-bytes 0)
+	    (printed-objects 0))
+	(declare (fixnum printed-bytes printed-objects))
+	(dolist (what (if top-n
+			  (subseq sorted 0 (min (length sorted) top-n))
+			  sorted))
+	  (let ((bytes (cddr what))
+		(objects (cadr what)))
+	    (incf printed-bytes bytes)
+	    (incf printed-objects objects)
+	    (format t "~S: ~:D bytes, ~D object~:P.~%" (car what)
+		    bytes objects)))
+
+	(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.~%"
+		    residual-bytes residual-objects))))
+
+      (format t "Structure total: ~:D bytes, ~:D object~:P.~%"
+	      total-bytes total-objects)))
+
+  (values))