Changeset 13438

Timestamp:

Feb 8, 2010, 11:05:04 AM (15 years ago)

Author:

gz

Message:

add map-core-region

rename core-object-type to core-object-typecode-type, add core-struct-type and core-instance-type, add core-object-type-key which gets istruct/struct/instance classes, and core-type-string for printable rep.

remove core-instance-class-name

add some declarations

print-object(core-info): bind *print-simple-bit-vector* to nil

open-core: allow caller to pass in an existing core-info object

core-heap-utilization: make it understand slot vectors, add classes and threshold args, and use report-heap-utilization for reporting.

File:

• branches/working-0711/ccl/library/core-files.lisp (modified) (26 diffs)

branches/working-0711/ccl/library/core-files.lisp

@@ -1 +1 @@
 ;;;
-;;;   Copyright (C) 2009, Clozure Associates and contributors
+;;;   Copyright (C) 2009-2010 Clozure Associates and contributors
 ;;;   This file is part of Clozure CL.
 ;;;
@@ -22 +22 @@
 
 (export '(open-core close-core
-          core-heap-utilization map-core-areas map-core-pointers
+          core-heap-utilization map-core-areas map-core-region map-core-pointers
           core-q core-l core-w core-b
           core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p
           core-uvtype core-uvtypep core-uvref core-uvsize
-          core-car core-cdr core-object-type core-istruct-type
+          core-car core-cdr core-object-typecode-type
+          core-istruct-type core-struct-type core-instance-type
+          core-object-type-key  core-type-string
           copy-from-core core-list
           core-keyword-package core-find-package core-find-symbol
@@ -37 +39 @@
           core-instance-class
           core-instance-p
-          core-instance-class-name
           core-string-equal
           core-all-processes core-process-name
@@ -71 +72 @@
 
 (defmethod print-object :around ((core core-info) (stream t))
-  (let ((*print-array* nil))
+  (let ((*print-array* nil)
+        (*print-simple-bit-vector* nil))
     (call-next-method)))
 
@@ -93 +95 @@
 ;; TODO: after load sections, check if highest heap address is a fixnum, and
 ;; arrange to use fixnum-only versions of the reading functions.
-(defun open-core (pathname &key (method :mmap))
+(defun open-core (pathname &key (method :mmap) (core-info nil))
+  (when core-info (check-type core-info core-info))
   (when *current-core*
     (close-core))
   (let* ((sections (read-sections pathname))
-         (core (make-core-info :pathname pathname :sections sections)))
+         (core (or core-info (make-core-info))))
+    (setf (core-info-pathname core) pathname)
+    (setf (core-info-sections core) sections)
+    (setf (core-info-symbol-ptrs core) nil)
+    (setf (core-info-classes-hash-table-ptr core) nil)
+    (setf (core-info-lfun-names-table-ptr core) nil)
+    (setf (core-info-process-class core) nil)
     (ecase method
       (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
@@ -103 +112 @@
                    (loop for data across sections do (incf (cdr data) offset))
                    (setf (core-info-mapped-ivector core) mapped-vector)
-                   (setf (core-info-raw-ivector core) vector))))
-      (:stream (setf (core-info-stream core)
-                     (open pathname :element-type '(unsigned-byte 8)))))
+                   (setf (core-info-raw-ivector core) vector)
+                   (setf (core-info-stream core) nil))))
+      (:stream (setf (core-info-stream core) (open pathname :element-type '(unsigned-byte 8))
+                     (core-info-mapped-ivector core) nil
+                     (core-info-raw-ivector core) nil)))
     (setq *current-core* core))
+  ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core)))
+  ;;  (error "Non-fixnum addresses not supported"))
   pathname)
 
