Changeset 13465


Ignore:
Timestamp:
Feb 26, 2010, 8:26:02 PM (9 years ago)
Author:
gz
Message:

add :image arg to core-open specify an image file, use it to load any readonly areas missing from the core file (which is usually where class and packae names live)

Location:
branches/working-0711/ccl/library
Files:
2 edited

Legend:

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

    r13461 r13465  
    2020#+:linuxx8664-target
    2121(progn
     22
     23
     24(defconstant $image-nsections 7)
     25(defconstant $image-data-offset-64 9)
     26(defconstant $image-header-size 16)
     27
     28(defconstant $image-sect-code 0)
     29(defconstant $image-sect-size 4)
     30(defconstant $image-sect-header-size 8)
    2231
    2332(export '(open-core close-core
     
    6170  sections
    6271  ;; uses either stream or ivector, determined at runtime
    63   stream
    64   mapped-ivector
    65   raw-ivector
     72  streams
     73  ivectors
    6674  ;; caches
    6775  symbol-ptrs
     
    8795    (setq *current-core* nil)
    8896    (when core
    89       (when (core-info-stream core)
    90         (close (core-info-stream core)))
    91       (when (core-info-mapped-ivector core)
    92         (unmap-ivector (core-info-mapped-ivector core)))
     97      (map nil #'close (core-info-streams core))
     98      (map nil #'unmap-ivector (core-info-ivectors core))
    9399      t)))
     100
     101;
     102(defmacro area-loop (with ptrvar &body body)
     103  (assert (eq with 'with))
     104  (let ((before (loop while (eq (car body) 'with)
     105                      nconc (list (pop body) (pop body) (pop body) (pop body)))))
     106    `(loop ,@before
     107           for ,ptrvar = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
     108             then (core-q ,ptrvar target::area.succ)
     109           until (eq (core-q area-ptr target::area.code) (ash area-void target::fixnum-shift))
     110           ,@body)))
     111
     112(def-accessor-macros %svref
     113  %core-sect.start-addr
     114  %core-sect.offset
     115  %core-sect.end-addr
     116  %core-sect.ivector
     117  %core-sect.stream)
     118
     119(defun make-core-sect (&key start end offset ivector stream)
     120  (vector start offset end ivector stream))
     121
    94122
    95123;; TODO: after load sections, check if highest heap address is a fixnum, and
    96124;; arrange to use fixnum-only versions of the reading functions.
    97 (defun open-core (pathname &key (method :mmap) (core-info nil))
     125(defun open-core (pathname &key (image nil) (method :mmap) (core-info nil))
    98126  (when core-info (check-type core-info core-info))
    99127  (when *current-core*
     
    107135    (setf (core-info-lfun-names-table-ptr core) nil)
    108136    (setf (core-info-process-class core) nil)
     137    (setf (core-info-ivectors core) nil)
     138    (setf (core-info-streams core) nil)
    109139    (ecase method
    110140      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
    111141                 (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector)
    112                    (loop for data across sections do (incf (cadr data) offset))
    113                    (setf (core-info-mapped-ivector core) mapped-vector)
    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)))
     142                   (push mapped-vector (core-info-ivectors core))
     143                   (loop for sect across sections
     144                         do (incf (%core-sect.offset sect) offset)
     145                         do (setf (%core-sect.ivector sect) vector)))))
     146      (:stream (let ((stream (open pathname :element-type '(unsigned-byte 8)
     147                                   :sharing :lock)))
     148                 (push stream (core-info-streams core))
     149                 (loop for sect across sections do (setf (%core-sect.stream sect) stream)))))
    119150    (setq *current-core* core))
    120151  ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core)))
    121152  ;;  (error "Non-fixnum addresses not supported"))
     153  (when (and image
     154             (area-loop with area-ptr
     155                        thereis (and (eq (core-q area-ptr target::area.code)
     156                                         (ash area-readonly target::fixnum-shift))
     157                                     (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active))
     158                                     (not (core-section-for-address (core-q area-ptr target::area.low))))))
     159    ;; Have a missing readonly section, and an image file that might contain it.
     160    (add-core-sections-from-image image))
    122161  pathname)
    123162
     
    177216                       unless (or (= (+ cur-filepos (- address cur-address)) filepos)
    178217                                  (= cur-address cur-end))
    179                          collect (list* cur-address cur-filepos cur-end)
     218                         collect (make-core-sect
     219                                      :start cur-address
     220                                      :end cur-end
     221                                      :offset cur-filepos)
    180222                       do (if (= (+ cur-filepos (- address cur-address)) filepos)
    181223                            (setq cur-end (max (+ address size) cur-end))
     
    186228
    187229
     230(defun add-core-sections-from-image (pathname)
     231  (with-open-file (header-stream  pathname :element-type '(signed-byte 32))
     232    (labels ((read-at (&optional pos)
     233               (when pos (file-position header-stream pos))
     234               (read-byte header-stream))
     235             (readn (pos) (+ (logand #xFFFFFFFF (read-at pos)) (ash (read-at) 32))))
     236      (let* ((sig '(#x4F70656E #x4D434C49 #x6D616765 #x46696C65))
     237             (end (file-length header-stream))
     238             (page-mask (1- *host-page-size*))
     239             (header (+ end (/ (read-at (1- end)) 4))))
     240        (assert (and (integerp header) (< header end) (<= 0 header)))
     241        (file-position header-stream header)
     242        (assert (loop for s in sig always (eql s (read-at))))
     243        (let* ((nsections (read-at (+ header $image-nsections)))
     244               (offset
     245                #+64-bit-host (/ (+ (ash (read-at (+ header $image-data-offset-64)) 32)
     246                                    (logand #xFFFFFFFF (read-at))) 4)
     247                #-64-bit-host 0)
     248               (sections (loop repeat nsections
     249                               for pos upfrom (+ header $image-header-size) by $image-sect-header-size
     250                               for epos = (* 4 (+ header $image-header-size
     251                                                         (* nsections $image-sect-header-size)
     252                                                         offset))
     253                                 then (+ fpos mem-size)
     254                               as fpos = (logandc2 (+ epos page-mask) page-mask)
     255                               as mem-size = (readn (+ pos $image-sect-size))
     256                               when (eq (readn (+ pos $image-sect-code))
     257                                        (ash area-readonly target::fixnum-shift))
     258                                 collect (cons fpos mem-size)))
     259               (new (area-loop with area-ptr
     260                               when (and (eq (core-q area-ptr target::area.code)
     261                                             (ash area-readonly target::fixnum-shift))
     262                                         (< (core-q area-ptr target::area.low)
     263                                            (core-q area-ptr target::area.active))
     264                                         (not (core-section-for-address (core-q area-ptr target::area.low))))
     265                               collect (let* ((size (- (core-q area-ptr target::area.active)
     266                                                       (core-q area-ptr target::area.low)))
     267                                              (matches (remove size sections :key 'cdr :test-not 'eql)))
     268
     269                                         ;; **** should just do nothing if not found
     270                                         (assert (eql (length matches) 1))
     271                                         (make-core-sect
     272                                          :start (core-q area-ptr target::area.low)
     273                                          :end (core-q area-ptr target::area.active)
     274                                          :offset (caar matches)))))
     275               (image-stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock)))
     276          (unwind-protect
     277               (let ((core (current-core)))
     278                 (setf (core-info-sections core)
     279                       (sort (concatenate 'vector new (core-info-sections core))
     280                             #'< :key (lambda (s) (%core-sect.start-addr s))))
     281                 (push image-stream (core-info-streams core))
     282                 (loop for s in new do (setf (%core-sect.stream s) image-stream))
     283                 (setq image-stream nil))
     284            (when image-stream (close image-stream :abort t))))))))
     285
     286
    188287(declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq
    189288                 core-stream-readb core-stream-readw core-stream-readl core-stream-readq))
     
    192291         (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl)
    193292         (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq)
    194          (ftype (function (integer) fixnum) core-offset-for-address))
    195 
    196 (define-condition invalid-core-address (simple-error) ())
     293         (ftype (function (simple-vector) fixnum) core-section-for-address))
     294
     295(define-condition invalid-core-address (simple-error)
     296  ()
     297  (:default-initargs :format-control "Unknown core address x~x"))
    197298
    198299(declaim (inline core-section-for-address))
     
    208309                            (%i< half len)
    209310                            (let ((sect (%svref sections half)))
    210                               (and (< address (%cddr (%svref sections half))) sect)))))
     311                              (and (< address (%core-sect.end-addr (%svref sections half))) sect)))))
    211312             (let ((sect (%svref sections half)))
    212                (if (%i<= (%car sect) address)
     313               (if (%i<= (%core-sect.start-addr sect) address)
    213314                 (setq low half)
    214315                 (setq high half))))))
     
    216317(defun core-heap-address-p (address)
    217318  (core-section-for-address address))
    218 
    219 (defun core-offset-for-address (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)))))
    226319
    227320
     
    266359(defun core-q (address &optional (offset 0))
    267360  (declare (optimize (speed 3) (safety 0)))
    268   (let* ((core (current-core))
    269          (ivector (core-info-raw-ivector core)))
    270     (declare (type core-info core))
     361  (incf address offset)
     362  (let* ((sect (or (core-section-for-address address)
     363                   (error 'invalid-core-address
     364                          :format-arguments (list address))))
     365         (ivector (%core-sect.ivector sect))
     366         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    271367    (if ivector
    272       (core-ivector-readq ivector (core-offset-for-address (+ address offset)))
    273       (core-stream-readq (core-info-stream core) (core-offset-for-address (+ address offset))))))
     368      (core-ivector-readq ivector pos)
     369      (core-stream-readq (%core-sect.stream sect) pos))))
     370
    274371
    275372(defun core-l (address &optional (offset 0))
    276373  (declare (optimize (speed 3) (safety 0)))
    277   (let* ((core (current-core))
    278          (ivector (core-info-raw-ivector core)))
    279     (declare (type core-info core))
     374  (incf address offset)
     375  (let* ((sect (or (core-section-for-address address)
     376                   (error 'invalid-core-address
     377                          :format-arguments (list address))))
     378         (ivector (%core-sect.ivector sect))
     379         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    280380    (if ivector
    281       (core-ivector-readl ivector (core-offset-for-address (+ address offset)))
    282       (core-stream-readl (core-info-stream core) (core-offset-for-address (+ address offset))))))
     381      (core-ivector-readl ivector pos)
     382      (core-stream-readl (%core-sect.stream sect) pos))))
    283383
    284384(defun core-w (address &optional (offset 0))
    285385  (declare (optimize (speed 3) (safety 0)))
    286   (let* ((core (current-core))
    287          (ivector (core-info-raw-ivector core)))
    288     (declare (type core-info core))
     386  (incf address offset)
     387  (let* ((sect (or (core-section-for-address address)
     388                   (error 'invalid-core-address
     389                          :format-arguments (list address))))
     390         (ivector (%core-sect.ivector sect))
     391         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    289392    (if ivector
    290       (core-ivector-readw ivector (core-offset-for-address (+ address offset)))
    291       (core-stream-readw (core-info-stream core) (core-offset-for-address (+ address offset))))))
     393      (core-ivector-readw ivector pos)
     394      (core-stream-readw (%core-sect.stream sect) pos))))
    292395
    293396(defun core-b (address &optional (offset 0))
    294397  (declare (optimize (speed 3) (safety 0)))
    295   (let* ((core (current-core))
    296          (ivector (core-info-raw-ivector core)))
    297     (declare (type core-info core))
     398  (incf address offset)
     399  (let* ((sect (or (core-section-for-address address)
     400                   (error 'invalid-core-address
     401                          :format-arguments (list address))))
     402         (ivector (%core-sect.ivector sect))
     403         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    298404    (if ivector
    299       (core-ivector-readb ivector (core-offset-for-address (+ address offset)))
    300       (core-stream-readb (core-info-stream core) (core-offset-for-address (+ address offset))))))
     405      (core-ivector-readb ivector pos)
     406      (core-stream-readb (%core-sect.stream sect) pos))))
    301407
    302408;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    383489  (if (eq area :tenured)
    384490    (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)))))
     491    (area-loop with area-ptr
     492               with area = (cond ((or (eq area t) (eq area nil)) nil)
     493                                 ;; Special-case dynamic to work even if areas have been renumbered:
     494                                 ;;  assume the first area is always dynamic, use its code.
     495                                 ((eq area :dynamic)
     496                                  (list (ash (core-q (core-q (core-q (kernel-global-address 'all-areas))
     497                                                             target::area.succ)
     498                                                     target::area.code)
     499                                             (- target::fixnum-shift))))
     500                                 ((consp area) (mapcar #'heap-area-code area))
     501                                 (t (list (heap-area-code area))))
     502               as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
     503               do (when (and (<= area-readonly code)
     504                             (<= code area-dynamic)
     505                             (or (null area) (member code area))
     506                             (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
     507                    #+debug
     508                    (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
     509                            area-ptr (core-area-name code)
     510                            (core-q area-ptr target::area.low)
     511                            (core-q area-ptr target::area.active)
     512                            (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
     513                            (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
     514                    (map-core-area area-ptr function)))))
    411515
    412516(defun map-core-area (area-ptr fun)
  • branches/working-0711/ccl/library/dominance.lisp

    r13460 r13465  
    4848  )
    4949
    50 (defun open-core-graph (pathname)
     50(defun open-core-graph (pathname &key image)
    5151  (let ((cg (%cons-cg)))
    52     (open-core pathname :core-info cg)
     52    (open-core pathname :core-info cg :image image)
    5353    (let ((area-ptr (core-q (kernel-global-address 'tenured-area))))
    5454      (setf (cg.heap-base cg) (core-q area-ptr target::area.low))
Note: See TracChangeset for help on using the changeset viewer.