#!+sb-dyncount
(collect-dynamic-statistics nil))
(sb!c::defprinter (segment)
- name)
+ type)
(declaim (inline segment-current-index))
(defun segment-current-index (segment)
(def!struct (alignment-note (:include annotation)
(:conc-name alignment-)
(:predicate alignment-p)
- (:constructor make-alignment (bits size fill-byte))
+ (:constructor make-alignment (bits size pattern))
(:copier nil))
;; the minimum number of low-order bits that must be zero
(bits 0 :type alignment)
;; the amount of filler we are assuming this alignment op will take
(size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))
- ;; the byte used as filling
- (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
+ ;; the byte used as filling or :LONG-NOP, indicating to call EMIT-LONG-NOP
+ ;; to emit a filling pattern
+ (pattern 0 :type (or possibly-signed-assembly-unit
+ (member :long-nop))))
;;; a reference to someplace that needs to be back-patched when
;;; we actually know what label positions, etc. are
(incf (segment-current-posn segment))
(values))
-;;; interface: Output AMOUNT copies of FILL-BYTE to SEGMENT.
-(defun emit-skip (segment amount &optional (fill-byte 0))
+;;; interface: Output AMOUNT bytes to SEGMENT, either copies of
+;;; PATTERN (if that is an integer), or by calling EMIT-LONG-NOP
+;;; (if PATTERN is :LONG-NOP).
+(defun emit-skip (segment amount &optional (pattern 0))
(declare (type segment segment)
(type index amount))
- (dotimes (i amount)
- (emit-byte segment fill-byte))
+ (etypecase pattern
+ (integer
+ (dotimes (i amount)
+ (emit-byte segment pattern)))
+ ((eql :long-nop)
+ (sb!vm:emit-long-nop segment amount)))
(values))
;;; This is used to handle the common parts of annotation emission. We
;;; This is used internally whenever a chooser or alignment decides it
;;; doesn't need as much space as it originally thought.
+;;; This function used to extend an existing filler instead of creating
+;;; a new one when the previous segment annotation was a filler. Now
+;;; this is only done if the previous filler is immediately adjacent
+;;; to the new one in the segment, too. To see why this restriction is
+;;; necessary, consider a jump followed by an alignment made of
+;;; multi-byte NOPs when both are shrunk: The shortened alignment is
+;;; reemitted at its original _start_ position but the joined filler
+;;; would extend over this position and instead leave a subsequence of
+;;; the segment up to the alignment's original _end_ position visible.
(defun emit-filler (segment n-bytes)
(declare (type index n-bytes))
(let ((last (segment-last-annotation segment)))
- (cond ((and last (filler-p (car last)))
+ (cond ((and last
+ (filler-p (car last))
+ (= (+ (filler-index (car last))
+ (filler-bytes (car last)))
+ (segment-current-index segment)))
(incf (filler-bytes (car last)) n-bytes))
(t
(emit-annotation segment (make-filler n-bytes)))))
;;; see if we can guarantee the alignment restriction by just outputting a
;;; fixed number of bytes. If so, we do so. Otherwise, we create and emit an
;;; alignment note.
-(defun %emit-alignment (segment vop bits &optional (fill-byte 0))
+(defun %emit-alignment (segment vop bits &optional (pattern 0))
(when (segment-run-scheduler segment)
(schedule-pending-instructions segment))
(let ((hook (segment-inst-hook segment)))
(offset (- (segment-current-posn segment)
(segment-sync-posn segment))))
(cond ((> bits alignment)
- ;; We need more bits of alignment. First emit enough noise
- ;; to get back in sync with alignment, and then emit an
- ;; alignment note to cover the rest.
- (let ((slop (logand offset (1- (ash 1 alignment)))))
- (unless (zerop slop)
- (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
- (let ((size (logand (1- (ash 1 bits))
- (lognot (1- (ash 1 alignment))))))
+ ;; We need more bits of alignment. Emit an alignment note.
+ ;; The ALIGNMENT many least significant bits of (- OFFSET)
+ ;; give the amount of bytes to skip to get back in sync with
+ ;; ALIGNMENT, and one-bits to the left of that up to position
+ ;; BITS provide the remaining amount.
+ (let ((size (deposit-field (- offset)
+ (byte 0 alignment)
+ (1- (ash 1 bits)))))
(aver (> size 0))
- (emit-annotation segment (make-alignment bits size fill-byte))
- (emit-skip segment size fill-byte))
+ (emit-annotation segment (make-alignment bits size pattern))
+ (emit-skip segment size pattern))
(setf (segment-alignment segment) bits)
(setf (segment-sync-posn segment) (segment-current-posn segment)))
(t
- ;; The last alignment was more restrictive then this one.
+ ;; The last alignment was more restrictive than this one.
;; So we can just figure out how much noise to emit
;; assuming the last alignment was met.
(let* ((mask (1- (ash 1 bits)))
(new-offset (logand (+ offset mask) (lognot mask))))
- (emit-skip segment (- new-offset offset) fill-byte))
+ (emit-skip segment (- new-offset offset) pattern))
;; But we emit an alignment with size=0 so we can verify
;; that everything works.
- (emit-annotation segment (make-alignment bits 0 fill-byte)))))
+ (emit-annotation segment (make-alignment bits 0 pattern)))))
(values))
;;; This is used to find how ``aligned'' different offsets are.
(with-modified-segment-index-and-posn (segment index posn)
(setf (segment-last-annotation segment) prev)
(%emit-alignment segment nil (alignment-bits note)
- (alignment-fill-byte note))
+ (alignment-pattern note))
(let* ((new-index (segment-current-index segment))
(size (- new-index index))
(old-size (alignment-size note))
(with-modified-segment-index-and-posn (segment
(alignment-index note)
posn)
+ (when (eql (alignment-pattern note) :long-nop)
+ ;; We need to re-emit the alignment because a shorter
+ ;; multi-byte NOP pattern is most of the time not a
+ ;; prefix of a longer one.
+ (emit-skip segment size (alignment-pattern note)))
(emit-filler segment additional-delta)
(setf prev (segment-last-annotation segment))
(if prev
(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
body)))))))))
(def sb!int:def!macro macroexpand)
#+sb-xc-host
- (def sb!xc:defmacro sb!xc:macroexpand))
+ (def sb!xc:defmacro %macroexpand))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
;;; ordinary function.
-(defmacro emit-alignment (bits &optional (fill-byte 0))
+(defmacro emit-alignment (bits &optional (pattern 0))
#!+sb-doc
"Emit an alignment restriction to the current segment."
- `(%emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
+ `(%emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,pattern))
(defun label-position (label &optional if-after delta)
#!+sb-doc
(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
projects / sbcl.git / blobdiff