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

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

More core file functions (from r13155)

File size: 53.4 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 gc-area-name (code)
272  (cond ((eq code area-void) :void)
273        ((eq code area-cstack) :cstack)
274        ((eq code area-vstack) :vstack)
275        ((eq code area-tstack) :tstack)
276        ((eq code area-readonly) :readonly)
277        ((eq code area-watched) :watched)
278        ((eq code area-managed-static) :managed-static)
279        ((eq code area-static) :static)
280        ((eq code area-dynamic) :dynamic)
281        ((eql 0 (logand code (1- (ash 1 target::fixnum-shift))))
282         (gc-area-name (ash code (- target::fixnum-shift))))
283        (t code)))
284
285(defun gc-area-code (name)
286  (case name
287    (:void area-void)
288    (:cstack area-cstack)
289    (:vstack area-vstack)
290    (:tstack area-tstack)
291    (:readonly area-readonly)
292    (:watched area-watched)
293    (:managed-static area-managed-static)
294    (:static area-static)
295    (:dynamic area-dynamic)
296    (t (if (and (fixnump name)
297                (<= area-readonly name area-dynamic))
298         name
299         (gc-area-code (require-type name '(member :void :cstack :vstack :tstack :readonly :managed-static :static :dynamic)))))))
300
301
302(defx86lapfunction %%raw-obj ((address arg_z))
303  (unbox-fixnum address arg_z)
304  (single-value-return))
305
306(declaim (inline uvheader-p uvheader-typecode uvheader-size))
307
308(defun uvheader-p (header)
309  (let ((tag (logand header target::fulltagmask)))
310    (declare (fixnum tag))
311    (and (<= target::fulltag-nodeheader-0 tag)
312         (<= tag target::fulltag-immheader-2)
313         (neq tag target::fulltag-odd-fixnum))))
314
315(defun uvheader-typecode (header)
316  (the fixnum (logand #xFF header)))
317
318(defun uvheader-size (header)
319  (ash header (- target::num-subtag-bits)))
320
321(defun uvheader-byte-size (header)
322  (x8664::x8664-misc-byte-count (uvheader-typecode header) (uvheader-size header)))
323
324(defun uvheader-type (header)
325  (let* ((typecode (uvheader-typecode header))
326         (low4 (logand typecode target::fulltagmask))
327         (high4 (ash typecode (- target::ntagbits))))
328    (declare (type (unsigned-byte 8) typecode)
329             (type (unsigned-byte 4) low4 high4))
330    (cond ((eql low4 x8664::fulltag-immheader-0)
331           (%svref *immheader-0-types* high4))
332          ((eql low4 x8664::fulltag-immheader-1)
333           (%svref *immheader-1-types* high4))
334          ((eql low4 x8664::fulltag-immheader-2)
335           (%svref *immheader-2-types* high4))
336          ((eql low4 x8664::fulltag-nodeheader-0)
337           (%svref *nodeheader-0-types* high4))
338          ((eql low4 x8664::fulltag-nodeheader-1)
339           (%svref *nodeheader-1-types* high4))
340          (t 'bogus))))
341
342(defun uvheader-type-typecode (symbol &aux pos)
343  (unless (eq symbol 'bogus)
344    (cond ((setq pos (position symbol *immheader-0-types*))
345           (logior (ash pos target::ntagbits) target::fulltag-immheader-0))
346          ((setq pos (position symbol *immheader-1-types*))
347           (logior (ash pos target::ntagbits) target::fulltag-immheader-1))
348          ((setq pos (position symbol *immheader-2-types*))
349           (logior (ash pos target::ntagbits) target::fulltag-immheader-2))
350          ((setq pos (position symbol *nodeheader-0-types*))
351           (logior (ash pos target::ntagbits) target::fulltag-nodeheader-0))
352          ((setq pos (position symbol *nodeheader-1-types*))
353           (logior (ash pos target::ntagbits) target::fulltag-nodeheader-1)))))
354
355;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
356;;
357;;  Core heap
358
359(defun map-core-areas (function &key area)
360  (setq area (cond ((or (eq area t) (eq area nil)) nil)
361                   ((consp area) (mapcar #'gc-area-code area))
362                   (t (list (gc-area-code area)))))
363  (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
364          then (core-q area-ptr target::area.succ)
365        as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
366        until (= code area-void)
367        do (when (and (<= area-readonly code)
368                      (<= code area-dynamic)
369                      (or (null area) (member code area))
370                      (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
371             #+debug
372             (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
373                     area-ptr (gc-area-name code)
374                     (core-q area-ptr target::area.low)
375                     (core-q area-ptr target::area.active)
376                     (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
377                     (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
378             (map-core-area area-ptr function))))
379
380(defun map-core-area (area-ptr fun)
381  (let* ((ptr (core-q area-ptr target::area.low))
382         (end (core-q area-ptr target::area.active)))
383    (loop
384      (when (>= ptr end) (return))
385      (let ((header (core-q ptr)))
386        (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 (logand typecode target::fulltagmask))
455         (len (uvheader-size header)))
456    (assert (< -1 index len))
457    (cond ((or (eql tag target::fulltag-nodeheader-0)
458               (eql tag target::fulltag-nodeheader-1))
459           (core-q addr (ash index target::word-shift)))
460          ((eql 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 (ash index target::word-shift)))))
465          ((eq tag target::ivector-class-32-bit)
466           (cond ((eq typecode target::subtag-simple-base-string)
467                  (code-char (core-l addr (ash index 2))))
468                 ((eq typecode target::subtag-single-float-vector)
469                  (error "~s not implemented yet" 'target::subtag-single-float-vector))
470                 (t (core-l addr (ash index 2)))))
471          ((eq typecode target::subtag-bit-vector)
472           (let ((byte (core-b addr (ash (+ index 7) -3))))
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 (ash index 1))))))
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-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-istruct-type (obj)
508  (and (core-uvtypep obj :istruct)
509       (core-car (core-uvref obj 0))))
510       
511
512(defun core-object-type-and-size (obj)
513  (let ((fulltag (logand obj target::fulltagmask)))
514    (if (eq fulltag target::fulltag-cons)
515      (values 'cons target::dnode-size target::dnode-size)
516      (if (%i<= target::fulltag-misc fulltag)
517        (let* ((header (core-uvheader obj))
518               (logsize (uvheader-byte-size header))
519               ;; total including header and alignment.
520               (total (logandc2 (+ logsize target::node-size (1- target::dnode-size))
521                                (1- target::dnode-size))))
522          (values (uvheader-type header) logsize total))))))
523
524(defun core-heap-utilization (&key area unit sort)
525  (let* ((hash (make-hash-table :shared nil))
526         (total-physsize 0)
527         (div (ecase unit
528                ((nil) 1)
529                (:kb 1024.0d0)
530                (:mb (* 1024.0d0 1024.0d0))
531                (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
532         (sort-key (ecase sort
533                     (:count #'cadr)
534                     (:logical-size #'caddr)
535                     ((:physical-size nil) #'cdddr)))
536         (all nil))
537    (map-core-areas (lambda (obj)
538                      (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj)
539                        (let ((a (or (gethash type hash)
540                                     (setf (gethash type hash) (list* 0 0 0)))))
541                          (incf (car a))
542                          (incf (cadr a) logsize)
543                          (incf (cddr a) physsize))))
544                    :area area)
545    (maphash (lambda (type data)
546               (incf total-physsize (cddr data))
547               (push (cons type data) all))
548             hash)
549    (setq all (sort all #'> :key sort-key))
550    (format t "~&Object type~42tCount    Logical size   Physical size   % of Heap~%~50t~a~66t~:*~a"
551            (ecase unit
552              ((nil) " (in bytes)")
553              (:kb   "(in kilobytes)")
554              (:mb   "(in megabytes)")
555              (:gb   "(in gigabytes)")))
556    (loop for (type count logsize . physsize) in all
557          do (if unit
558               (format t "~&~a~36t~11d~16,2f~16,2f~11,2f%"
559                       type
560                       count
561                       (/ logsize div)
562                       (/ physsize div)
563                       (* 100.0 (/ physsize total-physsize)))
564               (format t "~&~a~36t~11d~16d~16d~11,2f%"
565                       type
566                       count
567                       logsize
568                       physsize
569                       (* 100.0 (/ physsize total-physsize)))))
570    (if unit
571      (format t "~&Total~63t~16,2f" (/ total-physsize div))
572      (format t "~&Total~63t~16d" total-physsize)))
573  (values))
574
575
576(defstruct unresolved-address address)
577
578(defmethod print-object ((obj unresolved-address) stream)
579  (let* ((address (unresolved-address-address obj)))
580    (format stream "#<Core ~S~@[[~d]~] #x~x >" 
581            (core-object-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    (cond ((or (eq tag target::fulltag-nodeheader-0)
633               (eq tag target::fulltag-nodeheader-1))
634           (when (eql typecode target::subtag-function)
635             ;; Don't bother copying the code for now
636             (let ((skip (core-l addr)))
637               (assert (<= 0 skip len))
638               (incf addr (ash skip target::word-shift))
639               (decf len skip)))
640           (dotimes (i len)
641             (setf (%svref vec i)
642                   (copy-from-core (core-q addr (ash i target::word-shift)) :depth depth)))
643           (let ((ptrtag (logand vec-ptr target::fulltagmask)))
644             (cond ((eql ptrtag target::fulltag-symbol)
645                    (%symvector->symptr vec))
646                   ((eql ptrtag target::fulltag-function)
647                    (%function-vector-to-function vec))
648                   (t vec))))
649          ((eq tag target::ivector-class-64-bit)
650           (cond ((eq typecode target::subtag-double-float-vector)
651                  (warn "~s not implemented yet" 'target::subtag-double-float-vector)
652                  (make-unresolved-address :address vec-ptr))
653                 (t
654                  (dotimes (i len vec)
655                    (setf (uvref vec i) (core-q addr (ash i target::word-shift)))))))
656          ((eq tag target::ivector-class-32-bit)
657           (cond ((eq typecode target::subtag-simple-base-string)
658                  (dotimes (i len vec)
659                    (setf (uvref vec i) (code-char (core-l addr (ash i 2))))))
660                 ((eq typecode target::subtag-single-float-vector)
661                  (warn "~s not implemented yet" 'target::subtag-single-float-vector)
662                  (make-unresolved-address :address vec-ptr))
663                 (t
664                  (dotimes (i len vec)
665                    (setf (uvref vec i) (core-l addr (ash i 2)))))))
666          ((eq typecode target::subtag-bit-vector)
667           (warn "bit vector not implemented yet")
668           (make-unresolved-address :address vec-ptr))
669          ((>= typecode target::min-8-bit-ivector-subtag)
670           (dotimes (i len vec)
671             (setf (uvref vec i) (core-b addr i))))
672          (t
673           (dotimes (i len vec)
674             (setf (uvref vec i) (core-w addr (ash i 1))))))))
675
676(defun map-core-pointers (fn &key area)
677  (map-core-areas (lambda (obj)
678                    (cond ((core-consp obj)
679                           (funcall fn (core-car obj) obj 0)
680                           (funcall fn (core-cdr obj) obj 1))
681                          (t
682                           (let* ((header (core-uvheader obj))
683                                  (subtag (logand header target::fulltagmask)))
684                             (when (or (eq subtag target::fulltag-nodeheader-0)
685                                       (eq subtag target::fulltag-nodeheader-1))
686                               (let* ((typecode (uvheader-typecode header))
687                                      (len (uvheader-size header))
688                                      (addr (+ (logandc2 obj target::fulltagmask) target::node-size)))
689                                 (when (eql typecode target::subtag-function)
690                                   (let ((skip (core-l addr)))
691                                     (assert (<= 0 skip len))
692                                     (incf addr (ash skip target::word-shift))
693                                     (decf len skip)))
694                                 (dotimes (i len)
695                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))
696                  :area area))
697
698(defun core-find-tra-function (tra)
699  (assert (eq (logand tra target::tagmask) target::tag-tra))
700  (map-core-areas (lambda (obj)
701                    (when (core-uvtypep obj :function)
702                      (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size))
703                             (skip  (core-l addr))
704                             (offset (- tra addr)))
705                        (when (<= 0 offset (ash skip target::word-shift))
706                          (return-from core-find-tra-function (values obj (+ offset (- target::node-size
707                                                                                       (logand obj target::fulltagmask)))))))))))
708
709(defun core-instance-class (obj)
710  (when (core-uvtypep obj :slot-vector)
711    (setq obj (core-uvref obj slot-vector.instance)))
712  (assert (core-uvtypep obj :instance))
713  (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class))
714
715(defun core-instance-p (obj class)
716  (and (core-uvtypep obj :instance)
717       (labels ((matchp (iclass)
718                  (or (eql iclass class)
719                      (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers)
720                              then (core-cdr supers)
721                            while (core-consp supers)
722                            thereis (matchp (core-car supers))))))
723         (matchp (core-instance-class obj)))))
724
725
726(defun core-instance-class-name (obj)
727  (let* ((class (core-instance-class obj))
728         (class-slots (core-uvref class instance.slots))
729         (name (core-uvref class-slots %class.name)))
730    (core-symbol-name name)))
731
732(defun core-symptr (obj)
733  (if (core-nullp obj)
734    (nil-relative-symbol-address 'nil)
735    (when (core-uvtypep obj :symbol)
736      (let ((tag (logand obj target::fulltagmask)))
737        (unless (eq tag target::fulltag-symbol)
738          (incf obj (%i- target::fulltag-symbol tag))))
739      obj)))
740   
741(defun core-symbol-name (obj)
742  (when (setq obj (core-symptr obj))
743    (copy-from-core (core-q obj target::symbol.pname) :depth 1)))
744
745(defun core-symbol-value (obj)
746  (when (setq obj (core-symptr obj))
747    (core-q obj target::symbol.vcell)))
748
749(defun core-symbol-package (obj)
750  (when (setq obj (core-symptr obj))
751    (let ((cell (core-q obj target::symbol.package-predicate)))
752      (if (core-consp cell)
753        (core-car cell)
754        cell))))
755
756(defun core-all-packages-ptr ()
757  (core-symbol-value (nil-relative-symbol-address '%all-packages%)))
758
759(defun core-keyword-package ()
760  (core-symbol-value (nil-relative-symbol-address '*keyword-package*)))
761
762(defun core-symbol-pointers ()
763  (or (core-info-symbol-ptrs (current-core))
764      (let ((vector (make-array 1000 :adjustable t :fill-pointer 0))
765            (keys (core-keyword-package)))
766        (map-core-areas (lambda (obj)
767                          (when (core-symbolp obj)
768                            (unless (eq (core-symbol-package obj) keys)
769                              (vector-push-extend obj vector)))))
770        (setf (core-info-symbol-ptrs (current-core)) vector))))
771
772(defun core-map-symbols (fun)
773  (loop for sym-ptr across (core-symbol-pointers) do (funcall fun sym-ptr)))
774
775
776(defun core-string-equal (ptr string &aux (len (length string)))
777  (assert (core-uvtypep ptr :simple-string))
778  (when (eq (core-uvsize ptr) len)
779    (loop for i from 0 below len
780          always (eql (core-uvref ptr i) (aref string i)))))
781
782(defun core-find-package (name &key error)
783  (setq name (string name))
784  (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr)
785            while (core-consp list-ptr)
786            as pkg-ptr = (core-car list-ptr)
787            when (loop for names-ptr = (core-uvref pkg-ptr pkg.names) then (core-cdr names-ptr)
788                       while (core-consp names-ptr)
789                       as name-ptr = (core-car names-ptr)
790                       thereis (core-string-equal name-ptr name))
791              do (return pkg-ptr))
792      (and error (error "No package named ~s" name))))
793
794(defun core-package-names (pkg-ptr)
795  (assert (core-uvtypep pkg-ptr :package))
796  (copy-from-core (core-uvref pkg-ptr pkg.names) :depth 2))
797
798(defun core-package-name (pkg-ptr)
799  (assert (core-uvtypep pkg-ptr :package)) 
800  (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1))
801
802(defun core-find-symbol (name &optional (package (symbol-package name)))
803  ;; Unlike the real cl:find-symbol, this doesn't look for inherited symbols,
804  ;; you have to get the package right.
805  (let* ((symbol-name (string name))
806         (name-len (length symbol-name))
807         (pkg-ptr (if (integerp package)
808                    package
809                    (core-find-package (if (packagep package)
810                                         (package-name package)
811                                         (string package))
812                                       :error t))))
813    (assert (core-uvtypep pkg-ptr :package))
814    (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len)
815      (flet ((findsym (htab-ptr)
816               (let* ((vec-ptr (core-car htab-ptr))
817                      (vlen (core-uvsize vec-ptr)))
818                 (loop for idx = (fast-mod primary vlen) then (+ i secondary)
819                       for i = idx then (if (>= idx vlen) (- idx vlen) idx)
820                       as sym = (core-uvref vec-ptr i)
821                       until (eql sym 0)
822                       do (when (and (core-symbolp sym)
823                                     (core-string-equal (core-q sym target::symbol.pname) symbol-name))
824                            (return (if (eq sym (nil-relative-symbol-address 'nil))
825                                      (target-nil-value)
826                                      sym)))))))
827        (or (findsym (core-uvref pkg-ptr pkg.itab))
828            (findsym (core-uvref pkg-ptr pkg.etab)))))))
829
830(defun core-gethash (key-ptr hash-ptr)
831  (when (core-uvtypep hash-ptr :istruct)
832    (setq hash-ptr (core-uvref hash-ptr nhash.vector)))
833  (assert (core-uvtypep hash-ptr :hash-vector))
834  (loop for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2
835        do (when (eq (core-uvref hash-ptr i) key-ptr)
836             (return (core-uvref hash-ptr (1+ i))))))
837
838(defun core-hash-table-count (hash-ptr)
839  (when (core-uvtypep hash-ptr :istruct)
840    (setq hash-ptr (core-uvref hash-ptr nhash.vector)))
841  (assert (core-uvtypep hash-ptr :hash-vector))
842  (loop with rehashing = (%fixnum-address-of (%slot-unbound-marker))
843        with free = (%fixnum-address-of (%unbound-marker))
844        for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2
845        count (let ((value (core-uvref hash-ptr (1+ i))))
846                (when (eq value rehashing)
847                  (error "This table is being rehashed"))
848                (neq value free))))
849
850(defun core-classes-hash-table-ptr ()
851  (or (core-info-classes-hash-table-ptr (current-core))
852      (setf (core-info-classes-hash-table-ptr (current-core))
853            (core-symbol-value (core-find-symbol '%find-classes%)))))
854
855(defun core-find-class (name)
856  (let* ((name-ptr (etypecase name
857                     (integer 
858                        (assert (core-symbolp name))
859                        name)
860                     (symbol (core-find-symbol name))))
861         (hash-ptr (core-classes-hash-table-ptr))
862         (cell (core-gethash name-ptr hash-ptr))
863         (class (and cell (core-uvref cell class-cell-class))))
864    (and class (core-uvtypep class :instance) class)))
865
866(defun core-lfun-names-table-ptr ()
867  (or (core-info-lfun-names-table-ptr (current-core))
868      (setf (core-info-lfun-names-table-ptr (current-core))
869            (core-symbol-value (core-find-symbol '*lfun-names*)))))
870
871(defun core-closure-function (fun)
872  (while (and (core-functionp fun)
873              (logbitp $lfbits-trampoline-bit (core-lfun-bits fun)))
874    (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size)))
875      (setq fun (core-q addr (ash (core-l addr) target::word-shift)))
876      (when (core-uvtypep fun :simple-vector)
877        (setq fun (core-uvref fun 0)))
878      #+gz (assert (core-functionp fun))))
879  fun)
880
881   
882(defun core-lfun-name (fn)
883  (assert (core-functionp fn))
884  (flet ((lfun-name (fn)
885           (or (core-gethash fn (core-lfun-names-table-ptr))
886               (let* ((lfbits (core-lfun-bits fn))
887                      (name (if (and (logbitp $lfbits-gfn-bit lfbits)
888                                     (not (logbitp $lfbits-method-bit lfbits)))
889                                (core-uvref (core-uvref fn gf.slots) sgf.name)
890                                (unless (logbitp $lfbits-noname-bit lfbits)
891                                  (core-uvref fn (- (core-uvsize fn) 2))))))
892                 (and name
893                      (not (eql name (%fixnum-address-of (%slot-unbound-marker))))
894                      (not (core-nullp name))
895                      name)))))
896    (or (lfun-name fn)
897        (let ((inner-fn (core-closure-function fn)))
898          (and (core-functionp inner-fn)
899               (not (eql inner-fn fn))
900               (lfun-name inner-fn))))))
901
902(defun core-list (ptr)
903  (let ((cars (loop while (core-consp ptr)
904                    collect (core-car ptr)
905                    do (setq ptr (core-cdr ptr)))))
906    (if (core-nullp ptr)
907      cars
908      (nconc cars ptr))))
909
910(defun core-all-processes ()
911  (let* ((sym (core-find-symbol 'all-processes))
912         (closure (core-uvref sym target::symbol.fcell-cell))
913         (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size))
914         (imm-end (core-uvsize closure))
915         (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx)
916                      when (core-uvtypep imm :value-cell) return imm))
917         (val (core-uvref vcell target::value-cell.value-cell))
918         (processes (core-list val)))
919    processes))
920
921(defun core-process-name (proc)
922  (assert (core-uvtypep proc :instance))
923  (let ((slots (core-uvref proc ccl::instance.slots)))
924    (copy-from-core (core-uvref slots 1) :depth 1)))
925
926(defun core-process-tcr (proc)
927  (assert (core-uvtypep proc :instance))
928  (let* ((slots (core-uvref proc ccl::instance.slots))
929         (thread (core-uvref slots 2)))
930    (core-uvref thread ccl::lisp-thread.tcr)))
931
932(defun core-find-process-for-id (lwp)
933  (loop for proc in (core-all-processes)
934        when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id))
935          return proc))
936
937;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
938
939(defun core-process-class ()
940  (or (core-info-process-class (current-core))
941      (setf (core-info-process-class (current-core))
942            (core-find-class 'process))))
943
944(defun core-print (obj &optional (stream t) depth)
945  ;; TODO: could dispatch on core-object-type...
946  (cond ((core-nullp obj) (format stream "NIL"))
947        ((core-symbolp obj)
948         (core-print-symbol obj stream))
949        ((core-uvtypep obj :function)
950         (core-print-function obj stream))
951        ((core-instance-p obj (core-process-class))
952         (core-print-process obj stream))
953        ((and depth (< (decf depth) 0))
954         (format stream "x~x" obj))
955        ((core-consp obj)
956         (loop for sep = "(" then " "
957               for i from 0 below (or *print-length* 100)
958               while (core-consp obj)
959               do (format stream sep)
960               do (core-print (core-car obj) stream depth)
961               do (setq obj (core-cdr obj)))
962         (unless (core-nullp obj)
963           (format stream " . ")
964           (core-print obj stream depth))
965         (format stream ")"))
966        (t (format stream "#<core ~s x~x>"
967                   (core-object-type obj) obj))))
968
969(defun core-print-symbol (sym stream)
970  (let ((package (core-symbol-package sym)))
971    (cond ((core-nullp package)
972           (format stream "#:"))
973          ((eq package (core-keyword-package))
974           (format stream ":"))
975          (t (let ((pkgname (core-package-name package)))
976               (unless (string-equal pkgname "COMMON-LISP")
977                 (format stream "~a::" pkgname)))))
978    (format stream "~a" (core-symbol-name sym))))
979
980(defun core-lfun-bits (fun)
981  (ash (core-uvref fun (1- (core-uvsize fun))) (- target::fixnum-shift)))
982
983(defun core-print-function (fun stream)
984  (let* ((lfbits (core-lfun-bits fun))
985         (name (core-lfun-name fun)))
986    (format stream "#<")
987    (cond ((or (null name) (core-nullp name))
988           (format stream "Anonymous function"))
989          ((logbitp $lfbits-method-bit lfbits)
990           (assert (core-uvtypep name :instance))
991           (let* ((slot-vector (core-uvref name instance.slots))
992                  (method-qualifiers (core-uvref slot-vector %method.qualifiers))
993                  (method-specializers (core-uvref slot-vector %method.specializers))
994                  (method-name (core-uvref slot-vector %method.name)))
995             (format stream "Method-Function ")
996             (core-print method-name stream)
997             (format stream " ")
998             (unless (core-nullp method-qualifiers)
999               (if (core-nullp (core-cdr method-qualifiers))
1000                 (core-print (core-car method-qualifiers) stream)
1001                 (core-print method-qualifiers stream))
1002               (format stream " "))
1003             ;; print specializer list but print names instead of classes.
1004             (loop for sep = "(" then " "
1005                   while (core-consp method-specializers)
1006                   do (format stream sep)
1007                   do (let ((spec (core-car method-specializers)))
1008                        (if (core-uvtypep spec :instance)
1009                          (core-print (core-uvref (core-uvref spec instance.slots) %class.name) stream)
1010                          (core-print spec stream)))
1011                   do (setq method-specializers (core-cdr method-specializers)))
1012             (unless (core-nullp method-specializers)
1013               (format stream " . ")
1014               (core-print method-specializers stream))
1015             (format stream ")")))
1016          (t
1017           (if (logbitp $lfbits-gfn-bit lfbits)
1018               (format stream "Generic Function ")
1019               (format stream "Function "))
1020           (core-print name stream)))
1021    (format stream " x~x>" fun)))
1022
1023(defun core-print-process (proc stream)
1024  (format stream "#<~a ~s LWP(~d) #x~x>"
1025          (core-instance-class-name proc)
1026          (core-process-name proc)
1027          (core-q (core-process-tcr proc) target::tcr.native-thread-id)
1028          proc))
1029
1030(defun dwim-core-frame-pointer (tcr &optional end)
1031  (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr)))
1032         (lexprs (list (core-q (kernel-global-address 'lexpr-return))
1033                       (core-q (kernel-global-address 'lexpr-return1v))))
1034         (stack-area (core-q tcr target::tcr.vs-area))
1035         (fp (core-q stack-area target::area.high))
1036         (low (core-q stack-area target::area.low)))
1037    (flet ((validp (pp)
1038             (let ((tra (core-q pp target::lisp-frame.return-address)))
1039               (when (eql tra ret1valn)
1040                 (setq tra (core-q pp target::lisp-frame.xtra)))
1041               (or (eql (logand tra target::tagmask) target::tag-tra)
1042                   (eql tra 0)
1043                   (member tra lexprs)))))
1044      (decf fp (* 2 target::node-size))
1045      (when (and end (<= low end fp))
1046        (setq low (- end 8)))
1047      (loop while
1048            (loop for pp downfrom (- fp target::node-size) above low by target::node-size
1049                  do (when (eql (core-q pp target::lisp-frame.backptr) fp)
1050                       (when (validp pp)
1051                         (return (setq fp pp))))))
1052      fp)))
1053
1054(defun core-stack-frame-values (tcr fp)
1055  (let* ((bottom (core-q fp target::lisp-frame.backptr))
1056         (top (if (eql 0 (core-q fp target::lisp-frame.return-address))
1057                (+ fp target::xcf.size)
1058                (+ fp (if (eql (core-q fp target::lisp-frame.return-address)
1059                               (core-q (kernel-global-address 'ret1valaddr)))
1060                        target::lisp-frame.size
1061                        target::lisp-frame.xtra))))
1062         (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db)
1063                        until (or (eql db 0) (>= db bottom))
1064                        when (<= top db) return db)))
1065    (loop for vsp from top below bottom by target::node-size
1066          when (eql vsp db-link)
1067            ;; The db-link will be followed by var and val, which we'll just collect normally
1068            do (setq db-link (core-q db-link) vsp (+ vsp target::node-size))
1069            and collect `(:db-link ,db-link)
1070          collect (core-q vsp))))
1071
1072(defun core-print-call-history (process &key (stream t) origin detailed-p)
1073  (flet ((fp-backlink (fp vs-end)
1074           (let ((backlink (core-q fp target::lisp-frame.backptr)))
1075             (when (or (eql backlink 0)
1076                       (<= vs-end backlink)
1077                       (<= vs-end (core-q backlink target::lisp-frame.backptr)))
1078               (setq backlink vs-end))
1079             (assert (< fp backlink))
1080             backlink))
1081         (fp-tra (fp)
1082           (let ((tra (core-q fp target::lisp-frame.return-address)))
1083             (if (eql tra (core-q (kernel-global-address 'ret1valaddr)))
1084               (core-q fp target::lisp-frame.xtra)
1085               tra)))
1086         (recover-fn (pc)
1087           (when (and (eql (logand pc target::tagmask) target::tag-tra)
1088                      (eql (core-w pc) target::recover-fn-from-rip-word0)
1089                      (eql (core-b pc 2) target::recover-fn-from-rip-byte2))
1090             (+ pc target::recover-fn-from-rip-length
1091                (- (core-l pc target::recover-fn-from-rip-disp-offset)
1092                   #x100000000)))))
1093    (format stream "~&")
1094    (core-print process stream)
1095    (let* ((tcr (core-process-tcr process))
1096           (vs-area (core-q tcr target::tcr.vs-area))
1097           (vs-end (core-q vs-area target::area.high))
1098           (valence (core-q tcr target::tcr.valence))
1099           (fp (or origin
1100                   ;; TODO: find the registers in the core file!
1101                   (case valence
1102                     ;; TCR_STATE_LISP
1103                     (0 (let ((xp (core-q tcr target::tcr.suspend-context)))
1104                          (format stream "~&")
1105                          (if (eql xp 0)
1106                            (format stream "Unknown lisp context, guessing frame pointer:")
1107                            (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn
1108                          (if (eql xp 0)
1109                            (dwim-core-frame-pointer tcr)
1110                            ;; uc_mcontext.gregs[rbp]
1111                            (core-q xp (* 15 target::node-size)))))
1112                     ;; TCR_STATE_FOREIGN
1113                     (1 (format stream "~&In foreign code")
1114                        ;; the save-rbp seems to include some non-lisp frames sometimes,
1115                        ;; shave them down.
1116                        #+no (core-q tcr target::tcr.save-rbp)
1117                        (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp)))
1118                     ;; TCR_STATE_EXCEPTION_WAIT
1119                     (2 (let ((xp (core-q tcr target::tcr.pending-exception-context)))
1120                          ;; regs start at index 5, in this order:
1121                          ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z
1122                          ;; rbp temp0 imm1 imm0 nargs rsp rip
1123                          (format stream " exception-wait")
1124                          (if (zerop xp)
1125                            (format stream "~&context unknown")
1126                            (let* ((fn (core-q xp (* 10 target::node-size)))
1127                                   (sp (core-q xp (* 20 target::node-size)))
1128                                   (ra (core-q sp)))
1129                              (if (and (core-functionp fn)
1130                                       (and (<= fn ra)
1131                                            (< ra (+ fn (* (core-uvsize fn) target::node-size)))))
1132                                (progn
1133                                  (format stream "~&")
1134                                  (core-print fn stream)
1135                                  (format stream " + ~d" (- ra fn)))
1136                                (progn
1137                                  (format stream "~&top of stack = x~x, r13 = " ra)
1138                                  (core-print fn stream)))))
1139                          (unless (zerop xp)
1140                            (core-q xp (* 15 target::node-size))))))
1141                   (error "Cannot find frame pointer"))))
1142      (unless (<= (core-q vs-area target::area.low) fp vs-end)
1143        (error "frame pointer x~x is not in stack area" fp))
1144      (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc)
1145            do (format stream "~&fp: x~x  pc: x~x : " fp pc)
1146            do (cond (fun
1147                      (core-print fun stream)
1148                      (format stream " + ~d " (- pc fun)))
1149                     ((eql pc 0) ;; exception frame
1150                      (let* ((nominal-function (core-q fp target::xcf.nominal-function))
1151                             (obj (core-q fp target::xcf.containing-object)))
1152                        (when (core-functionp nominal-function)
1153                          (format stream "exception ")
1154                          (core-print nominal-function stream)
1155                          (format stream " + ~d"
1156                                  (if (eq (- obj target::fulltag-misc)
1157                                          (- nominal-function target::fulltag-function))
1158                                    (- (core-q fp target::xcf.relative-pc) target::tag-function)
1159                                    (let ((pc (core-q fp target::xcf.ra0)))
1160                                      (when (eql nominal-function (recover-fn pc))
1161                                        (- pc nominal-function))))))))
1162                     ((eql pc (core-q (kernel-global-address 'lexpr-return)))
1163                      (format stream "lexpr return"))
1164                     ((eql pc (core-q (kernel-global-address 'lexpr-return1v)))
1165                      (format stream "lexpr1v return"))
1166                     (t
1167                      (if (eql (logand pc target::tagmask) target::tag-tra)
1168                        (format stream " # couldn't recover function")
1169                        (unless (core-nullp pc)
1170                          (format stream "bad frame!")))
1171                      ;; can't trust backlink
1172                      (return)))
1173               ;; TODO: print stack addressses
1174            do (when detailed-p
1175                 (loop for val in (core-stack-frame-values tcr fp)
1176                       do (format stream "~&     ")
1177                       do (if (integerp val)
1178                            (handler-case (core-print val stream)
1179                              (error () (format stream "#<Error printing value @x~x>" val)))
1180                            (format stream "~a x~x" (car val) (cadr val)))))
1181            do (setq fp (fp-backlink fp vs-end))))))
1182
1183
1184)                             ; :x8664-target
Note: See TracBrowser for help on using the repository browser.