(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) pattern)))
- (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 pattern))
(emit-skip segment size pattern))
(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