;;;; files for more information.
(in-package "SB!ASSEM")
-
-(sb!int:file-comment
- "$Header$")
\f
;;;; assembly control parameters
;;;; the SEGMENT structure
;;; This structure holds the state of the assembler.
-(defstruct segment
+(defstruct (segment (:copier nil))
;; the name of this segment (for debugging output and stuff)
- (name "Unnamed" :type simple-base-string)
- ;; Ordinarily this is a vector where instructions are written. If the segment
- ;; is made invalid (e.g. by APPEND-SEGMENT) then the vector can be
- ;; replaced by NIL.
+ (name "unnamed" :type simple-base-string)
+ ;; Ordinarily this is a vector where instructions are written. If
+ ;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the
+ ;; vector can be replaced by NIL.
(buffer (make-array 0
:fill-pointer 0
:adjustable t
:element-type 'assembly-unit)
:type (or null (vector assembly-unit)))
- ;; whether or not to run the scheduler. Note: if the instruction definitions
- ;; were not compiled with the scheduler turned on, this has no effect.
+ ;; whether or not to run the scheduler. Note: if the instruction
+ ;; definitions were not compiled with the scheduler turned on, this
+ ;; has no effect.
(run-scheduler nil)
- ;; If a function, then this is funcalled for each inst emitted with the
- ;; segment, the VOP, the name of the inst (as a string), and the inst
- ;; arguments.
+ ;; If a function, then this is funcalled for each inst emitted with
+ ;; the segment, the VOP, the name of the inst (as a string), and the
+ ;; inst arguments.
(inst-hook nil :type (or function null))
- ;; what position does this correspond to? Initially, positions and indexes
- ;; are the same, but after we start collapsing choosers, positions can change
- ;; while indexes stay the same.
- (current-posn 0 :type posn)
+ ;; what position does this correspond to? Initially, positions and
+ ;; indexes are the same, but after we start collapsing choosers,
+ ;; positions can change while indexes stay the same.
+ (current-posn 0 :type index)
;; a list of all the annotations that have been output to this segment
(annotations nil :type list)
;; a pointer to the last cons cell in the annotations list. This is
;; the number of bits of alignment at the last time we synchronized
(alignment max-alignment :type alignment)
;; the position the last time we synchronized
- (sync-posn 0 :type posn)
- ;; The posn and index everything ends at. This is not maintained while the
- ;; data is being generated, but is filled in after. Basically, we copy
- ;; current-posn and current-index so that we can trash them while processing
- ;; choosers and back-patches.
- (final-posn 0 :type posn)
+ (sync-posn 0 :type index)
+ ;; The posn and index everything ends at. This is not maintained
+ ;; while the data is being generated, but is filled in after.
+ ;; Basically, we copy CURRENT-POSN and CURRENT-INDEX so that we can
+ ;; trash them while processing choosers and back-patches.
+ (final-posn 0 :type index)
(final-index 0 :type index)
;; *** State used by the scheduler during instruction queueing.
;;
:type simple-vector)
(writers (make-array *assem-max-locations* :initial-element nil)
:type simple-vector)
- ;; The number of additional cycles before the next control transfer, or NIL
- ;; if a control transfer hasn't been queued. When a delayed branch is
- ;; queued, this slot is set to the delay count.
+ ;; The number of additional cycles before the next control transfer,
+ ;; or NIL if a control transfer hasn't been queued. When a delayed
+ ;; branch is queued, this slot is set to the delay count.
(branch-countdown nil :type (or null (and fixnum unsigned-byte)))
;; *** These two slots are used both by the queuing noise and the
;; scheduling noise.
;;
- ;; All the instructions that are pending and don't have any unresolved
- ;; dependents. We don't list branches here even if they would otherwise
- ;; qualify. They are listed above.
+ ;; All the instructions that are pending and don't have any
+ ;; unresolved dependents. We don't list branches here even if they
+ ;; would otherwise qualify. They are listed above.
(emittable-insts-sset (make-sset) :type sset)
- ;; list of queued branches. We handle these specially, because they have to
- ;; be emitted at a specific place (e.g. one slot before the end of the
- ;; block).
+ ;; list of queued branches. We handle these specially, because they
+ ;; have to be emitted at a specific place (e.g. one slot before the
+ ;; end of the block).
(queued-branches nil :type list)
- ;; *** state used by the scheduler during instruction scheduling.
+ ;; *** state used by the scheduler during instruction scheduling
;;
- ;; the instructions who would have had a read dependent removed if it were
- ;; not for a delay slot. This is a list of lists. Each element in the
- ;; top level list corresponds to yet another cycle of delay. Each element
- ;; in the second level lists is a dotted pair, holding the dependency
- ;; instruction and the dependent to remove.
+ ;; the instructions who would have had a read dependent removed if
+ ;; it were not for a delay slot. This is a list of lists. Each
+ ;; element in the top level list corresponds to yet another cycle of
+ ;; delay. Each element in the second level lists is a dotted pair,
+ ;; holding the dependency instruction and the dependent to remove.
(delayed nil :type list)
;; The emittable insts again, except this time as a list sorted by depth.
(emittable-insts-queue nil :type list)
(defun segment-current-index (segment)
(fill-pointer (segment-buffer segment)))
(defun (setf segment-current-index) (new-value segment)
+ ;; FIXME: It would be lovely to enforce this, but first FILL-IN will
+ ;; need to be convinced to stop rolling SEGMENT-CURRENT-INDEX
+ ;; backwards.
+ ;;
+ ;; Enforce an observed regularity which makes it easier to think
+ ;; about what's going on in the (legacy) code: The segment never
+ ;; shrinks. -- WHN the reverse engineer
+ #+nil (aver (>= new-value (segment-current-index segment)))
(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..
+ ;; 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)))))
;; Now that the array has the intended next free byte, we can point to it.
(setf (fill-pointer buffer) new-value)))
+
+
+;;; Various functions (like BACK-PATCH-FUN or CHOOSER-WORST-CASE-FUN)
+;;; aren't cleanly parameterized, but instead use
+;;; SEGMENT-CURRENT-INDEX and/or SEGMENT-CURRENT-POSN as global
+;;; variables. So code which calls such functions needs to modify
+;;; SEGMENT-CURRENT-INDEX and SEGMENT-CURRENT-POSN. This is left over
+;;; from the old new-assem.lisp C-style code, and so all the
+;;; destruction happens to be done after other uses of these slots are
+;;; done and things basically work. However, (1) it's fundamentally
+;;; nasty, and (2) at least one thing doesn't work right: OpenMCL
+;;; properly points out that SUBSEQ's indices aren't supposed to
+;;; exceed its logical LENGTH, i.e. its FILL-POINTER, i.e.
+;;; SEGMENT-CURRENT-INDEX.
+;;;
+;;; As a quick fix involving minimal modification of legacy code,
+;;; we do such sets of SEGMENT-CURRENT-INDEX and SEGMENT-CURRENT-POSN
+;;; using this macro, which restores 'em afterwards.
+;;;
+;;; FIXME: It'd probably be better to cleanly parameterize things like
+;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
+(defmacro with-modified-segment-index-and-posn ((segment index posn)
+ &body body)
+ (with-unique-names (n-segment old-index old-posn)
+ `(let* ((,n-segment ,segment)
+ (,old-index (segment-current-index ,n-segment))
+ (,old-posn (segment-current-posn ,n-segment)))
+ (unwind-protect
+ (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)))))
\f
;;;; structures/types used by the scheduler
-(sb!c:def-boolean-attribute instruction
- ;; This attribute is set if the scheduler can freely flush this instruction
- ;; if it thinks it is not needed. Examples are NOP and instructions that
- ;; have no side effect not described by the writes.
+(!def-boolean-attribute instruction
+ ;; This attribute is set if the scheduler can freely flush this
+ ;; instruction if it thinks it is not needed. Examples are NOP and
+ ;; instructions that have no side effect not described by the
+ ;; writes.
flushable
- ;; This attribute is set when an instruction can cause a control transfer.
- ;; For test instructions, the delay is used to determine how many
- ;; instructions follow the branch.
+ ;; This attribute is set when an instruction can cause a control
+ ;; transfer. For test instructions, the delay is used to determine
+ ;; how many instructions follow the branch.
branch
- ;; This attribute indicates that this ``instruction'' can be variable length,
- ;; and therefore better never be used in a branch delay slot.
+ ;; This attribute indicates that this ``instruction'' can be
+ ;; variable length, and therefore had better never be used in a
+ ;; branch delay slot.
variable-length)
(defstruct (instruction
(:include sset-element)
(:conc-name inst-)
- (:constructor make-instruction (number emitter attributes delay)))
+ (:constructor make-instruction (number emitter attributes delay))
+ (:copier nil))
;; The function to envoke to actually emit this instruction. Gets called
;; with the segment as its one argument.
- (emitter (required-argument) :type (or null function))
+ (emitter (missing-arg) :type (or null function))
;; The attributes of this instruction.
(attributes (instruction-attributes) :type sb!c:attributes)
- ;; Number of instructions or cycles of delay before additional instructions
- ;; can read our writes.
+ ;; Number of instructions or cycles of delay before additional
+ ;; instructions can read our writes.
(delay 0 :type (and fixnum unsigned-byte))
- ;; the maximum number of instructions in the longest dependency chain from
- ;; this instruction to one of the independent instructions. This is used
- ;; as a heuristic at to which instructions should be scheduled first.
+ ;; the maximum number of instructions in the longest dependency
+ ;; chain from this instruction to one of the independent
+ ;; instructions. This is used as a heuristic at to which
+ ;; instructions should be scheduled first.
(depth nil :type (or null (and fixnum unsigned-byte)))
- ;; ** When trying remember which of the next four is which, note that the
- ;; ``read'' or ``write'' always refers to the dependent (second)
- ;; instruction.
+ ;; Note: When trying remember which of the next four is which, note
+ ;; that the ``read'' or ``write'' always refers to the dependent
+ ;; (second) instruction.
;;
;; instructions whose writes this instruction tries to read
(read-dependencies (make-sset) :type sset)
name)
'<flushed>)))
(when (inst-depth inst)
- (format stream ", depth=~D" (inst-depth inst)))))
+ (format stream ", depth=~W" (inst-depth inst)))))
#!+sb-show-assem
(defun reset-inst-ids ()
\f
;;;; the scheduler itself
-(defmacro without-scheduling ((&optional (segment '**current-segment**))
+(defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
&body body)
#!+sb-doc
"Execute BODY (as a PROGN) without scheduling any of the instructions
(multiple-value-bind (loc-num size)
(sb!c:location-number read)
#!+sb-show-assem (format *trace-output*
- "~&~S reads ~S[~D for ~D]~%"
+ "~&~S reads ~S[~W for ~W]~%"
inst read loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(multiple-value-bind (loc-num size)
(sb!c:location-number write)
#!+sb-show-assem (format *trace-output*
- "~&~S writes ~S[~D for ~D]~%"
+ "~&~S writes ~S[~W for ~W]~%"
inst write loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(push inst (svref (segment-writers segment) index)))))
(values))
-;;; This routine is called by due to uses of the INST macro when the scheduler
-;;; is turned on. The change to the dependency graph has already been computed,
-;;; so we just have to check to see whether the basic block is terminated.
+;;; This routine is called by due to uses of the INST macro when the
+;;; scheduler is turned on. The change to the dependency graph has
+;;; already been computed, so we just have to check to see whether the
+;;; basic block is terminated.
(defun queue-inst (segment inst)
#!+sb-show-assem (format *trace-output* "~&queuing ~S~%" inst)
#!+sb-show-assem (format *trace-output*
(inst-write-dependencies inst))
(writes write))
(writes)))
- (assert (segment-run-scheduler segment))
+ (aver (segment-run-scheduler segment))
(let ((countdown (segment-branch-countdown segment)))
(when countdown
(decf countdown)
- (assert (not (instruction-attributep (inst-attributes inst)
- variable-length))))
+ (aver (not (instruction-attributep (inst-attributes inst)
+ variable-length))))
(cond ((instruction-attributep (inst-attributes inst) branch)
(unless countdown
(setf countdown (inst-delay inst)))
(schedule-pending-instructions segment))))
(values))
-;;; Emit all the pending instructions, and reset any state. This is called
-;;; whenever we hit a label (i.e. an entry point of some kind) and when the
-;;; user turns the scheduler off (otherwise, the queued instructions would
-;;; sit there until the scheduler was turned back on, and emitted in the
-;;; wrong place).
+;;; Emit all the pending instructions, and reset any state. This is
+;;; called whenever we hit a label (i.e. an entry point of some kind)
+;;; and when the user turns the scheduler off (otherwise, the queued
+;;; instructions would sit there until the scheduler was turned back
+;;; on, and emitted in the wrong place).
(defun schedule-pending-instructions (segment)
- (assert (segment-run-scheduler segment))
+ (aver (segment-run-scheduler segment))
;; Quick blow-out if nothing to do.
(when (and (sset-empty (segment-emittable-insts-sset segment))
#!+sb-show-assem (format *trace-output*
"~&scheduling pending instructions..~%")
- ;; Note that any values live at the end of the block have to be computed
- ;; last.
+ ;; Note that any values live at the end of the block have to be
+ ;; computed last.
(let ((emittable-insts (segment-emittable-insts-sset segment))
(writers (segment-writers segment)))
(dotimes (index (length writers))
(setf (instruction-attributep (inst-attributes inst) flushable)
nil)))))
- ;; Grovel through the entire graph in the forward direction finding all
- ;; the leaf instructions.
+ ;; Grovel through the entire graph in the forward direction finding
+ ;; all the leaf instructions.
(labels ((grovel-inst (inst)
(let ((max 0))
(do-sset-elements (dep (inst-write-dependencies inst))
"initially delayed: ~S~%"
(segment-delayed segment))
- ;; Accumulate the results in reverse order. Well, actually, this list will
- ;; be in forward order, because we are generating the reverse order in
- ;; reverse.
+ ;; Accumulate the results in reverse order. Well, actually, this
+ ;; list will be in forward order, because we are generating the
+ ;; reverse order in reverse.
(let ((results nil))
;; Schedule all the branches in their exact locations.
(dolist (branch (segment-queued-branches 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.
+ ;; 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
;; That's all, folks.
(values))
-;;; Utility for maintaining the segment-delayed list. We cdr down list
-;;; n times (extending it if necessary) and then push thing on into the car
-;;; of that cons cell.
+;;; a utility for maintaining the segment-delayed list. We cdr down
+;;; list n times (extending it if necessary) and then push thing on
+;;; into the car of that cons cell.
(defun add-to-nth-list (list thing n)
(do ((cell (or list (setf list (list nil)))
(or (cdr cell) (setf (cdr cell) (list nil))))
;;; Find the next instruction to schedule and return it after updating
;;; any dependency information. If we can't do anything useful right
-;;; now, but there is more work to be done, return :NOP to indicate that
-;;; a nop must be emitted. If we are all done, return NIL.
+;;; now, but there is more work to be done, return :NOP to indicate
+;;; that a nop must be emitted. If we are all done, return NIL.
(defun schedule-one-inst (segment delay-slot-p)
(do ((prev nil remaining)
(remaining (segment-emittable-insts-queue segment) (cdr remaining)))
(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.
+ ;; 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))))))
;; Nothing to do, so make something up.
(cond ((segment-delayed segment)
;; All done.
nil)))
-;;; This function is called whenever an instruction has been scheduled, and we
-;;; want to know what possibilities that opens up. So look at all the
-;;; instructions that this one depends on, and remove this instruction from
-;;; their dependents list. If we were the last dependent, then that
-;;; dependency can be emitted now.
+;;; This function is called whenever an instruction has been
+;;; scheduled, and we want to know what possibilities that opens up.
+;;; So look at all the instructions that this one depends on, and
+;;; remove this instruction from their dependents list. If we were the
+;;; last dependent, then that dependency can be emitted now.
(defun note-resolved-dependencies (segment inst)
- (assert (sset-empty (inst-read-dependents inst)))
- (assert (sset-empty (inst-write-dependents inst)))
+ (aver (sset-empty (inst-read-dependents inst)))
+ (aver (sset-empty (inst-write-dependents inst)))
(do-sset-elements (dep (inst-write-dependencies inst))
;; These are the instructions who have to be completed before our
;; write fires. Doesn't matter how far before, just before.
(inst-delay dep)))))
(values))
-;;; Process the next entry in segment-delayed. This is called whenever anyone
-;;; emits an instruction.
+;;; Process the next entry in segment-delayed. This is called whenever
+;;; anyone emits an instruction.
(defun advance-one-inst (segment)
(let ((delayed-stuff (pop (segment-delayed segment))))
(dolist (stuff delayed-stuff)
(insert-emittable-inst segment dependency)))
(insert-emittable-inst segment stuff)))))
-;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS-
-;;; QUEUE list. We keep the emittable-insts sorted with the largest ``depths''
-;;; first. Except that if INST is a branch, don't bother. It will be handled
-;;; correctly by the branch emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
+;;; Note that inst is emittable by sticking it in the
+;;; SEGMENT-EMITTABLE-INSTS-QUEUE list. We keep the emittable-insts
+;;; sorted with the largest ``depths'' first. Except that if INST is a
+;;; branch, don't bother. It will be handled correctly by the branch
+;;; emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
(defun insert-emittable-inst (segment inst)
(unless (instruction-attributep (inst-attributes inst) branch)
#!+sb-show-assem (format *trace-output* "now emittable: ~S~%" inst)
;;;; structure used during output emission
;;; common supertype for all the different kinds of annotations
-(defstruct (annotation (:constructor nil))
- ;; Where in the raw output stream was this annotation emitted.
+(defstruct (annotation (:constructor nil)
+ (:copier nil))
+ ;; Where in the raw output stream was this annotation emitted?
(index 0 :type index)
- ;; What position does that correspond to.
+ ;; What position does that correspond to?
(posn nil :type (or index null)))
(defstruct (label (:include annotation)
- (:constructor gen-label ()))
+ (:constructor gen-label ())
+ (:copier nil))
;; (doesn't need any additional information beyond what is in the
;; annotation structure)
)
(format stream "L~D" (sb!c:label-id label))))
;;; a constraint on how the output stream must be aligned
-(defstruct (alignment-note
- (:include annotation)
- (:conc-name alignment-)
- (:predicate alignment-p)
- (:constructor make-alignment (bits size fill-byte)))
- ;; The minimum number of low-order bits that must be zero.
+(defstruct (alignment-note (:include annotation)
+ (:conc-name alignment-)
+ (:predicate alignment-p)
+ (:constructor make-alignment (bits size fill-byte))
+ (: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.
+ ;; 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.
+ ;; the byte used as filling
(fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
;;; a reference to someplace that needs to be back-patched when
;;; we actually know what label positions, etc. are
-(defstruct (back-patch
- (:include annotation)
- (:constructor make-back-patch (size function)))
- ;; The area effected by this back-patch.
- (size 0 :type index)
- ;; The function to use to generate the real data
- (function nil :type function))
-
-;;; This is similar to a BACK-PATCH, but also an indication that the amount
-;;; of stuff output depends on label-positions, etc. Back-patches can't change
-;;; their mind about how much stuff to emit, but choosers can.
-(defstruct (chooser
- (:include annotation)
- (:constructor make-chooser
- (size alignment maybe-shrink worst-case-fun)))
- ;; the worst case size for this chooser. There is this much space allocated
- ;; in the output buffer.
- (size 0 :type index)
+(defstruct (back-patch (:include annotation)
+ (:constructor make-back-patch (size fun))
+ (:copier nil))
+ ;; the area affected by this back-patch
+ (size 0 :type index :read-only t)
+ ;; the function to use to generate the real data
+ (fun nil :type function :read-only t))
+
+;;; This is similar to a BACK-PATCH, but also an indication that the
+;;; amount of stuff output depends on label positions, etc.
+;;; BACK-PATCHes can't change their mind about how much stuff to emit,
+;;; but CHOOSERs can.
+(defstruct (chooser (:include annotation)
+ (:constructor make-chooser
+ (size alignment maybe-shrink worst-case-fun))
+ (:copier nil))
+ ;; the worst case size for this chooser. There is this much space
+ ;; allocated in the output buffer.
+ (size 0 :type index :read-only t)
;; the worst case alignment this chooser is guaranteed to preserve
- (alignment 0 :type alignment)
- ;; the function to call to determine of we can use a shorter sequence. It
- ;; returns NIL if nothing shorter can be used, or emits that sequence and
- ;; returns T.
- (maybe-shrink nil :type function)
- ;; the function to call to generate the worst case sequence. This is used
- ;; when nothing else can be condensed.
- (worst-case-fun nil :type function))
-
-;;; This is used internally when we figure out a chooser or alignment doesn't
-;;; really need as much space as we initially gave it.
-(defstruct (filler
- (:include annotation)
- (:constructor make-filler (bytes)))
+ (alignment 0 :type alignment :read-only t)
+ ;; the function to call to determine if we can use a shorter
+ ;; sequence. It returns NIL if nothing shorter can be used, or emits
+ ;; that sequence and returns T.
+ (maybe-shrink nil :type function :read-only t)
+ ;; the function to call to generate the worst case sequence. This is
+ ;; used when nothing else can be condensed.
+ (worst-case-fun nil :type function :read-only t))
+
+;;; This is used internally when we figure out a chooser or alignment
+;;; doesn't really need as much space as we initially gave it.
+(defstruct (filler (:include annotation)
+ (:constructor make-filler (bytes))
+ (:copier nil))
;; the number of bytes of filler here
(bytes 0 :type index))
\f
;;;; output functions
-;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if necessary.
+;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if
+;;; necessary.
(defun emit-byte (segment byte)
(declare (type segment segment))
- ;; We could use DECLARE instead of CHECK-TYPE here, but (1) CMU CL's inspired
- ;; decision to treat DECLARE as ASSERT by default has not been copied by
- ;; other compilers, and this code runs in the cross-compilation host Common
- ;; Lisp, not just CMU CL, and (2) classic CMU CL allowed more things here
- ;; than this, and I haven't tried to proof-read all the calls to EMIT-BYTE to
- ;; ensure that they're passing appropriate. -- WHN 19990323
- (check-type byte possibly-signed-assembly-unit)
+ (declare (type possibly-signed-assembly-unit byte))
(vector-push-extend (logand byte assembly-unit-mask)
(segment-buffer segment))
(incf (segment-current-posn segment))
(emit-byte segment fill-byte))
(values))
-;;; Used to handle the common parts of annotation emision. We just
-;;; assign the posn and index of the note and tack it on to the end
-;;; of the segment's annotations list.
+;;; This is used to handle the common parts of annotation emission. We
+;;; just assign the POSN and INDEX of NOTE and tack it on to the end
+;;; of SEGMENT's annotations list.
(defun emit-annotation (segment note)
(declare (type segment segment)
(type annotation note))
(when (annotation-posn note)
- (error "attempt to emit ~S a second time"))
+ (error "attempt to emit ~S a second time" note))
(setf (annotation-posn note) (segment-current-posn segment))
(setf (annotation-index note) (segment-current-index segment))
(let ((last (segment-last-annotation segment))
(setf (segment-annotations segment) new))))
(values))
+;;; Note that the instruction stream has to be back-patched when label
+;;; positions are finally known. SIZE bytes are reserved in SEGMENT,
+;;; and function will be called with two arguments: the segment and
+;;; the position. The function should look at the position and the
+;;; position of any labels it wants to and emit the correct sequence.
+;;; (And it better be the same size as SIZE). SIZE can be zero, which
+;;; is useful if you just want to find out where things ended up.
(defun emit-back-patch (segment size function)
- #!+sb-doc
- "Note that the instruction stream has to be back-patched when label positions
- are finally known. SIZE bytes are reserved in SEGMENT, and function will
- be called with two arguments: the segment and the position. The function
- should look at the position and the position of any labels it wants to
- and emit the correct sequence. (And it better be the same size as SIZE).
- SIZE can be zero, which is useful if you just want to find out where things
- ended up."
(emit-annotation segment (make-back-patch size function))
(emit-skip segment size))
+;;; Note that the instruction stream here depends on the actual
+;;; positions of various labels, so can't be output until label
+;;; positions are known. Space is made in SEGMENT for at least SIZE
+;;; bytes. When all output has been generated, the MAYBE-SHRINK
+;;; functions for all choosers are called with three arguments: the
+;;; segment, the position, and a magic value. The MAYBE- SHRINK
+;;; decides if it can use a shorter sequence, and if so, emits that
+;;; sequence to the segment and returns T. If it can't do better than
+;;; the worst case, it should return NIL (without emitting anything).
+;;; When calling LABEL-POSITION, it should pass it the position and
+;;; the magic-value it was passed so that LABEL-POSITION can return
+;;; the correct result. If the chooser never decides to use a shorter
+;;; sequence, the WORST-CASE-FUN will be called, just like a
+;;; BACK-PATCH. (See EMIT-BACK-PATCH.)
(defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
- #!+sb-doc
- "Note that the instruction stream here depends on the actual positions of
- various labels, so can't be output until label positions are known. Space
- is made in SEGMENT for at least SIZE bytes. When all output has been
- generated, the MAYBE-SHRINK functions for all choosers are called with
- three arguments: the segment, the position, and a magic value. The MAYBE-
- SHRINK decides if it can use a shorter sequence, and if so, emits that
- sequence to the segment and returns T. If it can't do better than the
- worst case, it should return NIL (without emitting anything). When calling
- LABEL-POSITION, it should pass it the position and the magic-value it was
- passed so that LABEL-POSITION can return the correct result. If the chooser
- never decides to use a shorter sequence, the WORST-CASE-FUN will be called,
- just like a BACK-PATCH. (See EMIT-BACK-PATCH.)"
(declare (type segment segment) (type index size) (type alignment alignment)
(type function maybe-shrink worst-case-fun))
(let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
(emit-skip segment size)
(adjust-alignment-after-chooser segment chooser)))
-;;; Called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to recompute the
-;;; current alignment information in light of this chooser. If the alignment
-;;; guaranteed byte the chooser is less then the segments current alignment,
-;;; we have to adjust the segments notion of the current alignment.
+;;; This is called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to
+;;; recompute the current alignment information in light of this
+;;; chooser. If the alignment guaranteed byte the chooser is less then
+;;; the segments current alignment, we have to adjust the segments
+;;; notion of the current alignment.
;;;
-;;; The hard part is recomputing the sync posn, because it's not just the
-;;; choosers posn. Consider a chooser that emits either one or three words.
-;;; It preserves 8-byte (3 bit) alignments, because the difference between
-;;; the two choices is 8 bytes.
+;;; The hard part is recomputing the sync posn, because it's not just
+;;; the chooser's posn. Consider a chooser that emits either one or
+;;; three words. It preserves 8-byte (3 bit) alignments, because the
+;;; difference between the two choices is 8 bytes.
(defun adjust-alignment-after-chooser (segment chooser)
(declare (type segment segment) (type chooser chooser))
(let ((alignment (chooser-alignment chooser))
(seg-alignment (segment-alignment segment)))
(when (< alignment seg-alignment)
- ;; The chooser might change the alignment of the output. So we have
- ;; to figure out what the worst case alignment could be.
+ ;; The chooser might change the alignment of the output. So we
+ ;; have to figure out what the worst case alignment could be.
(setf (segment-alignment segment) alignment)
(let* ((posn (chooser-posn chooser))
(sync-posn (segment-sync-posn segment))
(setf (segment-sync-posn segment) (- posn delta)))))
(values))
-;;; Used internally whenever a chooser or alignment decides it doesn't need
-;;; as much space as it originally thought.
-(defun emit-filler (segment bytes)
+;;; This is used internally whenever a chooser or alignment decides it
+;;; doesn't need as much space as it originally thought.
+(defun emit-filler (segment n-bytes)
+ (declare (type index n-bytes))
(let ((last (segment-last-annotation segment)))
(cond ((and last (filler-p (car last)))
- (incf (filler-bytes (car last)) bytes))
+ (incf (filler-bytes (car last)) n-bytes))
(t
- (emit-annotation segment (make-filler bytes)))))
- (incf (segment-current-index segment) bytes)
+ (emit-annotation segment (make-filler n-bytes)))))
+ (incf (segment-current-index segment) n-bytes)
(values))
-;;; EMIT-LABEL (the interface) basically just expands into this, supplying
-;;; the segment and vop.
+;;; EMIT-LABEL (the interface) basically just expands into this,
+;;; supplying the SEGMENT and VOP.
(defun %emit-label (segment vop label)
(when (segment-run-scheduler segment)
(schedule-pending-instructions segment))
(funcall hook segment vop :label label)))
(emit-annotation segment label))
-;;; Called by the ALIGN macro to emit an alignment note. We check to 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.
+;;; Called by the ALIGN macro to emit an alignment note. We check to
+;;; 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))
(when (segment-run-scheduler segment)
(schedule-pending-instructions 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.
+ ;; 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))))))
- (assert (> size 0))
+ (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.
+ ;; 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-annotation segment (make-alignment bits 0 fill-byte)))))
(values))
-;;; Used to find how ``aligned'' different offsets are. Returns the number
-;;; of low-order 0 bits, up to MAX-ALIGNMENT.
+;;; This is used to find how ``aligned'' different offsets are.
+;;; Returns the number of low-order 0 bits, up to MAX-ALIGNMENT.
(defun find-alignment (offset)
(dotimes (i max-alignment max-alignment)
(when (logbitp i offset)
(return i))))
-;;; Emit a postit. The function will be called as a back-patch with the
-;;; position the following instruction is finally emitted. Postits do not
-;;; interfere at all with scheduling.
+;;; Emit a postit. The function will be called as a back-patch with
+;;; the position the following instruction is finally emitted. Postits
+;;; do not interfere at all with scheduling.
(defun %emit-postit (segment function)
(push function (segment-postits segment))
(values))
\f
;;;; output compression/position assignment stuff
-;;; Grovel though all the annotations looking for choosers. When we find
-;;; a chooser, invoke the maybe-shrink function. If it returns T, it output
-;;; some other byte sequence.
+;;; Grovel though all the annotations looking for choosers. When we
+;;; find a chooser, invoke the maybe-shrink function. If it returns T,
+;;; it output some other byte sequence.
(defun compress-output (segment)
(dotimes (i 5) ; it better not take more than one or two passes.
(let ((delta 0))
(setf (annotation-posn note) posn))
(cond
((chooser-p note)
- (setf (segment-current-index segment) (chooser-index note))
- (setf (segment-current-posn segment) 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 ~D bytes, but claimed its max was ~D."
- note new-size old-size))
- (let ((additional-delta (- old-size new-size)))
- (when (< (find-alignment additional-delta)
- (chooser-alignment note))
- (error "~S shrunk by ~D bytes, but claimed that it ~
- preserve ~D bits of alignment."
- 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 ~D 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))))
+ (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 ~
+ preserves ~W bits of alignment."
+ 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.
+ ;; Re-emit the alignment, letting it collapse if we know
+ ;; anything more about the alignment guarantees of the
+ ;; segment.
(let ((index (alignment-index note)))
- (setf (segment-current-index segment) index)
- (setf (segment-current-posn segment) 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 ~D, ~
- and is ~D now."
- note old-size size))
- (when (plusp additional-delta)
- (emit-filler segment additional-delta)
- (incf delta additional-delta)))
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-annotations segment)
- (cdr remaining))))))
+ (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, ~
+ and is ~W now."
+ note old-size size))
+ (when (plusp additional-delta)
+ (emit-filler segment additional-delta)
+ (incf delta additional-delta)))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))))
(t
(setf prev remaining)))))
(when (zerop delta)
(decf (segment-final-posn segment) delta)))
(values))
-;;; We have run all the choosers we can, so now we have to figure out exactly
-;;; how much space each alignment note needs.
+;;; We have run all the choosers we can, so now we have to figure out
+;;; exactly how much space each alignment note needs.
(defun finalize-positions (segment)
(let ((delta 0))
(do* ((prev nil)
(size (- new-posn posn))
(old-size (alignment-size note))
(additional-delta (- old-size size)))
- (assert (<= 0 size old-size))
+ (aver (<= 0 size old-size))
(unless (zerop additional-delta)
(setf (segment-last-annotation segment) prev)
(incf delta additional-delta)
- (setf (segment-current-index segment) (alignment-index note))
- (setf (segment-current-posn segment) posn)
- (emit-filler segment additional-delta)
- (setf prev (segment-last-annotation segment)))
- (if prev
- (setf (cdr prev) next)
- (setf (segment-annotations segment) next))))
+ (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)
(decf (segment-final-posn segment) delta)))
(values))
-;;; Grovel over segment, filling in any backpatches. If any choosers are left
-;;; over, we need to emit their worst case varient.
+;;; Grovel over segment, filling in any backpatches. If any choosers
+;;; are left over, we need to emit their worst case varient.
(defun process-back-patches (segment)
(do* ((prev nil)
(remaining (segment-annotations segment) next)
(flet ((fill-in (function old-size)
(let ((index (annotation-index note))
(posn (annotation-posn note)))
- (setf (segment-current-index segment) index)
- (setf (segment-current-posn segment) 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 ~D bytes, but claimed it was ~D."
- 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)))))
+ (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-function note)
+ (fill-in (back-patch-fun note)
(back-patch-size note)))
((chooser-p note)
(fill-in (chooser-worst-case-fun note)
\f
;;;; interface to the rest of the compiler
-;;; This holds the current segment while assembling. Use ASSEMBLE to change
-;;; it.
+;;; This holds the current segment while assembling. Use ASSEMBLE to
+;;; change it.
;;;
-;;; The double asterisks in the name are intended to suggest that this
-;;; isn't just any old special variable, it's an extra-special variable,
-;;; because sometimes MACROLET is used to bind it. So be careful out there..
+;;; The double parens in the name are intended to suggest that this
+;;; isn't just any old special variable, it's an extra-special
+;;; variable, because sometimes MACROLET is used to bind it. So be
+;;; careful out there..
+;;;
+;;; (This used to be called **CURRENT-SEGMENT** in SBCL until 0.7.3,
+;;; and just *CURRENT-SEGMENT* in CMU CL. In both cases, the rebinding
+;;; now done with MACROLET was done with SYMBOL-MACROLET instead. The
+;;; rename-with-double-asterisks was because the SYMBOL-MACROLET made
+;;; it an extra-special variable. The change over to
+;;; %%CURRENT-SEGMENT%% was because ANSI forbids the use of
+;;; SYMBOL-MACROLET on special variable names, and CLISP correctly
+;;; complains about this when being used as a bootstrap host.)
+(defmacro %%current-segment%% () '**current-segment**)
(defvar **current-segment**)
-;;; Just like **CURRENT-SEGMENT**, except this holds the current vop. Used only
-;;; to keep track of which vops emit which insts.
+;;; Just like %%CURRENT-SEGMENT%%, except this holds the current vop.
+;;; This is used only to keep track of which vops emit which insts.
;;;
;;; The double asterisks in the name are intended to suggest that this
-;;; isn't just any old special variable, it's an extra-special variable,
-;;; because sometimes MACROLET is used to bind it. So be careful out there..
+;;; isn't just any old special variable, it's an extra-special
+;;; variable, because sometimes MACROLET is used to bind it. So be
+;;; careful out there..
+(defmacro %%current-vop%% () '**current-vop**)
(defvar **current-vop** nil)
-;;; We also symbol-macrolet **CURRENT-SEGMENT** to a local holding the segment
-;;; so uses of **CURRENT-SEGMENT** inside the body don't have to keep
-;;; dereferencing the symbol. Given that ASSEMBLE is the only interface to
-;;; **CURRENT-SEGMENT**, we don't have to worry about the special value
-;;; becomming out of sync with the lexical value. Unless some bozo closes over
-;;; it, but nobody does anything like that...
+;;; We also MACROLET %%CURRENT-SEGMENT%% to a local holding the
+;;; segment so uses of %%CURRENT-SEGMENT%% inside the body don't have
+;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
+;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
+;;; special value becomming out of sync with the lexical value. Unless
+;;; some bozo closes over it, but nobody does anything like that...
;;;
-;;; FIXME: The way this macro uses MACROEXPAND internally breaks my old
-;;; assumptions about macros which are needed both in the host and the target.
-;;; (This is more or less the same way that PUSH-IN, DELETEF-IN, and
-;;; DEF-BOOLEAN-ATTRIBUTE break my old assumptions, except that they used
-;;; GET-SETF-EXPANSION instead of MACROEXPAND to do the dirty deed.) The
-;;; quick and dirty "solution" here is the same as there: use cut and
-;;; paste to duplicate the defmacro in a
-;;; (SB!INT:DEF!MACRO FOO (..) .. CL:MACROEXPAND ..)
-;;; #+SB-XC-HOST
-;;; (DEFMACRO FOO (..) .. SB!XC:MACROEXPAND ..)
-;;; idiom. This is disgusting and unmaintainable, and there are obviously
-;;; better solutions and maybe even good solutions, but I'm disinclined to
+;;; FIXME: The way this macro uses MACROEXPAND internally breaks my
+;;; old assumptions about macros which are needed both in the host and
+;;; the target. (This is more or less the same way that PUSH-IN,
+;;; DELETEF-IN, and !DEF-BOOLEAN-ATTRIBUTE break my old assumptions,
+;;; except that they used GET-SETF-EXPANSION instead of MACROEXPAND to
+;;; do the dirty deed.) The quick and dirty "solution" here is the
+;;; same as there: use cut and paste to duplicate the defmacro in a
+;;; (SB!INT:DEF!MACRO FOO (..) .. CL:MACROEXPAND ..) #+SB-XC-HOST
+;;; (DEFMACRO FOO (..) .. SB!XC:MACROEXPAND ..) idiom. This is
+;;; disgusting and unmaintainable, and there are obviously better
+;;; solutions and maybe even good solutions, but I'm disinclined to
;;; hunt for good solutions until the system works and I can test them
;;; in isolation.
(sb!int:def!macro assemble ((&optional segment vop &key labels) &body body
(when (intersection labels inherited-labels)
(error "duplicate nested labels: ~S"
(intersection labels inherited-labels)))
- `(let* ((,seg-var ,(or segment '**current-segment**))
- (,vop-var ,(or vop '**current-vop**))
- ,@(when segment
- `((**current-segment** ,seg-var)))
- ,@(when vop
- `((**current-vop** ,vop-var)))
- ,@(mapcar #'(lambda (name)
- `(,name (gen-label)))
+ `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
new-labels))
- (symbol-macrolet ((**current-segment** ,seg-var)
- (**current-vop** ,vop-var)
- ,@(when (or inherited-labels nested-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 (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))
#+sb-xc-host
(sb!xc:defmacro assemble ((&optional segment vop &key labels)
&body body
(when (intersection labels inherited-labels)
(error "duplicate nested labels: ~S"
(intersection labels inherited-labels)))
- `(let* ((,seg-var ,(or segment '**current-segment**))
- (,vop-var ,(or vop '**current-vop**))
- ,@(when segment
- `((**current-segment** ,seg-var)))
- ,@(when vop
- `((**current-vop** ,vop-var)))
- ,@(mapcar #'(lambda (name)
- `(,name (gen-label)))
+ `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
new-labels))
- (symbol-macrolet ((**current-segment** ,seg-var)
- (**current-vop** ,vop-var)
- ,@(when (or inherited-labels nested-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 (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
((functionp inst)
(funcall inst (cdr whole) env))
(t
- `(,inst **current-segment** **current-vop** ,@args)))))
+ `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
-;;; Note: The need to capture SYMBOL-MACROLET bindings of **CURRENT-SEGMENT*
-;;; and **CURRENT-VOP** prevents this from being an ordinary function.
+;;; Note: The need to capture MACROLET bindings of %%CURRENT-SEGMENT%%
+;;; and %%CURRENT-VOP%% prevents this from being an ordinary function.
(defmacro emit-label (label)
#!+sb-doc
"Emit LABEL at this location in the current segment."
- `(%emit-label **current-segment** **current-vop** ,label))
+ `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
-;;; Note: The need to capture SYMBOL-MACROLET bindings of **CURRENT-SEGMENT*
-;;; prevents this from being an ordinary function.
+;;; Note: The need to capture MACROLET bindings of
+;;; %%CURRENT-SEGMENT%% prevents this from being an ordinary function.
(defmacro emit-postit (function)
- `(%emit-postit **current-segment** ,function))
+ `(%emit-postit (%%current-segment%%) ,function))
-;;; Note: The need to capture SYMBOL-MACROLET bindings of **CURRENT-SEGMENT*
-;;; and **CURRENT-VOP** prevents this from being an ordinary function.
+;;; Note: The need to capture SYMBOL-MACROLET bindings of
+;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
+;;; ordinary function.
(defmacro align (bits &optional (fill-byte 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 ,fill-byte))
;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
;;; called EMIT-ALIGNMENT, and the function that it calls should be
;;; called %EMIT-ALIGNMENT.
(setf (segment-postits segment) (segment-postits other-segment))
(dolist (postit postits)
(emit-back-patch segment 0 postit)))
- #!-x86 (emit-alignment segment nil max-alignment)
- #!+x86 (emit-alignment segment nil max-alignment #x90)
+ (emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90)
(let ((segment-current-index-0 (segment-current-index segment))
(segment-current-posn-0 (segment-current-posn segment)))
(incf (segment-current-index segment)
(process-back-patches segment)
(segment-final-posn 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.
+;;; 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
+;;; 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))
(flet ((frob (i0 i1)
(frob i0 (segment-final-index segment))))
(values))
-;;; Write the code accumulated in SEGMENT to STREAM, and return the number of
-;;; bytes written.
+;;; Write the code accumulated in SEGMENT to STREAM, and return the
+;;; number of bytes written.
(defun write-segment-contents (segment stream)
(let ((result 0))
(declare (type index result))
\f
;;;; interface to the instruction set definition
-;;; Define a function named NAME that merges its arguments into a single
-;;; integer and then emits the bytes of that integer in the correct order
-;;; based on the endianness of the target-backend.
+;;; Define a function named NAME that merges its arguments into a
+;;; single integer and then emits the bytes of that integer in the
+;;; correct order based on the endianness of the target-backend.
(defmacro define-bitfield-emitter (name total-bits &rest byte-specs)
(sb!int:collect ((arg-names) (arg-types))
(let* ((total-bits (eval total-bits))
(num-bytes (multiple-value-bind (quo rem)
(truncate total-bits assembly-unit-bits)
(unless (zerop rem)
- (error "~D isn't an even multiple of ~D."
+ (error "~W isn't an even multiple of ~W."
total-bits assembly-unit-bits))
quo))
(bytes (make-array num-bytes :initial-element nil))
(let ((forms nil))
(dotimes (i num-bytes)
(let ((pieces (svref bytes i)))
- (assert pieces)
+ (aver pieces)
(push `(emit-byte ,segment-arg
,(if (cdr pieces)
`(logior ,@pieces)
(when lambda-list
(let ((param (car lambda-list)))
(cond
- ((member param lambda-list-keywords)
+ ((member param sb!xc:lambda-list-keywords)
(new-lambda-list param)
(grovel param (cdr lambda-list)))
(t
(multiple-value-bind (key var)
(if (consp name)
(values (first name) (second name))
- (values (intern (symbol-name name) :keyword)
- name))
+ (values (keywordicate name) name))
`(append (and ,supplied-p (list ',key ,var))
,(grovel state (cdr lambda-list))))))
(&rest
reconstructor))))))
(defun extract-nths (index glue list-of-lists-of-lists)
- (mapcar #'(lambda (list-of-lists)
- (cons glue
- (mapcar #'(lambda (list)
- (nth index list))
- list-of-lists)))
+ (mapcar (lambda (list-of-lists)
+ (cons glue
+ (mapcar (lambda (list)
+ (nth index list))
+ list-of-lists)))
list-of-lists-of-lists))
(defmacro define-instruction (name lambda-list &rest options)
(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
+ ;; 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 printer nil)))
+ `(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
`((declare ,@decls)))
(let ((,postits (segment-postits ,segment-name)))
(setf (segment-postits ,segment-name) nil)
- (symbol-macrolet
- (;; Apparently this binding is intended to keep anyone from
- ;; accidentally using **CURRENT-SEGMENT** within the body
- ;; of the emitter. The error message sorta suggests that
- ;; this can happen accidentally by including one emitter
- ;; inside another. But I dunno.. -- WHN 19990323
- (**current-segment**
- ;; FIXME: I can't see why we have to use
- ;; (MACROLET ((LOSE () (ERROR ..))) (LOSE))
- ;; instead of just (ERROR "..") here.
- (macrolet ((lose ()
- (error "You can't use INST without an ~
- ASSEMBLE inside emitters.")))
- (lose))))
+ (macrolet ((%%current-segment%% ()
+ (error "You can't use INST without an ~
+ ASSEMBLE inside emitters.")))
,@emitter))
(values))
(eval-when (:compile-toplevel :load-toplevel :execute)
(append ,@(extract-nths 0 'list pdefs)))))))))
(defmacro define-instruction-macro (name lambda-list &body body)
- (let ((whole (gensym "WHOLE-"))
- (env (gensym "ENV-")))
+ (with-unique-names (whole env)
(multiple-value-bind (body local-defs)
(sb!kernel:parse-defmacro lambda-list
whole
:environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%define-instruction ,(symbol-name name)
- #'(lambda (,whole ,env)
- ,@local-defs
- (block ,name
- ,body)))))))
+ (lambda (,whole ,env)
+ ,@local-defs
+ (block ,name
+ ,body)))))))
(defun %define-instruction (name defun)
(setf (gethash name *assem-instructions*) defun)
projects / sbcl.git / blobdiff