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

Last change on this file since 14680 was 14680, checked in by gb, 9 years ago

Just use the FFI to find sections in core files. Ignore sections
that aren't actually allocated in memory.

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