@@ -196 +209 @@
   (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
   (when offset (stream-position s offset))
-  (%i+ (core-stream-readb s nil) (ash (core-stream-readb s nil) 8)))
+  (%i+ (core-stream-readb s nil) (%ilsl 8 (core-stream-readb s nil))))
 
 (defun core-stream-readl (s offset)
   (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
   (when offset (stream-position s offset))
-  (%i+ (core-stream-readw s nil) (ash (core-stream-readw s nil) 16)))
+  (%i+ (core-stream-readw s nil) (%ilsl 16 (core-stream-readw s nil))))
 
 (defun core-stream-readq (s offset)
   (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
   (when offset (stream-position s offset))
-  (+ (core-stream-readl s nil) (ash (core-stream-readl s nil) 32)))
+  (+ (core-stream-readl s nil) (ash (the fixnum (core-stream-readl s nil)) 32)))
 
 (defun core-ivector-readb (vec offset)
@@ -215 +228 @@
 (defun core-ivector-readw (vec offset)
   (declare (optimize (speed 3) (safety 0)))
-  (%i+ (core-ivector-readb vec offset) (ash (core-ivector-readb vec (%i+ offset 1)) 8)))
+  (%i+ (core-ivector-readb vec offset) (%ilsl 8 (core-ivector-readb vec (+ offset 1)))))
 
 (defun core-ivector-readl (vec offset)
   (declare (optimize (speed 3) (safety 0)))
-  (%i+ (core-ivector-readw vec offset) (ash (core-ivector-readw vec (%i+ offset 2)) 16)))
+  (%i+ (core-ivector-readw vec offset) (%ilsl 16 (core-ivector-readw vec (+ offset 2)))))
 
 (defun core-ivector-readq (vec offset)
   (declare (optimize (speed 3) (safety 0)))
-  (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (%i+ offset 4)) 32)))
+  (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (+ offset 4)) 32)))
 
 
@@ -302 +315 @@
 
 (defun uvheader-size (header)
-  (ash header (- target::num-subtag-bits)))
+  (the fixnum (ash header (- target::num-subtag-bits))))
 
 (defun uvheader-byte-size (header)
@@ -328 +341 @@
   (unless (eq symbol 'bogus)
     (cond ((setq pos (position symbol *immheader-0-types*))
-           (logior (ash pos target::ntagbits) target::fulltag-immheader-0))
+           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-0))
           ((setq pos (position symbol *immheader-1-types*))
-           (logior (ash pos target::ntagbits) target::fulltag-immheader-1))
+           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-1))
           ((setq pos (position symbol *immheader-2-types*))
-           (logior (ash pos target::ntagbits) target::fulltag-immheader-2))
+           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-2))
           ((setq pos (position symbol *nodeheader-0-types*))
-           (logior (ash pos target::ntagbits) target::fulltag-nodeheader-0))
+           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-0))
           ((setq pos (position symbol *nodeheader-1-types*))
-           (logior (ash pos target::ntagbits) target::fulltag-nodeheader-1)))))
+           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-1)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -364 +377 @@
 
 (defun map-core-area (area-ptr fun)
-  (let* ((ptr (core-q area-ptr target::area.low))
-         (end (core-q area-ptr target::area.active)))
-    (loop
-      (when (>= ptr end) (return))
-      (let ((header (core-q ptr)))
-        (cond ((uvheader-p header)
-               (let ((subtag (uvheader-typecode header)))
-                 (funcall fun
-                          (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
-                                       ((eq subtag target::subtag-function) target::fulltag-function)
-                                       (t target::fulltag-misc)))))
-               (let* ((bytes (uvheader-byte-size header))
-                      (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
-                                       (1- target::dnode-size))))
-                 (declare (fixnum bytes total))
-                 (incf ptr total)))
-              (t
-               (funcall fun (+ ptr target::fulltag-cons))
-               (incf ptr target::cons.size)))))))
+  (map-core-region (core-q area-ptr target::area.low)
+                   (core-q area-ptr target::area.active)
+                   fun))
+
+(defun map-core-region (ptr end fun)
+  (loop
+    while (< ptr end) as header = (core-q ptr)
+    do (cond ((uvheader-p header)
+              (let ((subtag (uvheader-typecode header)))
+                (funcall fun
+                         (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
+                                      ((eq subtag target::subtag-function) target::fulltag-function)
+                                      (t target::fulltag-misc)))))
+              (let* ((bytes (uvheader-byte-size header))
+                     (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
+                                      (1- target::dnode-size))))
+                (declare (fixnum bytes total))
+                (incf ptr total)))
+             (t
+              (funcall fun (+ ptr target::fulltag-cons))
+              (incf ptr target::cons.size)))))
 
 
@@ -437 +452 @@
          (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size))
          (typecode (uvheader-typecode header))
