src/compiler/assem.lisp

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