From b6f74a607b050112e3956294ebbe7ffef3c332b2 Mon Sep 17 00:00:00 2001 From: Lutz Euler Date: Tue, 19 Mar 2013 19:16:23 +0100 Subject: [PATCH] Fix printing of prefix instructions during disassembly. During disassembly of assembler segments (which happens when compiling with SB-C::*COMPILER-TRACE-OUTPUT* set) sometimes instruction prefixes like x86-64's REX would be printed wrongly. The direct cause of this was that SEGMENT-OVERFLOW didn't consider prefix instructions as belonging to the following non-prefix instruction. Instead of adding special treatment for prefix instructions there, simplify the whole operation of DISASSEMBLE-ASSEM-SEGMENT. So far this repartitioned the pieces of the segment's contents that ON-SEGMENT-CONTENTS-VECTORLY provided, while caring not to split the contents inside instructions, which needed a sizable amount of code. Now the segment's contents are simply collected into a single vector which is disassembled as a whole. Fixes lp#1085729. --- package-data-list.lisp-expr | 6 +- src/compiler/assem.lisp | 14 ++++ src/compiler/target-disassem.lisp | 133 ++----------------------------------- 3 files changed, 24 insertions(+), 129 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 00c4dec..0b8c809 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -140,7 +140,8 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "MAKE-SEGMENT" "SEGMENT-TYPE" "ASSEMBLE" "INST" "LABEL" "LABEL-P" "GEN-LABEL" "EMIT-LABEL" "LABEL-POSITION" "APPEND-SEGMENT" "FINALIZE-SEGMENT" - "ON-SEGMENT-CONTENTS-VECTORLY" "WRITE-SEGMENT-CONTENTS" + "ON-SEGMENT-CONTENTS-VECTORLY" "SEGMENT-CONTENTS-AS-VECTOR" + "WRITE-SEGMENT-CONTENTS" "READS" "WRITES" "SEGMENT" "WITHOUT-SCHEDULING" "VARIABLE-LENGTH" @@ -520,8 +521,7 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*." "DEFINE-ARG-TYPE" "GEN-ARG-TYPE-DEF-FORM" "READ-SIGNED-SUFFIX" "ADD-OFFS-HOOK" "MAKE-MEMORY-SEGMENT" "GEN-PREAMBLE-FORM" - "MAKE-SEGMENT" "SEGMENT-OVERFLOW" - "SEG-VIRTUAL-LOCATION" "MAKE-DECODED-INST" + "MAKE-SEGMENT" "SEG-VIRTUAL-LOCATION" "MAKE-DECODED-INST" "DCHUNK" "*DEFAULT-DSTATE-HOOKS*" "MAKE-CODE-SEGMENT" "MAKE-OFFS-HOOK" "DSTATE-SEGMENT" "DSTATE-CUR-OFFS" diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index dfb1275..b5c2549 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1357,6 +1357,20 @@ (defun on-segment-contents-vectorly (segment function) (frob i0 (segment-final-index segment)))) (values)) +;;; Return the contents of SEGMENT as a freshly consed vector. +(defun segment-contents-as-vector (segment) + (let ((vector (make-array (segment-final-posn segment) + :element-type 'assembly-unit)) + (index 0)) + (declare (type index index)) + (on-segment-contents-vectorly + segment + (lambda (v) + (declare (type (simple-array assembly-unit 1) v)) + (setf (subseq vector index) v) + (incf index (length v)))) + vector)) + ;;; Write the code accumulated in SEGMENT to STREAM, and return the ;;; number of bytes written. (defun write-segment-contents (segment stream) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index dc23874..d078c87 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1365,23 +1365,6 @@ (defun get-code-segments (code (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 @@ (defun disassemble-code-component (code-component &key (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))) -- 1.7.4.1