-         (tag (logand typecode target::fulltagmask))
+         (tag (%ilogand typecode target::fulltagmask))
          (len (uvheader-size header)))
     (assert (< -1 index len))
-    (cond ((or (eql tag target::fulltag-nodeheader-0)
-               (eql tag target::fulltag-nodeheader-1))
-           (core-q addr (ash index target::word-shift)))
-          ((eql tag target::ivector-class-64-bit)
+    (cond ((or (eq tag target::fulltag-nodeheader-0)
+               (eq tag target::fulltag-nodeheader-1))
+           (core-q addr (%ilsl target::word-shift index)))
+          ((eq tag target::ivector-class-64-bit)
            (cond ((eq typecode target::subtag-double-float-vector)
                   (error "~s not implemented yet" 'target::subtag-double-float-vector))
                  (t
-                  (core-q addr (ash index target::word-shift)))))
+                  (core-q addr (%ilsl target::word-shift index)))))
           ((eq tag target::ivector-class-32-bit)
            (cond ((eq typecode target::subtag-simple-base-string)
-                  (code-char (core-l addr (ash index 2))))
+                  (%code-char (core-l addr (%ilsl 2 index))))
                  ((eq typecode target::subtag-single-float-vector)
                   (error "~s not implemented yet" 'target::subtag-single-float-vector))
-                 (t (core-l addr (ash index 2)))))
+                 (t (core-l addr (%ilsl 2 index)))))
           ((eq typecode target::subtag-bit-vector)
-           (let ((byte (core-b addr (ash (+ index 7) -3))))
+           (let ((byte (core-b addr (%iasr 3 (%i+ index 7)))))
              (error "not implemented, for ~b" byte)))
           ((>= typecode target::min-8-bit-ivector-subtag)
            (core-b addr index))
-          (t (core-w addr (ash index 1))))))
+          (t (core-w addr (%ilsl 1 index))))))
 
 (defun core-uvsize (vec-ptr)
@@ -472 +487 @@
   (core-q obj target::cons.cdr))
 
