From 61b0dc6bc8291e7480c3f89f4ed1ee06c3c885a9 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Mon, 18 May 1992 17:56:10 +0000
Subject: [PATCH] Initial revision

---
 compiler/new-assem.lisp | 1556 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 1556 insertions(+)
 create mode 100644 compiler/new-assem.lisp

diff --git a/compiler/new-assem.lisp b/compiler/new-assem.lisp
new file mode 100644
index 000000000..67fe7ac0e
--- /dev/null
+++ b/compiler/new-assem.lisp
@@ -0,0 +1,1556 @@
+;;; -*- Package: NEW-ASSEM -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/new-assem.lisp,v 1.1 1992/05/18 17:56:10 wlott Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; Effecient retargetable scheduling assembler.
+;;;
+;;; Written by William Lott.
+;;;
+(in-package :new-assem)
+
+(export '(emit-byte emit-skip emit-back-patch emit-chooser
+	  define-emitter define-instruction define-instruction-macro
+	  def-assembler-params
+
+	  make-segment segment-name assemble align inst
+	  label label-p gen-label emit-label label-position
+	  append-segment finalize-segment
+	  segment-map-output release-segment))
+
+
+;;;; Assembly control parameters.
+
+(defstruct (assem-params
+	    (:print-function %print-assem-params))
+  (backend (ext:required-argument) :type c::backend)
+  (scheduler-p nil :type (member t nil))
+  (instructions (make-hash-table :test #'equal) :type hash-table))
+;;;
+(c::defprinter assem-params
+  (backend :prin1 (c:backend-name backend)))
+
+;;; DEF-ASSEMBLER-PARAMS -- Interface.
+;;;
+(defmacro def-assembler-params (&rest options)
+  "Set up the assembler."
+  `(eval-when (compile load eval)
+     (setf (c:backend-assembler-params c:*target-backend*)
+	   (make-assem-params :backend c:*target-backend*
+			      ,@options))))
+
+
+;;;; Constants.
+
+;;; ASSEMBLY-UNIT-BITS -- Number of bits in the minimum assembly unit,
+;;; (also refered to as a ``byte'').  Hopefully, different instruction
+;;; sets won't require chainging this.
+;;; 
+(defconstant assembly-unit-bits 8)
+
+(deftype assembly-unit ()
+  `(unsigned-byte ,assembly-unit-bits))
+
+;;; OUTPUT-BLOCK-SIZE -- The size (in bytes) to use per output block.  Each
+;;; output block is a chunk of raw memory, pointed to by a sap.
+;;;
+(defconstant output-block-size (* 8 1024))
+
+(deftype output-block-index ()
+  `(integer 0 ,output-block-size))
+
+;;; MAX-ALIGNMENT -- The maximum alignment we can guarentee given the object
+;;; format.  If the loader only loads objects 8-byte aligned, we can't do
+;;; any better then that ourselves.
+;;;
+(defconstant max-alignment 3)
+
+(deftype alignment ()
+  `(integer 0 ,max-alignment))
+
+;;; MAX-INDEX -- The maximum an index will ever become.  Well, actually,
+;;; just a bound on it so we can define a type.  There is no real hard
+;;; limit on indexes, but we will run out of memory sometime.
+;;; 
+(defconstant max-index (1- most-positive-fixnum))
+
+(deftype index ()
+  `(integer 0 ,max-index))
+
+;;; MAX-POSN -- Like MAX-INDEX, except for positions.
+;;; 
+(defconstant max-posn (1- most-positive-fixnum))
+
+(deftype posn ()
+  `(integer 0 ,max-posn))
+
+
+
+;;;; The SEGMENT structure.
+
+;;; SEGMENT -- This structure holds the state of the assembler.
+;;; 
+(defstruct (segment
+	    (:print-function %print-segment)
+	    (:constructor make-segment (&key name run-scheduler inst-hook)))
+  ;;
+  ;; The name of this segment.  Only using in trace files.
+  (name "Unnamed" :type simple-base-string)
+  ;;
+  ;; Wether or not run the scheduler.  Note: if the instruction defintions
+  ;; were not compiled with the scheduler turned on, this has no effect.
+  (run-scheduler nil)
+  ;;
+  ;; If a function, then it is funcalled for each inst emitted with the
+  ;; segment, the VOP, the name of the inst (as a string), and the inst
+  ;; arguments.
+  (inst-hook nil :type (or function null))
+  ;;
+  ;; Where to deposit the next byte.
+  (fill-pointer (system:int-sap 0) :type system:system-area-pointer)
+  ;;
+  ;; Where the current output block ends.  If fill-pointer is ever sap= to
+  ;; this, don't deposit a byte.  Move the fill pointer into a new block.
+  (block-end (system:int-sap 0) :type system:system-area-pointer)
+  ;;
+  ;; What position does this correspond to.  Initially, positions and indexes
+  ;; are the same, but after we start collapsing choosers, positions can change
+  ;; while indexes stay the same.
+  (current-posn 0 :type posn)
+  ;;
+  ;; Were in the output blocks are we currently outputing.
+  (current-index 0 :type index)
+  ;;
+  ;; A vector of the output blocks.
+  (output-blocks (make-array 4 :initial-element nil) :type simple-vector)
+  ;;
+  ;; A list of all the annotations that have been output to this segment.
+  (annotations nil :type list)
+  ;;
+  ;; A pointer to the last cons cell in the annotations list.  This is
+  ;; so we can quickly add things to the end of the annotations list.
+  (last-annotation nil :type list)
+  ;;
+  ;; The number of bits of alignment at the last time we synchronized.
+  (alignment max-alignment :type alignment)
+  ;;
+  ;; The position the last time we synchronized.
+  (sync-posn 0 :type posn)
+  ;;
+  ;; The posn and index everything ends at.  This is not maintained while the
+  ;; data is being generated, but is filled in after.  Basically, we copy
+  ;; current-posn and current-index so that we can trash them while processing
+  ;; choosers and back-patches.
+  (final-posn 0 :type posn)
+  (final-index 0 :type index)
+  ;;
+  ;; *** State used by the scheduler during instruction queueing.
+  ;;
+  ;; A-lists mapping locations to the instruction that reads them and
+  ;; instructions that write them.  If maintaining these as a-lists is
+  ;; too expensive (consing, time, or whatever) we could represent this
+  ;; information in a slot in the location.  But then the scheduler would not
+  ;; be re-enterent.
+  (readers nil :type list)
+  (writers nil :type list)
+  ;;
+  ;; The number of additional cycles before the next control transfer, or NIL
+  ;; if a control transfer hasn't been queued.  When a delayed branch is
+  ;; queued, this slot is set to the delay count.
+  (branch-countdown nil :type (or null (and fixnum unsigned-byte)))
+  ;;
+  ;; *** These two slots are used both by the queuing noise and the
+  ;; scheduling noise.
+  ;;
+  ;; A list of all the instructions that are pending and don't have any
+  ;; unresolved dependents.  We don't list branches here even if they would
+  ;; otherwise qualify.  They are listed above.
+  ;;
+  (emittable-insts nil :type list)
+  ;;
+  ;; List of queued branches.  We handle these specially, because they have to
+  ;; be emitted at a specific place (e.g. one slot before the end of the
+  ;; block).
+  (queued-branches nil :type list)
+  ;;
+  ;; *** State used by the scheduler duing instruction scheduling.
+  ;;
+  ;; The instructions who would have had a read dependent removed if it were
+  ;; not for a delay slot.  This is a list of lists.  Each element in the
+  ;; top level list corresponds to yet another cycle of delay.  Each element
+  ;; in the second level lists is a dotted pair, holding the dependency
+  ;; instruction and the dependent to remove.
+  (delayed nil :type list))
+
+(c::defprinter segment name)
+
+
+;;;; Structures/types used by the scheduler.
+
+(c:def-boolean-attribute instruction
+  ;;
+  ;; This attribute is set if the scheduler can freely flush this instruction
+  ;; if it thinks it is not needed.  Examples are NOP and instructions that
+  ;; have no side effect not described by the writes.
+  flushable
+  ;;
+  ;; This attribute is set when an instruction can cause a control transfer.
+  ;; For test instructions, the delay is used to determine how many
+  ;; instructions follow the branch.
+  branch
+  )
+
+(defstruct (instruction
+	    (:print-function %print-instruction)
+	    (:conc-name inst-)
+	    (:constructor make-instruction (emitter attributes delay)))
+  ;;
+  ;; The function to envoke to actually emit this instruction.  Gets called
+  ;; with the segment as its one argument.
+  (emitter (required-argument) :type (or null function))
+  ;;
+  ;; The attributes of this instruction.
+  (attributes (instruction-attributes) :type c:attributes)
+  ;;
+  ;; Number of instructions or cycles of delay before additional instructions
+  ;; can read our writes.
+  (delay 0 :type (and fixnum unsigned-byte))
+  ;;
+  ;; The maximum number of instructions in the longest dependency chain from
+  ;; this instruction to one of the independent instructions.  This is used
+  ;; as a heuristic at to which instructions should be scheduled first.
+  (depth nil :type (or null (and fixnum unsigned-byte)))
+  ;;
+  ;; ** When trying remember which of the next four is which, note that the
+  ;; ``read'' or ``write'' always referes to the dependent (second)
+  ;; instruction.
+  ;;
+  ;; List of the instructions whos writes this instruction tries to read.
+  (read-dependencies nil :type list)
+  ;;
+  ;; List of the instructions whos writes or reads are overwritten by this
+  ;; instruction.
+  (write-dependencies nil :type list)
+  ;;
+  ;; List of the instructions who write what we read or write.
+  (write-dependents nil :type list)
+  ;;
+  ;; List of the instrucitons who read what we write.
+  (read-dependents nil :type list))
+;;;
+(defvar *inst-ids* (make-hash-table :test #'eq))
+(defvar *next-inst-id* 0)
+(defun %print-instruction (inst stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (inst stream :type t :identity t)
+    (princ (or (gethash inst *inst-ids*)
+	       (setf (gethash inst *inst-ids*)
+		     (incf *next-inst-id*)))
+	   stream)
+    (when (inst-depth inst)
+      (format stream ", depth=~D" (inst-depth inst)))))
+
+(defun reset-inst-ids ()
+  (clrhash *inst-ids*)
+  (setf *next-inst-id* 0))
+
+
+;;;; The scheduler itself.
+
+;;; WITHOUT-SCHEDULING -- interface.
+;;;
+(defmacro without-scheduling ((&optional (segment '*current-segment*))
+			      &body body)
+  "Execute BODY (as a progn) without scheduling any of the instructions
+   generated inside it.  DO NOT throw or return-from out of it."
+  (let ((var (gensym))
+	(seg (gensym)))
+    `(let* ((,seg ,segment)
+	    (,var (segment-run-scheduler ,seg)))
+       (when ,var
+	 (schedule-pending-instructions ,seg)
+	 (setf (segment-run-scheduler ,seg) nil))
+       ,@body
+       (setf (segment-run-scheduler ,seg) ,var))))
+
+;;; QUEUE-INST -- internal.
+;;;
+;;; This routine is called by due to uses of the INST macro when the scheduler
+;;; is turned on.  We compute the change to the dependency graph and check to
+;;; see if the basic block is terminated.
+;;; 
+(defun queue-inst (segment inst reads writes)
+  #+nil (format *trace-output* "Queuing ~S~%" inst)
+  (assert (segment-run-scheduler segment))
+  (let* ((writers (segment-writers segment))
+	 (readers (segment-readers segment))
+	 (read-dependencies nil)
+	 (write-dependencies nil)
+	 (emittable-insts (segment-emittable-insts segment)))
+    (dolist (read reads)
+      (let ((writer (assoc read writers :test #'eq)))
+	(when writer
+	  (let ((prev-inst (cdr writer)))
+	    (pushnew prev-inst read-dependencies)
+	    (pushnew inst (inst-read-dependents prev-inst))
+	    (setf emittable-insts
+		  (delete prev-inst emittable-insts :test #'eq)))))
+      (push (cons read inst) readers))
+    (dolist (write writes)
+      (let ((writer (assoc write writers :test #'eq)))
+	(when writer
+	  (let ((prev-inst (cdr writer)))
+	    (pushnew prev-inst write-dependencies)
+	    (pushnew inst (inst-write-dependents prev-inst))
+	    (setf emittable-insts
+		  (delete prev-inst emittable-insts :test #'eq)))
+	  (setf writers (delete writer writers :test #'eq))))
+      (let ((reader (assoc write readers :test #'eq)))
+	(when reader
+	  (let ((prev-inst (cdr reader)))
+	    (unless (eq prev-inst inst)
+	      (pushnew prev-inst write-dependencies)
+	      (pushnew inst (inst-write-dependents prev-inst))
+	      (setf emittable-insts
+		    (delete prev-inst emittable-insts :test #'eq)))
+	    (setf readers (delete reader readers :test #'eq))))))
+    #+nil
+    (when read-dependencies
+      (format *trace-output* "Reads values produced by ~:S.~%"
+	      read-dependencies))
+    #+nil
+    (when write-dependencies
+      (format *trace-output* "Writes values used by ~:S.~%"
+	      write-dependencies))
+    (setf (inst-read-dependencies inst) read-dependencies)
+    (setf (inst-write-dependencies inst) write-dependencies)
+    (dolist (read reads)
+      (push (cons read inst) readers))
+    (setf (segment-readers segment) readers)
+    (dolist (write writes)
+      (push (cons write inst) writers))
+    (setf (segment-writers segment) writers)
+    (let ((countdown (segment-branch-countdown segment)))
+      (cond ((instruction-attributep (inst-attributes inst) branch)
+	     (unless countdown
+	       (setf countdown (inst-delay inst)))
+	     (push (cons countdown inst)
+		   (segment-queued-branches segment)))
+	    (t
+	     (setf emittable-insts (cons inst emittable-insts))))
+      (setf (segment-emittable-insts segment) emittable-insts)
+      (when countdown
+	(if (minusp (decf countdown))
+	    (schedule-pending-instructions segment)
+	    (setf (segment-branch-countdown segment) countdown)))))
+  (ext:undefined-value))
+
+;;; SCHEDULE-PENDING-INSTRUCTIONS -- internal.
+;;;
+;;; Emit all the pending instructions, and reset any state.  This is called
+;;; whenever we hit a label (i.e. an entry point of some kind) and when the
+;;; user turns the scheduler off (otherwise, the queued instructions would
+;;; sit there until the scheduler was turned back on, and emitted in the
+;;; wrong place).
+;;; 
+(defun schedule-pending-instructions (segment)
+  (assert (segment-run-scheduler segment))
+  ;;
+  ;; Quick blow-out if nothing to do.
+  (unless (or (segment-emittable-insts segment)
+	      (segment-queued-branches segment))
+    (return-from schedule-pending-instructions
+		 (ext:undefined-value)))
+  ;;
+  ;; Grovel through the entire graph in the forward direction finding all
+  ;; the leaf instructions.
+  (labels ((grovel-inst (inst)
+	     (let ((write-deps (inst-write-dependencies inst))
+		   (read-deps (inst-read-dependencies inst))
+		   (max 0))
+	       (dolist (dep write-deps)
+		 (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
+		   (when (> dep-depth max)
+		     (setf max dep-depth))))
+	       (dolist (dep read-deps)
+		 (let ((dep-depth
+			(+ (or (inst-depth dep) (grovel-inst dep))
+			   (inst-delay dep))))
+		   (when (> dep-depth max)
+		     (setf max dep-depth))))
+	       (cond ((and (null (inst-read-dependents inst))
+			   (instruction-attributep (inst-attributes inst)
+						   flushable)
+			   (not (member inst (segment-writers segment)
+					:key #'cdr :test #'eq)))
+		      (setf (inst-emitter inst) nil)
+		      (setf (inst-depth inst) max))
+		     (t
+		      (setf (inst-depth inst) #+nil (1+ max) max))))))
+    (let ((really-emittable-insts nil)
+	  (delayed nil))
+      (dolist (inst (segment-emittable-insts segment))
+	(grovel-inst inst)
+	(if (zerop (inst-delay inst))
+	    (push inst really-emittable-insts)
+	    (setf delayed
+		  (add-to-nth-list delayed inst (1- (inst-delay inst))))))
+      (setf (segment-emittable-insts segment)
+	    (sort really-emittable-insts #'> :key #'inst-depth))
+      (setf (segment-delayed segment) delayed)))
+  #+nil
+  (format *trace-output* "Queued branches: ~S~%"
+	  (segment-queued-branches segment))
+  #+nil
+  (format *trace-output* "Initially emittable: ~S~%"
+	  (segment-emittable-insts segment))
+  #+nil
+  (format *trace-output* "Initially delayed: ~S~%"
+	  (segment-delayed segment))
+  ;;
+  ;; Accumulate the results in reverse order.  Well, actually, this list will
+  ;; be in forward order, because we are generating the reverse order in
+  ;; reverse.
+  (let ((results nil))
+    ;;
+    ;; Schedule all the branches in their exact locations.
+    (let ((insts-from-end 0))
+      (dolist (branch (segment-queued-branches segment))
+	(dotimes (i (- (car branch) insts-from-end))
+	  #+nil
+	  (format *trace-output* "Filling branch delay slot...~%")
+	  (let ((inst (or (schedule-one-inst segment) :nop)))
+	    (push inst results))
+	  (advance-one-inst segment)
+	  (incf insts-from-end))
+	(push (cdr branch) results)
+	#+nil
+	(format *trace-output* "Emitting ~S~%" (cdr branch))
+	(advance-one-inst segment)))
+    ;;
+    ;; Keep scheduling stuff until we run out.
+    (loop
+      (let ((inst (schedule-one-inst segment)))
+	(unless inst
+	  (return))
+	(push inst results)
+	(advance-one-inst segment)))
+    ;;
+    ;; Now call the emitters, but turn the scheduler off for the duration.
+    (setf (segment-run-scheduler segment) nil)
+    (dolist (inst results)
+      (if (eq inst :nop)
+	  (format t "*** NOP ***~%")
+	  (funcall (inst-emitter inst) segment)))
+    (setf (segment-run-scheduler segment) t))
+  ;;
+  ;; Clear out any residue left over.
+  (setf (segment-queued-branches segment) nil)
+  (setf (segment-branch-countdown segment) nil)
+  (setf (segment-readers segment) nil)
+  (setf (segment-writers segment) nil)
+  ;;
+  ;; That's all folks.
+  (ext:undefined-value))
+
+;;; ADD-TO-NTH-LIST -- internal.
+;;;
+;;; Utility for maintaining the segment-delayed list.  We cdr down list
+;;; n times (extending it if necessary) and then push thing on into the car
+;;; of that cons cell.
+;;; 
+(defun add-to-nth-list (list thing n)
+  (do ((cell (or list (setf list (list nil)))
+	     (or (cdr cell) (setf (cdr cell) (list nil))))
+       (i n (1- i)))
+      ((zerop i)
+       (push thing (car cell))
+       list)))
+
+;;; SCHEDULE-ONE-INST -- internal.
+;;;
+;;; Find the next instruction to schedule and return it after updating
+;;; any dependency information.  If we can't do anything useful right
+;;; now, but there is more work to be done, return :NOP to indicate that
+;;; a nop must be emitted.  If we are all done, return NIL.
+;;; 
+(defun schedule-one-inst (segment)
+  (let ((inst (pop (segment-emittable-insts segment))))
+    (cond (inst
+	   ;; We've got us a live one here.  Go for it.
+	   (assert (null (inst-write-dependents inst)))
+	   (assert (null (inst-read-dependents inst)))
+	   #+nil
+	   (format *Trace-output* "Emitting ~S~%" inst)
+	   (dolist (dep (inst-write-dependencies inst))
+	     ;; These are the instructions who have to be completed before our
+	     ;; write fires.  Doesn't matter how far before, just before.
+	     (let ((dependents (inst-write-dependents dep)))
+	       (setf dependents (delete inst dependents :test #'eq))
+	       (setf (inst-write-dependents dep) dependents)
+	       (when (and (null dependents)
+			  (null (inst-read-dependents dep)))
+		 (insert-emittable-inst segment dep))))
+	   (dolist (dep (inst-read-dependencies inst))
+	     ;; These are the instructions who write values we read.  If there
+	     ;; is no delay, then just remove us from the dependent list.
+	     ;; Otherwise, record the fact that in n cycles, we should be
+	     ;; removed.
+	     (if (zerop (inst-delay dep))
+		 (let ((dependents (inst-read-dependents dep)))
+		   (setf dependents (delete inst dependents :test #'eq))
+		   (setf (inst-read-dependents dep) dependents)
+		   (when (and (null dependents)
+			      (null (inst-write-dependents dep)))
+		     (insert-emittable-inst segment dep)))
+		 (setf (segment-delayed segment)
+		       (add-to-nth-list (segment-delayed segment)
+					(cons dep inst)
+					(inst-delay dep)))))
+	   ;; Are we wanting to flush this instruction?
+	   (if (inst-emitter inst)
+	       ;; Nope, it's still a go.  So return it.
+	       inst
+	       ;; Yep.  Find some other instruction to do.
+	       (schedule-one-inst segment)))
+	  ((segment-delayed segment)
+	   ;; No emittable instructions, but we have more work to do.  Emit
+	   ;; a NOP to fill in a delay slot.
+	   #+nil (format *trace-output* "Emitting a NOP.~%")
+	   :nop)
+	  (t
+	   ;; All done.
+	   nil))))
+
+;;; ADVANCE-ONE-INST -- internal.
+;;;
+;;; Process the next entry in segment-delayed.  This is called whenever anyone
+;;; emits an instruction.
+;;;
+(defun advance-one-inst (segment)
+  (let ((delayed-stuff (pop (segment-delayed segment))))
+    (dolist (stuff delayed-stuff)
+      (if (consp stuff)
+	  (let* ((dependency (car stuff))
+		 (dependent (cdr stuff))
+		 (dependents (inst-read-dependents dependency)))
+	    (setf dependents (delete dependent dependents :test #'eq))
+	    (setf (inst-read-dependents dependency) dependents)
+	    (when (and (null dependents)
+		       (null (inst-write-dependents dependency)))
+	      (insert-emittable-inst segment dependency)))
+	  (insert-emittable-inst segment stuff)))))
+
+;;; INSERT-EMITTABLE-INST -- internal.
+;;;
+;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS
+;;; list.  We keep the emittable-insts sorted with the largest ``depths''
+;;; first.
+;;;
+(defun insert-emittable-inst (segment inst)
+  #+nil
+  (format *Trace-output* "Now emittable: ~S~%" inst)
+  (do ((my-depth (inst-depth inst))
+       (remaining (segment-emittable-insts segment) (cdr remaining))
+       (prev nil remaining))
+      ((or (null remaining) (> my-depth (inst-depth (car remaining))))
+       (if prev
+	   (setf (cdr prev) (cons inst remaining))
+	   (setf (segment-emittable-insts segment) (cons inst remaining)))
+       (ext:undefined-value))))
+
+
+;;;; Structure used during output emission.
+
+;;; ANNOTATION -- Common supertype for all the different kinds of annotations.
+;;; 
+(defstruct (annotation
+	    (:constructor nil))
+  ;;
+  ;; Where in the raw output stream was this annotation emitted.
+  (index 0 :type index)
+  ;;
+  ;; What position does that correspond to.
+  (posn nil :type (or index null)))
+
+;;; LABEL -- Doesn't need any additional information beyond what is in the
+;;; annotation structure.
+;;; 
+(defstruct (label
+	    (:include annotation)
+	    (:constructor gen-label ())
+	    (:print-function %print-label))
+  )
+;;;
+(defun %print-label (label stream depth)
+  (declare (ignore depth))
+  (if (or *print-escape* *print-readably*)
+      (print-unreadable-object (label stream :type t)
+	(prin1 (c:label-id label) stream))
+      (format stream "L~D" (c:label-id label))))
+
+;;; ALIGNMENT-NOTE -- A constraint on how the output stream must be aligned.
+;;; 
+(defstruct (alignment-note
+	    (:include annotation)
+	    (:conc-name alignment-)
+	    (:predicate alignment-p)
+	    (:constructor make-alignment (bits size)))
+  ;;
+  ;; The minimum number of low-order bits that must be zero.
+  (bits 0 :type alignment)
+  ;;
+  ;; The amount of filler we are assuming this alignment op will take.
+  (size 0 :type (integer 0 #.(1- (ash 1 max-alignment)))))
+
+;;; BACK-PATCH -- a reference to someplace that needs to be back-patched when
+;;; we actually know what label positions, etc. are.
+;;; 
+(defstruct (back-patch
+	    (:include annotation)
+	    (:constructor make-back-patch (size function)))
+  ;;
+  ;; The area effected by this back-patch.
+  (size 0 :type index)
+  ;;
+  ;; The function to use to generate the real data
+  (function nil :type function))
+
+;;; CHOOSER -- Similar to a back-patch, but also an indication that the amount
+;;; of stuff output depends on label-positions, etc.  Back-patches can't change
+;;; their mind about how much stuff to emit, but choosers can.
+;;; 
+(defstruct (chooser
+	    (:include annotation)
+	    (:constructor make-chooser
+			  (size alignment maybe-shrink worst-case-fun)))
+  ;;
+  ;; The worst case size for this chooser.  There is this much space allocated
+  ;; in the output buffer.
+  (size 0 :type index)
+  ;;
+  ;; The worst case alignment this chooser is guarenteed to preserve.
+  (alignment 0 :type alignment)
+  ;;
+  ;; The function to call to determine of we can use a shorter sequence.  It
+  ;; returns NIL if nothing shorter can be used, or emits that sequence and
+  ;; returns T.
+  (maybe-shrink nil :type function)
+  ;;
+  ;; The function to call to generate the worst case sequence.  This is used
+  ;; when nothing else can be condensed.
+  (worst-case-fun nil :type function))
+
+;;; FILLER -- Used internally when we figure out a chooser or alignment doesn't
+;;; really need as much space as we initially gave it.
+;;;
+(defstruct (filler
+	    (:include annotation)
+	    (:constructor make-filler (bytes)))
+  ;;
+  ;; The number of bytes of filler here.
+  (bytes 0 :type index))
+
+
+
+;;;; Output buffer utility functions.
+
+;;; A list of all the output-blocks we have allocated but aren't using.
+;;; We free-list them because allocation more is slow and the garbage collector
+;;; doesn't know about them, so it can't be slowed down by use keep ahold of
+;;; them.
+;;; 
+(defvar *available-output-blocks* nil)
+
+;;; A list of all the output-blocks we have ever allocated.  We don't really
+;;; need to keep tract of this if RELEASE-OUTPUT-BLOCK were always called,
+;;; but...
+;;;
+(defvar *all-output-blocks* nil)
+
+;;; NEW-OUTPUT-BLOCK -- internal.
+;;;
+;;; Return a new output block, allocating one if necessary.
+;;;
+(defun new-output-block ()
+  (if *available-output-blocks*
+      (pop *available-output-blocks*)
+      (let ((block (system:allocate-system-memory output-block-size)))
+	(push block *all-output-blocks*)
+	block)))
+
+;;; RELEASE-OUTPUT-BLOCK -- internal.
+;;;
+;;; Return block to the list of avaiable blocks.
+;;;
+(defun release-output-block (block)
+  (push block *available-output-blocks*))
+
+;;; FORGET-OUTPUT-BLOCKS -- internal.
+;;;
+;;; We call this whenever a core starts up, because system-memory isn't
+;;; saves with the core.  If we didn't, we would find our hands full of
+;;; bogus SAPs, which would make all sorts of things unhappy.
+;;;
+(defun forget-output-blocks ()
+  (setf *available-output-blocks* nil))
+;;;
+(pushnew 'forget-output-blocks ext:*after-save-initializations*)
+
+
+
+;;;; Output functions.
+
+;;; FIND-NEW-FILL-POINTER -- internal.
+;;;
+;;; Find us a new fill pointer for the current index in segment.  Allocate
+;;; any additional storage as necessary.
+;;; 
+(defun find-new-fill-pointer (segment)
+  (declare (type segment segment))
+  (let* ((index (segment-current-index segment))
+	 (blocks (segment-output-blocks segment))
+	 (num-blocks (length blocks)))
+    (multiple-value-bind
+	(block-num offset)
+	(truncate index output-block-size)
+      (when (>= block-num num-blocks)
+	(setf blocks (adjust-array blocks (+ block-num 3)))
+	(setf (segment-output-blocks segment) blocks))
+      (let ((block (or (aref blocks block-num)
+		       (setf (aref blocks block-num) (new-output-block)))))
+	(setf (segment-block-end segment)
+	      (system:sap+ block output-block-size))
+	(setf (segment-fill-pointer segment) (system:sap+ block offset))))))
+
+;;; EMIT-BYTE -- interface.
+;;;
+;;; Emit the supplied BYTE to SEGMENT, growing it if necessary.
+;;; 
+(declaim (inline emit-byte))
+(defun emit-byte (segment byte)
+  "Emit BYTE to SEGMENT."
+  (declare (type segment segment)
+	   (type (or assembly-unit (signed-byte #.assembly-unit-bits)) byte))
+  (let* ((orig-ptr (segment-fill-pointer segment))
+	 (ptr (if (system:sap= orig-ptr (segment-block-end segment))
+		  (find-new-fill-pointer segment)
+		  orig-ptr)))
+    (setf (system:sap-ref-8 ptr 0) (ldb (byte assembly-unit-bits 0) byte))
+    (setf (segment-fill-pointer segment) (system:sap+ ptr 1)))
+  (incf (segment-current-posn segment))
+  (incf (segment-current-index segment))
+  (ext:undefined-value))
+
+;;; EMIT-SKIP -- interface.
+;;; 
+(defun emit-skip (segment amount)
+  "Output AMOUNT zeros (in bytes) to SEGMENT."
+  (declare (type segment segment)
+	   (type index amount))
+  (dotimes (i amount)
+    (emit-byte segment 0))
+  (ext:undefined-value))
+
+;;; EMIT-ANNOTATION -- internal.
+;;;
+;;; Used to handle the common parts of annotation emision.  We just
+;;; assign the posn and index of the note and tack it on to the end
+;;; of the segment's annotations list.
+;;; 
+(defun emit-annotation (segment note)
+  (declare (type segment segment)
+	   (type annotation note))
+  (when (annotation-posn note)
+    (error "Attempt to emit ~S for the second time."))
+  (setf (annotation-posn note) (segment-current-posn segment))
+  (setf (annotation-index note) (segment-current-index segment))
+  (let ((last (segment-last-annotation segment))
+	(new (list note)))
+    (setf (segment-last-annotation segment)
+	  (if last 
+	      (setf (cdr last) new)
+	      (setf (segment-annotations segment) new))))
+  (ext:undefined-value))
+
+;;; EMIT-BACK-PATCH -- interface.
+;;; 
+(defun emit-back-patch (segment size function)
+  "Note that the instruction stream has to be back-patched when label positions
+   are finally known.  SIZE bytes are reserved in SEGMENT, and function will
+   be called with two arguments: the segment and the position.  The function
+   should look at the position and the position of any labels it wants to
+   and emit the correct sequence.  (And it better be the same size as SIZE).
+   SIZE can be zero, which is useful if you just want to find out where things
+   ended up."
+  (emit-annotation segment (make-back-patch size function))
+  (emit-skip segment size))
+
+;;; EMIT-CHOOSER -- interface.
+;;; 
+(defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
+  "Note that the instruction stream here depends on the actual positions of
+   various labels, so can't be output until label positions are known.  Space
+   is made in SEGMENT for at least SIZE bytes.  When all output has been
+   generated, the MAYBE-SHRINK functions for all choosers are called with
+   three arguments: the segment, the position, and a magic value.  The MAYBE-
+   SHRINK decides if it can use a shorter sequence, and if so, emits that
+   sequence to the segment and returns T.  If it can't do better than the
+   worst case, it should return NIL (without emitting anything).  When calling
+   LABEL-POSITION, it should pass it the position and the magic-value it was
+   passed so that LABEL-POSITION can return the correct result.  If the chooser
+   never decides to use a shorter sequence, the WORST-CASE-FUN will be called,
+   just like a BACK-PATCH.  (See EMIT-BACK-PATCH.)"
+  (declare (type segment segment) (type index size) (type alignment alignment)
+	   (type function maybe-shrink worst-case-fun))
+  (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
+    (emit-annotation segment chooser)
+    (emit-skip segment size)
+    (adjust-alignment-after-chooser segment chooser)))
+
+;;; ADJUST-ALIGNMENT-AFTER-CHOOSER -- internal.
+;;;
+;;; Called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to recompute the
+;;; current alignment information in light of this chooser.  If the alignment
+;;; guarenteed byte the chooser is less then the segments current alignment,
+;;; we have to adjust the segments notion of the current alignment.
+;;;
+;;; The hard part is recomputing the sync posn, because it's not just the
+;;; choosers posn.  Consider a chooser that emits either one or three words.
+;;; It preserves 8-byte (3 bit) alignments, because the difference between
+;;; the two choices is 8 bytes.
+;;;
+(defun adjust-alignment-after-chooser (segment chooser)
+  (declare (type segment segment) (type chooser chooser))
+  (let ((alignment (chooser-alignment chooser))
+	(seg-alignment (segment-alignment segment)))
+    (when (< alignment seg-alignment)
+      ;; The chooser might change the alignment of the output.  So we have
+      ;; to figure out what the worst case alignment could be.
+      (setf (segment-alignment segment) alignment)
+      (let* ((posn (chooser-posn chooser))
+	     (sync-posn (segment-sync-posn segment))
+	     (offset (- posn sync-posn))
+	     (delta (logand offset (1- (ash 1 alignment)))))
+	(setf (segment-sync-posn segment) (- posn delta)))))
+  (ext:undefined-value))
+
+;;; EMIT-FILLER -- internal.
+;;;
+;;; Used internally whenever a chooser or alignment decides it doesn't need
+;;; as much space as it originally though.
+;;;
+(defun emit-filler (segment bytes)
+  (let ((last (segment-last-annotation segment)))
+    (cond ((and last (filler-p (car last)))
+	   (incf (filler-bytes (car last)) bytes))
+	  (t
+	   (emit-annotation segment (make-filler bytes)))))
+  (incf (segment-current-index segment) bytes)
+  (setf (segment-fill-pointer segment) (system:int-sap 0))
+  (setf (segment-block-end segment) (system:int-sap 0))
+  (ext:undefined-value))
+
+;;; EMIT-LABEL -- internal.
+;;;
+;;; EMIT-LABEL (the interface) basically just expands into this, supplying
+;;; the segment.
+;;; 
+(defun %emit-label (segment vop label)
+  (when (segment-run-scheduler segment)
+    (schedule-pending-instructions segment))
+  (let ((hook (segment-inst-hook segment)))
+    (when hook
+      (funcall hook segment vop :label label)))
+  (emit-annotation segment label))
+
+;;; EMIT-ALIGNMENT -- internal.
+;;;
+;;; Called by the ALIGN macro to emit an alignment note.  We check to see
+;;; if we can guarentee the alignment restriction by just outputing a fixed
+;;; number of bytes.  If so, we do so.  Otherwise, we create and emit
+;;; an alignment note.
+;;; 
+(defun emit-alignment (segment vop bits)
+  (when (segment-run-scheduler segment)
+    (schedule-pending-instructions segment))
+  (let ((hook (segment-inst-hook segment)))
+    (when hook
+      (funcall hook segment vop :align bits)))
+  (let ((alignment (segment-alignment segment))
+	(offset (- (segment-current-posn segment)
+		   (segment-sync-posn segment))))
+    (cond ((> bits alignment)
+	   ;; We need more bits of alignment.  First emit enough noise
+	   ;; to get back in sync with alignment, and then emit an alignment
+	   ;; note to cover the rest.
+	   (let ((slop (logand offset (1- (ash 1 alignment)))))
+	     (unless (zerop slop)
+	       (emit-skip segment (- (ash 1 alignment) slop))))
+	   (let ((size (logand (1- (ash 1 bits))
+			       (lognot (1- (ash 1 alignment))))))
+	     (assert (> size 0))
+	     (emit-annotation segment (make-alignment bits size))
+	     (emit-skip segment size))
+	   (setf (segment-alignment segment) bits)
+	   (setf (segment-sync-posn segment) (segment-current-posn segment)))
+	  (t
+	   ;; The last alignment was more restrictive then this one.
+	   ;; So we can just figure out how much noise to emit assuming
+	   ;; the last alignment was met.
+	   (let* ((mask (1- (ash 1 bits)))
+		  (new-offset (logand (+ offset mask) (lognot mask))))
+	     (emit-skip segment (- new-offset offset)))
+	   ;; But we emit an alignment with size=0 so we can verify
+	   ;; that everything works.
+	   (emit-annotation segment (make-alignment bits 0)))))
+  (ext:undefined-value))
+
+
+;;; FIND-ALIGNMENT -- internal.
+;;;
+;;; Used to find how ``aligned'' different offsets are.  Returns the number
+;;; of low-order 0 bits, up to MAX-ALIGNMENT.
+;;; 
+(defun find-alignment (offset)
+  (dotimes (i max-alignment max-alignment)
+    (when (logbitp i offset)
+      (return i))))
+
+
+
+;;;; Output compression/position assignment stuff
+
+;;; COMPRESS-OUTPUT -- internal.
+;;;
+;;; Grovel though all the annotations looking for choosers.  When we find
+;;; a chooser, invoke the maybe-shrink function.  If it returns T, it output
+;;; some other byte sequence.
+;;; 
+(defun compress-output (segment)
+  (dotimes (i 5) ; it better not take more than one or two passes.
+    (let ((delta 0))
+      (setf (segment-alignment segment) max-alignment)
+      (setf (segment-sync-posn segment) 0)
+      (do* ((prev nil)
+	    (remaining (segment-annotations segment) next)
+	    (next (cdr remaining) (cdr remaining)))
+	   ((null remaining))
+	(let* ((note (car remaining))
+	       (posn (annotation-posn note)))
+	  (unless (zerop delta)
+	    (decf posn delta)
+	    (setf (annotation-posn note) posn))
+	  (cond
+	   ((chooser-p note)
+	    (setf (segment-current-index segment) (chooser-index note))
+	    (setf (segment-current-posn segment) posn)
+	    (setf (segment-fill-pointer segment) (system:int-sap 0))
+	    (setf (segment-block-end segment) (system:int-sap 0))
+	    (setf (segment-last-annotation segment) prev)
+	    (cond
+	     ((funcall (chooser-maybe-shrink note) segment posn delta)
+	      ;; It emitted some replacement.
+	      (let ((new-size (- (segment-current-index segment)
+				 (chooser-index note)))
+		    (old-size (chooser-size note)))
+		(when (> new-size old-size)
+		  (error "~S emitted ~D bytes, but claimed it's max was ~D"
+			 note new-size old-size))
+		(let ((additional-delta (- old-size new-size)))
+		  (when (< (find-alignment additional-delta)
+			   (chooser-alignment note))
+		    (error "~S shrunk by ~D bytes, but claimed that it ~
+			    preserve ~D bits of alignment."
+			   note additional-delta (chooser-alignment note)))
+		  (incf delta additional-delta)
+		  (emit-filler segment additional-delta))
+		(setf prev (segment-last-annotation segment))
+		(if prev
+		    (setf (cdr prev) (cdr remaining))
+		    (setf (segment-annotations segment)
+			  (cdr remaining)))))
+	     (t
+	      ;; The chooser passed on shrinking.  Make sure it didn't emit
+	      ;; anything.
+	      (unless (= (segment-current-index segment) (chooser-index note))
+		(error "Chooser ~S passed, but not before emitting ~D bytes."
+		       note
+		       (- (segment-current-index segment)
+			  (chooser-index note))))
+	      ;; Act like we just emitted this chooser.
+	      (let ((size (chooser-size note)))
+		(incf (segment-current-index segment) size)
+		(incf (segment-current-posn segment) size))
+	      ;; Adjust the alignment accordingly.
+	      (adjust-alignment-after-chooser segment note)
+	      ;; And keep this chooser for next time around.
+	      (setf prev remaining))))
+	   ((alignment-p note)
+	    (unless (zerop (alignment-size note))
+	      ;; Re-emit the alignment, letting it collapse if we know anything
+	      ;; more about the alignment guarentees of the segment.
+	      (let ((index (alignment-index note)))
+		(setf (segment-current-index segment) index)
+		(setf (segment-current-posn segment) posn)
+		(setf (segment-fill-pointer segment) (system:int-sap 0))
+		(setf (segment-block-end segment) (system:int-sap 0))
+		(setf (segment-last-annotation segment) prev)
+		(emit-alignment segment nil (alignment-bits note))
+		(let* ((new-index (segment-current-index segment))
+		       (size (- new-index index))
+		       (old-size (alignment-size note))
+		       (additional-delta (- old-size size)))
+		  (when (minusp additional-delta)
+		    (error "Alignment ~S needs more space now?  It was ~D, ~
+			    and is ~D now."
+			   note old-size size))
+		  (when (plusp additional-delta)
+		    (emit-filler segment additional-delta)
+		    (incf delta additional-delta)))
+		(setf prev (segment-last-annotation segment))
+		(if prev
+		    (setf (cdr prev) (cdr remaining))
+		    (setf (segment-annotations segment)
+			  (cdr remaining))))))
+	   (t
+	    (setf prev remaining)))))
+      (when (zerop delta)
+	(return))
+      (decf (segment-final-posn segment) delta)))
+  (ext:undefined-value))
+
+;;; FINALIZE-POSITIONS -- internal.
+;;;
+;;; We have run all the choosers we can, so now we have to figure out exactly
+;;; how much space each alignment note needs.
+;;; 
+(defun finalize-positions (segment)
+  (let ((delta 0))
+    (do* ((prev nil)
+	  (remaining (segment-annotations segment) next)
+	  (next (cdr remaining) (cdr remaining)))
+	 ((null remaining))
+      (let* ((note (car remaining))
+	     (posn (- (annotation-posn note) delta)))
+	(cond
+	 ((alignment-p note)
+	  (let* ((bits (alignment-bits note))
+		 (mask (1- (ash 1 bits)))
+		 (new-posn (logand (+ posn mask) (lognot mask)))
+		 (size (- new-posn posn))
+		 (old-size (alignment-size note))
+		 (additional-delta (- old-size size)))
+	    (assert (<= 0 size old-size))
+	    (unless (zerop additional-delta)
+	      (setf (segment-last-annotation segment) prev)
+	      (incf delta additional-delta)
+	      (setf (segment-current-index segment) (alignment-index note))
+	      (setf (segment-current-posn segment) posn)
+	      (emit-filler segment additional-delta)
+	      (setf prev (segment-last-annotation segment)))
+	    (if prev
+		(setf (cdr prev) next)
+		(setf (segment-annotations segment) next))))
+	 (t
+	  (setf (annotation-posn note) posn)
+	  (setf prev remaining)
+	  (setf next (cdr remaining))))))
+    (unless (zerop delta)
+      (decf (segment-final-posn segment) delta)))
+  (ext:undefined-value))
+
+;;; PROCESS-BACK-PATCHES -- internal.
+;;;
+;;; Grovel over segment, filling in any backpatches.  If any choosers are left
+;;; over, we need to emit their worst case varient.
+;;;
+(defun process-back-patches (segment)
+  (do* ((prev nil)
+	(remaining (segment-annotations segment) next)
+	(next (cdr remaining) (cdr remaining)))
+      ((null remaining))
+    (let ((note (car remaining)))
+      (flet ((fill-in (function old-size)
+	       (let ((index (annotation-index note))
+		     (posn (annotation-posn note)))
+		 (setf (segment-current-index segment) index)
+		 (setf (segment-current-posn segment) posn)
+		 (setf (segment-fill-pointer segment) (system:int-sap 0))
+		 (setf (segment-block-end segment) (system:int-sap 0))
+		 (setf (segment-last-annotation segment) prev)
+		 (funcall function segment posn)
+		 (let ((new-size (- (segment-current-index segment) index)))
+		   (unless (= new-size old-size)
+		     (error "~S emitted ~D bytes, but claimed it's was ~D"
+			    note new-size old-size)))
+		 (setf prev (segment-last-annotation segment))
+		 (if prev
+		     (setf (cdr prev) next)
+		     (setf (segment-annotations segment) next)))))
+	(cond ((back-patch-p note)
+	       (fill-in (back-patch-function note)
+			(back-patch-size note)))
+	      ((chooser-p note)
+	       (fill-in (chooser-worst-case-fun note)
+			(chooser-size note)))
+	      (t
+	       (setf prev remaining)))))))
+
+
+;;;; Interface to the rest of the compiler.
+
+;;; *CURRENT-SEGMENT* -- internal.
+;;;
+;;; The holds the current segment while assembling.  Use ASSEMBLE to change
+;;; it.
+;;; 
+(defvar *current-segment*)
+
+;;; *CURRENT-VOP* -- internal.
+;;;
+;;; Just like *CURRENT-SEGMENT*, but holds the current vop.  Used only to keep
+;;; track of which vops emit which insts.
+;;; 
+(defvar *current-vop* nil)
+
+;;; ASSEMBLE -- interface.
+;;;
+;;; We also symbol-macrolet *current-segment* to a local holding the segment
+;;; so uses of *current-segment* inside the body don't have to keep
+;;; dereferencing the symbol.  Given that ASSEMBLE is the only interface to
+;;; *current-segment*, we don't have to worry about the special value becomming
+;;; out of sync with the lexical value.  Unless some bozo closes over it,
+;;; but nobody does anything like that...
+;;;
+(defmacro assemble ((&optional segment vop) &body body)
+  "Execute BODY (as a progn) with SEGMENT as the current segment."
+  (flet ((label-name-p (thing)
+	   (and thing (symbolp thing))))
+    (let ((seg-var (gensym "SEGMENT-"))
+	  (vop-var (gensym "VOP-"))
+	  (label-names (remove-if-not #'label-name-p body)))
+      `(let* ((,seg-var ,(or segment '*current-segment*))
+	      (,vop-var ,(or vop '*current-vop*))
+	      (*current-segment* ,seg-var)
+	      (*current-vop* ,vop-var)
+	      ,@(mapcar #'(lambda (name)
+			    `(,name (gen-label)))
+			label-names))
+	 (symbol-macrolet ((*current-segment* ,seg-var)
+			   (*current-vop* ,vop-var))
+	   ,@(mapcar #'(lambda (form)
+			 (if (label-name-p form)
+			     `(emit-label ,form)
+			     form))
+		     body))))))
+
+;;; INST -- interface.
+;;; 
+(defmacro inst (&whole whole instruction &rest args &environment env)
+  "Emit the specified instruction to the current segment."
+  (let ((inst (gethash (symbol-name instruction)
+		       (assem-params-instructions
+			(c:backend-assembler-params c:*target-backend*)))))
+    (cond ((null inst)
+	   (error "Unknown instruction: ~S" instruction))
+	  ((functionp inst)
+	   (funcall inst (cdr whole) env))
+	  (t
+	   `(,inst *current-segment* *current-vop* ,@args)))))
+
+;;; EMIT-LABEL -- interface.
+;;; 
+(defmacro emit-label (label)
+  "Emit LABEL at this location in the current segment."
+  `(%emit-label *current-segment* *current-vop* ,label))
+
+;;; ALIGN -- interface.
+;;; 
+(defmacro align (bits)
+  "Emit an alignment restriction to the current segment."
+  `(emit-alignment *current-segment* *current-vop* ,bits))
+
+;;; LABEL-POSITION -- interface.
+;;; 
+(defun label-position (label &optional if-after delta)
+  "Return the current position for LABEL.  Chooser maybe-shrink functions
+   should supply IF-AFTER and DELTA to assure correct results."
+  (let ((posn (label-posn label)))
+    (if (and if-after (> posn if-after))
+	(- posn delta)
+	posn)))
+
+;;; APPEND-SEGMENT -- interface.
+;;; 
+(defun append-segment (segment other-segment)
+  "Append OTHER-SEGMENT to the end of SEGMENT.  Don't use OTHER-SEGMENT
+   for anything after this."
+  (emit-alignment segment nil max-alignment)
+  (let ((offset-in-last-block (rem (segment-current-index segment)
+				   output-block-size)))
+    (unless (zerop offset-in-last-block)
+      (emit-filler segment (- output-block-size offset-in-last-block))))
+  (let* ((blocks (segment-output-blocks segment))
+	 (next-block-num (floor (segment-current-index segment)
+				output-block-size))
+	 (other-blocks (segment-output-blocks other-segment)))
+    (setf blocks
+	  (adjust-array blocks (+ next-block-num (length other-blocks))))
+    (setf (segment-output-blocks segment) blocks)
+    (replace blocks other-blocks :start1 next-block-num))
+  (let ((index-delta (segment-current-index segment))
+	(posn-delta (segment-current-posn segment))
+	(other-annotations (segment-annotations other-segment)))
+    (setf (segment-current-index segment)
+	  (+ index-delta (segment-current-index other-segment)))
+    (setf (segment-current-posn segment)
+	  (+ posn-delta (segment-current-posn other-segment)))
+    (setf (segment-fill-pointer segment) (system:int-sap 0))
+    (setf (segment-block-end segment) (system:int-sap 0))
+    (when other-annotations
+      (dolist (note other-annotations)
+	(incf (annotation-index note) index-delta)
+	(incf (annotation-posn note) posn-delta))
+      (let ((last (segment-last-annotation segment)))
+	(if last
+	    (setf (cdr last) other-annotations)
+	    (setf (segment-annotations segment) other-annotations))
+	(setf (segment-last-annotation segment)
+	      (segment-last-annotation other-segment)))))
+  (ext:undefined-value))
+
+;;; FINALIZE-SEGMENT -- interface.
+;;; 
+(defun finalize-segment (segment)
+  "Does any final processing of SEGMENT and returns the total number of bytes
+   covered by this segment."
+  (when (segment-run-scheduler segment)
+    (schedule-pending-instructions segment))
+  (setf (segment-final-index segment) (segment-current-index segment))
+  (setf (segment-final-posn segment) (segment-current-posn segment))
+  (setf (segment-inst-hook segment) nil)
+  (compress-output segment)
+  (finalize-positions segment)
+  (process-back-patches segment)
+  (segment-final-posn segment))
+
+;;; SEGMENT-MAP-OUTPUT -- interface.
+;;;
+(defun segment-map-output (segment function)
+  "Call FUNCTION on all the output accumulated in SEGMENT.  FUNCTION is called
+   zero or more times with two arguments: a SAP and a number of bytes."
+  (let ((old-index 0)
+	(blocks (segment-output-blocks segment))
+	(sap (system:int-sap 0))
+	(end (system:int-sap 0)))
+    (labels ((map-until (index)
+	       (unless (system:sap< sap end)
+		 (multiple-value-bind
+		     (block-num block-offset)
+		     (floor old-index output-block-size)
+		   (let ((block (aref blocks block-num)))
+		     (setf sap (system:sap+ block block-offset))
+		     (setf end (system:sap+ block output-block-size)))))
+	       (let* ((desired (- index old-index))
+		      (available (system:sap- end sap))
+		      (amount (min desired available)))
+		 (funcall function sap amount)
+		 (incf old-index amount)
+		 (setf sap (system:sap+ sap amount))
+		 (when (< amount desired)
+		   (map-until index)))))
+      (dolist (note (segment-annotations segment))
+	(when (filler-p note)
+	  (let ((index (filler-index note)))
+	    (when (< old-index index)
+	      (map-until index)))
+	  (let ((bytes (filler-bytes note)))
+	    (incf old-index bytes)
+	    (setf sap (system:sap+ sap bytes)))))
+      (let ((index (segment-final-index segment)))
+	(when (< old-index index)
+	  (map-until index))))))
+
+;;; RELEASE-SEGMENT -- interface.
+;;; 
+(defun release-segment (segment)
+  "Releases any output buffers held on to by segment."
+  (let ((blocks (segment-output-blocks segment)))
+    (loop
+      for block across blocks
+      do (when block
+	   (release-output-block block))))
+  (ext:undefined-value))
+
+
+;;;; Interface to the instruction set definition.
+
+;;; DEFINE-EMITTER -- Interface.
+;;;
+;;; Define a function named NAME that merges it's arguments into a single
+;;; integer and then emits the bytes of that integer in the correct order
+;;; based on the endianness of the target-backend.
+;;;
+(defmacro define-emitter (name total-bits &rest byte-specs)
+  (ext:collect ((arg-names) (arg-types))
+    (let* ((total-bits (eval total-bits))
+	   (overall-mask (ash -1 total-bits))
+	   (num-bytes (multiple-value-bind
+			  (quo rem)
+			  (truncate total-bits assembly-unit-bits)
+			(unless (zerop rem)
+			  (error "~D isn't an even multiple of ~D"
+				 total-bits assembly-unit-bits))
+			quo))
+	   (bytes (make-array num-bytes :initial-element nil))
+	   (segment-arg (gensym "SEGMENT-")))
+      (dolist (byte-spec-expr byte-specs)
+	(let* ((byte-spec (eval byte-spec-expr))
+	       (byte-size (byte-size byte-spec))
+	       (byte-posn (byte-position byte-spec))
+	       (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
+	  (when (ldb-test (byte byte-size byte-posn) overall-mask)
+	    (error "Byte spec ~S either overlaps another byte spec, or ~
+		    extends past the end."
+		   byte-spec-expr))
+	  (setf (ldb byte-spec overall-mask) -1)
+	  (arg-names arg)
+	  (arg-types `(type (integer ,(ash -1 (1- byte-size))
+				     ,(1- (ash 1 byte-size)))
+			    ,arg))
+	  (multiple-value-bind
+	      (start-byte offset)
+	      (floor byte-posn assembly-unit-bits)
+	    (let ((end-byte (floor (1- (+ byte-posn byte-size))
+				   assembly-unit-bits)))
+	      (flet ((maybe-ash (expr offset)
+		       (if (zerop offset)
+			   expr
+			   `(ash ,expr ,offset))))
+		(declare (inline maybe-ash))
+		(cond ((zerop byte-size))
+		      ((= start-byte end-byte)
+		       (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
+					offset)
+			     (svref bytes start-byte)))
+		      (t
+		       (push (maybe-ash
+			      `(ldb (byte ,(- assembly-unit-bits offset) 0)
+				    ,arg)
+			      offset)
+			     (svref bytes start-byte))
+		       (do ((index (1+ start-byte) (1+ index)))
+			   ((>= index end-byte))
+			 (push
+			  `(ldb (byte ,assembly-unit-bits
+				      ,(- (* assembly-unit-bits
+					     (- index start-byte))
+					  offset))
+				,arg)
+			  (svref bytes index)))
+		       (let ((len (rem (+ byte-size offset)
+				       assembly-unit-bits)))
+			 (push
+			  `(ldb (byte ,(if (zerop len)
+					   assembly-unit-bits
+					   len)
+				      ,(- (* assembly-unit-bits
+					     (- end-byte start-byte))
+					  offset))
+				,arg)
+			  (svref bytes end-byte))))))))))
+      (unless (= overall-mask -1)
+	(error "There are holes."))
+      (let ((forms nil))
+	(dotimes (i num-bytes)
+	  (let ((pieces (svref bytes i)))
+	    (assert pieces)
+	    (push `(emit-byte ,segment-arg
+			      ,(if (cdr pieces)
+				   `(logior ,@pieces)
+				   (car pieces)))
+		  forms)))
+	`(defun ,name (,segment-arg ,@(arg-names))
+	   (declare (type segment ,segment-arg) ,@(arg-types))
+	   ,@(ecase (c:backend-byte-order c:*target-backend*)
+	       (:little-endian (nreverse forms))
+	       (:big-endian forms))
+	   ',name)))))
+
+(defun grovel-lambda-list (lambda-list)
+  (let ((segment-name (car lambda-list))
+	(vop-var (gensym "VOP-")))
+    (ext:collect ((new-lambda-list))
+      (new-lambda-list segment-name)
+      (new-lambda-list vop-var)
+      (labels
+	  ((grovel (state lambda-list)
+	     (when lambda-list
+	       (let ((param (car lambda-list)))
+		 (cond
+		  ((member param lambda-list-keywords)
+		   (new-lambda-list param)
+		   (grovel param (cdr lambda-list)))
+		  (t
+		   (ecase state
+		     ((nil)
+		      (new-lambda-list param)
+		      `(cons ,param ,(grovel state (cdr lambda-list))))
+		     (&optional
+		      (multiple-value-bind
+			  (name default supplied-p)
+			  (if (consp param)
+			      (values (first param)
+				      (second param)
+				      (or (third param)
+					  (gensym "SUPPLIED-P-")))
+			      (values param nil (gensym "SUPPLIED-P-")))
+			(new-lambda-list (list name default supplied-p))
+			`(and ,supplied-p
+			      (cons ,(if (consp name)
+					 (second name)
+					 name)
+				    ,(grovel state (cdr lambda-list))))))
+		     (&key
+		      (multiple-value-bind
+			  (name default supplied-p)
+			  (if (consp param)
+			      (values (first param)
+				      (second param)
+				      (or (third param)
+					  (gensym "SUPPLIED-P-")))
+			      (values param nil (gensym "SUPPLIED-P-")))
+			(new-lambda-list (list name default supplied-p))
+			(multiple-value-bind
+			    (key var)
+			    (if (consp name)
+				(values (first name) (second name))
+				(values (intern (symbol-name name) :keyword)
+					name))
+			  `(append (and ,supplied-p (list ',key ,var))
+				   ,(grovel state (cdr lambda-list))))))
+		     (&rest
+		      (new-lambda-list param)
+		      (grovel state (cdr lambda-list))
+		      param))))))))
+	(let ((reconstructor (grovel nil (cdr lambda-list))))
+	  (values (new-lambda-list)
+		  segment-name
+		  vop-var
+		  reconstructor))))))
+
+;;; DEFINE-INSTRUCTION -- interface.
+;;; 
+(defmacro define-instruction (name lambda-list &rest options)
+  (let* ((sym-name (symbol-name name))
+	 (defun-name (ext:symbolicate sym-name "-INST-EMITTER"))
+	 (emitter nil)
+	 (decls nil)
+	 (attributes nil)
+	 (reads nil)
+	 (writes nil)
+	 (delay nil)
+	 (pinned nil))
+    (multiple-value-bind
+	(new-lambda-list segment-name vop-name arg-reconstructor)
+	(grovel-lambda-list lambda-list)
+      (dolist (option-spec options)
+	(multiple-value-bind
+	    (option args)
+	    (if (consp option-spec)
+		(values (car option-spec) (cdr option-spec))
+		(values option-spec nil))
+	  (case option
+	    (:emitter
+	     (when emitter
+	       (error "Can only specify one emitter per instruction."))
+	     (setf emitter args))
+	    (:declare
+	     (setf decls (append decls args)))
+	    (:attributes
+	     (setf attributes (append attributes args)))
+	    (:reads
+	     (when reads
+	       (error
+		"Can only specify one reads expression per instruction."))
+	     (setf reads args))
+	    (:writes
+	     (when writes
+	       (error
+		"Can only specify one writes expression per instruction."))
+	     (setf writes args))
+	    (:delay
+	     (when delay
+	       (error "Can only specify delay once per instruction."))
+	     (setf delay args))
+	    (:pinned
+	     (setf pinned t))
+	    (t
+	     (error "Unknown option: ~S" (car option))))))
+      (push `(let ((hook (segment-inst-hook ,segment-name)))
+	       (when hook
+		 (funcall hook ,segment-name ,vop-name ,sym-name
+			  ,arg-reconstructor)))
+	    emitter)
+      (when (assem-params-scheduler-p
+	     (c:backend-assembler-params c:*target-backend*))
+	(if pinned
+	    (setf emitter
+		  `((when (segment-run-scheduler ,segment-name)
+		      (schedule-pending-instructions ,segment-name))
+		    ,@emitter))
+	    (let ((flet-name
+		   (gensym (concatenate 'string "EMIT-" sym-name "-INST-"))))
+	      (setf emitter `((flet ((,flet-name (,segment-name)
+				       ,@emitter))
+				(if (segment-run-scheduler ,segment-name)
+				    (queue-inst ,segment-name
+						(make-instruction
+						 #',flet-name
+						 (instruction-attributes
+						  ,@attributes)
+						 (progn ,@delay))
+						(progn ,@reads)
+						(progn ,@writes))
+				    (,flet-name ,segment-name))))))))
+      `(progn
+	 (defun ,defun-name ,new-lambda-list
+	   ,@(when decls
+	       `((declare ,@decls)))
+	   (symbol-macrolet ((*current-segment* ,segment-name))
+			    ,@emitter)
+	   (ext:undefined-value))
+	 (eval-when (compile load eval)
+	   (%define-instruction ,sym-name ',defun-name))))))
+
+;;; DEFINE-INSTRUCTION-MACRO -- interface.
+;;;
+(defmacro define-instruction-macro (name lambda-list &body body)
+  (let ((whole (gensym "WHOLE-"))
+	(env (gensym "ENV-")))
+    (multiple-value-bind
+	(body local-defs)
+	(lisp::parse-defmacro lambda-list whole body name 'instruction-macro
+			      :environment env)
+      `(eval-when (compile load eval)
+	 (%define-instruction ',name
+			      #'(lambda (,whole ,env)
+				  ,@local-defs
+				  (block ,name
+				    ,@body)))))))
+
+(defun %define-instruction (name defun)
+  (setf (gethash name
+		 (assem-params-instructions
+		  (c:backend-assembler-params c:*target-backend*)))
+	defun)
+  name)
-- 
GitLab