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

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

Fix build, revert r13495

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