;;; This structure holds the state of the assembler.
(defstruct (segment (:copier nil))
- ;; the name of this segment (for debugging output and stuff)
- (name "unnamed" :type simple-string)
+ ;; the type of this segment (for debugging output and stuff)
+ (type :regular :type (member :regular :elsewhere))
;; Ordinarily this is a vector where instructions are written. If
;; the segment is made invalid (e.g. by APPEND-SEGMENT) then the
- ;; vector can be replaced by NIL.
- (buffer (make-array 0
- :fill-pointer 0
- :adjustable t
- :element-type 'assembly-unit)
- :type (or null (vector assembly-unit)))
+ ;; vector can be replaced by NIL. This used to be an adjustable
+ ;; array, but we now do the array size management manually for
+ ;; performance reasons (as of 2006-05-13 hairy array operations
+ ;; are rather slow compared to simple ones).
+ (buffer (make-array 0 :element-type 'assembly-unit)
+ :type (or null (simple-array assembly-unit)))
;; whether or not to run the scheduler. Note: if the instruction
;; definitions were not compiled with the scheduler turned on, this
;; has no effect.
;; indexes are the same, but after we start collapsing choosers,
;; positions can change while indexes stay the same.
(current-posn 0 :type index)
+ (%current-index 0 :type index)
;; 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
(sb!c::defprinter (segment)
name)
-;;; where the next byte of output goes
-#!-sb-fluid (declaim (inline segment-current-index))
+(declaim (inline segment-current-index))
(defun segment-current-index (segment)
- (fill-pointer (segment-buffer segment)))
+ (segment-%current-index segment))
+
(defun (setf segment-current-index) (new-value segment)
+ (declare (type index new-value)
+ (type segment segment))
;; FIXME: It would be lovely to enforce this, but first FILL-IN will
;; need to be convinced to stop rolling SEGMENT-CURRENT-INDEX
;; backwards.
;; about what's going on in the (legacy) code: The segment never
;; shrinks. -- WHN the reverse engineer
#+nil (aver (>= new-value (segment-current-index segment)))
- (let ((buffer (segment-buffer segment)))
- ;; Make sure that the array is big enough.
- (do ()
- ((>= (array-dimension buffer 0) new-value))
- ;; When we have to increase the size of the array, we want to
- ;; roughly double the vector length: that way growing the array
- ;; to size N conses only O(N) bytes in total. But just doubling
- ;; the length would leave a zero-length vector unchanged. Hence,
- ;; take the MAX with 1..
- (adjust-array buffer (max 1 (* 2 (array-dimension buffer 0)))))
+ (let* ((buffer (segment-buffer segment))
+ (new-buffer-size (length buffer)))
+ (declare (type (simple-array (unsigned-byte 8)) buffer)
+ (type index new-buffer-size))
+ ;; Make sure the array is big enough.
+ (when (<= new-buffer-size new-value)
+ (do ()
+ ((> new-buffer-size new-value))
+ ;; When we have to increase the size of the array, we want to
+ ;; roughly double the vector length: that way growing the array
+ ;; to size N conses only O(N) bytes in total. But just doubling
+ ;; the length would leave a zero-length vector unchanged. Hence,
+ ;; take the MAX with 1..
+ (setf new-buffer-size (max 1 (* 2 new-buffer-size))))
+ (let ((new-buffer (make-array new-buffer-size
+ :element-type '(unsigned-byte 8))))
+ (replace new-buffer buffer)
+ (setf (segment-buffer segment) new-buffer)))
;; Now that the array has the intended next free byte, we can point to it.
- (setf (fill-pointer buffer) new-value)))
-
+ (setf (segment-%current-index segment) new-value)))
;;; Various functions (like BACK-PATCH-FUN or CHOOSER-WORST-CASE-FUN)
;;; aren't cleanly parameterized, but instead use
(defun emit-byte (segment byte)
(declare (type segment segment))
(declare (type possibly-signed-assembly-unit byte))
- (vector-push-extend (logand byte assembly-unit-mask)
- (segment-buffer segment))
+ (let ((old-index (segment-current-index segment)))
+ (incf (segment-current-index segment))
+ (setf (aref (segment-buffer segment) old-index)
+ (logand byte assembly-unit-mask)))
(incf (segment-current-posn segment))
(values))
;;; 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
+;;; 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).
;;; This is called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to
;;; recompute the current alignment information in light of this
-;;; chooser. If the alignment guaranteed byte the chooser is less then
-;;; the segments current alignment, we have to adjust the segments
+;;; chooser. If the alignment guaranteed by the chooser is less than
+;;; the segment's current alignment, we have to adjust the segment's
;;; notion of the current alignment.
;;;
;;; The hard part is recomputing the sync posn, because it's not just
(funcall hook segment vop :label label)))
(emit-annotation segment label))
-;;; Called by the ALIGN macro to emit an alignment note. We check to
-;;; see if we can guarantee the alignment restriction by just
-;;; outputting a fixed number of bytes. If so, we do so. Otherwise, we
-;;; create and emit an alignment note.
-(defun emit-alignment (segment vop bits &optional (fill-byte 0))
+;;; Called by the EMIT-ALIGNMENT macro to emit an alignment note. We check to
+;;; see if we can guarantee the alignment restriction by just outputting a
+;;; fixed number of bytes. If so, we do so. Otherwise, we create and emit an
+;;; alignment note.
+(defun %emit-alignment (segment vop bits &optional (fill-byte 0))
(when (segment-run-scheduler segment)
(schedule-pending-instructions segment))
(let ((hook (segment-inst-hook segment)))
(let ((index (alignment-index note)))
(with-modified-segment-index-and-posn (segment index posn)
(setf (segment-last-annotation segment) prev)
- (emit-alignment segment nil (alignment-bits note)
- (alignment-fill-byte note))
+ (%emit-alignment segment nil (alignment-bits note)
+ (alignment-fill-byte note))
(let* ((new-index (segment-current-index segment))
(size (- new-index index))
(old-size (alignment-size note))
(values))
;;; Grovel over segment, filling in any backpatches. If any choosers
-;;; are left over, we need to emit their worst case varient.
+;;; are left over, we need to emit their worst case variant.
(defun process-back-patches (segment)
(do* ((prev nil)
(remaining (segment-annotations segment) next)
;;; This holds the current segment while assembling. Use ASSEMBLE to
;;; change it.
;;;
-;;; The double parens in the name are intended to suggest that this
+;;; The double asterisks in the name are intended to suggest that this
;;; isn't just any old special variable, it's an extra-special
;;; variable, because sometimes MACROLET is used to bind it. So be
;;; careful out there..
;;; solutions and maybe even good solutions, but I'm disinclined to
;;; hunt for good solutions until the system works and I can test them
;;; in isolation.
-(sb!int:def!macro assemble ((&optional segment vop &key labels) &body body
- &environment env)
- #!+sb-doc
- "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-"))
- (visible-labels (remove-if-not #'label-name-p body))
- (inherited-labels
- (multiple-value-bind (expansion expanded)
- (macroexpand '..inherited-labels.. env)
- (if expanded expansion nil)))
- (new-labels (append labels
- (set-difference visible-labels
- inherited-labels)))
- (nested-labels (set-difference (append inherited-labels new-labels)
- visible-labels)))
- (when (intersection labels inherited-labels)
- (error "duplicate nested labels: ~S"
- (intersection labels inherited-labels)))
- `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
- (,vop-var ,(or vop '(%%current-vop%%)))
- ,@(when segment
- `((**current-segment** ,seg-var)))
- ,@(when vop
- `((**current-vop** ,vop-var)))
- ,@(mapcar (lambda (name)
- `(,name (gen-label)))
- new-labels))
- (declare (ignorable ,vop-var ,seg-var)
- ;; Must be done so that contribs and user code doing
- ;; low-level stuff don't need to worry about this.
- (disable-package-locks %%current-segment%% %%current-vop%%))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
- ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
- ;; can't deal with this declaration, so disable it on host.
- ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration.
- #-sb-xc-host
- (declare (enable-package-locks %%current-segment%% %%current-vop%%))
- (symbol-macrolet (,@(when (or inherited-labels nested-labels)
- `((..inherited-labels.. ,nested-labels))))
- ,@(mapcar (lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
- body)))))))
-#+sb-xc-host
-(sb!xc:defmacro assemble ((&optional segment vop &key labels)
- &body body
- &environment env)
- #!+sb-doc
- "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-"))
- (visible-labels (remove-if-not #'label-name-p body))
- (inherited-labels
- (multiple-value-bind
- (expansion expanded)
- (sb!xc:macroexpand '..inherited-labels.. env)
- (if expanded expansion nil)))
- (new-labels (append labels
- (set-difference visible-labels
- inherited-labels)))
- (nested-labels (set-difference (append inherited-labels new-labels)
- visible-labels)))
- (when (intersection labels inherited-labels)
- (error "duplicate nested labels: ~S"
- (intersection labels inherited-labels)))
- `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
- (,vop-var ,(or vop '(%%current-vop%%)))
- ,@(when segment
- `((**current-segment** ,seg-var)))
- ,@(when vop
- `((**current-vop** ,vop-var)))
- ,@(mapcar (lambda (name)
- `(,name (gen-label)))
- new-labels))
- (declare (ignorable ,vop-var ,seg-var))
- (macrolet ((%%current-segment%% () '**current-segment**)
- (%%current-vop%% () '**current-vop**))
- (symbol-macrolet (,@(when (or inherited-labels nested-labels)
- `((..inherited-labels.. ,nested-labels))))
- ,@(mapcar (lambda (form)
- (if (label-name-p form)
- `(emit-label ,form)
- form))
- body)))))))
+;;;
+;;; The above comment remains true, except that instead of a cut-and-paste
+;;; copy we now have a macrolet. This is charitably called progress.
+;;; -- NS 2008-09-19
+(macrolet
+ ((def (defmacro macroexpand)
+ `(,defmacro assemble ((&optional segment vop &key labels) &body body
+ &environment env)
+ #!+sb-doc
+ "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-"))
+ (visible-labels (remove-if-not #'label-name-p body))
+ (inherited-labels
+ (multiple-value-bind (expansion expanded)
+ (,macroexpand '..inherited-labels.. env)
+ (if expanded expansion nil)))
+ (new-labels (append labels
+ (set-difference visible-labels
+ inherited-labels)))
+ (nested-labels (set-difference (append inherited-labels new-labels)
+ visible-labels)))
+ (when (intersection labels inherited-labels)
+ (error "duplicate nested labels: ~S"
+ (intersection labels inherited-labels)))
+ `(let* ((,seg-var ,(or segment '(%%current-segment%%)))
+ (,vop-var ,(or vop '(%%current-vop%%)))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
+ ,@(mapcar (lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (declare (ignorable ,vop-var ,seg-var)
+ ;; Must be done so that contribs and user code doing
+ ;; low-level stuff don't need to worry about this.
+ (disable-package-locks %%current-segment%% %%current-vop%%))
+ (macrolet ((%%current-segment%% () ',seg-var)
+ (%%current-vop%% () ',vop-var))
+ ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
+ ;; can't deal with this declaration, so disable it on host.
+ ;; Ditto for later ENABLE-PACKAGE-LOCKS %%C-S%% declaration.
+ #-sb-xc-host
+ (declare (enable-package-locks %%current-segment%% %%current-vop%%))
+ (symbol-macrolet (,@(when (or inherited-labels nested-labels)
+ `((..inherited-labels.. ,nested-labels))))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))))
+ (def sb!int:def!macro macroexpand)
+ #+sb-xc-host
+ (def sb!xc:defmacro sb!xc:macroexpand))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
;;; ordinary function.
-(defmacro align (bits &optional (fill-byte 0))
+(defmacro emit-alignment (bits &optional (fill-byte 0))
#!+sb-doc
"Emit an alignment restriction to the current segment."
- `(emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
-;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
-;;; called EMIT-ALIGNMENT, and the function that it calls should be
-;;; called %EMIT-ALIGNMENT.
+ `(%emit-alignment (%%current-segment%%) (%%current-vop%%) ,bits ,fill-byte))
(defun label-position (label &optional if-after delta)
#!+sb-doc
(setf (segment-postits segment) (segment-postits other-segment))
(dolist (postit postits)
(emit-back-patch segment 0 postit)))
- (emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90)
+ #!-(or x86 x86-64)
+ (%emit-alignment segment nil max-alignment)
+ #!+(or x86 x86-64)
+ (unless (eq :elsewhere (segment-type other-segment))
+ (%emit-alignment segment nil max-alignment))
(let ((segment-current-index-0 (segment-current-index segment))
(segment-current-posn-0 (segment-current-posn segment)))
(incf (segment-current-index segment)
;; worth enough in efficiency to justify it? -- WHN 19990322
(let ((last (segment-last-annotation segment)))
(if last
- (setf (cdr last) other-annotations)
- (setf (segment-annotations segment) other-annotations)))
+ (setf (cdr last) other-annotations)
+ (setf (segment-annotations segment) other-annotations)))
(setf (segment-last-annotation segment)
(segment-last-annotation other-segment)))))
(values))
(declare (type function function))
(let ((buffer (segment-buffer segment))
(i0 0))
+ (declare (type (simple-array (unsigned-byte 8)) buffer))
(flet ((frob (i0 i1)
(when (< i0 i1)
(funcall function (subseq buffer i0 i1)))))
(defmacro define-instruction-macro (name lambda-list &body body)
(with-unique-names (whole env)
(multiple-value-bind (body local-defs)
- (sb!kernel:parse-defmacro lambda-list
- whole
- body
- name
+ (sb!kernel:parse-defmacro lambda-list whole body name
'instruction-macro
:environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)