Fix comment about *code-coverage-info*.
[sbcl.git] / src / compiler / assem.lisp
blob7323065d94ee46b996e259e7f2e563a793ccaffa
1 ;;;; scheduling assembler
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!ASSEM")
14 ;;;; assembly control parameters
16 (defvar *assem-scheduler-p* nil)
17 (declaim (type boolean *assem-scheduler-p*))
19 (defvar *assem-instructions* (make-hash-table))
21 (defvar *assem-max-locations* 0)
22 (declaim (type index *assem-max-locations*))
24 ;;;; the SEGMENT structure
26 ;;; This structure holds the state of the assembler.
27 (defstruct (segment (:copier nil))
28 ;; the type of this segment (for debugging output and stuff)
29 (type :regular :type (member :regular :elsewhere))
30 ;; Ordinarily this is a vector where instructions are written. If
31 ;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the
32 ;; vector can be replaced by NIL. This used to be an adjustable
33 ;; array, but we now do the array size management manually for
34 ;; performance reasons (as of 2006-05-13 hairy array operations
35 ;; are rather slow compared to simple ones).
36 (buffer (make-array 0 :element-type 'assembly-unit)
37 :type (or null (simple-array assembly-unit)))
38 ;; whether or not to run the scheduler. Note: if the instruction
39 ;; definitions were not compiled with the scheduler turned on, this
40 ;; has no effect.
41 (run-scheduler nil)
42 ;; If a function, then this is funcalled for each inst emitted with
43 ;; the segment, the VOP, the name of the inst (as a string), and the
44 ;; inst arguments.
45 (inst-hook nil :type (or function null))
46 ;; what position does this correspond to? Initially, positions and
47 ;; indexes are the same, but after we start collapsing choosers,
48 ;; positions can change while indexes stay the same.
49 (current-posn 0 :type index)
50 (%current-index 0 :type index)
51 ;; a list of all the annotations that have been output to this segment
52 (annotations nil :type list)
53 ;; a pointer to the last cons cell in the annotations list. This is
54 ;; so we can quickly add things to the end of the annotations list.
55 (last-annotation nil :type list)
56 ;; the number of bits of alignment at the last time we synchronized
57 (alignment max-alignment :type alignment)
58 ;; the position the last time we synchronized
59 (sync-posn 0 :type index)
60 ;; The posn and index everything ends at. This is not maintained
61 ;; while the data is being generated, but is filled in after.
62 ;; Basically, we copy CURRENT-POSN and CURRENT-INDEX so that we can
63 ;; trash them while processing choosers and back-patches.
64 (final-posn 0 :type index)
65 (final-index 0 :type index)
66 ;; *** State used by the scheduler during instruction queueing.
68 ;; a list of postits. These are accumulated between instructions.
69 (postits nil :type list)
70 ;; ``Number'' for last instruction queued. Used only to supply insts
71 ;; with unique sset-element-number's.
72 (inst-number 0 :type index)
73 ;; SIMPLE-VECTORs mapping locations to the instruction that reads them and
74 ;; instructions that write them
75 (readers (make-array *assem-max-locations* :initial-element nil)
76 :type simple-vector)
77 (writers (make-array *assem-max-locations* :initial-element nil)
78 :type simple-vector)
79 ;; The number of additional cycles before the next control transfer,
80 ;; or NIL if a control transfer hasn't been queued. When a delayed
81 ;; branch is queued, this slot is set to the delay count.
82 (branch-countdown nil :type (or null (and fixnum unsigned-byte)))
83 ;; *** These two slots are used both by the queuing noise and the
84 ;; scheduling noise.
86 ;; All the instructions that are pending and don't have any
87 ;; unresolved dependents. We don't list branches here even if they
88 ;; would otherwise qualify. They are listed above.
89 (emittable-insts-sset (make-sset) :type sset)
90 ;; list of queued branches. We handle these specially, because they
91 ;; have to be emitted at a specific place (e.g. one slot before the
92 ;; end of the block).
93 (queued-branches nil :type list)
94 ;; *** state used by the scheduler during instruction scheduling
96 ;; the instructions who would have had a read dependent removed if
97 ;; it were not for a delay slot. This is a list of lists. Each
98 ;; element in the top level list corresponds to yet another cycle of
99 ;; delay. Each element in the second level lists is a dotted pair,
100 ;; holding the dependency instruction and the dependent to remove.
101 (delayed nil :type list)
102 ;; The emittable insts again, except this time as a list sorted by depth.
103 (emittable-insts-queue nil :type list)
104 ;; Whether or not to collect dynamic statistics. This is just the same as
105 ;; *COLLECT-DYNAMIC-STATISTICS* but is faster to reference.
106 #!+sb-dyncount
107 (collect-dynamic-statistics nil))
108 (sb!c::defprinter (segment)
109 type)
111 (declaim (inline segment-current-index))
112 (defun segment-current-index (segment)
113 (segment-%current-index segment))
115 (defun (setf segment-current-index) (new-value segment)
116 (declare (type index new-value)
117 (type segment segment))
118 ;; FIXME: It would be lovely to enforce this, but first FILL-IN will
119 ;; need to be convinced to stop rolling SEGMENT-CURRENT-INDEX
120 ;; backwards.
122 ;; Enforce an observed regularity which makes it easier to think
123 ;; about what's going on in the (legacy) code: The segment never
124 ;; shrinks. -- WHN the reverse engineer
125 #+nil (aver (>= new-value (segment-current-index segment)))
126 (let* ((buffer (segment-buffer segment))
127 (new-buffer-size (length buffer)))
128 (declare (type (simple-array (unsigned-byte 8)) buffer)
129 (type index new-buffer-size))
130 ;; Make sure the array is big enough.
131 (when (<= new-buffer-size new-value)
132 (do ()
133 ((> new-buffer-size new-value))
134 ;; When we have to increase the size of the array, we want to
135 ;; roughly double the vector length: that way growing the array
136 ;; to size N conses only O(N) bytes in total. But just doubling
137 ;; the length would leave a zero-length vector unchanged. Hence,
138 ;; take the MAX with 1..
139 (setf new-buffer-size (max 1 (* 2 new-buffer-size))))
140 (let ((new-buffer (make-array new-buffer-size
141 :element-type '(unsigned-byte 8))))
142 (replace new-buffer buffer)
143 (setf (segment-buffer segment) new-buffer)))
144 ;; Now that the array has the intended next free byte, we can point to it.
145 (setf (segment-%current-index segment) new-value)))
147 ;;; Various functions (like BACK-PATCH-FUN or CHOOSER-WORST-CASE-FUN)
148 ;;; aren't cleanly parameterized, but instead use
149 ;;; SEGMENT-CURRENT-INDEX and/or SEGMENT-CURRENT-POSN as global
150 ;;; variables. So code which calls such functions needs to modify
151 ;;; SEGMENT-CURRENT-INDEX and SEGMENT-CURRENT-POSN. This is left over
152 ;;; from the old new-assem.lisp C-style code, and so all the
153 ;;; destruction happens to be done after other uses of these slots are
154 ;;; done and things basically work. However, (1) it's fundamentally
155 ;;; nasty, and (2) at least one thing doesn't work right: OpenMCL
156 ;;; properly points out that SUBSEQ's indices aren't supposed to
157 ;;; exceed its logical LENGTH, i.e. its FILL-POINTER, i.e.
158 ;;; SEGMENT-CURRENT-INDEX.
160 ;;; As a quick fix involving minimal modification of legacy code,
161 ;;; we do such sets of SEGMENT-CURRENT-INDEX and SEGMENT-CURRENT-POSN
162 ;;; using this macro, which restores 'em afterwards.
164 ;;; FIXME: It'd probably be better to cleanly parameterize things like
165 ;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
166 (defmacro with-modified-segment-index-and-posn ((segment index posn)
167 &body body)
168 (with-unique-names (n-segment old-index old-posn)
169 `(let* ((,n-segment ,segment)
170 (,old-index (segment-current-index ,n-segment))
171 (,old-posn (segment-current-posn ,n-segment)))
172 (unwind-protect
173 (progn
174 (setf (segment-current-index ,n-segment) ,index
175 (segment-current-posn ,n-segment) ,posn)
176 ,@body)
177 (setf (segment-current-index ,n-segment) ,old-index
178 (segment-current-posn ,n-segment) ,old-posn)))))
180 ;;;; structures/types used by the scheduler
182 (!def-boolean-attribute instruction
183 ;; This attribute is set if the scheduler can freely flush this
184 ;; instruction if it thinks it is not needed. Examples are NOP and
185 ;; instructions that have no side effect not described by the
186 ;; writes.
187 flushable
188 ;; This attribute is set when an instruction can cause a control
189 ;; transfer. For test instructions, the delay is used to determine
190 ;; how many instructions follow the branch.
191 branch
192 ;; This attribute indicates that this ``instruction'' can be
193 ;; variable length, and therefore had better never be used in a
194 ;; branch delay slot.
195 variable-length)
197 (defstruct (instruction
198 (:include sset-element)
199 (:conc-name inst-)
200 (:constructor make-instruction (number emitter attributes delay))
201 (:copier nil))
202 ;; The function to envoke to actually emit this instruction. Gets called
203 ;; with the segment as its one argument.
204 (emitter (missing-arg) :type (or null function))
205 ;; The attributes of this instruction.
206 (attributes (instruction-attributes) :type sb!c:attributes)
207 ;; Number of instructions or cycles of delay before additional
208 ;; instructions can read our writes.
209 (delay 0 :type (and fixnum unsigned-byte))
210 ;; the maximum number of instructions in the longest dependency
211 ;; chain from this instruction to one of the independent
212 ;; instructions. This is used as a heuristic at to which
213 ;; instructions should be scheduled first.
214 (depth nil :type (or null (and fixnum unsigned-byte)))
215 ;; Note: When trying remember which of the next four is which, note
216 ;; that the ``read'' or ``write'' always refers to the dependent
217 ;; (second) instruction.
219 ;; instructions whose writes this instruction tries to read
220 (read-dependencies (make-sset) :type sset)
221 ;; instructions whose writes or reads are overwritten by this instruction
222 (write-dependencies (make-sset) :type sset)
223 ;; instructions which write what we read or write
224 (write-dependents (make-sset) :type sset)
225 ;; instructions which read what we write
226 (read-dependents (make-sset) :type sset))
227 #!+sb-show-assem (defvar *inst-ids* (make-hash-table :test 'eq))
228 #!+sb-show-assem (defvar *next-inst-id* 0)
229 (defmethod print-object ((inst instruction) stream)
230 (print-unreadable-object (inst stream :type t :identity t)
231 #!+sb-show-assem
232 (princ (or (gethash inst *inst-ids*)
233 (setf (gethash inst *inst-ids*)
234 (incf *next-inst-id*)))
235 stream)
236 (format stream
237 #!+sb-show-assem " emitter=~S" #!-sb-show-assem "emitter=~S"
238 (let ((emitter (inst-emitter inst)))
239 (if emitter
240 (multiple-value-bind (lambda lexenv-p name)
241 (function-lambda-expression emitter)
242 (declare (ignore lambda lexenv-p))
243 name)
244 '<flushed>)))
245 (when (inst-depth inst)
246 (format stream ", depth=~W" (inst-depth inst)))))
248 #!+sb-show-assem
249 (defun reset-inst-ids ()
250 (clrhash *inst-ids*)
251 (setf *next-inst-id* 0))
253 ;;;; the scheduler itself
255 (defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
256 &body body)
257 #!+sb-doc
258 "Execute BODY (as a PROGN) without scheduling any of the instructions
259 generated inside it. This is not protected by UNWIND-PROTECT, so
260 DO NOT use THROW or RETURN-FROM to escape from it."
261 ;; FIXME: Why not just use UNWIND-PROTECT? Or is there some other
262 ;; reason why we shouldn't use THROW or RETURN-FROM?
263 (let ((var (gensym))
264 (seg (gensym)))
265 `(let* ((,seg ,segment)
266 (,var (segment-run-scheduler ,seg)))
267 (when ,var
268 (schedule-pending-instructions ,seg)
269 (setf (segment-run-scheduler ,seg) nil))
270 ,@body
271 (setf (segment-run-scheduler ,seg) ,var))))
273 (defmacro note-dependencies ((segment inst) &body body)
274 (sb!int:once-only ((segment segment) (inst inst))
275 `(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc))
276 (writes (loc &rest keys)
277 `(note-write-dependency ,',segment ,',inst ,loc ,@keys)))
278 ,@body)))
280 #!+(or hppa sparc ppc mips) ; only for platforms with scheduling assembler.
281 (defun note-read-dependency (segment inst read)
282 (multiple-value-bind (loc-num size)
283 (sb!c:location-number read)
284 #!+sb-show-assem (format *trace-output*
285 "~&~S reads ~S[~W for ~W]~%"
286 inst read loc-num size)
287 (when loc-num
288 ;; Iterate over all the locations for this TN.
289 (do ((index loc-num (1+ index))
290 (end-loc (+ loc-num (or size 1))))
291 ((>= index end-loc))
292 (declare (type (mod 2048) index end-loc))
293 (let ((writers (svref (segment-writers segment) index)))
294 (when writers
295 ;; The inst that wrote the value we want to read must have
296 ;; completed.
297 (let ((writer (car writers)))
298 (sset-adjoin writer (inst-read-dependencies inst))
299 (sset-adjoin inst (inst-read-dependents writer))
300 (sset-delete writer (segment-emittable-insts-sset segment))
301 ;; And it must have been completed *after* all other
302 ;; writes to that location. Actually, that isn't quite
303 ;; true. Each of the earlier writes could be done
304 ;; either before this last write, or after the read, but
305 ;; we have no way of representing that.
306 (dolist (other-writer (cdr writers))
307 (sset-adjoin other-writer (inst-write-dependencies writer))
308 (sset-adjoin writer (inst-write-dependents other-writer))
309 (sset-delete other-writer
310 (segment-emittable-insts-sset segment))))
311 ;; And we don't need to remember about earlier writes any
312 ;; more. Shortening the writers list means that we won't
313 ;; bother generating as many explicit arcs in the graph.
314 (setf (cdr writers) nil)))
315 (push inst (svref (segment-readers segment) index)))))
316 (values))
318 #!+(or hppa sparc ppc mips) ; only for platforms with scheduling assembler.
319 (defun note-write-dependency (segment inst write &key partially)
320 (multiple-value-bind (loc-num size)
321 (sb!c:location-number write)
322 #!+sb-show-assem (format *trace-output*
323 "~&~S writes ~S[~W for ~W]~%"
324 inst write loc-num size)
325 (when loc-num
326 ;; Iterate over all the locations for this TN.
327 (do ((index loc-num (1+ index))
328 (end-loc (+ loc-num (or size 1))))
329 ((>= index end-loc))
330 (declare (type (mod 2048) index end-loc))
331 ;; All previous reads of this location must have completed.
332 (dolist (prev-inst (svref (segment-readers segment) index))
333 (unless (eq prev-inst inst)
334 (sset-adjoin prev-inst (inst-write-dependencies inst))
335 (sset-adjoin inst (inst-write-dependents prev-inst))
336 (sset-delete prev-inst (segment-emittable-insts-sset segment))))
337 (when partially
338 ;; All previous writes to the location must have completed.
339 (dolist (prev-inst (svref (segment-writers segment) index))
340 (sset-adjoin prev-inst (inst-write-dependencies inst))
341 (sset-adjoin inst (inst-write-dependents prev-inst))
342 (sset-delete prev-inst (segment-emittable-insts-sset segment)))
343 ;; And we can forget about remembering them, because
344 ;; depending on us is as good as depending on them.
345 (setf (svref (segment-writers segment) index) nil))
346 (push inst (svref (segment-writers segment) index)))))
347 (values))
349 ;;; This routine is called by due to uses of the INST macro when the
350 ;;; scheduler is turned on. The change to the dependency graph has
351 ;;; already been computed, so we just have to check to see whether the
352 ;;; basic block is terminated.
353 (defun queue-inst (segment inst)
354 #!+sb-show-assem (format *trace-output* "~&queuing ~S~%" inst)
355 #!+sb-show-assem (format *trace-output*
356 " reads ~S~% writes ~S~%"
357 (sb!int:collect ((reads))
358 (do-sset-elements (read
359 (inst-read-dependencies inst))
360 (reads read))
361 (reads))
362 (sb!int:collect ((writes))
363 (do-sset-elements (write
364 (inst-write-dependencies inst))
365 (writes write))
366 (writes)))
367 (aver (segment-run-scheduler segment))
368 (let ((countdown (segment-branch-countdown segment)))
369 (when countdown
370 (decf countdown)
371 (aver (not (instruction-attributep (inst-attributes inst)
372 variable-length))))
373 (cond ((instruction-attributep (inst-attributes inst) branch)
374 (unless countdown
375 (setf countdown (inst-delay inst)))
376 (push (cons countdown inst)
377 (segment-queued-branches segment)))
379 (sset-adjoin inst (segment-emittable-insts-sset segment))))
380 (when countdown
381 (setf (segment-branch-countdown segment) countdown)
382 (when (zerop countdown)
383 (schedule-pending-instructions segment))))
384 (values))
386 #!-(or mips ppc sparc) ; not defined for platforms other than these
387 (defun sb!c:emit-nop (seg) seg (bug "EMIT-NOP"))
389 ;;; Emit all the pending instructions, and reset any state. This is
390 ;;; called whenever we hit a label (i.e. an entry point of some kind)
391 ;;; and when the user turns the scheduler off (otherwise, the queued
392 ;;; instructions would sit there until the scheduler was turned back
393 ;;; on, and emitted in the wrong place).
394 (defun schedule-pending-instructions (segment)
395 (aver (segment-run-scheduler segment))
397 ;; Quick blow-out if nothing to do.
398 (when (and (sset-empty (segment-emittable-insts-sset segment))
399 (null (segment-queued-branches segment)))
400 (return-from schedule-pending-instructions
401 (values)))
403 #!+sb-show-assem (format *trace-output*
404 "~&scheduling pending instructions..~%")
406 ;; Note that any values live at the end of the block have to be
407 ;; computed last.
408 (let ((emittable-insts (segment-emittable-insts-sset segment))
409 (writers (segment-writers segment)))
410 (dotimes (index (length writers))
411 (let* ((writer (svref writers index))
412 (inst (car writer))
413 (overwritten (cdr writer)))
414 (when writer
415 (when overwritten
416 (let ((write-dependencies (inst-write-dependencies inst)))
417 (dolist (other-inst overwritten)
418 (sset-adjoin inst (inst-write-dependents other-inst))
419 (sset-adjoin other-inst write-dependencies)
420 (sset-delete other-inst emittable-insts))))
421 ;; If the value is live at the end of the block, we can't flush it.
422 (setf (instruction-attributep (inst-attributes inst) flushable)
423 nil)))))
425 ;; Grovel through the entire graph in the forward direction finding
426 ;; all the leaf instructions.
427 (labels ((grovel-inst (inst)
428 (let ((max 0))
429 (do-sset-elements (dep (inst-write-dependencies inst))
430 (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
431 (when (> dep-depth max)
432 (setf max dep-depth))))
433 (do-sset-elements (dep (inst-read-dependencies inst))
434 (let ((dep-depth
435 (+ (or (inst-depth dep) (grovel-inst dep))
436 (inst-delay dep))))
437 (when (> dep-depth max)
438 (setf max dep-depth))))
439 (cond ((and (sset-empty (inst-read-dependents inst))
440 (instruction-attributep (inst-attributes inst)
441 flushable))
442 #!+sb-show-assem (format *trace-output*
443 "flushing ~S~%"
444 inst)
445 (setf (inst-emitter inst) nil)
446 (setf (inst-depth inst) max))
448 (setf (inst-depth inst) max))))))
449 (let ((emittable-insts nil)
450 (delayed nil))
451 (do-sset-elements (inst (segment-emittable-insts-sset segment))
452 (grovel-inst inst)
453 (if (zerop (inst-delay inst))
454 (push inst emittable-insts)
455 (setf delayed
456 (add-to-nth-list delayed inst (1- (inst-delay inst))))))
457 (setf (segment-emittable-insts-queue segment)
458 (sort emittable-insts #'> :key #'inst-depth))
459 (setf (segment-delayed segment) delayed))
460 (dolist (branch (segment-queued-branches segment))
461 (grovel-inst (cdr branch))))
462 #!+sb-show-assem (format *trace-output*
463 "queued branches: ~S~%"
464 (segment-queued-branches segment))
465 #!+sb-show-assem (format *trace-output*
466 "initially emittable: ~S~%"
467 (segment-emittable-insts-queue segment))
468 #!+sb-show-assem (format *trace-output*
469 "initially delayed: ~S~%"
470 (segment-delayed segment))
472 ;; Accumulate the results in reverse order. Well, actually, this
473 ;; list will be in forward order, because we are generating the
474 ;; reverse order in reverse.
475 (let ((results nil))
477 ;; Schedule all the branches in their exact locations.
478 (let ((insts-from-end (segment-branch-countdown segment)))
479 (dolist (branch (segment-queued-branches segment))
480 (let ((inst (cdr branch)))
481 (dotimes (i (- (car branch) insts-from-end))
482 ;; Each time through this loop we need to emit another
483 ;; instruction. First, we check to see whether there is
484 ;; any instruction that must be emitted before (i.e. must
485 ;; come after) the branch inst. If so, emit it. Otherwise,
486 ;; just pick one of the emittable insts. If there is
487 ;; nothing to do, then emit a nop. ### Note: despite the
488 ;; fact that this is a loop, it really won't work for
489 ;; repetitions other than zero and one. For example, if
490 ;; the branch has two dependents and one of them dpends on
491 ;; the other, then the stuff that grabs a dependent could
492 ;; easily grab the wrong one. But I don't feel like fixing
493 ;; this because it doesn't matter for any of the
494 ;; architectures we are using or plan on using.
495 (flet ((maybe-schedule-dependent (dependents)
496 (do-sset-elements (inst dependents)
497 ;; If do-sset-elements enters the body, then there is a
498 ;; dependent. Emit it.
499 (note-resolved-dependencies segment inst)
500 ;; Remove it from the emittable insts.
501 (setf (segment-emittable-insts-queue segment)
502 (delete inst
503 (segment-emittable-insts-queue segment)
504 :test #'eq))
505 ;; And if it was delayed, removed it from the delayed
506 ;; list. This can happen if there is a load in a
507 ;; branch delay slot.
508 (block scan-delayed
509 (do ((delayed (segment-delayed segment)
510 (cdr delayed)))
511 ((null delayed))
512 (do ((prev nil cons)
513 (cons (car delayed) (cdr cons)))
514 ((null cons))
515 (when (eq (car cons) inst)
516 (if prev
517 (setf (cdr prev) (cdr cons))
518 (setf (car delayed) (cdr cons)))
519 (return-from scan-delayed nil)))))
520 ;; And return it.
521 (return inst))))
522 (let ((fill (or (maybe-schedule-dependent
523 (inst-read-dependents inst))
524 (maybe-schedule-dependent
525 (inst-write-dependents inst))
526 (schedule-one-inst segment t)
527 :nop)))
528 #!+sb-show-assem (format *trace-output*
529 "filling branch delay slot with ~S~%"
530 fill)
531 (push fill results)))
532 (advance-one-inst segment)
533 (incf insts-from-end))
534 (note-resolved-dependencies segment inst)
535 (push inst results)
536 #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
537 (advance-one-inst segment))))
539 ;; Keep scheduling stuff until we run out.
540 (loop
541 (let ((inst (schedule-one-inst segment nil)))
542 (unless inst
543 (return))
544 (push inst results)
545 (advance-one-inst segment)))
547 ;; Now call the emitters, but turn the scheduler off for the duration.
548 (setf (segment-run-scheduler segment) nil)
549 (dolist (inst results)
550 (if (eq inst :nop)
551 (sb!c:emit-nop segment)
552 (funcall (inst-emitter inst) segment)))
553 (setf (segment-run-scheduler segment) t))
555 ;; Clear out any residue left over.
556 (setf (segment-inst-number segment) 0)
557 (setf (segment-queued-branches segment) nil)
558 (setf (segment-branch-countdown segment) nil)
559 (setf (segment-emittable-insts-sset segment) (make-sset))
560 (fill (segment-readers segment) nil)
561 (fill (segment-writers segment) nil)
563 ;; That's all, folks.
564 (values))
566 ;;; a utility for maintaining the segment-delayed list. We cdr down
567 ;;; list n times (extending it if necessary) and then push thing on
568 ;;; into the car of that cons cell.
569 (defun add-to-nth-list (list thing n)
570 (do ((cell (or list (setf list (list nil)))
571 (or (cdr cell) (setf (cdr cell) (list nil))))
572 (i n (1- i)))
573 ((zerop i)
574 (push thing (car cell))
575 list)))
577 ;;; Find the next instruction to schedule and return it after updating
578 ;;; any dependency information. If we can't do anything useful right
579 ;;; now, but there is more work to be done, return :NOP to indicate
580 ;;; that a nop must be emitted. If we are all done, return NIL.
581 (defun schedule-one-inst (segment delay-slot-p)
582 (do ((prev nil remaining)
583 (remaining (segment-emittable-insts-queue segment) (cdr remaining)))
584 ((null remaining))
585 (let ((inst (car remaining)))
586 (unless (and delay-slot-p
587 (instruction-attributep (inst-attributes inst)
588 variable-length))
589 ;; We've got us a live one here. Go for it.
590 #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
591 ;; Delete it from the list of insts.
592 (if prev
593 (setf (cdr prev) (cdr remaining))
594 (setf (segment-emittable-insts-queue segment)
595 (cdr remaining)))
596 ;; Note that this inst has been emitted.
597 (note-resolved-dependencies segment inst)
598 ;; And return.
599 (return-from schedule-one-inst
600 ;; Are we wanting to flush this instruction?
601 (if (inst-emitter inst)
602 ;; Nope, it's still a go. So return it.
603 inst
604 ;; Yes, so pick a new one. We have to start
605 ;; over, because note-resolved-dependencies
606 ;; might have changed the emittable-insts-queue.
607 (schedule-one-inst segment delay-slot-p))))))
608 ;; Nothing to do, so make something up.
609 (cond ((segment-delayed segment)
610 ;; No emittable instructions, but we have more work to do. Emit
611 ;; a NOP to fill in a delay slot.
612 #!+sb-show-assem (format *trace-output* "emitting a NOP~%")
613 :nop)
615 ;; All done.
616 nil)))
618 ;;; This function is called whenever an instruction has been
619 ;;; scheduled, and we want to know what possibilities that opens up.
620 ;;; So look at all the instructions that this one depends on, and
621 ;;; remove this instruction from their dependents list. If we were the
622 ;;; last dependent, then that dependency can be emitted now.
623 (defun note-resolved-dependencies (segment inst)
624 (aver (sset-empty (inst-read-dependents inst)))
625 (aver (sset-empty (inst-write-dependents inst)))
626 (do-sset-elements (dep (inst-write-dependencies inst))
627 ;; These are the instructions who have to be completed before our
628 ;; write fires. Doesn't matter how far before, just before.
629 (let ((dependents (inst-write-dependents dep)))
630 (sset-delete inst dependents)
631 (when (and (sset-empty dependents)
632 (sset-empty (inst-read-dependents dep)))
633 (insert-emittable-inst segment dep))))
634 (do-sset-elements (dep (inst-read-dependencies inst))
635 ;; These are the instructions who write values we read. If there
636 ;; is no delay, then just remove us from the dependent list.
637 ;; Otherwise, record the fact that in n cycles, we should be
638 ;; removed.
639 (if (zerop (inst-delay dep))
640 (let ((dependents (inst-read-dependents dep)))
641 (sset-delete inst dependents)
642 (when (and (sset-empty dependents)
643 (sset-empty (inst-write-dependents dep)))
644 (insert-emittable-inst segment dep)))
645 (setf (segment-delayed segment)
646 (add-to-nth-list (segment-delayed segment)
647 (cons dep inst)
648 (inst-delay dep)))))
649 (values))
651 ;;; Process the next entry in segment-delayed. This is called whenever
652 ;;; anyone emits an instruction.
653 (defun advance-one-inst (segment)
654 (let ((delayed-stuff (pop (segment-delayed segment))))
655 (dolist (stuff delayed-stuff)
656 (if (consp stuff)
657 (let* ((dependency (car stuff))
658 (dependent (cdr stuff))
659 (dependents (inst-read-dependents dependency)))
660 (sset-delete dependent dependents)
661 (when (and (sset-empty dependents)
662 (sset-empty (inst-write-dependents dependency)))
663 (insert-emittable-inst segment dependency)))
664 (insert-emittable-inst segment stuff)))))
666 ;;; Note that inst is emittable by sticking it in the
667 ;;; SEGMENT-EMITTABLE-INSTS-QUEUE list. We keep the emittable-insts
668 ;;; sorted with the largest ``depths'' first. Except that if INST is a
669 ;;; branch, don't bother. It will be handled correctly by the branch
670 ;;; emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
671 (defun insert-emittable-inst (segment inst)
672 (unless (instruction-attributep (inst-attributes inst) branch)
673 #!+sb-show-assem (format *trace-output* "now emittable: ~S~%" inst)
674 (do ((my-depth (inst-depth inst))
675 (remaining (segment-emittable-insts-queue segment) (cdr remaining))
676 (prev nil remaining))
677 ((or (null remaining) (> my-depth (inst-depth (car remaining))))
678 (if prev
679 (setf (cdr prev) (cons inst remaining))
680 (setf (segment-emittable-insts-queue segment)
681 (cons inst remaining))))))
682 (values))
684 ;;;; structure used during output emission
686 ;;; a constraint on how the output stream must be aligned
687 (defstruct (alignment-note (:include annotation)
688 (:conc-name alignment-)
689 (:predicate alignment-p)
690 (:constructor make-alignment (bits size pattern))
691 (:copier nil))
692 ;; the minimum number of low-order bits that must be zero
693 (bits 0 :type alignment)
694 ;; the amount of filler we are assuming this alignment op will take
695 (size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))
696 ;; the byte used as filling or :LONG-NOP, indicating to call EMIT-LONG-NOP
697 ;; to emit a filling pattern
698 (pattern 0 :type (or possibly-signed-assembly-unit
699 (member :long-nop))))
701 ;;; a reference to someplace that needs to be back-patched when
702 ;;; we actually know what label positions, etc. are
703 (defstruct (back-patch (:include annotation)
704 (:constructor make-back-patch (size fun))
705 (:copier nil))
706 ;; the area affected by this back-patch
707 (size 0 :type index :read-only t)
708 ;; the function to use to generate the real data
709 (fun nil :type function :read-only t))
711 ;;; This is similar to a BACK-PATCH, but also an indication that the
712 ;;; amount of stuff output depends on label positions, etc.
713 ;;; BACK-PATCHes can't change their mind about how much stuff to emit,
714 ;;; but CHOOSERs can.
715 (defstruct (chooser (:include annotation)
716 (:constructor make-chooser
717 (size alignment maybe-shrink worst-case-fun))
718 (:copier nil))
719 ;; the worst case size for this chooser. There is this much space
720 ;; allocated in the output buffer.
721 (size 0 :type index :read-only t)
722 ;; the worst case alignment this chooser is guaranteed to preserve
723 (alignment 0 :type alignment :read-only t)
724 ;; the function to call to determine if we can use a shorter
725 ;; sequence. It returns NIL if nothing shorter can be used, or emits
726 ;; that sequence and returns T.
727 (maybe-shrink nil :type function :read-only t)
728 ;; the function to call to generate the worst case sequence. This is
729 ;; used when nothing else can be condensed.
730 (worst-case-fun nil :type function :read-only t))
732 ;;; This is used internally when we figure out a chooser or alignment
733 ;;; doesn't really need as much space as we initially gave it.
734 (defstruct (filler (:include annotation)
735 (:constructor make-filler (bytes))
736 (:copier nil))
737 ;; the number of bytes of filler here
738 (bytes 0 :type index))
740 ;;;; output functions
742 ;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if
743 ;;; necessary.
744 (defun emit-byte (segment byte)
745 (declare (type segment segment))
746 (declare (type possibly-signed-assembly-unit byte))
747 (let ((old-index (segment-current-index segment)))
748 (incf (segment-current-index segment))
749 (setf (aref (segment-buffer segment) old-index)
750 (logand byte assembly-unit-mask)))
751 (incf (segment-current-posn segment))
752 (values))
754 ;;; interface: Output AMOUNT bytes to SEGMENT, either copies of
755 ;;; PATTERN (if that is an integer), or by calling EMIT-LONG-NOP
756 ;;; (if PATTERN is :LONG-NOP).
757 (defun emit-skip (segment amount &optional (pattern 0))
758 (declare (type segment segment)
759 (type index amount))
760 (etypecase pattern
761 (integer
762 (dotimes (i amount)
763 (emit-byte segment pattern)))
764 ;; EMIT-LONG-NOP does not exist for most backends.
765 ;; Better to get an ECASE error than undefined-function.
766 #!+x86-64
767 ((eql :long-nop)
768 (sb!vm:emit-long-nop segment amount)))
769 (values))
771 ;;; This is used to handle the common parts of annotation emission. We
772 ;;; just assign the POSN and INDEX of NOTE and tack it on to the end
773 ;;; of SEGMENT's annotations list.
774 (defun emit-annotation (segment note)
775 (declare (type segment segment)
776 (type annotation note))
777 (when (annotation-posn note)
778 (error "attempt to emit ~S a second time" note))
779 (setf (annotation-posn note) (segment-current-posn segment))
780 (setf (annotation-index note) (segment-current-index segment))
781 (let ((last (segment-last-annotation segment))
782 (new (list note)))
783 (setf (segment-last-annotation segment)
784 (if last
785 (setf (cdr last) new)
786 (setf (segment-annotations segment) new))))
787 (values))
789 ;;; Note that the instruction stream has to be back-patched when label
790 ;;; positions are finally known. SIZE bytes are reserved in SEGMENT,
791 ;;; and function will be called with two arguments: the segment and
792 ;;; the position. The function should look at the position and the
793 ;;; position of any labels it wants to and emit the correct sequence.
794 ;;; (And it better be the same size as SIZE). SIZE can be zero, which
795 ;;; is useful if you just want to find out where things ended up.
796 (defun emit-back-patch (segment size function)
797 (emit-annotation segment (make-back-patch size function))
798 (emit-skip segment size))
800 ;;; Note that the instruction stream here depends on the actual
801 ;;; positions of various labels, so can't be output until label
802 ;;; positions are known. Space is made in SEGMENT for at least SIZE
803 ;;; bytes. When all output has been generated, the MAYBE-SHRINK
804 ;;; functions for all choosers are called with three arguments: the
805 ;;; segment, the position, and a magic value. The MAYBE-SHRINK
806 ;;; decides if it can use a shorter sequence, and if so, emits that
807 ;;; sequence to the segment and returns T. If it can't do better than
808 ;;; the worst case, it should return NIL (without emitting anything).
809 ;;; When calling LABEL-POSITION, it should pass it the position and
810 ;;; the magic-value it was passed so that LABEL-POSITION can return
811 ;;; the correct result. If the chooser never decides to use a shorter
812 ;;; sequence, the WORST-CASE-FUN will be called, just like a
813 ;;; BACK-PATCH. (See EMIT-BACK-PATCH.)
814 (defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
815 (declare (type segment segment) (type index size) (type alignment alignment)
816 (type function maybe-shrink worst-case-fun))
817 (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
818 (emit-annotation segment chooser)
819 (emit-skip segment size)
820 (adjust-alignment-after-chooser segment chooser)))
822 ;;; This is called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to
823 ;;; recompute the current alignment information in light of this
824 ;;; chooser. If the alignment guaranteed by the chooser is less than
825 ;;; the segment's current alignment, we have to adjust the segment's
826 ;;; notion of the current alignment.
828 ;;; The hard part is recomputing the sync posn, because it's not just
829 ;;; the chooser's posn. Consider a chooser that emits either one or
830 ;;; three words. It preserves 8-byte (3 bit) alignments, because the
831 ;;; difference between the two choices is 8 bytes.
832 (defun adjust-alignment-after-chooser (segment chooser)
833 (declare (type segment segment) (type chooser chooser))
834 (let ((alignment (chooser-alignment chooser))
835 (seg-alignment (segment-alignment segment)))
836 (when (< alignment seg-alignment)
837 ;; The chooser might change the alignment of the output. So we
838 ;; have to figure out what the worst case alignment could be.
839 (setf (segment-alignment segment) alignment)
840 (let* ((posn (chooser-posn chooser))
841 (sync-posn (segment-sync-posn segment))
842 (offset (- posn sync-posn))
843 (delta (logand offset (1- (ash 1 alignment)))))
844 (setf (segment-sync-posn segment) (- posn delta)))))
845 (values))
847 ;;; This is used internally whenever a chooser or alignment decides it
848 ;;; doesn't need as much space as it originally thought.
849 ;;; This function used to extend an existing filler instead of creating
850 ;;; a new one when the previous segment annotation was a filler. Now
851 ;;; this is only done if the previous filler is immediately adjacent
852 ;;; to the new one in the segment, too. To see why this restriction is
853 ;;; necessary, consider a jump followed by an alignment made of
854 ;;; multi-byte NOPs when both are shrunk: The shortened alignment is
855 ;;; reemitted at its original _start_ position but the joined filler
856 ;;; would extend over this position and instead leave a subsequence of
857 ;;; the segment up to the alignment's original _end_ position visible.
858 (defun emit-filler (segment n-bytes)
859 (declare (type index n-bytes))
860 (let ((last (segment-last-annotation segment)))
861 (cond ((and last
862 (filler-p (car last))
863 (= (+ (filler-index (car last))
864 (filler-bytes (car last)))
865 (segment-current-index segment)))
866 (incf (filler-bytes (car last)) n-bytes))
868 (emit-annotation segment (make-filler n-bytes)))))
869 (incf (segment-current-index segment) n-bytes)
870 (values))
872 ;;; EMIT-LABEL (the interface) basically just expands into this,
873 ;;; supplying the SEGMENT and VOP.
874 (defun %emit-label (segment vop label)
875 (when (segment-run-scheduler segment)
876 (schedule-pending-instructions segment))
877 (let ((postits (segment-postits segment)))
878 (setf (segment-postits segment) nil)
879 (dolist (postit postits)
880 (emit-back-patch segment 0 postit)))
881 (let ((hook (segment-inst-hook segment)))
882 (when hook
883 (funcall hook segment vop :label label)))
884 (emit-annotation segment label))
886 ;;; Called by the EMIT-ALIGNMENT macro to emit an alignment note. We check to
887 ;;; see if we can guarantee the alignment restriction by just outputting a
888 ;;; fixed number of bytes. If so, we do so. Otherwise, we create and emit an
889 ;;; alignment note.
890 (defun %emit-alignment (segment vop bits &optional (pattern 0))
891 (when (segment-run-scheduler segment)
892 (schedule-pending-instructions segment))
893 (let ((hook (segment-inst-hook segment)))
894 (when hook
895 (funcall hook segment vop :align bits)))
896 (let ((alignment (segment-alignment segment))
897 (offset (- (segment-current-posn segment)
898 (segment-sync-posn segment))))
899 (cond ((> bits alignment)
900 ;; We need more bits of alignment. Emit an alignment note.
901 ;; The ALIGNMENT many least significant bits of (- OFFSET)
902 ;; give the amount of bytes to skip to get back in sync with
903 ;; ALIGNMENT, and one-bits to the left of that up to position
904 ;; BITS provide the remaining amount.
905 (let ((size (deposit-field (- offset)
906 (byte 0 alignment)
907 (1- (ash 1 bits)))))
908 (aver (> size 0))
909 (emit-annotation segment (make-alignment bits size pattern))
910 (emit-skip segment size pattern))
911 (setf (segment-alignment segment) bits)
912 (setf (segment-sync-posn segment) (segment-current-posn segment)))
914 ;; The last alignment was more restrictive than this one.
915 ;; So we can just figure out how much noise to emit
916 ;; assuming the last alignment was met.
917 (let* ((mask (1- (ash 1 bits)))
918 (new-offset (logand (+ offset mask) (lognot mask))))
919 (emit-skip segment (- new-offset offset) pattern))
920 ;; But we emit an alignment with size=0 so we can verify
921 ;; that everything works.
922 (emit-annotation segment (make-alignment bits 0 pattern)))))
923 (values))
925 ;;; This is used to find how ``aligned'' different offsets are.
926 ;;; Returns the number of low-order 0 bits, up to MAX-ALIGNMENT.
927 (defun find-alignment (offset)
928 (dotimes (i max-alignment max-alignment)
929 (when (logbitp i offset)
930 (return i))))
932 ;;; Emit a postit. The function will be called as a back-patch with
933 ;;; the position the following instruction is finally emitted. Postits
934 ;;; do not interfere at all with scheduling.
935 (defun %emit-postit (segment function)
936 (push function (segment-postits segment))
937 (values))
939 ;;;; output compression/position assignment stuff
941 ;;; Grovel though all the annotations looking for choosers. When we
942 ;;; find a chooser, invoke the maybe-shrink function. If it returns T,
943 ;;; it output some other byte sequence.
944 (defun compress-output (segment)
945 (dotimes (i 5) ; it better not take more than one or two passes.
946 (let ((delta 0))
947 (setf (segment-alignment segment) max-alignment)
948 (setf (segment-sync-posn segment) 0)
949 (do* ((prev nil)
950 (remaining (segment-annotations segment) next)
951 (next (cdr remaining) (cdr remaining)))
952 ((null remaining))
953 (let* ((note (car remaining))
954 (posn (annotation-posn note)))
955 (unless (zerop delta)
956 (decf posn delta)
957 (setf (annotation-posn note) posn))
958 (cond
959 ((chooser-p note)
960 (with-modified-segment-index-and-posn (segment (chooser-index note)
961 posn)
962 (setf (segment-last-annotation segment) prev)
963 (cond
964 ((funcall (chooser-maybe-shrink note) segment posn delta)
965 ;; It emitted some replacement.
966 (let ((new-size (- (segment-current-index segment)
967 (chooser-index note)))
968 (old-size (chooser-size note)))
969 (when (> new-size old-size)
970 (error "~S emitted ~W bytes, but claimed its max was ~W."
971 note new-size old-size))
972 (let ((additional-delta (- old-size new-size)))
973 (when (< (find-alignment additional-delta)
974 (chooser-alignment note))
975 (error "~S shrunk by ~W bytes, but claimed that it ~
976 preserves ~W bits of alignment."
977 note additional-delta (chooser-alignment note)))
978 (incf delta additional-delta)
979 (emit-filler segment additional-delta))
980 (setf prev (segment-last-annotation segment))
981 (if prev
982 (setf (cdr prev) (cdr remaining))
983 (setf (segment-annotations segment)
984 (cdr remaining)))))
986 ;; The chooser passed on shrinking. Make sure it didn't
987 ;; emit anything.
988 (unless (= (segment-current-index segment)
989 (chooser-index note))
990 (error "Chooser ~S passed, but not before emitting ~W bytes."
991 note
992 (- (segment-current-index segment)
993 (chooser-index note))))
994 ;; Act like we just emitted this chooser.
995 (let ((size (chooser-size note)))
996 (incf (segment-current-index segment) size)
997 (incf (segment-current-posn segment) size))
998 ;; Adjust the alignment accordingly.
999 (adjust-alignment-after-chooser segment note)
1000 ;; And keep this chooser for next time around.
1001 (setf prev remaining)))))
1002 ((alignment-p note)
1003 (unless (zerop (alignment-size note))
1004 ;; Re-emit the alignment, letting it collapse if we know
1005 ;; anything more about the alignment guarantees of the
1006 ;; segment.
1007 (let ((index (alignment-index note)))
1008 (with-modified-segment-index-and-posn (segment index posn)
1009 (setf (segment-last-annotation segment) prev)
1010 (%emit-alignment segment nil (alignment-bits note)
1011 (alignment-pattern note))
1012 (let* ((new-index (segment-current-index segment))
1013 (size (- new-index index))
1014 (old-size (alignment-size note))
1015 (additional-delta (- old-size size)))
1016 (when (minusp additional-delta)
1017 (error "Alignment ~S needs more space now? It was ~W, ~
1018 and is ~W now."
1019 note old-size size))
1020 (when (plusp additional-delta)
1021 (emit-filler segment additional-delta)
1022 (incf delta additional-delta)))
1023 (setf prev (segment-last-annotation segment))
1024 (if prev
1025 (setf (cdr prev) (cdr remaining))
1026 (setf (segment-annotations segment)
1027 (cdr remaining)))))))
1029 (setf prev remaining)))))
1030 (when (zerop delta)
1031 (return))
1032 (decf (segment-final-posn segment) delta)))
1033 (values))
1035 ;;; We have run all the choosers we can, so now we have to figure out
1036 ;;; exactly how much space each alignment note needs.
1037 (defun finalize-positions (segment)
1038 (let ((delta 0))
1039 (do* ((prev nil)
1040 (remaining (segment-annotations segment) next)
1041 (next (cdr remaining) (cdr remaining)))
1042 ((null remaining))
1043 (let* ((note (car remaining))
1044 (posn (- (annotation-posn note) delta)))
1045 (cond
1046 ((alignment-p note)
1047 (let* ((bits (alignment-bits note))
1048 (mask (1- (ash 1 bits)))
1049 (new-posn (logand (+ posn mask) (lognot mask)))
1050 (size (- new-posn posn))
1051 (old-size (alignment-size note))
1052 (additional-delta (- old-size size)))
1053 (aver (<= 0 size old-size))
1054 (unless (zerop additional-delta)
1055 (setf (segment-last-annotation segment) prev)
1056 (incf delta additional-delta)
1057 (with-modified-segment-index-and-posn (segment
1058 (alignment-index note)
1059 posn)
1060 (when (eql (alignment-pattern note) :long-nop)
1061 ;; We need to re-emit the alignment because a shorter
1062 ;; multi-byte NOP pattern is most of the time not a
1063 ;; prefix of a longer one.
1064 (emit-skip segment size (alignment-pattern note)))
1065 (emit-filler segment additional-delta)
1066 (setf prev (segment-last-annotation segment))
1067 (if prev
1068 (setf (cdr prev) next)
1069 (setf (segment-annotations segment) next))))))
1071 (setf (annotation-posn note) posn)
1072 (setf prev remaining)
1073 (setf next (cdr remaining))))))
1074 (unless (zerop delta)
1075 (decf (segment-final-posn segment) delta)))
1076 (values))
1078 ;;; Grovel over segment, filling in any backpatches. If any choosers
1079 ;;; are left over, we need to emit their worst case variant.
1080 (defun process-back-patches (segment)
1081 (do* ((prev nil)
1082 (remaining (segment-annotations segment) next)
1083 (next (cdr remaining) (cdr remaining)))
1084 ((null remaining))
1085 (let ((note (car remaining)))
1086 (flet ((fill-in (function old-size)
1087 (let ((index (annotation-index note))
1088 (posn (annotation-posn note)))
1089 (with-modified-segment-index-and-posn (segment index posn)
1090 (setf (segment-last-annotation segment) prev)
1091 (funcall function segment posn)
1092 (let ((new-size (- (segment-current-index segment) index)))
1093 (unless (= new-size old-size)
1094 (error "~S emitted ~W bytes, but claimed it was ~W."
1095 note new-size old-size)))
1096 (let ((tail (segment-last-annotation segment)))
1097 (if tail
1098 (setf (cdr tail) next)
1099 (setf (segment-annotations segment) next)))
1100 (setf next (cdr prev))))))
1101 (cond ((back-patch-p note)
1102 (fill-in (back-patch-fun note)
1103 (back-patch-size note)))
1104 ((chooser-p note)
1105 (fill-in (chooser-worst-case-fun note)
1106 (chooser-size note)))
1108 (setf prev remaining)))))))
1110 ;;; Replace the SEGMENT-BUFFER of SEGMENT with a vector that contains
1111 ;;; only the valid content of the original buffer, that is, the parts
1112 ;;; not covered by fillers. Set FINAL-INDEX of SEGMENT to the length
1113 ;;; of the new vector and return this length.
1114 (defun compact-segment-buffer (segment)
1115 (let ((buffer (segment-buffer segment))
1116 (new-buffer (make-array (segment-final-posn segment)
1117 :element-type 'assembly-unit))
1118 (i0 0)
1119 (index 0))
1120 (declare (type (simple-array assembly-unit 1) buffer)
1121 (type index index))
1122 (flet ((frob (i0 i1)
1123 (when (< i0 i1)
1124 (replace new-buffer buffer :start1 index :start2 i0 :end2 i1)
1125 (incf index (- i1 i0)))))
1126 (dolist (note (segment-annotations segment))
1127 (when (filler-p note)
1128 (let ((i1 (filler-index note)))
1129 (frob i0 i1)
1130 (setf i0 (+ i1 (filler-bytes note))))))
1131 (frob i0 (segment-final-index segment)))
1132 (aver (= index (segment-final-posn segment)))
1133 (setf (segment-buffer segment) new-buffer)
1134 (setf (segment-final-index segment) (segment-final-posn segment))))
1137 ;;;; interface to the rest of the compiler
1139 ;;; This holds the current segment while assembling. Use ASSEMBLE to
1140 ;;; change it.
1142 ;;; The double asterisks in the name are intended to suggest that this
1143 ;;; isn't just any old special variable, it's an extra-special
1144 ;;; variable, because sometimes MACROLET is used to bind it. So be
1145 ;;; careful out there..
1147 ;;; (This used to be called **CURRENT-SEGMENT** in SBCL until 0.7.3,
1148 ;;; and just *CURRENT-SEGMENT* in CMU CL. In both cases, the rebinding
1149 ;;; now done with MACROLET was done with SYMBOL-MACROLET instead. The
1150 ;;; rename-with-double-asterisks was because the SYMBOL-MACROLET made
1151 ;;; it an extra-special variable. The change over to
1152 ;;; %%CURRENT-SEGMENT%% was because ANSI forbids the use of
1153 ;;; SYMBOL-MACROLET on special variable names, and CLISP correctly
1154 ;;; complains about this when being used as a bootstrap host.)
1155 (defmacro %%current-segment%% () '**current-segment**)
1156 (defvar **current-segment**)
1158 ;;; Just like %%CURRENT-SEGMENT%%, except this holds the current vop.
1159 ;;; This is used only to keep track of which vops emit which insts.
1161 ;;; The double asterisks in the name are intended to suggest that this
1162 ;;; isn't just any old special variable, it's an extra-special
1163 ;;; variable, because sometimes MACROLET is used to bind it. So be
1164 ;;; careful out there..
1165 (defmacro %%current-vop%% () '**current-vop**)
1166 (defvar **current-vop** nil)
1168 ;;; We also MACROLET %%CURRENT-SEGMENT%% to a local holding the
1169 ;;; segment so uses of %%CURRENT-SEGMENT%% inside the body don't have
1170 ;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
1171 ;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
1172 ;;; special value becomming out of sync with the lexical value. Unless
1173 ;;; some bozo closes over it, but nobody does anything like that...
1174 (defmacro assemble ((&optional segment vop &key labels) &body body
1175 &environment env)
1176 #!+sb-doc
1177 "Execute BODY (as a progn) with SEGMENT as the current segment."
1178 (flet ((label-name-p (thing)
1179 (and thing (symbolp thing))))
1180 (let* ((seg-var (gensym "SEGMENT-"))
1181 (vop-var (gensym "VOP-"))
1182 (visible-labels (remove-if-not #'label-name-p body))
1183 (inherited-labels
1184 (multiple-value-bind (expansion expanded)
1185 (#+sb-xc-host cl:macroexpand
1186 #-sb-xc-host %macroexpand '..inherited-labels.. env)
1187 (if expanded (copy-list expansion) nil)))
1188 (new-labels
1189 (sort (append labels
1190 (set-difference visible-labels
1191 inherited-labels))
1192 #'string<))
1193 (nested-labels
1194 (sort (set-difference (append inherited-labels new-labels)
1195 visible-labels)
1196 #'string<)))
1197 (when (intersection labels inherited-labels)
1198 (error "duplicate nested labels: ~S"
1199 (intersection labels inherited-labels)))
1200 `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
1201 (,vop-var ,(or vop '(%%current-vop%%)))
1202 ,@(when segment
1203 `((**current-segment** ,seg-var)))
1204 ,@(when vop
1205 `((**current-vop** ,vop-var)))
1206 ,@(mapcar (lambda (name)
1207 `(,name (gen-label)))
1208 new-labels))
1209 (declare (ignorable ,vop-var ,seg-var)
1210 ;; Must be done so that contribs and user code doing
1211 ;; low-level stuff don't need to worry about this.
1212 (disable-package-locks %%current-segment%% %%current-vop%%))
1213 (macrolet ((%%current-segment%% () ',seg-var)
1214 (%%current-vop%% () ',vop-var))
1215 ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
1216 ;; can't deal with this declaration, so disable it on host.
1217 ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration.
1218 #-sb-xc-host
1219 (declare (enable-package-locks %%current-segment%% %%current-vop%%))
1220 (symbol-macrolet (,@(when (or inherited-labels nested-labels)
1221 `((..inherited-labels.. ,nested-labels))))
1222 ,@(mapcar (lambda (form)
1223 (if (label-name-p form)
1224 `(emit-label ,form)
1225 form))
1226 body)))))))
1228 (defun inst-emitter-symbol (symbol &optional create)
1229 (values (funcall (if create 'intern 'find-symbol)
1230 (string-downcase symbol)
1231 *backend-instruction-set-package*)))
1233 (defmacro inst (instruction &rest args &environment env)
1234 #!+sb-doc
1235 "Emit the specified instruction to the current segment."
1236 (let* ((stringablep (typep instruction '(or symbol string character)))
1237 (sym (and stringablep (inst-emitter-symbol instruction))))
1238 (if (#-sb-xc macro-function #+sb-xc sb!xc:macro-function sym env)
1239 `(,sym ,@args)
1240 ;; An ordinary style-warning suffices to indicate missing emitters.
1241 `(,@(if stringablep `(,sym) `(funcall (inst-emitter-symbol ,instruction)))
1242 (%%current-segment%%) (%%current-vop%%) ,@args))))
1244 ;;; Note: The need to capture MACROLET bindings of %%CURRENT-SEGMENT%%
1245 ;;; and %%CURRENT-VOP%% prevents this from being an ordinary function.
1246 (defmacro emit-label (label)
1247 #!+sb-doc
1248 "Emit LABEL at this location in the current segment."
1249 `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
1251 ;;; Note: The need to capture MACROLET bindings of
1252 ;;; %%CURRENT-SEGMENT%% prevents this from being an ordinary function.
1253 (defmacro emit-postit (function)
1254 `(%emit-postit (%%current-segment%%) ,function))
1256 ;;; Note: The need to capture SYMBOL-MACROLET bindings of
1257 ;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
1258 ;;; ordinary function.
1259 (defmacro emit-alignment (bits &optional (pattern 0))
1260 #!+sb-doc
1261 "Emit an alignment restriction to the current segment."
1262 `(%emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,pattern))
1264 (defun label-position (label &optional if-after delta)
1265 #!+sb-doc
1266 "Return the current position for LABEL. Chooser maybe-shrink functions
1267 should supply IF-AFTER and DELTA in order to ensure correct results."
1268 (let ((posn (label-posn label)))
1269 (if (and if-after (> posn if-after))
1270 (- posn delta)
1271 posn)))
1273 (defun append-segment (segment other-segment)
1274 #!+sb-doc
1275 "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT
1276 for anything after this."
1277 (when (segment-run-scheduler segment)
1278 (schedule-pending-instructions segment))
1279 (let ((postits (segment-postits segment)))
1280 (setf (segment-postits segment) (segment-postits other-segment))
1281 (dolist (postit postits)
1282 (emit-back-patch segment 0 postit)))
1283 #!-(or x86 x86-64)
1284 (%emit-alignment segment nil max-alignment)
1285 #!+(or x86 x86-64)
1286 (unless (eq :elsewhere (segment-type other-segment))
1287 (%emit-alignment segment nil max-alignment))
1288 (let ((segment-current-index-0 (segment-current-index segment))
1289 (segment-current-posn-0 (segment-current-posn segment)))
1290 (incf (segment-current-index segment)
1291 (segment-current-index other-segment))
1292 (replace (segment-buffer segment)
1293 (segment-buffer other-segment)
1294 :start1 segment-current-index-0)
1295 (setf (segment-buffer other-segment) nil) ; to prevent accidental reuse
1296 (incf (segment-current-posn segment)
1297 (segment-current-posn other-segment))
1298 (let ((other-annotations (segment-annotations other-segment)))
1299 (when other-annotations
1300 (dolist (note other-annotations)
1301 (incf (annotation-index note) segment-current-index-0)
1302 (incf (annotation-posn note) segment-current-posn-0))
1303 ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
1304 ;; worth enough in efficiency to justify it? -- WHN 19990322
1305 (let ((last (segment-last-annotation segment)))
1306 (if last
1307 (setf (cdr last) other-annotations)
1308 (setf (segment-annotations segment) other-annotations)))
1309 (setf (segment-last-annotation segment)
1310 (segment-last-annotation other-segment)))))
1311 (values))
1313 (defun finalize-segment (segment)
1314 #!+sb-doc
1315 "Do any final processing of SEGMENT and return the total number of bytes
1316 covered by this segment."
1317 (when (segment-run-scheduler segment)
1318 (schedule-pending-instructions segment))
1319 (setf (segment-run-scheduler segment) nil)
1320 (let ((postits (segment-postits segment)))
1321 (setf (segment-postits segment) nil)
1322 (dolist (postit postits)
1323 (emit-back-patch segment 0 postit)))
1324 (setf (segment-final-index segment) (segment-current-index segment))
1325 (setf (segment-final-posn segment) (segment-current-posn segment))
1326 (setf (segment-inst-hook segment) nil)
1327 (compress-output segment)
1328 (finalize-positions segment)
1329 (process-back-patches segment)
1330 (compact-segment-buffer segment))
1332 ;;; Return the contents of SEGMENT as a vector. We assume SEGMENT has
1333 ;;; been finalized so that we can simply return its buffer.
1334 (defun segment-contents-as-vector (segment)
1335 (declare (type segment segment))
1336 (aver (= (segment-final-index segment) (segment-final-posn segment)))
1337 (segment-buffer segment))
1339 ;;; Write the code accumulated in SEGMENT to STREAM, and return the
1340 ;;; number of bytes written. We assume that SEGMENT has been finalized.
1341 (defun write-segment-contents (segment stream)
1342 (declare (type segment segment))
1343 (let ((v (segment-contents-as-vector segment)))
1344 (declare (type (simple-array assembly-unit 1) v))
1345 (length (write-sequence v stream))))
1348 ;;;; interface to the instruction set definition
1350 ;;; Define a function named NAME that merges its arguments into a
1351 ;;; single integer and then emits the bytes of that integer in the
1352 ;;; correct order based on the endianness of the target-backend.
1353 (defmacro define-bitfield-emitter (name total-bits &rest byte-specs)
1354 (sb!int:collect ((arg-names) (arg-types))
1355 (let* ((total-bits (eval total-bits))
1356 (overall-mask (ash -1 total-bits))
1357 (num-bytes (multiple-value-bind (quo rem)
1358 (truncate total-bits assembly-unit-bits)
1359 (unless (zerop rem)
1360 (error "~W isn't an even multiple of ~W."
1361 total-bits assembly-unit-bits))
1362 quo))
1363 (bytes (make-array num-bytes :initial-element nil))
1364 (segment-arg (sb!xc:gensym "SEGMENT-")))
1365 (dolist (byte-spec-expr byte-specs)
1366 (let* ((byte-spec (eval byte-spec-expr))
1367 (byte-size (byte-size byte-spec))
1368 (byte-posn (byte-position byte-spec))
1369 (arg (sb!xc:gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
1370 (when (ldb-test (byte byte-size byte-posn) overall-mask)
1371 (error "The byte spec ~S either overlaps another byte spec, or ~
1372 extends past the end."
1373 byte-spec-expr))
1374 (setf (ldb byte-spec overall-mask) -1)
1375 (arg-names arg)
1376 (arg-types `(type (integer ,(ash -1 (1- byte-size))
1377 ,(1- (ash 1 byte-size)))
1378 ,arg))
1379 (multiple-value-bind (start-byte offset)
1380 (floor byte-posn assembly-unit-bits)
1381 (let ((end-byte (floor (1- (+ byte-posn byte-size))
1382 assembly-unit-bits)))
1383 (flet ((maybe-ash (expr offset)
1384 (if (zerop offset)
1385 expr
1386 `(ash ,expr ,offset))))
1387 (declare (inline maybe-ash))
1388 (cond ((zerop byte-size))
1389 ((= start-byte end-byte)
1390 (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
1391 offset)
1392 (svref bytes start-byte)))
1394 (push (maybe-ash
1395 `(ldb (byte ,(- assembly-unit-bits offset) 0)
1396 ,arg)
1397 offset)
1398 (svref bytes start-byte))
1399 (do ((index (1+ start-byte) (1+ index)))
1400 ((>= index end-byte))
1401 (push
1402 `(ldb (byte ,assembly-unit-bits
1403 ,(- (* assembly-unit-bits
1404 (- index start-byte))
1405 offset))
1406 ,arg)
1407 (svref bytes index)))
1408 (let ((len (rem (+ byte-size offset)
1409 assembly-unit-bits)))
1410 (push
1411 `(ldb (byte ,(if (zerop len)
1412 assembly-unit-bits
1413 len)
1414 ,(- (* assembly-unit-bits
1415 (- end-byte start-byte))
1416 offset))
1417 ,arg)
1418 (svref bytes end-byte))))))))))
1419 (unless (= overall-mask -1)
1420 (error "There are holes."))
1421 (let ((forms nil))
1422 (dotimes (i num-bytes)
1423 (let ((pieces (svref bytes i)))
1424 (aver pieces)
1425 (push `(emit-byte ,segment-arg
1426 ,(if (cdr pieces)
1427 `(logior ,@pieces)
1428 (car pieces)))
1429 forms)))
1430 `(defun ,name (,segment-arg ,@(arg-names))
1431 (declare (type segment ,segment-arg) ,@(arg-types))
1432 ,@(ecase sb!c:*backend-byte-order*
1433 (:little-endian (nreverse forms))
1434 (:big-endian forms))
1435 ',name)))))
1437 ;;; Return a list of forms involving VALUES that will pass the arguments from
1438 ;;; LAMBA-LIST by way of MULTIPLE-VALUE-CALL. Secondary value is the augmented
1439 ;;; lambda-list which has a supplied-p var for every &OPTIONAL and &KEY arg.
1440 (defun make-arglist-forwarder (lambda-list)
1441 (multiple-value-bind (llks required optional rest keys aux)
1442 (parse-lambda-list lambda-list)
1443 (collect ((reconstruction))
1444 (flet ((augment (spec var def sup-p var-maker arg-passing-form)
1445 (multiple-value-bind (sup-p new-spec)
1446 (if sup-p
1447 (values (car sup-p) spec)
1448 (let ((sup-p (copy-symbol var)))
1449 (values sup-p `(,(funcall var-maker) ,def ,sup-p))))
1450 (reconstruction `(if ,sup-p ,arg-passing-form (values)))
1451 new-spec)))
1452 (setq optional ; Ensure that each &OPTIONAL arg has a supplied-p var.
1453 (mapcar (lambda (spec)
1454 (multiple-value-bind (var def sup)
1455 (parse-optional-arg-spec spec)
1456 (augment spec var def sup (lambda () var) var)))
1457 optional))
1458 (unless (ll-kwds-restp llks)
1459 (setq keys ; Do the same for &KEY, unless &REST is present.
1460 (mapcar (lambda (spec)
1461 (multiple-value-bind (key var def sup)
1462 (parse-key-arg-spec spec)
1463 (augment spec var def sup
1464 (lambda ()
1465 (if (eq (keywordicate var) key)
1467 `(,key ,var)))
1468 `(values ',key ,var))))
1469 keys))))
1470 (values `(,@required ,@(reconstruction) ,@(if rest `((values-list ,@rest))))
1471 (make-lambda-list llks nil required optional rest keys aux)))))
1473 (defmacro define-instruction (name lambda-list &rest options)
1474 (binding* ((sym-name (symbol-name name))
1475 (defun-name (inst-emitter-symbol sym-name t))
1476 (segment-name (car lambda-list))
1477 (vop-name nil)
1478 (postits (gensym "POSTITS-"))
1479 (emitter nil)
1480 (decls nil)
1481 (attributes nil)
1482 (cost nil)
1483 (dependencies nil)
1484 (delay nil)
1485 (pinned nil)
1486 (pdefs nil)
1487 ((arg-reconstructor new-lambda-list)
1488 (make-arglist-forwarder (cdr lambda-list))))
1489 (dolist (option-spec options)
1490 (multiple-value-bind (option args)
1491 (if (consp option-spec)
1492 (values (car option-spec) (cdr option-spec))
1493 (values option-spec nil))
1494 (case option
1495 (:emitter
1496 (when emitter
1497 (error "You can only specify :EMITTER once per instruction."))
1498 (setf emitter args))
1499 (:declare
1500 (setf decls (append decls args)))
1501 (:attributes
1502 (setf attributes (append attributes args)))
1503 (:cost
1504 (setf cost (first args)))
1505 (:dependencies
1506 (setf dependencies (append dependencies args)))
1507 (:delay
1508 (when delay
1509 (error "You can only specify :DELAY once per instruction."))
1510 (setf delay args))
1511 (:pinned
1512 (setf pinned t))
1513 (:vop-var
1514 (if vop-name
1515 (error "You can only specify :VOP-VAR once per instruction.")
1516 (setf vop-name (car args))))
1517 (:printer
1518 (let* ((inst-args (second args))
1519 (names (mapcar #'car inst-args)))
1520 (when (> (length names) (length (remove-duplicates names)))
1521 (error "Duplicate operand names in ~S~%" args)))
1522 (destructuring-bind (name operands . options) args
1523 (push ``(,',name (,,@(mapcar (lambda (x) ``(,',(car x) ,,@(cdr x)))
1524 operands))
1525 ,,@options) pdefs)))
1527 (error "unknown option: ~S" option)))))
1528 (unless vop-name
1529 (setq vop-name (make-symbol "VOP")))
1530 (when emitter
1531 (push `(let ((hook (segment-inst-hook ,segment-name)))
1532 (when hook
1533 (multiple-value-call hook ,segment-name ,vop-name ,sym-name
1534 ,@arg-reconstructor)))
1535 emitter)
1536 (push `(dolist (postit ,postits)
1537 (emit-back-patch ,segment-name 0 postit))
1538 emitter)
1539 (unless cost (setf cost 1))
1540 #!+sb-dyncount
1541 (push `(when (segment-collect-dynamic-statistics ,segment-name)
1542 (let* ((info (sb!c:ir2-component-dyncount-info
1543 (sb!c:component-info
1544 sb!c:*component-being-compiled*)))
1545 (costs (sb!c:dyncount-info-costs info))
1546 (block-number (sb!c:block-number
1547 (sb!c:ir2-block-block
1548 (sb!c:vop-block ,vop-name)))))
1549 (incf (aref costs block-number) ,cost)))
1550 emitter)
1551 (when *assem-scheduler-p*
1552 (if pinned
1553 (setf emitter
1554 `((when (segment-run-scheduler ,segment-name)
1555 (schedule-pending-instructions ,segment-name))
1556 ,@emitter))
1557 (let ((flet-name
1558 (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
1559 (inst-name (gensym "INST-")))
1560 (setf emitter `((flet ((,flet-name (,segment-name)
1561 ,@emitter))
1562 (if (segment-run-scheduler ,segment-name)
1563 (let ((,inst-name
1564 (make-instruction
1565 (incf (segment-inst-number
1566 ,segment-name))
1567 #',flet-name
1568 (instruction-attributes
1569 ,@attributes)
1570 (progn ,@delay))))
1571 ,@(when dependencies
1572 `((note-dependencies
1573 (,segment-name ,inst-name)
1574 ,@dependencies)))
1575 (queue-inst ,segment-name ,inst-name))
1576 (,flet-name ,segment-name)))))))))
1577 `(progn
1578 #-sb-xc-host ; The disassembler is not used on the host.
1579 (setf (get ',defun-name 'sb!disassem::instruction-flavors)
1580 (list ,@pdefs))
1581 ,(when emitter
1582 `(defun ,defun-name (,segment-name ,vop-name ,@new-lambda-list)
1583 ,@(when decls
1584 `((declare ,@decls)))
1585 (let ((,postits (segment-postits ,segment-name)))
1586 ;; Must be done so that contribs and user code doing
1587 ;; low-level stuff don't need to worry about this.
1588 (declare (disable-package-locks %%current-segment%%))
1589 (setf (segment-postits ,segment-name) nil)
1590 (macrolet ((%%current-segment%% ()
1591 (error "You can't use INST without an ~
1592 ASSEMBLE inside emitters.")))
1593 ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
1594 ;; can't deal with this declaration, so disable it on host
1595 ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%%
1596 ;; declaration.
1597 #-sb-xc-host
1598 (declare (enable-package-locks %%current-segment%%))
1599 ,@emitter))
1600 (values))))))
1602 (defmacro define-instruction-macro (name lambda-list &body body)
1603 `(defmacro ,(inst-emitter-symbol (symbol-name name) t) ,lambda-list ,@body))