X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fassem.lisp;h=d052886519df0d9370dfa62bf936c318075689f0;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=abaa89d5034c8f238da599db05f71a96223cfbe7;hpb=a6d3d28acd3433c02a081d42dab15bdfe101794b;p=sbcl.git diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index abaa89d..d052886 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -26,16 +26,16 @@ ;;; 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. @@ -48,6 +48,7 @@ ;; 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 @@ -106,13 +107,15 @@ #!+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. @@ -121,19 +124,26 @@ ;; 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 @@ -693,14 +703,16 @@ (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 @@ -748,17 +760,25 @@ (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 @@ -839,10 +859,23 @@ ;;; 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))))) @@ -863,11 +896,11 @@ (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))) @@ -877,29 +910,29 @@ (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. @@ -987,8 +1020,8 @@ (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)) @@ -1037,6 +1070,11 @@ (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 @@ -1081,13 +1119,40 @@ (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)))) + ;;;; 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.. @@ -1133,97 +1198,63 @@ ;;; 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 @@ -1251,13 +1282,10 @@ ;;; 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 @@ -1278,7 +1306,11 @@ (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) @@ -1298,8 +1330,8 @@ ;; 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)) @@ -1321,47 +1353,23 @@ (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)))) + ;;;; interface to the instruction set definition @@ -1379,12 +1387,12 @@ 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." @@ -1454,7 +1462,7 @@ (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) @@ -1477,8 +1485,8 @@ (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) @@ -1491,8 +1499,8 @@ (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) @@ -1567,7 +1575,8 @@ (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 @@ -1580,7 +1589,8 @@ `(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))))) @@ -1670,10 +1680,7 @@ (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)