source: branches/qres/ccl/library/core-files.lisp @ 15278

Last change on this file since 15278 was 13566, checked in by gz, 9 years ago

core-string-equal => core-string=

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