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