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

Last change on this file since 14680 was 14680, checked in by gb, 10 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.