Changeset 13167
- Timestamp:
- Nov 5, 2009, 7:44:54 AM (15 years ago)
- File:
-
- 1 edited
-
trunk/source/library/core-files.lisp (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/source/library/core-files.lisp
r13087 r13167 24 24 core-heap-utilization map-core-areas map-core-pointers 25 25 core-q core-l core-w core-b 26 core-consp core-symbolp core- listp core-nullp core-uvector-p26 core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p 27 27 core-uvtype core-uvtypep core-uvref core-uvsize 28 28 core-car core-cdr core-object-type core-istruct-type … … 33 33 core-symbol-name core-symbol-value core-symbol-package 34 34 core-gethash core-hash-table-count 35 core-lfun-name 35 core-lfun-name core-lfun-bits 36 36 core-find-class 37 core-instance-class 38 core-instance-p 37 39 core-instance-class-name 38 40 core-string-equal 39 41 core-all-processes core-process-name 42 core-find-process-for-id 43 core-print 44 core-print-call-history 40 45 )) 46 47 (eval-when (:compile-toplevel :execute) 48 (require "HASHENV" "ccl:xdump;hashenv")) 41 49 42 50 ;; The intended way to use these facilities is to open up a particular core file once, 43 51 ;; and then repeatedly call functions to examine it. So for convenience, we keep the 44 52 ;; 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. 45 54 46 55 (defvar *current-core* nil) … … 48 57 49 58 (defstruct core-info 59 pathname 50 60 sections 51 61 ;; uses either stream or ivector, determined at runtime … … 57 67 classes-hash-table-ptr 58 68 lfun-names-table-ptr 69 process-class 59 70 ) 60 71 … … 86 97 (close-core)) 87 98 (let* ((sections (readelf-sections pathname)) 88 (core (make-core-info : sections sections)))99 (core (make-core-info :pathname pathname :sections sections))) 89 100 (ecase method 90 101 (:mmap (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8)))) … … 248 259 (defun kernel-global-address (global) 249 260 (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))) 252 262 253 263 (defun nil-relative-symbol-address (sym) … … 390 400 391 401 392 (declaim (inline core-consp core-symbolp core- listp core-nullp))402 (declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp)) 393 403 394 404 (defun core-consp (ptr) … … 397 407 (defun core-symbolp (ptr) 398 408 (eq (logand ptr target::fulltagmask) target::fulltag-symbol)) 409 410 (defun core-functionp (ptr) 411 (eq (logand ptr target::fulltagmask) target::fulltag-function)) 399 412 400 413 (defun core-listp (ptr) … … 661 674 (setf (uvref vec i) (core-w addr (ash i 1)))))))) 662 675 663 (defun map-core-pointers (fn )676 (defun map-core-pointers (fn &key area) 664 677 (map-core-areas (lambda (obj) 665 678 (cond ((core-consp obj) … … 680 693 (decf len skip))) 681 694 (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) 686 710 (when (core-uvtypep obj :slot-vector) 687 711 (setq obj (core-uvref obj slot-vector.instance))) 688 712 (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)) 691 728 (class-slots (core-uvref class instance.slots)) 692 729 (name (core-uvref class-slots %class.name))) … … 832 869 (core-symbol-value (core-find-symbol '*lfun-names*))))) 833 870 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 834 882 (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)))))) 838 901 839 902 (defun core-list (ptr) … … 867 930 (core-uvref thread ccl::lisp-thread.tcr))) 868 931 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.
