;;; 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-base-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.
;; have to be emitted at a specific place (e.g. one slot before the
;; end of the block).
(queued-branches nil :type list)
- ;; *** state used by the scheduler during instruction scheduling.
+ ;; *** state used by the scheduler during instruction scheduling
;;
;; the instructions who would have had a read dependent removed if
;; it were not for a delay slot. This is a list of lists. Each
;; how many instructions follow the branch.
branch
;; This attribute indicates that this ``instruction'' can be
- ;; variable length, and therefore better never be used in a branch
- ;; delay slot.
- variable-length)
+ ;; variable length, and therefore had better never be used in a
+ ;; branch delay slot.
+ var-length)
(defstruct (instruction
(:include sset-element)
(:copier nil))
;; The function to envoke to actually emit this instruction. Gets called
;; with the segment as its one argument.
- (emitter (required-argument) :type (or null function))
+ (emitter (missing-arg) :type (or null function))
;; The attributes of this instruction.
(attributes (instruction-attributes) :type sb!c:attributes)
;; Number of instructions or cycles of delay before additional
name)
'<flushed>)))
(when (inst-depth inst)
- (format stream ", depth=~D" (inst-depth inst)))))
+ (format stream ", depth=~W" (inst-depth inst)))))
#!+sb-show-assem
(defun reset-inst-ids ()
\f
;;;; the scheduler itself
-(defmacro without-scheduling ((&optional (segment '**current-segment**))
+(defmacro without-scheduling ((&optional (segment '(%%current-segment%%)))
&body body)
#!+sb-doc
"Execute BODY (as a PROGN) without scheduling any of the instructions
(multiple-value-bind (loc-num size)
(sb!c:location-number read)
#!+sb-show-assem (format *trace-output*
- "~&~S reads ~S[~D for ~D]~%"
+ "~&~S reads ~S[~W for ~W]~%"
inst read loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(multiple-value-bind (loc-num size)
(sb!c:location-number write)
#!+sb-show-assem (format *trace-output*
- "~&~S writes ~S[~D for ~D]~%"
+ "~&~S writes ~S[~W for ~W]~%"
inst write loc-num size)
(when loc-num
;; Iterate over all the locations for this TN.
(when countdown
(decf countdown)
(aver (not (instruction-attributep (inst-attributes inst)
- variable-length))))
+ var-length))))
(cond ((instruction-attributep (inst-attributes inst) branch)
(unless countdown
(setf countdown (inst-delay inst)))
(let ((inst (car remaining)))
(unless (and delay-slot-p
(instruction-attributep (inst-attributes inst)
- variable-length))
+ var-length))
;; We've got us a live one here. Go for it.
#!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
;; Delete it from the list of insts.
(:predicate alignment-p)
(:constructor make-alignment (bits size fill-byte))
(:copier nil))
- ;; The minimum number of low-order bits that must be zero.
+ ;; 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.
+ ;; 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.
+ ;; the byte used as filling
(fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
;;; a reference to someplace that needs to be back-patched when
(:include annotation)
(:constructor make-back-patch (size function))
(:copier nil))
- ;; The area effected by this back-patch.
+ ;; the area effected by this back-patch
(size 0 :type index)
- ;; The function to use to generate the real data
+ ;; the function to use to generate the real data
(function nil :type function))
;;; This is similar to a BACK-PATCH, but also an indication that the
;;; necessary.
(defun emit-byte (segment byte)
(declare (type segment segment))
- ;; We could use DECLARE instead of CHECK-TYPE here, but (1) CMU CL's
- ;; inspired decision to treat DECLARE as ASSERT by default has not
- ;; been copied by other compilers, and this code runs in the
- ;; cross-compilation host Common Lisp, not just CMU CL, and (2)
- ;; classic CMU CL allowed more things here than this, and I haven't
- ;; tried to proof-read all the calls to EMIT-BYTE to ensure that
- ;; they're passing appropriate. -- WHN 19990323
- (check-type byte possibly-signed-assembly-unit)
+ (declare (type possibly-signed-assembly-unit byte))
(vector-push-extend (logand byte assembly-unit-mask)
(segment-buffer segment))
(incf (segment-current-posn segment))
(chooser-index note)))
(old-size (chooser-size note)))
(when (> new-size old-size)
- (error "~S emitted ~D bytes, but claimed its max was ~D."
+ (error "~S emitted ~W bytes, but claimed its max was ~W."
note new-size old-size))
(let ((additional-delta (- old-size new-size)))
(when (< (find-alignment additional-delta)
(chooser-alignment note))
- (error "~S shrunk by ~D bytes, but claimed that it ~
- preserve ~D bits of alignment."
+ (error "~S shrunk by ~W bytes, but claimed that it ~
+ preserves ~W bits of alignment."
note additional-delta (chooser-alignment note)))
(incf delta additional-delta)
(emit-filler segment additional-delta))
;; The chooser passed on shrinking. Make sure it didn't emit
;; anything.
(unless (= (segment-current-index segment) (chooser-index note))
- (error "Chooser ~S passed, but not before emitting ~D bytes."
+ (error "Chooser ~S passed, but not before emitting ~W bytes."
note
(- (segment-current-index segment)
(chooser-index note))))
(old-size (alignment-size note))
(additional-delta (- old-size size)))
(when (minusp additional-delta)
- (error "Alignment ~S needs more space now? It was ~D, ~
- and is ~D now."
+ (error "Alignment ~S needs more space now? It was ~W, ~
+ and is ~W now."
note old-size size))
(when (plusp additional-delta)
(emit-filler segment additional-delta)
(funcall function segment posn)
(let ((new-size (- (segment-current-index segment) index)))
(unless (= new-size old-size)
- (error "~S emitted ~D bytes, but claimed it was ~D."
+ (error "~S emitted ~W bytes, but claimed it was ~W."
note new-size old-size)))
(let ((tail (segment-last-annotation segment)))
(if tail
;;; This holds the current segment while assembling. Use ASSEMBLE to
;;; change it.
;;;
-;;; The double asterisks in the name are intended to suggest that this
+;;; The double parens 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..
+;;;
+;;; (This used to be called **CURRENT-SEGMENT** in SBCL until 0.7.3,
+;;; and just *CURRENT-SEGMENT* in CMU CL. In both cases, the rebinding
+;;; now done with MACROLET was done with SYMBOL-MACROLET instead. The
+;;; rename-with-double-asterisks was because the SYMBOL-MACROLET made
+;;; it an extra-special variable. The change over to
+;;; %%CURRENT-SEGMENT%% was because ANSI forbids the use of
+;;; SYMBOL-MACROLET on special variable names, and CLISP correctly
+;;; complains about this when being used as a bootstrap host.)
+(defmacro %%current-segment%% () '**current-segment**)
(defvar **current-segment**)
-;;; Just like **CURRENT-SEGMENT**, except this holds the current vop.
+;;; Just like %%CURRENT-SEGMENT%%, except this holds the current vop.
;;; Used only to keep track of which vops emit which insts.
;;;
;;; 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..
+(defmacro %%current-vop%% () '**current-vop**)
(defvar **current-vop** nil)
-;;; We also SYMBOL-MACROLET **CURRENT-SEGMENT** to a local holding the
-;;; segment so uses of **CURRENT-SEGMENT** inside the body don't have
+;;; We also MACROLET %%CURRENT-SEGMENT%% to a local holding the
+;;; segment so uses of %%CURRENT-SEGMENT%% inside the body don't have
;;; to keep dereferencing the symbol. Given that ASSEMBLE is the only
;;; interface to **CURRENT-SEGMENT**, we don't have to worry about the
;;; special value becomming out of sync with the lexical value. Unless
(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)))
+ `(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))
- (symbol-macrolet ((**current-segment** ,seg-var)
- (**current-vop** ,vop-var)
- ,@(when (or inherited-labels nested-labels)
+ (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))))))
+ ,@(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
(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)))
+ `(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))
- (symbol-macrolet ((**current-segment** ,seg-var)
- (**current-vop** ,vop-var)
- ,@(when (or inherited-labels nested-labels)
+ (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))))))
+ ,@(mapcar (lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body)))))))
(defmacro inst (&whole whole instruction &rest args &environment env)
#!+sb-doc
((functionp inst)
(funcall inst (cdr whole) env))
(t
- `(,inst **current-segment** **current-vop** ,@args)))))
+ `(,inst (%%current-segment%%) (%%current-vop%%) ,@args)))))
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* and **CURRENT-VOP** prevents this from being an
(defmacro emit-label (label)
#!+sb-doc
"Emit LABEL at this location in the current segment."
- `(%emit-label **current-segment** **current-vop** ,label))
+ `(%emit-label (%%current-segment%%) (%%current-vop%%) ,label))
;;; Note: The need to capture SYMBOL-MACROLET bindings of
;;; **CURRENT-SEGMENT* prevents this from being an ordinary function.
(defmacro emit-postit (function)
- `(%emit-postit **current-segment** ,function))
+ `(%emit-postit (%%current-segment%%) ,function))
;;; Note: The need to capture SYMBOL-MACROLET bindings of
-;;; **CURRENT-SEGMENT* and **CURRENT-VOP** prevents this from being an
+;;; **CURRENT-SEGMENT* and (%%CURRENT-VOP%%) prevents this from being an
;;; ordinary function.
(defmacro align (bits &optional (fill-byte 0))
#!+sb-doc
"Emit an alignment restriction to the current segment."
- `(emit-alignment **current-segment** **current-vop** ,bits ,fill-byte))
+ `(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.
(num-bytes (multiple-value-bind (quo rem)
(truncate total-bits assembly-unit-bits)
(unless (zerop rem)
- (error "~D isn't an even multiple of ~D."
+ (error "~W isn't an even multiple of ~W."
total-bits assembly-unit-bits))
quo))
(bytes (make-array num-bytes :initial-element nil))
(when lambda-list
(let ((param (car lambda-list)))
(cond
- ((member param lambda-list-keywords)
+ ((member param sb!xc:lambda-list-keywords)
(new-lambda-list param)
(grovel param (cdr lambda-list)))
(t
reconstructor))))))
(defun extract-nths (index glue list-of-lists-of-lists)
- (mapcar #'(lambda (list-of-lists)
- (cons glue
- (mapcar #'(lambda (list)
- (nth index list))
- list-of-lists)))
+ (mapcar (lambda (list-of-lists)
+ (cons glue
+ (mapcar (lambda (list)
+ (nth index list))
+ list-of-lists)))
list-of-lists-of-lists))
(defmacro define-instruction (name lambda-list &rest options)
(error "You can only specify :VOP-VAR once per instruction.")
(setf vop-var (car args))))
(:printer
+ (sb!int:/noshow "uniquifying :PRINTER with" args)
(push (eval `(list (multiple-value-list
,(sb!disassem:gen-printer-def-forms-def-form
name
+ (format nil "~A[~A]" name args)
(cdr option-spec)))))
pdefs))
(:printer-list
(push
(eval
`(eval
- `(list ,@(mapcar #'(lambda (printer)
- `(multiple-value-list
- ,(sb!disassem:gen-printer-def-forms-def-form
- ',name printer nil)))
+ `(list ,@(mapcar (lambda (printer)
+ `(multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ ',name
+ (format nil "~A[~A]" ',name printer)
+ printer
+ nil)))
,(cadr option-spec)))))
pdefs))
(t
`((declare ,@decls)))
(let ((,postits (segment-postits ,segment-name)))
(setf (segment-postits ,segment-name) nil)
- (symbol-macrolet
- (;; Apparently this binding is intended to keep
- ;; anyone from accidentally using
- ;; **CURRENT-SEGMENT** within the body of the
- ;; emitter. The error message sorta suggests that
- ;; this can happen accidentally by including one
- ;; emitter inside another. But I dunno.. -- WHN
- ;; 19990323
- (**current-segment**
- ;; FIXME: I can't see why we have to use
- ;; (MACROLET ((LOSE () (ERROR ..))) (LOSE))
- ;; instead of just (ERROR "..") here.
- (macrolet ((lose ()
- (error "You can't use INST without an ~
- ASSEMBLE inside emitters.")))
- (lose))))
+ (macrolet ((%%current-segment%% ()
+ (error "You can't use INST without an ~
+ ASSEMBLE inside emitters.")))
,@emitter))
(values))
(eval-when (:compile-toplevel :load-toplevel :execute)
:environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%define-instruction ,(symbol-name name)
- #'(lambda (,whole ,env)
- ,@local-defs
- (block ,name
- ,body)))))))
+ (lambda (,whole ,env)
+ ,@local-defs
+ (block ,name
+ ,body)))))))
(defun %define-instruction (name defun)
(setf (gethash name *assem-instructions*) defun)
projects / sbcl.git / blobdiff