Changeset 13167


Ignore:
Timestamp:
Nov 5, 2009, 3:44:54 PM (10 years ago)
Author:
gz
Message:

More core file functions (from r13155)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/library/core-files.lisp

    r13087 r13167  
    2424          core-heap-utilization map-core-areas map-core-pointers
    2525          core-q core-l core-w core-b
    26           core-consp core-symbolp core-listp core-nullp core-uvector-p
     26          core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p
    2727          core-uvtype core-uvtypep core-uvref core-uvsize
    2828          core-car core-cdr core-object-type core-istruct-type
     
    3333          core-symbol-name core-symbol-value core-symbol-package
    3434          core-gethash core-hash-table-count
    35           core-lfun-name
     35          core-lfun-name core-lfun-bits
    3636          core-find-class
     37          core-instance-class
     38          core-instance-p
    3739          core-instance-class-name
    3840          core-string-equal
    3941          core-all-processes core-process-name
     42          core-find-process-for-id
     43          core-print
     44          core-print-call-history
    4045          ))
     46
     47(eval-when (:compile-toplevel :execute)
     48  (require "HASHENV" "ccl:xdump;hashenv"))
    4149
    4250;; The intended way to use these facilities is to open up a particular core file once,
    4351;; and then repeatedly call functions to examine it.  So for convenience, we keep the
    4452;; core file in a global var, rather than making all user functions take an extra arg.
     53;; There is nothing intrinsic that would prevent having multiple core files open at once.
    4554
    4655(defvar *current-core* nil)
     
    4857
    4958(defstruct core-info
     59  pathname
    5060  sections
    5161  ;; uses either stream or ivector, determined at runtime
     
    5767  classes-hash-table-ptr
    5868  lfun-names-table-ptr
     69  process-class
    5970  )
    6071
     
    8697    (close-core))
    8798  (let* ((sections (readelf-sections pathname))
    88          (core (make-core-info :sections sections)))
     99         (core (make-core-info :pathname pathname :sections sections)))
    89100    (ecase method
    90101      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
     
    248259(defun kernel-global-address (global)
    249260  (check-type global symbol)
    250   (+ (target-nil-value)
    251      (target::%kernel-global (or (find-symbol (symbol-name global) :ccl) global))))
     261  (+ (target-nil-value) (target::%kernel-global global)))
    252262
    253263(defun nil-relative-symbol-address (sym)
     
    390400
    391401
    392 (declaim (inline core-consp core-symbolp core-listp core-nullp))
     402(declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp))
    393403
    394404(defun core-consp (ptr)
     
    397407(defun core-symbolp (ptr)
    398408  (eq (logand ptr target::fulltagmask) target::fulltag-symbol))
     409
     410(defun core-functionp (ptr)
     411  (eq (logand ptr target::fulltagmask) target::fulltag-function))
    399412
    400413(defun core-listp (ptr)
     
    661674             (setf (uvref vec i) (core-w addr (ash i 1))))))))
    662675
    663 (defun map-core-pointers (fn)
     676(defun map-core-pointers (fn &key area)
    664677  (map-core-areas (lambda (obj)
    665678                    (cond ((core-consp obj)
     
    680693                                     (decf len skip)))
    681694                                 (dotimes (i len)
    682                                    (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))))
    683 
    684 
    685 (defun core-instance-class-name (obj)
     695                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))
     696                  :area area))
     697
     698(defun core-find-tra-function (tra)
     699  (assert (eq (logand tra target::tagmask) target::tag-tra))
     700  (map-core-areas (lambda (obj)
     701                    (when (core-uvtypep obj :function)
     702                      (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size))
     703                             (skip  (core-l addr))
     704                             (offset (- tra addr)))
     705                        (when (<= 0 offset (ash skip target::word-shift))
     706                          (return-from core-find-tra-function (values obj (+ offset (- target::node-size
     707                                                                                       (logand obj target::fulltagmask)))))))))))
     708
     709(defun core-instance-class (obj)
    686710  (when (core-uvtypep obj :slot-vector)
    687711    (setq obj (core-uvref obj slot-vector.instance)))
    688712  (assert (core-uvtypep obj :instance))
    689   (let* ((wrapper (core-uvref obj instance.class-wrapper))
    690          (class (core-uvref wrapper %wrapper-class))
     713  (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class))
     714
     715(defun core-instance-p (obj class)
     716  (and (core-uvtypep obj :instance)
     717       (labels ((matchp (iclass)
     718                  (or (eql iclass class)
     719                      (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers)
     720                              then (core-cdr supers)
     721                            while (core-consp supers)
     722                            thereis (matchp (core-car supers))))))
     723         (matchp (core-instance-class obj)))))
     724
     725
     726(defun core-instance-class-name (obj)
     727  (let* ((class (core-instance-class obj))
    691728         (class-slots (core-uvref class instance.slots))
    692729         (name (core-uvref class-slots %class.name)))
     
    832869            (core-symbol-value (core-find-symbol '*lfun-names*)))))
    833870
     871(defun core-closure-function (fun)
     872  (while (and (core-functionp fun)
     873              (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
     874    (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
     875      (setq fun (core-q addr (ash (core-l addr) target::word-shift)))
     876      (when (core-uvtypep fun :simple-vector)
     877        (setq fun (core-uvref fun 0)))
     878      #+gz (assert (core-functionp fun))))
     879  fun)
     880
     881   
    834882(defun core-lfun-name (fn)
    835   (assert (core-uvtypep fn :function))
    836   (core-gethash fn (core-lfun-names-table-ptr)))
    837 
     883  (assert (core-functionp fn))
     884  (flet ((lfun-name (fn)
     885           (or (core-gethash fn (core-lfun-names-table-ptr))
     886               (let* ((lfbits (core-lfun-bits fn))
     887                      (name (if (and (logbitp $lfbits-gfn-bit lfbits)
     888                                     (not (logbitp $lfbits-method-bit lfbits)))
     889                                (core-uvref (core-uvref fn gf.slots) sgf.name)
     890                                (unless (logbitp $lfbits-noname-bit lfbits)
     891                                  (core-uvref fn (- (core-uvsize fn) 2))))))
     892                 (and name
     893                      (not (eql name (%fixnum-address-of (%slot-unbound-marker))))
     894                      (not (core-nullp name))
     895                      name)))))
     896    (or (lfun-name fn)
     897        (let ((inner-fn (core-closure-function fn)))
     898          (and (core-functionp inner-fn)
     899               (not (eql inner-fn fn))
     900               (lfun-name inner-fn))))))
    838901
    839902(defun core-list (ptr)
     
    867930    (core-uvref thread ccl::lisp-thread.tcr)))
    868931
    869 ) ; :x8664-target
     932(defun core-find-process-for-id (lwp)
     933  (loop for proc in (core-all-processes)
     934        when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id))
     935          return proc))
     936
     937;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     938
     939(defun core-process-class ()
     940  (or (core-info-process-class (current-core))
     941      (setf (core-info-process-class (current-core))
     942            (core-find-class 'process))))
     943
     944(defun core-print (obj &optional (stream t) depth)
     945  ;; TODO: could dispatch on core-object-type...
     946  (cond ((core-nullp obj) (format stream "NIL"))
     947        ((core-symbolp obj)
     948         (core-print-symbol obj stream))
     949        ((core-uvtypep obj :function)
     950         (core-print-function obj stream))
     951        ((core-instance-p obj (core-process-class))
     952         (core-print-process obj stream))
     953        ((and depth (< (decf depth) 0))
     954         (format stream "x~x" obj))
     955        ((core-consp obj)
     956         (loop for sep = "(" then " "
     957               for i from 0 below (or *print-length* 100)
     958               while (core-consp obj)
     959               do (format stream sep)
     960               do (core-print (core-car obj) stream depth)
     961               do (setq obj (core-cdr obj)))
     962         (unless (core-nullp obj)
     963           (format stream " . ")
     964           (core-print obj stream depth))
     965         (format stream ")"))
     966        (t (format stream "#<core ~s x~x>"
     967                   (core-object-type obj) obj))))
     968
     969(defun core-print-symbol (sym stream)
     970  (let ((package (core-symbol-package sym)))
     971    (cond ((core-nullp package)
     972           (format stream "#:"))
     973          ((eq package (core-keyword-package))
     974           (format stream ":"))
     975          (t (let ((pkgname (core-package-name package)))
     976               (unless (string-equal pkgname "COMMON-LISP")
     977                 (format stream "~a::" pkgname)))))
     978    (format stream "~a" (core-symbol-name sym))))
     979
     980(defun core-lfun-bits (fun)
     981  (ash (core-uvref fun (1- (core-uvsize fun))) (- target::fixnum-shift)))
     982
     983(defun core-print-function (fun stream)
     984  (let* ((lfbits (core-lfun-bits fun))
     985         (name (core-lfun-name fun)))
     986    (format stream "#<")
     987    (cond ((or (null name) (core-nullp name))
     988           (format stream "Anonymous function"))
     989          ((logbitp $lfbits-method-bit lfbits)
     990           (assert (core-uvtypep name :instance))
     991           (let* ((slot-vector (core-uvref name instance.slots))
     992                  (method-qualifiers (core-uvref slot-vector %method.qualifiers))
     993                  (method-specializers (core-uvref slot-vector %method.specializers))
     994                  (method-name (core-uvref slot-vector %method.name)))
     995             (format stream "Method-Function ")
     996             (core-print method-name stream)
     997             (format stream " ")
     998             (unless (core-nullp method-qualifiers)
     999               (if (core-nullp (core-cdr method-qualifiers))
     1000                 (core-print (core-car method-qualifiers) stream)
     1001                 (core-print method-qualifiers stream))
     1002               (format stream " "))
     1003             ;; print specializer list but print names instead of classes.
     1004             (loop for sep = "(" then " "
     1005                   while (core-consp method-specializers)
     1006                   do (format stream sep)
     1007                   do (let ((spec (core-car method-specializers)))
     1008                        (if (core-uvtypep spec :instance)
     1009                          (core-print (core-uvref (core-uvref spec instance.slots) %class.name) stream)
     1010                          (core-print spec stream)))
     1011                   do (setq method-specializers (core-cdr method-specializers)))
     1012             (unless (core-nullp method-specializers)
     1013               (format stream " . ")
     1014               (core-print method-specializers stream))
     1015             (format stream ")")))
     1016          (t
     1017           (if (logbitp $lfbits-gfn-bit lfbits)
     1018               (format stream "Generic Function ")
     1019               (format stream "Function "))
     1020           (core-print name stream)))
     1021    (format stream " x~x>" fun)))
     1022
     1023(defun core-print-process (proc stream)
     1024  (format stream "#<~a ~s LWP(~d) #x~x>"
     1025          (core-instance-class-name proc)
     1026          (core-process-name proc)
     1027          (core-q (core-process-tcr proc) target::tcr.native-thread-id)
     1028          proc))
     1029
     1030(defun dwim-core-frame-pointer (tcr &optional end)
     1031  (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr)))
     1032         (lexprs (list (core-q (kernel-global-address 'lexpr-return))
     1033                       (core-q (kernel-global-address 'lexpr-return1v))))
     1034         (stack-area (core-q tcr target::tcr.vs-area))
     1035         (fp (core-q stack-area target::area.high))
     1036         (low (core-q stack-area target::area.low)))
     1037    (flet ((validp (pp)
     1038             (let ((tra (core-q pp target::lisp-frame.return-address)))
     1039               (when (eql tra ret1valn)
     1040                 (setq tra (core-q pp target::lisp-frame.xtra)))
     1041               (or (eql (logand tra target::tagmask) target::tag-tra)
     1042                   (eql tra 0)
     1043                   (member tra lexprs)))))
     1044      (decf fp (* 2 target::node-size))
     1045      (when (and end (<= low end fp))
     1046        (setq low (- end 8)))
     1047      (loop while
     1048            (loop for pp downfrom (- fp target::node-size) above low by target::node-size
     1049                  do (when (eql (core-q pp target::lisp-frame.backptr) fp)
     1050                       (when (validp pp)
     1051                         (return (setq fp pp))))))
     1052      fp)))
     1053
     1054(defun core-stack-frame-values (tcr fp)
     1055  (let* ((bottom (core-q fp target::lisp-frame.backptr))
     1056         (top (if (eql 0 (core-q fp target::lisp-frame.return-address))
     1057                (+ fp target::xcf.size)
     1058                (+ fp (if (eql (core-q fp target::lisp-frame.return-address)
     1059                               (core-q (kernel-global-address 'ret1valaddr)))
     1060                        target::lisp-frame.size
     1061                        target::lisp-frame.xtra))))
     1062         (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db)
     1063                        until (or (eql db 0) (>= db bottom))
     1064                        when (<= top db) return db)))
     1065    (loop for vsp from top below bottom by target::node-size
     1066          when (eql vsp db-link)
     1067            ;; The db-link will be followed by var and val, which we'll just collect normally
     1068            do (setq db-link (core-q db-link) vsp (+ vsp target::node-size))
     1069            and collect `(:db-link ,db-link)
     1070          collect (core-q vsp))))
     1071
     1072(defun core-print-call-history (process &key (stream t) origin detailed-p)
     1073  (flet ((fp-backlink (fp vs-end)
     1074           (let ((backlink (core-q fp target::lisp-frame.backptr)))
     1075             (when (or (eql backlink 0)
     1076                       (<= vs-end backlink)
     1077                       (<= vs-end (core-q backlink target::lisp-frame.backptr)))
     1078               (setq backlink vs-end))
     1079             (assert (< fp backlink))
     1080             backlink))
     1081         (fp-tra (fp)
     1082           (let ((tra (core-q fp target::lisp-frame.return-address)))
     1083             (if (eql tra (core-q (kernel-global-address 'ret1valaddr)))
     1084               (core-q fp target::lisp-frame.xtra)
     1085               tra)))
     1086         (recover-fn (pc)
     1087           (when (and (eql (logand pc target::tagmask) target::tag-tra)
     1088                      (eql (core-w pc) target::recover-fn-from-rip-word0)
     1089                      (eql (core-b pc 2) target::recover-fn-from-rip-byte2))
     1090             (+ pc target::recover-fn-from-rip-length
     1091                (- (core-l pc target::recover-fn-from-rip-disp-offset)
     1092                   #x100000000)))))
     1093    (format stream "~&")
     1094    (core-print process stream)
     1095    (let* ((tcr (core-process-tcr process))
     1096           (vs-area (core-q tcr target::tcr.vs-area))
     1097           (vs-end (core-q vs-area target::area.high))
     1098           (valence (core-q tcr target::tcr.valence))
     1099           (fp (or origin
     1100                   ;; TODO: find the registers in the core file!
     1101                   (case valence
     1102                     ;; TCR_STATE_LISP
     1103                     (0 (let ((xp (core-q tcr target::tcr.suspend-context)))
     1104                          (format stream "~&")
     1105                          (if (eql xp 0)
     1106                            (format stream "Unknown lisp context, guessing frame pointer:")
     1107                            (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn
     1108                          (if (eql xp 0)
     1109                            (dwim-core-frame-pointer tcr)
     1110                            ;; uc_mcontext.gregs[rbp]
     1111                            (core-q xp (* 15 target::node-size)))))
     1112                     ;; TCR_STATE_FOREIGN
     1113                     (1 (format stream "~&In foreign code")
     1114                        ;; the save-rbp seems to include some non-lisp frames sometimes,
     1115                        ;; shave them down.
     1116                        #+no (core-q tcr target::tcr.save-rbp)
     1117                        (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp)))
     1118                     ;; TCR_STATE_EXCEPTION_WAIT
     1119                     (2 (let ((xp (core-q tcr target::tcr.pending-exception-context)))
     1120                          ;; regs start at index 5, in this order:
     1121                          ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z
     1122                          ;; rbp temp0 imm1 imm0 nargs rsp rip
     1123                          (format stream " exception-wait")
     1124                          (if (zerop xp)
     1125                            (format stream "~&context unknown")
     1126                            (let* ((fn (core-q xp (* 10 target::node-size)))
     1127                                   (sp (core-q xp (* 20 target::node-size)))
     1128                                   (ra (core-q sp)))
     1129                              (if (and (core-functionp fn)
     1130                                       (and (<= fn ra)
     1131                                            (< ra (+ fn (* (core-uvsize fn) target::node-size)))))
     1132                                (progn
     1133                                  (format stream "~&")
     1134                                  (core-print fn stream)
     1135                                  (format stream " + ~d" (- ra fn)))
     1136                                (progn
     1137                                  (format stream "~&top of stack = x~x, r13 = " ra)
     1138                                  (core-print fn stream)))))
     1139                          (unless (zerop xp)
     1140                            (core-q xp (* 15 target::node-size))))))
     1141                   (error "Cannot find frame pointer"))))
     1142      (unless (<= (core-q vs-area target::area.low) fp vs-end)
     1143        (error "frame pointer x~x is not in stack area" fp))
     1144      (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc)
     1145            do (format stream "~&fp: x~x  pc: x~x : " fp pc)
     1146            do (cond (fun
     1147                      (core-print fun stream)
     1148                      (format stream " + ~d " (- pc fun)))
     1149                     ((eql pc 0) ;; exception frame
     1150                      (let* ((nominal-function (core-q fp target::xcf.nominal-function))
     1151                             (obj (core-q fp target::xcf.containing-object)))
     1152                        (when (core-functionp nominal-function)
     1153                          (format stream "exception ")
     1154                          (core-print nominal-function stream)
     1155                          (format stream " + ~d"
     1156                                  (if (eq (- obj target::fulltag-misc)
     1157                                          (- nominal-function target::fulltag-function))
     1158                                    (- (core-q fp target::xcf.relative-pc) target::tag-function)
     1159                                    (let ((pc (core-q fp target::xcf.ra0)))
     1160                                      (when (eql nominal-function (recover-fn pc))
     1161                                        (- pc nominal-function))))))))
     1162                     ((eql pc (core-q (kernel-global-address 'lexpr-return)))
     1163                      (format stream "lexpr return"))
     1164                     ((eql pc (core-q (kernel-global-address 'lexpr-return1v)))
     1165                      (format stream "lexpr1v return"))
     1166                     (t
     1167                      (if (eql (logand pc target::tagmask) target::tag-tra)
     1168                        (format stream " # couldn't recover function")
     1169                        (unless (core-nullp pc)
     1170                          (format stream "bad frame!")))
     1171                      ;; can't trust backlink
     1172                      (return)))
     1173               ;; TODO: print stack addressses
     1174            do (when detailed-p
     1175                 (loop for val in (core-stack-frame-values tcr fp)
     1176                       do (format stream "~&     ")
     1177                       do (if (integerp val)
     1178                            (handler-case (core-print val stream)
     1179                              (error () (format stream "#<Error printing value @x~x>" val)))
     1180                            (format stream "~a x~x" (car val) (cadr val)))))
     1181            do (setq fp (fp-backlink fp vs-end))))))
     1182
     1183
     1184)                             ; :x8664-target
Note: See TracChangeset for help on using the changeset viewer.