Changeset 13438


Ignore:
Timestamp:
Feb 8, 2010, 7:05:04 PM (10 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:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/library/core-files.lisp

    r13388 r13438  
    11;;;
    2 ;;;   Copyright (C) 2009, Clozure Associates and contributors
     2;;;   Copyright (C) 2009-2010 Clozure Associates and contributors
    33;;;   This file is part of Clozure CL.
    44;;;
     
    2222
    2323(export '(open-core close-core
    24           core-heap-utilization map-core-areas map-core-pointers
     24          core-heap-utilization map-core-areas map-core-region map-core-pointers
    2525          core-q core-l core-w core-b
    2626          core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p
    2727          core-uvtype core-uvtypep core-uvref core-uvsize
    28           core-car core-cdr core-object-type core-istruct-type
     28          core-car core-cdr core-object-typecode-type
     29          core-istruct-type core-struct-type core-instance-type
     30          core-object-type-key  core-type-string
    2931          copy-from-core core-list
    3032          core-keyword-package core-find-package core-find-symbol
     
    3739          core-instance-class
    3840          core-instance-p
    39           core-instance-class-name
    4041          core-string-equal
    4142          core-all-processes core-process-name
     
    7172
    7273(defmethod print-object :around ((core core-info) (stream t))
    73   (let ((*print-array* nil))
     74  (let ((*print-array* nil)
     75        (*print-simple-bit-vector* nil))
    7476    (call-next-method)))
    7577
     
    9395;; TODO: after load sections, check if highest heap address is a fixnum, and
    9496;; arrange to use fixnum-only versions of the reading functions.
    95 (defun open-core (pathname &key (method :mmap))
     97(defun open-core (pathname &key (method :mmap) (core-info nil))
     98  (when core-info (check-type core-info core-info))
    9699  (when *current-core*
    97100    (close-core))
    98101  (let* ((sections (read-sections pathname))
    99          (core (make-core-info :pathname pathname :sections sections)))
     102         (core (or core-info (make-core-info))))
     103    (setf (core-info-pathname core) pathname)
     104    (setf (core-info-sections core) sections)
     105    (setf (core-info-symbol-ptrs core) nil)
     106    (setf (core-info-classes-hash-table-ptr core) nil)
     107    (setf (core-info-lfun-names-table-ptr core) nil)
     108    (setf (core-info-process-class core) nil)
    100109    (ecase method
    101110      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
     
    103112                   (loop for data across sections do (incf (cdr data) offset))
    104113                   (setf (core-info-mapped-ivector core) mapped-vector)
    105                    (setf (core-info-raw-ivector core) vector))))
    106       (:stream (setf (core-info-stream core)
    107                      (open pathname :element-type '(unsigned-byte 8)))))
     114                   (setf (core-info-raw-ivector core) vector)
     115                   (setf (core-info-stream core) nil))))
     116      (:stream (setf (core-info-stream core) (open pathname :element-type '(unsigned-byte 8))
     117                     (core-info-mapped-ivector core) nil
     118                     (core-info-raw-ivector core) nil)))
    108119    (setq *current-core* core))
     120  ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core)))
     121  ;;  (error "Non-fixnum addresses not supported"))
    109122  pathname)
    110123
     
    196209  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
    197210  (when offset (stream-position s offset))
    198   (%i+ (core-stream-readb s nil) (ash (core-stream-readb s nil) 8)))
     211  (%i+ (core-stream-readb s nil) (%ilsl 8 (core-stream-readb s nil))))
    199212
    200213(defun core-stream-readl (s offset)
    201214  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
    202215  (when offset (stream-position s offset))
    203   (%i+ (core-stream-readw s nil) (ash (core-stream-readw s nil) 16)))
     216  (%i+ (core-stream-readw s nil) (%ilsl 16 (core-stream-readw s nil))))
    204217
    205218(defun core-stream-readq (s offset)
    206219  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
    207220  (when offset (stream-position s offset))
    208   (+ (core-stream-readl s nil) (ash (core-stream-readl s nil) 32)))
     221  (+ (core-stream-readl s nil) (ash (the fixnum (core-stream-readl s nil)) 32)))
    209222
    210223(defun core-ivector-readb (vec offset)
     
    215228(defun core-ivector-readw (vec offset)
    216229  (declare (optimize (speed 3) (safety 0)))
    217   (%i+ (core-ivector-readb vec offset) (ash (core-ivector-readb vec (%i+ offset 1)) 8)))
     230  (%i+ (core-ivector-readb vec offset) (%ilsl 8 (core-ivector-readb vec (+ offset 1)))))
    218231
    219232(defun core-ivector-readl (vec offset)
    220233  (declare (optimize (speed 3) (safety 0)))
    221   (%i+ (core-ivector-readw vec offset) (ash (core-ivector-readw vec (%i+ offset 2)) 16)))
     234  (%i+ (core-ivector-readw vec offset) (%ilsl 16 (core-ivector-readw vec (+ offset 2)))))
    222235
    223236(defun core-ivector-readq (vec offset)
    224237  (declare (optimize (speed 3) (safety 0)))
    225   (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (%i+ offset 4)) 32)))
     238  (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (+ offset 4)) 32)))
    226239
    227240
     
    302315
    303316(defun uvheader-size (header)
    304   (ash header (- target::num-subtag-bits)))
     317  (the fixnum (ash header (- target::num-subtag-bits))))
    305318
    306319(defun uvheader-byte-size (header)
     
    328341  (unless (eq symbol 'bogus)
    329342    (cond ((setq pos (position symbol *immheader-0-types*))
    330            (logior (ash pos target::ntagbits) target::fulltag-immheader-0))
     343           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-0))
    331344          ((setq pos (position symbol *immheader-1-types*))
    332            (logior (ash pos target::ntagbits) target::fulltag-immheader-1))
     345           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-1))
    333346          ((setq pos (position symbol *immheader-2-types*))
    334            (logior (ash pos target::ntagbits) target::fulltag-immheader-2))
     347           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-2))
    335348          ((setq pos (position symbol *nodeheader-0-types*))
    336            (logior (ash pos target::ntagbits) target::fulltag-nodeheader-0))
     349           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-0))
    337350          ((setq pos (position symbol *nodeheader-1-types*))
    338            (logior (ash pos target::ntagbits) target::fulltag-nodeheader-1)))))
     351           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-1)))))
    339352
    340353;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    364377
    365378(defun map-core-area (area-ptr fun)
    366   (let* ((ptr (core-q area-ptr target::area.low))
    367          (end (core-q area-ptr target::area.active)))
    368     (loop
    369       (when (>= ptr end) (return))
    370       (let ((header (core-q ptr)))
    371         (cond ((uvheader-p header)
    372                (let ((subtag (uvheader-typecode header)))
    373                  (funcall fun
    374                           (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
    375                                        ((eq subtag target::subtag-function) target::fulltag-function)
    376                                        (t target::fulltag-misc)))))
    377                (let* ((bytes (uvheader-byte-size header))
    378                       (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
    379                                        (1- target::dnode-size))))
    380                  (declare (fixnum bytes total))
    381                  (incf ptr total)))
    382               (t
    383                (funcall fun (+ ptr target::fulltag-cons))
    384                (incf ptr target::cons.size)))))))
     379  (map-core-region (core-q area-ptr target::area.low)
     380                   (core-q area-ptr target::area.active)
     381                   fun))
     382
     383(defun map-core-region (ptr end fun)
     384  (loop
     385    while (< ptr end) as header = (core-q ptr)
     386    do (cond ((uvheader-p header)
     387              (let ((subtag (uvheader-typecode header)))
     388                (funcall fun
     389                         (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
     390                                      ((eq subtag target::subtag-function) target::fulltag-function)
     391                                      (t target::fulltag-misc)))))
     392              (let* ((bytes (uvheader-byte-size header))
     393                     (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
     394                                      (1- target::dnode-size))))
     395                (declare (fixnum bytes total))
     396                (incf ptr total)))
     397             (t
     398              (funcall fun (+ ptr target::fulltag-cons))
     399              (incf ptr target::cons.size)))))
    385400
    386401
     
    437452         (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size))
    438453         (typecode (uvheader-typecode header))
    439          (tag (logand typecode target::fulltagmask))
     454         (tag (%ilogand typecode target::fulltagmask))
    440455         (len (uvheader-size header)))
    441456    (assert (< -1 index len))
    442     (cond ((or (eql tag target::fulltag-nodeheader-0)
    443                (eql tag target::fulltag-nodeheader-1))
    444            (core-q addr (ash index target::word-shift)))
    445           ((eql tag target::ivector-class-64-bit)
     457    (cond ((or (eq tag target::fulltag-nodeheader-0)
     458               (eq tag target::fulltag-nodeheader-1))
     459           (core-q addr (%ilsl target::word-shift index)))
     460          ((eq tag target::ivector-class-64-bit)
    446461           (cond ((eq typecode target::subtag-double-float-vector)
    447462                  (error "~s not implemented yet" 'target::subtag-double-float-vector))
    448463                 (t
    449                   (core-q addr (ash index target::word-shift)))))
     464                  (core-q addr (%ilsl target::word-shift index)))))
    450465          ((eq tag target::ivector-class-32-bit)
    451466           (cond ((eq typecode target::subtag-simple-base-string)
    452                   (code-char (core-l addr (ash index 2))))
     467                  (%code-char (core-l addr (%ilsl 2 index))))
    453468                 ((eq typecode target::subtag-single-float-vector)
    454469                  (error "~s not implemented yet" 'target::subtag-single-float-vector))
    455                  (t (core-l addr (ash index 2)))))
     470                 (t (core-l addr (%ilsl 2 index)))))
    456471          ((eq typecode target::subtag-bit-vector)
    457            (let ((byte (core-b addr (ash (+ index 7) -3))))
     472           (let ((byte (core-b addr (%iasr 3 (%i+ index 7)))))
    458473             (error "not implemented, for ~b" byte)))
    459474          ((>= typecode target::min-8-bit-ivector-subtag)
    460475           (core-b addr index))
    461           (t (core-w addr (ash index 1))))))
     476          (t (core-w addr (%ilsl 1 index))))))
    462477
    463478(defun core-uvsize (vec-ptr)
     
    472487  (core-q obj target::cons.cdr))
    473488
    474 (defun core-object-type (obj)
     489(defun core-object-typecode-type (obj)
    475490  (let ((fulltag (logand obj target::fulltagmask)))
    476491    (cond ((eq fulltag target::fulltag-cons) 'cons)
     
    490505           'bogus))))
    491506
     507(defun core-object-type-key (obj)
     508  ;; Returns either a symbol (for built-in types) or a pointer to type symbol or class.
     509  ;; Whatever it returns must be suitable for use in an eql hash table; use core-type-string
     510  ;; to get a printable rep.
     511  (let ((type (core-object-typecode-type obj)))
     512    (case type
     513      (internal-structure (core-istruct-type obj))
     514      (structure (core-struct-type obj))
     515      (instance (core-instance-type obj))
     516      (t type))))
     517
     518(defun core-type-string (object-type)
     519  (with-output-to-string (s)
     520    (if (fixnump object-type)
     521      (core-print object-type s)
     522      (prin1 object-type s))))
     523
    492524(defun core-istruct-type (obj)
    493525  (and (core-uvtypep obj :istruct)
    494526       (core-car (core-uvref obj 0))))
    495527       
     528(defun core-struct-type (obj)
     529  (and (core-uvtypep obj :struct)
     530       (core-uvref (core-car (core-uvref obj 0)) 1)))
     531
     532(defun core-instance-type (obj)
     533  (and (core-uvtypep obj :instance)
     534       (core-uvref (core-uvref (core-instance-class obj) instance.slots) %class.name)))
     535
    496536
    497537(defun core-object-type-and-size (obj)
     
    507547          (values (uvheader-type header) logsize total))))))
    508548
    509 (defun core-heap-utilization (&key area unit sort)
    510   (let* ((hash (make-hash-table :shared nil))
    511          (total-physsize 0)
    512          (div (ecase unit
    513                 ((nil) 1)
    514                 (:kb 1024.0d0)
    515                 (:mb (* 1024.0d0 1024.0d0))
    516                 (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
    517          (sort-key (ecase sort
    518                      (:count #'cadr)
    519                      (:logical-size #'caddr)
    520                      ((:physical-size nil) #'cdddr)))
     549(defun core-heap-utilization (&key (stream *debug-io*) area unit (sort :size) classes (threshold 0.00005))
     550  (let* ((obj-hash (make-hash-table :shared nil))
     551         (slotv-hash (make-hash-table :shared nil))
    521552         (all nil))
    522     (map-core-areas (lambda (obj)
     553    (map-core-areas (lambda (obj &aux (hash obj-hash))
    523554                      (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj)
     555                        (when classes
     556                          (when (core-uvtypep obj :slot-vector)
     557                            (setq hash slotv-hash
     558                                  obj (core-uvref obj slot-vector.instance)))
     559                          (setq type (core-object-type-key obj)))
    524560                        (let ((a (or (gethash type hash)
    525                                      (setf (gethash type hash) (list* 0 0 0)))))
     561                                     (setf (gethash type hash) (list 0 0 0)))))
    526562                          (incf (car a))
    527563                          (incf (cadr a) logsize)
    528                           (incf (cddr a) physsize))))
     564                          (incf (caddr a) physsize))))
    529565                    :area area)
    530566    (maphash (lambda (type data)
    531                (incf total-physsize (cddr data))
    532                (push (cons type data) all))
    533              hash)
    534     (setq all (sort all #'> :key sort-key))
    535     (format t "~&Object type~42tCount    Logical size   Physical size   % of Heap~%~50t~a~66t~:*~a"
    536             (ecase unit
    537               ((nil) " (in bytes)")
    538               (:kb   "(in kilobytes)")
    539               (:mb   "(in megabytes)")
    540               (:gb   "(in gigabytes)")))
    541     (loop for (type count logsize . physsize) in all
    542           do (if unit
    543                (format t "~&~a~36t~11d~16,2f~16,2f~11,2f%"
    544                        type
    545                        count
    546                        (/ logsize div)
    547                        (/ physsize div)
    548                        (* 100.0 (/ physsize total-physsize)))
    549                (format t "~&~a~36t~11d~16d~16d~11,2f%"
    550                        type
    551                        count
    552                        logsize
    553                        physsize
    554                        (* 100.0 (/ physsize total-physsize)))))
    555     (if unit
    556       (format t "~&Total~63t~16,2f" (/ total-physsize div))
    557       (format t "~&Total~63t~16d" total-physsize)))
    558   (values))
     567               (push (cons (core-type-string type) data) all))
     568             obj-hash)
     569    (maphash (lambda (type data)
     570               (push (cons (concatenate 'string (core-type-string type) " slot-vector") data) all))
     571             slotv-hash)
     572    (report-heap-utilization all :stream stream :unit unit :sort sort :threshold threshold)))
    559573
    560574
     
    563577(defmethod print-object ((obj unresolved-address) stream)
    564578  (let* ((address (unresolved-address-address obj)))
    565     (format stream "#<Core ~S~@[[~d]~] #x~x >"
    566             (core-object-type address)
     579    (format stream "#<Core ~A~@[[~d]~] #x~x >"
     580            (or (ignore-errors (core-type-string (core-object-type-key address)))
     581                (core-object-typecode-type address))
    567582            (and (core-uvector-p address) (core-uvsize address))
    568583            address)))
     
    615630         (len (uvheader-size header))
    616631         (vec (%alloc-misc len typecode)))
     632    (declare (type fixnum typecode tag len))
    617633    (cond ((or (eq tag target::fulltag-nodeheader-0)
    618634               (eq tag target::fulltag-nodeheader-1))
    619            (when (eql typecode target::subtag-function)
     635           (when (eq typecode target::subtag-function)
    620636             ;; Don't bother copying the code for now
    621637             (let ((skip (core-l addr)))
     638               (declare (fixnum skip))
    622639               (assert (<= 0 skip len))
    623640               (incf addr (ash skip target::word-shift))
    624641               (decf len skip)))
    625642           (dotimes (i len)
     643             (declare (fixnum i))
    626644             (setf (%svref vec i)
    627                    (copy-from-core (core-q addr (ash i target::word-shift)) :depth depth)))
     645                   (copy-from-core (core-q addr (%ilsl target::word-shift i)) :depth depth)))
    628646           (let ((ptrtag (logand vec-ptr target::fulltagmask)))
    629              (cond ((eql ptrtag target::fulltag-symbol)
     647             (cond ((eq ptrtag target::fulltag-symbol)
    630648                    (%symvector->symptr vec))
    631                    ((eql ptrtag target::fulltag-function)
     649                   ((eq ptrtag target::fulltag-function)
    632650                    (%function-vector-to-function vec))
    633651                   (t vec))))
     
    638656                 (t
    639657                  (dotimes (i len vec)
    640                     (setf (uvref vec i) (core-q addr (ash i target::word-shift)))))))
     658                    (setf (uvref vec i) (core-q addr (%ilsl target::word-shift i)))))))
    641659          ((eq tag target::ivector-class-32-bit)
    642660           (cond ((eq typecode target::subtag-simple-base-string)
    643661                  (dotimes (i len vec)
    644                     (setf (uvref vec i) (code-char (core-l addr (ash i 2))))))
     662                    (setf (uvref vec i) (%code-char (core-l addr (%ilsl 2 i))))))
    645663                 ((eq typecode target::subtag-single-float-vector)
    646664                  (warn "~s not implemented yet" 'target::subtag-single-float-vector)
     
    648666                 (t
    649667                  (dotimes (i len vec)
    650                     (setf (uvref vec i) (core-l addr (ash i 2)))))))
     668                    (setf (uvref vec i) (core-l addr (%ilsl 2 i)))))))
    651669          ((eq typecode target::subtag-bit-vector)
    652670           (warn "bit vector not implemented yet")
     
    657675          (t
    658676           (dotimes (i len vec)
    659              (setf (uvref vec i) (core-w addr (ash i 1))))))))
     677             (setf (uvref vec i) (core-w addr (%ilsl 1 i))))))))
    660678
    661679(defun map-core-pointers (fn &key area)
     
    672690                                      (len (uvheader-size header))
    673691                                      (addr (+ (logandc2 obj target::fulltagmask) target::node-size)))
    674                                  (when (eql typecode target::subtag-function)
     692                                 (declare (fixnum typecode len))
     693                                 (when (eq typecode target::subtag-function)
    675694                                   (let ((skip (core-l addr)))
     695                                     (declare (fixnum skip))
    676696                                     (assert (<= 0 skip len))
    677                                      (incf addr (ash skip target::word-shift))
     697                                     (incf addr (%ilsl target::word-shift skip))
    678698                                     (decf len skip)))
    679699                                 (dotimes (i len)
    680                                    (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))
     700                                   (funcall fn (core-q addr (%ilsl target::word-shift i)) obj i))))))))
    681701                  :area area))
    682702
     
    708728         (matchp (core-instance-class obj)))))
    709729
    710 
    711 (defun core-instance-class-name (obj)
    712   (let* ((class (core-instance-class obj))
    713          (class-slots (core-uvref class instance.slots))
    714          (name (core-uvref class-slots %class.name)))
    715     (core-symbol-name name)))
    716730
    717731(defun core-symptr (obj)
     
    858872              (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
    859873    (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
    860       (setq fun (core-q addr (ash (core-l addr) target::word-shift)))
     874      (setq fun (core-q addr (%ilsl target::word-shift (core-l addr))))
    861875      (when (core-uvtypep fun :simple-vector)
    862876        (setq fun (core-uvref fun 0)))
     
    928942
    929943(defun core-print (obj &optional (stream t) depth)
    930   ;; TODO: could dispatch on core-object-type...
     944  ;; TODO: could dispatch on core-object-typecode-type...
    931945  (cond ((core-nullp obj) (format stream "NIL"))
    932946        ((core-symbolp obj)
     
    950964         (format stream ")"))
    951965        (t (format stream "#<core ~s x~x>"
    952                    (core-object-type obj) obj))))
     966                   (core-object-typecode-type obj) obj))))
    953967
    954968(defun core-print-symbol (sym stream)
     
    10081022(defun core-print-process (proc stream)
    10091023  (format stream "#<~a ~s LWP(~d) #x~x>"
    1010           (core-instance-class-name proc)
     1024          (core-symbol-name (core-instance-type proc))
    10111025          (core-process-name proc)
    10121026          (core-q (core-process-tcr proc) target::tcr.native-thread-id)
Note: See TracChangeset for help on using the changeset viewer.