- (let ((buffer (segment-buffer segment)))
- ;; Make sure that the array is big enough.
- (do ()
- ((>= (array-dimension buffer 0) new-value))
- ;; When we have to increase the size of the array, we want to
- ;; roughly double the vector length: that way growing the array
- ;; to size N conses only O(N) bytes in total. But just doubling
- ;; the length would leave a zero-length vector unchanged. Hence,
- ;; take the MAX with 1..
- (adjust-array buffer (max 1 (* 2 (array-dimension buffer 0)))))
+ (let* ((buffer (segment-buffer segment))
+ (new-buffer-size (length buffer)))
+ (declare (type (simple-array (unsigned-byte 8)) buffer)
+ (type index new-buffer-size))
+ ;; Make sure the array is big enough.
+ (when (<= new-buffer-size new-value)
+ (do ()
+ ((> new-buffer-size new-value))
+ ;; When we have to increase the size of the array, we want to
+ ;; roughly double the vector length: that way growing the array
+ ;; to size N conses only O(N) bytes in total. But just doubling
+ ;; the length would leave a zero-length vector unchanged. Hence,
+ ;; take the MAX with 1..
+ (setf new-buffer-size (max 1 (* 2 new-buffer-size))))
+ (let ((new-buffer (make-array new-buffer-size
+ :element-type '(unsigned-byte 8))))
+ (replace new-buffer buffer)
+ (setf (segment-buffer segment) new-buffer)))
- (progn
- (setf (segment-current-index ,n-segment) ,index
- (segment-current-posn ,n-segment) ,posn)
- ,@body)
- (setf (segment-current-index ,n-segment) ,old-index
- (segment-current-posn ,n-segment) ,old-posn)))))
+ (progn
+ (setf (segment-current-index ,n-segment) ,index
+ (segment-current-posn ,n-segment) ,posn)
+ ,@body)
+ (setf (segment-current-index ,n-segment) ,old-index
+ (segment-current-posn ,n-segment) ,old-posn)))))
- (end-loc (+ loc-num (or size 1))))
- ((>= index end-loc))
- (declare (type (mod 2048) index end-loc))
- (let ((writers (svref (segment-writers segment) index)))
- (when writers
- ;; The inst that wrote the value we want to read must have
- ;; completed.
- (let ((writer (car writers)))
- (sset-adjoin writer (inst-read-dependencies inst))
- (sset-adjoin inst (inst-read-dependents writer))
- (sset-delete writer (segment-emittable-insts-sset segment))
- ;; And it must have been completed *after* all other
- ;; writes to that location. Actually, that isn't quite
- ;; true. Each of the earlier writes could be done
- ;; either before this last write, or after the read, but
- ;; we have no way of representing that.
- (dolist (other-writer (cdr writers))
- (sset-adjoin other-writer (inst-write-dependencies writer))
- (sset-adjoin writer (inst-write-dependents other-writer))
- (sset-delete other-writer
- (segment-emittable-insts-sset segment))))
- ;; And we don't need to remember about earlier writes any
- ;; more. Shortening the writers list means that we won't
- ;; bother generating as many explicit arcs in the graph.
- (setf (cdr writers) nil)))
- (push inst (svref (segment-readers segment) index)))))
+ (end-loc (+ loc-num (or size 1))))
+ ((>= index end-loc))
+ (declare (type (mod 2048) index end-loc))
+ (let ((writers (svref (segment-writers segment) index)))
+ (when writers
+ ;; The inst that wrote the value we want to read must have
+ ;; completed.
+ (let ((writer (car writers)))
+ (sset-adjoin writer (inst-read-dependencies inst))
+ (sset-adjoin inst (inst-read-dependents writer))
+ (sset-delete writer (segment-emittable-insts-sset segment))
+ ;; And it must have been completed *after* all other
+ ;; writes to that location. Actually, that isn't quite
+ ;; true. Each of the earlier writes could be done
+ ;; either before this last write, or after the read, but
+ ;; we have no way of representing that.
+ (dolist (other-writer (cdr writers))
+ (sset-adjoin other-writer (inst-write-dependencies writer))
+ (sset-adjoin writer (inst-write-dependents other-writer))
+ (sset-delete other-writer
+ (segment-emittable-insts-sset segment))))
+ ;; And we don't need to remember about earlier writes any
+ ;; more. Shortening the writers list means that we won't
+ ;; bother generating as many explicit arcs in the graph.
+ (setf (cdr writers) nil)))
+ (push inst (svref (segment-readers segment) index)))))
- (end-loc (+ loc-num (or size 1))))
- ((>= index end-loc))
- (declare (type (mod 2048) index end-loc))
- ;; All previous reads of this location must have completed.
- (dolist (prev-inst (svref (segment-readers segment) index))
- (unless (eq prev-inst inst)
- (sset-adjoin prev-inst (inst-write-dependencies inst))
- (sset-adjoin inst (inst-write-dependents prev-inst))
- (sset-delete prev-inst (segment-emittable-insts-sset segment))))
- (when partially
- ;; All previous writes to the location must have completed.
- (dolist (prev-inst (svref (segment-writers segment) index))
- (sset-adjoin prev-inst (inst-write-dependencies inst))
- (sset-adjoin inst (inst-write-dependents prev-inst))
- (sset-delete prev-inst (segment-emittable-insts-sset segment)))
- ;; And we can forget about remembering them, because
- ;; depending on us is as good as depending on them.
- (setf (svref (segment-writers segment) index) nil))
- (push inst (svref (segment-writers segment) index)))))
+ (end-loc (+ loc-num (or size 1))))
+ ((>= index end-loc))
+ (declare (type (mod 2048) index end-loc))
+ ;; All previous reads of this location must have completed.
+ (dolist (prev-inst (svref (segment-readers segment) index))
+ (unless (eq prev-inst inst)
+ (sset-adjoin prev-inst (inst-write-dependencies inst))
+ (sset-adjoin inst (inst-write-dependents prev-inst))
+ (sset-delete prev-inst (segment-emittable-insts-sset segment))))
+ (when partially
+ ;; All previous writes to the location must have completed.
+ (dolist (prev-inst (svref (segment-writers segment) index))
+ (sset-adjoin prev-inst (inst-write-dependencies inst))
+ (sset-adjoin inst (inst-write-dependents prev-inst))
+ (sset-delete prev-inst (segment-emittable-insts-sset segment)))
+ ;; And we can forget about remembering them, because
+ ;; depending on us is as good as depending on them.
+ (setf (svref (segment-writers segment) index) nil))
+ (push inst (svref (segment-writers segment) index)))))
- (inst (car writer))
- (overwritten (cdr writer)))
- (when writer
- (when overwritten
- (let ((write-dependencies (inst-write-dependencies inst)))
- (dolist (other-inst overwritten)
- (sset-adjoin inst (inst-write-dependents other-inst))
- (sset-adjoin other-inst write-dependencies)
- (sset-delete other-inst emittable-insts))))
- ;; If the value is live at the end of the block, we can't flush it.
- (setf (instruction-attributep (inst-attributes inst) flushable)
- nil)))))
+ (inst (car writer))
+ (overwritten (cdr writer)))
+ (when writer
+ (when overwritten
+ (let ((write-dependencies (inst-write-dependencies inst)))
+ (dolist (other-inst overwritten)
+ (sset-adjoin inst (inst-write-dependents other-inst))
+ (sset-adjoin other-inst write-dependencies)
+ (sset-delete other-inst emittable-insts))))
+ ;; If the value is live at the end of the block, we can't flush it.
+ (setf (instruction-attributep (inst-attributes inst) flushable)
+ nil)))))
- (let ((max 0))
- (do-sset-elements (dep (inst-write-dependencies inst))
- (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
- (when (> dep-depth max)
- (setf max dep-depth))))
- (do-sset-elements (dep (inst-read-dependencies inst))
- (let ((dep-depth
- (+ (or (inst-depth dep) (grovel-inst dep))
- (inst-delay dep))))
- (when (> dep-depth max)
- (setf max dep-depth))))
- (cond ((and (sset-empty (inst-read-dependents inst))
- (instruction-attributep (inst-attributes inst)
- flushable))
- #!+sb-show-assem (format *trace-output*
- "flushing ~S~%"
- inst)
- (setf (inst-emitter inst) nil)
- (setf (inst-depth inst) max))
- (t
- (setf (inst-depth inst) max))))))
+ (let ((max 0))
+ (do-sset-elements (dep (inst-write-dependencies inst))
+ (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
+ (when (> dep-depth max)
+ (setf max dep-depth))))
+ (do-sset-elements (dep (inst-read-dependencies inst))
+ (let ((dep-depth
+ (+ (or (inst-depth dep) (grovel-inst dep))
+ (inst-delay dep))))
+ (when (> dep-depth max)
+ (setf max dep-depth))))
+ (cond ((and (sset-empty (inst-read-dependents inst))
+ (instruction-attributep (inst-attributes inst)
+ flushable))
+ #!+sb-show-assem (format *trace-output*
+ "flushing ~S~%"
+ inst)
+ (setf (inst-emitter inst) nil)
+ (setf (inst-depth inst) max))
+ (t
+ (setf (inst-depth inst) max))))))
- (let ((inst (cdr branch)))
- (dotimes (i (- (car branch) insts-from-end))
- ;; Each time through this loop we need to emit another
- ;; instruction. First, we check to see whether there is
- ;; any instruction that must be emitted before (i.e. must
- ;; come after) the branch inst. If so, emit it. Otherwise,
- ;; just pick one of the emittable insts. If there is
- ;; nothing to do, then emit a nop. ### Note: despite the
- ;; fact that this is a loop, it really won't work for
- ;; repetitions other then zero and one. For example, if
- ;; the branch has two dependents and one of them dpends on
- ;; the other, then the stuff that grabs a dependent could
- ;; easily grab the wrong one. But I don't feel like fixing
- ;; this because it doesn't matter for any of the
- ;; architectures we are using or plan on using.
- (flet ((maybe-schedule-dependent (dependents)
- (do-sset-elements (inst dependents)
- ;; If do-sset-elements enters the body, then there is a
- ;; dependent. Emit it.
- (note-resolved-dependencies segment inst)
- ;; Remove it from the emittable insts.
- (setf (segment-emittable-insts-queue segment)
- (delete inst
- (segment-emittable-insts-queue segment)
- :test #'eq))
- ;; And if it was delayed, removed it from the delayed
- ;; list. This can happen if there is a load in a
- ;; branch delay slot.
- (block scan-delayed
- (do ((delayed (segment-delayed segment)
- (cdr delayed)))
- ((null delayed))
- (do ((prev nil cons)
- (cons (car delayed) (cdr cons)))
- ((null cons))
- (when (eq (car cons) inst)
- (if prev
- (setf (cdr prev) (cdr cons))
- (setf (car delayed) (cdr cons)))
- (return-from scan-delayed nil)))))
- ;; And return it.
- (return inst))))
- (let ((fill (or (maybe-schedule-dependent
- (inst-read-dependents inst))
- (maybe-schedule-dependent
- (inst-write-dependents inst))
- (schedule-one-inst segment t)
- :nop)))
- #!+sb-show-assem (format *trace-output*
- "filling branch delay slot with ~S~%"
- fill)
- (push fill results)))
- (advance-one-inst segment)
- (incf insts-from-end))
- (note-resolved-dependencies segment inst)
- (push inst results)
- #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
- (advance-one-inst segment))))
+ (let ((inst (cdr branch)))
+ (dotimes (i (- (car branch) insts-from-end))
+ ;; Each time through this loop we need to emit another
+ ;; instruction. First, we check to see whether there is
+ ;; any instruction that must be emitted before (i.e. must
+ ;; come after) the branch inst. If so, emit it. Otherwise,
+ ;; just pick one of the emittable insts. If there is
+ ;; nothing to do, then emit a nop. ### Note: despite the
+ ;; fact that this is a loop, it really won't work for
+ ;; repetitions other then zero and one. For example, if
+ ;; the branch has two dependents and one of them dpends on
+ ;; the other, then the stuff that grabs a dependent could
+ ;; easily grab the wrong one. But I don't feel like fixing
+ ;; this because it doesn't matter for any of the
+ ;; architectures we are using or plan on using.
+ (flet ((maybe-schedule-dependent (dependents)
+ (do-sset-elements (inst dependents)
+ ;; If do-sset-elements enters the body, then there is a
+ ;; dependent. Emit it.
+ (note-resolved-dependencies segment inst)
+ ;; Remove it from the emittable insts.
+ (setf (segment-emittable-insts-queue segment)
+ (delete inst
+ (segment-emittable-insts-queue segment)
+ :test #'eq))
+ ;; And if it was delayed, removed it from the delayed
+ ;; list. This can happen if there is a load in a
+ ;; branch delay slot.
+ (block scan-delayed
+ (do ((delayed (segment-delayed segment)
+ (cdr delayed)))
+ ((null delayed))
+ (do ((prev nil cons)
+ (cons (car delayed) (cdr cons)))
+ ((null cons))
+ (when (eq (car cons) inst)
+ (if prev
+ (setf (cdr prev) (cdr cons))
+ (setf (car delayed) (cdr cons)))
+ (return-from scan-delayed nil)))))
+ ;; And return it.
+ (return inst))))
+ (let ((fill (or (maybe-schedule-dependent
+ (inst-read-dependents inst))
+ (maybe-schedule-dependent
+ (inst-write-dependents inst))
+ (schedule-one-inst segment t)
+ :nop)))
+ #!+sb-show-assem (format *trace-output*
+ "filling branch delay slot with ~S~%"
+ fill)
+ (push fill results)))
+ (advance-one-inst segment)
+ (incf insts-from-end))
+ (note-resolved-dependencies segment inst)
+ (push inst results)
+ #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
+ (advance-one-inst segment))))
- (instruction-attributep (inst-attributes inst)
- variable-length))
- ;; We've got us a live one here. Go for it.
- #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
- ;; Delete it from the list of insts.
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-emittable-insts-queue segment)
- (cdr remaining)))
- ;; Note that this inst has been emitted.
- (note-resolved-dependencies segment inst)
- ;; And return.
- (return-from schedule-one-inst
- ;; Are we wanting to flush this instruction?
- (if (inst-emitter inst)
- ;; Nope, it's still a go. So return it.
- inst
- ;; Yes, so pick a new one. We have to start
- ;; over, because note-resolved-dependencies
- ;; might have changed the emittable-insts-queue.
- (schedule-one-inst segment delay-slot-p))))))
+ (instruction-attributep (inst-attributes inst)
+ variable-length))
+ ;; We've got us a live one here. Go for it.
+ #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
+ ;; Delete it from the list of insts.
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-emittable-insts-queue segment)
+ (cdr remaining)))
+ ;; Note that this inst has been emitted.
+ (note-resolved-dependencies segment inst)
+ ;; And return.
+ (return-from schedule-one-inst
+ ;; Are we wanting to flush this instruction?
+ (if (inst-emitter inst)
+ ;; Nope, it's still a go. So return it.
+ inst
+ ;; Yes, so pick a new one. We have to start
+ ;; over, because note-resolved-dependencies
+ ;; might have changed the emittable-insts-queue.
+ (schedule-one-inst segment delay-slot-p))))))
- (let* ((dependency (car stuff))
- (dependent (cdr stuff))
- (dependents (inst-read-dependents dependency)))
- (sset-delete dependent dependents)
- (when (and (sset-empty dependents)
- (sset-empty (inst-write-dependents dependency)))
- (insert-emittable-inst segment dependency)))
- (insert-emittable-inst segment stuff)))))
+ (let* ((dependency (car stuff))
+ (dependent (cdr stuff))
+ (dependents (inst-read-dependents dependency)))
+ (sset-delete dependent dependents)
+ (when (and (sset-empty dependents)
+ (sset-empty (inst-write-dependents dependency)))
+ (insert-emittable-inst segment dependency)))
+ (insert-emittable-inst segment stuff)))))
- ;; 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))))))
- (aver (> size 0))
- (emit-annotation segment (make-alignment bits size fill-byte))
- (emit-skip segment size fill-byte))
- (setf (segment-alignment segment) bits)
- (setf (segment-sync-posn segment) (segment-current-posn segment)))
- (t
- ;; The last alignment was more restrictive then 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))
- ;; But we emit an alignment with size=0 so we can verify
- ;; that everything works.
- (emit-annotation segment (make-alignment bits 0 fill-byte)))))
+ ;; 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))))))
+ (aver (> size 0))
+ (emit-annotation segment (make-alignment bits size fill-byte))
+ (emit-skip segment size fill-byte))
+ (setf (segment-alignment segment) bits)
+ (setf (segment-sync-posn segment) (segment-current-posn segment)))
+ (t
+ ;; The last alignment was more restrictive then 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))
+ ;; But we emit an alignment with size=0 so we can verify
+ ;; that everything works.
+ (emit-annotation segment (make-alignment bits 0 fill-byte)))))
- (remaining (segment-annotations segment) next)
- (next (cdr remaining) (cdr remaining)))
- ((null remaining))
- (let* ((note (car remaining))
- (posn (annotation-posn note)))
- (unless (zerop delta)
- (decf posn delta)
- (setf (annotation-posn note) posn))
- (cond
- ((chooser-p note)
- (with-modified-segment-index-and-posn (segment (chooser-index note)
- posn)
- (setf (segment-last-annotation segment) prev)
- (cond
- ((funcall (chooser-maybe-shrink note) segment posn delta)
- ;; It emitted some replacement.
- (let ((new-size (- (segment-current-index segment)
- (chooser-index note)))
- (old-size (chooser-size note)))
- (when (> new-size old-size)
- (error "~S emitted ~W bytes, but claimed its max was ~W."
- note new-size old-size))
- (let ((additional-delta (- old-size new-size)))
- (when (< (find-alignment additional-delta)
- (chooser-alignment note))
- (error "~S shrunk by ~W bytes, but claimed that it ~
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
+ (let* ((note (car remaining))
+ (posn (annotation-posn note)))
+ (unless (zerop delta)
+ (decf posn delta)
+ (setf (annotation-posn note) posn))
+ (cond
+ ((chooser-p note)
+ (with-modified-segment-index-and-posn (segment (chooser-index note)
+ posn)
+ (setf (segment-last-annotation segment) prev)
+ (cond
+ ((funcall (chooser-maybe-shrink note) segment posn delta)
+ ;; It emitted some replacement.
+ (let ((new-size (- (segment-current-index segment)
+ (chooser-index note)))
+ (old-size (chooser-size note)))
+ (when (> new-size old-size)
+ (error "~S emitted ~W bytes, but claimed its max was ~W."
+ note new-size old-size))
+ (let ((additional-delta (- old-size new-size)))
+ (when (< (find-alignment additional-delta)
+ (chooser-alignment note))
+ (error "~S shrunk by ~W bytes, but claimed that it ~
- note additional-delta (chooser-alignment note)))
- (incf delta additional-delta)
- (emit-filler segment additional-delta))
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-annotations segment)
- (cdr remaining)))))
- (t
- ;; The chooser passed on shrinking. Make sure it didn't
- ;; emit anything.
- (unless (= (segment-current-index segment)
- (chooser-index note))
- (error "Chooser ~S passed, but not before emitting ~W bytes."
- note
- (- (segment-current-index segment)
- (chooser-index note))))
- ;; Act like we just emitted this chooser.
- (let ((size (chooser-size note)))
- (incf (segment-current-index segment) size)
- (incf (segment-current-posn segment) size))
- ;; Adjust the alignment accordingly.
- (adjust-alignment-after-chooser segment note)
- ;; And keep this chooser for next time around.
- (setf prev remaining)))))
- ((alignment-p note)
- (unless (zerop (alignment-size note))
- ;; Re-emit the alignment, letting it collapse if we know
- ;; anything more about the alignment guarantees of the
- ;; segment.
- (let ((index (alignment-index note)))
- (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))
- (let* ((new-index (segment-current-index segment))
- (size (- new-index index))
- (old-size (alignment-size note))
- (additional-delta (- old-size size)))
- (when (minusp additional-delta)
- (error "Alignment ~S needs more space now? It was ~W, ~
+ note additional-delta (chooser-alignment note)))
+ (incf delta additional-delta)
+ (emit-filler segment additional-delta))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))
+ (t
+ ;; The chooser passed on shrinking. Make sure it didn't
+ ;; emit anything.
+ (unless (= (segment-current-index segment)
+ (chooser-index note))
+ (error "Chooser ~S passed, but not before emitting ~W bytes."
+ note
+ (- (segment-current-index segment)
+ (chooser-index note))))
+ ;; Act like we just emitted this chooser.
+ (let ((size (chooser-size note)))
+ (incf (segment-current-index segment) size)
+ (incf (segment-current-posn segment) size))
+ ;; Adjust the alignment accordingly.
+ (adjust-alignment-after-chooser segment note)
+ ;; And keep this chooser for next time around.
+ (setf prev remaining)))))
+ ((alignment-p note)
+ (unless (zerop (alignment-size note))
+ ;; Re-emit the alignment, letting it collapse if we know
+ ;; anything more about the alignment guarantees of the
+ ;; segment.
+ (let ((index (alignment-index note)))
+ (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))
+ (let* ((new-index (segment-current-index segment))
+ (size (- new-index index))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (when (minusp additional-delta)
+ (error "Alignment ~S needs more space now? It was ~W, ~
- (posn (- (annotation-posn note) delta)))
- (cond
- ((alignment-p note)
- (let* ((bits (alignment-bits note))
- (mask (1- (ash 1 bits)))
- (new-posn (logand (+ posn mask) (lognot mask)))
- (size (- new-posn posn))
- (old-size (alignment-size note))
- (additional-delta (- old-size size)))
- (aver (<= 0 size old-size))
- (unless (zerop additional-delta)
- (setf (segment-last-annotation segment) prev)
- (incf delta additional-delta)
- (with-modified-segment-index-and-posn (segment
- (alignment-index note)
- posn)
- (emit-filler segment additional-delta)
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) next)
- (setf (segment-annotations segment) next))))))
- (t
- (setf (annotation-posn note) posn)
- (setf prev remaining)
- (setf next (cdr remaining))))))
+ (posn (- (annotation-posn note) delta)))
+ (cond
+ ((alignment-p note)
+ (let* ((bits (alignment-bits note))
+ (mask (1- (ash 1 bits)))
+ (new-posn (logand (+ posn mask) (lognot mask)))
+ (size (- new-posn posn))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (aver (<= 0 size old-size))
+ (unless (zerop additional-delta)
+ (setf (segment-last-annotation segment) prev)
+ (incf delta additional-delta)
+ (with-modified-segment-index-and-posn (segment
+ (alignment-index note)
+ posn)
+ (emit-filler segment additional-delta)
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) next)
+ (setf (segment-annotations segment) next))))))
+ (t
+ (setf (annotation-posn note) posn)
+ (setf prev remaining)
+ (setf next (cdr remaining))))))
- (let ((index (annotation-index note))
- (posn (annotation-posn note)))
- (with-modified-segment-index-and-posn (segment index posn)
- (setf (segment-last-annotation segment) prev)
- (funcall function segment posn)
- (let ((new-size (- (segment-current-index segment) index)))
- (unless (= new-size old-size)
- (error "~S emitted ~W bytes, but claimed it was ~W."
- note new-size old-size)))
- (let ((tail (segment-last-annotation segment)))
- (if tail
- (setf (cdr tail) next)
- (setf (segment-annotations segment) next)))
- (setf next (cdr prev))))))
- (cond ((back-patch-p note)
- (fill-in (back-patch-fun note)
- (back-patch-size note)))
- ((chooser-p note)
- (fill-in (chooser-worst-case-fun note)
- (chooser-size note)))
- (t
- (setf prev remaining)))))))
+ (let ((index (annotation-index note))
+ (posn (annotation-posn note)))
+ (with-modified-segment-index-and-posn (segment index posn)
+ (setf (segment-last-annotation segment) prev)
+ (funcall function segment posn)
+ (let ((new-size (- (segment-current-index segment) index)))
+ (unless (= new-size old-size)
+ (error "~S emitted ~W bytes, but claimed it was ~W."
+ note new-size old-size)))
+ (let ((tail (segment-last-annotation segment)))
+ (if tail
+ (setf (cdr tail) next)
+ (setf (segment-annotations segment) next)))
+ (setf next (cdr prev))))))
+ (cond ((back-patch-p note)
+ (fill-in (back-patch-fun note)
+ (back-patch-size note)))
+ ((chooser-p note)
+ (fill-in (chooser-worst-case-fun note)
+ (chooser-size note)))
+ (t
+ (setf prev remaining)))))))
- (vop-var (gensym "VOP-"))
- (visible-labels (remove-if-not #'label-name-p body))
- (inherited-labels
- (multiple-value-bind (expansion expanded)
- (macroexpand '..inherited-labels.. env)
- (if expanded expansion nil)))
- (new-labels (append labels
- (set-difference visible-labels
- inherited-labels)))
- (nested-labels (set-difference (append inherited-labels new-labels)
- visible-labels)))
+ (vop-var (gensym "VOP-"))
+ (visible-labels (remove-if-not #'label-name-p body))
+ (inherited-labels
+ (multiple-value-bind (expansion expanded)
+ (macroexpand '..inherited-labels.. env)
+ (if expanded expansion nil)))
+ (new-labels (append labels
+ (set-difference visible-labels
+ inherited-labels)))
+ (nested-labels (set-difference (append inherited-labels new-labels)
+ visible-labels)))
- ,@(mapcar (lambda (name)
- `(,name (gen-label)))
- new-labels))
- (declare (ignorable ,vop-var ,seg-var)
- ;; Must be done so that contribs and user code doing
- ;; low-level stuff don't need to worry about this.
- (disable-package-locks %%current-segment%% %%current-vop%%))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (declare (ignorable ,vop-var ,seg-var)
+ ;; Must be done so that contribs and user code doing
+ ;; low-level stuff don't need to worry about this.
+ (disable-package-locks %%current-segment%% %%current-vop%%))
+ (macrolet ((%%current-segment%% () ',seg-var)
+ (%%current-vop%% () ',vop-var))
- ,@(mapcar (lambda (name)
- `(,name (gen-label)))
- new-labels))
- (declare (ignorable ,vop-var ,seg-var))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
- (symbol-macrolet (,@(when (or inherited-labels nested-labels)
- `((..inherited-labels.. ,nested-labels))))
- ,@(mapcar (lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
- body)))))))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (declare (ignorable ,vop-var ,seg-var))
+ (macrolet ((%%current-segment%% () ',seg-var)
+ (%%current-vop%% () ',vop-var))
+ (symbol-macrolet (,@(when (or inherited-labels nested-labels)
+ `((..inherited-labels.. ,nested-labels))))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))
- (dolist (note other-annotations)
- (incf (annotation-index note) segment-current-index-0)
- (incf (annotation-posn note) segment-current-posn-0))
- ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
- ;; worth enough in efficiency to justify it? -- WHN 19990322
- (let ((last (segment-last-annotation segment)))
- (if last
- (setf (cdr last) other-annotations)
- (setf (segment-annotations segment) other-annotations)))
- (setf (segment-last-annotation segment)
- (segment-last-annotation other-segment)))))
+ (dolist (note other-annotations)
+ (incf (annotation-index note) segment-current-index-0)
+ (incf (annotation-posn note) segment-current-posn-0))
+ ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
+ ;; worth enough in efficiency to justify it? -- WHN 19990322
+ (let ((last (segment-last-annotation segment)))
+ (if last
+ (setf (cdr last) other-annotations)
+ (setf (segment-annotations segment) other-annotations)))
+ (setf (segment-last-annotation segment)
+ (segment-last-annotation other-segment)))))
- byte-spec-expr))
- (setf (ldb byte-spec overall-mask) -1)
- (arg-names arg)
- (arg-types `(type (integer ,(ash -1 (1- byte-size))
- ,(1- (ash 1 byte-size)))
- ,arg))
- (multiple-value-bind (start-byte offset)
- (floor byte-posn assembly-unit-bits)
- (let ((end-byte (floor (1- (+ byte-posn byte-size))
- assembly-unit-bits)))
- (flet ((maybe-ash (expr offset)
- (if (zerop offset)
- expr
- `(ash ,expr ,offset))))
- (declare (inline maybe-ash))
- (cond ((zerop byte-size))
- ((= start-byte end-byte)
- (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
- offset)
- (svref bytes start-byte)))
- (t
- (push (maybe-ash
- `(ldb (byte ,(- assembly-unit-bits offset) 0)
- ,arg)
- offset)
- (svref bytes start-byte))
- (do ((index (1+ start-byte) (1+ index)))
- ((>= index end-byte))
- (push
- `(ldb (byte ,assembly-unit-bits
- ,(- (* assembly-unit-bits
- (- index start-byte))
- offset))
- ,arg)
- (svref bytes index)))
- (let ((len (rem (+ byte-size offset)
- assembly-unit-bits)))
- (push
- `(ldb (byte ,(if (zerop len)
- assembly-unit-bits
- len)
- ,(- (* assembly-unit-bits
- (- end-byte start-byte))
- offset))
- ,arg)
- (svref bytes end-byte))))))))))
+ byte-spec-expr))
+ (setf (ldb byte-spec overall-mask) -1)
+ (arg-names arg)
+ (arg-types `(type (integer ,(ash -1 (1- byte-size))
+ ,(1- (ash 1 byte-size)))
+ ,arg))
+ (multiple-value-bind (start-byte offset)
+ (floor byte-posn assembly-unit-bits)
+ (let ((end-byte (floor (1- (+ byte-posn byte-size))
+ assembly-unit-bits)))
+ (flet ((maybe-ash (expr offset)
+ (if (zerop offset)
+ expr
+ `(ash ,expr ,offset))))
+ (declare (inline maybe-ash))
+ (cond ((zerop byte-size))
+ ((= start-byte end-byte)
+ (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
+ offset)
+ (svref bytes start-byte)))
+ (t
+ (push (maybe-ash
+ `(ldb (byte ,(- assembly-unit-bits offset) 0)
+ ,arg)
+ offset)
+ (svref bytes start-byte))
+ (do ((index (1+ start-byte) (1+ index)))
+ ((>= index end-byte))
+ (push
+ `(ldb (byte ,assembly-unit-bits
+ ,(- (* assembly-unit-bits
+ (- index start-byte))
+ offset))
+ ,arg)
+ (svref bytes index)))
+ (let ((len (rem (+ byte-size offset)
+ assembly-unit-bits)))
+ (push
+ `(ldb (byte ,(if (zerop len)
+ assembly-unit-bits
+ len)
+ ,(- (* assembly-unit-bits
+ (- end-byte start-byte))
+ offset))
+ ,arg)
+ (svref bytes end-byte))))))))))
- (dotimes (i num-bytes)
- (let ((pieces (svref bytes i)))
- (aver pieces)
- (push `(emit-byte ,segment-arg
- ,(if (cdr pieces)
- `(logior ,@pieces)
- (car pieces)))
- forms)))
- `(defun ,name (,segment-arg ,@(arg-names))
- (declare (type segment ,segment-arg) ,@(arg-types))
- ,@(ecase sb!c:*backend-byte-order*
- (:little-endian (nreverse forms))
- (:big-endian forms))
- ',name)))))
+ (dotimes (i num-bytes)
+ (let ((pieces (svref bytes i)))
+ (aver pieces)
+ (push `(emit-byte ,segment-arg
+ ,(if (cdr pieces)
+ `(logior ,@pieces)
+ (car pieces)))
+ forms)))
+ `(defun ,name (,segment-arg ,@(arg-names))
+ (declare (type segment ,segment-arg) ,@(arg-types))
+ ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian (nreverse forms))
+ (:big-endian forms))
+ ',name)))))
- ((grovel (state lambda-list)
- (when lambda-list
- (let ((param (car lambda-list)))
- (cond
- ((member param sb!xc:lambda-list-keywords)
- (new-lambda-list param)
- (grovel param (cdr lambda-list)))
- (t
- (ecase state
- ((nil)
- (new-lambda-list param)
- `(cons ,param ,(grovel state (cdr lambda-list))))
- (&optional
- (multiple-value-bind (name default supplied-p)
- (if (consp param)
- (values (first param)
- (second param)
- (or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
- (new-lambda-list (list name default supplied-p))
- `(and ,supplied-p
- (cons ,(if (consp name)
- (second name)
- name)
- ,(grovel state (cdr lambda-list))))))
- (&key
- (multiple-value-bind (name default supplied-p)
- (if (consp param)
- (values (first param)
- (second param)
- (or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
- (new-lambda-list (list name default supplied-p))
- (multiple-value-bind (key var)
- (if (consp name)
- (values (first name) (second name))
- (values (keywordicate name) name))
- `(append (and ,supplied-p (list ',key ,var))
- ,(grovel state (cdr lambda-list))))))
- (&rest
- (new-lambda-list param)
- (grovel state (cdr lambda-list))
- param))))))))
- (let ((reconstructor (grovel nil (cdr lambda-list))))
- (values (new-lambda-list)
- segment-name
- vop-var
- reconstructor))))))
+ ((grovel (state lambda-list)
+ (when lambda-list
+ (let ((param (car lambda-list)))
+ (cond
+ ((member param sb!xc:lambda-list-keywords)
+ (new-lambda-list param)
+ (grovel param (cdr lambda-list)))
+ (t
+ (ecase state
+ ((nil)
+ (new-lambda-list param)
+ `(cons ,param ,(grovel state (cdr lambda-list))))
+ (&optional
+ (multiple-value-bind (name default supplied-p)
+ (if (consp param)
+ (values (first param)
+ (second param)
+ (or (third param)
+ (gensym "SUPPLIED-P-")))
+ (values param nil (gensym "SUPPLIED-P-")))
+ (new-lambda-list (list name default supplied-p))
+ `(and ,supplied-p
+ (cons ,(if (consp name)
+ (second name)
+ name)
+ ,(grovel state (cdr lambda-list))))))
+ (&key
+ (multiple-value-bind (name default supplied-p)
+ (if (consp param)
+ (values (first param)
+ (second param)
+ (or (third param)
+ (gensym "SUPPLIED-P-")))
+ (values param nil (gensym "SUPPLIED-P-")))
+ (new-lambda-list (list name default supplied-p))
+ (multiple-value-bind (key var)
+ (if (consp name)
+ (values (first name) (second name))
+ (values (keywordicate name) name))
+ `(append (and ,supplied-p (list ',key ,var))
+ ,(grovel state (cdr lambda-list))))))
+ (&rest
+ (new-lambda-list param)
+ (grovel state (cdr lambda-list))
+ param))))))))
+ (let ((reconstructor (grovel nil (cdr lambda-list))))
+ (values (new-lambda-list)
+ segment-name
+ vop-var
+ reconstructor))))))
- (if (consp option-spec)
- (values (car option-spec) (cdr option-spec))
- (values option-spec nil))
- (sb!int:/noshow option args)
- (case option
- (:emitter
- (when emitter
- (error "You can only specify :EMITTER once per instruction."))
- (setf emitter args))
- (:declare
- (setf decls (append decls args)))
- (:attributes
- (setf attributes (append attributes args)))
- (:cost
- (setf cost (first args)))
- (:dependencies
- (setf dependencies (append dependencies args)))
- (:delay
- (when delay
- (error "You can only specify :DELAY once per instruction."))
- (setf delay args))
- (:pinned
- (setf pinned t))
- (:vop-var
- (if vop-var
- (error "You can only specify :VOP-VAR once per instruction.")
- (setf vop-var (car args))))
- (:printer
- (sb!int:/noshow "uniquifying :PRINTER with" args)
- (push (eval `(list (multiple-value-list
- ,(sb!disassem:gen-printer-def-forms-def-form
- name
- (format nil "~@:(~A[~A]~)" name args)
- (cdr option-spec)))))
- pdefs))
- (:printer-list
- ;; same as :PRINTER, but is EVALed first, and is a list of
- ;; printers
- (push
- (eval
- `(eval
- `(list ,@(mapcar (lambda (printer)
- `(multiple-value-list
- ,(sb!disassem:gen-printer-def-forms-def-form
- ',name
- (format nil "~@:(~A[~A]~)" ',name printer)
- printer
- nil)))
- ,(cadr option-spec)))))
- pdefs))
- (t
- (error "unknown option: ~S" option)))))
+ (if (consp option-spec)
+ (values (car option-spec) (cdr option-spec))
+ (values option-spec nil))
+ (sb!int:/noshow option args)
+ (case option
+ (:emitter
+ (when emitter
+ (error "You can only specify :EMITTER once per instruction."))
+ (setf emitter args))
+ (:declare
+ (setf decls (append decls args)))
+ (:attributes
+ (setf attributes (append attributes args)))
+ (:cost
+ (setf cost (first args)))
+ (:dependencies
+ (setf dependencies (append dependencies args)))
+ (:delay
+ (when delay
+ (error "You can only specify :DELAY once per instruction."))
+ (setf delay args))
+ (:pinned
+ (setf pinned t))
+ (:vop-var
+ (if vop-var
+ (error "You can only specify :VOP-VAR once per instruction.")
+ (setf vop-var (car args))))
+ (:printer
+ (sb!int:/noshow "uniquifying :PRINTER with" args)
+ (push (eval `(list (multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ name
+ (format nil "~@:(~A[~A]~)" name args)
+ (cdr option-spec)))))
+ pdefs))
+ (:printer-list
+ ;; same as :PRINTER, but is EVALed first, and is a list of
+ ;; printers
+ (push
+ (eval
+ `(eval
+ `(list ,@(mapcar (lambda (printer)
+ `(multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ ',name
+ (format nil "~@:(~A[~A]~)" ',name printer)
+ printer
+ nil)))
+ ,(cadr option-spec)))))
+ pdefs))
+ (t
+ (error "unknown option: ~S" option)))))
- (if pinned
- (setf emitter
- `((when (segment-run-scheduler ,segment-name)
- (schedule-pending-instructions ,segment-name))
- ,@emitter))
- (let ((flet-name
- (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
- (inst-name (gensym "INST-")))
- (setf emitter `((flet ((,flet-name (,segment-name)
- ,@emitter))
- (if (segment-run-scheduler ,segment-name)
- (let ((,inst-name
- (make-instruction
- (incf (segment-inst-number
- ,segment-name))
- #',flet-name
- (instruction-attributes
- ,@attributes)
- (progn ,@delay))))
- ,@(when dependencies
- `((note-dependencies
- (,segment-name ,inst-name)
- ,@dependencies)))
- (queue-inst ,segment-name ,inst-name))
- (,flet-name ,segment-name))))))))
+ (if pinned
+ (setf emitter
+ `((when (segment-run-scheduler ,segment-name)
+ (schedule-pending-instructions ,segment-name))
+ ,@emitter))
+ (let ((flet-name
+ (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
+ (inst-name (gensym "INST-")))
+ (setf emitter `((flet ((,flet-name (,segment-name)
+ ,@emitter))
+ (if (segment-run-scheduler ,segment-name)
+ (let ((,inst-name
+ (make-instruction
+ (incf (segment-inst-number
+ ,segment-name))
+ #',flet-name
+ (instruction-attributes
+ ,@attributes)
+ (progn ,@delay))))
+ ,@(when dependencies
+ `((note-dependencies
+ (,segment-name ,inst-name)
+ ,@dependencies)))
+ (queue-inst ,segment-name ,inst-name))
+ (,flet-name ,segment-name))))))))
- (defun ,defun-name ,new-lambda-list
- ,@(when decls
- `((declare ,@decls)))
- (let ((,postits (segment-postits ,segment-name)))
- ;; Must be done so that contribs and user code doing
- ;; low-level stuff don't need to worry about this.
- (declare (disable-package-locks %%current-segment%%))
- (setf (segment-postits ,segment-name) nil)
- (macrolet ((%%current-segment%% ()
- (error "You can't use INST without an ~
+ (defun ,defun-name ,new-lambda-list
+ ,@(when decls
+ `((declare ,@decls)))
+ (let ((,postits (segment-postits ,segment-name)))
+ ;; Must be done so that contribs and user code doing
+ ;; low-level stuff don't need to worry about this.
+ (declare (disable-package-locks %%current-segment%%))
+ (setf (segment-postits ,segment-name) nil)
+ (macrolet ((%%current-segment%% ()
+ (error "You can't use INST without an ~
- (declare (enable-package-locks %%current-segment%%))
- ,@emitter))
- (values))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (%define-instruction ,sym-name ',defun-name))
- ,@(extract-nths 1 'progn pdefs)
- ,@(when pdefs
- `((sb!disassem:install-inst-flavors
- ',name
- (append ,@(extract-nths 0 'list pdefs)))))))))
+ (declare (enable-package-locks %%current-segment%%))
+ ,@emitter))
+ (values))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%define-instruction ,sym-name ',defun-name))
+ ,@(extract-nths 1 'progn pdefs)
+ ,@(when pdefs
+ `((sb!disassem:install-inst-flavors
+ ',name
+ (append ,@(extract-nths 0 'list pdefs)))))))))