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