Index: /branches/working-0711/ccl/library/core-files.lisp =================================================================== --- /branches/working-0711/ccl/library/core-files.lisp (revision 13437) +++ /branches/working-0711/ccl/library/core-files.lisp (revision 13438) @@ -1,4 +1,4 @@ ;;; -;;; Copyright (C) 2009, Clozure Associates and contributors +;;; Copyright (C) 2009-2010 Clozure Associates and contributors ;;; This file is part of Clozure CL. ;;; @@ -22,9 +22,11 @@ (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,5 +39,4 @@ core-instance-class core-instance-p - core-instance-class-name core-string-equal core-all-processes core-process-name @@ -71,5 +72,6 @@ (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,9 +95,16 @@ ;; 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,8 +112,12 @@ (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,15 +209,15 @@ (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,13 +228,13 @@ (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,5 +315,5 @@ (defun uvheader-size (header) - (ash header (- target::num-subtag-bits))) + (the fixnum (ash header (- target::num-subtag-bits)))) (defun uvheader-byte-size (header) @@ -328,13 +341,13 @@ (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,23 +377,25 @@ (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,27 +452,27 @@ (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,5 +487,5 @@ (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,8 +505,33 @@ '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,54 +547,28 @@ (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,6 +577,7 @@ (defmethod print-object ((obj unresolved-address) stream) (let* ((address (unresolved-address-address obj))) - (format stream "#" - (core-object-type address) + (format stream "#" + (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,19 +630,22 @@ (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,9 +656,9 @@ (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,5 +666,5 @@ (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,5 +675,5 @@ (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,11 +690,13 @@ (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,10 +728,4 @@ (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,5 +872,5 @@ (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,5 +942,5 @@ (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,5 +964,5 @@ (format stream ")")) (t (format stream "#" - (core-object-type obj) obj)))) + (core-object-typecode-type obj) obj)))) (defun core-print-symbol (sym stream) @@ -1008,5 +1022,5 @@ (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)