Skip to content
Snippets Groups Projects
Commit c9462790 authored by hallgren's avatar hallgren
Browse files

New instruction definitions for the new assembler.

parent e5fac6e8
No related branches found
No related tags found
No related merge requests found
;;; -*- Package: SPARC -*- ;;; -*- Package: SPARC -*-
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at ;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact ;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ********************************************************************** ;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.9 1992/07/09 19:46:32 hallgren Exp $")
;;; ;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/insts.lisp,v 1.8 1992/03/06 11:01:37 wlott Exp $ ;;; **********************************************************************
;;; ;;;
;;; Description of the SPARC architecture. ;;; Description of the SPARC architecture.
;;; ;;;
;;; Written by William Lott ;;; Written by William Lott.
;;;
;;; Converted to the SPARC by Sean Hallgren.
;;; ;;;
(in-package "SPARC") (in-package "SPARC")
(use-package "ASSEM")
(use-package "NEW-ASSEM")
(use-package "EXT") (use-package "EXT")
(use-package "C") (use-package "C")
(disassem:set-disassem-params (def-assembler-params
:instruction-alignment 32 :scheduler-p nil)
:storage-class-sets '((register any-reg descriptor-reg base-character-reg
sap-reg signed-reg unsigned-reg
non-descriptor-reg interior-reg)
(float-reg single-reg double-reg)
(control-stack control-stack)
(number-stack signed-stack unsigned-stack
base-character-stack sap-stack
single-stack double-stack))
)
;;;; Special argument types and fixups. ;;;; Functions to convert TN's and random symbolic things into values.
(defvar *disassem-use-lisp-reg-names* t) (defun reg-tn-encoding (tn)
(declare (type tn tn))
(defconstant reg-symbols (sc-case tn
(map 'vector (zero zero-offset)
#'(lambda (name) (null null-offset)
(cond ((null name) nil) (t
(t (make-symbol (concatenate 'string "%" name))))) (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers)
*register-names*)) (tn-offset tn)
(error "~S isn't a register." tn)))))
(define-argument-type reg
:type '(and tn (defun fp-reg-tn-encoding (tn &optional odd)
(satisfies (lambda (object) (declare (type tn tn))
(or (eq (sc-name (tn-sc object)) 'null) (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers)
(eq (sc-name (tn-sc object)) 'zero) (error "~S isn't a floating-point register." tn))
(eq (sb-name (sc-sb (tn-sc object))) (if odd
'registers))))) (1+ (tn-offset tn))
:function (lambda (tn) (tn-offset tn)))
(case (sc-name (tn-sc tn))
(null null-offset) (defconstant branch-conditions
(zero 0) '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc))
(t (tn-offset tn))))
:disassem-printer #'(lambda (value stream dstate) (deftype branch-condition ()
(declare (stream stream) (fixnum value)) `(member ,@branch-conditions))
(let ((regname (aref reg-symbols value)))
(princ regname stream) (defun branch-condition (condition)
(disassem:maybe-note-associated-storage-ref (or (position condition branch-conditions)
value (error "Unknown branch condition: ~S~%Must be one of: ~S"
'register condition branch-conditions)))
regname
dstate))) (defconstant fp-branch-conditions
) '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o))
(defconstant float-reg-symbols (deftype fp-branch-condition ()
(coerce `(member ,@fp-branch-conditions))
(loop for n from 0 to 31 collect (make-symbol (format nil "%F~d" n)))
'vector)) (defun fp-branch-condition (condition)
(or (position condition fp-branch-conditions)
(define-argument-type fp-reg (error "Unknown fp-branch condition: ~S~%Must be one of: ~S"
:type '(and tn condition fp-branch-conditions)))
(satisfies (lambda (object)
(eq (sb-name (sc-sb (tn-sc object)))
'float-registers))))
:function tn-offset
:disassem-printer #'(lambda (value stream dstate)
(declare (stream stream) (fixnum value))
(let ((regname (aref float-reg-symbols value)))
(princ regname stream)
(disassem:maybe-note-associated-storage-ref
value
'float-reg
regname
dstate)))
)
(define-argument-type odd-fp-reg
:type '(and tn
(satisfies (lambda (object)
(eq (sb-name (sc-sb (tn-sc object)))
'float-registers))))
:function (lambda (tn) (1+ (tn-offset tn))))
(define-argument-type relative-label
:type 'label
:function (lambda (label)
(ash (- (label-position label) *current-position*) -2))
:sign-extend t
:disassem-use-label #'(lambda (value dstate)
(declare (type disassem:disassem-state dstate))
(+ (ash value 2) (disassem:dstate-curpos dstate))))
(eval-when (compile eval load)
(defconstant branch-conditions
'(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)))
;;; Note that these aren't the standard names for branch-conditions, I think
;;; they're a bit more readable (e.g., "eq" instead of "e"). You could just
;;; put a vector of the normal ones here too.
(defconstant branch-cond-name-vec
(coerce branch-conditions 'vector))
(define-argument-type branch-condition
:type '(member . #.branch-conditions)
:function (lambda (cond) (position cond branch-conditions))
:disassem-printer branch-cond-name-vec)
(defconstant branch-cond-true
#b1000)
(eval-when (compile eval load)
(defconstant branch-fp-conditions
'(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)))
(defconstant branch-fp-cond-name-vec
(coerce branch-fp-conditions 'vector))
(define-argument-type branch-fp-condition
:type '(member . #.branch-fp-conditions)
:function (lambda (fp-cond) (position fp-cond branch-fp-conditions))
:disassem-printer branch-fp-cond-name-vec)
(define-fixup-type :call :disassem-use-label t)
(define-fixup-type :sethi
:disassem-printer #'(lambda (value stream dstate)
(declare (ignore dstate))
(format stream "%hi(#x~8,'0x)" (ash value 10))))
(define-fixup-type :add)
;;;; Formats: ;;;; Primitive emitters.
(define-format (format-1 32 (define-emitter emit-word 32
:disassem-printer '(:name :tab disp)) (byte 32 0))
(op (byte 2 30) :default 1)
(disp (byte 30 0) :default-type (unsigned-byte 30))) (define-emitter emit-short 16
(byte 16 0))
(define-format (format-2-immed 32 (define-emitter emit-format-1 32
:disassem-printer '(:name :tab immed ", " rd)) (byte 2 30) (byte 30 0))
(op (byte 2 30) :default 0)
(rd (byte 5 25) :default-type reg) (define-emitter emit-format-2-immed 32
(op2 (byte 3 22)) (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
(immed (byte 22 0) :default-type (signed-byte 22)))
(define-emitter emit-format-2-branch 32
(defconstant branch-printer (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0))
`(:name (:unless (:constant ,branch-cond-true) cond)
(:unless (a :constant 0) "," 'A) (define-emitter emit-format-2-unimp 32
:tab (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0))
disp))
(define-emitter emit-format-3-reg 32
(define-format (format-2-branch 32 :disassem-printer branch-printer) (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5)
(op (byte 2 30) :default 0) (byte 5 0))
(a (byte 1 29))
(cond (byte 4 25) :default-type branch-condition) (define-emitter emit-format-3-immed 32
(op2 (byte 3 22)) (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0))
(disp (byte 22 0) :default-type relative-label))
(define-format (format-2-unimp 32 (define-emitter emit-format-3-fpop 32
:disassem-printer '(:name :tab data)) (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0))
(op (byte 2 30) :default 0)
(ignore (byte 5 25) :default 0)
(op2 (byte 3 22) :default 0)
(data (byte 22 0) :default-type (unsigned-byte 22)))
(defconstant f3-printer
'(:name :tab
(:unless (:same-as rd) rs1 ", ")
(:choose rs2 immed) ", "
rd))
(define-format (format-3-reg 32 :disassem-printer f3-printer)
(op (byte 2 30))
(rd (byte 5 25) :default-type reg)
(op3 (byte 6 19))
(rs1 (byte 5 14) :default-type reg)
(i (byte 1 13) :default 0)
(asi (byte 8 5) :default 0)
(rs2 (byte 5 0) :default-type reg))
(define-format (format-3-immed 32 :disassem-printer f3-printer)
(op (byte 2 30))
(rd (byte 5 25) :default-type reg)
(op3 (byte 6 19))
(rs1 (byte 5 14) :default-type reg)
(i (byte 1 13) :default 1)
(immed (byte 13 0) :default-type (signed-byte 13)))
(define-format (format-3-fpop 32
:disassem-printer
'(:name :tab (:unless (:same-as rd) rs1 ", ") rs2 ", " rd))
(op (byte 2 30))
(rd (byte 5 25) :default-type fp-reg)
(op3 (byte 6 19))
(rs1 (byte 5 14) :default-type fp-reg)
(opf (byte 9 5))
(rs2 (byte 5 0) :default-type fp-reg))
;;;; Instructions. ;;;; Buncha format-3-instructions.
(defun emit-format-3-inst (segment op op3 dst src1 src2 &key load-store fixup)
(unless src2
(cond ((and (typep src1 'tn) load-store)
(setf src2 0))
(t
(setf src2 src1)
(setf src1 dst))))
(etypecase src2
(tn
(emit-format-3-reg segment op (reg-tn-encoding dst) op3
(reg-tn-encoding src1) 0 0 (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment op (reg-tn-encoding dst) op3
(reg-tn-encoding src1) 1 src2))
(fixup
(unless (or load-store fixup)
(error "Fixups aren't allowed."))
(note-fixup segment :add src2)
(emit-format-3-immed segment op (reg-tn-encoding dst) op3
(reg-tn-encoding src1) 1 0))))
(defun emit-fp-format-3-inst (segment op op3 dst src1 src2
&key load-store fixup odd)
(unless src2
(cond ((and (typep src1 'tn) load-store)
(setf src2 0))
(t
(setf src2 src1)
(setf src1 dst))))
(etypecase src2
(tn
(emit-format-3-reg segment op (fp-reg-tn-encoding dst odd) op3
(reg-tn-encoding src1) 0 0
(reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment op (fp-reg-tn-encoding dst odd) op3
(reg-tn-encoding src1) 1 src2))
(fixup
(unless (or load-store fixup)
(error "Fixups aren't allowed."))
(note-fixup segment :add src2)
(emit-format-3-immed segment op (fp-reg-tn-encoding dst odd) op3
(reg-tn-encoding src1) 1 0))))
(eval-when (compile eval) (eval-when (compile eval)
;;; have to do this because defconstant is evalutated in the null lex env. (defmacro define-f3-inst (name op op3 &key fixup load-store dest-kind)
(defmacro with-ref-format (printer) `(define-instruction ,name (segment dst src1 &optional src2)
`(let* ((i-or-r (:declare (type tn dst)
'(:choose immed rs2)) ,(if (or fixup load-store)
(ref-format '(type (or tn (signed-byte 13) null fixup) src1 src2)
`("[" rs1 (:unless (:constant 0) "+" ,i-or-r) "]" '(type (or tn (signed-byte 13) null) src1 src2)))
(:choose (:unless (:constant 0) asi) nil)))) ,(if dest-kind
,printer)) `(:emitter (emit-fp-format-3-inst segment ,op ,op3 dst src1 src2
:load-store ,load-store
(defconstant load-printer :fixup ,fixup
(with-ref-format `(:NAME :TAB ,ref-format ", " rd))) :odd (eq ',dest-kind 'odd-fp-reg)))
(defconstant store-printer `(:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2
(with-ref-format `(:NAME :TAB rd ", " ,ref-format))) :load-store ,load-store
:fixup ,fixup)))))
(defmacro define-f3-inst (name op op3 &key (dest-kind 'reg) fixup load-store disassem-printer)
`(define-instruction (,name ) ; eval-when (compile eval)
,@(if disassem-printer
`(:disassem-printer ,disassem-printer)
(case load-store
((:load t) ; note that the sun notation for
; things (like swap) that do both is
; like a load
`(:disassem-printer ',load-printer))
(:store
`(:disassem-printer ',store-printer)))))
(format-3-reg (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :argument reg)
(rs2 :argument reg))
,(if (not load-store)
`(format-3-reg (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :same-as rd)
(rs2 :argument reg))
`(format-3-immed (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :argument reg)
(immed :constant 0)))
(format-3-immed (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :argument reg)
(immed :argument (signed-byte 13)))
(format-3-immed (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :same-as rd)
(immed :argument (signed-byte 13)))
,@(when (or load-store fixup)
`((format-3-immed (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :argument reg)
(immed :argument add-fixup))
(format-3-immed (op :constant ,op)
(rd :argument ,dest-kind)
(op3 :constant ,op3)
(rs1 :same-as rd)
(immed :argument add-fixup))))))
(setf (macro-function 'define-f3-inst)
(compile nil (function-lambda-expression
(macro-function 'define-f3-inst))))
) ; eval-when
(define-f3-inst ldsb #b11 #b001001 :load-store :load) (define-f3-inst ldsb #b11 #b001001 :load-store :load)
(define-f3-inst ldsh #b11 #b001010 :load-store :load) (define-f3-inst ldsh #b11 #b001010 :load-store :load)
(define-f3-inst ldub #b11 #b000001 :load-store :load) (define-f3-inst ldub #b11 #b000001 :load-store :load)
(define-f3-inst lduh #b11 #b000010 :load-store :load) (define-f3-inst lduh #b11 #b000010 :load-store :load)
;;; ----------------------------------------------------------------
(define-f3-inst ld #b11 #b000000 :load-store :load) (define-f3-inst ld #b11 #b000000 :load-store :load)
(defun note-niss-ref (chunk inst stream dstate)
(when stream
(disassem:maybe-note-nil-indexed-symbol-slot-ref
(disassem:arg-value 'immed chunk inst)
dstate)))
(defun note-control-stack-var-ref (chunk inst stream dstate)
(when stream
(disassem:maybe-note-single-storage-ref
(/ (disassem:arg-value 'immed chunk inst) word-bytes)
'control-stack
dstate))
)
(defun note-number-stack-var-ref (chunk inst stream dstate)
(when stream
(disassem:maybe-note-single-storage-ref
(/ (disassem:arg-value 'immed chunk inst) word-bytes)
'number-stack
dstate))
)
(disassem:specialize (ld
:disassem-control
#'(lambda (chunk inst stream dstate)
(when stream
(disassem:note-code-constant
(disassem:arg-value 'immed chunk inst)
dstate))))
immed
(rs1 :constant code-offset))
(disassem:specialize (ld :disassem-control #'note-niss-ref)
immed
(rs1 :constant null-offset))
(disassem:specialize (ld :disassem-control #'note-control-stack-var-ref)
immed
(rs1 :constant cfp-offset))
(disassem:specialize (ld :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
;;; ----------------------------------------------------------------
(define-f3-inst ldd #b11 #b000011 :load-store :load) (define-f3-inst ldd #b11 #b000011 :load-store :load)
(disassem:specialize (ldd :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
(define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load) (define-f3-inst ldf #b11 #b100000 :dest-kind fp-reg :load-store :load)
(disassem:specialize (ldf :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
(define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load) (define-f3-inst ldf-odd #b11 #b100000 :dest-kind odd-fp-reg :load-store :load)
(define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load) (define-f3-inst lddf #b11 #b100011 :dest-kind fp-reg :load-store :load)
(disassem:specialize (lddf :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
(define-f3-inst stb #b11 #b000101 :load-store :store) (define-f3-inst stb #b11 #b000101 :load-store :store)
(define-f3-inst sth #b11 #b000110 :load-store :store) (define-f3-inst sth #b11 #b000110 :load-store :store)
;;; ----------------------------------------------------------------
(define-f3-inst st #b11 #b000100 :load-store :store) (define-f3-inst st #b11 #b000100 :load-store :store)
(disassem:specialize (st :disassem-control #'note-niss-ref)
immed
(rs1 :constant null-offset))
(disassem:specialize (st :disassem-control #'note-control-stack-var-ref)
immed
(rs1 :constant cfp-offset))
(disassem:specialize (st :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
;;; ----------------------------------------------------------------
(define-f3-inst std #b11 #b000111 :load-store :store) (define-f3-inst std #b11 #b000111 :load-store :store)
(disassem:specialize (std :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
(define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store) (define-f3-inst stf #b11 #b100100 :dest-kind fp-reg :load-store :store)
(disassem:specialize (stf :disassem-control #'note-number-stack-var-ref) (define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store)(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
immed
(rs1 :constant nfp-offset))
(define-f3-inst stf-odd #b11 #b100100 :dest-kind odd-fp-reg :load-store :store)
(define-f3-inst stdf #b11 #b100111 :dest-kind fp-reg :load-store :store)
(disassem:specialize (stdf :disassem-control #'note-number-stack-var-ref)
immed
(rs1 :constant nfp-offset))
(define-f3-inst ldstub #b11 #b001101 :load-store t) (define-f3-inst ldstub #b11 #b001101 :load-store t)
(define-f3-inst swap #b11 #b001111 :load-store t) (define-f3-inst swap #b11 #b001111 :load-store t)
(define-instruction (ldfsr)
(format-3-immed (op :constant #b11)
(rd :constant 0)
(op3 :constant #b100001)
(rs1 :argument reg)
(immed :argument (signed-byte 13))))
(define-instruction (stfsr)
(format-3-immed (op :constant #b11)
(rd :constant 0)
(op3 :constant #b100101)
(rs1 :argument reg)
(immed :argument (signed-byte 13))))
;;; ----------------------------------------------------------------
(define-f3-inst add #b10 #b000000 :fixup t) (define-f3-inst add #b10 #b000000 :fixup t)
(defstruct sethi-note
target-reg
high-bits
following-addr)
(defun look-at-sethi-note (chunk inst stream dstate)
(when stream
(let ((sethi-note (disassem:dstate-get-prop dstate 'sethi-note)))
(when (and sethi-note
(= (disassem:dstate-curpos dstate)
(sethi-note-following-addr sethi-note))
(= (disassem:arg-value 'rs1 chunk inst)
(sethi-note-target-reg sethi-note)))
(let ((value
(+ (sethi-note-high-bits sethi-note)
(disassem:arg-value 'immed
chunk inst))))
(or (disassem:maybe-note-assembler-routine value dstate)
(disassem:note #'(lambda (stream)
(format stream "#x~x (~d)"
value
(disassem:sign-extend value 32)))
dstate)))))))
(disassem:specialize (add :disassem-control #'look-at-sethi-note)
immed)
;;; note: this must be after the above, because the disassem-controls
;;; are exclusive
(disassem:specialize (add
:disassem-control
#'(lambda (chunk inst stream dstate)
(when stream
(disassem:maybe-note-nil-indexed-object
(disassem:arg-value 'immed chunk inst)
dstate))))
immed
(rs1 :constant null-offset))
;;; ----------------------------------------------------------------
(define-f3-inst addcc #b10 #b010000) (define-f3-inst addcc #b10 #b010000)
(define-f3-inst addx #b10 #b001000) (define-f3-inst addx #b10 #b001000)
(define-f3-inst addxcc #b10 #b011000) (define-f3-inst addxcc #b10 #b011000)
(define-f3-inst taddcc #b10 #b100000) (define-f3-inst taddcc #b10 #b100000)
(define-f3-inst taddcctv #b10 #b100010) (define-f3-inst taddcctv #b10 #b100010)
(define-f3-inst sub #b10 #b000100) (define-f3-inst sub #b10 #b000100)
(define-f3-inst subcc #b10 #b010100) (define-f3-inst subcc #b10 #b010100)
(define-f3-inst subx #b10 #b001100) (define-f3-inst subx #b10 #b001100)
(define-f3-inst subxcc #b10 #b011100) (define-f3-inst subxcc #b10 #b011100)
(define-f3-inst tsubcc #b10 #b100001) (define-f3-inst tsubcc #b10 #b100001)
(define-f3-inst tsubcctv #b10 #b100011) (define-f3-inst tsubcctv #b10 #b100011)
(define-f3-inst mulscc #b10 #b100100) (define-f3-inst mulscc #b10 #b100100)
(define-f3-inst and #b10 #b000001) (define-f3-inst and #b10 #b000001)
(define-f3-inst andcc #b10 #b010001) (define-f3-inst andcc #b10 #b010001)
(define-f3-inst andn #b10 #b000101) (define-f3-inst andn #b10 #b000101)
(define-f3-inst andncc #b10 #b010101) (define-f3-inst andncc #b10 #b010101)
(define-f3-inst or #b10 #b000010) (define-f3-inst or #b10 #b000010)
(disassem:specialize (or :disassem-control #'look-at-sethi-note) immed)
(define-f3-inst orcc #b10 #b010010) (define-f3-inst orcc #b10 #b010010)
(define-f3-inst orn #b10 #b000110) (define-f3-inst orn #b10 #b000110)
(define-f3-inst orncc #b10 #b010110) (define-f3-inst orncc #b10 #b010110)
...@@ -486,267 +212,168 @@ ...@@ -486,267 +212,168 @@
(define-f3-inst xorcc #b10 #b010011) (define-f3-inst xorcc #b10 #b010011)
(define-f3-inst xnor #b10 #b000111) (define-f3-inst xnor #b10 #b000111)
(define-f3-inst xnorcc #b10 #b010111) (define-f3-inst xnorcc #b10 #b010111)
(define-f3-inst sll #b10 #b100101) (define-f3-inst sll #b10 #b100101)
(define-f3-inst srl #b10 #b100110) (define-f3-inst srl #b10 #b100110)
(define-f3-inst sra #b10 #b100111) (define-f3-inst sra #b10 #b100111)
(defun sethi-note (chunk inst stream dstate)
(when stream
(let ((sethi-note (disassem:dstate-get-prop dstate 'sethi-note)))
(when (null sethi-note)
(setf sethi-note (make-sethi-note)
(disassem:dstate-get-prop dstate 'sethi-note) sethi-note))
(setf (sethi-note-target-reg sethi-note)
(disassem:arg-value 'rd chunk inst))
(setf (sethi-note-high-bits sethi-note)
(ash (disassem:arg-value 'immed chunk inst) 10))
(setf (sethi-note-following-addr sethi-note)
(disassem:dstate-nextpos dstate)))))
(define-instruction (sethi :disassem-control #'sethi-note)
(format-2-immed (rd :argument reg)
(op2 :constant #b100)
(immed :argument (or (unsigned-byte 22) (signed-byte 22))))
(format-2-immed (rd :argument reg)
(op2 :constant #b100)
(immed :argument sethi-fixup)))
(define-f3-inst save #b10 #b111100) (define-f3-inst save #b10 #b111100)
(define-f3-inst restore #b10 #b111101) (define-f3-inst restore #b10 #b111101)
(define-instruction (b)
(format-2-branch (op :constant #b00) ;;;; Random instructions.
(a :constant 0)
(cond :argument branch-condition) (define-instruction ldfsr (segment src1 src2)
(op2 :constant #b010) (:declare (type tn src1) (type (signed-byte 13) src2))
(disp :argument relative-label)) (:emitter (emit-format-3-immed segment #b11 0 #b100001
(format-2-branch (op :constant #b00) (reg-tn-encoding src1) 1 src2)))
(a :constant 0)
(cond :constant branch-cond-true) (define-instruction stfsr (segment src1 src2)
(op2 :constant #b010) (:declare (type tn src1) (type (signed-byte 13) src2))
(disp :argument relative-label))) (:emitter (emit-format-3-immed segment #b11 0 #b100101
(reg-tn-encoding src1) 1 src2)))
(define-instruction (ba)
(format-2-branch (op :constant #b00) (define-instruction sethi (segment dst src1)
(a :constant 1) (:declare (type tn dst)
(cond :argument branch-condition) (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1))
(op2 :constant #b010) (:emitter
(disp :argument relative-label)) (etypecase src1
(format-2-branch (op :constant #b00) (integer
(a :constant 1) (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100
(cond :constant #b1000) src1))
(op2 :constant #b010) (fixup
(disp :argument relative-label))) (note-fixup segment :sethi src1)
(disassem:specialize (ba :name 'b)) (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0)))))
(define-instruction (t
:disassem-printer '(:name rd :tab immed)) (define-instruction rdy (segment dst)
(format-3-immed (op :constant #b10) (:declare (type tn dst))
(rd :argument branch-condition) (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000
(op3 :constant #b111010) 0 1 0)))
(rs1 :constant 0)
(immed :argument (or (signed-byte 13) (unsigned-byte 13))))) (define-instruction wry (segment src1 &optional src2)
(:declare (type tn src1) (type (or (signed-byte 13) tn null) src2))
(define-instruction (fb) (:emitter
(format-2-branch (op :constant #b00) (etypecase src2
(a :constant 0) (null
(cond :argument branch-fp-condition) (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0))
(op2 :constant #b110) (tn
(disp :argument relative-label))) (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0
(reg-tn-encoding src2)))
;;; slightly complicated to handle both jal and j (integer
(defconstant jal-printer (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1
'(:name :tab src2)))))
(:choose (rs1 (:unless (:constant 0) "+" immed))
(:cond ((rs2 :constant 0) rs1) (define-instruction unimp (segment data)
((rs1 :constant 0) rs2) (:declare (type (unsigned-byte 22) data))
(t rs1 "+" rs2))) (:emitter (emit-format-2-unimp segment 0 0 0 data)))
(:unless (:constant 0) ", " rd)))
(define-instruction (jal :disassem-printer jal-printer)
(format-3-reg (op :constant #b10)
(rd :argument reg)
(op3 :constant #b111000)
(rs1 :argument reg)
(rs2 :argument reg))
(format-3-reg (op :constant #b10)
(rd :argument reg)
(op3 :constant #b111000)
(rs1 :constant 0)
(rs2 :argument reg))
(format-3-immed (op :constant #b10)
(rd :argument reg)
(op3 :constant #b111000)
(rs1 :argument reg)
(immed :argument (signed-byte 13)))
(format-3-immed (op :constant #b10)
(rd :argument reg)
(op3 :constant #b111000)
(rs1 :argument reg)
(immed :argument add-fixup)))
(disassem:specialize (jal :disassem-control #'look-at-sethi-note)
immed)
(define-instruction (j :disassem-printer jal-printer)
(format-3-reg (op :constant #b10)
(rd :constant 0)
(op3 :constant #b111000)
(rs1 :argument reg)
(rs2 :argument reg))
(format-3-reg (op :constant #b10)
(rd :constant 0)
(op3 :constant #b111000)
(rs1 :argument reg)
(rs2 :constant 0))
(format-3-immed (op :constant #b10)
(rd :constant 0)
(op3 :constant #b111000)
(rs1 :argument reg)
(immed :argument (signed-byte 13)))
(format-3-immed (op :constant #b10)
(rd :constant 0)
(op3 :constant #b111000)
(rs1 :argument reg)
(immed :argument add-fixup)))
(disassem:specialize (j :disassem-control #'look-at-sethi-note)
immed)
(define-instruction (rdy :disassem-printer '('RD :tab '%Y ", " rd))
(format-3-immed (op :constant #b10)
(rd :argument reg)
(op3 :constant #b101000)
(rs1 :constant 0)
(immed :constant 0)))
(define-instruction (wry
:disassem-printer
'('WR :tab
rs1
(:unless (:constant 0) ", " (:choose immed rs2))
", " '%Y))
(format-3-reg (op :constant #b10)
(rd :constant 0)
(op3 :constant #b110000)
(rs1 :argument reg)
(rs2 :argument reg))
(format-3-reg (op :constant #b10)
(rd :constant 0)
(op3 :constant #b110000)
(rs1 :argument reg)
(rs2 :constant 0))
(format-3-immed (op :constant #b10)
(rd :constant 0)
(op3 :constant #b110000)
(rs1 :argument reg)
(immed :argument (signed-byte 13))))
;;; ----------------------------------------------------------------
(defun snarf-error-junk (sap offset &optional length-only)
(let* ((length (system:sap-ref-8 sap offset))
(vector (make-array length :element-type '(unsigned-byte 8))))
(declare (type system:system-area-pointer sap)
(type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector))
(cond (length-only
(values 0 (1+ length) nil nil))
(t
(kernel:copy-from-system-area sap (* sparc:byte-bits (1+ offset))
vector (* sparc:word-bits
sparc:vector-data-offset)
(* length sparc:byte-bits))
(collect ((sc-offsets)
(lengths))
(lengths 1) ; the length byte
(let* ((index 0)
(error-number (c::read-var-integer vector index)))
(lengths index)
(loop
(when (>= index length)
(return))
(let ((old-index index))
(sc-offsets (c::read-var-integer vector index))
(lengths (- index old-index))))
(values error-number
(1+ length)
(sc-offsets)
(lengths))))))))
(defmacro break-cases (breaknum &body cases)
(let ((bn-temp (gensym)))
(collect ((clauses))
(dolist (case cases)
(clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
`(let ((,bn-temp ,breaknum))
(cond ,@(clauses))))))
(defun unimp-control (chunk inst stream dstate)
(flet ((nt (x) (if stream (disassem:note x dstate))))
(break-cases (disassem:arg-value 'data chunk inst)
(vm:error-trap
(nt "Error trap")
(disassem:handle-break-args #'snarf-error-junk stream dstate))
(vm:cerror-trap
(nt "Cerror trap")
(disassem:handle-break-args #'snarf-error-junk stream dstate))
(vm:object-not-list-trap
(nt "Object not list trap"))
(vm:breakpoint-trap
(nt "Breakpoint trap"))
(vm:pending-interrupt-trap
(nt "Pending interrupt trap"))
(vm:halt-trap
(nt "Halt trap"))
(vm:function-end-breakpoint-trap
(nt "Function end breakpoint trap"))
(vm:object-not-structure-trap
(nt "Object not structure trap"))
)))
(define-instruction (unimp :disassem-control #'unimp-control)
(format-2-unimp (data :argument (unsigned-byte 22))))
;;; ----------------------------------------------------------------
;;;; Branch instructions.
(defun emit-relative-branch (segment a op2 cond-or-target target &optional fp)
(emit-back-patch segment 4
#'(lambda (segment posn)
(unless target
(setf target cond-or-target)
(setf cond-or-target :t))
(emit-format-2-branch
segment #b00 a
(if fp
(fp-branch-condition cond-or-target)
(branch-condition cond-or-target))
op2
(ash (- (label-position target) posn) -2)))))
(define-instruction b (segment cond-or-target &optional target)
(:declare (type (or label branch-condition) cond-or-target)
(type (or label null) target))
(:emitter
(emit-relative-branch segment 0 #b010 cond-or-target target)))
(define-instruction ba (segment cond-or-target &optional target)
(:declare (type (or label branch-condition) cond-or-target)
(type (or label null) target))
(:emitter
(emit-relative-branch segment 1 #b010 cond-or-target target)))
(define-instruction t (segment condition target)
(:declare (type branch-condition condition)
(type (or (signed-byte 13) (unsigned-byte 13)) target))
(:emitter (emit-format-3-immed segment #b10 (branch-condition condition)
#b111010 0 1 target)))
(define-instruction fb (segment condition target)
(:declare (type fp-branch-condition condition) (type label target))
(:emitter
(emit-relative-branch segment 0 #b110 condition target t)))
(define-instruction jal (segment dst src1 &optional src2)
(:declare (type tn dst)
(type (or tn integer) src1)
(type (or null fixup tn (signed-byte 13)) src2))
(:emitter
(unless src2
(setf src2 src1)
(setf src1 0))
(etypecase src2
(tn
(emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b111000
(if (integerp src1)
src1
(reg-tn-encoding src1))
0 0 (reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b111000
(reg-tn-encoding src1) 1 src2))
(fixup
(note-fixup segment :add src2)
(emit-format-3-immed segment #b10 (reg-tn-encoding dst)
#b111000 (reg-tn-encoding src1) 1 0)))))
(define-instruction j (segment src1 &optional src2)
(:declare (type tn src1) (type (or tn (signed-byte 13) fixup null) src2))
(:emitter
(etypecase src2
(null
(emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0 0))
(tn
(emit-format-3-reg segment #b10 0 #b111000 (reg-tn-encoding src1) 0 0
(reg-tn-encoding src2)))
(integer
(emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
src2))
(fixup
(note-fixup segment :add src2)
(emit-format-3-immed segment #b10 0 #b111000 (reg-tn-encoding src1) 1
0)))))
;;;; Unary and binary fp insts.
(defun emit-fp-inst (segment opf op3 dst src1 src2)
(unless src2
(setf src2 src1)
(setf src1 dst))
(emit-format-3-fpop segment #b10 (fp-reg-tn-encoding dst) op3
(fp-reg-tn-encoding src1) opf (fp-reg-tn-encoding src2)))
(eval-when (compile eval) (eval-when (compile eval)
(defmacro define-unary-fp-inst (name opf &optional odd) (defmacro define-unary-fp-inst (name opf)
(let ((kind (if odd 'odd-fp-reg 'fp-reg))) `(define-instruction ,name (segment dst src1 &optional src2)
`(define-instruction (,name) (:declare (type tn dst src1) (type (or null tn) src2))
(format-3-fpop (op :constant #b10) (:emitter (emit-fp-inst segment ,opf #b110100 dst src1 src2))))
(rd :argument ,kind)
(op3 :constant #b110100)
(rs1 :argument ,kind)
(opf :constant ,opf)
(rs2 :argument ,kind))
(format-3-fpop (op :constant #b10)
(rd :argument ,kind)
(op3 :constant #b110100)
(rs1 :same-as rd)
(opf :constant ,opf)
(rs2 :argument ,kind)))))
(defmacro define-binary-fp-inst (name opf &optional (op3 #b110100)) (defmacro define-binary-fp-inst (name opf &optional (op3 #b110100))
`(define-instruction (,name) `(define-instruction ,name (segment dst src1 &optional src2)
(format-3-fpop (op :constant #b10) (:declare (type tn dst src1) (type (or null tn) src2))
(rd :argument fp-reg) (:emitter (emit-fp-inst segment ,opf ,op3 dst src1 src2))))
(op3 :constant ,op3)
(rs1 :argument fp-reg)
(opf :constant ,opf)
(rs2 :argument fp-reg))
(format-3-fpop (op :constant #b10)
(rd :argument fp-reg)
(op3 :constant ,op3)
(rs1 :same-as rd)
(opf :constant ,opf)
(rs2 :argument fp-reg))))
); eval-when (compile eval) ); eval-when (compile eval)
(define-unary-fp-inst fitos #b011000100) (define-unary-fp-inst fitos #b011000100)
(define-unary-fp-inst fitod #b011001000) (define-unary-fp-inst fitod #b011001000)
(define-unary-fp-inst fitox #b011001100) (define-unary-fp-inst fitox #b011001100)
...@@ -767,7 +394,7 @@ ...@@ -767,7 +394,7 @@
(define-unary-fp-inst fxtod #b011001011) (define-unary-fp-inst fxtod #b011001011)
(define-unary-fp-inst fmovs #b000000001) (define-unary-fp-inst fmovs #b000000001)
(define-unary-fp-inst fmovs-odd #b000000001 t) (define-unary-fp-inst fmovs-odd #b000000001)
(define-unary-fp-inst fnegs #b000000101) (define-unary-fp-inst fnegs #b000000101)
(define-unary-fp-inst fabss #b000001001) (define-unary-fp-inst fabss #b000001001)
...@@ -776,6 +403,7 @@ ...@@ -776,6 +403,7 @@
(define-unary-fp-inst fsqrtx #b000101011) (define-unary-fp-inst fsqrtx #b000101011)
(define-binary-fp-inst fadds #b001000001) (define-binary-fp-inst fadds #b001000001)
(define-binary-fp-inst faddd #b001000010) (define-binary-fp-inst faddd #b001000010)
(define-binary-fp-inst faddx #b001000011) (define-binary-fp-inst faddx #b001000011)
...@@ -798,197 +426,199 @@ ...@@ -798,197 +426,199 @@
(define-binary-fp-inst fcmpex #b001010111 #b110101) (define-binary-fp-inst fcmpex #b001010111 #b110101)
;;;; Pseudo-instructions, etc. ;;;; li, jali, ji, nop, cmp, not, neg, move, and more
(define-pseudo-instruction li 64 (reg value) (define-instruction li (segment reg value)
(etypecase value (:declare (type tn reg)
((signed-byte 13) (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
(inst add reg zero-tn value)) fixup) value))
((or (signed-byte 32) (unsigned-byte 32)) (:vop-var vop)
(let ((hi (ldb (byte 22 10) value)) (:emitter
(lo (ldb (byte 10 0) value))) (assemble (segment vop)
(inst sethi reg hi) (etypecase value
(unless (zerop lo) ((signed-byte 13)
(inst add reg lo)))) (inst add reg zero-tn value))
(fixup ((or (signed-byte 32) (unsigned-byte 32))
(inst sethi reg value) (let ((hi (ldb (byte 22 10) value))
(inst add reg value)))) (lo (ldb (byte 10 0) value)))
(inst sethi reg hi)
(unless (zerop lo)
(inst add reg lo))))
(fixup
(inst sethi reg value)
(inst add reg value))))))
;;; Jal to a full 32-bit address. Tmpreg is trashed. ;;; Jal to a full 32-bit address. Tmpreg is trashed.
(define-pseudo-instruction jali 64 (link tmpreg value) (define-instruction jali (segment link tmpreg value)
(etypecase value (:declare (type tn link tmpreg)
((signed-byte 13) (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
(inst jal link zero-tn value)) fixup) value))
((or (signed-byte 32) (unsigned-byte 32)) (:vop-var vop)
(let ((hi (ldb (byte 22 10) value)) (:emitter
(lo (ldb (byte 10 0) value))) (assemble (segment vop)
(inst sethi tmpreg hi) (etypecase value
(inst jal link tmpreg lo))) ((signed-byte 13)
(fixup (inst jal link zero-tn value))
(inst sethi tmpreg value) ((or (signed-byte 32) (unsigned-byte 32))
(inst jal link tmpreg value)))) (let ((hi (ldb (byte 22 10) value))
(lo (ldb (byte 10 0) value)))
(inst sethi tmpreg hi)
(inst jal link tmpreg lo)))
(fixup
(inst sethi tmpreg value)
(inst jal link tmpreg value))))))
;;; Jump to a full 32-bit address. Tmpreg is trashed. ;;; Jump to a full 32-bit address. Tmpreg is trashed.
(define-pseudo-instruction ji 64 (tmpreg value) (define-instruction ji (segment tmpreg value)
(inst jali zero-tn tmpreg value)) (:declare (type tn tmpreg)
(type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32)
(define-instruction (nop :disassem-printer '(:name)) fixup) value))
(format-2-immed (rd :constant 0) (:vop-var vop)
(op2 :constant #b100) (:emitter
(immed :constant 0))) (assemble (segment vop)
(inst jali zero-tn tmpreg value))))
(define-instruction (cmp
:disassem-printer (define-instruction nop (segment)
'(:name :tab rs1 ", " (:choose immed rs2))) (:emitter (emit-format-2-immed segment 0 0 #b100 0)))
(format-3-reg (op :constant #b10)
(rd :constant 0) (define-instruction cmp (segment src1 &optional src2)
(op3 :constant #b010100) (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2))
(rs1 :argument reg) (:emitter
(rs2 :argument reg)) (etypecase src2
(format-3-reg (op :constant #b10) (null
(rd :constant 0) (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0))
(op3 :constant #b010100) (tn
(rs1 :argument reg) (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0
(rs2 :constant 0)) (reg-tn-encoding src2)))
(format-3-immed (op :constant #b10) (integer
(rd :constant 0) (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1
(op3 :constant #b010100) src2)))))
(rs1 :argument reg)
(immed :argument (signed-byte 13)))) (define-instruction not (segment dst &optional src1)
(:declare (type tn dst) (type (or tn null) src1))
(define-instruction (not (:emitter
:disassem-printer (unless src1
'(:name :tab (:unless (:same-as rd) rs1 ", " ) rd)) (setf src1 dst))
(format-3-reg (op :constant #b10) (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111
(rd :argument reg) (reg-tn-encoding src1) 0 0 0)))
(op3 :constant #b000111)
(rs1 :argument reg) (define-instruction neg (segment dst &optional src1)
(rs2 :constant 0)) (:declare (type tn dst) (type (or tn null) src1))
(format-3-reg (op :constant #b10) (:emitter
(rd :argument reg) (unless src1
(op3 :constant #b000111) (setf src1 dst))
(rs1 :same-as rd) (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100
(rs2 :constant 0))) 0 0 0 (reg-tn-encoding src1))))
(define-instruction (neg (define-instruction move (segment dst src1)
:disassem-printer (:declare (type tn dst src1))
'(:name :tab (:unless (:same-as rd) rs2 ", " ) rd)) (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010
(format-3-reg (op :constant #b10) 0 0 0 (reg-tn-encoding src1))))
(rd :argument reg)
(op3 :constant #b000100)
(rs1 :constant 0)
(rs2 :argument reg))
(format-3-reg (op :constant #b10)
(rd :argument reg)
(op3 :constant #b000100)
(rs1 :constant 0)
(rs2 :same-as rd)))
(define-instruction (move :disassem-printer '(:name :tab rs2 ", " rd))
(format-3-reg (op :constant #b10)
(rd :argument reg)
(op3 :constant #b000010)
(rs1 :constant 0)
(rs2 :argument reg)))
;;; Instructions for dumping data and header objects. ;;;; Instructions for dumping data and header objects.
(define-format (word-format 32) (define-instruction word (segment word)
(data (byte 32 0))) (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word))
(define-instruction (word) :pinned
(word-format (data :argument (or (unsigned-byte 32) (signed-byte 32))))) (:emitter
(emit-word segment word)))
(define-format (short-format 16)
(data (byte 16 0))) (define-instruction short (segment short)
(define-instruction (short) (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short))
(short-format (data :argument (or (unsigned-byte 16) (signed-byte 16))))) :pinned
(:emitter
(define-format (byte-format 8) (emit-short segment short)))
(data (byte 8 0)))
(define-instruction (byte) (define-instruction byte (segment byte)
(byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8))))) (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte))
:pinned
(:emitter
(define-format (header-object 32) (emit-byte segment byte)))
(type (byte 8 0))
(data (byte 24 8) (define-emitter emit-header-object 32
:default 0 (byte 24 8) (byte 8 0))
:function (lambda (ignore)
(declare (ignore ignore))
(ash (+ *current-position* (component-header-length))
(- vm:word-shift))))) (defun emit-header-data (segment type)
(emit-back-patch
(define-instruction (function-header-word) segment 4
(header-object (type :constant vm:function-header-type))) #'(lambda (segment posn)
(emit-word segment
(define-instruction (lra-header-word) (logior type
(header-object (type :constant vm:return-pc-header-type))) (ash (+ posn (component-header-length))
(- type-bits word-shift)))))))
(define-instruction function-header-word (segment)
:pinned
(:emitter
(emit-header-data segment function-header-type)))
(define-instruction lra-header-word (segment)
:pinned
(:emitter
(emit-header-data segment return-pc-header-type)))
;;;; Instructions for converting between code objects, functions, and lras ;;;; Instructions for converting between code objects, functions, and lras.
(eval-when (compile eval)
(defun emit-compute-inst (segment vop dst src label temp calc)
(defmacro define-compute-instruction (name calculation) (emit-chooser
(let ((add (symbolicate name "-ADD")) ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments.
(sethi (symbolicate name "-SETHI")) segment 12 3
(or (symbolicate name "-OR"))) #'(lambda (segment posn delta-if-after)
`(progn (let ((delta (funcall calc label posn delta-if-after)))
(define-instruction (,add) (when (<= (- (ash 1 12)) delta (1- (ash 1 12)))
(format-3-immed (emit-back-patch segment 4
(op :constant #b10) #'(lambda (segment posn)
(rd :argument reg) (assemble (segment vop)
(op3 :constant #b000000) (inst add dst src
(rs1 :argument reg) (funcall calc label posn 0)))))
(immed :argument label t)))
:function (lambda (label) #'(lambda (segment posn)
(let ((result ,calculation)) (let ((delta (funcall calc label posn 0)))
(assert (typep result '(signed-byte 13))) (assemble (segment vop)
result))))) (inst sethi temp (ldb (byte 22 10) delta))
(define-instruction (,sethi) (inst or temp (ldb (byte 10 0) delta))
(format-2-immed (rd :argument reg) (inst add dst src temp))))))
(op2 :constant #b100)
(immed :argument label
:function (lambda (label)
(ash ,calculation -10)))))
(define-instruction (,or)
(format-3-immed (op :constant #b10)
(rd :argument reg)
(op3 :constant #b000010)
(rs1 :same-as rd)
(immed :argument label
:function (lambda (label)
(logand ,calculation
(1- (ash 1 10)))))))
(define-pseudo-instruction ,name 96 (dst src label temp)
(cond ((typep ,calculation '(signed-byte 13))
(inst ,add dst src label))
(t
(inst ,sethi temp label)
(inst ,or temp label)
(inst add dst src temp)))))))
); eval-when (compile eval)
;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag ;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag
(define-compute-instruction compute-code-from-fn (define-instruction compute-code-from-fn (segment dst src label temp)
(- vm:other-pointer-type (:declare (type tn dst src temp) (type label label))
vm:function-pointer-type (:reads src)
(label-position label) (:writes (list dst temp))
(component-header-length))) (:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
#'(lambda (label posn delta-if-after)
(- other-pointer-type
function-pointer-type
(label-position label posn delta-if-after)
(component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag ;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
(define-compute-instruction compute-code-from-lra (define-instruction compute-code-from-lra (segment dst src label temp)
(- (+ (label-position label) (:declare (type tn dst src temp) (type label label))
(component-header-length)))) (:reads src)
(:writes (list dst temp))
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
#'(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 ;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
(define-compute-instruction compute-lra-from-code (define-instruction compute-lra-from-code (segment dst src label temp)
(+ (label-position label) (:declare (type tn dst src temp) (type label label))
(component-header-length))) (:reads src)
(:writes (list dst temp))
(:vop-var vop)
(:emitter
(emit-compute-inst segment vop dst src label temp
#'(lambda (label posn delta-if-after)
(+ (label-position label posn delta-if-after)
(component-header-length))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment