;;; I wonder whether the separation of the disassembler from the
;;; virtual machine is valid or adds value.
-;;; FIXME: In CMU CL, the code in this file seems to be fully
-;;; compiled, not byte compiled. I'm not sure that's reasonable:
-;;; there's a lot of code in this file, and considering the overall
-;;; speed of the compiler, having some byte-interpretation overhead
-;;; for every few bytes emitted doesn't seem likely to be noticeable.
-;;; I'd like to see what happens if I come back and byte-compile this
-;;; file.
-
;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
(sb!disassem:define-argument-type displacement
:sign-extend t
- :use-label #'offset-next)
+ :use-label #'offset-next
+ :printer #'(lambda (value stream dstate)
+ (sb!disassem:maybe-note-assembler-routine value nil dstate)
+ (print-label value stream dstate)))
(sb!disassem:define-argument-type accum
:printer #'(lambda (value stream dstate)
(defun print-fp-reg (value stream dstate)
(declare (ignore dstate))
(format stream "FR~D" value))
-
(defun prefilter-fp-reg (value dstate)
;; just return it
(declare (ignore dstate))
value)
-)
+) ; EVAL-WHEN
(sb!disassem:define-argument-type fp-reg
:prefilter #'prefilter-fp-reg
:printer #'print-fp-reg)
(princ (schar (symbol-name word-width) 0) stream)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
-(defconstant conditions
+(defparameter *conditions*
'((:o . 0)
(:no . 1)
(:b . 2) (:nae . 2) (:c . 2)
(:nl . 13) (:ge . 13)
(:le . 14) (:ng . 14)
(:nle . 15) (:g . 15)))
-
(defparameter *condition-name-vec*
(let ((vec (make-array 16 :initial-element nil)))
- (dolist (cond conditions)
+ (dolist (cond *conditions*)
(when (null (aref vec (cdr cond)))
(setf (aref vec (cdr cond)) (car cond))))
vec))
-);EVAL-WHEN
+) ; EVAL-WHEN
;;; Set assembler parameters. (In CMU CL, this was done with
;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
:printer *condition-name-vec*)
(defun conditional-opcode (condition)
- (cdr (assoc condition conditions :test #'eq)))
+ (cdr (assoc condition *conditions* :test #'eq)))
\f
;;;; disassembler instruction formats
(- (+ (component-header-length)
(or (label-position offset)
0))
- other-pointer-type))))
+ other-pointer-lowtag))))
(emit-dword segment (or offset 0)))))
(defun emit-relative-fixup (segment fixup)
(defun reg-tn-encoding (tn)
(declare (type tn tn))
- (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+ (aver (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
(let ((offset (tn-offset tn)))
(logior (ash (logand offset 1) 2)
(ash offset -1))))
-(defstruct (ea (:constructor make-ea (size &key base index scale disp)))
+(defstruct (ea (:constructor make-ea (size &key base index scale disp))
+ (:copier nil))
(size nil :type (member :byte :word :dword))
(base nil :type (or tn null))
(index nil :type (or tn null))
(t
(format stream "~A PTR [" (symbol-name (ea-size ea)))
(when (ea-base ea)
- (write-string (x86-location-print-name (ea-base ea)) stream)
+ (write-string (sb!c::location-print-name (ea-base ea)) stream)
(when (ea-index ea)
(write-string "+" stream)))
(when (ea-index ea)
- (write-string (x86-location-print-name (ea-index ea)) stream))
+ (write-string (sb!c::location-print-name (ea-index ea)) stream))
(unless (= (ea-scale ea) 1)
(format stream "*~A" (ea-scale ea)))
(typecase (ea-disp ea)
(make-fixup nil
:code-object
(- (* (tn-offset thing) word-bytes)
- other-pointer-type))))))
+ other-pointer-lowtag))))))
(ea
(let* ((base (ea-base thing))
(index (ea-index thing))
(and (eql disp 0)
(not (= (reg-tn-encoding base) #b101))))
#b00)
- ((and (target-fixnump disp) (<= -128 disp 127))
+ ((and (fixnump disp) (<= -128 disp 127))
#b01)
(t
#b10)))
(defun byte-reg-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)
- (member (sc-name (tn-sc thing)) byte-sc-names)
+ (member (sc-name (tn-sc thing)) *byte-sc-names*)
t))
(defun byte-ea-p (thing)
(typecase thing
(ea (eq (ea-size thing) :byte))
(tn
- (and (member (sc-name (tn-sc thing)) byte-sc-names) t))
+ (and (member (sc-name (tn-sc thing)) *byte-sc-names*) t))
(t nil)))
(defun word-reg-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)
- (member (sc-name (tn-sc thing)) word-sc-names)
+ (member (sc-name (tn-sc thing)) *word-sc-names*)
t))
(defun word-ea-p (thing)
(typecase thing
(ea (eq (ea-size thing) :word))
- (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t))
+ (tn (and (member (sc-name (tn-sc thing)) *word-sc-names*) t))
(t nil)))
(defun dword-reg-p (thing)
(and (tn-p thing)
(eq (sb-name (sc-sb (tn-sc thing))) 'registers)
- (member (sc-name (tn-sc thing)) dword-sc-names)
+ (member (sc-name (tn-sc thing)) *dword-sc-names*)
t))
(defun dword-ea-p (thing)
(typecase thing
(ea (eq (ea-size thing) :dword))
(tn
- (and (member (sc-name (tn-sc thing)) dword-sc-names) t))
+ (and (member (sc-name (tn-sc thing)) *dword-sc-names*) t))
(t nil)))
(defun register-p (thing)
(defun operand-size (thing)
(typecase thing
(tn
+ ;; FIXME: might as well be COND instead of having to use #. readmacro
+ ;; to hack up the code
(case (sc-name (tn-sc thing))
- (#.dword-sc-names
+ (#.*dword-sc-names*
:dword)
- (#.word-sc-names
+ (#.*word-sc-names*
:word)
- (#.byte-sc-names
+ (#.*byte-sc-names*
:byte)
- ;; added by jrd. float-registers is a separate size (?)
- (#.float-sc-names
+ ;; added by jrd: float-registers is a separate size (?)
+ (#.*float-sc-names*
:float)
- (#.double-sc-names
+ (#.*double-sc-names*
:double)
(t
(error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
(emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
(emit-ea segment dst (reg-tn-encoding src)))
((fixup-p src)
- (assert (eq size :dword))
+ (aver (eq size :dword))
(emit-byte segment #b11000111)
(emit-ea segment dst #b000)
(emit-absolute-fixup segment src))
(error "bogus arguments to MOV: ~S ~S" dst src))))))
(defun emit-move-with-extension (segment dst src opcode)
- (assert (register-p dst))
+ (aver (register-p dst))
(let ((dst-size (operand-size dst))
(src-size (operand-size src)))
(ecase dst-size
(:word
- (assert (eq src-size :byte))
+ (aver (eq src-size :byte))
(maybe-emit-operand-size-prefix segment :word)
(emit-byte segment #b00001111)
(emit-byte segment opcode)
(emit-absolute-fixup segment src))
(t
(let ((size (operand-size src)))
- (assert (not (eq size :byte)))
+ (aver (not (eq size :byte)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p src)
(emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
(:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
(:emitter
(let ((size (operand-size dst)))
- (assert (not (eq size :byte)))
+ (aver (not (eq size :byte)))
(maybe-emit-operand-size-prefix segment size)
(cond ((register-p dst)
(emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
(define-instruction lea (segment dst src)
(:printer reg-reg/mem ((op #b1000110) (width 1)))
(:emitter
- (assert (dword-reg-p dst))
+ (aver (dword-reg-p dst))
(emit-byte segment #b10001101)
(emit-ea segment src (reg-tn-encoding dst))))
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
(:emitter
- (assert (register-p src))
+ (aver (register-p src))
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(:printer accum-reg/mem ((op '(#b1111011 #b100))))
(:emitter
(let ((size (matching-operand-size dst src)))
- (assert (accumulator-p dst))
+ (aver (accumulator-p dst))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
(emit-ea segment src #b100))))
(:printer accum-reg/mem ((op '(#b1111011 #b110))))
(:emitter
(let ((size (matching-operand-size dst src)))
- (assert (accumulator-p dst))
+ (aver (accumulator-p dst))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
(emit-ea segment src #b110))))
(:printer accum-reg/mem ((op '(#b1111011 #b111))))
(:emitter
(let ((size (matching-operand-size dst src)))
- (assert (accumulator-p dst))
+ (aver (accumulator-p dst))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
(emit-ea segment src #b111))))
;; Register/Memory with Register.
(:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
(:emitter
- (assert (register-p src))
+ (aver (register-p src))
(let ((size (matching-operand-size src dst)))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(:printer string-op ((op #b0110110)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
(:printer string-op ((op #b1010110)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
(:printer string-op ((op #b0110111)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
(:printer string-op ((op #b1010111)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
(:printer string-op ((op #b1010101)))
(:emitter
(let ((size (operand-size acc)))
- (assert (accumulator-p acc))
+ (aver (accumulator-p acc))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
1
#'(lambda (segment posn)
(let ((disp (- (label-position target) (1+ posn))))
- (assert (<= -128 disp 127))
+ (aver (<= -128 disp 127))
(emit-byte segment disp)))))
(define-instruction jmp (segment cond &optional where)
(nt "pending interrupt trap"))
(#.sb!vm:halt-trap
(nt "halt trap"))
- (#.sb!vm:function-end-breakpoint-trap
+ (#.sb!vm:fun-end-breakpoint-trap
(nt "function end breakpoint trap")))))
(define-instruction break (segment code)
(logior type
(ash (+ posn
(component-header-length))
- (- type-bits
+ (- n-widetag-bits
word-shift)))))))
-(define-instruction function-header-word (segment)
+(define-instruction simple-fun-header-word (segment)
(:emitter
- (emit-header-data segment function-header-type)))
+ (emit-header-data segment simple-fun-header-widetag)))
(define-instruction lra-header-word (segment)
(:emitter
- (emit-header-data segment return-pc-header-type)))
+ (emit-header-data segment return-pc-header-widetag)))
\f
;;;; fp instructions
;;;;
(define-instruction fadd-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b000))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b000)))
;;; with pop
(define-instruction faddp-sti (segment destination)
(:printer floating-point-fp ((op '(#b110 #b000))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011110)
(emit-fp-op segment destination #b000)))
(define-instruction fsub-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b101))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b101)))
;;; with a pop
(define-instruction fsubp-sti (segment destination)
(:printer floating-point-fp ((op '(#b110 #b101))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011110)
(emit-fp-op segment destination #b101)))
(define-instruction fsubr-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b100))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b100)))
;;; with a pop
(define-instruction fsubrp-sti (segment destination)
(:printer floating-point-fp ((op '(#b110 #b100))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011110)
(emit-fp-op segment destination #b100)))
(define-instruction fmul-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b001))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b001)))
(define-instruction fdiv-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b111))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b111)))
(define-instruction fdivr-sti (segment destination)
(:printer floating-point-fp ((op '(#b100 #b110))))
(:emitter
- (assert (fp-reg-tn-p destination))
+ (aver (fp-reg-tn-p destination))
(emit-byte segment #b11011100)
(emit-fp-op segment destination #b110)))
;; XX Printer conflicts with frstor
;; (:printer floating-point ((op '(#b101 #b100))))
(:emitter
- (assert (fp-reg-tn-p src))
+ (aver (fp-reg-tn-p src))
(emit-byte segment #b11011101)
(emit-fp-op segment src #b100)))
projects / sbcl.git / blobdiff