;;;; -*- 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.
(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
"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"
"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"
(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))))
+
\f
;;;; interface to the rest of the compiler
(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))))
+
\f
;;;; interface to the instruction set definition
(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)
(make-code-segment code start-offset length)
(nreverse segments))))
\f
-;;; 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
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
\f
-;;; 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))))))))
-\f
;;;; 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)))
\f
projects / sbcl.git / commitdiff