Changeset 13461


Ignore:
Timestamp:
Feb 24, 2010, 5:18:55 PM (10 years ago)
Author:
gz
Message:

make map-core-areas accept :area :tenured to only look at the tenured area. Also handle :dynamic specially so works even if areas have been renumbered since the core file was made.

make core-offset-for-address do bounds checking, signal an error if not in any known section. Catch that error and do something reasonable when printing or just looking up types.

File:
1 edited

Legend:

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

    r13441 r13461  
    110110      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
    111111                 (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector)
    112                    (loop for data across sections do (incf (cdr data) offset))
     112                   (loop for data across sections do (incf (cadr data) offset))
    113113                   (setf (core-info-mapped-ivector core) mapped-vector)
    114114                   (setf (core-info-raw-ivector core) vector)
     
    167167                           (unless (eql size 0)
    168168                             (list (list address filepos size)))))))
    169            (sections (cons (list most-positive-fixnum 0 0) sections));; hack for loop below
    170169           (sections (sort sections #'< :key #'car));; sort by address
     170           (sections (let ((last (car (last sections))))  ;; hack for loop below
     171                       (nconc sections (list (list (+ (car last) (caddr last) 1) 0 0)))))
    171172           (sections (loop
    172173                       with cur-address = -1
     
    176177                       unless (or (= (+ cur-filepos (- address cur-address)) filepos)
    177178                                  (= cur-address cur-end))
    178                          collect (cons cur-address cur-filepos)
     179                         collect (list* cur-address cur-filepos cur-end)
    179180                       do (if (= (+ cur-filepos (- address cur-address)) filepos)
    180181                            (setq cur-end (max (+ address size) cur-end))
     
    193194         (ftype (function (integer) fixnum) core-offset-for-address))
    194195
     196(define-condition invalid-core-address (simple-error) ())
     197
     198(declaim (inline core-section-for-address))
     199(defun core-section-for-address (address)
     200  (loop with sections = (core-info-sections (current-core))
     201        with len fixnum = (length sections)
     202        with low fixnum = -1
     203        with high fixnum = len
     204        do (let ((half (the fixnum (ash (%i+ high low) -1))))
     205             (declare (fixnum half))
     206             (when (eq half low)
     207               (return (and (%i<= 0 half)
     208                            (%i< half len)
     209                            (let ((sect (%svref sections half)))
     210                              (and (< address (%cddr (%svref sections half))) sect)))))
     211             (let ((sect (%svref sections half)))
     212               (if (%i<= (%car sect) address)
     213                 (setq low half)
     214                 (setq high half))))))
     215
     216(defun core-heap-address-p (address)
     217  (core-section-for-address address))
     218
    195219(defun core-offset-for-address (address)
    196   ;; sections are sorted, so could do binary search if this became a bottleneck.
    197   ;; (there are around 50 sections)
    198   (or (loop for prev = nil then sect as sect across (core-info-sections (current-core))
    199             do (when (< address (car sect))
    200                  (return (and prev (+ (cdr prev) (- address (car prev)))))))
    201       (error "Unknown core address x~x" address)))
     220  (let ((sect (core-section-for-address address)))
     221    (if sect
     222      (+ (%cadr sect) (- address (%car sect)))
     223      (error 'invalid-core-address
     224             :format-control "Unknown core address x~x"
     225             :format-arguments (list address)))))
     226
    202227
    203228(defun core-stream-readb (s offset)
     
    356381
    357382(defun map-core-areas (function &key area)
    358   (setq area (cond ((or (eq area t) (eq area nil)) nil)
    359                    ((consp area) (mapcar #'heap-area-code area))
    360                    (t (list (heap-area-code area)))))
    361   (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
    362           then (core-q area-ptr target::area.succ)
    363         as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
    364         until (= code area-void)
    365         do (when (and (<= area-readonly code)
    366                       (<= code area-dynamic)
    367                       (or (null area) (member code area))
    368                       (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
    369              #+debug
    370              (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
    371                      area-ptr (core-area-name code)
    372                      (core-q area-ptr target::area.low)
    373                      (core-q area-ptr target::area.active)
    374                      (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
    375                      (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
    376              (map-core-area area-ptr function))))
     383  (if (eq area :tenured)
     384    (map-core-area (core-q (kernel-global-address 'tenured-area)) function)
     385    (loop with area = (cond ((or (eq area t) (eq area nil)) nil)
     386                            ;; Special-case dynamic to work even if areas have been renumbered:
     387                            ;;  assume the first area is always dynamic, use its code.
     388                            ((eq area :dynamic)
     389                             (list (ash (core-q (core-q (core-q (kernel-global-address 'all-areas))
     390                                                        target::area.succ)
     391                                                target::area.code)
     392                                        (- target::fixnum-shift))))
     393                            ((consp area) (mapcar #'heap-area-code area))
     394                            (t (list (heap-area-code area))))
     395          for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
     396            then (core-q area-ptr target::area.succ)
     397          as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
     398          until (= code area-void)
     399          do (when (and (<= area-readonly code)
     400                        (<= code area-dynamic)
     401                        (or (null area) (member code area))
     402                        (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
     403               #+debug
     404               (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
     405                       area-ptr (core-area-name code)
     406                       (core-q area-ptr target::area.low)
     407                       (core-q area-ptr target::area.active)
     408                       (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
     409                       (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
     410               (map-core-area area-ptr function)))))
    377411
    378412(defun map-core-area (area-ptr fun)
     
    498532           (type-of (%%raw-obj obj)))
    499533          ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address)
    500           ((eq fulltag target::fulltag-misc) (core-uvtype obj))
     534          ((eq fulltag target::fulltag-misc)
     535           ;; (core-uvtype obj)
     536           (handler-case (core-uvtype obj) (invalid-core-address () 'unmapped)))
    501537          ((eq fulltag target::fulltag-symbol) 'symbol)
    502538          ;; TODO: Could get hairier based on lfun-bits, but usually don't care.
     
    577613(defmethod print-object ((obj unresolved-address) stream)
    578614  (let* ((address (unresolved-address-address obj)))
    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))
    582             (and (core-uvector-p address) (core-uvsize address))
    583             address)))
     615    (if (and (core-uvector-p address)
     616             (not (handler-case (core-uvheader address) (invalid-core-address () nil))))
     617      (format stream "#<Unmapped #x~x >" address)
     618      (format stream "#<Core ~A~@[[~d]~] #x~x >"
     619              (or (ignore-errors (core-type-string (core-object-type-key address)))
     620                  (core-object-typecode-type address))
     621              (and (core-uvector-p address) (core-uvsize address))
     622            address))))
    584623
    585624(defun copy-from-core (obj &key (depth 1))
     
    597636          ((< (decf depth) 0)
    598637           (make-unresolved-address :address obj))
    599           ((%i<= target::fulltag-misc fulltag)
     638          ((and (%i<= target::fulltag-misc fulltag)
     639                (handler-case (core-uvheader obj) (invalid-core-address nil)))
    600640           (or (and (core-uvtypep obj :package)
    601641                    (find-package (core-package-name obj)))
     
    9751015           (format stream ":"))
    9761016          (t (let ((pkgname (core-package-name package)))
    977                (unless (string-equal pkgname "COMMON-LISP")
    978                  (format stream "~a::" pkgname)))))
    979     (format stream "~a" (core-symbol-name sym))))
     1017               (etypecase pkgname
     1018                 (unresolved-address (format stream "@~x::" (unresolved-address-address pkgname)))
     1019                 (string (unless (string-equal pkgname "COMMON-LISP")
     1020                           (format stream "~a::" pkgname)))))))
     1021    (let ((symname (core-symbol-name sym)))
     1022      (etypecase symname
     1023        (unresolved-address (format stream "@~x" (unresolved-address-address symname)))
     1024        (string (format stream "~a" symname)))))
     1025  (values))
    9801026
    9811027(defun core-lfun-bits (fun)
Note: See TracChangeset for help on using the changeset viewer.