1 | ;;; |
---|
2 | ;;; Copyright (C) 2009-2010 Clozure Associates and contributors |
---|
3 | ;;; This file is part of Clozure CL. |
---|
4 | ;;; |
---|
5 | ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public |
---|
6 | ;;; License , known as the LLGPL and distributed with Clozure CL as the |
---|
7 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
8 | ;;; which is distributed with Clozure CL as the file "LGPL". Where these |
---|
9 | ;;; conflict, the preamble takes precedence. |
---|
10 | ;;; |
---|
11 | ;;; Clozure CL is referenced in the preamble as the "LIBRARY." |
---|
12 | ;;; |
---|
13 | ;;; The LLGPL is also available online at |
---|
14 | ;;; http://opensource.franz.com/preamble.html |
---|
15 | |
---|
16 | ;; Functions to examine core files. |
---|
17 | |
---|
18 | (in-package :ccl) |
---|
19 | |
---|
20 | #+:linuxx8664-target |
---|
21 | (progn |
---|
22 | |
---|
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 | |
---|
32 | (export '(open-core close-core |
---|
33 | core-heap-utilization map-core-areas |
---|
34 | core-q core-l core-w core-b |
---|
35 | core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p |
---|
36 | core-uvtype core-uvtypep core-uvref core-uvsize |
---|
37 | core-car core-cdr core-object-typecode-type |
---|
38 | core-object-type-key core-type-string |
---|
39 | copy-from-core core-list |
---|
40 | core-keyword-package core-find-package core-find-symbol |
---|
41 | core-package-names core-package-name |
---|
42 | core-map-symbols |
---|
43 | core-symbol-name core-symbol-value core-symbol-package core-symbol-plist |
---|
44 | core-gethash core-hash-table-count |
---|
45 | core-lfun-name core-lfun-bits core-nth-immediate |
---|
46 | core-find-class |
---|
47 | core-instance-class |
---|
48 | core-instance-p |
---|
49 | core-string= |
---|
50 | core-all-processes core-process-name |
---|
51 | core-find-process-for-id |
---|
52 | core-print |
---|
53 | core-print-call-history |
---|
54 | )) |
---|
55 | |
---|
56 | (eval-when (:compile-toplevel :execute) |
---|
57 | (require "HASHENV" "ccl:xdump;hashenv")) |
---|
58 | |
---|
59 | ;; The intended way to use these facilities is to open up a particular core file once, |
---|
60 | ;; and then repeatedly call functions to examine it. So for convenience, we keep the |
---|
61 | ;; core file in a global var, rather than making all user functions take an extra arg. |
---|
62 | ;; There is nothing intrinsic that would prevent having multiple core files open at once. |
---|
63 | |
---|
64 | (defvar *current-core* nil) |
---|
65 | |
---|
66 | |
---|
67 | (eval-when (load eval #-BOOTSTRAPPED compile) |
---|
68 | |
---|
69 | (defstruct core-info |
---|
70 | pathname |
---|
71 | sections |
---|
72 | ;; uses either stream or ivector, determined at runtime |
---|
73 | streams |
---|
74 | ivectors |
---|
75 | ;; caches |
---|
76 | symbol-ptrs |
---|
77 | classes-hash-table-ptr |
---|
78 | lfun-names-table-ptr |
---|
79 | process-class |
---|
80 | ) |
---|
81 | ) |
---|
82 | |
---|
83 | (defmethod print-object :around ((core core-info) (stream t)) |
---|
84 | (let ((*print-array* nil) |
---|
85 | (*print-simple-bit-vector* nil)) |
---|
86 | (call-next-method))) |
---|
87 | |
---|
88 | (declaim (type (or null core-info) *current-core*) |
---|
89 | (ftype (function () core-info) current-core) |
---|
90 | (inline current-core)) |
---|
91 | |
---|
92 | (defun current-core () |
---|
93 | (or *current-core* (require-type *current-core* 'core-info))) |
---|
94 | |
---|
95 | (defun close-core () |
---|
96 | (let ((core *current-core*)) |
---|
97 | (setq *current-core* nil) |
---|
98 | (when core |
---|
99 | (map nil #'close (core-info-streams core)) |
---|
100 | (map nil #'unmap-ivector (core-info-ivectors core)) |
---|
101 | t))) |
---|
102 | |
---|
103 | ; |
---|
104 | (defmacro area-loop (with ptrvar &body body) |
---|
105 | (assert (eq with 'with)) |
---|
106 | (let ((before (loop while (eq (car body) 'with) |
---|
107 | nconc (list (pop body) (pop body) (pop body) (pop body))))) |
---|
108 | `(loop ,@before |
---|
109 | for ,ptrvar = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ) |
---|
110 | then (core-q ,ptrvar target::area.succ) |
---|
111 | until (eq (core-q area-ptr target::area.code) (ash area-void target::fixnum-shift)) |
---|
112 | ,@body))) |
---|
113 | |
---|
114 | (def-accessor-macros %svref |
---|
115 | %core-sect.start-addr |
---|
116 | %core-sect.offset |
---|
117 | %core-sect.end-addr |
---|
118 | %core-sect.ivector |
---|
119 | %core-sect.stream) |
---|
120 | |
---|
121 | (defun make-core-sect (&key start end offset ivector stream) |
---|
122 | (vector start offset end ivector stream)) |
---|
123 | |
---|
124 | |
---|
125 | (defvar *core-info-class* 'core-info) |
---|
126 | |
---|
127 | ;; TODO: after load sections, check if highest heap address is a fixnum, and |
---|
128 | ;; arrange to use fixnum-only versions of the reading functions. |
---|
129 | (defun open-core (pathname &key (image nil) (method :mmap) (core-info nil)) |
---|
130 | (when *current-core* |
---|
131 | (close-core)) |
---|
132 | (let* ((sections (read-sections pathname)) |
---|
133 | (core (require-type (or core-info (make-instance *core-info-class*)) 'core-info))) |
---|
134 | (setf (core-info-pathname core) pathname) |
---|
135 | (setf (core-info-sections core) sections) |
---|
136 | (setf (core-info-symbol-ptrs core) nil) |
---|
137 | (setf (core-info-classes-hash-table-ptr core) nil) |
---|
138 | (setf (core-info-lfun-names-table-ptr core) nil) |
---|
139 | (setf (core-info-process-class core) nil) |
---|
140 | (setf (core-info-ivectors core) nil) |
---|
141 | (setf (core-info-streams core) nil) |
---|
142 | (ecase method |
---|
143 | (:mmap (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8)))) |
---|
144 | (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector) |
---|
145 | (push mapped-vector (core-info-ivectors core)) |
---|
146 | (loop for sect across sections |
---|
147 | do (incf (%core-sect.offset sect) offset) |
---|
148 | do (setf (%core-sect.ivector sect) vector))))) |
---|
149 | (:stream (let ((stream (open pathname :element-type '(unsigned-byte 8) |
---|
150 | :sharing :lock))) |
---|
151 | (push stream (core-info-streams core)) |
---|
152 | (loop for sect across sections do (setf (%core-sect.stream sect) stream))))) |
---|
153 | (setq *current-core* core)) |
---|
154 | ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core))) |
---|
155 | ;; (error "Non-fixnum addresses not supported")) |
---|
156 | (when (and image |
---|
157 | (area-loop with area-ptr |
---|
158 | thereis (and (eq (core-q area-ptr target::area.code) |
---|
159 | (ash area-readonly target::fixnum-shift)) |
---|
160 | (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)) |
---|
161 | (not (core-section-for-address (core-q area-ptr target::area.low)))))) |
---|
162 | ;; Have a missing readonly section, and an image file that might contain it. |
---|
163 | (add-core-sections-from-image image)) |
---|
164 | pathname) |
---|
165 | |
---|
166 | ;; Kinda stupid to call external program for this... |
---|
167 | (defun read-sections (pathname) |
---|
168 | (flet ((split (line start end) |
---|
169 | (loop while (setq start (position-if-not #'whitespacep line :start start :end end)) |
---|
170 | as match = (cdr (assq (char line start) '((#\[ . #\]) (#\( . #\)) (#\< . #\>)))) |
---|
171 | as next = (if match |
---|
172 | (1+ (or (position match line :start (1+ start) :end end) |
---|
173 | (error "Unmatched ~c at position ~s" (char line start) start))) |
---|
174 | (or (position-if #'whitespacep line :start start :end end) end)) |
---|
175 | collect (subseq line start next) |
---|
176 | do (setq start next)))) |
---|
177 | (let* ((file (native-translated-namestring pathname)) |
---|
178 | (string (with-output-to-string (output) |
---|
179 | #+readelf (ccl:run-program "readelf" `("--sections" "--wide" ,file) :output output) |
---|
180 | #-readelf (ccl:run-program "objdump" `("-h" "-w" ,file) :output output))) |
---|
181 | (header-pos (or #+readelf (position #\[ string) |
---|
182 | #-readelf (search "Idx Name" string) |
---|
183 | (error "Cannot parse: ~%~a" string))) |
---|
184 | (sections (loop |
---|
185 | for start = (1+ (position #\newline string :start header-pos)) then (1+ end) |
---|
186 | for end = (or (position #\newline string :start start) (length string)) |
---|
187 | while (and (< start end) (find (aref string start) " 123456789")) |
---|
188 | nconc |
---|
189 | (multiple-value-bind (name address filepos size) |
---|
190 | #+readelf |
---|
191 | (destructuring-bind (number name type address filepos size &rest flags) |
---|
192 | (split string start end) |
---|
193 | (declare (ignore flags)) |
---|
194 | (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\]))) |
---|
195 | (setq number (read-from-string number :start 1 :end (1- (length number)))) |
---|
196 | (when (eql number 0) |
---|
197 | (shiftf size filepos address type)) |
---|
198 | (values name address filepos size)) |
---|
199 | #-readelf |
---|
200 | (destructuring-bind (number name size address lma filepos &rest flags) |
---|
201 | (split string start end) |
---|
202 | (declare (ignore lma flags)) |
---|
203 | (parse-integer number :radix 10) ;; error checking only |
---|
204 | (values name address filepos size)) |
---|
205 | (unless (or (equal name "") (eql (char name 0) #\.)) |
---|
206 | (setq address (parse-integer address :radix 16)) |
---|
207 | (setq filepos (parse-integer filepos :radix 16)) |
---|
208 | (setq size (parse-integer size :radix 16)) |
---|
209 | (unless (eql size 0) |
---|
210 | (list (list address filepos size))))))) |
---|
211 | (sections (sort sections #'< :key #'car));; sort by address |
---|
212 | (sections (let ((last (car (last sections)))) ;; hack for loop below |
---|
213 | (nconc sections (list (list (+ (car last) (caddr last) 1) 0 0))))) |
---|
214 | (sections (loop |
---|
215 | with cur-address = -1 |
---|
216 | with cur-filepos = -1 |
---|
217 | with cur-end = cur-address |
---|
218 | for (address filepos size) in sections |
---|
219 | unless (or (= (+ cur-filepos (- address cur-address)) filepos) |
---|
220 | (= cur-address cur-end)) |
---|
221 | collect (make-core-sect |
---|
222 | :start cur-address |
---|
223 | :end cur-end |
---|
224 | :offset cur-filepos) |
---|
225 | do (if (= (+ cur-filepos (- address cur-address)) filepos) |
---|
226 | (setq cur-end (max (+ address size) cur-end)) |
---|
227 | (progn |
---|
228 | (assert (<= cur-end address));; no overlap. |
---|
229 | (setq cur-address address cur-filepos filepos cur-end (+ address size))))))) |
---|
230 | (coerce sections 'vector)))) |
---|
231 | |
---|
232 | |
---|
233 | (defun add-core-sections-from-image (pathname) |
---|
234 | (with-open-file (header-stream pathname :element-type '(signed-byte 32)) |
---|
235 | (labels ((read-at (&optional pos) |
---|
236 | (when pos (file-position header-stream pos)) |
---|
237 | (read-byte header-stream)) |
---|
238 | (readn (pos) (+ (logand #xFFFFFFFF (read-at pos)) (ash (read-at) 32)))) |
---|
239 | (let* ((sig '(#x4F70656E #x4D434C49 #x6D616765 #x46696C65)) |
---|
240 | (end (file-length header-stream)) |
---|
241 | (page-mask (1- *host-page-size*)) |
---|
242 | (header (+ end (/ (read-at (1- end)) 4)))) |
---|
243 | (unless (progn |
---|
244 | (file-position header-stream (- end 4)) |
---|
245 | (loop repeat 3 as s in sig always (eql s (read-at)))) |
---|
246 | (error "~s is not a ccl image file" pathname)) |
---|
247 | (assert (and (integerp header) (< header end) (<= 0 header))) |
---|
248 | (file-position header-stream header) |
---|
249 | (assert (loop for s in sig always (eql s (read-at)))) |
---|
250 | (let* ((nsections (read-at (+ header $image-nsections))) |
---|
251 | (offset |
---|
252 | #+64-bit-host (/ (+ (ash (read-at (+ header $image-data-offset-64)) 32) |
---|
253 | (logand #xFFFFFFFF (read-at))) 4) |
---|
254 | #-64-bit-host 0) |
---|
255 | (sections (loop repeat nsections |
---|
256 | for pos upfrom (+ header $image-header-size) by $image-sect-header-size |
---|
257 | for epos = (* 4 (+ header $image-header-size |
---|
258 | (* nsections $image-sect-header-size) |
---|
259 | offset)) |
---|
260 | then (+ fpos mem-size) |
---|
261 | as fpos = (logandc2 (+ epos page-mask) page-mask) |
---|
262 | as mem-size = (readn (+ pos $image-sect-size)) |
---|
263 | when (eq (readn (+ pos $image-sect-code)) |
---|
264 | (ash area-readonly target::fixnum-shift)) |
---|
265 | collect (cons fpos mem-size))) |
---|
266 | (new (area-loop with area-ptr |
---|
267 | when (and (eq (core-q area-ptr target::area.code) |
---|
268 | (ash area-readonly target::fixnum-shift)) |
---|
269 | (< (core-q area-ptr target::area.low) |
---|
270 | (core-q area-ptr target::area.active)) |
---|
271 | (not (core-section-for-address (core-q area-ptr target::area.low)))) |
---|
272 | collect (let* ((size (- (core-q area-ptr target::area.active) |
---|
273 | (core-q area-ptr target::area.low))) |
---|
274 | (matches (remove size sections :key 'cdr :test-not 'eql))) |
---|
275 | |
---|
276 | ;; **** should just do nothing if not found |
---|
277 | (assert (eql (length matches) 1)) |
---|
278 | (make-core-sect |
---|
279 | :start (core-q area-ptr target::area.low) |
---|
280 | :end (core-q area-ptr target::area.active) |
---|
281 | :offset (caar matches))))) |
---|
282 | (image-stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock))) |
---|
283 | (unwind-protect |
---|
284 | (let ((core (current-core))) |
---|
285 | (setf (core-info-sections core) |
---|
286 | (sort (concatenate 'vector new (core-info-sections core)) |
---|
287 | #'< :key (lambda (s) (%core-sect.start-addr s)))) |
---|
288 | (push image-stream (core-info-streams core)) |
---|
289 | (loop for s in new do (setf (%core-sect.stream s) image-stream)) |
---|
290 | (setq image-stream nil)) |
---|
291 | (when image-stream (close image-stream :abort t)))))))) |
---|
292 | |
---|
293 | |
---|
294 | (declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq |
---|
295 | core-stream-readb core-stream-readw core-stream-readl core-stream-readq)) |
---|
296 | (declaim (ftype (function (t t) (unsigned-byte 8)) core-ivector-readb core-stream-readb) |
---|
297 | (ftype (function (t t) (unsigned-byte 16)) core-ivector-readw core-stream-readw) |
---|
298 | (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl) |
---|
299 | (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq) |
---|
300 | (ftype (function (simple-vector) fixnum) core-section-for-address)) |
---|
301 | |
---|
302 | (define-condition invalid-core-address (simple-error) |
---|
303 | () |
---|
304 | (:default-initargs :format-control "Unknown core address x~x")) |
---|
305 | |
---|
306 | (declaim (inline core-section-for-address)) |
---|
307 | (defun core-section-for-address (address) |
---|
308 | (loop with sections = (core-info-sections (current-core)) |
---|
309 | with len fixnum = (length sections) |
---|
310 | with low fixnum = -1 |
---|
311 | with high fixnum = len |
---|
312 | do (let ((half (the fixnum (ash (%i+ high low) -1)))) |
---|
313 | (declare (fixnum half)) |
---|
314 | (when (eq half low) |
---|
315 | (return (and (%i<= 0 half) |
---|
316 | (%i< half len) |
---|
317 | (let ((sect (%svref sections half))) |
---|
318 | (and (< address (%core-sect.end-addr (%svref sections half))) sect))))) |
---|
319 | (let ((sect (%svref sections half))) |
---|
320 | (if (%i<= (%core-sect.start-addr sect) address) |
---|
321 | (setq low half) |
---|
322 | (setq high half)))))) |
---|
323 | |
---|
324 | (defun core-heap-address-p (address) |
---|
325 | (core-section-for-address address)) |
---|
326 | |
---|
327 | |
---|
328 | (defun core-stream-readb (s offset) |
---|
329 | (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) |
---|
330 | (when offset (stream-position s offset)) |
---|
331 | (read-byte s)) |
---|
332 | |
---|
333 | (defun core-stream-readw (s offset) |
---|
334 | (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) |
---|
335 | (when offset (stream-position s offset)) |
---|
336 | (%i+ (core-stream-readb s nil) (%ilsl 8 (core-stream-readb s nil)))) |
---|
337 | |
---|
338 | (defun core-stream-readl (s offset) |
---|
339 | (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) |
---|
340 | (when offset (stream-position s offset)) |
---|
341 | (%i+ (core-stream-readw s nil) (%ilsl 16 (core-stream-readw s nil)))) |
---|
342 | |
---|
343 | (defun core-stream-readq (s offset) |
---|
344 | (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) |
---|
345 | (when offset (stream-position s offset)) |
---|
346 | (+ (core-stream-readl s nil) (ash (the fixnum (core-stream-readl s nil)) 32))) |
---|
347 | |
---|
348 | (defun core-ivector-readb (vec offset) |
---|
349 | (declare (type (simple-array (unsigned-byte 8) (*)) vec) (fixnum offset) |
---|
350 | (optimize (speed 3) (safety 0))) |
---|
351 | (aref vec offset)) |
---|
352 | |
---|
353 | (defun core-ivector-readw (vec offset) |
---|
354 | (declare (optimize (speed 3) (safety 0))) |
---|
355 | (%i+ (core-ivector-readb vec offset) (%ilsl 8 (core-ivector-readb vec (+ offset 1))))) |
---|
356 | |
---|
357 | (defun core-ivector-readl (vec offset) |
---|
358 | (declare (optimize (speed 3) (safety 0))) |
---|
359 | (%i+ (core-ivector-readw vec offset) (%ilsl 16 (core-ivector-readw vec (+ offset 2))))) |
---|
360 | |
---|
361 | (defun core-ivector-readq (vec offset) |
---|
362 | (declare (optimize (speed 3) (safety 0))) |
---|
363 | (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (+ offset 4)) 32))) |
---|
364 | |
---|
365 | |
---|
366 | (defun core-q (address &optional (offset 0)) |
---|
367 | (declare (optimize (speed 3) (safety 0))) |
---|
368 | (incf address offset) |
---|
369 | (let* ((sect (or (core-section-for-address address) |
---|
370 | (error 'invalid-core-address |
---|
371 | :format-arguments (list address)))) |
---|
372 | (ivector (%core-sect.ivector sect)) |
---|
373 | (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) |
---|
374 | (if ivector |
---|
375 | (core-ivector-readq ivector pos) |
---|
376 | (core-stream-readq (%core-sect.stream sect) pos)))) |
---|
377 | |
---|
378 | |
---|
379 | (defun core-l (address &optional (offset 0)) |
---|
380 | (declare (optimize (speed 3) (safety 0))) |
---|
381 | (incf address offset) |
---|
382 | (let* ((sect (or (core-section-for-address address) |
---|
383 | (error 'invalid-core-address |
---|
384 | :format-arguments (list address)))) |
---|
385 | (ivector (%core-sect.ivector sect)) |
---|
386 | (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) |
---|
387 | (if ivector |
---|
388 | (core-ivector-readl ivector pos) |
---|
389 | (core-stream-readl (%core-sect.stream sect) pos)))) |
---|
390 | |
---|
391 | (defun core-w (address &optional (offset 0)) |
---|
392 | (declare (optimize (speed 3) (safety 0))) |
---|
393 | (incf address offset) |
---|
394 | (let* ((sect (or (core-section-for-address address) |
---|
395 | (error 'invalid-core-address |
---|
396 | :format-arguments (list address)))) |
---|
397 | (ivector (%core-sect.ivector sect)) |
---|
398 | (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) |
---|
399 | (if ivector |
---|
400 | (core-ivector-readw ivector pos) |
---|
401 | (core-stream-readw (%core-sect.stream sect) pos)))) |
---|
402 | |
---|
403 | (defun core-b (address &optional (offset 0)) |
---|
404 | (declare (optimize (speed 3) (safety 0))) |
---|
405 | (incf address offset) |
---|
406 | (let* ((sect (or (core-section-for-address address) |
---|
407 | (error 'invalid-core-address |
---|
408 | :format-arguments (list address)))) |
---|
409 | (ivector (%core-sect.ivector sect)) |
---|
410 | (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) |
---|
411 | (if ivector |
---|
412 | (core-ivector-readb ivector pos) |
---|
413 | (core-stream-readb (%core-sect.stream sect) pos)))) |
---|
414 | |
---|
415 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
416 | ;; |
---|
417 | ;; general utilities |
---|
418 | |
---|
419 | ;; NIL is constant, assume is same in core as here. |
---|
420 | (defun kernel-global-address (global) |
---|
421 | (check-type global symbol) |
---|
422 | (+ (target-nil-value) (target::%kernel-global global))) |
---|
423 | |
---|
424 | (defun nil-relative-symbol-address (sym) |
---|
425 | (+ (target-nil-value) |
---|
426 | #x20 ;;; dunno why |
---|
427 | (* (or (position sym x86::*x86-nil-relative-symbols* :test #'eq) |
---|
428 | (error "Not a nil-relative symbol ~s" sym)) |
---|
429 | target::symbol.size) |
---|
430 | (- target::fulltag-symbol target::fulltag-nil))) |
---|
431 | |
---|
432 | (defun core-area-name (code) |
---|
433 | (or (heap-area-name code) |
---|
434 | (and (integerp code) |
---|
435 | (not (logtest code (1- (ash 1 target::fixnum-shift)))) |
---|
436 | (heap-area-name (ash code (- target::fixnum-shift)))))) |
---|
437 | |
---|
438 | (defx86lapfunction %%raw-obj ((address arg_z)) |
---|
439 | (unbox-fixnum address arg_z) |
---|
440 | (single-value-return)) |
---|
441 | |
---|
442 | (declaim (inline uvheader-p uvheader-typecode uvheader-size)) |
---|
443 | |
---|
444 | (defun uvheader-p (header) |
---|
445 | (let ((tag (logand header target::fulltagmask))) |
---|
446 | (declare (fixnum tag)) |
---|
447 | (and (<= target::fulltag-nodeheader-0 tag) |
---|
448 | (<= tag target::fulltag-immheader-2) |
---|
449 | (neq tag target::fulltag-odd-fixnum)))) |
---|
450 | |
---|
451 | (defun uvheader-typecode (header) |
---|
452 | (the fixnum (logand #xFF header))) |
---|
453 | |
---|
454 | (defun uvheader-size (header) |
---|
455 | (the fixnum (ash header (- target::num-subtag-bits)))) |
---|
456 | |
---|
457 | (defun uvheader-byte-size (header) |
---|
458 | (x8664::x8664-misc-byte-count (uvheader-typecode header) (uvheader-size header))) |
---|
459 | |
---|
460 | (defun uvheader-type (header) |
---|
461 | (let* ((typecode (uvheader-typecode header)) |
---|
462 | (low4 (logand typecode target::fulltagmask)) |
---|
463 | (high4 (ash typecode (- target::ntagbits)))) |
---|
464 | (declare (type (unsigned-byte 8) typecode) |
---|
465 | (type (unsigned-byte 4) low4 high4)) |
---|
466 | (cond ((eql low4 x8664::fulltag-immheader-0) |
---|
467 | (%svref *immheader-0-types* high4)) |
---|
468 | ((eql low4 x8664::fulltag-immheader-1) |
---|
469 | (%svref *immheader-1-types* high4)) |
---|
470 | ((eql low4 x8664::fulltag-immheader-2) |
---|
471 | (%svref *immheader-2-types* high4)) |
---|
472 | ((eql low4 x8664::fulltag-nodeheader-0) |
---|
473 | (%svref *nodeheader-0-types* high4)) |
---|
474 | ((eql low4 x8664::fulltag-nodeheader-1) |
---|
475 | (%svref *nodeheader-1-types* high4)) |
---|
476 | (t 'bogus)))) |
---|
477 | |
---|
478 | (defun uvheader-type-typecode (symbol &aux pos) |
---|
479 | (unless (eq symbol 'bogus) |
---|
480 | (cond ((setq pos (position symbol *immheader-0-types*)) |
---|
481 | (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-0)) |
---|
482 | ((setq pos (position symbol *immheader-1-types*)) |
---|
483 | (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-1)) |
---|
484 | ((setq pos (position symbol *immheader-2-types*)) |
---|
485 | (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-2)) |
---|
486 | ((setq pos (position symbol *nodeheader-0-types*)) |
---|
487 | (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-0)) |
---|
488 | ((setq pos (position symbol *nodeheader-1-types*)) |
---|
489 | (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-1))))) |
---|
490 | |
---|
491 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
492 | ;; |
---|
493 | ;; Core heap |
---|
494 | |
---|
495 | |
---|
496 | (defun core-heap-area-code (area) |
---|
497 | (let ((code (heap-area-code area)) |
---|
498 | (dynamic (ash (core-q (core-q (core-q (kernel-global-address 'all-areas)) |
---|
499 | target::area.succ) |
---|
500 | target::area.code) |
---|
501 | (- target::fixnum-shift)))) |
---|
502 | (if (or (fixnump area) |
---|
503 | (eq dynamic area-dynamic) |
---|
504 | ;; account for watched area having been inserted |
---|
505 | (<= code area-watched)) |
---|
506 | code |
---|
507 | (1- code)))) |
---|
508 | |
---|
509 | (defun map-core-areas (function &key area) |
---|
510 | (if (eq area :tenured) |
---|
511 | (map-core-area (core-q (kernel-global-address 'tenured-area)) function) |
---|
512 | (area-loop with area-ptr |
---|
513 | with area = (cond ((or (eq area t) (eq area nil)) nil) |
---|
514 | ((consp area) (mapcar #'core-heap-area-code area)) |
---|
515 | (t (list (core-heap-area-code area)))) |
---|
516 | as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift)) |
---|
517 | do (when (and (<= area-readonly code) |
---|
518 | (<= code area-dynamic) |
---|
519 | (or (null area) (member code area)) |
---|
520 | (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active))) |
---|
521 | #+debug |
---|
522 | (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)" |
---|
523 | area-ptr (core-area-name code) |
---|
524 | (core-q area-ptr target::area.low) |
---|
525 | (core-q area-ptr target::area.active) |
---|
526 | (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low)) |
---|
527 | (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low))) |
---|
528 | (map-core-area area-ptr function))))) |
---|
529 | |
---|
530 | (defun map-core-area (area-ptr fun) |
---|
531 | (map-core-region (core-q area-ptr target::area.low) |
---|
532 | (core-q area-ptr target::area.active) |
---|
533 | fun)) |
---|
534 | |
---|
535 | (defun map-core-region (ptr end fun) |
---|
536 | (loop |
---|
537 | while (< ptr end) as header = (core-q ptr) |
---|
538 | do (cond ((uvheader-p header) |
---|
539 | (let ((subtag (uvheader-typecode header))) |
---|
540 | (funcall fun |
---|
541 | (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol) |
---|
542 | ((eq subtag target::subtag-function) target::fulltag-function) |
---|
543 | (t target::fulltag-misc))))) |
---|
544 | (let* ((bytes (uvheader-byte-size header)) |
---|
545 | (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size))) |
---|
546 | (1- target::dnode-size)))) |
---|
547 | (declare (fixnum bytes total)) |
---|
548 | (incf ptr total))) |
---|
549 | (t |
---|
550 | (funcall fun (+ ptr target::fulltag-cons)) |
---|
551 | (incf ptr target::cons.size))))) |
---|
552 | |
---|
553 | |
---|
554 | (declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp)) |
---|
555 | |
---|
556 | (defun core-consp (ptr) |
---|
557 | (eq (logand ptr target::fulltagmask) target::fulltag-cons)) |
---|
558 | |
---|
559 | (defun core-symbolp (ptr) |
---|
560 | (eq (logand ptr target::fulltagmask) target::fulltag-symbol)) |
---|
561 | |
---|
562 | (defun core-functionp (ptr) |
---|
563 | (eq (logand ptr target::fulltagmask) target::fulltag-function)) |
---|
564 | |
---|
565 | (defun core-listp (ptr) |
---|
566 | (eq (logand ptr target::tagmask) target::tag-list)) |
---|
567 | |
---|
568 | (defun core-nullp (obj) |
---|
569 | (eq (logand obj target::fulltagmask) target::fulltag-nil)) |
---|
570 | |
---|
571 | ;; uvector utilities |
---|
572 | (declaim (inline core-uvector-p core-uvheader core-uvtypecode core-uvtype)) |
---|
573 | |
---|
574 | (defun core-uvector-p (ptr) |
---|
575 | (%i>= (logand ptr target::fulltagmask) target::fulltag-misc)) |
---|
576 | |
---|
577 | (defun core-uvheader (vec-ptr) |
---|
578 | (core-q (logandc2 vec-ptr target::fulltagmask))) |
---|
579 | |
---|
580 | (defun core-uvtypecode (vec-ptr) |
---|
581 | (uvheader-typecode (core-uvheader vec-ptr))) |
---|
582 | |
---|
583 | (defun core-uvtype (vec-ptr) |
---|
584 | (uvheader-type (core-uvheader vec-ptr))) |
---|
585 | |
---|
586 | (defmacro core-uvtypep (vec-ptr type &aux temp) |
---|
587 | (when (keywordp type) |
---|
588 | (setq type (type-keyword-code type))) |
---|
589 | (when (and (or (symbolp (setq temp type)) |
---|
590 | (and (quoted-form-p type) |
---|
591 | (symbolp (setq temp (cadr type))))) |
---|
592 | (setq temp (find-symbol (symbol-name temp) :ccl)) |
---|
593 | (setq temp (uvheader-type-typecode temp))) |
---|
594 | (setq type temp)) |
---|
595 | (when (constant-symbol-p type) |
---|
596 | (setq temp (symbol-value type)) |
---|
597 | (when (<= 0 temp #xFF) (setq type temp))) |
---|
598 | `(let ((vec-ptr ,vec-ptr)) |
---|
599 | (and (core-uvector-p vec-ptr) |
---|
600 | (eq (core-uvtypecode vec-ptr) ,type)))) |
---|
601 | |
---|
602 | (defun core-uvref (vec-ptr index) |
---|
603 | (let* ((header (core-uvheader vec-ptr)) |
---|
604 | (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) |
---|
605 | (typecode (uvheader-typecode header)) |
---|
606 | (tag (%ilogand typecode target::fulltagmask)) |
---|
607 | (len (uvheader-size header))) |
---|
608 | (assert (< -1 index len)) |
---|
609 | (cond ((or (eq tag target::fulltag-nodeheader-0) |
---|
610 | (eq tag target::fulltag-nodeheader-1)) |
---|
611 | (core-q addr (%ilsl target::word-shift index))) |
---|
612 | ((eq tag target::ivector-class-64-bit) |
---|
613 | (cond ((eq typecode target::subtag-double-float-vector) |
---|
614 | (error "~s not implemented yet" 'target::subtag-double-float-vector)) |
---|
615 | (t |
---|
616 | (core-q addr (%ilsl target::word-shift index))))) |
---|
617 | ((eq tag target::ivector-class-32-bit) |
---|
618 | (cond ((eq typecode target::subtag-simple-base-string) |
---|
619 | (%code-char (core-l addr (%ilsl 2 index)))) |
---|
620 | ((eq typecode target::subtag-single-float-vector) |
---|
621 | (error "~s not implemented yet" 'target::subtag-single-float-vector)) |
---|
622 | (t (core-l addr (%ilsl 2 index))))) |
---|
623 | ((eq typecode target::subtag-bit-vector) |
---|
624 | (let ((byte (core-b addr (%iasr 3 (%i+ index 7))))) |
---|
625 | (error "not implemented, for ~b" byte))) |
---|
626 | ((>= typecode target::min-8-bit-ivector-subtag) |
---|
627 | (core-b addr index)) |
---|
628 | (t (core-w addr (%ilsl 1 index)))))) |
---|
629 | |
---|
630 | (defun core-uvsize (vec-ptr) |
---|
631 | (uvheader-size (core-uvheader vec-ptr))) |
---|
632 | |
---|
633 | (defun core-car (obj) |
---|
634 | (assert (core-listp obj)) |
---|
635 | (core-q obj target::cons.car)) |
---|
636 | |
---|
637 | (defun core-cdr (obj) |
---|
638 | (assert (core-listp obj)) |
---|
639 | (core-q obj target::cons.cdr)) |
---|
640 | |
---|
641 | (defun core-object-typecode-type (obj) |
---|
642 | (let ((fulltag (logand obj target::fulltagmask))) |
---|
643 | (cond ((eq fulltag target::fulltag-cons) 'cons) |
---|
644 | ((eq fulltag target::fulltag-nil) 'null) |
---|
645 | ((eq (logand fulltag target::tagmask) target::tag-fixnum) 'fixnum) |
---|
646 | ((and (or (eq fulltag target::fulltag-imm-0) |
---|
647 | (eq fulltag target::fulltag-imm-1)) |
---|
648 | (fixnump obj)) |
---|
649 | ;; Assumes we're running on same architecture as core file. |
---|
650 | (type-of (%%raw-obj obj))) |
---|
651 | ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address) |
---|
652 | ((eq fulltag target::fulltag-misc) |
---|
653 | ;; (core-uvtype obj) |
---|
654 | (handler-case (core-uvtype obj) (invalid-core-address () 'unmapped))) |
---|
655 | ((eq fulltag target::fulltag-symbol) 'symbol) |
---|
656 | ;; TODO: Could get hairier based on lfun-bits, but usually don't care. |
---|
657 | ((eq fulltag target::fulltag-function) 'function) |
---|
658 | (t (cerror "treat as ~*~s" "Invalid object tag at #x~x" obj 'bogus) |
---|
659 | 'bogus)))) |
---|
660 | |
---|
661 | (defun core-object-type-key (obj) |
---|
662 | ;; Returns either a symbol (for built-in types) or a pointer to type symbol or class. |
---|
663 | ;; Whatever it returns must be suitable for use in an eql hash table; use core-type-string |
---|
664 | ;; to get a printable rep. |
---|
665 | (let ((type (core-object-typecode-type obj))) |
---|
666 | (case type |
---|
667 | (function (core-function-type obj)) |
---|
668 | (internal-structure (core-istruct-type obj)) |
---|
669 | (structure (core-struct-type obj)) |
---|
670 | (instance (core-instance-type obj)) |
---|
671 | (t type)))) |
---|
672 | |
---|
673 | (defun core-function-type (obj) |
---|
674 | (and (core-uvtypep obj :function) |
---|
675 | (let ((bits (core-lfun-bits obj))) |
---|
676 | (declare (fixnum bits)) |
---|
677 | (or (if (logbitp $lfbits-trampoline-bit bits) |
---|
678 | (let* ((inner-fn (core-closure-function obj)) |
---|
679 | (inner-bits (core-lfun-bits inner-fn))) |
---|
680 | (if (neq inner-fn obj) |
---|
681 | (if (logbitp $lfbits-method-bit inner-bits) |
---|
682 | 'compiled-lexical-closure |
---|
683 | (unless (logbitp $lfbits-gfn-bit inner-bits) |
---|
684 | (if (logbitp $lfbits-cm-bit inner-bits) |
---|
685 | 'combined-method |
---|
686 | 'compiled-lexical-closure))) |
---|
687 | 'compiled-lexical-closure)) |
---|
688 | (if (logbitp $lfbits-method-bit bits) |
---|
689 | 'method-function |
---|
690 | (unless (logbitp $lfbits-gfn-bit bits) |
---|
691 | (if (logbitp $lfbits-cm-bit bits) |
---|
692 | 'combined-method |
---|
693 | 'function)))) |
---|
694 | (core-class-name |
---|
695 | (core-uvref |
---|
696 | (core-nth-immediate obj gf.instance.class-wrapper) |
---|
697 | %wrapper-class)))))) |
---|
698 | |
---|
699 | (defun core-type-string (object-type) |
---|
700 | (with-output-to-string (s) |
---|
701 | (if (fixnump object-type) |
---|
702 | (core-print object-type s) |
---|
703 | (prin1 object-type s)))) |
---|
704 | |
---|
705 | (defun core-istruct-type (obj) |
---|
706 | (and (core-uvtypep obj :istruct) |
---|
707 | (core-car (core-uvref obj 0)))) |
---|
708 | |
---|
709 | (defun core-struct-type (obj) |
---|
710 | (and (core-uvtypep obj :struct) |
---|
711 | (core-uvref (core-car (core-uvref obj 0)) 1))) |
---|
712 | |
---|
713 | (defun core-instance-type (obj) |
---|
714 | (and (core-uvtypep obj :instance) |
---|
715 | (core-class-name (core-instance-class obj)))) |
---|
716 | |
---|
717 | (defun core-class-name (class) |
---|
718 | (core-uvref (core-uvref class instance.slots) %class.name)) |
---|
719 | |
---|
720 | (defun core-object-type-and-size (obj) |
---|
721 | (let ((fulltag (logand obj target::fulltagmask))) |
---|
722 | (if (eq fulltag target::fulltag-cons) |
---|
723 | (values 'cons target::dnode-size target::dnode-size) |
---|
724 | (if (%i<= target::fulltag-misc fulltag) |
---|
725 | (let* ((header (core-uvheader obj)) |
---|
726 | (logsize (uvheader-byte-size header)) |
---|
727 | ;; total including header and alignment. |
---|
728 | (total (logandc2 (+ logsize target::node-size (1- target::dnode-size)) |
---|
729 | (1- target::dnode-size)))) |
---|
730 | (values (uvheader-type header) logsize total)))))) |
---|
731 | |
---|
732 | (defun core-heap-utilization (&key (stream *debug-io*) area unit (sort :size) classes (threshold 0.00005)) |
---|
733 | (let* ((obj-hash (make-hash-table :shared nil)) |
---|
734 | (slotv-hash (make-hash-table :shared nil)) |
---|
735 | (all nil)) |
---|
736 | (map-core-areas (lambda (obj &aux (hash obj-hash)) |
---|
737 | (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj) |
---|
738 | (when classes |
---|
739 | (when (core-uvtypep obj :slot-vector) |
---|
740 | (setq hash slotv-hash |
---|
741 | obj (core-uvref obj slot-vector.instance))) |
---|
742 | (setq type (core-object-type-key obj))) |
---|
743 | (let ((a (or (gethash type hash) |
---|
744 | (setf (gethash type hash) (list 0 0 0))))) |
---|
745 | (incf (car a)) |
---|
746 | (incf (cadr a) logsize) |
---|
747 | (incf (caddr a) physsize)))) |
---|
748 | :area area) |
---|
749 | (maphash (lambda (type data) |
---|
750 | (push (cons (core-type-string type) data) all)) |
---|
751 | obj-hash) |
---|
752 | (maphash (lambda (type data) |
---|
753 | (push (cons (concatenate 'string (core-type-string type) " slot-vector") data) all)) |
---|
754 | slotv-hash) |
---|
755 | (report-heap-utilization all :stream stream :unit unit :sort sort :threshold threshold))) |
---|
756 | |
---|
757 | |
---|
758 | (defstruct unresolved-address address) |
---|
759 | |
---|
760 | (defmethod print-object ((obj unresolved-address) stream) |
---|
761 | (let* ((address (unresolved-address-address obj))) |
---|
762 | (if (and (core-uvector-p address) |
---|
763 | (not (handler-case (core-uvheader address) (invalid-core-address () nil)))) |
---|
764 | (format stream "#<Unmapped #x~x >" address) |
---|
765 | (format stream "#<Core ~A~@[[~d]~] #x~x >" |
---|
766 | (or (ignore-errors (core-type-string (core-object-type-key address))) |
---|
767 | (core-object-typecode-type address)) |
---|
768 | (and (core-uvector-p address) (core-uvsize address)) |
---|
769 | address)))) |
---|
770 | |
---|
771 | (defun copy-from-core (obj &key (depth 1)) |
---|
772 | (check-type depth (integer 0)) |
---|
773 | (when (unresolved-address-p obj) |
---|
774 | (setq obj (unresolved-address-address obj))) |
---|
775 | (let ((fulltag (logand obj target::fulltagmask))) |
---|
776 | (cond ((eq fulltag target::fulltag-nil) nil) |
---|
777 | ((eq (logand fulltag target::tagmask) target::tag-fixnum) |
---|
778 | (ash obj (- target::fixnum-shift))) |
---|
779 | ((and (fixnump obj) |
---|
780 | (or (eq fulltag target::fulltag-imm-0) |
---|
781 | (eq fulltag target::fulltag-imm-1))) |
---|
782 | (%%raw-obj obj)) |
---|
783 | ((< (decf depth) 0) |
---|
784 | (make-unresolved-address :address obj)) |
---|
785 | ((and (%i<= target::fulltag-misc fulltag) |
---|
786 | (handler-case (core-uvheader obj) (invalid-core-address nil))) |
---|
787 | (or (and (core-uvtypep obj :package) |
---|
788 | (find-package (core-package-name obj))) |
---|
789 | (let ((v (%copy-uvector-from-core obj depth))) |
---|
790 | (when (and (symbolp v) (<= depth 1)) |
---|
791 | ;; Need to fix up the package slot else it's not useful |
---|
792 | (let ((pp (%svref (symptr->symvector v) target::symbol.package-predicate-cell))) |
---|
793 | (when (unresolved-address-p pp) |
---|
794 | (setq pp (copy-from-core pp :depth 1))) |
---|
795 | (when (and (consp pp) (unresolved-address-p (car pp))) |
---|
796 | (let ((pkg (unresolved-address-address (car pp)))) |
---|
797 | (when (and (core-uvtypep pkg :package) |
---|
798 | (setq pkg (find-package (core-package-name pkg)))) |
---|
799 | (setf (car pp) pkg)))) |
---|
800 | (setf (%svref (symptr->symvector v) target::symbol.package-predicate-cell) pp)) |
---|
801 | ;; ditto for pname |
---|
802 | (let ((pp (%svref (symptr->symvector v) target::symbol.pname-cell))) |
---|
803 | (when (unresolved-address-p pp) |
---|
804 | (setf (%svref (symptr->symvector v) target::symbol.pname-cell) |
---|
805 | (copy-from-core pp :depth 1))))) |
---|
806 | v))) |
---|
807 | ((eq fulltag target::fulltag-cons) |
---|
808 | (cons (copy-from-core (core-car obj) :depth depth) |
---|
809 | (copy-from-core (core-cdr obj) :depth depth))) |
---|
810 | (t (make-unresolved-address :address obj))))) |
---|
811 | |
---|
812 | (defun %copy-uvector-from-core (vec-ptr depth) |
---|
813 | (let* ((header (core-uvheader vec-ptr)) |
---|
814 | (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) |
---|
815 | (typecode (uvheader-typecode header)) |
---|
816 | (tag (logand typecode target::fulltagmask)) |
---|
817 | (len (uvheader-size header)) |
---|
818 | (vec (%alloc-misc len typecode))) |
---|
819 | (declare (type fixnum typecode tag len)) |
---|
820 | (cond ((or (eq tag target::fulltag-nodeheader-0) |
---|
821 | (eq tag target::fulltag-nodeheader-1)) |
---|
822 | (when (eq typecode target::subtag-function) |
---|
823 | ;; Don't bother copying the code for now |
---|
824 | (let ((skip (core-l addr))) |
---|
825 | (declare (fixnum skip)) |
---|
826 | (assert (<= 0 skip len)) |
---|
827 | (incf addr (ash skip target::word-shift)) |
---|
828 | (decf len skip))) |
---|
829 | (dotimes (i len) |
---|
830 | (declare (fixnum i)) |
---|
831 | (setf (%svref vec i) |
---|
832 | (copy-from-core (core-q addr (%ilsl target::word-shift i)) :depth depth))) |
---|
833 | (let ((ptrtag (logand vec-ptr target::fulltagmask))) |
---|
834 | (cond ((eq ptrtag target::fulltag-symbol) |
---|
835 | (%symvector->symptr vec)) |
---|
836 | ((eq ptrtag target::fulltag-function) |
---|
837 | (%function-vector-to-function vec)) |
---|
838 | (t vec)))) |
---|
839 | ((eq tag target::ivector-class-64-bit) |
---|
840 | (cond ((eq typecode target::subtag-double-float-vector) |
---|
841 | (warn "~s not implemented yet" 'target::subtag-double-float-vector) |
---|
842 | (make-unresolved-address :address vec-ptr)) |
---|
843 | (t |
---|
844 | (dotimes (i len vec) |
---|
845 | (setf (uvref vec i) (core-q addr (%ilsl target::word-shift i))))))) |
---|
846 | ((eq tag target::ivector-class-32-bit) |
---|
847 | (cond ((eq typecode target::subtag-simple-base-string) |
---|
848 | (dotimes (i len vec) |
---|
849 | (setf (uvref vec i) (%code-char (core-l addr (%ilsl 2 i)))))) |
---|
850 | ((eq typecode target::subtag-single-float-vector) |
---|
851 | (warn "~s not implemented yet" 'target::subtag-single-float-vector) |
---|
852 | (make-unresolved-address :address vec-ptr)) |
---|
853 | (t |
---|
854 | (dotimes (i len vec) |
---|
855 | (setf (uvref vec i) (core-l addr (%ilsl 2 i))))))) |
---|
856 | ((eq typecode target::subtag-bit-vector) |
---|
857 | (warn "bit vector not implemented yet") |
---|
858 | (make-unresolved-address :address vec-ptr)) |
---|
859 | ((>= typecode target::min-8-bit-ivector-subtag) |
---|
860 | (dotimes (i len vec) |
---|
861 | (setf (uvref vec i) (core-b addr i)))) |
---|
862 | (t |
---|
863 | (dotimes (i len vec) |
---|
864 | (setf (uvref vec i) (core-w addr (%ilsl 1 i)))))))) |
---|
865 | |
---|
866 | (defun map-core-pointers (fn &key area) |
---|
867 | (map-core-areas (lambda (obj) |
---|
868 | (cond ((core-consp obj) |
---|
869 | (funcall fn (core-car obj) obj 0) |
---|
870 | (funcall fn (core-cdr obj) obj 1)) |
---|
871 | (t |
---|
872 | (let* ((header (core-uvheader obj)) |
---|
873 | (subtag (logand header target::fulltagmask))) |
---|
874 | (when (or (eq subtag target::fulltag-nodeheader-0) |
---|
875 | (eq subtag target::fulltag-nodeheader-1)) |
---|
876 | (let* ((typecode (uvheader-typecode header)) |
---|
877 | (len (uvheader-size header)) |
---|
878 | (addr (+ (logandc2 obj target::fulltagmask) target::node-size))) |
---|
879 | (declare (fixnum typecode len)) |
---|
880 | (when (eq typecode target::subtag-function) |
---|
881 | (let ((skip (core-l addr))) |
---|
882 | (declare (fixnum skip)) |
---|
883 | (assert (<= 0 skip len)) |
---|
884 | (incf addr (%ilsl target::word-shift skip)) |
---|
885 | (decf len skip))) |
---|
886 | (dotimes (i len) |
---|
887 | (funcall fn (core-q addr (%ilsl target::word-shift i)) obj i)))))))) |
---|
888 | :area area)) |
---|
889 | |
---|
890 | (defun core-find-tra-function (tra) |
---|
891 | (assert (eq (logand tra target::tagmask) target::tag-tra)) |
---|
892 | (map-core-areas (lambda (obj) |
---|
893 | (when (core-uvtypep obj :function) |
---|
894 | (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size)) |
---|
895 | (skip (core-l addr)) |
---|
896 | (offset (- tra addr))) |
---|
897 | (when (<= 0 offset (ash skip target::word-shift)) |
---|
898 | (return-from core-find-tra-function (values obj (+ offset (- target::node-size |
---|
899 | (logand obj target::fulltagmask))))))))))) |
---|
900 | |
---|
901 | (defun core-instance-class (obj) |
---|
902 | (when (core-uvtypep obj :slot-vector) |
---|
903 | (setq obj (core-uvref obj slot-vector.instance))) |
---|
904 | (assert (core-uvtypep obj :instance)) |
---|
905 | (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class)) |
---|
906 | |
---|
907 | (defun core-instance-p (obj class) |
---|
908 | (and (core-uvtypep obj :instance) |
---|
909 | (labels ((matchp (iclass) |
---|
910 | (or (eql iclass class) |
---|
911 | (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers) |
---|
912 | then (core-cdr supers) |
---|
913 | while (core-consp supers) |
---|
914 | thereis (matchp (core-car supers)))))) |
---|
915 | (matchp (core-instance-class obj))))) |
---|
916 | |
---|
917 | |
---|
918 | (defun core-symptr (obj) |
---|
919 | (if (core-nullp obj) |
---|
920 | (nil-relative-symbol-address 'nil) |
---|
921 | (when (core-uvtypep obj :symbol) |
---|
922 | (let ((tag (logand obj target::fulltagmask))) |
---|
923 | (unless (eq tag target::fulltag-symbol) |
---|
924 | (incf obj (%i- target::fulltag-symbol tag)))) |
---|
925 | obj))) |
---|
926 | |
---|
927 | (defun core-symbol-name (obj) |
---|
928 | (when (setq obj (core-symptr obj)) |
---|
929 | (copy-from-core (core-q obj target::symbol.pname) :depth 1))) |
---|
930 | |
---|
931 | (defun core-symbol-value (obj) |
---|
932 | (when (setq obj (core-symptr obj)) |
---|
933 | (core-q obj target::symbol.vcell))) |
---|
934 | |
---|
935 | (defun core-symbol-package (obj) |
---|
936 | (when (setq obj (core-symptr obj)) |
---|
937 | (let ((cell (core-q obj target::symbol.package-predicate))) |
---|
938 | (if (core-consp cell) |
---|
939 | (core-car cell) |
---|
940 | cell)))) |
---|
941 | |
---|
942 | (defun core-symbol-plist (obj) |
---|
943 | (when (setq obj (core-symptr obj)) |
---|
944 | (core-cdr (core-q obj target::symbol.plist)))) |
---|
945 | |
---|
946 | (defun core-all-packages-ptr () |
---|
947 | (core-symbol-value (nil-relative-symbol-address '%all-packages%))) |
---|
948 | |
---|
949 | (defun core-keyword-package () |
---|
950 | (core-symbol-value (nil-relative-symbol-address '*keyword-package*))) |
---|
951 | |
---|
952 | (defun core-symbol-pointers () |
---|
953 | (or (core-info-symbol-ptrs (current-core)) |
---|
954 | (let ((vector (make-array 1000 :adjustable t :fill-pointer 0))) |
---|
955 | (map-core-areas (lambda (obj) |
---|
956 | (when (core-symbolp obj) |
---|
957 | (vector-push-extend obj vector)))) |
---|
958 | (setf (core-info-symbol-ptrs (current-core)) vector)))) |
---|
959 | |
---|
960 | (defun core-map-symbols (fun) |
---|
961 | (loop for sym-ptr across (core-symbol-pointers) do (funcall fun sym-ptr))) |
---|
962 | |
---|
963 | |
---|
964 | (defun core-string= (ptr string &aux (len (length string))) |
---|
965 | (assert (core-uvtypep ptr :simple-string)) |
---|
966 | (when (eq (core-uvsize ptr) len) |
---|
967 | (loop for i from 0 below len |
---|
968 | always (eql (core-uvref ptr i) (aref string i))))) |
---|
969 | |
---|
970 | (defun core-find-package (name &key error) |
---|
971 | (when (integerp name) |
---|
972 | (when (core-symbolp name) |
---|
973 | (setq name (core-q name target::symbol.pname))) |
---|
974 | (when (core-uvtypep name :simple-string) |
---|
975 | (setq name (copy-from-core name :depth 1)))) |
---|
976 | (setq name (string name)) |
---|
977 | (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr) |
---|
978 | while (core-consp list-ptr) |
---|
979 | as pkg-ptr = (core-car list-ptr) |
---|
980 | when (loop for names-ptr = (core-uvref pkg-ptr pkg.names) then (core-cdr names-ptr) |
---|
981 | while (core-consp names-ptr) |
---|
982 | as name-ptr = (core-car names-ptr) |
---|
983 | thereis (core-string-equal name-ptr name)) |
---|
984 | do (return pkg-ptr)) |
---|
985 | (and error (error "No package named ~s" name)))) |
---|
986 | |
---|
987 | (defun core-package-names (pkg-ptr) |
---|
988 | (assert (core-uvtypep pkg-ptr :package)) |
---|
989 | (copy-from-core (core-uvref pkg-ptr pkg.names) :depth 2)) |
---|
990 | |
---|
991 | (defun core-package-name (pkg-ptr) |
---|
992 | (assert (core-uvtypep pkg-ptr :package)) |
---|
993 | (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1)) |
---|
994 | |
---|
995 | (defun core-find-symbol (name &optional package) |
---|
996 | ;; Unlike cl:find-symbol, this doesn't look for inherited symbols, |
---|
997 | ;; you have to get the package right. |
---|
998 | (when (integerp name) |
---|
999 | (when (core-symbolp name) |
---|
1000 | (when (null package) |
---|
1001 | (setq package (core-symbol-package name))) |
---|
1002 | (setq name (core-q name target::symbol.pname))) |
---|
1003 | (when (core-uvtypep name :simple-string) |
---|
1004 | (setq name (copy-from-core name :depth 1)))) |
---|
1005 | (when (and (null package) (non-nil-symbolp name)) |
---|
1006 | (setq package (symbol-package name))) |
---|
1007 | (when (null package) (error "Package is required")) |
---|
1008 | (let* ((symbol-name (string name)) |
---|
1009 | (name-len (length symbol-name)) |
---|
1010 | (pkg-ptr (if (and (integerp package) (core-uvtypep package :package)) |
---|
1011 | package |
---|
1012 | (core-find-package (if (packagep package) |
---|
1013 | (package-name package) |
---|
1014 | package) |
---|
1015 | :error t)))) |
---|
1016 | (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len) |
---|
1017 | (flet ((findsym (htab-ptr) |
---|
1018 | (let* ((vec-ptr (core-car htab-ptr)) |
---|
1019 | (vlen (core-uvsize vec-ptr))) |
---|
1020 | (loop for idx = (fast-mod primary vlen) then (+ i secondary) |
---|
1021 | for i = idx then (if (>= idx vlen) (- idx vlen) idx) |
---|
1022 | as sym = (core-uvref vec-ptr i) |
---|
1023 | until (eql sym 0) |
---|
1024 | do (when (and (core-symbolp sym) |
---|
1025 | (core-string-equal (core-q sym target::symbol.pname) symbol-name)) |
---|
1026 | (return (if (eq sym (nil-relative-symbol-address 'nil)) |
---|
1027 | (target-nil-value) |
---|
1028 | sym))))))) |
---|
1029 | (or (findsym (core-uvref pkg-ptr pkg.itab)) |
---|
1030 | (findsym (core-uvref pkg-ptr pkg.etab))))))) |
---|
1031 | |
---|
1032 | (defun core-gethash (key-ptr hash-ptr) |
---|
1033 | (when (core-uvtypep hash-ptr :istruct) |
---|
1034 | (setq hash-ptr (core-uvref hash-ptr nhash.vector))) |
---|
1035 | (assert (core-uvtypep hash-ptr :hash-vector)) |
---|
1036 | (loop for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 |
---|
1037 | do (when (eq (core-uvref hash-ptr i) key-ptr) |
---|
1038 | (return (core-uvref hash-ptr (1+ i)))))) |
---|
1039 | |
---|
1040 | (defun core-hash-table-count (hash-ptr) |
---|
1041 | (when (core-uvtypep hash-ptr :istruct) |
---|
1042 | (setq hash-ptr (core-uvref hash-ptr nhash.vector))) |
---|
1043 | (assert (core-uvtypep hash-ptr :hash-vector)) |
---|
1044 | (loop with rehashing = (%fixnum-address-of (%slot-unbound-marker)) |
---|
1045 | with free = (%fixnum-address-of (%unbound-marker)) |
---|
1046 | for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 |
---|
1047 | count (let ((value (core-uvref hash-ptr (1+ i)))) |
---|
1048 | (when (eq value rehashing) |
---|
1049 | (error "This table is being rehashed")) |
---|
1050 | (neq value free)))) |
---|
1051 | |
---|
1052 | (defun core-classes-hash-table-ptr () |
---|
1053 | (or (core-info-classes-hash-table-ptr (current-core)) |
---|
1054 | (setf (core-info-classes-hash-table-ptr (current-core)) |
---|
1055 | (core-symbol-value (core-find-symbol '%find-classes%))))) |
---|
1056 | |
---|
1057 | (defun core-find-class (name) |
---|
1058 | (let* ((name-ptr (etypecase name |
---|
1059 | (integer |
---|
1060 | (assert (core-symbolp name)) |
---|
1061 | name) |
---|
1062 | (symbol (core-find-symbol name)))) |
---|
1063 | (hash-ptr (core-classes-hash-table-ptr)) |
---|
1064 | (cell (core-gethash name-ptr hash-ptr)) |
---|
1065 | (class (and cell (core-uvref cell class-cell-class)))) |
---|
1066 | (and class (core-uvtypep class :instance) class))) |
---|
1067 | |
---|
1068 | (defun core-lfun-names-table-ptr () |
---|
1069 | (or (core-info-lfun-names-table-ptr (current-core)) |
---|
1070 | (setf (core-info-lfun-names-table-ptr (current-core)) |
---|
1071 | (core-symbol-value (core-find-symbol '*lfun-names*))))) |
---|
1072 | |
---|
1073 | (defun core-nth-immediate (fn i) |
---|
1074 | (assert (core-uvtypep fn :function)) |
---|
1075 | (let ((addr (+ (logandc2 fn target::fulltagmask) target::node-size))) |
---|
1076 | (core-q addr (%ilsl target::word-shift (+ (core-l addr) i -1))))) |
---|
1077 | |
---|
1078 | (defun core-closure-function (fun) |
---|
1079 | (while (and (core-functionp fun) |
---|
1080 | (logbitp $lfbits-trampoline-bit (core-lfun-bits fun))) |
---|
1081 | (setq fun (core-nth-immediate fun 1)) |
---|
1082 | (when (core-uvtypep fun :simple-vector) |
---|
1083 | (setq fun (core-uvref fun 0))) |
---|
1084 | #+gz (assert (core-functionp fun))) |
---|
1085 | fun) |
---|
1086 | |
---|
1087 | (defun core-lfun-name (fn) |
---|
1088 | (assert (core-functionp fn)) |
---|
1089 | (flet ((lfun-name (fn) |
---|
1090 | (or (core-gethash fn (core-lfun-names-table-ptr)) |
---|
1091 | (let* ((lfbits (core-lfun-bits fn)) |
---|
1092 | (name (if (and (logbitp $lfbits-gfn-bit lfbits) |
---|
1093 | (not (logbitp $lfbits-method-bit lfbits))) |
---|
1094 | (core-uvref (core-nth-immediate fn gf.slots) sgf.name) |
---|
1095 | (unless (logbitp $lfbits-noname-bit lfbits) |
---|
1096 | (core-uvref fn (- (core-uvsize fn) 2)))))) |
---|
1097 | (and name |
---|
1098 | (not (eql name (%fixnum-address-of (%slot-unbound-marker)))) |
---|
1099 | (not (core-nullp name)) |
---|
1100 | name))))) |
---|
1101 | (or (lfun-name fn) |
---|
1102 | (let ((inner-fn (core-closure-function fn))) |
---|
1103 | (and (core-functionp inner-fn) |
---|
1104 | (not (eql inner-fn fn)) |
---|
1105 | (lfun-name inner-fn)))))) |
---|
1106 | |
---|
1107 | (defun core-list (ptr) |
---|
1108 | (let ((cars (loop while (core-consp ptr) |
---|
1109 | collect (core-car ptr) |
---|
1110 | do (setq ptr (core-cdr ptr))))) |
---|
1111 | (if (core-nullp ptr) |
---|
1112 | cars |
---|
1113 | (nconc cars ptr)))) |
---|
1114 | |
---|
1115 | (defun core-all-processes () |
---|
1116 | (let* ((sym (core-find-symbol 'all-processes)) |
---|
1117 | (closure (core-uvref sym target::symbol.fcell-cell)) |
---|
1118 | (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size)) |
---|
1119 | (imm-end (core-uvsize closure)) |
---|
1120 | (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx) |
---|
1121 | when (core-uvtypep imm :value-cell) return imm)) |
---|
1122 | (val (core-uvref vcell target::value-cell.value-cell)) |
---|
1123 | (processes (core-list val))) |
---|
1124 | processes)) |
---|
1125 | |
---|
1126 | (defun core-process-name (proc) |
---|
1127 | (assert (core-uvtypep proc :instance)) |
---|
1128 | (let ((slots (core-uvref proc ccl::instance.slots))) |
---|
1129 | (copy-from-core (core-uvref slots 1) :depth 1))) |
---|
1130 | |
---|
1131 | (defun core-process-tcr (proc) |
---|
1132 | (assert (core-uvtypep proc :instance)) |
---|
1133 | (let* ((slots (core-uvref proc ccl::instance.slots)) |
---|
1134 | (thread (core-uvref slots 2))) |
---|
1135 | (core-uvref thread ccl::lisp-thread.tcr))) |
---|
1136 | |
---|
1137 | (defun core-find-process-for-id (lwp) |
---|
1138 | (loop for proc in (core-all-processes) |
---|
1139 | when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id)) |
---|
1140 | return proc)) |
---|
1141 | |
---|
1142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
---|
1143 | |
---|
1144 | (defun core-process-class () |
---|
1145 | (or (core-info-process-class (current-core)) |
---|
1146 | (setf (core-info-process-class (current-core)) |
---|
1147 | (core-find-class 'process)))) |
---|
1148 | |
---|
1149 | (defun core-print (obj &optional (stream t) depth) |
---|
1150 | ;; TODO: could dispatch on core-object-typecode-type... |
---|
1151 | (cond ((core-nullp obj) (format stream "NIL")) |
---|
1152 | ((core-symbolp obj) |
---|
1153 | (core-print-symbol obj stream)) |
---|
1154 | ((core-uvtypep obj :function) |
---|
1155 | (core-print-function obj stream)) |
---|
1156 | ((core-instance-p obj (core-process-class)) |
---|
1157 | (core-print-process obj stream)) |
---|
1158 | ((and depth (< (decf depth) 0)) |
---|
1159 | (format stream "x~x" obj)) |
---|
1160 | ((core-consp obj) |
---|
1161 | (loop for sep = "(" then " " |
---|
1162 | for i from 0 below (or *print-length* 100) |
---|
1163 | while (core-consp obj) |
---|
1164 | do (format stream sep) |
---|
1165 | do (core-print (core-car obj) stream depth) |
---|
1166 | do (setq obj (core-cdr obj))) |
---|
1167 | (unless (core-nullp obj) |
---|
1168 | (format stream " . ") |
---|
1169 | (core-print obj stream depth)) |
---|
1170 | (format stream ")")) |
---|
1171 | (t (format stream "#<core ~a x~x>" |
---|
1172 | (or (ignore-errors (core-type-string (core-object-type-key obj))) |
---|
1173 | (core-object-typecode-type obj)) |
---|
1174 | obj)))) |
---|
1175 | |
---|
1176 | (defun core-print-symbol (sym stream) |
---|
1177 | (let ((package (core-symbol-package sym))) |
---|
1178 | (cond ((core-nullp package) |
---|
1179 | (format stream "#:")) |
---|
1180 | ((eq package (core-keyword-package)) |
---|
1181 | (format stream ":")) |
---|
1182 | (t (let ((pkgname (core-package-name package))) |
---|
1183 | (etypecase pkgname |
---|
1184 | (unresolved-address (format stream "@~x::" (unresolved-address-address pkgname))) |
---|
1185 | (string (unless (string-equal pkgname "COMMON-LISP") |
---|
1186 | (format stream "~a::" pkgname))))))) |
---|
1187 | (let ((symname (core-symbol-name sym))) |
---|
1188 | (etypecase symname |
---|
1189 | (unresolved-address (format stream "@~x" (unresolved-address-address symname))) |
---|
1190 | (string (format stream "~a" symname))))) |
---|
1191 | (values)) |
---|
1192 | |
---|
1193 | (defun core-lfun-bits (fun) |
---|
1194 | (let ((unsigned (core-uvref fun (1- (core-uvsize fun))))) |
---|
1195 | (ash (if (logbitp (1- (* target::node-size 8)) unsigned) |
---|
1196 | (logior (ash -1 (* target::node-size 8)) unsigned) |
---|
1197 | unsigned) |
---|
1198 | (- target::fixnum-shift)))) |
---|
1199 | |
---|
1200 | |
---|
1201 | (defun core-print-function (fun stream) |
---|
1202 | (let* ((lfbits (core-lfun-bits fun)) |
---|
1203 | (name (core-lfun-name fun))) |
---|
1204 | (format stream "#<") |
---|
1205 | (cond ((or (null name) (core-nullp name)) |
---|
1206 | (format stream "Anonymous function")) |
---|
1207 | ((logbitp $lfbits-method-bit lfbits) |
---|
1208 | (assert (core-uvtypep name :instance)) |
---|
1209 | (let* ((slot-vector (core-uvref name instance.slots)) |
---|
1210 | (method-qualifiers (core-uvref slot-vector %method.qualifiers)) |
---|
1211 | (method-specializers (core-uvref slot-vector %method.specializers)) |
---|
1212 | (method-name (core-uvref slot-vector %method.name))) |
---|
1213 | (format stream "Method-Function ") |
---|
1214 | (core-print method-name stream) |
---|
1215 | (format stream " ") |
---|
1216 | (unless (core-nullp method-qualifiers) |
---|
1217 | (if (core-nullp (core-cdr method-qualifiers)) |
---|
1218 | (core-print (core-car method-qualifiers) stream) |
---|
1219 | (core-print method-qualifiers stream)) |
---|
1220 | (format stream " ")) |
---|
1221 | ;; print specializer list but print names instead of classes. |
---|
1222 | (loop for sep = "(" then " " |
---|
1223 | while (core-consp method-specializers) |
---|
1224 | do (format stream sep) |
---|
1225 | do (let ((spec (core-car method-specializers))) |
---|
1226 | (if (core-uvtypep spec :instance) |
---|
1227 | (let ((slots (core-uvref spec instance.slots))) |
---|
1228 | ;; specializer is either a class or a ccl::eql-specializer |
---|
1229 | (if (eql (core-uvsize slots) 3) |
---|
1230 | (progn |
---|
1231 | (format stream "(EQL ") |
---|
1232 | (core-print (core-uvref slots 2) stream) |
---|
1233 | (format stream ")")) |
---|
1234 | (core-print (core-uvref slots %class.name) stream))) |
---|
1235 | (core-print spec stream))) |
---|
1236 | do (setq method-specializers (core-cdr method-specializers))) |
---|
1237 | (unless (core-nullp method-specializers) |
---|
1238 | (format stream " . ") |
---|
1239 | (core-print method-specializers stream)) |
---|
1240 | (format stream ")"))) |
---|
1241 | (t |
---|
1242 | (if (logbitp $lfbits-gfn-bit lfbits) |
---|
1243 | (format stream "Generic Function ") |
---|
1244 | (format stream "Function ")) |
---|
1245 | (core-print name stream))) |
---|
1246 | (format stream " x~x>" fun))) |
---|
1247 | |
---|
1248 | (defun core-print-process (proc stream) |
---|
1249 | (format stream "#<~a ~s LWP(~d) #x~x>" |
---|
1250 | (core-symbol-name (core-instance-type proc)) |
---|
1251 | (core-process-name proc) |
---|
1252 | (core-q (core-process-tcr proc) target::tcr.native-thread-id) |
---|
1253 | proc)) |
---|
1254 | |
---|
1255 | (defun dwim-core-frame-pointer (tcr &optional end) |
---|
1256 | (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr))) |
---|
1257 | (lexprs (list (core-q (kernel-global-address 'lexpr-return)) |
---|
1258 | (core-q (kernel-global-address 'lexpr-return1v)))) |
---|
1259 | (stack-area (core-q tcr target::tcr.vs-area)) |
---|
1260 | (fp (core-q stack-area target::area.high)) |
---|
1261 | (low (core-q stack-area target::area.low))) |
---|
1262 | (flet ((validp (pp) |
---|
1263 | (let ((tra (core-q pp target::lisp-frame.return-address))) |
---|
1264 | (when (eql tra ret1valn) |
---|
1265 | (setq tra (core-q pp target::lisp-frame.xtra))) |
---|
1266 | (or (eql (logand tra target::tagmask) target::tag-tra) |
---|
1267 | (eql tra 0) |
---|
1268 | (member tra lexprs))))) |
---|
1269 | (decf fp (* 2 target::node-size)) |
---|
1270 | (when (and end (<= low end fp)) |
---|
1271 | (setq low (- end 8))) |
---|
1272 | (loop while |
---|
1273 | (loop for pp downfrom (- fp target::node-size) above low by target::node-size |
---|
1274 | do (when (eql (core-q pp target::lisp-frame.backptr) fp) |
---|
1275 | (when (validp pp) |
---|
1276 | (return (setq fp pp)))))) |
---|
1277 | fp))) |
---|
1278 | |
---|
1279 | (defun core-stack-frame-values (tcr fp) |
---|
1280 | (let* ((bottom (core-q fp target::lisp-frame.backptr)) |
---|
1281 | (top (if (eql 0 (core-q fp target::lisp-frame.return-address)) |
---|
1282 | (+ fp target::xcf.size) |
---|
1283 | (+ fp (if (eql (core-q fp target::lisp-frame.return-address) |
---|
1284 | (core-q (kernel-global-address 'ret1valaddr))) |
---|
1285 | target::lisp-frame.size |
---|
1286 | target::lisp-frame.xtra)))) |
---|
1287 | (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db) |
---|
1288 | until (or (eql db 0) (>= db bottom)) |
---|
1289 | when (<= top db) return db))) |
---|
1290 | (loop for vsp from top below bottom by target::node-size |
---|
1291 | when (eql vsp db-link) |
---|
1292 | ;; The db-link will be followed by var and val, which we'll just collect normally |
---|
1293 | do (setq db-link (core-q db-link) vsp (+ vsp target::node-size)) |
---|
1294 | and collect `(:db-link ,db-link) |
---|
1295 | collect (core-q vsp)))) |
---|
1296 | |
---|
1297 | (defun core-print-call-history (process &key (stream t) origin detailed-p) |
---|
1298 | (flet ((fp-backlink (fp vs-end) |
---|
1299 | (let ((backlink (core-q fp target::lisp-frame.backptr))) |
---|
1300 | (when (or (eql backlink 0) |
---|
1301 | (<= vs-end backlink) |
---|
1302 | (<= vs-end (core-q backlink target::lisp-frame.backptr))) |
---|
1303 | (setq backlink vs-end)) |
---|
1304 | (assert (< fp backlink)) |
---|
1305 | backlink)) |
---|
1306 | (fp-tra (fp) |
---|
1307 | (let ((tra (core-q fp target::lisp-frame.return-address))) |
---|
1308 | (if (eql tra (core-q (kernel-global-address 'ret1valaddr))) |
---|
1309 | (core-q fp target::lisp-frame.xtra) |
---|
1310 | tra))) |
---|
1311 | (recover-fn (pc) |
---|
1312 | (when (and (eql (logand pc target::tagmask) target::tag-tra) |
---|
1313 | (eql (core-w pc) target::recover-fn-from-rip-word0) |
---|
1314 | (eql (core-b pc 2) target::recover-fn-from-rip-byte2)) |
---|
1315 | (+ pc target::recover-fn-from-rip-length |
---|
1316 | (- (core-l pc target::recover-fn-from-rip-disp-offset) |
---|
1317 | #x100000000))))) |
---|
1318 | (format stream "~&") |
---|
1319 | (core-print process stream) |
---|
1320 | (let* ((tcr (core-process-tcr process)) |
---|
1321 | (vs-area (core-q tcr target::tcr.vs-area)) |
---|
1322 | (vs-end (core-q vs-area target::area.high)) |
---|
1323 | (valence (core-q tcr target::tcr.valence)) |
---|
1324 | (fp (or origin |
---|
1325 | ;; TODO: find the registers in the core file! |
---|
1326 | (case valence |
---|
1327 | ;; TCR_STATE_LISP |
---|
1328 | (0 (let ((xp (core-q tcr target::tcr.suspend-context))) |
---|
1329 | (format stream "~&") |
---|
1330 | (if (eql xp 0) |
---|
1331 | (format stream "Unknown lisp context, guessing frame pointer:") |
---|
1332 | (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn |
---|
1333 | (if (eql xp 0) |
---|
1334 | (dwim-core-frame-pointer tcr) |
---|
1335 | ;; uc_mcontext.gregs[rbp] |
---|
1336 | (core-q xp (* 15 target::node-size))))) |
---|
1337 | ;; TCR_STATE_FOREIGN |
---|
1338 | (1 (format stream "~&In foreign code") |
---|
1339 | ;; the save-rbp seems to include some non-lisp frames sometimes, |
---|
1340 | ;; shave them down. |
---|
1341 | #+no (core-q tcr target::tcr.save-rbp) |
---|
1342 | (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp))) |
---|
1343 | ;; TCR_STATE_EXCEPTION_WAIT |
---|
1344 | (2 (let ((xp (core-q tcr target::tcr.pending-exception-context))) |
---|
1345 | ;; regs start at index 5, in this order: |
---|
1346 | ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z |
---|
1347 | ;; rbp temp0 imm1 imm0 nargs rsp rip |
---|
1348 | (format stream " exception-wait") |
---|
1349 | (if (zerop xp) |
---|
1350 | (format stream "~&context unknown") |
---|
1351 | (let* ((fn (core-q xp (* 10 target::node-size))) |
---|
1352 | (sp (core-q xp (* 20 target::node-size))) |
---|
1353 | (ra (core-q sp))) |
---|
1354 | (if (and (core-functionp fn) |
---|
1355 | (and (<= fn ra) |
---|
1356 | (< ra (+ fn (* (core-uvsize fn) target::node-size))))) |
---|
1357 | (progn |
---|
1358 | (format stream "~&") |
---|
1359 | (core-print fn stream) |
---|
1360 | (format stream " + ~d" (- ra fn))) |
---|
1361 | (progn |
---|
1362 | (format stream "~&top of stack = x~x, r13 = " ra) |
---|
1363 | (core-print fn stream))))) |
---|
1364 | (unless (zerop xp) |
---|
1365 | (core-q xp (* 15 target::node-size)))))) |
---|
1366 | (error "Cannot find frame pointer")))) |
---|
1367 | (unless (<= (core-q vs-area target::area.low) fp vs-end) |
---|
1368 | (error "frame pointer x~x is not in stack area" fp)) |
---|
1369 | (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc) |
---|
1370 | do (format stream "~&fp: x~x pc: x~x : " fp pc) |
---|
1371 | do (cond (fun |
---|
1372 | (core-print fun stream) |
---|
1373 | (format stream " + ~d " (- pc fun))) |
---|
1374 | ((eql pc 0) ;; exception frame |
---|
1375 | (let* ((nominal-function (core-q fp target::xcf.nominal-function)) |
---|
1376 | (obj (core-q fp target::xcf.containing-object))) |
---|
1377 | (when (core-functionp nominal-function) |
---|
1378 | (format stream "exception ") |
---|
1379 | (core-print nominal-function stream) |
---|
1380 | (format stream " + ~d" |
---|
1381 | (if (eq (- obj target::fulltag-misc) |
---|
1382 | (- nominal-function target::fulltag-function)) |
---|
1383 | (- (core-q fp target::xcf.relative-pc) target::tag-function) |
---|
1384 | (let ((pc (core-q fp target::xcf.ra0))) |
---|
1385 | (when (eql nominal-function (recover-fn pc)) |
---|
1386 | (- pc nominal-function)))))))) |
---|
1387 | ((eql pc (core-q (kernel-global-address 'lexpr-return))) |
---|
1388 | (format stream "lexpr return")) |
---|
1389 | ((eql pc (core-q (kernel-global-address 'lexpr-return1v))) |
---|
1390 | (format stream "lexpr1v return")) |
---|
1391 | (t |
---|
1392 | (if (eql (logand pc target::tagmask) target::tag-tra) |
---|
1393 | (format stream " # couldn't recover function") |
---|
1394 | (unless (core-nullp pc) |
---|
1395 | (format stream "bad frame!"))) |
---|
1396 | ;; can't trust backlink |
---|
1397 | (return))) |
---|
1398 | ;; TODO: print stack addressses |
---|
1399 | do (when detailed-p |
---|
1400 | (loop for val in (core-stack-frame-values tcr fp) |
---|
1401 | do (format stream "~& ") |
---|
1402 | do (if (integerp val) |
---|
1403 | (handler-case (core-print val stream) |
---|
1404 | (error () (format stream "#<Error printing value @x~x>" val))) |
---|
1405 | (format stream "~a x~x" (car val) (cadr val))))) |
---|
1406 | do (setq fp (fp-backlink fp vs-end)))))) |
---|
1407 | |
---|
1408 | |
---|
1409 | ) ; :x8664-target |
---|
1410 | |
---|