From 51bc001b7a98af096af782a672389e51004af068 Mon Sep 17 00:00:00 2001 From: Lutz Euler Date: Thu, 6 Jun 2013 16:26:30 +0200 Subject: [PATCH] Simplify getting the contents of assembler segments. Extend FINALIZE-SEGMENT to compact the segment's buffer and provide an exported function to get at this buffer. This resolves an old KLUDGE noted at ON-SEGMENT-CONTENTS-VECTORLY, making this function unnecessary. There are several benefits to this change: First, the consumers of assembler segment's contents, like WRITE-SEGMENT-CONTENTS which is used for example during FASL dumping, or MAKE-CORE-COMPONENT, now call WRITE-SEQUENCE respectively COPY-BYTE-VECTOR-TO-SYSTEM-AREA only once per segment and not once per the pieces of the segment's contents that ON-SEGMENT-CONTENTS-VECTORLY provided, which makes for less overhead. Second, this allows to greatly simplify the whole operation of DISASSEMBLE-ASSEM-SEGMENT, in the course deleting several helpers of it. So far this repartitioned the pieces of the segment's contents from ON-SEGMENT-CONTENTS-VECTORLY, while caring not to split the contents inside instructions, which needed a sizable amount of code. Now the segment's contents are simply disassembled as a whole. Also, the old code (specifically SEGMENT-OVERFLOW) didn't take prefix instructions into account correctly which surfaced as the bug in lp#1085729. Fixes lp#1085729. Also, fix an unrelated typo in NEWS. --- NEWS | 5 +- package-data-list.lisp-expr | 8 +- src/compiler/assem.lisp | 78 +++++++++---------- src/compiler/generic/target-core.lisp | 10 +-- src/compiler/target-disassem.lisp | 133 ++------------------------------- 5 files changed, 59 insertions(+), 175 deletions(-) diff --git a/NEWS b/NEWS index ffeca18..1390418 100644 --- a/NEWS +++ b/NEWS @@ -1,6 +1,6 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.1.8: - * enchancement: disassemble now annotates some previously missing static + * enhancement: disassemble now annotates some previously missing static functions, like LENGTH. * optimization: calls to static functions on x86-64 use less instructions. * optimization: compute encode-universal-time at compile time when possible. @@ -18,6 +18,9 @@ changes relative to sbcl-1.1.8: (lp#1184586) * bug fix: tests for sb-bsd-sockets no longer use a predefined port for listening, allowing several tests to run in parallel. + * bug fix: during disassembly to *COMPILER-TRACE-OUTPUT* instruction + prefixes as used on x86 and x86-64 no longer sometimes print incorrectly. + (lp#1085729) changes in sbcl-1.1.8 relative to sbcl-1.1.7: * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 5cd38ac..f769209 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -142,8 +142,9 @@ 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" + "EMIT-LABEL" "LABEL-POSITION" "APPEND-SEGMENT" + "FINALIZE-SEGMENT" + "SEGMENT-CONTENTS-AS-VECTOR" "WRITE-SEGMENT-CONTENTS" "READS" "WRITES" "SEGMENT" "WITHOUT-SCHEDULING" "VARIABLE-LENGTH" @@ -513,8 +514,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-SEGMENT" "SEG-VIRTUAL-LOCATION" "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..d052886 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1119,6 +1119,33 @@ (chooser-size note))) (t (setf prev remaining))))))) + +;;; Replace the SEGMENT-BUFFER of SEGMENT with a vector that contains +;;; only the valid content of the original buffer, that is, the parts +;;; not covered by fillers. Set FINAL-INDEX of SEGMENT to the length +;;; of the new vector and return this length. +(defun compact-segment-buffer (segment) + (let ((buffer (segment-buffer segment)) + (new-buffer (make-array (segment-final-posn segment) + :element-type 'assembly-unit)) + (i0 0) + (index 0)) + (declare (type (simple-array assembly-unit 1) buffer) + (type index index)) + (flet ((frob (i0 i1) + (when (< i0 i1) + (replace new-buffer buffer :start1 index :start2 i0 :end2 i1) + (incf index (- i1 i0))))) + (dolist (note (segment-annotations segment)) + (when (filler-p note) + (let ((i1 (filler-index note))) + (frob i0 i1) + (setf i0 (+ i1 (filler-bytes note)))))) + (frob i0 (segment-final-index segment))) + (aver (= index (segment-final-posn segment))) + (setf (segment-buffer segment) new-buffer) + (setf (segment-final-index segment) (segment-final-posn segment)))) + ;;;; interface to the rest of the compiler @@ -1326,48 +1353,23 @@ (compress-output segment) (finalize-positions segment) (process-back-patches segment) - (segment-final-posn segment)) + (compact-segment-buffer segment)) -;;; Call FUNCTION on all the stuff accumulated in SEGMENT. FUNCTION -;;; should accept a single vector argument. It will be called zero or -;;; more times on vectors of the appropriate byte type. The -;;; concatenation of the vector arguments from all the calls is the -;;; contents of SEGMENT. -;;; -;;; KLUDGE: This implementation is sort of slow and gross, calling -;;; FUNCTION repeatedly and consing a fresh vector for its argument -;;; each time. It might be possible to make a more efficient version -;;; by making FINALIZE-SEGMENT do all the compacting currently done by -;;; this function: then this function could become trivial and fast, -;;; calling FUNCTION once on the entire compacted segment buffer. -- -;;; WHN 19990322 -(defun on-segment-contents-vectorly (segment function) - (declare (type function function)) - (let ((buffer (segment-buffer segment)) - (i0 0)) - (declare (type (simple-array (unsigned-byte 8)) buffer)) - (flet ((frob (i0 i1) - (when (< i0 i1) - (funcall function (subseq buffer i0 i1))))) - (dolist (note (segment-annotations segment)) - (when (filler-p note) - (let ((i1 (filler-index note))) - (frob i0 i1) - (setf i0 (+ i1 (filler-bytes note)))))) - (frob i0 (segment-final-index segment)))) - (values)) +;;; Return the contents of SEGMENT as a vector. We assume SEGMENT has +;;; been finalized so that we can simply return its buffer. +(defun segment-contents-as-vector (segment) + (declare (type segment segment)) + (aver (= (segment-final-index segment) (segment-final-posn segment))) + (segment-buffer segment)) ;;; Write the code accumulated in SEGMENT to STREAM, and return the -;;; number of bytes written. +;;; number of bytes written. We assume that SEGMENT has been finalized. (defun write-segment-contents (segment stream) - (let ((result 0)) - (declare (type index result)) - (on-segment-contents-vectorly segment - (lambda (v) - (declare (type (vector assembly-unit) v)) - (incf result (length v)) - (write-sequence v stream))) - result)) + (declare (type segment segment)) + (let ((v (segment-contents-as-vector segment))) + (declare (type (simple-array assembly-unit 1) v)) + (length (write-sequence v stream)))) + ;;;; interface to the instruction set definition diff --git a/src/compiler/generic/target-core.lisp b/src/compiler/generic/target-core.lisp index 3174ae5..92197e2 100644 --- a/src/compiler/generic/target-core.lisp +++ b/src/compiler/generic/target-core.lisp @@ -66,12 +66,10 @@ (fill-ptr (code-instructions code-obj))) (declare (type index box-num total-length)) - (sb!assem:on-segment-contents-vectorly - segment - (lambda (v) - (declare (type (simple-array sb!assem:assembly-unit 1) v)) - (copy-byte-vector-to-system-area v fill-ptr) - (setf fill-ptr (sap+ fill-ptr (length v))))) + (let ((v (sb!assem:segment-contents-as-vector segment))) + (declare (type (simple-array sb!assem:assembly-unit 1) v)) + (copy-byte-vector-to-system-area v fill-ptr) + (setf fill-ptr (sap+ fill-ptr (length v)))) (do-core-fixups code-obj fixup-notes) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index aeaa79e..0caa4a2 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))) -- 1.7.10.4