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

Last change on this file since 13388 was 13388, checked in by gz, 10 years ago

fix for objdump parsing

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