-(defun core-object-type (obj)
+(defun core-object-typecode-type (obj)
   (let ((fulltag (logand obj target::fulltagmask)))
     (cond ((eq fulltag target::fulltag-cons) 'cons)
@@ -490 +505 @@
            'bogus))))
 
+(defun core-object-type-key (obj)
+  ;; Returns either a symbol (for built-in types) or a pointer to type symbol or class.
+  ;; Whatever it returns must be suitable for use in an eql hash table; use core-type-string
+  ;; to get a printable rep.
+  (let ((type (core-object-typecode-type obj)))
+    (case type
+      (internal-structure (core-istruct-type obj))
+      (structure (core-struct-type obj))
+      (instance (core-instance-type obj))
+      (t type))))
+
+(defun core-type-string (object-type)
+  (with-output-to-string (s)
+    (if (fixnump object-type)
+      (core-print object-type s)
+      (prin1 object-type s))))
+
 (defun core-istruct-type (obj)
   (and (core-uvtypep obj :istruct)
        (core-car (core-uvref obj 0))))
        
+(defun core-struct-type (obj)
+  (and (core-uvtypep obj :struct)
+       (core-uvref (core-car (core-uvref obj 0)) 1)))
+
+(defun core-instance-type (obj)
+  (and (core-uvtypep obj :instance)
+       (core-uvref (core-uvref (core-instance-class obj) instance.slots) %class.name)))
+
 
 (defun core-object-type-and-size (obj)
@@ -507 +547 @@
           (values (uvheader-type header) logsize total))))))
 
-(defun core-heap-utilization (&key area unit sort)
-  (let* ((hash (make-hash-table :shared nil))
-         (total-physsize 0)
-         (div (ecase unit
-                ((nil) 1)
-                (:kb 1024.0d0)
-                (:mb (* 1024.0d0 1024.0d0))
-                (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
-         (sort-key (ecase sort
-                     (:count #'cadr)
-                     (:logical-size #'caddr)
-                     ((:physical-size nil) #'cdddr)))
+(defun core-heap-utilization (&key (stream *debug-io*) area unit (sort :size) classes (threshold 0.00005))
+  (let* ((obj-hash (make-hash-table :shared nil))
+         (slotv-hash (make-hash-table :shared nil))
          (all nil))
-    (map-core-areas (lambda (obj)
+    (map-core-areas (lambda (obj &aux (hash obj-hash))
                       (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj)
+                        (when classes
+                          (when (core-uvtypep obj :slot-vector)
+                            (setq hash slotv-hash
+                                  obj (core-uvref obj slot-vector.instance)))
+                          (setq type (core-object-type-key obj)))
                         (let ((a (or (gethash type hash)
-                                     (setf (gethash type hash) (list* 0 0 0)))))
+                                     (setf (gethash type hash) (list 0 0 0)))))
                           (incf (car a))
                           (incf (cadr a) logsize)
-                          (incf (cddr a) physsize))))
+                          (incf (caddr a) physsize))))
                     :area area)
     (maphash (lambda (type data)
-               (incf total-physsize (cddr data))
-               (push (cons type data) all))
-             hash)
-    (setq all (sort all #'> :key sort-key))
-    (format t "~&Object type~42tCount    Logical size   Physical size   % of Heap~%~50t~a~66t~:*~a"
-            (ecase unit
-              ((nil) " (in bytes)")
-              (:kb   "(in kilobytes)")
-              (:mb   "(in megabytes)")
-              (:gb   "(in gigabytes)")))
-    (loop for (type count logsize . physsize) in all
-          do (if unit
-               (format t "~&~a~36t~11d~16,2f~16,2f~11,2f%"
-                       type
-                       count
-                       (/ logsize div)
-                       (/ physsize div)
-                       (* 100.0 (/ physsize total-physsize)))
-               (format t "~&~a~36t~11d~16d~16d~11,2f%"
-                       type
-                       count
-                       logsize
-                       physsize
-                       (* 100.0 (/ physsize total-physsize)))))
-    (if unit
-      (format t "~&Total~63t~16,2f" (/ total-physsize div))
-      (format t "~&Total~63t~16d" total-physsize)))
-  (values))
+               (push (cons (core-type-string type) data) all))
+             obj-hash)
+    (maphash (lambda (type data)
+               (push (cons (concatenate 'string (core-type-string type) " slot-vector") data) all))
+             slotv-hash)
+    (report-heap-utilization all :stream stream :unit unit :sort sort :threshold threshold)))
 
 
@@ -563 +577 @@
 (defmethod print-object ((obj unresolved-address) stream)
   (let* ((address (unresolved-address-address obj)))
-    (format stream "#<Core ~S~@[[~d]~] #x~x >" 
-            (core-object-type address)
+    (format stream "#<Core ~A~@[[~d]~] #x~x >"
+            (or (ignore-errors (core-type-string (core-object-type-key address)))
+                (core-object-typecode-type address))
             (and (core-uvector-p address) (core-uvsize address))
             address)))
@@ -615 +630 @@
          (len (uvheader-size header))
          (vec (%alloc-misc len typecode)))
+    (declare (type fixnum typecode tag len))
     (cond ((or (eq tag target::fulltag-nodeheader-0)
                (eq tag target::fulltag-nodeheader-1))
-           (when (eql typecode target::subtag-function)
+           (when (eq typecode target::subtag-function)
              ;; Don't bother copying the code for now
              (let ((skip (core-l addr)))
+               (declare (fixnum skip))
                (assert (<= 0 skip len))
                (incf addr (ash skip target::word-shift))
                (decf len skip)))
            (dotimes (i len)
+             (declare (fixnum i))
              (setf (%svref vec i)
-                   (copy-from-core (core-q addr (ash i target::word-shift)) :depth depth)))
+                   (copy-from-core (core-q addr (%ilsl target::word-shift i)) :depth depth)))
            (let ((ptrtag (logand vec-ptr target::fulltagmask)))
-             (cond ((eql ptrtag target::fulltag-symbol)
+             (cond ((eq ptrtag target::fulltag-symbol)
                     (%symvector->symptr vec))
-                   ((eql ptrtag target::fulltag-function)
+                   ((eq ptrtag target::fulltag-function)
                     (%function-vector-to-function vec))
                    (t vec))))
@@ -638 +656 @@
                  (t
                   (dotimes (i len vec)
-                    (setf (uvref vec i) (core-q addr (ash i target::word-shift)))))))
+                    (setf (uvref vec i) (core-q addr (%ilsl target::word-shift i)))))))
           ((eq tag target::ivector-class-32-bit)
            (cond ((eq typecode target::subtag-simple-base-string)
                   (dotimes (i len vec)
-                    (setf (uvref vec i) (code-char (core-l addr (ash i 2))))))
+                    (setf (uvref vec i) (%code-char (core-l addr (%ilsl 2 i))))))
                  ((eq typecode target::subtag-single-float-vector)
                   (warn "~s not implemented yet" 'target::subtag-single-float-vector)
@@ -648 +666 @@
                  (t
                   (dotimes (i len vec)
-                    (setf (uvref vec i) (core-l addr (ash i 2)))))))
+                    (setf (uvref vec i) (core-l addr (%ilsl 2 i)))))))
           ((eq typecode target::subtag-bit-vector)
            (warn "bit vector not implemented yet")
@@ -657 +675 @@
           (t
            (dotimes (i len vec)
-             (setf (uvref vec i) (core-w addr (ash i 1))))))))
+             (setf (uvref vec i) (core-w addr (%ilsl 1 i))))))))
 
 (defun map-core-pointers (fn &key area)
@@ -672 +690 @@
                                       (len (uvheader-size header))
                                       (addr (+ (logandc2 obj target::fulltagmask) target::node-size)))
