(in-package "SB!VM")
+; normally assem-scheduler-p is t, and nil if debugging the assembler
(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf sb!assem:*assem-scheduler-p* nil))
+ (setf *assem-scheduler-p* nil))
+(setf *assem-max-locations* 68) ; see number-location
+
\f
;;;; Utility functions.
(fp-single-zero (values 0 nil))
(single-reg (values (tn-offset tn) nil))
(fp-double-zero (values 0 t))
- (double-reg (values (tn-offset tn) t))))
+ (double-reg (values (tn-offset tn) t))
+ (complex-single-reg (values (tn-offset tn) nil))
+ (complex-double-reg (values (tn-offset tn) t))))
(defconstant-eqx compare-conditions
'(:never := :< :<= :<< :<<= :sv :od :tr :<> :>= :> :>>= :>> :nsv :ev)
\f
;;;; Initial disassembler setup.
-(setf sb!disassem:*disassem-inst-alignment-bytes* 4)
+;;; FIXME-lav: is this still used, if so , why use package prefix
+;;; (setf sb!disassem:*disassem-inst-alignment-bytes* 4)
(defvar *disassem-use-lisp-reg-names* t)
+; In each define-instruction the form (:dependencies ...)
+; contains read and write howto that passed as LOC here.
+; Example: (:dependencies (reads src) (writes dst) (writes temp))
+; src, dst and temp is passed each in loc, and can be a register
+; immediate or anything else.
+; this routine will return an location-number
+; this number must be less than *assem-max-locations*
+(!def-vm-support-routine location-number (loc)
+ (etypecase loc
+ (null)
+ (number)
+ (label)
+ (fixup)
+ (tn
+ (ecase (sb-name (sc-sb (tn-sc loc)))
+ (immediate-constant
+ ;; Can happen if $ZERO or $NULL are passed in.
+ nil)
+ (registers
+ (unless (zerop (tn-offset loc))
+ (tn-offset loc)))))
+ (symbol
+ (ecase loc
+ (:memory 0)))))
+
(defparameter reg-symbols
(map 'vector
- #'(lambda (name)
- (cond ((null name) nil)
- (t (make-symbol (concatenate 'string "$" name)))))
+ (lambda (name)
+ (cond ((null name) nil)
+ (t (make-symbol (concatenate 'string "$" name)))))
*register-names*))
(sb!disassem:define-arg-type reg
- :printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'registers
- regname
- dstate))))
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'registers
+ regname
+ dstate))))
(defparameter float-reg-symbols
#.(coerce
'vector))
(sb!disassem:define-arg-type fp-reg
- :printer #'(lambda (value stream dstate)
- (declare (stream stream) (fixnum value))
- (let ((regname (aref float-reg-symbols value)))
- (princ regname stream)
- (sb!disassem:maybe-note-associated-storage-ref
- value
- 'float-registers
- regname
- dstate))))
+ :printer (lambda (value stream dstate)
+ (declare (stream stream) (fixnum value))
+ (let ((regname (aref float-reg-symbols value)))
+ (princ regname stream)
+ (sb!disassem:maybe-note-associated-storage-ref
+ value
+ 'float-registers
+ regname
+ dstate))))
(sb!disassem:define-arg-type fp-fmt-0c
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (ecase value
- (0 (format stream "~A" '\,SGL))
- (1 (format stream "~A" '\,DBL))
- (3 (format stream "~A" '\,QUAD)))))
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (ecase value
+ (0 (format stream "~A" '\,SGL))
+ (1 (format stream "~A" '\,DBL))
+ (3 (format stream "~A" '\,QUAD)))))
(defun low-sign-extend (x n)
(let ((normal (dpb x (byte 1 (1- n)) (ldb (byte (1- n) 1) x))))
(incf offset (byte-size e)))
result))
-(defmacro define-imx-decode (name bits)
+(macrolet ((define-imx-decode (name bits)
`(sb!disassem:define-arg-type ,name
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (low-sign-extend value ,bits)))))
-
-(define-imx-decode im5 5)
-(define-imx-decode im11 11)
-(define-imx-decode im14 14)
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (low-sign-extend value ,bits))))))
+ (define-imx-decode im5 5)
+ (define-imx-decode im11 11)
+ (define-imx-decode im14 14))
(sb!disassem:define-arg-type im3
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (assemble-bits value `(,(byte 1 0)
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (assemble-bits value `(,(byte 1 0)
,(byte 2 1))))))
(sb!disassem:define-arg-type im21
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S"
- (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
- ,(byte 2 14) ,(byte 5 16)
- ,(byte 2 12))))))
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S"
+ (assemble-bits value `(,(byte 1 0) ,(byte 11 1)
+ ,(byte 2 14) ,(byte 5 16)
+ ,(byte 2 12))))))
(sb!disassem:define-arg-type cp
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (- 31 value))))
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (- 31 value))))
(sb!disassem:define-arg-type clen
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" (- 32 value))))
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" (- 32 value))))
(sb!disassem:define-arg-type compare-condition
:printer #("" \,= \,< \,<= \,<< \,<<= \,SV \,OD \,TR \,<> \,>=
\?>= \!< \!?= \<> \!= \!=T \!? \<=> \TRUE? \TRUE))
(sb!disassem:define-arg-type integer
- :printer #'(lambda (value stream dstate)
- (declare (ignore dstate) (stream stream) (fixnum value))
- (format stream "~S" value)))
+ :printer (lambda (value stream dstate)
+ (declare (ignore dstate) (stream stream) (fixnum value))
+ (format stream "~S" value)))
(sb!disassem:define-arg-type space
:printer #("" |1,| |2,| |3,|))
(t :field (byte 5 21) :type 'reg)
(w :fields `(,(byte 5 16) ,(byte 11 2) ,(byte 1 0))
:use-label
- #'(lambda (value dstate)
- (declare (type sb!disassem:disassem-state dstate) (list value))
- (let ((x (logior (ash (first value) 12) (ash (second value) 1)
- (third value))))
- (+ (ash (sign-extend
- (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
- ,(byte 10 2))) 17) 2)
- (sb!disassem:dstate-cur-addr dstate) 8))))
+ (lambda (value dstate)
+ (declare (type sb!disassem:disassem-state dstate) (list value))
+ (let ((x (logior (ash (first value) 12) (ash (second value) 1)
+ (third value))))
+ (+ (ash (sign-extend
+ (assemble-bits x `(,(byte 1 0) ,(byte 5 12) ,(byte 1 1)
+ ,(byte 10 2))) 17) 2)
+ (sb!disassem:dstate-cur-addr dstate) 8))))
(op2 :field (byte 3 13))
(n :field (byte 1 1) :type 'nullify))
(r1 :field (byte 5 16) :type 'reg)
(w :fields `(,(byte 11 2) ,(byte 1 0))
:use-label
- #'(lambda (value dstate)
- (declare (type sb!disassem:disassem-state dstate) (list value))
- (let ((x (logior (ash (first value) 1) (second value))))
- (+ (ash (sign-extend
- (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
- 12) 2)
- (sb!disassem:dstate-cur-addr dstate) 8))))
+ (lambda (value dstate)
+ (declare (type sb!disassem:disassem-state dstate) (list value))
+ (let ((x (logior (ash (first value) 1) (second value))))
+ (+ (ash (sign-extend
+ (assemble-bits x `(,(byte 1 0) ,(byte 1 1) ,(byte 10 2)))
+ 12) 2)
+ (sb!disassem:dstate-cur-addr dstate) 8))))
(c :field (byte 3 13))
(n :field (byte 1 1) :type 'nullify))
(nt "Halt trap"))
(#.fun-end-breakpoint-trap
(nt "Function end breakpoint trap"))
- )))
+ (#.single-step-around-trap
+ (nt "Single step around trap")))))
(sb!disassem:define-instruction-format
(system-inst 32)
(byte 2 14)
(byte 14 0))
-
-(defun im14-encoding (segment disp)
- (declare (type (or fixup (signed-byte 14))))
- (cond ((fixup-p disp)
- (note-fixup segment :load disp)
- (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+(defun encode-imm21 (segment value)
+ (declare (type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+ (cond ((fixup-p value)
+ (note-fixup segment :hi value)
+ (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
0)
(t
- (dpb (ldb (byte 13 0) disp)
- (byte 13 1)
- (ldb (byte 1 13) disp)))))
+ (let ((hi (ldb (byte 21 11) value)))
+ (logior (ash (ldb (byte 5 2) hi) 16)
+ (ash (ldb (byte 2 7) hi) 14)
+ (ash (ldb (byte 2 0) hi) 12)
+ (ash (ldb (byte 11 9) hi) 1)
+ (ldb (byte 1 20) hi))))))
+
+(defun encode-imm11 (value)
+ (declare (type (signed-byte 11) value))
+ (dpb (ldb (byte 10 0) value)
+ (byte 10 1)
+ (ldb (byte 1 10) value)))
-(macrolet ((define-load-inst (name opcode)
- `(define-instruction ,name (segment disp base reg)
- (:declare (type tn reg base)
- (type (or fixup (signed-byte 14)) disp))
- (:printer load/store ((op ,opcode) (s 0))
- '(:name :tab im14 "(" s b ")," t/r))
- (:emitter
+(defun encode-imm11u (value)
+ (declare (type (or (signed-byte 32) (unsigned-byte 32)) value))
+ (declare (type (unsigned-byte 11) value))
+ (dpb (ldb (byte 11 0) value)
+ (byte 11 1)
+ 0))
+
+(defun encode-imm14 (value)
+ (declare (type (signed-byte 14) value))
+ (dpb (ldb (byte 13 0) value)
+ (byte 13 1)
+ (ldb (byte 1 13) value)))
+
+(defun encode-disp/fixup (segment disp imm-bits)
+ (cond
+ ((fixup-p disp)
+ (aver (or (null (fixup-offset disp)) (zerop (fixup-offset disp))))
+ (if imm-bits
+ (note-fixup segment :load11u disp)
+ (note-fixup segment :load disp))
+ 0)
+ (t
+ (if imm-bits
+ (encode-imm11u disp)
+ (encode-imm14 disp)))))
+
+; LDO can be used in two ways: to load an 14bit-signed value
+; or load an 11bit-unsigned value. The latter is used for
+; example in an LDIL/LDO pair. The key :unsigned specifies this.
+(macrolet ((define-load-inst (name opcode &optional imm-bits)
+ `(define-instruction ,name (segment disp base reg &key unsigned)
+ (:declare (type tn reg base)
+ (type (member t nil) unsigned)
+ (type (or fixup (signed-byte 14)) disp))
+ (:delay 0)
+ (:printer load/store ((op ,opcode) (s 0))
+ '(:name :tab im14 "(" s b ")," t/r))
+ (:dependencies (reads base) (reads :memory) (writes reg))
+ (:emitter
(emit-load/store segment ,opcode
- (reg-tn-encoding base) (reg-tn-encoding reg) 0
- (im14-encoding segment disp)))))
- (define-store-inst (name opcode)
- `(define-instruction ,name (segment reg disp base)
- (:declare (type tn reg base)
- (type (or fixup (signed-byte 14)) disp))
- (:printer load/store ((op ,opcode) (s 0))
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (if unsigned
+ (encode-disp/fixup segment disp t)
+ (encode-disp/fixup segment disp nil))))))
+ (define-store-inst (name opcode &optional imm-bits)
+ `(define-instruction ,name (segment reg disp base)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 14)) disp))
+ (:delay 0)
+ (:printer load/store ((op ,opcode) (s 0))
'(:name :tab t/r "," im14 "(" s b ")"))
- (:emitter
+ (:dependencies (reads base) (reads reg) (writes :memory))
+ (:emitter
(emit-load/store segment ,opcode
- (reg-tn-encoding base) (reg-tn-encoding reg) 0
- (im14-encoding segment disp))))))
- (define-load-inst ldw #x12)
- (define-load-inst ldh #x11)
- (define-load-inst ldb #x10)
- (define-load-inst ldwm #x13)
- (define-load-inst ldo #x0D)
-
- (define-store-inst stw #x1A)
- (define-store-inst sth #x19)
- (define-store-inst stb #x18)
- (define-store-inst stwm #x1B))
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (encode-disp/fixup segment disp ,imm-bits))))))
+ (define-load-inst ldw #x12)
+ (define-load-inst ldh #x11)
+ (define-load-inst ldb #x10)
+ (define-load-inst ldwm #x13)
+ (define-load-inst ldo #x0D)
+ (define-store-inst stw #x1A)
+ (define-store-inst sth #x19)
+ (define-store-inst stb #x18)
+ (define-store-inst stwm #x1B))
(define-bitfield-emitter emit-extended-load/store 32
(byte 6 26) (byte 5 21) (byte 5 16) (byte 2 14) (byte 1 13)
`(define-instruction ,name (segment index base reg &key modify scale)
(:declare (type tn reg base index)
(type (member t nil) modify scale))
+ (:delay 0)
+ (:dependencies (reads index) (reads base) (writes reg) (reads :memory))
(:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
(op2 0))
`(:name ,@cmplt-index-print :tab x/im5/r
(:declare (type tn base reg)
(type (or fixup (signed-byte 5)) disp)
(type (member :before :after nil) modify))
+ (:delay 0)
+ (:dependencies (reads base) (writes reg) (reads :memory))
(:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
(op2 4))
`(:name ,@cmplt-disp-print :tab x/im5/r
(:declare (type tn reg base)
(type (or fixup (signed-byte 5)) disp)
(type (member :before :after nil) modify))
+ (:delay 0)
+ (:dependencies (reads base) (reads reg) (writes :memory))
(:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
(op2 4))
`(:name ,@cmplt-disp-print :tab x/im5/r
(type (signed-byte 5) disp)
(type (member :begin :end) where)
(type (member t nil) modify))
+ (:delay 0)
+ (:dependencies (reads base) (reads reg) (writes :memory))
(:printer extended-load/store ((ext4/c #xC) (t/im5 nil :type 'im5) (op2 4))
`(:name ,@cmplt-store-print :tab x/im5/r "," t/im5 "(" s b ")"))
(:emitter
(short-disp-encoding segment disp))))
\f
-;;;; Immediate Instructions.
+;;;; Immediate 21-bit Instructions.
+;;; Note the heavy scrambling of the immediate value to instruction memory
-(define-bitfield-emitter emit-ldil 32
+(define-bitfield-emitter emit-imm21 32
(byte 6 26)
(byte 5 21)
(byte 21 0))
-(defun immed-21-encoding (segment value)
- (declare (type (or fixup (signed-byte 21) (unsigned-byte 21)) value))
- (cond ((fixup-p value)
- (note-fixup segment :hi value)
- (aver (or (null (fixup-offset value)) (zerop (fixup-offset value))))
- 0)
- (t
- (logior (ash (ldb (byte 5 2) value) 16)
- (ash (ldb (byte 2 7) value) 14)
- (ash (ldb (byte 2 0) value) 12)
- (ash (ldb (byte 11 9) value) 1)
- (ldb (byte 1 20) value)))))
-
(define-instruction ldil (segment value reg)
(:declare (type tn reg)
- (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
+ (:delay 0)
+ (:dependencies (writes reg))
(:printer ldil ((op #x08)))
(:emitter
- (emit-ldil segment #x08 (reg-tn-encoding reg)
- (immed-21-encoding segment value))))
+ (emit-imm21 segment #x08 (reg-tn-encoding reg)
+ (encode-imm21 segment value))))
+; this one overwrites number stack ?
(define-instruction addil (segment value reg)
(:declare (type tn reg)
- (type (or (signed-byte 21) (unsigned-byte 21) fixup) value))
+ (type (or (signed-byte 32) (unsigned-byte 32) fixup) value))
+ (:delay 0)
+ (:dependencies (writes reg))
(:printer ldil ((op #x0A)))
(:emitter
- (emit-ldil segment #x0A (reg-tn-encoding reg)
- (immed-21-encoding segment value))))
+ (emit-imm21 segment #x0A (reg-tn-encoding reg)
+ (encode-imm21 segment value))))
\f
;;;; Branch instructions.
(type label target)
(type (member t nil) nullify))
(emit-back-patch segment 4
- #'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (aver (<= (- (ash 1 16)) disp (1- (ash 1 16))))
- (multiple-value-bind
- (w1 w2 w)
- (decompose-branch-disp segment disp)
- (emit-branch segment opcode link w1 sub-opcode w2
- (if nullify 1 0) w))))))
+ (lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (aver (typep disp '(signed-byte 17)))
+ (multiple-value-bind
+ (w1 w2 w)
+ (decompose-branch-disp segment disp)
+ (emit-branch segment opcode link w1 sub-opcode w2
+ (if nullify 1 0) w))))))
(define-instruction b (segment target &key nullify)
(:declare (type label target) (type (member t nil) nullify))
+ (:delay 0)
(:emitter
(emit-relative-branch segment #x3A 0 0 target nullify)))
(define-instruction bl (segment target reg &key nullify)
(:declare (type tn reg) (type label target) (type (member t nil) nullify))
(:printer branch17 ((op1 #x3A) (op2 0)) '(:name n :tab w "," t))
+ (:delay 0)
+ (:dependencies (writes reg))
(:emitter
(emit-relative-branch segment #x3A (reg-tn-encoding reg) 0 target nullify)))
(define-instruction gateway (segment target reg &key nullify)
(:declare (type tn reg) (type label target) (type (member t nil) nullify))
(:printer branch17 ((op1 #x3A) (op2 1)) '(:name n :tab w "," t))
+ (:delay 0)
+ (:dependencies (writes reg))
(:emitter
(emit-relative-branch segment #x3A (reg-tn-encoding reg) 1 target nullify)))
(:declare (type tn base)
(type (member t nil) nullify)
(type (or tn null) offset))
+ (:delay 0)
+ (:dependencies (reads base))
(:printer branch ((op1 #x3A) (op2 6)) '(:name n :tab x "(" t ")"))
(:emitter
(emit-branch segment #x3A (reg-tn-encoding base)
(type tn base)
(type (unsigned-byte 3) space)
(type (member t nil) nullify))
+ (:delay 0)
+ (:dependencies (reads base))
(:printer branch17 ((op1 #x38) (op2 nil :type 'im3))
'(:name n :tab w "(" op2 "," t ")"))
(:emitter
(type tn base)
(type (unsigned-byte 3) space)
(type (member t nil) nullify))
+ (:delay 0)
+ (:dependencies (reads base))
(:printer branch17 ((op1 #x39) (op2 nil :type 'im3))
'(:name n :tab w "(" op2 "," t ")"))
+ (:dependencies (writes lip-tn))
(:emitter
(multiple-value-bind
(w1 w2 w)
(defun emit-conditional-branch (segment opcode r2 r1 cond target nullify)
(emit-back-patch segment 4
- #'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
- (aver (<= (- (ash 1 11)) disp (1- (ash 1 11))))
- (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
- (ldb (byte 1 10) disp)))
- (w (ldb (byte 1 11) disp)))
- (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
+ (lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ ; emit-conditional-branch is used by instruction emitters: MOVB, COMB, ADDB and BB
+ ; which assembles an immediate of total 12 bits (including sign bit).
+ (aver (typep disp '(signed-byte 12)))
+ (let ((w1 (logior (ash (ldb (byte 10 0) disp) 1)
+ (ldb (byte 1 10) disp)))
+ (w (ldb (byte 1 11) disp))) ; take out the sign bit
+ (emit-branch segment opcode r2 r1 cond w1 (if nullify 1 0) w))))))
(defun im5-encoding (value)
(declare (type (signed-byte 5) value)
(byte 4 1)
(ldb (byte 1 4) value)))
-(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind)
+(macrolet ((define-branch-inst (r-name r-opcode i-name i-opcode cond-kind
+ writes-reg)
(let* ((conditional (symbolicate cond-kind "-CONDITION"))
(false-conditional (symbolicate conditional "-FALSE")))
`(progn
(define-instruction ,r-name (segment cond r1 r2 target &key nullify)
(:declare (type ,conditional cond)
- (type tn r1 r2)
- (type label target)
- (type (member t nil) nullify))
+ (type tn r1 r2)
+ (type label target)
+ (type (member t nil) nullify))
+ (:delay 0)
+ ,@(ecase writes-reg
+ (:write-reg
+ '((:dependencies (reads r1) (reads r2) (writes r2))))
+ (:pinned
+ '(:pinned))
+ (nil
+ '((:dependencies (reads r1) (reads r2)))))
+; ,@(if writes-reg
+; '((:dependencies (reads r1) (reads r2) (writes r2)))
+; '((:dependencies (reads r1) (reads r2))))
(:printer branch12 ((op1 ,r-opcode) (c nil :type ',conditional))
'(:name c n :tab r1 "," r2 "," w))
,@(unless (= r-opcode #x32)
- `((:printer branch12 ((op1 ,(+ 2 r-opcode))
- (c nil :type ',false-conditional))
- '(:name c n :tab r1 "," r2 "," w))))
+ `((:printer branch12 ((op1 ,(+ 2 r-opcode))
+ (c nil :type ',false-conditional))
+ '(:name c n :tab r1 "," r2 "," w))))
(:emitter
(multiple-value-bind
(cond-encoding false)
cond-encoding target nullify))))
(define-instruction ,i-name (segment cond imm reg target &key nullify)
(:declare (type ,conditional cond)
- (type (signed-byte 5) imm)
- (type tn reg)
- (type (member t nil) nullify))
+ (type (signed-byte 5) imm)
+ (type tn reg)
+ (type (member t nil) nullify))
+ (:delay 0)
+; ,@(if writes-reg
+; '((:dependencies (reads reg) (writes reg)))
+; '((:dependencies (reads reg))))
+ ,@(ecase writes-reg
+ (:write-reg
+ '((:dependencies (reads r1) (reads r2) (writes r2))))
+ (:pinned
+ '(:pinned))
+ (nil
+ '((:dependencies (reads r1) (reads r2)))))
(:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
(c nil :type ',conditional))
'(:name c n :tab r1 "," r2 "," w))
segment (if false (+ ,i-opcode 2) ,i-opcode)
(reg-tn-encoding reg) (im5-encoding imm)
cond-encoding target nullify))))))))
- (define-branch-inst movb #x32 movib #x33 extract/deposit)
- (define-branch-inst comb #x20 comib #x21 compare)
- (define-branch-inst addb #x28 addib #x29 add))
+ (define-branch-inst movb #x32 movib #x33 extract/deposit :write-reg)
+ (define-branch-inst comb #x20 comib #x21 compare :pinned)
+ (define-branch-inst addb #x28 addib #x29 add :write-reg))
(define-instruction bb (segment cond reg posn target &key nullify)
(:declare (type (member t nil) cond nullify)
(type tn reg)
(type (or (member :variable) (unsigned-byte 5)) posn))
+ (:delay 0)
+ (:dependencies (reads reg))
(:printer branch12 ((op1 30) (c nil :type 'extract/deposit-condition))
'('BVB c n :tab r1 "," w))
(:emitter
(byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
(byte 1 12) (byte 7 5) (byte 5 0))
-(macrolet ((define-r3-inst (name cond-kind opcode)
+(macrolet ((define-r3-inst (name cond-kind opcode &optional pinned)
`(define-instruction ,name (segment r1 r2 res &optional cond)
(:declare (type tn res r1 r2))
+ (:delay 0)
+ ,@(if pinned
+ '(:pinned)
+ '((:dependencies (reads r1) (reads r2) (writes res))))
(:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
cond-kind
"-CONDITION"))))
- ,@(when (= opcode #x12)
+ ,@(when (eq name 'or)
`((:printer r3-inst ((op ,opcode) (r2 0)
(c nil :type ',(symbolicate cond-kind
"-CONDITION")))
(define-r3-inst subto compare #x66)
(define-r3-inst ds compare #x22)
(define-r3-inst comclr compare #x44)
- (define-r3-inst or logical #x12)
+ (define-r3-inst or logical #x12 t) ; as a nop it must be pinned
(define-r3-inst xor logical #x14)
(define-r3-inst and logical #x10)
(define-r3-inst andcm logical #x00)
(byte 6 26) (byte 5 21) (byte 5 16) (byte 3 13)
(byte 1 12) (byte 1 11) (byte 11 0))
-(defun im11-encoding (value)
- (declare (type (signed-byte 11) value)
- #+nil (values (unsigned-byte 11)))
- (dpb (ldb (byte 10 0) value)
- (byte 10 1)
- (ldb (byte 1 10) value)))
-
-(macrolet ((define-imm-inst (name cond-kind opcode subcode)
- `(define-instruction ,name (segment imm src dst &optional cond)
- (:declare (type tn dst src)
+(macrolet ((define-imm-inst (name cond-kind opcode subcode &optional pinned)
+ `(define-instruction ,name (segment imm src dst &optional cond)
+ (:declare (type tn dst src)
(type (signed-byte 11) imm))
- (:printer imm-inst ((op ,opcode) (o ,subcode)
- (c nil :type
- ',(symbolicate cond-kind "-CONDITION"))))
- (:emitter
- (multiple-value-bind
- (cond false)
+ (:delay 0)
+ (:printer imm-inst ((op ,opcode) (o ,subcode)
+ (c nil :type
+ ',(symbolicate cond-kind "-CONDITION"))))
+ (:dependencies (reads imm) (reads src) (writes dst))
+ (:emitter
+ (multiple-value-bind (cond false)
(,(symbolicate cond-kind "-CONDITION") cond)
(emit-imm-inst segment ,opcode (reg-tn-encoding src)
(reg-tn-encoding dst) cond
(if false 1 0) ,subcode
- (im11-encoding imm)))))))
+ (encode-imm11 imm)))))))
(define-imm-inst addi add #x2D 0)
(define-imm-inst addio add #x2D 1)
(define-imm-inst addit add #x2C 0)
(define-instruction shd (segment r1 r2 count res &optional cond)
(:declare (type tn res r1 r2)
(type (or (member :variable) (integer 0 31)) count))
+ (:delay 0)
+ :pinned
(:printer extract/deposit-inst ((op1 #x34) (op2 2) (t/clen nil :type 'reg))
'(:name c :tab r1 "," r2 "," cp "," t/clen))
(:printer extract/deposit-inst ((op1 #x34) (op2 0) (t/clen nil :type 'reg))
(:declare (type tn res src)
(type (or (member :variable) (integer 0 31)) posn)
(type (integer 1 32) len))
+ (:delay 0)
+ (:dependencies (reads src) (writes res))
(:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
(op2 ,opcode))
'(:name c :tab r2 "," cp "," t/clen "," r1))
(define-extract-inst extrs 7))
(macrolet ((define-deposit-inst (name opcode)
- `(define-instruction ,name (segment src posn len res &optional cond)
- (:declare (type tn res)
- (type (or tn (signed-byte 5)) src)
- (type (or (member :variable) (integer 0 31)) posn)
- (type (integer 1 32) len))
- (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
- ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
- ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
- (op2 ,(+ 4 opcode)))
- ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
- (op2 ,(+ 6 opcode)))
- ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
- (if (= opcode 0) (cons ''Z base) base)))
- (:emitter
+ `(define-instruction ,name (segment src posn len res &optional cond)
+ (:declare (type tn res)
+ (type (or tn (signed-byte 5)) src)
+ (type (or (member :variable) (integer 0 31)) posn)
+ (type (integer 1 32) len))
+ (:delay 0)
+ (:dependencies (reads src) (writes res))
+ (:printer extract/deposit-inst ((op1 #x35) (op2 ,opcode))
+ ',(let ((base '('VDEP c :tab r1 "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (op2 ,(+ 2 opcode)))
+ ',(let ((base '('DEP c :tab r1 "," cp "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+ (op2 ,(+ 4 opcode)))
+ ',(let ((base '('VDEPI c :tab r1 "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:printer extract/deposit-inst ((op1 #x35) (r1 nil :type 'im5)
+ (op2 ,(+ 6 opcode)))
+ ',(let ((base '('DEPI c :tab r1 "," cp "," t/clen "," r2)))
+ (if (= opcode 0) (cons ''Z base) base)))
+ (:emitter
+ (multiple-value-bind
+ (opcode src-encoding)
+ (etypecase src
+ (tn
+ (values ,opcode (reg-tn-encoding src)))
+ ((signed-byte 5)
+ (values ,(+ opcode 4) (im5-encoding src))))
(multiple-value-bind
- (opcode src-encoding)
- (etypecase src
- (tn
- (values ,opcode (reg-tn-encoding src)))
- ((signed-byte 5)
- (values ,(+ opcode 4) (im5-encoding src))))
- (multiple-value-bind
- (opcode posn-encoding)
- (etypecase posn
- ((member :variable)
- (values opcode 0))
- ((integer 0 31)
- (values (+ opcode 2) (- 31 posn))))
- (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
- src-encoding
- (extract/deposit-condition cond)
- opcode posn-encoding (- 32 len))))))))
+ (opcode posn-encoding)
+ (etypecase posn
+ ((member :variable)
+ (values opcode 0))
+ ((integer 0 31)
+ (values (+ opcode 2) (- 31 posn))))
+ (emit-extract/deposit-inst segment #x35 (reg-tn-encoding res)
+ src-encoding
+ (extract/deposit-condition cond)
+ opcode posn-encoding (- 32 len))))))))
(define-deposit-inst dep 1)
(define-deposit-inst zdep 0))
(define-instruction break (segment &optional (im5 0) (im13 0))
(:declare (type (unsigned-byte 13) im13)
(type (unsigned-byte 5) im5))
+ (:cost 0)
+ (:delay 0)
+ :pinned
(:printer break () :default :control #'break-control)
(:emitter
(emit-break segment 0 im13 0 im5)))
(define-instruction ldsid (segment res base &optional (space 0))
(:declare (type tn res base)
(type (integer 0 3) space))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #x85) (c nil :type 'space)
(s nil :printer #(0 0 1 1 2 2 3 3)))
`(:name :tab "(" s r1 ")," r3))
(define-instruction mtsp (segment reg space)
(:declare (type tn reg) (type (integer 0 7) space))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #xC1)) '(:name :tab r2 "," s))
(:emitter
(emit-system-inst segment 0 0 (reg-tn-encoding reg) (space-encoding space)
(define-instruction mfsp (segment space reg)
(:declare (type tn reg) (type (integer 0 7) space))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #x25) (c nil :type 'space)) '(:name :tab s r3))
(:emitter
(emit-system-inst segment 0 0 0 (space-encoding space) #x25
(define-instruction mtctl (segment reg ctrl-reg)
(:declare (type tn reg) (type control-reg ctrl-reg))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #xC2)) '(:name :tab r2 "," r1))
(:emitter
(emit-system-inst segment 0 (control-reg ctrl-reg) (reg-tn-encoding reg)
(define-instruction mfctl (segment ctrl-reg reg)
(:declare (type tn reg) (type control-reg ctrl-reg))
+ (:delay 0)
+ :pinned
(:printer system-inst ((op2 #x45)) '(:name :tab r1 "," r3))
(:emitter
(emit-system-inst segment 0 (control-reg ctrl-reg) 0 0 #x45
(:declare (type tn index base result)
(type (member t nil) modify scale)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 0))
- `('FLDDX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ `('FLDD ,@cmplt-index-print :tab x "(" s b ")" "," t))
(:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 0))
- `('FLDWX ,@cmplt-index-print :tab x "(" s b ")" "," t))
+ `('FLDW ,@cmplt-index-print :tab x "(" s b ")" "," t))
(:emitter
(multiple-value-bind
(result-encoding double-p)
(:declare (type tn index base value)
(type (member t nil) modify scale)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(:printer fp-load/store ((op #x0b) (x1 0) (x2 0) (x3 1))
- `('FSTDX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ `('FSTD ,@cmplt-index-print :tab t "," x "(" s b ")"))
(:printer fp-load/store ((op #x09) (x1 0) (x2 0) (x3 1))
- `('FSTWX ,@cmplt-index-print :tab t "," x "(" s b ")"))
+ `('FSTW ,@cmplt-index-print :tab t "," x "(" s b ")"))
(:emitter
(multiple-value-bind
(value-encoding double-p)
(type (signed-byte 5) disp)
(type (member :before :after nil) modify)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
- `('FLDDS ,@cmplt-disp-print :tab x "(" s b ")," t))
+ `('FLDD ,@cmplt-disp-print :tab x "(" s b ")," t))
(:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 0))
- `('FLDWS ,@cmplt-disp-print :tab x "(" s b ")," t))
+ `('FLDW ,@cmplt-disp-print :tab x "(" s b ")," t))
(:emitter
(multiple-value-bind
(result-encoding double-p)
(type (signed-byte 5) disp)
(type (member :before :after nil) modify)
(type (member nil 0 1) side))
+ (:delay 0)
+ :pinned
(:printer fp-load/store ((op #x0b) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
- `('FSTDS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
+ `('FSTD ,@cmplt-disp-print :tab t "," x "(" s b ")"))
(:printer fp-load/store ((op #x09) (x nil :type 'im5) (x1 1) (x2 0) (x3 1))
- `('FSTWS ,@cmplt-disp-print :tab t "," x "(" s b ")"))
+ `('FSTW ,@cmplt-disp-print :tab t "," x "(" s b ")"))
(:emitter
(multiple-value-bind
(value-encoding double-p)
(define-instruction funop (segment op from to)
(:declare (type funop op)
(type tn from to))
+ (:delay 0)
+ :pinned
(:printer fp-class-0-inst ((op1 #x0C) (op2 2) (x2 0))
'('FCPY fmt :tab r "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 3) (x2 0))
(macrolet ((define-class-1-fp-inst (name subcode)
`(define-instruction ,name (segment from to)
(:declare (type tn from to))
+ (:delay 0)
(:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
'(:name sf df :tab r "," t))
(:emitter
(define-instruction fcmp (segment cond r1 r2)
(:declare (type (unsigned-byte 5) cond)
(type tn r1 r2))
+ (:delay 0)
+ :pinned
(:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 2) (t nil :type 'fcmp-cond))
'(:name fmt t :tab r "," x1))
(:emitter
(if r1-double-p 1 0) 2 0 0 cond)))))
(define-instruction ftest (segment)
+ (:delay 0)
+ :pinned
(:printer fp-class-0-inst ((op1 #x0c) (op2 1) (x2 2)) '(:name))
(:emitter
(emit-fp-class-0-inst segment #x0C 0 0 1 0 2 0 1 0)))
(define-instruction fbinop (segment op r1 r2 result)
(:declare (type fbinop op)
(type tn r1 r2 result))
+ (:delay 0)
+ :pinned
(:printer fp-class-0-inst ((op1 #x0C) (op2 0) (x2 3))
'('FADD fmt :tab r "," x1 "," t))
(:printer fp-class-0-inst ((op1 #x0C) (op2 1) (x2 3))
(define-instruction li (segment value reg)
(:declare (type tn reg)
(type (or fixup (signed-byte 32) (unsigned-byte 32)) value))
+ (:delay 0)
+ (:dependencies (reads reg))
(:vop-var vop)
(:emitter
(assemble (segment vop)
(etypecase value
(fixup
(inst ldil value reg)
- (inst ldo value reg reg))
+ (inst ldo value reg reg :unsigned t))
((signed-byte 14)
(inst ldo value zero-tn reg))
((or (signed-byte 32) (unsigned-byte 32))
- (let ((hi (ldb (byte 21 11) value))
- (lo (ldb (byte 11 0) value)))
- (inst ldil hi reg)
- (unless (zerop lo)
- (inst ldo lo reg reg))))))))
+ (let ((lo (ldb (byte 11 0) value)))
+ (inst ldil value reg)
+ (inst ldo lo reg reg :unsigned t)))))))
(define-instruction-macro sll (src count result &optional cond)
(once-only ((result result) (src src) (count count) (cond cond))
(type (member t nil) not-p)
(type tn r1 r2)
(type label target))
+ (:delay 0)
+ (:dependencies (reads r1) (reads r2))
(:vop-var vop)
(:emitter
(emit-chooser segment 8 2
- #'(lambda (segment posn delta)
- (let ((disp (label-relative-displacement target posn delta)))
- (when (<= 0 disp (1- (ash 1 11)))
- (assemble (segment vop)
- (inst comb (maybe-negate-cond cond not-p) r1 r2 target
- :nullify t))
- t)))
- #'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
+ (lambda (segment posn delta)
+ (let ((disp (label-relative-displacement target posn delta)))
+ (when (<= 0 disp (1- (ash 1 11)))
(assemble (segment vop)
- (cond ((<= (- (ash 1 11)) disp (1- (ash 1 11)))
- (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
- (inst nop))
- (t
- (inst comclr r1 r2 zero-tn
- (maybe-negate-cond cond (not not-p)))
- (inst b target :nullify t)))))))))
+ (inst comb (maybe-negate-cond cond not-p) r1 r2 target
+ :nullify t))
+ t)))
+ (lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (assemble (segment vop)
+ (cond ((typep disp '(signed-byte 12))
+ (inst comb (maybe-negate-cond cond not-p) r1 r2 target)
+ (inst nop)) ; FIXME-lav, cant nullify when backward branch
+ (t
+ (inst comclr r1 r2 zero-tn
+ (maybe-negate-cond cond (not not-p)))
+ (inst b target :nullify t)))))))))
(define-instruction bci (segment cond not-p imm reg target)
(:declare (type compare-condition cond)
(type (signed-byte 11) imm)
(type tn reg)
(type label target))
+ (:delay 0)
+ (:dependencies (reads reg))
(:vop-var vop)
(:emitter
(emit-chooser segment 8 2
- #'(lambda (segment posn delta-if-after)
- (let ((disp (label-relative-displacement target posn delta-if-after)))
- (when (and (<= 0 disp (1- (ash 1 11)))
- (<= (- (ash 1 4)) imm (1- (ash 1 4))))
- (assemble (segment vop)
- (inst comib (maybe-negate-cond cond not-p) imm reg target
- :nullify t))
- t)))
- #'(lambda (segment posn)
- (let ((disp (label-relative-displacement target posn)))
+ (lambda (segment posn delta-if-after)
+ (let ((disp (label-relative-displacement target posn delta-if-after)))
+ (when (and (<= 0 disp (1- (ash 1 11)))
+ (typep imm '(signed-byte 5)))
(assemble (segment vop)
- (cond ((and (<= (- (ash 1 11)) disp (1- (ash 1 11)))
- (<= (- (ash 1 4)) imm (1- (ash 1 4))))
- (inst comib (maybe-negate-cond cond not-p) imm reg target)
- (inst nop))
- (t
- (inst comiclr imm reg zero-tn
- (maybe-negate-cond cond (not not-p)))
- (inst b target :nullify t)))))))))
+ (inst comib (maybe-negate-cond cond not-p) imm reg target
+ :nullify t))
+ t)))
+ (lambda (segment posn)
+ (let ((disp (label-relative-displacement target posn)))
+ (assemble (segment vop)
+ (cond ((and (typep disp '(signed-byte 12))
+ (typep imm '(signed-byte 5)))
+ (inst comib (maybe-negate-cond cond not-p) imm reg target)
+ (inst nop))
+ (t
+ (inst comiclr imm reg zero-tn
+ (maybe-negate-cond cond (not not-p)))
+ (inst b target :nullify t)))))))))
\f
;;;; Instructions to convert between code ptrs, functions, and lras.
-(defun emit-compute-inst (segment vop src label temp dst calc)
- (emit-chooser
- ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
- segment 12 3
- #'(lambda (segment posn delta-if-after)
- (let ((delta (funcall calc label posn delta-if-after)))
- (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
- (emit-back-patch segment 4
- #'(lambda (segment posn)
- (assemble (segment vop)
- (inst addi (funcall calc label posn 0) src
- dst))))
- t)))
- #'(lambda (segment posn)
- (let ((delta (funcall calc label posn 0)))
- ;; Note: if we used addil/ldo to do this in 2 instructions then the
- ;; intermediate value would be tagged but pointing into space.
- (assemble (segment vop)
- (inst ldil (ldb (byte 21 11) delta) temp)
- (inst ldo (ldb (byte 11 0) delta) temp temp)
- (inst add src temp dst))))))
-
-;; code = lip - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-lip (segment src label temp dst)
- (:declare (type tn src dst temp)
- (type label label))
- (:vop-var vop)
- (:emitter
- (emit-compute-inst segment vop src label temp dst
- #'(lambda (label posn delta-if-after)
- (- other-pointer-lowtag
- (label-position label posn delta-if-after)
- (component-header-length))))))
-
-;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
-;; = lra - (header + label-offset)
-(define-instruction compute-code-from-lra (segment src label temp dst)
- (:declare (type tn src dst temp)
- (type label label))
- (:vop-var vop)
- (:emitter
- (emit-compute-inst segment vop src label temp dst
- #'(lambda (label posn delta-if-after)
- (- (+ (label-position label posn delta-if-after)
- (component-header-length)))))))
-
-;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
-;; = code + header + label-offset
-(define-instruction compute-lra-from-code (segment src label temp dst)
- (:declare (type tn src dst temp)
- (type label label))
- (:vop-var vop)
+(defun emit-header-data (segment type)
+ (emit-back-patch
+ segment 4
+ (lambda (segment posn)
+ (emit-word segment
+ (logior type
+ (ash (+ posn (component-header-length))
+ (- n-widetag-bits word-shift)))))))
+
+(define-instruction simple-fun-header-word (segment)
+ :pinned
+ (:cost 0)
+ (:delay 0)
(:emitter
- (emit-compute-inst segment vop src label temp dst
- #'(lambda (label posn delta-if-after)
- (+ (label-position label posn delta-if-after)
- (component-header-length))))))
+ (emit-header-data segment simple-fun-header-widetag)))
-\f
-;;;; Data instructions.
-
-(define-instruction byte (segment byte)
+(define-instruction lra-header-word (segment)
+ :pinned
+ (:cost 0)
+ (:delay 0)
(:emitter
- (emit-byte segment byte)))
+ (emit-header-data segment return-pc-header-widetag)))
-(define-bitfield-emitter emit-halfword 16
- (byte 16 0))
-
-(define-instruction halfword (segment halfword)
- (:emitter
- (emit-halfword segment halfword)))
+(defun emit-compute-inst (segment vop src label temp dst calc)
+ (emit-chooser
+ ;; We emit either 12 or 4 bytes, so we maintain 3 byte alignments.
+ segment 12 3
+ ;; This is the best-case that emits one instruction ( 4 bytes )
+ (lambda (segment posn delta-if-after)
+ (let ((delta (funcall calc label posn delta-if-after)))
+ ;; WHEN, Why not AVER ?
+ (when (typep delta '(signed-byte 11))
+ (emit-back-patch segment 4
+ (lambda (segment posn)
+ (assemble (segment vop)
+ (inst addi (funcall calc label posn 0) src
+ dst))))
+ t)))
+ ;; This is the worst-case that emits three instruction ( 12 bytes )
+ (lambda (segment posn)
+ (let ((delta (funcall calc label posn 0)))
+ ;; FIXME-lav: why do we hit below check ?
+ ;; (when (<= (- (ash 1 10)) delta (1- (ash 1 10)))
+ ;; (error "emit-compute-inst selected worst-case, but is shrinkable, delta is ~s" delta))
+ ;; Note: if we used addil/ldo to do this in 2 instructions then the
+ ;; intermediate value would be tagged but pointing into space.
+ ;; Does above note mean that the intermediate value would be
+ ;; a bogus pointer that would be GCed wrongly ?
+ ;; Also what I can see addil would also overwrite NFP (r1) ???
+ (assemble (segment vop)
+ ;; Three instructions (4 * 3) this is the reason for 12 bytes
+ (inst ldil delta temp)
+ (inst ldo (ldb (byte 11 0) delta) temp temp :unsigned t)
+ (inst add src temp dst))))))
+
+(macrolet ((compute ((name) &body body)
+ `(define-instruction ,name (segment src label temp dst)
+ (:declare (type tn src dst temp) (type label label))
+ (:attributes variable-length)
+ (:dependencies (reads src) (writes dst) (writes temp))
+ (:delay 0)
+ (:vop-var vop)
+ (:emitter
+ (emit-compute-inst segment vop src label temp dst
+ ,@body)))))
+ (compute (compute-code-from-lip)
+ (lambda (label posn delta-if-after)
+ (- other-pointer-lowtag
+ (label-position label posn delta-if-after)
+ (component-header-length))))
+ (compute (compute-code-from-lra)
+ (lambda (label posn delta-if-after)
+ (- (+ (label-position label posn delta-if-after)
+ (component-header-length)))))
+ (compute (compute-lra-from-code)
+ (lambda (label posn delta-if-after)
+ (+ (label-position label posn delta-if-after)
+ (component-header-length)))))
+\f
+;;;; Data instructions.
(define-bitfield-emitter emit-word 32
(byte 32 0))
-(define-instruction word (segment word)
- (:emitter
- (emit-word segment word)))
+(macrolet ((data (size type)
+ `(define-instruction ,size (segment ,size)
+ (:declare (type ,type ,size))
+ (:cost 0)
+ (:delay 0)
+ :pinned
+ (:emitter
+ (,(symbolicate "EMIT-" size) segment ,size)))))
+ (data byte (or (unsigned-byte 8) (signed-byte 8)))
+ (data short (or (unsigned-byte 16) (signed-byte 16)))
+ (data word (or (unsigned-byte 23) (signed-byte 23))))
-(define-instruction fun-header-word (segment)
- (:emitter
- (emit-back-patch
- segment 4
- #'(lambda (segment posn)
- (emit-word segment
- (logior simple-fun-header-widetag
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift))))))))
-(define-instruction lra-header-word (segment)
- (:emitter
- (emit-back-patch
- segment 4
- #'(lambda (segment posn)
- (emit-word segment
- (logior return-pc-header-widetag
- (ash (+ posn (component-header-length))
- (- n-widetag-bits word-shift))))))))
projects / sbcl.git / blobdiff