;;; 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 ()
(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.
(inst-write-dependencies inst))
(writes write))
(writes)))
- (assert (segment-run-scheduler segment))
+ (aver (segment-run-scheduler segment))
(let ((countdown (segment-branch-countdown segment)))
(when countdown
(decf countdown)
- (assert (not (instruction-attributep (inst-attributes inst)
- variable-length))))
+ (aver (not (instruction-attributep (inst-attributes inst)
+ var-length))))
(cond ((instruction-attributep (inst-attributes inst) branch)
(unless countdown
(setf countdown (inst-delay inst)))
;;; instructions would sit there until the scheduler was turned back
;;; on, and emitted in the wrong place).
(defun schedule-pending-instructions (segment)
- (assert (segment-run-scheduler segment))
+ (aver (segment-run-scheduler segment))
;; Quick blow-out if nothing to do.
(when (and (sset-empty (segment-emittable-insts-sset segment))
(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.
;;; remove this instruction from their dependents list. If we were the
;;; last dependent, then that dependency can be emitted now.
(defun note-resolved-dependencies (segment inst)
- (assert (sset-empty (inst-read-dependents inst)))
- (assert (sset-empty (inst-write-dependents inst)))
+ (aver (sset-empty (inst-read-dependents inst)))
+ (aver (sset-empty (inst-write-dependents inst)))
(do-sset-elements (dep (inst-write-dependencies inst))
;; These are the instructions who have to be completed before our
;; write fires. Doesn't matter how far before, just before.
(: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))
(emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
(let ((size (logand (1- (ash 1 bits))
(lognot (1- (ash 1 alignment))))))
- (assert (> size 0))
+ (aver (> size 0))
(emit-annotation segment (make-alignment bits size fill-byte))
(emit-skip segment size fill-byte))
(setf (segment-alignment segment) bits)
(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)
(size (- new-posn posn))
(old-size (alignment-size note))
(additional-delta (- old-size size)))
- (assert (<= 0 size old-size))
+ (aver (<= 0 size old-size))
(unless (zerop additional-delta)
(setf (segment-last-annotation segment) prev)
(incf delta 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
(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))
(let ((forms nil))
(dotimes (i num-bytes)
(let ((pieces (svref bytes i)))
- (assert pieces)
+ (aver pieces)
(push `(emit-byte ,segment-arg
,(if (cdr pieces)
`(logior ,@pieces)
(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
(multiple-value-bind (key var)
(if (consp name)
(values (first name) (second name))
- (values (intern (symbol-name name) :keyword)
- name))
+ (values (keywordicate name) name))
`(append (and ,supplied-p (list ',key ,var))
,(grovel state (cdr lambda-list))))))
(&rest
(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
projects / sbcl.git / blobdiff