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