;;; 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. This used to be an adjustable
#!+sb-dyncount
(collect-dynamic-statistics nil))
(sb!c::defprinter (segment)
- name)
+ type)
(declaim (inline segment-current-index))
(defun segment-current-index (segment)
(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))
;;; 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 (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))
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)))))
projects / sbcl.git / blobdiff