source: trunk/source/library/core-files.lisp @ 13174

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

heap utilization tweaks:

Changed %MAP-AREAS to take an area or list of areas, rather than min/max area codes. Make it accept symbolic area names as well.

Made HEAP-UTILIZATION accept some new keyword args:

  • :AREA can be used to restrict the area or areas walked, as in %map-areas.
  • :CLASSES, if true, causes it to classify objects by actual class rather than typecode.
  • :SORT specifies the order in which to print results, default is by name
  • :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes.

Added COLLECT-HEAP-UTILIZATION, which returns a list of (type count logical-size physical-size) instead of printing anything.

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