;;; 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-base-string)
+ (name "unnamed" :type simple-string)
;; 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.
;;; BACK-PATCH-FUN so we can avoid this nastiness altogether.
(defmacro with-modified-segment-index-and-posn ((segment index posn)
&body body)
- (let ((n-segment (gensym "SEGMENT"))
- (old-index (gensym "OLD-INDEX-"))
- (old-posn (gensym "OLD-POSN-")))
+ (with-unique-names (n-segment old-index old-posn)
`(let* ((,n-segment ,segment)
(,old-index (segment-current-index ,n-segment))
(,old-posn (segment-current-posn ,n-segment)))
;; branch delay slot.
variable-length)
-(defstruct (instruction
+(def!struct (instruction
(:include sset-element)
(:conc-name inst-)
(:constructor make-instruction (number emitter attributes delay))
;; nothing to do, then emit a nop. ### Note: despite the
;; fact that this is a loop, it really won't work for
;; repetitions other then zero and one. For example, if
-p ;; the branch has two dependents and one of them dpends on
+ ;; the branch has two dependents and one of them dpends on
;; the other, then the stuff that grabs a dependent could
;; easily grab the wrong one. But I don't feel like fixing
;; this because it doesn't matter for any of the
;;;; structure used during output emission
;;; common supertype for all the different kinds of annotations
-(defstruct (annotation (:constructor nil)
- (:copier nil))
+(def!struct (annotation (:constructor nil)
+ (:copier 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)))
-(defstruct (label (:include annotation)
- (:constructor gen-label ())
- (:copier nil))
+(def!struct (label (:include annotation)
+ (:constructor gen-label ())
+ (:copier nil))
;; (doesn't need any additional information beyond what is in the
;; annotation structure)
)
(format stream "L~D" (sb!c:label-id label))))
;;; 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 fill-byte))
- (:copier nil))
+(def!struct (alignment-note (:include annotation)
+ (:conc-name alignment-)
+ (:predicate alignment-p)
+ (:constructor make-alignment (bits size fill-byte))
+ (: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
;;; 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 fun))
- (:copier nil))
+(def!struct (back-patch (:include annotation)
+ (:constructor make-back-patch (size fun))
+ (:copier nil))
;; the area affected by this back-patch
(size 0 :type index :read-only t)
;; the function to use to generate the real data
;;; 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))
- (:copier nil))
+(def!struct (chooser (:include annotation)
+ (:constructor make-chooser
+ (size alignment maybe-shrink worst-case-fun))
+ (:copier nil))
;; the worst case size for this chooser. There is this much space
;; allocated in the output buffer.
(size 0 :type index :read-only t)
;;; This is 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))
- (:copier nil))
+(def!struct (filler (:include annotation)
+ (:constructor make-filler (bytes))
+ (:copier nil))
;; the number of bytes of filler here
(bytes 0 :type index))
\f
(declare (type segment segment)
(type annotation note))
(when (annotation-posn note)
- (error "attempt to emit ~S a second time"))
+ (error "attempt to emit ~S a second time" note))
(setf (annotation-posn note) (segment-current-posn segment))
(setf (annotation-index note) (segment-current-index segment))
(let ((last (segment-last-annotation segment))
(when (< (find-alignment additional-delta)
(chooser-alignment note))
(error "~S shrunk by ~W bytes, but claimed that it ~
- preserves ~W bits of alignment."
+ preserves ~W bits of alignment."
note additional-delta (chooser-alignment note)))
(incf delta additional-delta)
(emit-filler segment additional-delta))
(additional-delta (- old-size size)))
(when (minusp additional-delta)
(error "Alignment ~S needs more space now? It was ~W, ~
- and is ~W now."
+ and is ~W now."
note old-size size))
(when (plusp additional-delta)
(emit-filler segment additional-delta)
,@(mapcar (lambda (name)
`(,name (gen-label)))
new-labels))
- (declare (ignorable ,vop-var ,seg-var))
+ (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**))
- (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)))))))
+ ;; 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
(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)))))))
+ (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)))))))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
(setf (segment-postits segment) (segment-postits other-segment))
(dolist (postit postits)
(emit-back-patch segment 0 postit)))
- #!-x86 (emit-alignment segment nil max-alignment)
- #!+x86 (emit-alignment segment nil max-alignment #x90)
+ (emit-alignment segment nil max-alignment #!+(or x86-64 x86) #x90)
(let ((segment-current-index-0 (segment-current-index segment))
(segment-current-posn-0 (segment-current-posn segment)))
(incf (segment-current-index segment)
(arg (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."
+ extends past the end."
byte-spec-expr))
(setf (ldb byte-spec overall-mask) -1)
(arg-names arg)
,@(when decls
`((declare ,@decls)))
(let ((,postits (segment-postits ,segment-name)))
+ ;; Must be done so that contribs and user code doing
+ ;; low-level stuff don't need to worry about this.
+ (declare (disable-package-locks %%current-segment%%))
(setf (segment-postits ,segment-name) nil)
(macrolet ((%%current-segment%% ()
(error "You can't use INST without an ~
- ASSEMBLE inside emitters.")))
+ ASSEMBLE inside emitters.")))
+ ;; KLUDGE: Some host lisps (CMUCL 18e Sparc at least)
+ ;; can't deal with this declaration, so disable it on host
+ ;; Ditto for earlier ENABLE-PACKAGE-LOCKS %%C-S%% %%C-V%%
+ ;; declaration.
+ #-sb-xc-host
+ (declare (enable-package-locks %%current-segment%%))
,@emitter))
(values))
(eval-when (:compile-toplevel :load-toplevel :execute)
(append ,@(extract-nths 0 'list pdefs)))))))))
(defmacro define-instruction-macro (name lambda-list &body body)
- (let ((whole (gensym "WHOLE-"))
- (env (gensym "ENV-")))
+ (with-unique-names (whole env)
(multiple-value-bind (body local-defs)
(sb!kernel:parse-defmacro lambda-list
whole
projects / sbcl.git / blobdiff