;;; ;;; Copyright (C) 2009-2010 Clozure Associates and contributors ;;; This file is part of Clozure CL. ;;; ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public ;;; License , known as the LLGPL and distributed with Clozure CL as the ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, ;;; which is distributed with Clozure CL as the file "LGPL". Where these ;;; conflict, the preamble takes precedence. ;;; ;;; Clozure CL is referenced in the preamble as the "LIBRARY." ;;; ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html ;; Functions to examine core files. (in-package :ccl) #+:linuxx8664-target (progn (defconstant $image-nsections 7) (defconstant $image-data-offset-64 9) (defconstant $image-header-size 16) (defconstant $image-sect-code 0) (defconstant $image-sect-size 4) (defconstant $image-sect-header-size 8) (export '(open-core close-core core-heap-utilization map-core-areas core-q core-l core-w core-b core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p core-uvtype core-uvtypep core-uvref core-uvsize core-car core-cdr core-object-typecode-type core-object-type-key core-type-string copy-from-core core-list core-keyword-package core-find-package core-find-symbol core-package-names core-package-name core-map-symbols core-symbol-name core-symbol-value core-symbol-package core-symbol-plist core-gethash core-hash-table-count core-lfun-name core-lfun-bits core-nth-immediate core-find-class core-instance-class core-instance-p core-string= core-all-processes core-process-name core-find-process-for-id core-print core-print-call-history )) (eval-when (:compile-toplevel :execute) (require "HASHENV" "ccl:xdump;hashenv")) ;; The intended way to use these facilities is to open up a particular core file once, ;; and then repeatedly call functions to examine it. So for convenience, we keep the ;; core file in a global var, rather than making all user functions take an extra arg. ;; There is nothing intrinsic that would prevent having multiple core files open at once. (defvar *current-core* nil) (eval-when (load eval #-BOOTSTRAPPED compile) (defstruct core-info pathname sections ;; uses either stream or ivector, determined at runtime streams ivectors ;; caches symbol-ptrs classes-hash-table-ptr lfun-names-table-ptr process-class ) ) (defmethod print-object :around ((core core-info) (stream t)) (let ((*print-array* nil) (*print-simple-bit-vector* nil)) (call-next-method))) (declaim (type (or null core-info) *current-core*) (ftype (function () core-info) current-core) (inline current-core)) (defun current-core () (or *current-core* (require-type *current-core* 'core-info))) (defun close-core () (let ((core *current-core*)) (setq *current-core* nil) (when core (map nil #'close (core-info-streams core)) (map nil #'unmap-ivector (core-info-ivectors core)) t))) ; (defmacro area-loop (with ptrvar &body body) (assert (eq with 'with)) (let ((before (loop while (eq (car body) 'with) nconc (list (pop body) (pop body) (pop body) (pop body))))) `(loop ,@before for ,ptrvar = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ) then (core-q ,ptrvar target::area.succ) until (eq (core-q area-ptr target::area.code) (ash area-void target::fixnum-shift)) ,@body))) (def-accessor-macros %svref %core-sect.start-addr %core-sect.offset %core-sect.end-addr %core-sect.ivector %core-sect.stream) (defun make-core-sect (&key start end offset ivector stream) (vector start offset end ivector stream)) (defvar *core-info-class* 'core-info) ;; TODO: after load sections, check if highest heap address is a fixnum, and ;; arrange to use fixnum-only versions of the reading functions. (defun open-core (pathname &key (image nil) (method :mmap) (core-info nil)) (when *current-core* (close-core)) (let* ((sections (read-sections pathname)) (core (require-type (or core-info (make-instance *core-info-class*)) 'core-info))) (setf (core-info-pathname core) pathname) (setf (core-info-sections core) sections) (setf (core-info-symbol-ptrs core) nil) (setf (core-info-classes-hash-table-ptr core) nil) (setf (core-info-lfun-names-table-ptr core) nil) (setf (core-info-process-class core) nil) (setf (core-info-ivectors core) nil) (setf (core-info-streams core) nil) (ecase method (:mmap (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8)))) (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector) (push mapped-vector (core-info-ivectors core)) (loop for sect across sections do (incf (%core-sect.offset sect) offset) do (setf (%core-sect.ivector sect) vector))))) (:stream (let ((stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock))) (push stream (core-info-streams core)) (loop for sect across sections do (setf (%core-sect.stream sect) stream))))) (setq *current-core* core)) ;;(unless (every (lambda (sect) (fixnump (car sect))) (core-info-sections (current-core))) ;; (error "Non-fixnum addresses not supported")) (when (and image (area-loop with area-ptr thereis (and (eq (core-q area-ptr target::area.code) (ash area-readonly target::fixnum-shift)) (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)) (not (core-section-for-address (core-q area-ptr target::area.low)))))) ;; Have a missing readonly section, and an image file that might contain it. (add-core-sections-from-image image)) pathname) #-run-external-program-to-find-sections (defun sections-from-elf-file (pathname) (let* ((fd (fd-open (native-translated-namestring pathname) #$O_RDONLY))) (if (< fd 0) (signal-file-error fd pathname) (let* ((size (fd-size fd)) (map (#_mmap +null-ptr+ size #$PROT_READ #$MAP_PRIVATE fd 0))) (if (eql map #$MAP_FAILED) (progn (fd-close fd) (error "Can't memory map file ~a." pathname)) (unwind-protect (progn (unless (and (eql (%get-unsigned-byte map 0) #x7f) (eql (%get-unsigned-byte map 1) (char-code #\E)) (eql (%get-unsigned-byte map 2) (char-code #\L)) (eql (%get-unsigned-byte map 3) (char-code #\F)) (eql (pref map #+64-bit-host #>Elf64_Ehdr.e_type #-64-bit-host #>Elf32_Ehdr.e_type) #$ET_CORE)) (error "Not an ELF core file: ~a." pathname)) (let* ((nsects (pref map #+64-bit-host #>Elf64_Ehdr.e_shnum #-64-bit-host #>Elf32_Ehdr.e_shnum)) (sectptr (%inc-ptr map (pref map #+64-bit-host #>Elf64_Ehdr.e_shoff #-64-bit-host #>Elf32_Ehdr.e_shoff))) (core-sections ())) (dotimes (i nsects (sort (coerce core-sections 'vector) #'< :key (lambda (x) (%core-sect.start-addr x)))) (when (logtest #$SHF_ALLOC (pref sectptr #+64-bit-host #>Elf64_Shdr.sh_flags #-64-bit-host #>Elf32_Shdr.sh_flags)) (let* ((start (pref sectptr #+64-bit-host #>Elf64_Shdr.sh_addr #-64-bit-host #>Elf32_Shdr.sh_addr)) (end (+ start (pref sectptr #+64-bit-host #>Elf64_Shdr.sh_size #-64-bit-host #>Elf32_Shdr.sh_size))) (offset (pref sectptr #+64-bit-host #>Elf64_Shdr.sh_offset #-64-bit-host #>Elf32_Shdr.sh_offset))) (push (make-core-sect :start start :end end :offset offset) core-sections))) (%incf-ptr sectptr (record-length #+64-bit-host #>Elf64_Shdr #-64-bit-host #>Elf32_Shdr))))) (#_munmap map size) (fd-close fd))))))) ;; Kinda stupid to call external program for this... (defun read-sections (pathname) #-run-external-program-to-find-sections (sections-from-elf-file pathname) #+run-external-program-to-find-sections (flet ((split (line start end) (loop while (setq start (position-if-not #'whitespacep line :start start :end end)) as match = (cdr (assq (char line start) '((#\[ . #\]) (#\( . #\)) (#\< . #\>)))) as next = (if match (1+ (or (position match line :start (1+ start) :end end) (error "Unmatched ~c at position ~s" (char line start) start))) (or (position-if #'whitespacep line :start start :end end) end)) collect (subseq line start next) do (setq start next)))) (let* ((file (native-translated-namestring pathname)) (string (with-output-to-string (output) #+readelf (ccl:run-program "readelf" `("--sections" "--wide" ,file) :output output) #-readelf (ccl:run-program "objdump" `("-h" "-w" ,file) :output output))) (header-pos (or #+readelf (position #\[ string) #-readelf (search "Idx Name" string) (error "Cannot parse: ~%~a" string))) (sections (loop for start = (1+ (position #\newline string :start header-pos)) then (1+ end) for end = (or (position #\newline string :start start) (length string)) while (and (< start end) (find (aref string start) " 123456789")) nconc (multiple-value-bind (name address filepos size) #+readelf (destructuring-bind (number name type address filepos size &rest flags) (split string start end) (declare (ignore flags)) (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\]))) (setq number (read-from-string number :start 1 :end (1- (length number)))) (when (eql number 0) (shiftf size filepos address type)) (values name address filepos size)) #-readelf (destructuring-bind (number name size address lma filepos &rest flags) (split string start end) (declare (ignore lma flags)) (parse-integer number :radix 10) ;; error checking only (values name address filepos size)) (unless (or (equal name "") (eql (char name 0) #\.)) (setq address (parse-integer address :radix 16)) (setq filepos (parse-integer filepos :radix 16)) (setq size (parse-integer size :radix 16)) (unless (eql size 0) (list (list address filepos size))))))) (sections (sort sections #'< :key #'car));; sort by address (sections (let ((last (car (last sections)))) ;; hack for loop below (nconc sections (list (list (+ (car last) (caddr last) 1) 0 0))))) (sections (loop with cur-address = -1 with cur-filepos = -1 with cur-end = cur-address for (address filepos size) in sections unless (or (= (+ cur-filepos (- address cur-address)) filepos) (= cur-address cur-end)) collect (make-core-sect :start cur-address :end cur-end :offset cur-filepos) do (if (= (+ cur-filepos (- address cur-address)) filepos) (setq cur-end (max (+ address size) cur-end)) (progn (assert (<= cur-end address));; no overlap. (setq cur-address address cur-filepos filepos cur-end (+ address size))))))) (coerce sections 'vector)))) (defun add-core-sections-from-image (pathname) (with-open-file (header-stream pathname :element-type '(signed-byte 32)) (labels ((read-at (&optional pos) (when pos (file-position header-stream pos)) (read-byte header-stream)) (readn (pos) (+ (logand #xFFFFFFFF (read-at pos)) (ash (read-at) 32)))) (let* ((sig '(#x4F70656E #x4D434C49 #x6D616765 #x46696C65)) (end (file-length header-stream)) (page-mask (1- *host-page-size*)) (header (+ end (/ (read-at (1- end)) 4)))) (unless (progn (file-position header-stream (- end 4)) (loop repeat 3 as s in sig always (eql s (read-at)))) (error "~s is not a ccl image file" pathname)) (assert (and (integerp header) (< header end) (<= 0 header))) (file-position header-stream header) (assert (loop for s in sig always (eql s (read-at)))) (let* ((nsections (read-at (+ header $image-nsections))) (offset #+64-bit-host (/ (+ (ash (read-at (+ header $image-data-offset-64)) 32) (logand #xFFFFFFFF (read-at))) 4) #-64-bit-host 0) (sections (loop repeat nsections for pos upfrom (+ header $image-header-size) by $image-sect-header-size for epos = (* 4 (+ header $image-header-size (* nsections $image-sect-header-size) offset)) then (+ fpos mem-size) as fpos = (logandc2 (+ epos page-mask) page-mask) as mem-size = (readn (+ pos $image-sect-size)) when (eq (readn (+ pos $image-sect-code)) (ash area-readonly target::fixnum-shift)) collect (cons fpos mem-size))) (new (area-loop with area-ptr when (and (eq (core-q area-ptr target::area.code) (ash area-readonly target::fixnum-shift)) (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active)) (not (core-section-for-address (core-q area-ptr target::area.low)))) collect (let* ((size (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low))) (matches (remove size sections :key 'cdr :test-not 'eql))) ;; **** should just do nothing if not found (assert (eql (length matches) 1)) (make-core-sect :start (core-q area-ptr target::area.low) :end (core-q area-ptr target::area.active) :offset (caar matches))))) (image-stream (open pathname :element-type '(unsigned-byte 8) :sharing :lock))) (unwind-protect (let ((core (current-core))) (setf (core-info-sections core) (sort (concatenate 'vector new (core-info-sections core)) #'< :key (lambda (s) (%core-sect.start-addr s)))) (push image-stream (core-info-streams core)) (loop for s in new do (setf (%core-sect.stream s) image-stream)) (setq image-stream nil)) (when image-stream (close image-stream :abort t)))))))) (declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq core-stream-readb core-stream-readw core-stream-readl core-stream-readq)) (declaim (ftype (function (t t) (unsigned-byte 8)) core-ivector-readb core-stream-readb) (ftype (function (t t) (unsigned-byte 16)) core-ivector-readw core-stream-readw) (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl) (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq) (ftype (function (simple-vector) fixnum) core-section-for-address)) (define-condition invalid-core-address (simple-error) () (:default-initargs :format-control "Unknown core address x~x")) (declaim (inline core-section-for-address)) (defun core-section-for-address (address) (loop with sections = (core-info-sections (current-core)) with len fixnum = (length sections) with low fixnum = -1 with high fixnum = len do (let ((half (the fixnum (ash (%i+ high low) -1)))) (declare (fixnum half)) (when (eq half low) (return (and (%i<= 0 half) (%i< half len) (let ((sect (%svref sections half))) (and (< address (%core-sect.end-addr (%svref sections half))) sect))))) (let ((sect (%svref sections half))) (if (%i<= (%core-sect.start-addr sect) address) (setq low half) (setq high half)))))) (defun core-heap-address-p (address) (core-section-for-address address)) (defun core-stream-readb (s offset) (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) (when offset (stream-position s offset)) (read-byte s)) (defun core-stream-readw (s offset) (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) (when offset (stream-position s offset)) (%i+ (core-stream-readb s nil) (%ilsl 8 (core-stream-readb s nil)))) (defun core-stream-readl (s offset) (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) (when offset (stream-position s offset)) (%i+ (core-stream-readw s nil) (%ilsl 16 (core-stream-readw s nil)))) (defun core-stream-readq (s offset) (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) (when offset (stream-position s offset)) (+ (core-stream-readl s nil) (ash (the fixnum (core-stream-readl s nil)) 32))) (defun core-ivector-readb (vec offset) (declare (type (simple-array (unsigned-byte 8) (*)) vec) (fixnum offset) (optimize (speed 3) (safety 0))) (aref vec offset)) (defun core-ivector-readw (vec offset) (declare (optimize (speed 3) (safety 0))) (%i+ (core-ivector-readb vec offset) (%ilsl 8 (core-ivector-readb vec (+ offset 1))))) (defun core-ivector-readl (vec offset) (declare (optimize (speed 3) (safety 0))) (%i+ (core-ivector-readw vec offset) (%ilsl 16 (core-ivector-readw vec (+ offset 2))))) (defun core-ivector-readq (vec offset) (declare (optimize (speed 3) (safety 0))) (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (+ offset 4)) 32))) (defun core-q (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) (incf address offset) (let* ((sect (or (core-section-for-address address) (error 'invalid-core-address :format-arguments (list address)))) (ivector (%core-sect.ivector sect)) (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector (core-ivector-readq ivector pos) (core-stream-readq (%core-sect.stream sect) pos)))) (defun core-l (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) (incf address offset) (let* ((sect (or (core-section-for-address address) (error 'invalid-core-address :format-arguments (list address)))) (ivector (%core-sect.ivector sect)) (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector (core-ivector-readl ivector pos) (core-stream-readl (%core-sect.stream sect) pos)))) (defun core-w (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) (incf address offset) (let* ((sect (or (core-section-for-address address) (error 'invalid-core-address :format-arguments (list address)))) (ivector (%core-sect.ivector sect)) (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector (core-ivector-readw ivector pos) (core-stream-readw (%core-sect.stream sect) pos)))) (defun core-b (address &optional (offset 0)) (declare (optimize (speed 3) (safety 0))) (incf address offset) (let* ((sect (or (core-section-for-address address) (error 'invalid-core-address :format-arguments (list address)))) (ivector (%core-sect.ivector sect)) (pos (+ (%core-sect.offset sect) (- address (%core-sect.start-addr sect))))) (if ivector (core-ivector-readb ivector pos) (core-stream-readb (%core-sect.stream sect) pos)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; general utilities ;; NIL is constant, assume is same in core as here. (defun kernel-global-address (global) (check-type global symbol) (+ (target-nil-value) (target::%kernel-global global))) (defun nil-relative-symbol-address (sym) (+ (target-nil-value) #x20 ;;; dunno why (* (or (position sym x86::*x86-nil-relative-symbols* :test #'eq) (error "Not a nil-relative symbol ~s" sym)) target::symbol.size) (- target::fulltag-symbol target::fulltag-nil))) (defun core-area-name (code) (or (heap-area-name code) (and (integerp code) (not (logtest code (1- (ash 1 target::fixnum-shift)))) (heap-area-name (ash code (- target::fixnum-shift)))))) (defx86lapfunction %%raw-obj ((address arg_z)) (unbox-fixnum address arg_z) (single-value-return)) (declaim (inline uvheader-p uvheader-typecode uvheader-size)) (defun uvheader-p (header) (let ((tag (logand header target::fulltagmask))) (declare (fixnum tag)) (and (<= target::fulltag-nodeheader-0 tag) (<= tag target::fulltag-immheader-2) (neq tag target::fulltag-odd-fixnum)))) (defun uvheader-typecode (header) (the fixnum (logand #xFF header))) (defun uvheader-size (header) (the fixnum (ash header (- target::num-subtag-bits)))) (defun uvheader-byte-size (header) (x8664::x8664-misc-byte-count (uvheader-typecode header) (uvheader-size header))) (defun uvheader-type (header) (let* ((typecode (uvheader-typecode header)) (low4 (logand typecode target::fulltagmask)) (high4 (ash typecode (- target::ntagbits)))) (declare (type (unsigned-byte 8) typecode) (type (unsigned-byte 4) low4 high4)) (cond ((eql low4 x8664::fulltag-immheader-0) (%svref *immheader-0-types* high4)) ((eql low4 x8664::fulltag-immheader-1) (%svref *immheader-1-types* high4)) ((eql low4 x8664::fulltag-immheader-2) (%svref *immheader-2-types* high4)) ((eql low4 x8664::fulltag-nodeheader-0) (%svref *nodeheader-0-types* high4)) ((eql low4 x8664::fulltag-nodeheader-1) (%svref *nodeheader-1-types* high4)) (t 'bogus)))) (defun uvheader-type-typecode (symbol &aux pos) (unless (eq symbol 'bogus) (cond ((setq pos (position symbol *immheader-0-types*)) (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-0)) ((setq pos (position symbol *immheader-1-types*)) (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-1)) ((setq pos (position symbol *immheader-2-types*)) (%ilogior (%ilsl target::ntagbits pos) target::fulltag-immheader-2)) ((setq pos (position symbol *nodeheader-0-types*)) (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-0)) ((setq pos (position symbol *nodeheader-1-types*)) (%ilogior (%ilsl target::ntagbits pos) target::fulltag-nodeheader-1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Core heap (defun core-heap-area-code (area) (let ((code (heap-area-code area)) (dynamic (ash (core-q (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ) target::area.code) (- target::fixnum-shift)))) (if (or (fixnump area) (eq dynamic area-dynamic) ;; account for watched area having been inserted (<= code area-watched)) code (1- code)))) (defun map-core-areas (function &key area) (if (eq area :tenured) (map-core-area (core-q (kernel-global-address 'tenured-area)) function) (area-loop with area-ptr with area = (cond ((or (eq area t) (eq area nil)) nil) ((consp area) (mapcar #'core-heap-area-code area)) (t (list (core-heap-area-code area)))) as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift)) do (when (and (<= area-readonly code) (<= code area-dynamic) (or (null area) (member code area)) (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active))) #+debug (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)" area-ptr (core-area-name code) (core-q area-ptr target::area.low) (core-q area-ptr target::area.active) (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low)) (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low))) (map-core-area area-ptr function))))) (defun map-core-area (area-ptr fun) (map-core-region (core-q area-ptr target::area.low) (core-q area-ptr target::area.active) fun)) (defun map-core-region (ptr end fun) (loop while (< ptr end) as header = (core-q ptr) do (cond ((uvheader-p header) (let ((subtag (uvheader-typecode header))) (funcall fun (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol) ((eq subtag target::subtag-function) target::fulltag-function) (t target::fulltag-misc))))) (let* ((bytes (uvheader-byte-size header)) (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size))) (1- target::dnode-size)))) (declare (fixnum bytes total)) (incf ptr total))) (t (funcall fun (+ ptr target::fulltag-cons)) (incf ptr target::cons.size))))) (declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp)) (defun core-consp (ptr) (eq (logand ptr target::fulltagmask) target::fulltag-cons)) (defun core-symbolp (ptr) (eq (logand ptr target::fulltagmask) target::fulltag-symbol)) (defun core-functionp (ptr) (eq (logand ptr target::fulltagmask) target::fulltag-function)) (defun core-listp (ptr) (eq (logand ptr target::tagmask) target::tag-list)) (defun core-nullp (obj) (eq (logand obj target::fulltagmask) target::fulltag-nil)) ;; uvector utilities (declaim (inline core-uvector-p core-uvheader core-uvtypecode core-uvtype)) (defun core-uvector-p (ptr) (%i>= (logand ptr target::fulltagmask) target::fulltag-misc)) (defun core-uvheader (vec-ptr) (core-q (logandc2 vec-ptr target::fulltagmask))) (defun core-uvtypecode (vec-ptr) (uvheader-typecode (core-uvheader vec-ptr))) (defun core-uvtype (vec-ptr) (uvheader-type (core-uvheader vec-ptr))) (defmacro core-uvtypep (vec-ptr type &aux temp) (when (keywordp type) (setq type (type-keyword-code type))) (when (and (or (symbolp (setq temp type)) (and (quoted-form-p type) (symbolp (setq temp (cadr type))))) (setq temp (find-symbol (symbol-name temp) :ccl)) (setq temp (uvheader-type-typecode temp))) (setq type temp)) (when (constant-symbol-p type) (setq temp (symbol-value type)) (when (<= 0 temp #xFF) (setq type temp))) `(let ((vec-ptr ,vec-ptr)) (and (core-uvector-p vec-ptr) (eq (core-uvtypecode vec-ptr) ,type)))) (defun core-uvref (vec-ptr index) (let* ((header (core-uvheader vec-ptr)) (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) (typecode (uvheader-typecode header)) (tag (%ilogand typecode target::fulltagmask)) (len (uvheader-size header))) (assert (< -1 index len)) (cond ((or (eq tag target::fulltag-nodeheader-0) (eq tag target::fulltag-nodeheader-1)) (core-q addr (%ilsl target::word-shift index))) ((eq tag target::ivector-class-64-bit) (cond ((eq typecode target::subtag-double-float-vector) (error "~s not implemented yet" 'target::subtag-double-float-vector)) (t (core-q addr (%ilsl target::word-shift index))))) ((eq tag target::ivector-class-32-bit) (cond ((eq typecode target::subtag-simple-base-string) (%code-char (core-l addr (%ilsl 2 index)))) ((eq typecode target::subtag-single-float-vector) (error "~s not implemented yet" 'target::subtag-single-float-vector)) (t (core-l addr (%ilsl 2 index))))) ((eq typecode target::subtag-bit-vector) (let ((byte (core-b addr (%iasr 3 (%i+ index 7))))) (error "not implemented, for ~b" byte))) ((>= typecode target::min-8-bit-ivector-subtag) (core-b addr index)) (t (core-w addr (%ilsl 1 index)))))) (defun core-uvsize (vec-ptr) (uvheader-size (core-uvheader vec-ptr))) (defun core-car (obj) (assert (core-listp obj)) (core-q obj target::cons.car)) (defun core-cdr (obj) (assert (core-listp obj)) (core-q obj target::cons.cdr)) (defun core-object-typecode-type (obj) (let ((fulltag (logand obj target::fulltagmask))) (cond ((eq fulltag target::fulltag-cons) 'cons) ((eq fulltag target::fulltag-nil) 'null) ((eq (logand fulltag target::tagmask) target::tag-fixnum) 'fixnum) ((and (or (eq fulltag target::fulltag-imm-0) (eq fulltag target::fulltag-imm-1)) (fixnump obj)) ;; Assumes we're running on same architecture as core file. (type-of (%%raw-obj obj))) ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address) ((eq fulltag target::fulltag-misc) ;; (core-uvtype obj) (handler-case (core-uvtype obj) (invalid-core-address () 'unmapped))) ((eq fulltag target::fulltag-symbol) 'symbol) ;; TODO: Could get hairier based on lfun-bits, but usually don't care. ((eq fulltag target::fulltag-function) 'function) (t (cerror "treat as ~*~s" "Invalid object tag at #x~x" obj 'bogus) 'bogus)))) (defun core-object-type-key (obj) ;; Returns either a symbol (for built-in types) or a pointer to type symbol or class. ;; Whatever it returns must be suitable for use in an eql hash table; use core-type-string ;; to get a printable rep. (let ((type (core-object-typecode-type obj))) (case type (function (core-function-type obj)) (internal-structure (core-istruct-type obj)) (structure (core-struct-type obj)) (instance (core-instance-type obj)) (t type)))) (defun core-function-type (obj) (and (core-uvtypep obj :function) (let ((bits (core-lfun-bits obj))) (declare (fixnum bits)) (or (if (logbitp $lfbits-trampoline-bit bits) (let* ((inner-fn (core-closure-function obj)) (inner-bits (core-lfun-bits inner-fn))) (if (neq inner-fn obj) (if (logbitp $lfbits-method-bit inner-bits) 'compiled-lexical-closure (unless (logbitp $lfbits-gfn-bit inner-bits) (if (logbitp $lfbits-cm-bit inner-bits) 'combined-method 'compiled-lexical-closure))) 'compiled-lexical-closure)) (if (logbitp $lfbits-method-bit bits) 'method-function (unless (logbitp $lfbits-gfn-bit bits) (if (logbitp $lfbits-cm-bit bits) 'combined-method 'function)))) (core-class-name (core-uvref (core-nth-immediate obj gf.instance.class-wrapper) %wrapper-class)))))) (defun core-type-string (object-type) (with-output-to-string (s) (if (fixnump object-type) (core-print object-type s) (prin1 object-type s)))) (defun core-istruct-type (obj) (and (core-uvtypep obj :istruct) (core-car (core-uvref obj 0)))) (defun core-struct-type (obj) (and (core-uvtypep obj :struct) (core-uvref (core-car (core-uvref obj 0)) 1))) (defun core-instance-type (obj) (and (core-uvtypep obj :instance) (core-class-name (core-instance-class obj)))) (defun core-class-name (class) (core-uvref (core-uvref class instance.slots) %class.name)) (defun core-object-type-and-size (obj) (let ((fulltag (logand obj target::fulltagmask))) (if (eq fulltag target::fulltag-cons) (values 'cons target::dnode-size target::dnode-size) (if (%i<= target::fulltag-misc fulltag) (let* ((header (core-uvheader obj)) (logsize (uvheader-byte-size header)) ;; total including header and alignment. (total (logandc2 (+ logsize target::node-size (1- target::dnode-size)) (1- target::dnode-size)))) (values (uvheader-type header) logsize total)))))) (defun core-heap-utilization (&key (stream *debug-io*) area unit (sort :size) classes (threshold 0.00005)) (let* ((obj-hash (make-hash-table :shared nil)) (slotv-hash (make-hash-table :shared nil)) (all nil)) (map-core-areas (lambda (obj &aux (hash obj-hash)) (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj) (when classes (when (core-uvtypep obj :slot-vector) (setq hash slotv-hash obj (core-uvref obj slot-vector.instance))) (setq type (core-object-type-key obj))) (let ((a (or (gethash type hash) (setf (gethash type hash) (list 0 0 0))))) (incf (car a)) (incf (cadr a) logsize) (incf (caddr a) physsize)))) :area area) (maphash (lambda (type data) (push (cons (core-type-string type) data) all)) obj-hash) (maphash (lambda (type data) (push (cons (concatenate 'string (core-type-string type) " slot-vector") data) all)) slotv-hash) (report-heap-utilization all :stream stream :unit unit :sort sort :threshold threshold))) (defstruct unresolved-address address) (defmethod print-object ((obj unresolved-address) stream) (let* ((address (unresolved-address-address obj))) (if (and (core-uvector-p address) (not (handler-case (core-uvheader address) (invalid-core-address () nil)))) (format stream "#" address) (format stream "#" (or (ignore-errors (core-type-string (core-object-type-key address))) (core-object-typecode-type address)) (and (core-uvector-p address) (core-uvsize address)) address)))) (defun copy-from-core (obj &key (depth 1)) (check-type depth (integer 0)) (when (unresolved-address-p obj) (setq obj (unresolved-address-address obj))) (let ((fulltag (logand obj target::fulltagmask))) (cond ((eq fulltag target::fulltag-nil) nil) ((eq (logand fulltag target::tagmask) target::tag-fixnum) (ash obj (- target::fixnum-shift))) ((and (fixnump obj) (or (eq fulltag target::fulltag-imm-0) (eq fulltag target::fulltag-imm-1))) (%%raw-obj obj)) ((< (decf depth) 0) (make-unresolved-address :address obj)) ((and (%i<= target::fulltag-misc fulltag) (handler-case (core-uvheader obj) (invalid-core-address nil))) (or (and (core-uvtypep obj :package) (find-package (core-package-name obj))) (let ((v (%copy-uvector-from-core obj depth))) (when (and (symbolp v) (<= depth 1)) ;; Need to fix up the package slot else it's not useful (let ((pp (%svref (symptr->symvector v) target::symbol.package-predicate-cell))) (when (unresolved-address-p pp) (setq pp (copy-from-core pp :depth 1))) (when (and (consp pp) (unresolved-address-p (car pp))) (let ((pkg (unresolved-address-address (car pp)))) (when (and (core-uvtypep pkg :package) (setq pkg (find-package (core-package-name pkg)))) (setf (car pp) pkg)))) (setf (%svref (symptr->symvector v) target::symbol.package-predicate-cell) pp)) ;; ditto for pname (let ((pp (%svref (symptr->symvector v) target::symbol.pname-cell))) (when (unresolved-address-p pp) (setf (%svref (symptr->symvector v) target::symbol.pname-cell) (copy-from-core pp :depth 1))))) v))) ((eq fulltag target::fulltag-cons) (cons (copy-from-core (core-car obj) :depth depth) (copy-from-core (core-cdr obj) :depth depth))) (t (make-unresolved-address :address obj))))) (defun %copy-uvector-from-core (vec-ptr depth) (let* ((header (core-uvheader vec-ptr)) (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) (typecode (uvheader-typecode header)) (tag (logand typecode target::fulltagmask)) (len (uvheader-size header)) (vec (%alloc-misc len typecode))) (declare (type fixnum typecode tag len)) (cond ((or (eq tag target::fulltag-nodeheader-0) (eq tag target::fulltag-nodeheader-1)) (when (eq typecode target::subtag-function) ;; Don't bother copying the code for now (let ((skip (core-l addr))) (declare (fixnum skip)) (assert (<= 0 skip len)) (incf addr (ash skip target::word-shift)) (decf len skip))) (dotimes (i len) (declare (fixnum i)) (setf (%svref vec i) (copy-from-core (core-q addr (%ilsl target::word-shift i)) :depth depth))) (let ((ptrtag (logand vec-ptr target::fulltagmask))) (cond ((eq ptrtag target::fulltag-symbol) (%symvector->symptr vec)) ((eq ptrtag target::fulltag-function) (%function-vector-to-function vec)) (t vec)))) ((eq tag target::ivector-class-64-bit) (cond ((eq typecode target::subtag-double-float-vector) (warn "~s not implemented yet" 'target::subtag-double-float-vector) (make-unresolved-address :address vec-ptr)) (t (dotimes (i len vec) (setf (uvref vec i) (core-q addr (%ilsl target::word-shift i))))))) ((eq tag target::ivector-class-32-bit) (cond ((eq typecode target::subtag-simple-base-string) (dotimes (i len vec) (setf (uvref vec i) (%code-char (core-l addr (%ilsl 2 i)))))) ((eq typecode target::subtag-single-float-vector) (warn "~s not implemented yet" 'target::subtag-single-float-vector) (make-unresolved-address :address vec-ptr)) (t (dotimes (i len vec) (setf (uvref vec i) (core-l addr (%ilsl 2 i))))))) ((eq typecode target::subtag-bit-vector) (warn "bit vector not implemented yet") (make-unresolved-address :address vec-ptr)) ((>= typecode target::min-8-bit-ivector-subtag) (dotimes (i len vec) (setf (uvref vec i) (core-b addr i)))) (t (dotimes (i len vec) (setf (uvref vec i) (core-w addr (%ilsl 1 i)))))))) (defun map-core-pointers (fn &key area) (map-core-areas (lambda (obj) (cond ((core-consp obj) (funcall fn (core-car obj) obj 0) (funcall fn (core-cdr obj) obj 1)) (t (let* ((header (core-uvheader obj)) (subtag (logand header target::fulltagmask))) (when (or (eq subtag target::fulltag-nodeheader-0) (eq subtag target::fulltag-nodeheader-1)) (let* ((typecode (uvheader-typecode header)) (len (uvheader-size header)) (addr (+ (logandc2 obj target::fulltagmask) target::node-size))) (declare (fixnum typecode len)) (when (eq typecode target::subtag-function) (let ((skip (core-l addr))) (declare (fixnum skip)) (assert (<= 0 skip len)) (incf addr (%ilsl target::word-shift skip)) (decf len skip))) (dotimes (i len) (funcall fn (core-q addr (%ilsl target::word-shift i)) obj i)))))))) :area area)) (defun core-find-tra-function (tra) (assert (eq (logand tra target::tagmask) target::tag-tra)) (map-core-areas (lambda (obj) (when (core-uvtypep obj :function) (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size)) (skip (core-l addr)) (offset (- tra addr))) (when (<= 0 offset (ash skip target::word-shift)) (return-from core-find-tra-function (values obj (+ offset (- target::node-size (logand obj target::fulltagmask))))))))))) (defun core-instance-class (obj) (when (core-uvtypep obj :slot-vector) (setq obj (core-uvref obj slot-vector.instance))) (assert (core-uvtypep obj :instance)) (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class)) (defun core-instance-p (obj class) (and (core-uvtypep obj :instance) (labels ((matchp (iclass) (or (eql iclass class) (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers) then (core-cdr supers) while (core-consp supers) thereis (matchp (core-car supers)))))) (matchp (core-instance-class obj))))) (defun core-symptr (obj) (if (core-nullp obj) (nil-relative-symbol-address 'nil) (when (core-uvtypep obj :symbol) (let ((tag (logand obj target::fulltagmask))) (unless (eq tag target::fulltag-symbol) (incf obj (%i- target::fulltag-symbol tag)))) obj))) (defun core-symbol-name (obj) (when (setq obj (core-symptr obj)) (copy-from-core (core-q obj target::symbol.pname) :depth 1))) (defun core-symbol-value (obj) (when (setq obj (core-symptr obj)) (core-q obj target::symbol.vcell))) (defun core-symbol-package (obj) (when (setq obj (core-symptr obj)) (let ((cell (core-q obj target::symbol.package-predicate))) (if (core-consp cell) (core-car cell) cell)))) (defun core-symbol-plist (obj) (when (setq obj (core-symptr obj)) (core-cdr (core-q obj target::symbol.plist)))) (defun core-all-packages-ptr () (core-symbol-value (nil-relative-symbol-address '%all-packages%))) (defun core-keyword-package () (core-symbol-value (nil-relative-symbol-address '*keyword-package*))) (defun core-symbol-pointers () (or (core-info-symbol-ptrs (current-core)) (let ((vector (make-array 1000 :adjustable t :fill-pointer 0))) (map-core-areas (lambda (obj) (when (core-symbolp obj) (vector-push-extend obj vector)))) (setf (core-info-symbol-ptrs (current-core)) vector)))) (defun core-map-symbols (fun) (loop for sym-ptr across (core-symbol-pointers) do (funcall fun sym-ptr))) (defun core-string= (ptr string &aux (len (length string))) (assert (core-uvtypep ptr :simple-string)) (when (eq (core-uvsize ptr) len) (loop for i from 0 below len always (eql (core-uvref ptr i) (aref string i))))) (defun core-find-package (name &key error) (when (integerp name) (when (core-symbolp name) (setq name (core-q name target::symbol.pname))) (when (core-uvtypep name :simple-string) (setq name (copy-from-core name :depth 1)))) (setq name (string name)) (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr) while (core-consp list-ptr) as pkg-ptr = (core-car list-ptr) when (loop for names-ptr = (core-uvref pkg-ptr pkg.names) then (core-cdr names-ptr) while (core-consp names-ptr) as name-ptr = (core-car names-ptr) thereis (core-string= name-ptr name)) do (return pkg-ptr)) (and error (error "No package named ~s" name)))) (defun core-package-names (pkg-ptr) (assert (core-uvtypep pkg-ptr :package)) (copy-from-core (core-uvref pkg-ptr pkg.names) :depth 2)) (defun core-package-name (pkg-ptr) (assert (core-uvtypep pkg-ptr :package)) (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1)) (defun core-find-symbol (name &optional package) ;; Unlike cl:find-symbol, this doesn't look for inherited symbols, ;; you have to get the package right. (when (integerp name) (when (core-symbolp name) (when (null package) (setq package (core-symbol-package name))) (setq name (core-q name target::symbol.pname))) (when (core-uvtypep name :simple-string) (setq name (copy-from-core name :depth 1)))) (when (and (null package) (non-nil-symbolp name)) (setq package (symbol-package name))) (when (null package) (error "Package is required")) (let* ((symbol-name (string name)) (name-len (length symbol-name)) (pkg-ptr (if (and (integerp package) (core-uvtypep package :package)) package (core-find-package (if (packagep package) (package-name package) package) :error t)))) (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len) (flet ((findsym (htab-ptr) (let* ((vec-ptr (core-car htab-ptr)) (vlen (core-uvsize vec-ptr))) (loop for idx = (fast-mod primary vlen) then (+ i secondary) for i = idx then (if (>= idx vlen) (- idx vlen) idx) as sym = (core-uvref vec-ptr i) until (eql sym 0) do (when (and (core-symbolp sym) (core-string= (core-q sym target::symbol.pname) symbol-name)) (return (if (eq sym (nil-relative-symbol-address 'nil)) (target-nil-value) sym))))))) (or (findsym (core-uvref pkg-ptr pkg.itab)) (findsym (core-uvref pkg-ptr pkg.etab))))))) (defun core-gethash (key-ptr hash-ptr) (when (core-uvtypep hash-ptr :istruct) (setq hash-ptr (core-uvref hash-ptr nhash.vector))) (assert (core-uvtypep hash-ptr :hash-vector)) (loop for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 do (when (eq (core-uvref hash-ptr i) key-ptr) (return (core-uvref hash-ptr (1+ i)))))) (defun core-hash-table-count (hash-ptr) (when (core-uvtypep hash-ptr :istruct) (setq hash-ptr (core-uvref hash-ptr nhash.vector))) (assert (core-uvtypep hash-ptr :hash-vector)) (loop with rehashing = (%fixnum-address-of (%slot-unbound-marker)) with free = (%fixnum-address-of (%unbound-marker)) for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 count (let ((value (core-uvref hash-ptr (1+ i)))) (when (eq value rehashing) (error "This table is being rehashed")) (neq value free)))) (defun core-classes-hash-table-ptr () (or (core-info-classes-hash-table-ptr (current-core)) (setf (core-info-classes-hash-table-ptr (current-core)) (core-symbol-value (core-find-symbol '%find-classes%))))) (defun core-find-class (name) (let* ((name-ptr (etypecase name (integer (assert (core-symbolp name)) name) (symbol (core-find-symbol name)))) (hash-ptr (core-classes-hash-table-ptr)) (cell (core-gethash name-ptr hash-ptr)) (class (and cell (core-uvref cell class-cell-class)))) (and class (core-uvtypep class :instance) class))) (defun core-lfun-names-table-ptr () (or (core-info-lfun-names-table-ptr (current-core)) (setf (core-info-lfun-names-table-ptr (current-core)) (core-symbol-value (core-find-symbol '*lfun-names*))))) (defun core-nth-immediate (fn i) (assert (core-uvtypep fn :function)) (let ((addr (+ (logandc2 fn target::fulltagmask) target::node-size))) (core-q addr (%ilsl target::word-shift (+ (core-l addr) i -1))))) (defun core-closure-function (fun) (while (and (core-functionp fun) (logbitp $lfbits-trampoline-bit (core-lfun-bits fun))) (setq fun (core-nth-immediate fun 1)) (when (core-uvtypep fun :simple-vector) (setq fun (core-uvref fun 0))) #+gz (assert (core-functionp fun))) fun) (defun core-lfun-name (fn) (assert (core-functionp fn)) (flet ((lfun-name (fn) (or (core-gethash fn (core-lfun-names-table-ptr)) (let* ((lfbits (core-lfun-bits fn)) (name (if (and (logbitp $lfbits-gfn-bit lfbits) (not (logbitp $lfbits-method-bit lfbits))) (core-uvref (core-nth-immediate fn gf.slots) sgf.name) (unless (logbitp $lfbits-noname-bit lfbits) (core-uvref fn (- (core-uvsize fn) 2)))))) (and name (not (eql name (%fixnum-address-of (%slot-unbound-marker)))) (not (core-nullp name)) name))))) (or (lfun-name fn) (let ((inner-fn (core-closure-function fn))) (and (core-functionp inner-fn) (not (eql inner-fn fn)) (lfun-name inner-fn)))))) (defun core-list (ptr) (let ((cars (loop while (core-consp ptr) collect (core-car ptr) do (setq ptr (core-cdr ptr))))) (if (core-nullp ptr) cars (nconc cars ptr)))) (defun core-all-processes () (let* ((sym (core-find-symbol 'all-processes)) (closure (core-uvref sym target::symbol.fcell-cell)) (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size)) (imm-end (core-uvsize closure)) (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx) when (core-uvtypep imm :value-cell) return imm)) (val (core-uvref vcell target::value-cell.value-cell)) (processes (core-list val))) processes)) (defun core-process-name (proc) (assert (core-uvtypep proc :instance)) (let ((slots (core-uvref proc ccl::instance.slots))) (copy-from-core (core-uvref slots 1) :depth 1))) (defun core-process-tcr (proc) (assert (core-uvtypep proc :instance)) (let* ((slots (core-uvref proc ccl::instance.slots)) (thread (core-uvref slots 2))) (core-uvref thread ccl::lisp-thread.tcr))) (defun core-find-process-for-id (lwp) (loop for proc in (core-all-processes) when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id)) return proc)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun core-process-class () (or (core-info-process-class (current-core)) (setf (core-info-process-class (current-core)) (core-find-class 'process)))) (defun core-print (obj &optional (stream t) depth) ;; TODO: could dispatch on core-object-typecode-type... (cond ((core-nullp obj) (format stream "NIL")) ((core-symbolp obj) (core-print-symbol obj stream)) ((core-uvtypep obj :function) (core-print-function obj stream)) ((core-instance-p obj (core-process-class)) (core-print-process obj stream)) ((and depth (< (decf depth) 0)) (format stream "x~x" obj)) ((core-consp obj) (loop for sep = "(" then " " for i from 0 below (or *print-length* 100) while (core-consp obj) do (format stream sep) do (core-print (core-car obj) stream depth) do (setq obj (core-cdr obj))) (unless (core-nullp obj) (format stream " . ") (core-print obj stream depth)) (format stream ")")) (t (format stream "#" (or (ignore-errors (core-type-string (core-object-type-key obj))) (core-object-typecode-type obj)) obj)))) (defun core-print-symbol (sym stream) (let ((package (core-symbol-package sym))) (cond ((core-nullp package) (format stream "#:")) ((eq package (core-keyword-package)) (format stream ":")) (t (let ((pkgname (core-package-name package))) (etypecase pkgname (unresolved-address (format stream "@~x::" (unresolved-address-address pkgname))) (string (unless (string-equal pkgname "COMMON-LISP") (format stream "~a::" pkgname))))))) (let ((symname (core-symbol-name sym))) (etypecase symname (unresolved-address (format stream "@~x" (unresolved-address-address symname))) (string (format stream "~a" symname))))) (values)) (defun core-lfun-bits (fun) (let ((unsigned (core-uvref fun (1- (core-uvsize fun))))) (ash (if (logbitp (1- (* target::node-size 8)) unsigned) (logior (ash -1 (* target::node-size 8)) unsigned) unsigned) (- target::fixnum-shift)))) (defun core-print-function (fun stream) (let* ((lfbits (core-lfun-bits fun)) (name (core-lfun-name fun))) (format stream "#<") (cond ((or (null name) (core-nullp name)) (format stream "Anonymous function")) ((logbitp $lfbits-method-bit lfbits) (assert (core-uvtypep name :instance)) (let* ((slot-vector (core-uvref name instance.slots)) (method-qualifiers (core-uvref slot-vector %method.qualifiers)) (method-specializers (core-uvref slot-vector %method.specializers)) (method-name (core-uvref slot-vector %method.name))) (format stream "Method-Function ") (core-print method-name stream) (format stream " ") (unless (core-nullp method-qualifiers) (if (core-nullp (core-cdr method-qualifiers)) (core-print (core-car method-qualifiers) stream) (core-print method-qualifiers stream)) (format stream " ")) ;; print specializer list but print names instead of classes. (loop for sep = "(" then " " while (core-consp method-specializers) do (format stream sep) do (let ((spec (core-car method-specializers))) (if (core-uvtypep spec :instance) (let ((slots (core-uvref spec instance.slots))) ;; specializer is either a class or a ccl::eql-specializer (if (eql (core-uvsize slots) 3) (progn (format stream "(EQL ") (core-print (core-uvref slots 2) stream) (format stream ")")) (core-print (core-uvref slots %class.name) stream))) (core-print spec stream))) do (setq method-specializers (core-cdr method-specializers))) (unless (core-nullp method-specializers) (format stream " . ") (core-print method-specializers stream)) (format stream ")"))) (t (if (logbitp $lfbits-gfn-bit lfbits) (format stream "Generic Function ") (format stream "Function ")) (core-print name stream))) (format stream " x~x>" fun))) (defun core-print-process (proc stream) (format stream "#<~a ~s LWP(~d) #x~x>" (core-symbol-name (core-instance-type proc)) (core-process-name proc) (core-q (core-process-tcr proc) target::tcr.native-thread-id) proc)) (defun dwim-core-frame-pointer (tcr &optional end) (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr))) (lexprs (list (core-q (kernel-global-address 'lexpr-return)) (core-q (kernel-global-address 'lexpr-return1v)))) (stack-area (core-q tcr target::tcr.vs-area)) (fp (core-q stack-area target::area.high)) (low (core-q stack-area target::area.low))) (flet ((validp (pp) (let ((tra (core-q pp target::lisp-frame.return-address))) (when (eql tra ret1valn) (setq tra (core-q pp target::lisp-frame.xtra))) (or (eql (logand tra target::tagmask) target::tag-tra) (eql tra 0) (member tra lexprs))))) (decf fp (* 2 target::node-size)) (when (and end (<= low end fp)) (setq low (- end 8))) (loop while (loop for pp downfrom (- fp target::node-size) above low by target::node-size do (when (eql (core-q pp target::lisp-frame.backptr) fp) (when (validp pp) (return (setq fp pp)))))) fp))) (defun core-stack-frame-values (tcr fp) (let* ((bottom (core-q fp target::lisp-frame.backptr)) (top (if (eql 0 (core-q fp target::lisp-frame.return-address)) (+ fp target::xcf.size) (+ fp (if (eql (core-q fp target::lisp-frame.return-address) (core-q (kernel-global-address 'ret1valaddr))) target::lisp-frame.size target::lisp-frame.xtra)))) (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db) until (or (eql db 0) (>= db bottom)) when (<= top db) return db))) (loop for vsp from top below bottom by target::node-size when (eql vsp db-link) ;; The db-link will be followed by var and val, which we'll just collect normally do (setq db-link (core-q db-link) vsp (+ vsp target::node-size)) and collect `(:db-link ,db-link) collect (core-q vsp)))) (defun core-print-call-history (process &key (stream t) origin detailed-p) (flet ((fp-backlink (fp vs-end) (let ((backlink (core-q fp target::lisp-frame.backptr))) (when (or (eql backlink 0) (<= vs-end backlink) (<= vs-end (core-q backlink target::lisp-frame.backptr))) (setq backlink vs-end)) (assert (< fp backlink)) backlink)) (fp-tra (fp) (let ((tra (core-q fp target::lisp-frame.return-address))) (if (eql tra (core-q (kernel-global-address 'ret1valaddr))) (core-q fp target::lisp-frame.xtra) tra))) (recover-fn (pc) (when (and (eql (logand pc target::tagmask) target::tag-tra) (eql (core-w pc) target::recover-fn-from-rip-word0) (eql (core-b pc 2) target::recover-fn-from-rip-byte2)) (+ pc target::recover-fn-from-rip-length (- (core-l pc target::recover-fn-from-rip-disp-offset) #x100000000))))) (format stream "~&") (core-print process stream) (let* ((tcr (core-process-tcr process)) (vs-area (core-q tcr target::tcr.vs-area)) (vs-end (core-q vs-area target::area.high)) (valence (core-q tcr target::tcr.valence)) (fp (or origin ;; TODO: find the registers in the core file! (case valence ;; TCR_STATE_LISP (0 (let ((xp (core-q tcr target::tcr.suspend-context))) (format stream "~&") (if (eql xp 0) (format stream "Unknown lisp context, guessing frame pointer:") (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn (if (eql xp 0) (dwim-core-frame-pointer tcr) ;; uc_mcontext.gregs[rbp] (core-q xp (* 15 target::node-size))))) ;; TCR_STATE_FOREIGN (1 (format stream "~&In foreign code") ;; the save-rbp seems to include some non-lisp frames sometimes, ;; shave them down. #+no (core-q tcr target::tcr.save-rbp) (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp))) ;; TCR_STATE_EXCEPTION_WAIT (2 (let ((xp (core-q tcr target::tcr.pending-exception-context))) ;; regs start at index 5, in this order: ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z ;; rbp temp0 imm1 imm0 nargs rsp rip (format stream " exception-wait") (if (zerop xp) (format stream "~&context unknown") (let* ((fn (core-q xp (* 10 target::node-size))) (sp (core-q xp (* 20 target::node-size))) (ra (core-q sp))) (if (and (core-functionp fn) (and (<= fn ra) (< ra (+ fn (* (core-uvsize fn) target::node-size))))) (progn (format stream "~&") (core-print fn stream) (format stream " + ~d" (- ra fn))) (progn (format stream "~&top of stack = x~x, r13 = " ra) (core-print fn stream))))) (unless (zerop xp) (core-q xp (* 15 target::node-size)))))) (error "Cannot find frame pointer")))) (unless (<= (core-q vs-area target::area.low) fp vs-end) (error "frame pointer x~x is not in stack area" fp)) (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc) do (format stream "~&fp: x~x pc: x~x : " fp pc) do (cond (fun (core-print fun stream) (format stream " + ~d " (- pc fun))) ((eql pc 0) ;; exception frame (let* ((nominal-function (core-q fp target::xcf.nominal-function)) (obj (core-q fp target::xcf.containing-object))) (when (core-functionp nominal-function) (format stream "exception ") (core-print nominal-function stream) (format stream " + ~d" (if (eq (- obj target::fulltag-misc) (- nominal-function target::fulltag-function)) (- (core-q fp target::xcf.relative-pc) target::tag-function) (let ((pc (core-q fp target::xcf.ra0))) (when (eql nominal-function (recover-fn pc)) (- pc nominal-function)))))))) ((eql pc (core-q (kernel-global-address 'lexpr-return))) (format stream "lexpr return")) ((eql pc (core-q (kernel-global-address 'lexpr-return1v))) (format stream "lexpr1v return")) (t (if (eql (logand pc target::tagmask) target::tag-tra) (format stream " # couldn't recover function") (unless (core-nullp pc) (format stream "bad frame!"))) ;; can't trust backlink (return))) ;; TODO: print stack addressses do (when detailed-p (loop for val in (core-stack-frame-values tcr fp) do (format stream "~& ") do (if (integerp val) (handler-case (core-print val stream) (error () (format stream "#" val))) (format stream "~a x~x" (car val) (cadr val))))) do (setq fp (fp-backlink fp vs-end)))))) ) ; :x8664-target