Changeset 13145


Ignore:
Timestamp:
Oct 30, 2009, 10:30:36 PM (10 years ago)
Author:
gz
Message:

Oops, didn't mean to check this in yet, revert to prior version

File:
1 edited

Legend:

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

    r13144 r13145  
    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-functionp core-listp core-nullp core-uvector-p
     26          core-consp core-symbolp 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 core-lfun-bits
     35          core-lfun-name
    3636          core-find-class
    37           core-instance-class
    38           core-instance-p
    3937          core-instance-class-name
    4038          core-string-equal
    4139          core-all-processes core-process-name
    42           core-find-process-for-id
    43           core-print
    44           core-print-call-history
    4540          ))
    46 
    47 (eval-when (:compile-toplevel :execute)
    48   (require "HASHENV" "ccl:xdump;hashenv"))
    4941
    5042;; The intended way to use these facilities is to open up a particular core file once,
    5143;; and then repeatedly call functions to examine it.  So for convenience, we keep the
    5244;; 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.
    5445
    5546(defvar *current-core* nil)
     
    5748
    5849(defstruct core-info
    59   pathname
    6050  sections
    6151  ;; uses either stream or ivector, determined at runtime
     
    6757  classes-hash-table-ptr
    6858  lfun-names-table-ptr
    69   process-class
    7059  )
    7160
     
    9786    (close-core))
    9887  (let* ((sections (readelf-sections pathname))
    99          (core (make-core-info :pathname pathname :sections sections)))
     88         (core (make-core-info :sections sections)))
    10089    (ecase method
    10190      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
     
    259248(defun kernel-global-address (global)
    260249  (check-type global symbol)
    261   (+ (target-nil-value) (target::%kernel-global global)))
     250  (+ (target-nil-value)
     251     (target::%kernel-global (or (find-symbol (symbol-name global) :ccl) global))))
    262252
    263253(defun nil-relative-symbol-address (sym)
     
    400390
    401391
    402 (declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp))
     392(declaim (inline core-consp core-symbolp core-listp core-nullp))
    403393
    404394(defun core-consp (ptr)
     
    407397(defun core-symbolp (ptr)
    408398  (eq (logand ptr target::fulltagmask) target::fulltag-symbol))
    409 
    410 (defun core-functionp (ptr)
    411   (eq (logand ptr target::fulltagmask) target::fulltag-function))
    412399
    413400(defun core-listp (ptr)
     
    674661             (setf (uvref vec i) (core-w addr (ash i 1))))))))
    675662
    676 (defun map-core-pointers (fn &key area)
     663(defun map-core-pointers (fn)
    677664  (map-core-areas (lambda (obj)
    678665                    (cond ((core-consp obj)
     
    693680                                     (decf len skip)))
    694681                                 (dotimes (i len)
    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)
     682                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))))
     683
     684
     685(defun core-instance-class-name (obj)
    710686  (when (core-uvtypep obj :slot-vector)
    711687    (setq obj (core-uvref obj slot-vector.instance)))
    712688  (assert (core-uvtypep obj :instance))
    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))
     689  (let* ((wrapper (core-uvref obj instance.class-wrapper))
     690         (class (core-uvref wrapper %wrapper-class))
    728691         (class-slots (core-uvref class instance.slots))
    729692         (name (core-uvref class-slots %class.name)))
     
    869832            (core-symbol-value (core-find-symbol '*lfun-names*)))))
    870833
    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    
    882834(defun core-lfun-name (fn)
    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))))))
     835  (assert (core-uvtypep fn :function))
     836  (core-gethash fn (core-lfun-names-table-ptr)))
     837
    901838
    902839(defun core-list (ptr)
     
    930867    (core-uvref thread ccl::lisp-thread.tcr)))
    931868
    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 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                                (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 t "~&     ")
    1177                        do (if (integerp val)
    1178                             (core-print val stream)
    1179                             (format t "~a x~x" (car val) (cadr val)))))
    1180             do (setq fp (fp-backlink fp vs-end))))))
    1181 
    1182 
    1183 )                             ; :x8664-target
     869) ; :x8664-target
Note: See TracChangeset for help on using the changeset viewer.