;;; 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-dyncount
(collect-dynamic-statistics nil))
(sb!c::defprinter (segment)
- name)
+ type)
-;;; 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
(def!struct (alignment-note (:include annotation)
(:conc-name alignment-)
(:predicate alignment-p)
- (:constructor make-alignment (bits size fill-byte))
+ (:constructor make-alignment (bits size pattern))
(:copier nil))
;; 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))))
- ;; the byte used as filling
- (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
+ ;; the byte used as filling or :LONG-NOP, indicating to call EMIT-LONG-NOP
+ ;; to emit a filling pattern
+ (pattern 0 :type (or possibly-signed-assembly-unit
+ (member :long-nop))))
;;; a reference to someplace that needs to be back-patched when
;;; we actually know what label positions, etc. are
(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))
-;;; interface: Output AMOUNT copies of FILL-BYTE to SEGMENT.
-(defun emit-skip (segment amount &optional (fill-byte 0))
+;;; interface: Output AMOUNT bytes to SEGMENT, either copies of
+;;; PATTERN (if that is an integer), or by calling EMIT-LONG-NOP
+;;; (if PATTERN is :LONG-NOP).
+(defun emit-skip (segment amount &optional (pattern 0))
(declare (type segment segment)
(type index amount))
- (dotimes (i amount)
- (emit-byte segment fill-byte))
+ (etypecase pattern
+ (integer
+ (dotimes (i amount)
+ (emit-byte segment pattern)))
+ ((eql :long-nop)
+ (sb!vm:emit-long-nop segment amount)))
(values))
;;; This is used to handle the common parts of annotation emission. We
;;; 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
;;; This is used internally whenever a chooser or alignment decides it
;;; doesn't need as much space as it originally thought.
+;;; This function used to extend an existing filler instead of creating
+;;; a new one when the previous segment annotation was a filler. Now
+;;; this is only done if the previous filler is immediately adjacent
+;;; to the new one in the segment, too. To see why this restriction is
+;;; necessary, consider a jump followed by an alignment made of
+;;; multi-byte NOPs when both are shrunk: The shortened alignment is
+;;; reemitted at its original _start_ position but the joined filler
+;;; would extend over this position and instead leave a subsequence of
+;;; the segment up to the alignment's original _end_ position visible.
(defun emit-filler (segment n-bytes)
(declare (type index n-bytes))
(let ((last (segment-last-annotation segment)))
- (cond ((and last (filler-p (car last)))
+ (cond ((and last
+ (filler-p (car last))
+ (= (+ (filler-index (car last))
+ (filler-bytes (car last)))
+ (segment-current-index segment)))
(incf (filler-bytes (car last)) n-bytes))
(t
(emit-annotation segment (make-filler n-bytes)))))
(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 (pattern 0))
(when (segment-run-scheduler segment)
(schedule-pending-instructions segment))
(let ((hook (segment-inst-hook 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) fill-byte)))
- (let ((size (logand (1- (ash 1 bits))
- (lognot (1- (ash 1 alignment))))))
+ ;; We need more bits of alignment. Emit an alignment note.
+ ;; The ALIGNMENT many least significant bits of (- OFFSET)
+ ;; give the amount of bytes to skip to get back in sync with
+ ;; ALIGNMENT, and one-bits to the left of that up to position
+ ;; BITS provide the remaining amount.
+ (let ((size (deposit-field (- offset)
+ (byte 0 alignment)
+ (1- (ash 1 bits)))))
(aver (> size 0))
- (emit-annotation segment (make-alignment bits size fill-byte))
- (emit-skip segment size fill-byte))
+ (emit-annotation segment (make-alignment bits size pattern))
+ (emit-skip segment size pattern))
(setf (segment-alignment segment) bits)
(setf (segment-sync-posn segment) (segment-current-posn segment)))
(t
- ;; The last alignment was more restrictive then this one.
+ ;; The last alignment was more restrictive than 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) fill-byte))
+ (emit-skip segment (- new-offset offset) pattern))
;; But we emit an alignment with size=0 so we can verify
;; that everything works.
- (emit-annotation segment (make-alignment bits 0 fill-byte)))))
+ (emit-annotation segment (make-alignment bits 0 pattern)))))
(values))
;;; This is used to find how ``aligned'' different offsets are.
(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-pattern note))
(let* ((new-index (segment-current-index segment))
(size (- new-index index))
(old-size (alignment-size note))
(with-modified-segment-index-and-posn (segment
(alignment-index note)
posn)
+ (when (eql (alignment-pattern note) :long-nop)
+ ;; We need to re-emit the alignment because a shorter
+ ;; multi-byte NOP pattern is most of the time not a
+ ;; prefix of a longer one.
+ (emit-skip segment size (alignment-pattern note)))
(emit-filler segment additional-delta)
(setf prev (segment-last-annotation segment))
(if prev
(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)
(chooser-size note)))
(t
(setf prev remaining)))))))
+
+;;; Replace the SEGMENT-BUFFER of SEGMENT with a vector that contains
+;;; only the valid content of the original buffer, that is, the parts
+;;; not covered by fillers. Set FINAL-INDEX of SEGMENT to the length
+;;; of the new vector and return this length.
+(defun compact-segment-buffer (segment)
+ (let ((buffer (segment-buffer segment))
+ (new-buffer (make-array (segment-final-posn segment)
+ :element-type 'assembly-unit))
+ (i0 0)
+ (index 0))
+ (declare (type (simple-array assembly-unit 1) buffer)
+ (type index index))
+ (flet ((frob (i0 i1)
+ (when (< i0 i1)
+ (replace new-buffer buffer :start1 index :start2 i0 :end2 i1)
+ (incf index (- i1 i0)))))
+ (dolist (note (segment-annotations segment))
+ (when (filler-p note)
+ (let ((i1 (filler-index note)))
+ (frob i0 i1)
+ (setf i0 (+ i1 (filler-bytes note))))))
+ (frob i0 (segment-final-index segment)))
+ (aver (= index (segment-final-posn segment)))
+ (setf (segment-buffer segment) new-buffer)
+ (setf (segment-final-index segment) (segment-final-posn segment))))
+
\f
;;;; interface to the rest of the compiler
;;; 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 %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 (pattern 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 ,pattern))
(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))
(compress-output segment)
(finalize-positions segment)
(process-back-patches segment)
- (segment-final-posn segment))
+ (compact-segment-buffer segment))
-;;; Call FUNCTION on all the stuff accumulated in SEGMENT. FUNCTION
-;;; should accept a single vector argument. It will be called zero or
-;;; more times on vectors of the appropriate byte type. The
-;;; concatenation of the vector arguments from all the calls is the
-;;; contents of SEGMENT.
-;;;
-;;; KLUDGE: This implementation is sort of slow and gross, calling
-;;; FUNCTION repeatedly and consing a fresh vector for its argument
-;;; each time. It might be possible to make a more efficient version
-;;; by making FINALIZE-SEGMENT do all the compacting currently done by
-;;; this function: then this function could become trivial and fast,
-;;; calling FUNCTION once on the entire compacted segment buffer. --
-;;; WHN 19990322
-(defun on-segment-contents-vectorly (segment function)
- (declare (type function function))
- (let ((buffer (segment-buffer segment))
- (i0 0))
- (flet ((frob (i0 i1)
- (when (< i0 i1)
- (funcall function (subseq buffer i0 i1)))))
- (dolist (note (segment-annotations segment))
- (when (filler-p note)
- (let ((i1 (filler-index note)))
- (frob i0 i1)
- (setf i0 (+ i1 (filler-bytes note))))))
- (frob i0 (segment-final-index segment))))
- (values))
+;;; Return the contents of SEGMENT as a vector. We assume SEGMENT has
+;;; been finalized so that we can simply return its buffer.
+(defun segment-contents-as-vector (segment)
+ (declare (type segment segment))
+ (aver (= (segment-final-index segment) (segment-final-posn segment)))
+ (segment-buffer segment))
;;; Write the code accumulated in SEGMENT to STREAM, and return the
-;;; number of bytes written.
+;;; number of bytes written. We assume that SEGMENT has been finalized.
(defun write-segment-contents (segment stream)
- (let ((result 0))
- (declare (type index result))
- (on-segment-contents-vectorly segment
- (lambda (v)
- (declare (type (vector assembly-unit) v))
- (incf result (length v))
- (write-sequence v stream)))
- result))
+ (declare (type segment segment))
+ (let ((v (segment-contents-as-vector segment)))
+ (declare (type (simple-array assembly-unit 1) v))
+ (length (write-sequence v stream))))
+
\f
;;;; interface to the instruction set definition
total-bits assembly-unit-bits))
quo))
(bytes (make-array num-bytes :initial-element nil))
- (segment-arg (gensym "SEGMENT-")))
+ (segment-arg (sb!xc: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))))
+ (arg (sb!xc:gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
(when (ldb-test (byte byte-size byte-posn) overall-mask)
(error "The byte spec ~S either overlaps another byte spec, or ~
extends past the end."
(defun grovel-lambda-list (lambda-list vop-var)
(let ((segment-name (car lambda-list))
- (vop-var (or vop-var (gensym "VOP-"))))
+ (vop-var (or vop-var (sb!xc:gensym "VOP"))))
(sb!int:collect ((new-lambda-list))
(new-lambda-list segment-name)
(new-lambda-list vop-var)
(values (first param)
(second param)
(or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
+ (sb!xc:gensym "SUPPLIED-P-")))
+ (values param nil (sb!xc:gensym "SUPPLIED-P-")))
(new-lambda-list (list name default supplied-p))
`(and ,supplied-p
(cons ,(if (consp name)
(values (first param)
(second param)
(or (third param)
- (gensym "SUPPLIED-P-")))
- (values param nil (gensym "SUPPLIED-P-")))
+ (sb!xc:gensym "SUPPLIED-P-")))
+ (values param nil (sb!xc:gensym "SUPPLIED-P-")))
(new-lambda-list (list name default supplied-p))
(multiple-value-bind (key var)
(if (consp name)
(push (eval `(list (multiple-value-list
,(sb!disassem:gen-printer-def-forms-def-form
name
- (format nil "~@:(~A[~A]~)" name args)
+ (let ((*print-right-margin* 1000))
+ (format nil "~@:(~A[~A]~)" name args))
(cdr option-spec)))))
pdefs))
(:printer-list
`(multiple-value-list
,(sb!disassem:gen-printer-def-forms-def-form
',name
- (format nil "~@:(~A[~A]~)" ',name printer)
+ (let ((*print-right-margin* 1000))
+ (format nil "~@:(~A[~A]~)" ',name printer))
printer
nil)))
,(cadr option-spec)))))
(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)
projects / sbcl.git / blobdiff