X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftarget-disassem.lisp;h=0603947086d132d28fa77448390f333a6e0d46ed;hb=5f891793819e3cd714c443c9a0a7223b4fb13dd0;hp=623b27a593af6c6ee31c56792a53c0216a9881ad;hpb=044fd6468eace7c9bb1404d35b820cea413f64b3;p=sbcl.git diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 623b27a..0603947 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1365,23 +1365,6 @@ (make-code-segment code start-offset length) (nreverse segments)))) -;;; Return two values: the amount by which the last instruction in the -;;; segment goes past the end of the segment, and the offset of the -;;; end of the segment from the beginning of that instruction. If all -;;; instructions fit perfectly, return 0 and 0. -(defun segment-overflow (segment dstate) - (declare (type segment segment) - (type disassem-state dstate)) - (let ((seglen (seg-length segment)) - (last-start 0)) - (map-segment-instructions (lambda (chunk inst) - (declare (ignore chunk inst)) - (setf last-start (dstate-cur-offs dstate))) - segment - dstate) - (values (- (dstate-cur-offs dstate) seglen) - (- seglen last-start)))) - ;;; Compute labels for all the memory segments in SEGLIST and adds ;;; them to DSTATE. It's important to call this function with all the ;;; segments you're interested in, so that it can find references from @@ -1560,123 +1543,21 @@ (label-segments segments dstate)) (disassemble-segments segments stream dstate))) -;;; code for making useful segments from arbitrary lists of code-blocks - -;;; the maximum size of an instruction. Note that this includes -;;; pseudo-instructions like error traps with their associated -;;; operands, so it should be big enough to include them, i.e. it's -;;; not just 4 on a risc machine! -(defconstant max-instruction-size 16) - -(defun add-block-segments (seg-code-block - seglist - location - connecting-vec - dstate) - (declare (type list seglist) - (type integer location) - (type (or null (vector (unsigned-byte 8))) connecting-vec) - (type disassem-state dstate)) - (flet ((addit (seg overflow) - (let ((length (+ (seg-length seg) overflow))) - (when (> length 0) - (setf (seg-length seg) length) - (incf location length) - (push seg seglist))))) - (let ((connecting-overflow 0) - (amount (length seg-code-block))) - (when connecting-vec - ;; Tack on some of the new block to the old overflow vector. - (let* ((beginning-of-block-amount - (if seg-code-block (min max-instruction-size amount) 0)) - (connecting-vec - (if seg-code-block - (concatenate - '(vector (unsigned-byte 8)) - connecting-vec - (subseq seg-code-block 0 beginning-of-block-amount)) - connecting-vec))) - (when (and (< (length connecting-vec) max-instruction-size) - (not (null seg-code-block))) - (return-from add-block-segments - ;; We want connecting vectors to be large enough to hold - ;; any instruction, and since the current seg-code-block - ;; wasn't large enough to do this (and is now entirely - ;; on the end of the overflow-vector), just save it for - ;; next time. - (values seglist location connecting-vec))) - (when (> (length connecting-vec) 0) - (let ((seg - (make-vector-segment connecting-vec - 0 - (- (length connecting-vec) - beginning-of-block-amount) - :virtual-location location))) - (setf connecting-overflow (segment-overflow seg dstate)) - (addit seg connecting-overflow))))) - (cond ((null seg-code-block) - ;; nothing more to add - (values seglist location nil)) - ((< (- amount connecting-overflow) max-instruction-size) - ;; We can't create a segment with the minimum size - ;; required for an instruction, so just keep on accumulating - ;; in the overflow vector for the time-being. - (values seglist - location - (subseq seg-code-block connecting-overflow amount))) - (t - ;; Put as much as we can into a new segment, and the rest - ;; into the overflow-vector. - (let* ((initial-length - (- amount connecting-overflow max-instruction-size)) - (seg - (make-vector-segment seg-code-block - connecting-overflow - initial-length - :virtual-location location)) - (overflow - (segment-overflow seg dstate))) - (addit seg overflow) - (values seglist - location - (subseq seg-code-block - (+ connecting-overflow (seg-length seg)) - amount)))))))) - ;;;; code to disassemble assembler segments -(defun assem-segment-to-disassem-segments (assem-segment dstate) - (declare (type sb!assem:segment assem-segment) - (type disassem-state dstate)) - (let ((location 0) - (disassem-segments nil) - (connecting-vec nil)) - (sb!assem:on-segment-contents-vectorly - assem-segment - (lambda (seg-code-block) - (multiple-value-setq (disassem-segments location connecting-vec) - (add-block-segments seg-code-block - disassem-segments - location - connecting-vec - dstate)))) - (when connecting-vec - (setf disassem-segments - (add-block-segments nil - disassem-segments - location - connecting-vec - dstate))) - (sort disassem-segments #'< :key #'seg-virtual-location))) +(defun assem-segment-to-disassem-segment (assem-segment) + (declare (type sb!assem:segment assem-segment)) + (let ((contents (sb!assem:segment-contents-as-vector assem-segment))) + (make-vector-segment contents 0 (length contents) :virtual-location 0))) ;;; Disassemble the machine code instructions associated with ;;; ASSEM-SEGMENT (of type assem:segment). (defun disassemble-assem-segment (assem-segment stream) (declare (type sb!assem:segment assem-segment) (type stream stream)) - (let* ((dstate (make-dstate)) - (disassem-segments - (assem-segment-to-disassem-segments assem-segment dstate))) + (let ((dstate (make-dstate)) + (disassem-segments + (list (assem-segment-to-disassem-segment assem-segment)))) (label-segments disassem-segments dstate) (disassemble-segments disassem-segments stream dstate))) @@ -1792,9 +1673,20 @@ (when (null *assembler-routines-by-addr*) (setf *assembler-routines-by-addr* (invert-address-hash sb!fasl:*assembler-routines*)) + #!-sb-dynamic-core (setf *assembler-routines-by-addr* (invert-address-hash sb!sys:*static-foreign-symbols* - *assembler-routines-by-addr*))) + *assembler-routines-by-addr*)) + (loop for static in sb!vm:*static-funs* + for address = (+ sb!vm::nil-value + (sb!vm::static-fun-offset static)) + do + (setf (gethash address *assembler-routines-by-addr*) + static)) + ;; Not really a routine, but it uses the similar logic for annotations + #!+sb-safepoint + (setf (gethash sb!vm::gc-safepoint-page-addr *assembler-routines-by-addr*) + "safepoint")) (gethash address *assembler-routines-by-addr*)) ;;;; some handy function for machine-dependent code to use... @@ -2002,7 +1894,7 @@ (car (svref sb!c:*backend-internal-errors* errnum))) (defun get-sc-name (sc-offs) - (sb!c::location-print-name + (sb!c:location-print-name ;; FIXME: This seems like an awful lot of computation just to get a name. ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons ;; up a new object?