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

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

fix build (bootstrapping)

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.