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

Last change on this file since 13145 was 13145, checked in by gz, 11 years ago

Oops, didn't mean to check this in yet, revert to prior version

File size: 37.9 KB
Line 
1;;;
2;;;   Copyright (C) 2009, Clozure Associates and contributors
3;;;   This file is part of Clozure CL.
4;;;
5;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6;;;   License , known as the LLGPL and distributed with Clozure CL as the
7;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
9;;;   conflict, the preamble takes precedence. 
10;;;
11;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
12;;;
13;;;   The LLGPL is also available online at
14;;;   http://opensource.franz.com/preamble.html
15
16;; Functions to examine core files.
17
18(in-package :ccl)
19
20#+:linuxx8664-target
21(progn
22
23(export '(open-core close-core
24          core-heap-utilization map-core-areas map-core-pointers
25          core-q core-l core-w core-b
26          core-consp core-symbolp core-listp core-nullp core-uvector-p
27          core-uvtype core-uvtypep core-uvref core-uvsize
28          core-car core-cdr core-object-type core-istruct-type
29          copy-from-core core-list
30          core-keyword-package core-find-package core-find-symbol
31          core-package-names core-package-name
32          core-map-symbols
33          core-symbol-name core-symbol-value core-symbol-package
34          core-gethash core-hash-table-count
35          core-lfun-name
36          core-find-class
37          core-instance-class-name
38          core-string-equal
39          core-all-processes core-process-name
40          ))
41
42;; The intended way to use these facilities is to open up a particular core file once,
43;; and then repeatedly call functions to examine it.  So for convenience, we keep the
44;; core file in a global var, rather than making all user functions take an extra arg.
45
46(defvar *current-core* nil)
47
48
49(defstruct core-info
50  sections
51  ;; uses either stream or ivector, determined at runtime
52  stream
53  mapped-ivector
54  raw-ivector
55  ;; caches
56  symbol-ptrs
57  classes-hash-table-ptr
58  lfun-names-table-ptr
59  )
60
61(defmethod print-object :around ((core core-info) (stream t))
62  (let ((*print-array* nil))
63    (call-next-method)))
64
65(declaim (type (or null core-info) *current-core*)
66         (ftype (function () core-info) current-core)
67         (inline current-core))
68
69(defun current-core ()
70  (or *current-core* (require-type *current-core* 'core-info)))
71
72(defun close-core ()
73  (let ((core *current-core*))
74    (setq *current-core* nil)
75    (when core
76      (when (core-info-stream core)
77        (close (core-info-stream core)))
78      (when (core-info-mapped-ivector core)
79        (unmap-ivector (core-info-mapped-ivector core)))
80      t)))
81
82;; TODO: after load sections, check if highest heap address is a fixnum, and
83;; arrange to use fixnum-only versions of the reading functions.
84(defun open-core (pathname &key (method :mmap))
85  (when *current-core*
86    (close-core))
87  (let* ((sections (readelf-sections pathname))
88         (core (make-core-info :sections sections)))
89    (ecase method
90      (:mmap   (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8))))
91                 (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector)
92                   (loop for data across sections do (incf (cdr data) offset))
93                   (setf (core-info-mapped-ivector core) mapped-vector)
94                   (setf (core-info-raw-ivector core) vector))))
95      (:stream (setf (core-info-stream core)
96                     (open pathname :element-type '(unsigned-byte 8)))))
97    (setq *current-core* core))
98  pathname)
99
100;; Kinda stupid to call external program for this...
101(defun readelf-sections (pathname)
102  (flet ((split (line start end)
103           (loop while (setq start (position-if-not #'whitespacep line :start start :end end))
104                 as match = (cdr (assq (char line start) '((#\[ . #\]) (#\( . #\)) (#\< . #\>))))
105                 as next = (if match
106                             (1+ (or (position match line :start (1+ start) :end end)
107                                     (error "Unmatched ~c at position ~s" (char line start) start)))
108                             (or (position-if #'whitespacep line :start start :end end) end))
109                 collect (subseq line start next)
110                 do (setq start next))))
111    (let* ((file (native-translated-namestring pathname))
112           (string (with-output-to-string (output)
113                     (ccl:run-program "readelf" `("--sections" ,file) :output output)))
114           (sections (loop
115                       for start = (1+ (position #\newline string
116                                                 :start (1+ (position #\newline string
117                                                                      :start (position #\[ string)))))
118                         then next
119                       for next = (1+ (position #\newline string
120                                                :start (1+ (position #\newline string :start start))))
121                       while (eql #\space (aref string next))
122                       nconc
123                       (destructuring-bind (number name type address filepos size &optional ent-size flags link info align)
124                           (split string start next)
125                         (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\])))
126                         (setq number (read-from-string number :start 1 :end (1- (length number))))
127                         (when (eql number 0)
128                           (shiftf align info link flags ent-size size filepos address type name ""))
129                         (setq address (parse-integer address :radix 16))
130                         (setq filepos  (parse-integer filepos :radix 16))
131                         (setq size (parse-integer size :radix 16))
132                         (setq ent-size (parse-integer ent-size :radix 16))
133                         (unless (eql size 0)
134                           (assert (and (equal link "0") (equal info "0") (equal align "1")))
135                           (list (list address filepos size))))))
136           (sections (cons (list most-positive-fixnum 0 0) sections));; hack for loop below
137           (sections (sort sections #'< :key #'car));; sort by address
138           (sections (loop
139                       with cur-address = -1
140                       with cur-filepos = -1
141                       with cur-end = cur-address
142                       for (address filepos size) in sections
143                       unless (or (= (+ cur-filepos (- address cur-address)) filepos)
144                                  (= cur-address cur-end))
145                         collect (cons cur-address cur-filepos)
146                       do (if (= (+ cur-filepos (- address cur-address)) filepos)
147                            (setq cur-end (max (+ address size) cur-end))
148                            (progn
149                              (assert (<= cur-end address));; no overlap.
150                              (setq cur-address address cur-filepos filepos cur-end (+ address size)))))))
151      (coerce sections 'vector))))
152
153(declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq
154                 core-stream-readb core-stream-readw core-stream-readl core-stream-readq))
155(declaim (ftype (function (t t) (unsigned-byte 8)) core-ivector-readb core-stream-readb)
156         (ftype (function (t t) (unsigned-byte 16)) core-ivector-readw core-stream-readw)
157         (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl)
158         (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq)
159         (ftype (function (integer) fixnum) core-offset-for-address))
160
161(defun core-offset-for-address (address)
162  ;; sections are sorted, so could do binary search if this became a bottleneck.
163  ;; (there are around 50 sections)
164  (or (loop for prev = nil then sect as sect across (core-info-sections (current-core))
165            do (when (< address (car sect))
166                 (return (and prev (+ (cdr prev) (- address (car prev)))))))
167      (error "Unknown core address x~x" address)))
168
169(defun core-stream-readb (s offset)
170  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
171  (when offset (stream-position s offset))
172  (read-byte s))
173
174(defun core-stream-readw (s offset)
175  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
176  (when offset (stream-position s offset))
177  (%i+ (core-stream-readb s nil) (ash (core-stream-readb s nil) 8)))
178
179(defun core-stream-readl (s offset)
180  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
181  (when offset (stream-position s offset))
182  (%i+ (core-stream-readw s nil) (ash (core-stream-readw s nil) 16)))
183
184(defun core-stream-readq (s offset)
185  (declare (type basic-input-stream s) (optimize (speed 3) (safety 0)))
186  (when offset (stream-position s offset))
187  (+ (core-stream-readl s nil) (ash (core-stream-readl s nil) 32)))
188
189(defun core-ivector-readb (vec offset)
190  (declare (type (simple-array (unsigned-byte 8) (*)) vec) (fixnum offset)
191           (optimize (speed 3) (safety 0)))
192  (aref vec offset))
193
194(defun core-ivector-readw (vec offset)
195  (declare (optimize (speed 3) (safety 0)))
196  (%i+ (core-ivector-readb vec offset) (ash (core-ivector-readb vec (%i+ offset 1)) 8)))
197
198(defun core-ivector-readl (vec offset)
199  (declare (optimize (speed 3) (safety 0)))
200  (%i+ (core-ivector-readw vec offset) (ash (core-ivector-readw vec (%i+ offset 2)) 16)))
201
202(defun core-ivector-readq (vec offset)
203  (declare (optimize (speed 3) (safety 0)))
204  (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (%i+ offset 4)) 32)))
205
206
207(defun core-q (address &optional (offset 0))
208  (declare (optimize (speed 3) (safety 0)))
209  (let* ((core (current-core))
210         (ivector (core-info-raw-ivector core)))
211    (declare (type core-info core))
212    (if ivector
213      (core-ivector-readq ivector (core-offset-for-address (+ address offset)))
214      (core-stream-readq (core-info-stream core) (core-offset-for-address (+ address offset))))))
215
216(defun core-l (address &optional (offset 0))
217  (declare (optimize (speed 3) (safety 0)))
218  (let* ((core (current-core))
219         (ivector (core-info-raw-ivector core)))
220    (declare (type core-info core))
221    (if ivector
222      (core-ivector-readl ivector (core-offset-for-address (+ address offset)))
223      (core-stream-readl (core-info-stream core) (core-offset-for-address (+ address offset))))))
224
225(defun core-w (address &optional (offset 0))
226  (declare (optimize (speed 3) (safety 0)))
227  (let* ((core (current-core))
228         (ivector (core-info-raw-ivector core)))
229    (declare (type core-info core))
230    (if ivector
231      (core-ivector-readw ivector (core-offset-for-address (+ address offset)))
232      (core-stream-readw (core-info-stream core) (core-offset-for-address (+ address offset))))))
233
234(defun core-b (address &optional (offset 0))
235  (declare (optimize (speed 3) (safety 0)))
236  (let* ((core (current-core))
237         (ivector (core-info-raw-ivector core)))
238    (declare (type core-info core))
239    (if ivector
240      (core-ivector-readb ivector (core-offset-for-address (+ address offset)))
241      (core-stream-readb (core-info-stream core) (core-offset-for-address (+ address offset))))))
242
243;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
244;;
245;; general utilities
246
247;; NIL is constant, assume is same in core as here.
248(defun kernel-global-address (global)
249  (check-type global symbol)
250  (+ (target-nil-value)
251     (target::%kernel-global (or (find-symbol (symbol-name global) :ccl) global))))
252
253(defun nil-relative-symbol-address (sym)
254  (+ (target-nil-value)
255     #x20  ;;; dunno why
256     (* (or (position sym x86::*x86-nil-relative-symbols* :test #'eq)
257            (error "Not a nil-relative symbol ~s" sym))
258        target::symbol.size)
259     (- target::fulltag-symbol target::fulltag-nil)))
260
261(defun gc-area-name (code)
262  (cond ((eq code area-void) :void)
263        ((eq code area-cstack) :cstack)
264        ((eq code area-vstack) :vstack)
265        ((eq code area-tstack) :tstack)
266        ((eq code area-readonly) :readonly)
267        ((eq code area-watched) :watched)
268        ((eq code area-managed-static) :managed-static)
269        ((eq code area-static) :static)
270        ((eq code area-dynamic) :dynamic)
271        ((eql 0 (logand code (1- (ash 1 target::fixnum-shift))))
272         (gc-area-name (ash code (- target::fixnum-shift))))
273        (t code)))
274
275(defun gc-area-code (name)
276  (case name
277    (:void area-void)
278    (:cstack area-cstack)
279    (:vstack area-vstack)
280    (:tstack area-tstack)
281    (:readonly area-readonly)
282    (:watched area-watched)
283    (:managed-static area-managed-static)
284    (:static area-static)
285    (:dynamic area-dynamic)
286    (t (if (and (fixnump name)
287                (<= area-readonly name area-dynamic))
288         name
289         (gc-area-code (require-type name '(member :void :cstack :vstack :tstack :readonly :managed-static :static :dynamic)))))))
290
291
292(defx86lapfunction %%raw-obj ((address arg_z))
293  (unbox-fixnum address arg_z)
294  (single-value-return))
295
296(declaim (inline uvheader-p uvheader-typecode uvheader-size))
297
298(defun uvheader-p (header)
299  (let ((tag (logand header target::fulltagmask)))
300    (declare (fixnum tag))
301    (and (<= target::fulltag-nodeheader-0 tag)
302         (<= tag target::fulltag-immheader-2)
303         (neq tag target::fulltag-odd-fixnum))))
304
305(defun uvheader-typecode (header)
306  (the fixnum (logand #xFF header)))
307
308(defun uvheader-size (header)
309  (ash header (- target::num-subtag-bits)))
310
311(defun uvheader-byte-size (header)
312  (x8664::x8664-misc-byte-count (uvheader-typecode header) (uvheader-size header)))
313
314(defun uvheader-type (header)
315  (let* ((typecode (uvheader-typecode header))
316         (low4 (logand typecode target::fulltagmask))
317         (high4 (ash typecode (- target::ntagbits))))
318    (declare (type (unsigned-byte 8) typecode)
319             (type (unsigned-byte 4) low4 high4))
320    (cond ((eql low4 x8664::fulltag-immheader-0)
321           (%svref *immheader-0-types* high4))
322          ((eql low4 x8664::fulltag-immheader-1)
323           (%svref *immheader-1-types* high4))
324          ((eql low4 x8664::fulltag-immheader-2)
325           (%svref *immheader-2-types* high4))
326          ((eql low4 x8664::fulltag-nodeheader-0)
327           (%svref *nodeheader-0-types* high4))
328          ((eql low4 x8664::fulltag-nodeheader-1)
329           (%svref *nodeheader-1-types* high4))
330          (t 'bogus))))
331
332(defun uvheader-type-typecode (symbol &aux pos)
333  (unless (eq symbol 'bogus)
334    (cond ((setq pos (position symbol *immheader-0-types*))
335           (logior (ash pos target::ntagbits) target::fulltag-immheader-0))
336          ((setq pos (position symbol *immheader-1-types*))
337           (logior (ash pos target::ntagbits) target::fulltag-immheader-1))
338          ((setq pos (position symbol *immheader-2-types*))
339           (logior (ash pos target::ntagbits) target::fulltag-immheader-2))
340          ((setq pos (position symbol *nodeheader-0-types*))
341           (logior (ash pos target::ntagbits) target::fulltag-nodeheader-0))
342          ((setq pos (position symbol *nodeheader-1-types*))
343           (logior (ash pos target::ntagbits) target::fulltag-nodeheader-1)))))
344
345;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
346;;
347;;  Core heap
348
349(defun map-core-areas (function &key area)
350  (setq area (cond ((or (eq area t) (eq area nil)) nil)
351                   ((consp area) (mapcar #'gc-area-code area))
352                   (t (list (gc-area-code area)))))
353  (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ)
354          then (core-q area-ptr target::area.succ)
355        as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift))
356        until (= code area-void)
357        do (when (and (<= area-readonly code)
358                      (<= code area-dynamic)
359                      (or (null area) (member code area))
360                      (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)))
361             #+debug
362             (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)"
363                     area-ptr (gc-area-name code)
364                     (core-q area-ptr target::area.low)
365                     (core-q area-ptr target::area.active)
366                     (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))
367                     (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low)))
368             (map-core-area area-ptr function))))
369
370(defun map-core-area (area-ptr fun)
371  (let* ((ptr (core-q area-ptr target::area.low))
372         (end (core-q area-ptr target::area.active)))
373    (loop
374      (when (>= ptr end) (return))
375      (let ((header (core-q ptr)))
376        (cond ((uvheader-p header)
377               (let ((subtag (uvheader-typecode header)))
378                 (funcall fun
379                          (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol)
380                                       ((eq subtag target::subtag-function) target::fulltag-function)
381                                       (t target::fulltag-misc)))))
382               (let* ((bytes (uvheader-byte-size header))
383                      (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size)))
384                                       (1- target::dnode-size))))
385                 (declare (fixnum bytes total))
386                 (incf ptr total)))
387              (t
388               (funcall fun (+ ptr target::fulltag-cons))
389               (incf ptr target::cons.size)))))))
390
391
392(declaim (inline core-consp core-symbolp core-listp core-nullp))
393
394(defun core-consp (ptr)
395  (eq (logand ptr target::fulltagmask) target::fulltag-cons))
396
397(defun core-symbolp (ptr)
398  (eq (logand ptr target::fulltagmask) target::fulltag-symbol))
399
400(defun core-listp (ptr)
401  (eq (logand ptr target::tagmask) target::tag-list))
402
403(defun core-nullp (obj)
404  (eq (logand obj target::fulltagmask) target::fulltag-nil))
405
406;; uvector utilities
407(declaim (inline core-uvector-p core-uvheader core-uvtypecode core-uvtype))
408
409(defun core-uvector-p (ptr)
410  (%i>= (logand ptr target::fulltagmask) target::fulltag-misc))
411
412(defun core-uvheader (vec-ptr)
413  (core-q (logandc2 vec-ptr target::fulltagmask)))
414
415(defun core-uvtypecode (vec-ptr)
416  (uvheader-typecode (core-uvheader vec-ptr)))
417
418(defun core-uvtype (vec-ptr)
419  (uvheader-type (core-uvheader vec-ptr)))
420
421(defmacro core-uvtypep (vec-ptr type &aux temp)
422  (when (keywordp type)
423    (setq type (type-keyword-code type)))
424  (when (and (or (symbolp (setq temp type))
425                 (and (quoted-form-p type)
426                      (symbolp (setq temp (cadr type)))))
427             (setq temp (find-symbol (symbol-name temp) :ccl))
428             (setq temp (uvheader-type-typecode temp)))
429    (setq type temp))
430  (when (constant-symbol-p type)
431    (setq temp (symbol-value type))
432    (when (<= 0 temp #xFF) (setq type temp)))
433  `(let ((vec-ptr ,vec-ptr))
434     (and (core-uvector-p vec-ptr)
435          (eq (core-uvtypecode vec-ptr) ,type))))
436
437(defun core-uvref (vec-ptr index)
438  (let* ((header (core-uvheader vec-ptr))
439         (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size))
440         (typecode (uvheader-typecode header))
441         (tag (logand typecode target::fulltagmask))
442         (len (uvheader-size header)))
443    (assert (< -1 index len))
444    (cond ((or (eql tag target::fulltag-nodeheader-0)
445               (eql tag target::fulltag-nodeheader-1))
446           (core-q addr (ash index target::word-shift)))
447          ((eql tag target::ivector-class-64-bit)
448           (cond ((eq typecode target::subtag-double-float-vector)
449                  (error "~s not implemented yet" 'target::subtag-double-float-vector))
450                 (t
451                  (core-q addr (ash index target::word-shift)))))
452          ((eq tag target::ivector-class-32-bit)
453           (cond ((eq typecode target::subtag-simple-base-string)
454                  (code-char (core-l addr (ash index 2))))
455                 ((eq typecode target::subtag-single-float-vector)
456                  (error "~s not implemented yet" 'target::subtag-single-float-vector))
457                 (t (core-l addr (ash index 2)))))
458          ((eq typecode target::subtag-bit-vector)
459           (let ((byte (core-b addr (ash (+ index 7) -3))))
460             (error "not implemented, for ~b" byte)))
461          ((>= typecode target::min-8-bit-ivector-subtag)
462           (core-b addr index))
463          (t (core-w addr (ash index 1))))))
464
465(defun core-uvsize (vec-ptr)
466  (uvheader-size (core-uvheader vec-ptr)))
467
468(defun core-car (obj)
469  (assert (core-listp obj))
470  (core-q obj target::cons.car))
471
472(defun core-cdr (obj)
473  (assert (core-listp obj))
474  (core-q obj target::cons.cdr))
475
476(defun core-object-type (obj)
477  (let ((fulltag (logand obj target::fulltagmask)))
478    (cond ((eq fulltag target::fulltag-cons) 'cons)
479          ((eq fulltag target::fulltag-nil) 'null)
480          ((eq (logand fulltag target::tagmask) target::tag-fixnum) 'fixnum)
481          ((and (or (eq fulltag target::fulltag-imm-0)
482                    (eq fulltag target::fulltag-imm-1))
483                (fixnump obj))
484           ;; Assumes we're running on same architecture as core file.
485           (type-of (%%raw-obj obj)))
486          ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address)
487          ((eq fulltag target::fulltag-misc) (core-uvtype obj))
488          ((eq fulltag target::fulltag-symbol) 'symbol)
489          ;; TODO: Could get hairier based on lfun-bits, but usually don't care.
490          ((eq fulltag target::fulltag-function) 'function)
491          (t (cerror "treat as ~*~s" "Invalid object tag at #x~x" obj 'bogus)
492           'bogus))))
493
494(defun core-istruct-type (obj)
495  (and (core-uvtypep obj :istruct)
496       (core-car (core-uvref obj 0))))
497       
498
499(defun core-object-type-and-size (obj)
500  (let ((fulltag (logand obj target::fulltagmask)))
501    (if (eq fulltag target::fulltag-cons)
502      (values 'cons target::dnode-size target::dnode-size)
503      (if (%i<= target::fulltag-misc fulltag)
504        (let* ((header (core-uvheader obj))
505               (logsize (uvheader-byte-size header))
506               ;; total including header and alignment.
507               (total (logandc2 (+ logsize target::node-size (1- target::dnode-size))
508                                (1- target::dnode-size))))
509          (values (uvheader-type header) logsize total))))))
510
511(defun core-heap-utilization (&key area unit sort)
512  (let* ((hash (make-hash-table :shared nil))
513         (total-physsize 0)
514         (div (ecase unit
515                ((nil) 1)
516                (:kb 1024.0d0)
517                (:mb (* 1024.0d0 1024.0d0))
518                (:gb (* 1024.0d0 1024.0d0 1024.0d0))))
519         (sort-key (ecase sort
520                     (:count #'cadr)
521                     (:logical-size #'caddr)
522                     ((:physical-size nil) #'cdddr)))
523         (all nil))
524    (map-core-areas (lambda (obj)
525                      (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj)
526                        (let ((a (or (gethash type hash)
527                                     (setf (gethash type hash) (list* 0 0 0)))))
528                          (incf (car a))
529                          (incf (cadr a) logsize)
530                          (incf (cddr a) physsize))))
531                    :area area)
532    (maphash (lambda (type data)
533               (incf total-physsize (cddr data))
534               (push (cons type data) all))
535             hash)
536    (setq all (sort all #'> :key sort-key))
537    (format t "~&Object type~42tCount    Logical size   Physical size   % of Heap~%~50t~a~66t~:*~a"
538            (ecase unit
539              ((nil) " (in bytes)")
540              (:kb   "(in kilobytes)")
541              (:mb   "(in megabytes)")
542              (:gb   "(in gigabytes)")))
543    (loop for (type count logsize . physsize) in all
544          do (if unit
545               (format t "~&~a~36t~11d~16,2f~16,2f~11,2f%"
546                       type
547                       count
548                       (/ logsize div)
549                       (/ physsize div)
550                       (* 100.0 (/ physsize total-physsize)))
551               (format t "~&~a~36t~11d~16d~16d~11,2f%"
552                       type
553                       count
554                       logsize
555                       physsize
556                       (* 100.0 (/ physsize total-physsize)))))
557    (if unit
558      (format t "~&Total~63t~16,2f" (/ total-physsize div))
559      (format t "~&Total~63t~16d" total-physsize)))
560  (values))
561
562
563(defstruct unresolved-address address)
564
565(defmethod print-object ((obj unresolved-address) stream)
566  (let* ((address (unresolved-address-address obj)))
567    (format stream "#<Core ~S~@[[~d]~] #x~x >" 
568            (core-object-type address)
569            (and (core-uvector-p address) (core-uvsize address))
570            address)))
571
572(defun copy-from-core (obj &key (depth 1))
573  (check-type depth (integer 0))
574  (when (unresolved-address-p obj)
575    (setq obj (unresolved-address-address obj)))
576  (let ((fulltag (logand obj target::fulltagmask)))
577    (cond ((eq fulltag target::fulltag-nil) nil)
578          ((eq (logand fulltag target::tagmask) target::tag-fixnum)
579           (ash obj (- target::fixnum-shift)))
580          ((and (fixnump obj)
581                (or (eq fulltag target::fulltag-imm-0)
582                    (eq fulltag target::fulltag-imm-1)))
583           (%%raw-obj obj))
584          ((< (decf depth) 0)
585           (make-unresolved-address :address obj))
586          ((%i<= target::fulltag-misc fulltag)
587           (or (and (core-uvtypep obj :package)
588                    (find-package (core-package-name obj)))
589               (let ((v (%copy-uvector-from-core obj depth)))
590                 (when (and (symbolp v) (<= depth 1))
591                   ;; Need to fix up the package slot else it's not useful
592                   (let ((pp (%svref (symptr->symvector v) target::symbol.package-predicate-cell)))
593                     (when (unresolved-address-p pp)
594                       (setq pp (copy-from-core pp :depth 1)))
595                     (when (and (consp pp) (unresolved-address-p (car pp)))
596                       (let ((pkg (unresolved-address-address (car pp))))
597                         (when (and (core-uvtypep pkg :package)
598                                    (setq pkg (find-package (core-package-name pkg))))
599                           (setf (car pp) pkg))))
600                     (setf (%svref (symptr->symvector v) target::symbol.package-predicate-cell) pp))
601                   ;; ditto for pname
602                   (let ((pp (%svref (symptr->symvector v) target::symbol.pname-cell)))
603                     (when (unresolved-address-p pp)
604                       (setf (%svref (symptr->symvector v) target::symbol.pname-cell)
605                             (copy-from-core pp :depth 1)))))
606                 v)))
607          ((eq fulltag target::fulltag-cons)
608           (cons (copy-from-core (core-car obj) :depth depth)
609                 (copy-from-core (core-cdr obj) :depth depth)))
610          (t (make-unresolved-address :address obj)))))
611
612(defun %copy-uvector-from-core (vec-ptr depth)
613  (let* ((header (core-uvheader vec-ptr))
614         (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size))
615         (typecode (uvheader-typecode header))
616         (tag (logand typecode target::fulltagmask))
617         (len (uvheader-size header))
618         (vec (%alloc-misc len typecode)))
619    (cond ((or (eq tag target::fulltag-nodeheader-0)
620               (eq tag target::fulltag-nodeheader-1))
621           (when (eql typecode target::subtag-function)
622             ;; Don't bother copying the code for now
623             (let ((skip (core-l addr)))
624               (assert (<= 0 skip len))
625               (incf addr (ash skip target::word-shift))
626               (decf len skip)))
627           (dotimes (i len)
628             (setf (%svref vec i)
629                   (copy-from-core (core-q addr (ash i target::word-shift)) :depth depth)))
630           (let ((ptrtag (logand vec-ptr target::fulltagmask)))
631             (cond ((eql ptrtag target::fulltag-symbol)
632                    (%symvector->symptr vec))
633                   ((eql ptrtag target::fulltag-function)
634                    (%function-vector-to-function vec))
635                   (t vec))))
636          ((eq tag target::ivector-class-64-bit)
637           (cond ((eq typecode target::subtag-double-float-vector)
638                  (warn "~s not implemented yet" 'target::subtag-double-float-vector)
639                  (make-unresolved-address :address vec-ptr))
640                 (t
641                  (dotimes (i len vec)
642                    (setf (uvref vec i) (core-q addr (ash i target::word-shift)))))))
643          ((eq tag target::ivector-class-32-bit)
644           (cond ((eq typecode target::subtag-simple-base-string)
645                  (dotimes (i len vec)
646                    (setf (uvref vec i) (code-char (core-l addr (ash i 2))))))
647                 ((eq typecode target::subtag-single-float-vector)
648                  (warn "~s not implemented yet" 'target::subtag-single-float-vector)
649                  (make-unresolved-address :address vec-ptr))
650                 (t
651                  (dotimes (i len vec)
652                    (setf (uvref vec i) (core-l addr (ash i 2)))))))
653          ((eq typecode target::subtag-bit-vector)
654           (warn "bit vector not implemented yet")
655           (make-unresolved-address :address vec-ptr))
656          ((>= typecode target::min-8-bit-ivector-subtag)
657           (dotimes (i len vec)
658             (setf (uvref vec i) (core-b addr i))))
659          (t
660           (dotimes (i len vec)
661             (setf (uvref vec i) (core-w addr (ash i 1))))))))
662
663(defun map-core-pointers (fn)
664  (map-core-areas (lambda (obj)
665                    (cond ((core-consp obj)
666                           (funcall fn (core-car obj) obj 0)
667                           (funcall fn (core-cdr obj) obj 1))
668                          (t
669                           (let* ((header (core-uvheader obj))
670                                  (subtag (logand header target::fulltagmask)))
671                             (when (or (eq subtag target::fulltag-nodeheader-0)
672                                       (eq subtag target::fulltag-nodeheader-1))
673                               (let* ((typecode (uvheader-typecode header))
674                                      (len (uvheader-size header))
675                                      (addr (+ (logandc2 obj target::fulltagmask) target::node-size)))
676                                 (when (eql typecode target::subtag-function)
677                                   (let ((skip (core-l addr)))
678                                     (assert (<= 0 skip len))
679                                     (incf addr (ash skip target::word-shift))
680                                     (decf len skip)))
681                                 (dotimes (i len)
682                                   (funcall fn (core-q addr (ash i target::word-shift)) obj i))))))))))
683
684
685(defun core-instance-class-name (obj)
686  (when (core-uvtypep obj :slot-vector)
687    (setq obj (core-uvref obj slot-vector.instance)))
688  (assert (core-uvtypep obj :instance))
689  (let* ((wrapper (core-uvref obj instance.class-wrapper))
690         (class (core-uvref wrapper %wrapper-class))
691         (class-slots (core-uvref class instance.slots))
692         (name (core-uvref class-slots %class.name)))
693    (core-symbol-name name)))
694
695(defun core-symptr (obj)
696  (if (core-nullp obj)
697    (nil-relative-symbol-address 'nil)
698    (when (core-uvtypep obj :symbol)
699      (let ((tag (logand obj target::fulltagmask)))
700        (unless (eq tag target::fulltag-symbol)
701          (incf obj (%i- target::fulltag-symbol tag))))
702      obj)))
703   
704(defun core-symbol-name (obj)
705  (when (setq obj (core-symptr obj))
706    (copy-from-core (core-q obj target::symbol.pname) :depth 1)))
707
708(defun core-symbol-value (obj)
709  (when (setq obj (core-symptr obj))
710    (core-q obj target::symbol.vcell)))
711
712(defun core-symbol-package (obj)
713  (when (setq obj (core-symptr obj))
714    (let ((cell (core-q obj target::symbol.package-predicate)))
715      (if (core-consp cell)
716        (core-car cell)
717        cell))))
718
719(defun core-all-packages-ptr ()
720  (core-symbol-value (nil-relative-symbol-address '%all-packages%)))
721
722(defun core-keyword-package ()
723  (core-symbol-value (nil-relative-symbol-address '*keyword-package*)))
724
725(defun core-symbol-pointers ()
726  (or (core-info-symbol-ptrs (current-core))
727      (let ((vector (make-array 1000 :adjustable t :fill-pointer 0))
728            (keys (core-keyword-package)))
729        (map-core-areas (lambda (obj)
730                          (when (core-symbolp obj)
731                            (unless (eq (core-symbol-package obj) keys)
732                              (vector-push-extend obj vector)))))
733        (setf (core-info-symbol-ptrs (current-core)) vector))))
734
735(defun core-map-symbols (fun)
736  (loop for sym-ptr across (core-symbol-pointers) do (funcall fun sym-ptr)))
737
738
739(defun core-string-equal (ptr string &aux (len (length string)))
740  (assert (core-uvtypep ptr :simple-string))
741  (when (eq (core-uvsize ptr) len)
742    (loop for i from 0 below len
743          always (eql (core-uvref ptr i) (aref string i)))))
744
745(defun core-find-package (name &key error)
746  (setq name (string name))
747  (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr)
748            while (core-consp list-ptr)
749            as pkg-ptr = (core-car list-ptr)
750            when (loop for names-ptr = (core-uvref pkg-ptr pkg.names) then (core-cdr names-ptr)
751                       while (core-consp names-ptr)
752                       as name-ptr = (core-car names-ptr)
753                       thereis (core-string-equal name-ptr name))
754              do (return pkg-ptr))
755      (and error (error "No package named ~s" name))))
756
757(defun core-package-names (pkg-ptr)
758  (assert (core-uvtypep pkg-ptr :package))
759  (copy-from-core (core-uvref pkg-ptr pkg.names) :depth 2))
760
761(defun core-package-name (pkg-ptr)
762  (assert (core-uvtypep pkg-ptr :package)) 
763  (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1))
764
765(defun core-find-symbol (name &optional (package (symbol-package name)))
766  ;; Unlike the real cl:find-symbol, this doesn't look for inherited symbols,
767  ;; you have to get the package right.
768  (let* ((symbol-name (string name))
769         (name-len (length symbol-name))
770         (pkg-ptr (if (integerp package)
771                    package
772                    (core-find-package (if (packagep package)
773                                         (package-name package)
774                                         (string package))
775                                       :error t))))
776    (assert (core-uvtypep pkg-ptr :package))
777    (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len)
778      (flet ((findsym (htab-ptr)
779               (let* ((vec-ptr (core-car htab-ptr))
780                      (vlen (core-uvsize vec-ptr)))
781                 (loop for idx = (fast-mod primary vlen) then (+ i secondary)
782                       for i = idx then (if (>= idx vlen) (- idx vlen) idx)
783                       as sym = (core-uvref vec-ptr i)
784                       until (eql sym 0)
785                       do (when (and (core-symbolp sym)
786                                     (core-string-equal (core-q sym target::symbol.pname) symbol-name))
787                            (return (if (eq sym (nil-relative-symbol-address 'nil))
788                                      (target-nil-value)
789                                      sym)))))))
790        (or (findsym (core-uvref pkg-ptr pkg.itab))
791            (findsym (core-uvref pkg-ptr pkg.etab)))))))
792
793(defun core-gethash (key-ptr hash-ptr)
794  (when (core-uvtypep hash-ptr :istruct)
795    (setq hash-ptr (core-uvref hash-ptr nhash.vector)))
796  (assert (core-uvtypep hash-ptr :hash-vector))
797  (loop for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2
798        do (when (eq (core-uvref hash-ptr i) key-ptr)
799             (return (core-uvref hash-ptr (1+ i))))))
800
801(defun core-hash-table-count (hash-ptr)
802  (when (core-uvtypep hash-ptr :istruct)
803    (setq hash-ptr (core-uvref hash-ptr nhash.vector)))
804  (assert (core-uvtypep hash-ptr :hash-vector))
805  (loop with rehashing = (%fixnum-address-of (%slot-unbound-marker))
806        with free = (%fixnum-address-of (%unbound-marker))
807        for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2
808        count (let ((value (core-uvref hash-ptr (1+ i))))
809                (when (eq value rehashing)
810                  (error "This table is being rehashed"))
811                (neq value free))))
812
813(defun core-classes-hash-table-ptr ()
814  (or (core-info-classes-hash-table-ptr (current-core))
815      (setf (core-info-classes-hash-table-ptr (current-core))
816            (core-symbol-value (core-find-symbol '%find-classes%)))))
817
818(defun core-find-class (name)
819  (let* ((name-ptr (etypecase name
820                     (integer 
821                        (assert (core-symbolp name))
822                        name)
823                     (symbol (core-find-symbol name))))
824         (hash-ptr (core-classes-hash-table-ptr))
825         (cell (core-gethash name-ptr hash-ptr))
826         (class (and cell (core-uvref cell class-cell-class))))
827    (and class (core-uvtypep class :instance) class)))
828
829(defun core-lfun-names-table-ptr ()
830  (or (core-info-lfun-names-table-ptr (current-core))
831      (setf (core-info-lfun-names-table-ptr (current-core))
832            (core-symbol-value (core-find-symbol '*lfun-names*)))))
833
834(defun core-lfun-name (fn)
835  (assert (core-uvtypep fn :function))
836  (core-gethash fn (core-lfun-names-table-ptr)))
837
838
839(defun core-list (ptr)
840  (let ((cars (loop while (core-consp ptr)
841                    collect (core-car ptr)
842                    do (setq ptr (core-cdr ptr)))))
843    (if (core-nullp ptr)
844      cars
845      (nconc cars ptr))))
846
847(defun core-all-processes ()
848  (let* ((sym (core-find-symbol 'all-processes))
849         (closure (core-uvref sym target::symbol.fcell-cell))
850         (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size))
851         (imm-end (core-uvsize closure))
852         (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx)
853                      when (core-uvtypep imm :value-cell) return imm))
854         (val (core-uvref vcell target::value-cell.value-cell))
855         (processes (core-list val)))
856    processes))
857
858(defun core-process-name (proc)
859  (assert (core-uvtypep proc :instance))
860  (let ((slots (core-uvref proc ccl::instance.slots)))
861    (copy-from-core (core-uvref slots 1) :depth 1)))
862
863(defun core-process-tcr (proc)
864  (assert (core-uvtypep proc :instance))
865  (let* ((slots (core-uvref proc ccl::instance.slots))
866         (thread (core-uvref slots 2)))
867    (core-uvref thread ccl::lisp-thread.tcr)))
868
869) ; :x8664-target
Note: See TracBrowser for help on using the repository browser.