Changeset 13476


Ignore:
Timestamp:
Mar 3, 2010, 8:44:08 PM (10 years ago)
Author:
gz
Message:

Core file support improvements:

Added core-symbol-plist, core-nth-immediate, core-function-type.
Make core-object-type-key use core-function-type, so now different classes of function are reported separately by core-heap-utilities.
Check that :image arg to open-core is actually an image file.
Make open-core indirect thru *core-info-class* to make the core-info
Add explicit knowledge about recent area renumbering so can examine core files that predate the change.
Handle printing eql specializers when printing methods
Make sure core-lfun-bits always returns a fixnum.

File:
1 edited

Legend:

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

    r13465 r13476  
    3636          core-uvtype core-uvtypep core-uvref core-uvsize
    3737          core-car core-cdr core-object-typecode-type
    38           core-istruct-type core-struct-type core-instance-type
     38          core-istruct-type core-struct-type core-instance-type core-function-type
    3939          core-object-type-key  core-type-string
    4040          copy-from-core core-list
     
    4242          core-package-names core-package-name
    4343          core-map-symbols
    44           core-symbol-name core-symbol-value core-symbol-package
     44          core-symbol-name core-symbol-value core-symbol-package core-symbol-plist
    4545          core-gethash core-hash-table-count
    46           core-lfun-name core-lfun-bits
     46          core-lfun-name core-lfun-bits core-nth-immediate
    4747          core-find-class
    4848          core-instance-class
     
    7979  )
    8080
     81
    8182(defmethod print-object :around ((core core-info) (stream t))
    8283  (let ((*print-array* nil)
     
    121122
    122123
     124(defvar *core-info-class* 'core-info)
     125
    123126;; TODO: after load sections, check if highest heap address is a fixnum, and
    124127;; arrange to use fixnum-only versions of the reading functions.
    125128(defun open-core (pathname &key (image nil) (method :mmap) (core-info nil))
    126   (when core-info (check-type core-info core-info))
    127129  (when *current-core*
    128130    (close-core))
    129131  (let* ((sections (read-sections pathname))
    130          (core (or core-info (make-core-info))))
     132         (core (require-type (or core-info (make-instance *core-info-class*)) 'core-info)))
    131133    (setf (core-info-pathname core) pathname)
    132134    (setf (core-info-sections core) sections)
     
    238240             (page-mask (1- *host-page-size*))
    239241             (header (+ end (/ (read-at (1- end)) 4))))
     242        (unless (progn
     243                  (file-position header-stream (- end 4))
     244                  (loop repeat 3 as s in sig always (eql s (read-at))))
     245          (error "~s is not a ccl image file" pathname))
    240246        (assert (and (integerp header) (< header end) (<= 0 header)))
    241247        (file-position header-stream header)
     
    486492;;  Core heap
    487493
     494
     495(defun core-heap-area-code (area)
     496  (let ((code (heap-area-code area))
     497        (dynamic (ash (core-q (core-q (core-q (kernel-global-address 'all-areas))
     498                                      target::area.succ)
     499                              target::area.code)
     500                      (- target::fixnum-shift))))
     501    (if (or (fixnump area)
     502            (eq dynamic area-dynamic)
     503            ;; account for watched area having been inserted
     504            (<= code area-watched))
     505      code
     506      (1- code))))
     507
    488508(defun map-core-areas (function &key area)
    489509  (if (eq area :tenured)
     
    491511    (area-loop with area-ptr
    492512               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))))
     513                                 ((consp area) (mapcar #'core-heap-area-code area))
     514                                 (t (list (core-heap-area-code area))))
    502515               as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
    503516               do (when (and (<= area-readonly code)
     
    651664  (let ((type (core-object-typecode-type obj)))
    652665    (case type
     666      (function (core-function-type obj))
    653667      (internal-structure (core-istruct-type obj))
    654668      (structure (core-struct-type obj))
    655669      (instance (core-instance-type obj))
    656670      (t type))))
     671
     672(defun core-function-type (obj)
     673  (and (core-uvtypep obj :function)
     674       (let ((bits (core-lfun-bits obj)))
     675         (declare (fixnum bits))
     676         (or (if (logbitp $lfbits-trampoline-bit bits)
     677               (let* ((inner-fn (core-closure-function obj))
     678                      (inner-bits (core-lfun-bits inner-fn)))
     679                 (if (neq inner-fn obj)
     680                   (if (logbitp $lfbits-method-bit inner-bits)
     681                     'compiled-lexical-closure
     682                     (unless (logbitp $lfbits-gfn-bit inner-bits)
     683                       (if (logbitp $lfbits-cm-bit inner-bits)
     684                         'combined-method
     685                         'compiled-lexical-closure)))
     686                   'compiled-lexical-closure))
     687               (if (logbitp  $lfbits-method-bit bits)
     688                 'method-function
     689                 (unless (logbitp $lfbits-gfn-bit bits)
     690                   (if (logbitp $lfbits-cm-bit bits)
     691                     'combined-method
     692                     'function))))
     693             (core-class-name
     694              (core-uvref
     695               (core-nth-immediate obj gf.instance.class-wrapper)
     696               %wrapper-class))))))
    657697
    658698(defun core-type-string (object-type)
     
    672712(defun core-instance-type (obj)
    673713  (and (core-uvtypep obj :instance)
    674        (core-uvref (core-uvref (core-instance-class obj) instance.slots) %class.name)))
    675 
     714       (core-class-name (core-instance-class obj))))
     715
     716(defun core-class-name (class)
     717  (core-uvref (core-uvref class instance.slots) %class.name))
    676718
    677719(defun core-object-type-and-size (obj)
     
    897939        cell))))
    898940
     941(defun core-symbol-plist (obj)
     942  (when (setq obj (core-symptr obj))
     943    (core-cdr (core-q obj target::symbol.plist))))
     944
    899945(defun core-all-packages-ptr ()
    900946  (core-symbol-value (nil-relative-symbol-address '%all-packages%)))
     
    10121058            (core-symbol-value (core-find-symbol '*lfun-names*)))))
    10131059
     1060(defun core-nth-immediate (fn i)
     1061  (assert (core-uvtypep fn :function))
     1062  (let ((addr (+ (logandc2 fn target::fulltagmask) target::node-size)))
     1063    (core-q addr (%ilsl target::word-shift (+ (core-l addr) i -1)))))
     1064
    10141065(defun core-closure-function (fun)
    10151066  (while (and (core-functionp fun)
    10161067              (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
    1017     (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
    1018       (setq fun (core-q addr (%ilsl target::word-shift (core-l addr))))
    1019       (when (core-uvtypep fun :simple-vector)
    1020         (setq fun (core-uvref fun 0)))
    1021       #+gz (assert (core-functionp fun))))
     1068    (setq fun (core-nth-immediate fun 1))
     1069    (when (core-uvtypep fun :simple-vector)
     1070      (setq fun (core-uvref fun 0)))
     1071    #+gz (assert (core-functionp fun)))
    10221072  fun)
    10231073
    1024    
    10251074(defun core-lfun-name (fn)
    10261075  (assert (core-functionp fn))
     
    10301079                      (name (if (and (logbitp $lfbits-gfn-bit lfbits)
    10311080                                     (not (logbitp $lfbits-method-bit lfbits)))
    1032                                 (core-uvref (core-uvref fn gf.slots) sgf.name)
     1081                                (core-uvref (core-nth-immediate fn gf.slots) sgf.name)
    10331082                                (unless (logbitp $lfbits-noname-bit lfbits)
    10341083                                  (core-uvref fn (- (core-uvsize fn) 2))))))
     
    11301179
    11311180(defun core-lfun-bits (fun)
    1132   (ash (core-uvref fun (1- (core-uvsize fun))) (- target::fixnum-shift)))
     1181  (let ((unsigned (core-uvref fun (1- (core-uvsize fun)))))
     1182    (ash (if (logbitp (1- (* target::node-size 8)) unsigned)
     1183           (logior (ash -1 (* target::node-size 8)) unsigned)
     1184           unsigned)
     1185         (- target::fixnum-shift))))
     1186
    11331187
    11341188(defun core-print-function (fun stream)
     
    11581212                   do (let ((spec (core-car method-specializers)))
    11591213                        (if (core-uvtypep spec :instance)
    1160                           (core-print (core-uvref (core-uvref spec instance.slots) %class.name) stream)
     1214                          (let ((slots (core-uvref spec instance.slots)))
     1215                            ;; specializer is either a class or a ccl::eql-specializer
     1216                            (if (eql (core-uvsize slots) 3)
     1217                              (progn
     1218                                (format stream "(EQL ")
     1219                                (core-print (core-uvref slots 2) stream)
     1220                                (format stream ")"))
     1221                              (core-print (core-uvref slots %class.name) stream)))
    11611222                          (core-print spec stream)))
    11621223                   do (setq method-specializers (core-cdr method-specializers)))
     
    13341395
    13351396)                             ; :x8664-target
     1397
Note: See TracChangeset for help on using the changeset viewer.