Changeset 13491


Ignore:
Timestamp:
Mar 8, 2010, 5:01:06 PM (10 years ago)
Author:
gz
Message:

Merge assorted core file improvements

Location:
trunk/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source

  • trunk/source/library/core-files.lisp

    r13174 r13491  
    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;;;
     
    2121(progn
    2222
     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)
     31
    2332(export '(open-core close-core
    24           core-heap-utilization map-core-areas map-core-pointers
     33          core-heap-utilization map-core-areas map-core-region map-core-pointers
    2534          core-q core-l core-w core-b
    2635          core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p
    2736          core-uvtype core-uvtypep core-uvref core-uvsize
    28           core-car core-cdr core-object-type core-istruct-type
     37          core-car core-cdr core-object-typecode-type
     38          core-istruct-type core-struct-type core-instance-type core-function-type
     39          core-object-type-key  core-type-string
    2940          copy-from-core core-list
    3041          core-keyword-package core-find-package core-find-symbol
    3142          core-package-names core-package-name
    3243          core-map-symbols
    33           core-symbol-name core-symbol-value core-symbol-package
     44          core-symbol-name core-symbol-value core-symbol-package core-symbol-plist
    3445          core-gethash core-hash-table-count
    35           core-lfun-name core-lfun-bits
     46          core-lfun-name core-lfun-bits core-nth-immediate
    3647          core-find-class
    3748          core-instance-class
    3849          core-instance-p
    39           core-instance-class-name
    4050          core-string-equal
    4151          core-all-processes core-process-name
     
    6070  sections
    6171  ;; uses either stream or ivector, determined at runtime
    62   stream
    63   mapped-ivector
    64   raw-ivector
     72  streams
     73  ivectors
    6574  ;; caches
    6675  symbol-ptrs
     
    7079  )
    7180
     81
    7282(defmethod print-object :around ((core core-info) (stream t))
    73   (let ((*print-array* nil))
     83  (let ((*print-array* nil)
     84        (*print-simple-bit-vector* nil))
    7485    (call-next-method)))
    7586
     
    8596    (setq *current-core* nil)
    8697    (when core
    87       (when (core-info-stream core)
    88         (close (core-info-stream core)))
    89       (when (core-info-mapped-ivector core)
    90         (unmap-ivector (core-info-mapped-ivector core)))
     98      (map nil #'close (core-info-streams core))
     99      (map nil #'unmap-ivector (core-info-ivectors core))
    91100      t)))
     101
     102;
     103(defmacro area-loop (with ptrvar &body body)
     104  (assert (eq with 'with))
     105  (let ((before (loop while (eq (car body) 'with)
     106                      nconc (list (pop body) (pop body) (pop body) (pop body)))))
     107    `(loop ,@before
     108           for ,ptrvar = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
     109             then (core-q ,ptrvar target::area.succ)
     110           until (eq (core-q area-ptr target::area.code) (ash area-void target::fixnum-shift))
     111           ,@body)))
     112
     113(def-accessor-macros %svref
     114  %core-sect.start-addr
     115  %core-sect.offset
     116  %core-sect.end-addr
     117  %core-sect.ivector
     118  %core-sect.stream)
     119
     120(defun make-core-sect (&key start end offset ivector stream)
     121  (vector start offset end ivector stream))
     122
     123
     124(defvar *core-info-class* 'core-info)
    92125
    93126;; TODO: after load sections, check if highest heap address is a fixnum, and
    94127;; arrange to use fixnum-only versions of the reading functions.
    95 (defun open-core (pathname &key (method :mmap))
     128(defun open-core (pathname &key (image nil) (method :mmap) (core-info nil))
    96129  (when *current-core*
    97130    (close-core))
    98   (let* ((sections (readelf-sections pathname))
    99          (core (make-core-info :pathname pathname :sections sections)))
     131  (let* ((sections (read-sections pathname))
     132         (core (require-type (or core-info (make-instance *core-info-class*)) 'core-info)))
     133    (setf (core-info-pathname core) pathname)
     134    (setf (core-info-sections core) sections)
     135    (setf (core-info-symbol-ptrs core) nil)
     136    (setf (core-info-classes-hash-table-ptr core) nil)
     137    (setf (core-info-lfun-names-table-ptr core) nil)
     138    (setf (core-info-process-class core) nil)
     139    (setf (core-info-ivectors core) nil)
     140    (setf (core-info-streams core) nil)
    100141    (ecase method
    101142      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
    102143                 (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector)
    103                    (loop for data across sections do (incf (cdr data) offset))
    104                    (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)))))
     144                   (push mapped-vector (core-info-ivectors core))
     145                   (loop for sect across sections
     146                         do (incf (%core-sect.offset sect) offset)
     147                         do (setf (%core-sect.ivector sect) vector)))))
     148      (:stream (let ((stream (open pathname :element-type '(unsigned-byte 8)
     149                                   :sharing :lock)))
     150                 (push stream (core-info-streams core))
     151                 (loop for sect across sections do (setf (%core-sect.stream sect) stream)))))
    108152    (setq *current-core* core))
     153  ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core)))
     154  ;;  (error "Non-fixnum addresses not supported"))
     155  (when (and image
     156             (area-loop with area-ptr
     157                        thereis (and (eq (core-q area-ptr target::area.code)
     158                                         (ash area-readonly target::fixnum-shift))
     159                                     (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active))
     160                                     (not (core-section-for-address (core-q area-ptr target::area.low))))))
     161    ;; Have a missing readonly section, and an image file that might contain it.
     162    (add-core-sections-from-image image))
    109163  pathname)
    110164
    111165;; Kinda stupid to call external program for this...
    112 (defun readelf-sections (pathname)
     166(defun read-sections (pathname)
    113167  (flet ((split (line start end)
    114168           (loop while (setq start (position-if-not #'whitespacep line :start start :end end))
     
    122176    (let* ((file (native-translated-namestring pathname))
    123177           (string (with-output-to-string (output)
    124                      (ccl:run-program "readelf" `("--sections" ,file) :output output)))
     178                     #+readelf (ccl:run-program "readelf" `("--sections" "--wide" ,file) :output output)
     179                     #-readelf (ccl:run-program "objdump" `("-h" "-w" ,file) :output output)))
     180           (header-pos (or #+readelf (position #\[ string)
     181                           #-readelf (search "Idx Name" string)
     182                           (error "Cannot parse: ~%~a" string)))
    125183           (sections (loop
    126                        for start = (1+ (position #\newline string
    127                                                  :start (1+ (position #\newline string
    128                                                                       :start (position #\[ string)))))
    129                          then next
    130                        for next = (1+ (position #\newline string
    131                                                 :start (1+ (position #\newline string :start start))))
    132                        while (eql #\space (aref string next))
     184                       for start = (1+ (position #\newline string :start header-pos)) then (1+ end)
     185                       for end = (or (position #\newline string :start start) (length string))
     186                       while (and (< start end) (find (aref string start) " 123456789"))
    133187                       nconc
    134                        (destructuring-bind (number name type address filepos size &optional ent-size flags link info align)
    135                            (split string start next)
    136                          (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\])))
    137                          (setq number (read-from-string number :start 1 :end (1- (length number))))
    138                          (when (eql number 0)
    139                            (shiftf align info link flags ent-size size filepos address type name ""))
    140                          (setq address (parse-integer address :radix 16))
    141                          (setq filepos  (parse-integer filepos :radix 16))
    142                          (setq size (parse-integer size :radix 16))
    143                          (setq ent-size (parse-integer ent-size :radix 16))
    144                          (unless (eql size 0)
    145                            (assert (and (equal link "0") (equal info "0") (equal align "1")))
    146                            (list (list address filepos size))))))
    147            (sections (cons (list most-positive-fixnum 0 0) sections));; hack for loop below
     188                       (multiple-value-bind (name address filepos size)
     189                         #+readelf
     190                         (destructuring-bind (number name type address filepos size &rest flags)
     191                             (split string start end)
     192                           (declare (ignore flags))
     193                           (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\])))
     194                           (setq number (read-from-string number :start 1 :end (1- (length number))))
     195                           (when (eql number 0)
     196                             (shiftf size filepos address type))
     197                           (values name address filepos size))
     198                         #-readelf
     199                         (destructuring-bind (number name size address lma filepos &rest flags)
     200                             (split string start end)
     201                           (declare (ignore lma flags))
     202                           (parse-integer number :radix 10) ;; error checking only
     203                           (values name address filepos size))
     204                         (unless (or (equal name "") (eql (char name 0) #\.))
     205                           (setq address (parse-integer address :radix 16))
     206                           (setq filepos  (parse-integer filepos :radix 16))
     207                           (setq size (parse-integer size :radix 16))
     208                           (unless (eql size 0)
     209                             (list (list address filepos size)))))))
    148210           (sections (sort sections #'< :key #'car));; sort by address
     211           (sections (let ((last (car (last sections))))  ;; hack for loop below
     212                       (nconc sections (list (list (+ (car last) (caddr last) 1) 0 0)))))
    149213           (sections (loop
    150214                       with cur-address = -1
     
    154218                       unless (or (= (+ cur-filepos (- address cur-address)) filepos)
    155219                                  (= cur-address cur-end))
    156                          collect (cons cur-address cur-filepos)
     220                         collect (make-core-sect
     221                                      :start cur-address
     222                                      :end cur-end
     223                                      :offset cur-filepos)
    157224                       do (if (= (+ cur-filepos (- address cur-address)) filepos)
    158225                            (setq cur-end (max (+ address size) cur-end))
     
    162229      (coerce sections 'vector))))
    163230
     231
     232(defun add-core-sections-from-image (pathname)
     233  (with-open-file (header-stream  pathname :element-type '(signed-byte 32))
     234    (labels ((read-at (&optional pos)
     235               (when pos (file-position header-stream pos))
     236               (read-byte header-stream))
     237             (readn (pos) (+ (logand #xFFFFFFFF (read-at pos)) (ash (read-at) 32))))
     238      (let* ((sig '(#x4F70656E #x4D434C49 #x6D616765 #x46696C65))
     239             (end (file-length header-stream))
     240             (page-mask (1- *host-page-size*))
     241             (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))
     246        (assert (and (integerp header) (< header end) (<= 0 header)))
     247        (file-position header-stream header)
     248        (assert (loop for s in sig always (eql s (read-at))))
     249        (let* ((nsections (read-at (+ header $image-nsections)))
     250               (offset
     251                #+64-bit-host (/ (+ (ash (read-at (+ header $image-data-offset-64)) 32)
     252                                    (logand #xFFFFFFFF (read-at))) 4)
     253                #-64-bit-host 0)
     254               (sections (loop repeat nsections
     255                               for pos upfrom (+ header $image-header-size) by $image-sect-header-size
     256                               for epos = (* 4 (+ header $image-header-size
     257                                                         (* nsections $image-sect-header-size)
     258                                                         offset))
     259                                 then (+ fpos mem-size)
     260                               as fpos = (logandc2 (+ epos page-mask) page-mask)
     261                               as mem-size = (readn (+ pos $image-sect-size))
     262                               when (eq (readn (+ pos $image-sect-code))
     263                                        (ash area-readonly target::fixnum-shift))
     264                                 collect (cons fpos mem-size)))
     265               (new (area-loop with area-ptr
     266                               when (and (eq (core-q area-ptr target::area.code)
     267                                             (ash area-readonly target::fixnum-shift))
     268                                         (< (core-q area-ptr target::area.low)
     269                                            (core-q area-ptr target::area.active))
     270                                         (not (core-section-for-address (core-q area-ptr target::area.low))))
     271                               collect (let* ((size (- (core-q area-ptr target::area.active)
     272                                                       (core-q area-ptr target::area.low)))
     273                                              (matches (remove size sections :key 'cdr :test-not 'eql)))
     274
     275                                         ;; **** should just do nothing if not found
     276                                         (assert (eql (length matches) 1))
     277                                         (make-core-sect
     278                                          :start (core-q area-ptr target::area.low)
     279                                          :end (core-q area-ptr target::area.active)
     280                                          :offset (caar matches)))))
     281               (image-stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock)))
     282          (unwind-protect
     283               (let ((core (current-core)))
     284                 (setf (core-info-sections core)
     285                       (sort (concatenate 'vector new (core-info-sections core))
     286                             #'< :key (lambda (s) (%core-sect.start-addr s))))
     287                 (push image-stream (core-info-streams core))
     288                 (loop for s in new do (setf (%core-sect.stream s) image-stream))
     289                 (setq image-stream nil))
     290            (when image-stream (close image-stream :abort t))))))))
     291
     292
    164293(declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq
    165294                 core-stream-readb core-stream-readw core-stream-readl core-stream-readq))
     
    168297         (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl)
    169298         (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq)
    170          (ftype (function (integer) fixnum) core-offset-for-address))
    171 
    172 (defun core-offset-for-address (address)
    173   ;; sections are sorted, so could do binary search if this became a bottleneck.
    174   ;; (there are around 50 sections)
    175   (or (loop for prev = nil then sect as sect across (core-info-sections (current-core))
    176             do (when (< address (car sect))
    177                  (return (and prev (+ (cdr prev) (- address (car prev)))))))
    178       (error "Unknown core address x~x" address)))
     299         (ftype (function (simple-vector) fixnum) core-section-for-address))
     300
     301(define-condition invalid-core-address (simple-error)
     302  ()
     303  (:default-initargs :format-control "Unknown core address x~x"))
     304
     305(declaim (inline core-section-for-address))
     306(defun core-section-for-address (address)
     307  (loop with sections = (core-info-sections (current-core))
     308        with len fixnum = (length sections)
     309        with low fixnum = -1
     310        with high fixnum = len
     311        do (let ((half (the fixnum (ash (%i+ high low) -1))))
     312             (declare (fixnum half))
     313             (when (eq half low)
     314               (return (and (%i<= 0 half)
     315                            (%i< half len)
     316                            (let ((sect (%svref sections half)))
     317                              (and (< address (%core-sect.end-addr (%svref sections half))) sect)))))
     318             (let ((sect (%svref sections half)))
     319               (if (%i<= (%core-sect.start-addr sect) address)
     320                 (setq low half)
     321                 (setq high half))))))
     322
     323(defun core-heap-address-p (address)
     324  (core-section-for-address address))
     325
    179326
    180327(defun core-stream-readb (s offset)
     
    186333  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
    187334  (when offset (stream-position s offset))
    188   (%i+ (core-stream-readb s nil) (ash (core-stream-readb s nil) 8)))
     335  (%i+ (core-stream-readb s nil) (%ilsl 8 (core-stream-readb s nil))))
    189336
    190337(defun core-stream-readl (s offset)
    191338  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
    192339  (when offset (stream-position s offset))
    193   (%i+ (core-stream-readw s nil) (ash (core-stream-readw s nil) 16)))
     340  (%i+ (core-stream-readw s nil) (%ilsl 16 (core-stream-readw s nil))))
    194341
    195342(defun core-stream-readq (s offset)
    196343  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
    197344  (when offset (stream-position s offset))
    198   (+ (core-stream-readl s nil) (ash (core-stream-readl s nil) 32)))
     345  (+ (core-stream-readl s nil) (ash (the fixnum (core-stream-readl s nil)) 32)))
    199346
    200347(defun core-ivector-readb (vec offset)
     
    205352(defun core-ivector-readw (vec offset)
    206353  (declare (optimize (speed 3) (safety 0)))
    207   (%i+ (core-ivector-readb vec offset) (ash (core-ivector-readb vec (%i+ offset 1)) 8)))
     354  (%i+ (core-ivector-readb vec offset) (%ilsl 8 (core-ivector-readb vec (+ offset 1)))))
    208355
    209356(defun core-ivector-readl (vec offset)
    210357  (declare (optimize (speed 3) (safety 0)))
    211   (%i+ (core-ivector-readw vec offset) (ash (core-ivector-readw vec (%i+ offset 2)) 16)))
     358  (%i+ (core-ivector-readw vec offset) (%ilsl 16 (core-ivector-readw vec (+ offset 2)))))
    212359
    213360(defun core-ivector-readq (vec offset)
    214361  (declare (optimize (speed 3) (safety 0)))
    215   (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (%i+ offset 4)) 32)))
     362  (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (+ offset 4)) 32)))
    216363
    217364
    218365(defun core-q (address &optional (offset 0))
    219366  (declare (optimize (speed 3) (safety 0)))
    220   (let* ((core (current-core))
    221          (ivector (core-info-raw-ivector core)))
    222     (declare (type core-info core))
     367  (incf address offset)
     368  (let* ((sect (or (core-section-for-address address)
     369                   (error 'invalid-core-address
     370                          :format-arguments (list address))))
     371         (ivector (%core-sect.ivector sect))
     372         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    223373    (if ivector
    224       (core-ivector-readq ivector (core-offset-for-address (+ address offset)))
    225       (core-stream-readq (core-info-stream core) (core-offset-for-address (+ address offset))))))
     374      (core-ivector-readq ivector pos)
     375      (core-stream-readq (%core-sect.stream sect) pos))))
     376
    226377
    227378(defun core-l (address &optional (offset 0))
    228379  (declare (optimize (speed 3) (safety 0)))
    229   (let* ((core (current-core))
    230          (ivector (core-info-raw-ivector core)))
    231     (declare (type core-info core))
     380  (incf address offset)
     381  (let* ((sect (or (core-section-for-address address)
     382                   (error 'invalid-core-address
     383                          :format-arguments (list address))))
     384         (ivector (%core-sect.ivector sect))
     385         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    232386    (if ivector
    233       (core-ivector-readl ivector (core-offset-for-address (+ address offset)))
    234       (core-stream-readl (core-info-stream core) (core-offset-for-address (+ address offset))))))
     387      (core-ivector-readl ivector pos)
     388      (core-stream-readl (%core-sect.stream sect) pos))))
    235389
    236390(defun core-w (address &optional (offset 0))
    237391  (declare (optimize (speed 3) (safety 0)))
    238   (let* ((core (current-core))
    239          (ivector (core-info-raw-ivector core)))
    240     (declare (type core-info core))
     392  (incf address offset)
     393  (let* ((sect (or (core-section-for-address address)
     394                   (error 'invalid-core-address
     395                          :format-arguments (list address))))
     396         (ivector (%core-sect.ivector sect))
     397         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    241398    (if ivector
    242       (core-ivector-readw ivector (core-offset-for-address (+ address offset)))
    243       (core-stream-readw (core-info-stream core) (core-offset-for-address (+ address offset))))))
     399      (core-ivector-readw ivector pos)
     400      (core-stream-readw (%core-sect.stream sect) pos))))
    244401
    245402(defun core-b (address &optional (offset 0))
    246403  (declare (optimize (speed 3) (safety 0)))
    247   (let* ((core (current-core))
    248          (ivector (core-info-raw-ivector core)))
    249     (declare (type core-info core))
     404  (incf address offset)
     405  (let* ((sect (or (core-section-for-address address)
     406                   (error 'invalid-core-address
     407                          :format-arguments (list address))))
     408         (ivector (%core-sect.ivector sect))
     409         (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect)))))
    250410    (if ivector
    251       (core-ivector-readb ivector (core-offset-for-address (+ address offset)))
    252       (core-stream-readb (core-info-stream core) (core-offset-for-address (+ address offset))))))
     411      (core-ivector-readb ivector pos)
     412      (core-stream-readb (%core-sect.stream sect) pos))))
    253413
    254414;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    292452
    293453(defun uvheader-size (header)
    294   (ash header (- target::num-subtag-bits)))
     454  (the fixnum (ash header (- target::num-subtag-bits))))
    295455
    296456(defun uvheader-byte-size (header)
     
    318478  (unless (eq symbol 'bogus)
    319479    (cond ((setq pos (position symbol *immheader-0-types*))
    320            (logior (ash pos target::ntagbits) target::fulltag-immheader-0))
     480           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-0))
    321481          ((setq pos (position symbol *immheader-1-types*))
    322            (logior (ash pos target::ntagbits) target::fulltag-immheader-1))
     482           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-1))
    323483          ((setq pos (position symbol *immheader-2-types*))
    324            (logior (ash pos target::ntagbits) target::fulltag-immheader-2))
     484           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-2))
    325485          ((setq pos (position symbol *nodeheader-0-types*))
    326            (logior (ash pos target::ntagbits) target::fulltag-nodeheader-0))
     486           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-0))
    327487          ((setq pos (position symbol *nodeheader-1-types*))
    328            (logior (ash pos target::ntagbits) target::fulltag-nodeheader-1)))))
     488           (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-1)))))
    329489
    330490;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    332492;;  Core heap
    333493
     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
    334508(defun map-core-areas (function &key area)
    335   (setq area (cond ((or (eq area t) (eq area nil)) nil)
    336                    ((consp area) (mapcar #'heap-area-code area))
    337                    (t (list (heap-area-code area)))))
    338   (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
    339           then (core-q area-ptr target::area.succ)
    340         as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
    341         until (= code area-void)
    342         do (when (and (<= area-readonly code)
    343                       (<= code area-dynamic)
    344                       (or (null area) (member code area))
    345                       (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
    346              #+debug
    347              (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
    348                      area-ptr (core-area-name code)
    349                      (core-q area-ptr target::area.low)
    350                      (core-q area-ptr target::area.active)
    351                      (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
    352                      (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
    353              (map-core-area area-ptr function))))
     509  (if (eq area :tenured)
     510    (map-core-area (core-q (kernel-global-address 'tenured-area)) function)
     511    (area-loop with area-ptr
     512               with area = (cond ((or (eq area t) (eq area nil)) nil)
     513                                 ((consp area) (mapcar #'core-heap-area-code area))
     514                                 (t (list (core-heap-area-code area))))
     515               as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
     516               do (when (and (<= area-readonly code)
     517                             (<= code area-dynamic)
     518                             (or (null area) (member code area))
     519                             (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
     520                    #+debug
     521                    (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
     522                            area-ptr (core-area-name code)
     523                            (core-q area-ptr target::area.low)
     524                            (core-q area-ptr target::area.active)
     525                            (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
     526                            (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
     527                    (map-core-area area-ptr function)))))
    354528
    355529(defun map-core-area (area-ptr fun)
    356   (let* ((ptr (core-q area-ptr target::area.low))
    357          (end (core-q area-ptr target::area.active)))
    358     (loop
    359       (when (>= ptr end) (return))
    360       (let ((header (core-q ptr)))
    361         (cond ((uvheader-p header)
    362                (let ((subtag (uvheader-typecode header)))
    363                  (funcall fun
    364                           (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
    365                                        ((eq subtag target::subtag-function) target::fulltag-function)
    366                                        (t target::fulltag-misc)))))
    367                (let* ((bytes (uvheader-byte-size header))
    368                       (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
    369                                        (1- target::dnode-size))))
    370                  (declare (fixnum bytes total))
    371                  (incf ptr total)))
    372               (t
    373                (funcall fun (+ ptr target::fulltag-cons))
    374                (incf ptr target::cons.size)))))))
     530  (map-core-region (core-q area-ptr target::area.low)
     531                   (core-q area-ptr target::area.active)
     532                   fun))
     533
     534(defun map-core-region (ptr end fun)
     535  (loop
     536    while (< ptr end) as header = (core-q ptr)
     537    do (cond ((uvheader-p header)
     538              (let ((subtag (uvheader-typecode header)))
     539                (funcall fun
     540                         (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
     541                                      ((eq subtag target::subtag-function) target::fulltag-function)
     542                                      (t target::fulltag-misc)))))
     543              (let* ((bytes (uvheader-byte-size header))
     544                     (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
     545                                      (1- target::dnode-size))))
     546                (declare (fixnum bytes total))
     547                (incf ptr total)))
     548             (t
     549              (funcall fun (+ ptr target::fulltag-cons))
     550              (incf ptr target::cons.size)))))
    375551
    376552
     
    427603         (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size))
    428604         (typecode (uvheader-typecode header))
    429          (tag (logand typecode target::fulltagmask))
     605         (tag (%ilogand typecode target::fulltagmask))
    430606         (len (uvheader-size header)))
    431607    (assert (< -1 index len))
    432     (cond ((or (eql tag target::fulltag-nodeheader-0)
    433                (eql tag target::fulltag-nodeheader-1))
    434            (core-q addr (ash index target::word-shift)))
    435           ((eql tag target::ivector-class-64-bit)
     608    (cond ((or (eq tag target::fulltag-nodeheader-0)
     609               (eq tag target::fulltag-nodeheader-1))
     610           (core-q addr (%ilsl target::word-shift index)))
     611          ((eq tag target::ivector-class-64-bit)
    436612           (cond ((eq typecode target::subtag-double-float-vector)
    437613                  (error "~s not implemented yet" 'target::subtag-double-float-vector))
    438614                 (t
    439                   (core-q addr (ash index target::word-shift)))))
     615                  (core-q addr (%ilsl target::word-shift index)))))
    440616          ((eq tag target::ivector-class-32-bit)
    441617           (cond ((eq typecode target::subtag-simple-base-string)
    442                   (code-char (core-l addr (ash index 2))))
     618                  (%code-char (core-l addr (%ilsl 2 index))))
    443619                 ((eq typecode target::subtag-single-float-vector)
    444620                  (error "~s not implemented yet" 'target::subtag-single-float-vector))
    445                  (t (core-l addr (ash index 2)))))
     621                 (t (core-l addr (%ilsl 2 index)))))
    446622          ((eq typecode target::subtag-bit-vector)
    447            (let ((byte (core-b addr (ash (+ index 7) -3))))
     623           (let ((byte (core-b addr (%iasr 3 (%i+ index 7)))))
    448624             (error "not implemented, for ~b" byte)))
    449625          ((>= typecode target::min-8-bit-ivector-subtag)
    450626           (core-b addr index))
    451           (t (core-w addr (ash index 1))))))
     627          (t (core-w addr (%ilsl 1 index))))))
    452628
    453629(defun core-uvsize (vec-ptr)
     
    462638  (core-q obj target::cons.cdr))
    463639
    464 (defun core-object-type (obj)
     640(defun core-object-typecode-type (obj)
    465641  (let ((fulltag (logand obj target::fulltagmask)))
    466642    (cond ((eq fulltag target::fulltag-cons) 'cons)
     
    473649           (type-of (%%raw-obj obj)))
    474650          ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address)
    475           ((eq fulltag target::fulltag-misc) (core-uvtype obj))
     651          ((eq fulltag target::fulltag-misc)
     652           ;; (core-uvtype obj)
     653           (handler-case (core-uvtype obj) (invalid-core-address () 'unmapped)))
    476654          ((eq fulltag target::fulltag-symbol) 'symbol)
    477655          ;; TODO: Could get hairier based on lfun-bits, but usually don't care.
     
    480658           'bogus))))
    481659
     660(defun core-object-type-key (obj)
     661  ;; Returns either a symbol (for built-in types) or a pointer to type symbol or class.
     662  ;; Whatever it returns must be suitable for use in an eql hash table; use core-type-string
     663  ;; to get a printable rep.
     664  (let ((type (core-object-typecode-type obj)))
     665    (case type
     666      (function (core-function-type obj))
     667      (internal-structure (core-istruct-type obj))
     668      (structure (core-struct-type obj))
     669      (instance (core-instance-type obj))
     670      (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))))))
     697
     698(defun core-type-string (object-type)
     699  (with-output-to-string (s)
     700    (if (fixnump object-type)
     701      (core-print object-type s)
     702      (prin1 object-type s))))
     703
    482704(defun core-istruct-type (obj)
    483705  (and (core-uvtypep obj :istruct)
    484706       (core-car (core-uvref obj 0))))
    485707       
     708(defun core-struct-type (obj)
     709  (and (core-uvtypep obj :struct)
     710       (core-uvref (core-car (core-uvref obj 0)) 1)))
     711
     712(defun core-instance-type (obj)
     713  (and (core-uvtypep obj :instance)
     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))
    486718
    487719(defun core-object-type-and-size (obj)
     
    497729          (values (uvheader-type header) logsize total))))))
    498730
    499 (defun core-heap-utilization (&key area unit sort)
    500   (let* ((hash (make-hash-table :shared nil))
    501          (total-physsize 0)
    502          (div (ecase unit
    503                 ((nil) 1)
    504                 (:kb 1024.0d0)
    505                 (:mb (* 1024.0d0 1024.0d0))
    506                 (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
    507          (sort-key (ecase sort
    508                      (:count #'cadr)
    509                      (:logical-size #'caddr)
    510                      ((:physical-size nil) #'cdddr)))
     731(defun core-heap-utilization (&key (stream *debug-io*) area unit (sort :size) classes (threshold 0.00005))
     732  (let* ((obj-hash (make-hash-table :shared nil))
     733         (slotv-hash (make-hash-table :shared nil))
    511734         (all nil))
    512     (map-core-areas (lambda (obj)
     735    (map-core-areas (lambda (obj &aux (hash obj-hash))
    513736                      (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj)
     737                        (when classes
     738                          (when (core-uvtypep obj :slot-vector)
     739                            (setq hash slotv-hash
     740                                  obj (core-uvref obj slot-vector.instance)))
     741                          (setq type (core-object-type-key obj)))
    514742                        (let ((a (or (gethash type hash)
    515                                      (setf (gethash type hash) (list* 0 0 0)))))
     743                                     (setf (gethash type hash) (list 0 0 0)))))
    516744                          (incf (car a))
    517745                          (incf (cadr a) logsize)
    518                           (incf (cddr a) physsize))))
     746                          (incf (caddr a) physsize))))
    519747                    :area area)
    520748    (maphash (lambda (type data)
    521                (incf total-physsize (cddr data))
    522                (push (cons type data) all))
    523              hash)
    524     (setq all (sort all #'> :key sort-key))
    525     (format t "~&Object type~42tCount    Logical size   Physical size   % of Heap~%~50t~a~66t~:*~a"
    526             (ecase unit
    527               ((nil) " (in bytes)")
    528               (:kb   "(in kilobytes)")
    529               (:mb   "(in megabytes)")
    530               (:gb   "(in gigabytes)")))
    531     (loop for (type count logsize . physsize) in all
    532           do (if unit
    533                (format t "~&~a~36t~11d~16,2f~16,2f~11,2f%"
    534                        type
    535                        count
    536                        (/ logsize div)
    537                        (/ physsize div)
    538                        (* 100.0 (/ physsize total-physsize)))
    539                (format t "~&~a~36t~11d~16d~16d~11,2f%"
    540                        type
    541                        count
    542                        logsize
    543                        physsize
    544                        (* 100.0 (/ physsize total-physsize)))))
    545     (if unit
    546       (format t "~&Total~63t~16,2f" (/ total-physsize div))
    547       (format t "~&Total~63t~16d" total-physsize)))
    548   (values))
     749               (push (cons (core-type-string type) data) all))
     750             obj-hash)
     751    (maphash (lambda (type data)
     752               (push (cons (concatenate 'string (core-type-string type) " slot-vector") data) all))
     753             slotv-hash)
     754    (report-heap-utilization all :stream stream :unit unit :sort sort :threshold threshold)))
    549755
    550756
     
    553759(defmethod print-object ((obj unresolved-address) stream)
    554760  (let* ((address (unresolved-address-address obj)))
    555     (format stream "#<Core ~S~@[[~d]~] #x~x >"
    556             (core-object-type address)
    557             (and (core-uvector-p address) (core-uvsize address))
    558             address)))
     761    (if (and (core-uvector-p address)
     762             (not (handler-case (core-uvheader address) (invalid-core-address () nil))))
     763      (format stream "#<Unmapped #x~x >" address)
     764      (format stream "#<Core ~A~@[[~d]~] #x~x >"
     765              (or (ignore-errors (core-type-string (core-object-type-key address)))
     766                  (core-object-typecode-type address))
     767              (and (core-uvector-p address) (core-uvsize address))
     768            address))))
    559769
    560770(defun copy-from-core (obj &key (depth 1))
     
    572782          ((< (decf depth) 0)
    573783           (make-unresolved-address :address obj))
    574           ((%i<= target::fulltag-misc fulltag)
     784          ((and (%i<= target::fulltag-misc fulltag)
     785                (handler-case (core-uvheader obj) (invalid-core-address nil)))
    575786           (or (and (core-uvtypep obj :package)
    576787                    (find-package (core-package-name obj)))
     
    605816         (len (uvheader-size header))
    606817         (vec (%alloc-misc len typecode)))
     818    (declare (type fixnum typecode tag len))
    607819    (cond ((or (eq tag target::fulltag-nodeheader-0)
    608820               (eq tag target::fulltag-nodeheader-1))
    609            (when (eql typecode target::subtag-function)
     821           (when (eq typecode target::subtag-function)
    610822             ;; Don't bother copying the code for now
    611823             (let ((skip (core-l addr)))
     824               (declare (fixnum skip))
    612825               (assert (<= 0 skip len))
    613826               (incf addr (ash skip target::word-shift))
    614827               (decf len skip)))
    615828           (dotimes (i len)
     829             (declare (fixnum i))
    616830             (setf (%svref vec i)
    617                    (copy-from-core (core-q addr (ash i target::word-shift)) :depth depth)))
     831                   (copy-from-core (core-q addr (%ilsl target::word-shift i)) :depth depth)))
    618832           (let ((ptrtag (logand vec-ptr target::fulltagmask)))
    619              (cond ((eql ptrtag target::fulltag-symbol)
     833             (cond ((eq ptrtag target::fulltag-symbol)
    620834                    (%symvector->symptr vec))
    621                    ((eql ptrtag target::fulltag-function)
     835                   ((eq ptrtag target::fulltag-function)
    622836                    (%function-vector-to-function vec))
    623837                   (t vec))))
     
    628842                 (t
    629843                  (dotimes (i len vec)
    630                     (setf (uvref vec i) (core-q addr (ash i target::word-shift)))))))
     844                    (setf (uvref vec i) (core-q addr (%ilsl target::word-shift i)))))))
    631845          ((eq tag target::ivector-class-32-bit)
    632846           (cond ((eq typecode target::subtag-simple-base-string)
    633847                  (dotimes (i len vec)
    634                     (setf (uvref vec i) (code-char (core-l addr (ash i 2))))))
     848                    (setf (uvref vec i) (%code-char (core-l addr (%ilsl 2 i))))))
    635849                 ((eq typecode target::subtag-single-float-vector)
    636850                  (warn "~s not implemented yet" 'target::subtag-single-float-vector)
     
    638852                 (t
    639853                  (dotimes (i len vec)
    640                     (setf (uvref vec i) (core-l addr (ash i 2)))))))
     854                    (setf (uvref vec i) (core-l addr (%ilsl 2 i)))))))
    641855          ((eq typecode target::subtag-bit-vector)
    642856           (warn "bit vector not implemented yet")
     
    647861          (t
    648862           (dotimes (i len vec)
    649              (setf (uvref vec i) (core-w addr (ash i 1))))))))
     863             (setf (uvref vec i) (core-w addr (%ilsl 1 i))))))))
    650864
    651865(defun map-core-pointers (fn &key area)
     
    662876                                      (len (uvheader-size header))
    663877                                      (addr (+ (logandc2 obj target::fulltagmask) target::node-size)))
    664                                  (when (eql typecode target::subtag-function)
     878                                 (declare (fixnum typecode len))
     879                                 (when (eq typecode target::subtag-function)
    665880                                   (let ((skip (core-l addr)))
     881                                     (declare (fixnum skip))
    666882                                     (assert (<= 0 skip len))
    667                                      (incf addr (ash skip target::word-shift))
     883                                     (incf addr (%ilsl target::word-shift skip))
    668884                                     (decf len skip)))
    669885                                 (dotimes (i len)
    670                                    (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))
     886                                   (funcall fn (core-q addr (%ilsl target::word-shift i)) obj i))))))))
    671887                  :area area))
    672888
     
    698914         (matchp (core-instance-class obj)))))
    699915
    700 
    701 (defun core-instance-class-name (obj)
    702   (let* ((class (core-instance-class obj))
    703          (class-slots (core-uvref class instance.slots))
    704          (name (core-uvref class-slots %class.name)))
    705     (core-symbol-name name)))
    706916
    707917(defun core-symptr (obj)
     
    728938        (core-car cell)
    729939        cell))))
     940
     941(defun core-symbol-plist (obj)
     942  (when (setq obj (core-symptr obj))
     943    (core-cdr (core-q obj target::symbol.plist))))
    730944
    731945(defun core-all-packages-ptr ()
     
    8441058            (core-symbol-value (core-find-symbol '*lfun-names*)))))
    8451059
     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
    8461065(defun core-closure-function (fun)
    8471066  (while (and (core-functionp fun)
    8481067              (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
    849     (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
    850       (setq fun (core-q addr (ash (core-l addr) target::word-shift)))
    851       (when (core-uvtypep fun :simple-vector)
    852         (setq fun (core-uvref fun 0)))
    853       #+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)))
    8541072  fun)
    8551073
    856    
    8571074(defun core-lfun-name (fn)
    8581075  (assert (core-functionp fn))
     
    8621079                      (name (if (and (logbitp $lfbits-gfn-bit lfbits)
    8631080                                     (not (logbitp $lfbits-method-bit lfbits)))
    864                                 (core-uvref (core-uvref fn gf.slots) sgf.name)
     1081                                (core-uvref (core-nth-immediate fn gf.slots) sgf.name)
    8651082                                (unless (logbitp $lfbits-noname-bit lfbits)
    8661083                                  (core-uvref fn (- (core-uvsize fn) 2))))))
     
    9181135
    9191136(defun core-print (obj &optional (stream t) depth)
    920   ;; TODO: could dispatch on core-object-type...
     1137  ;; TODO: could dispatch on core-object-typecode-type...
    9211138  (cond ((core-nullp obj) (format stream "NIL"))
    9221139        ((core-symbolp obj)
     
    9391156           (core-print obj stream depth))
    9401157         (format stream ")"))
    941         (t (format stream "#<core ~s x~x>"
    942                    (core-object-type obj) obj))))
     1158        (t (format stream "#<core ~a x~x>"
     1159                   (or (ignore-errors (core-type-string (core-object-type-key obj)))
     1160                       (core-object-typecode-type obj))
     1161                   obj))))
    9431162
    9441163(defun core-print-symbol (sym stream)
     
    9491168           (format stream ":"))
    9501169          (t (let ((pkgname (core-package-name package)))
    951                (unless (string-equal pkgname "COMMON-LISP")
    952                  (format stream "~a::" pkgname)))))
    953     (format stream "~a" (core-symbol-name sym))))
     1170               (etypecase pkgname
     1171                 (unresolved-address (format stream "@~x::" (unresolved-address-address pkgname)))
     1172                 (string (unless (string-equal pkgname "COMMON-LISP")
     1173                           (format stream "~a::" pkgname)))))))
     1174    (let ((symname (core-symbol-name sym)))
     1175      (etypecase symname
     1176        (unresolved-address (format stream "@~x" (unresolved-address-address symname)))
     1177        (string (format stream "~a" symname)))))
     1178  (values))
    9541179
    9551180(defun core-lfun-bits (fun)
    956   (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
    9571187
    9581188(defun core-print-function (fun stream)
     
    9821212                   do (let ((spec (core-car method-specializers)))
    9831213                        (if (core-uvtypep spec :instance)
    984                           (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)))
    9851222                          (core-print spec stream)))
    9861223                   do (setq method-specializers (core-cdr method-specializers)))
     
    9981235(defun core-print-process (proc stream)
    9991236  (format stream "#<~a ~s LWP(~d) #x~x>"
    1000           (core-instance-class-name proc)
     1237          (core-symbol-name (core-instance-type proc))
    10011238          (core-process-name proc)
    10021239          (core-q (core-process-tcr proc) target::tcr.native-thread-id)
     
    11581395
    11591396)                             ; :x8664-target
     1397
Note: See TracChangeset for help on using the changeset viewer.