-                                 (when (eql typecode target::subtag-function)
+                                 (declare (fixnum typecode len))
+                                 (when (eq typecode target::subtag-function)
                                    (let ((skip (core-l addr)))
+                                     (declare (fixnum skip))
                                      (assert (<= 0 skip len))
-                                     (incf addr (ash skip target::word-shift))
+                                     (incf addr (%ilsl target::word-shift skip))
                                      (decf len skip)))
                                  (dotimes (i len)
-                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))
+                                   (funcall fn (core-q addr (%ilsl target::word-shift i)) obj i))))))))
                   :area area))
 
@@ -708 +728 @@
          (matchp (core-instance-class obj)))))
 
-
-(defun core-instance-class-name (obj)
-  (let* ((class (core-instance-class obj))
-         (class-slots (core-uvref class instance.slots))
-         (name (core-uvref class-slots %class.name)))
-    (core-symbol-name name)))
 
 (defun core-symptr (obj)
@@ -858 +872 @@
               (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
     (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
-      (setq fun (core-q addr (ash (core-l addr) target::word-shift)))
+      (setq fun (core-q addr (%ilsl target::word-shift (core-l addr))))
       (when (core-uvtypep fun :simple-vector)
         (setq fun (core-uvref fun 0)))
@@ -928 +942 @@
 
 (defun core-print (obj &optional (stream t) depth)
-  ;; TODO: could dispatch on core-object-type...
+  ;; TODO: could dispatch on core-object-typecode-type...
   (cond ((core-nullp obj) (format stream "NIL"))
         ((core-symbolp obj)
@@ -950 +964 @@
          (format stream ")"))
         (t (format stream "#<core ~s x~x>"
-                   (core-object-type obj) obj))))
+                   (core-object-typecode-type obj) obj))))
 
 (defun core-print-symbol (sym stream)
@@ -1008 +1022 @@
 (defun core-print-process (proc stream)
   (format stream "#<~a ~s LWP(~d) #x~x>"
-          (core-instance-class-name proc)
+          (core-symbol-name (core-instance-type proc))
           (core-process-name proc)
           (core-q (core-process-tcr proc) target::tcr.native-thread-id)