X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fassem.lisp;h=6b681005cbbb4aa28c58e20f2a82ecb9676baf4f;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=0d1710bb1b514d0073b8bc1927851ee1db44103b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 0d1710b..6b68100 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -10,9 +10,6 @@ ;;;; files for more information. (in-package "SB!ASSEM") - -(sb!int:file-comment - "$Header$") ;;;; assembly control parameters @@ -28,28 +25,29 @@ ;;;; 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-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 @@ -58,12 +56,12 @@ ;; 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. ;; @@ -78,28 +76,28 @@ :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) @@ -115,52 +113,99 @@ (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))))) ;;;; 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 +(def!struct (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) @@ -189,7 +234,7 @@ name) '))) (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 () @@ -198,7 +243,7 @@ ;;;; 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 @@ -227,7 +272,7 @@ (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. @@ -264,7 +309,7 @@ (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. @@ -290,9 +335,10 @@ (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* @@ -307,12 +353,12 @@ (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))) @@ -326,13 +372,13 @@ (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)) @@ -343,8 +389,8 @@ #!+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)) @@ -362,8 +408,8 @@ (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)) @@ -409,9 +455,9 @@ "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. @@ -419,18 +465,19 @@ (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 @@ -502,9 +549,9 @@ ;; 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)))) @@ -515,8 +562,8 @@ ;;; 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))) @@ -540,9 +587,9 @@ (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) @@ -554,14 +601,14 @@ ;; 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. @@ -587,8 +634,8 @@ (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) @@ -602,10 +649,11 @@ (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) @@ -622,14 +670,16 @@ ;;;; 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. +(def!struct (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 ())) +(def!struct (label (:include annotation) + (:constructor gen-label ()) + (:copier nil)) ;; (doesn't need any additional information beyond what is in the ;; annotation structure) ) @@ -640,68 +690,64 @@ (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. +(def!struct (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) +(def!struct (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. +(def!struct (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. +(def!struct (filler (:include annotation) + (:constructor make-filler (bytes)) + (:copier nil)) ;; the number of bytes of filler here (bytes 0 :type index)) ;;;; 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)) @@ -715,14 +761,14 @@ (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)) @@ -733,32 +779,32 @@ (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))) @@ -766,22 +812,23 @@ (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)) @@ -790,19 +837,20 @@ (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)) @@ -815,10 +863,10 @@ (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)) @@ -830,22 +878,22 @@ (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)) @@ -854,25 +902,25 @@ (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)) ;;;; 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)) @@ -889,73 +937,74 @@ (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) @@ -963,8 +1012,8 @@ (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) @@ -981,17 +1030,18 @@ (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) @@ -1000,8 +1050,8 @@ (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) @@ -1011,21 +1061,20 @@ (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) @@ -1035,41 +1084,53 @@ ;;;; 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 @@ -1093,24 +1154,33 @@ (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) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar #'(lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body)))))) + (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**)) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host. + ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%% %%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))))))) #+sb-xc-host (sb!xc:defmacro assemble ((&optional segment vop &key labels) &body body @@ -1135,24 +1205,25 @@ (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) - `((..inherited-labels.. ,nested-labels)))) - ,@(mapcar #'(lambda (form) - (if (label-name-p form) - `(emit-label ,form) - form)) - body)))))) + (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))))))) (defmacro inst (&whole whole instruction &rest args &environment env) #!+sb-doc @@ -1163,26 +1234,27 @@ ((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. @@ -1206,8 +1278,7 @@ (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) @@ -1252,18 +1323,21 @@ (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) @@ -1277,8 +1351,8 @@ (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)) @@ -1291,9 +1365,9 @@ ;;;; 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)) @@ -1301,7 +1375,7 @@ (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)) @@ -1313,7 +1387,7 @@ (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr)))) (when (ldb-test (byte byte-size byte-posn) overall-mask) (error "The byte spec ~S either overlaps another byte spec, or ~ - extends past the end." + extends past the end." byte-spec-expr)) (setf (ldb byte-spec overall-mask) -1) (arg-names arg) @@ -1365,7 +1439,7 @@ (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) @@ -1389,7 +1463,7 @@ (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 @@ -1423,8 +1497,7 @@ (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 @@ -1438,11 +1511,11 @@ 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) @@ -1490,20 +1563,26 @@ (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 @@ -1565,21 +1644,19 @@ ,@(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) - (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."))) + ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least) + ;; can't deal with this declaration, so disable it on host + ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%% + ;; declaration. + #-sb-xc-host + (declare (enable-package-locks %%current-segment%%)) ,@emitter)) (values)) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -1591,8 +1668,7 @@ (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 @@ -1602,10 +1678,10 @@ :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)