source: branches/working-0711/ccl/library/core-files.lisp @ 13438

Last change on this file since 13438 was 13438, checked in by gz, 11 years ago

add map-core-region

rename core-object-type to core-object-typecode-type, add core-struct-type and core-instance-type, add core-object-type-key which gets istruct/struct/instance classes, and core-type-string for printable rep.

remove core-instance-class-name

add some declarations

print-object(core-info): bind *print-simple-bit-vector* to nil

open-core: allow caller to pass in an existing core-info object

core-heap-utilization: make it understand slot vectors, add classes and threshold args, and use report-heap-utilization for reporting.

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