diff --git a/compiler/sparc/insts.lisp b/compiler/sparc/insts.lisp index 373e19c0f953edffa2a1a1afdaea46e19eee8439..d42d09f9d67fe23d24554c86d4da52d586bc693f 100644 --- a/compiler/sparc/insts.lisp +++ b/compiler/sparc/insts.lisp @@ -1,484 +1,210 @@ ;;; -*- Package: SPARC -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; 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 -;;; Scott Fahlman (FAHLMAN@CMUC). -;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; 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. ;;; -;;; Written by William Lott +;;; Written by William Lott. +;;; +;;; Converted to the SPARC by Sean Hallgren. ;;; (in-package "SPARC") -(use-package "ASSEM") + +(use-package "NEW-ASSEM") (use-package "EXT") (use-package "C") -(disassem:set-disassem-params - :instruction-alignment 32 - :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)) - ) +(def-assembler-params + :scheduler-p nil) -;;;; Special argument types and fixups. - -(defvar *disassem-use-lisp-reg-names* t) - -(defconstant reg-symbols - (map 'vector - #'(lambda (name) - (cond ((null name) nil) - (t (make-symbol (concatenate 'string "%" name))))) - *register-names*)) - -(define-argument-type reg - :type '(and tn - (satisfies (lambda (object) - (or (eq (sc-name (tn-sc object)) 'null) - (eq (sc-name (tn-sc object)) 'zero) - (eq (sb-name (sc-sb (tn-sc object))) - 'registers))))) - :function (lambda (tn) - (case (sc-name (tn-sc tn)) - (null null-offset) - (zero 0) - (t (tn-offset tn)))) - :disassem-printer #'(lambda (value stream dstate) - (declare (stream stream) (fixnum value)) - (let ((regname (aref reg-symbols value))) - (princ regname stream) - (disassem:maybe-note-associated-storage-ref - value - 'register - regname - dstate))) - ) - -(defconstant float-reg-symbols - (coerce - (loop for n from 0 to 31 collect (make-symbol (format nil "%F~d" n))) - 'vector)) - -(define-argument-type fp-reg - :type '(and tn - (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) - +;;;; Functions to convert TN's and random symbolic things into values. + +(defun reg-tn-encoding (tn) + (declare (type tn tn)) + (sc-case tn + (zero zero-offset) + (null null-offset) + (t + (if (eq (sb-name (sc-sb (tn-sc tn))) 'registers) + (tn-offset tn) + (error "~S isn't a register." tn))))) + +(defun fp-reg-tn-encoding (tn &optional odd) + (declare (type tn tn)) + (unless (eq (sb-name (sc-sb (tn-sc tn))) 'float-registers) + (error "~S isn't a floating-point register." tn)) + (if odd + (1+ (tn-offset tn)) + (tn-offset tn))) + +(defconstant branch-conditions + '(:f :eq :le :lt :leu :ltu :n :vs :t :ne :gt :ge :gtu :geu :p :vc)) + +(deftype branch-condition () + `(member ,@branch-conditions)) + +(defun branch-condition (condition) + (or (position condition branch-conditions) + (error "Unknown branch condition: ~S~%Must be one of: ~S" + condition branch-conditions))) + +(defconstant fp-branch-conditions + '(:f :ne :lg :ul :l :ug :g :u :t :eq :ue :ge :uge :le :ule :o)) + +(deftype fp-branch-condition () + `(member ,@fp-branch-conditions)) + +(defun fp-branch-condition (condition) + (or (position condition fp-branch-conditions) + (error "Unknown fp-branch condition: ~S~%Must be one of: ~S" + condition fp-branch-conditions))) -;;;; Formats: - -(define-format (format-1 32 - :disassem-printer '(:name :tab disp)) - (op (byte 2 30) :default 1) - (disp (byte 30 0) :default-type (unsigned-byte 30))) - - -(define-format (format-2-immed 32 - :disassem-printer '(:name :tab immed ", " rd)) - (op (byte 2 30) :default 0) - (rd (byte 5 25) :default-type reg) - (op2 (byte 3 22)) - (immed (byte 22 0) :default-type (signed-byte 22))) - -(defconstant branch-printer - `(:name (:unless (:constant ,branch-cond-true) cond) - (:unless (a :constant 0) "," 'A) - :tab - disp)) - -(define-format (format-2-branch 32 :disassem-printer branch-printer) - (op (byte 2 30) :default 0) - (a (byte 1 29)) - (cond (byte 4 25) :default-type branch-condition) - (op2 (byte 3 22)) - (disp (byte 22 0) :default-type relative-label)) - -(define-format (format-2-unimp 32 - :disassem-printer '(:name :tab data)) - (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)) +;;;; Primitive emitters. + +(define-emitter emit-word 32 + (byte 32 0)) + +(define-emitter emit-short 16 + (byte 16 0)) + +(define-emitter emit-format-1 32 + (byte 2 30) (byte 30 0)) + +(define-emitter emit-format-2-immed 32 + (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0)) + +(define-emitter emit-format-2-branch 32 + (byte 2 30) (byte 1 29) (byte 4 25) (byte 3 22) (byte 22 0)) + +(define-emitter emit-format-2-unimp 32 + (byte 2 30) (byte 5 25) (byte 3 22) (byte 22 0)) + +(define-emitter emit-format-3-reg 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 8 5) + (byte 5 0)) + +(define-emitter emit-format-3-immed 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 1 13) (byte 13 0)) + + +(define-emitter emit-format-3-fpop 32 + (byte 2 30) (byte 5 25) (byte 6 19) (byte 5 14) (byte 9 5) (byte 5 0)) -;;;; 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) -;;; have to do this because defconstant is evalutated in the null lex env. -(defmacro with-ref-format (printer) - `(let* ((i-or-r - '(:choose immed rs2)) - (ref-format - `("[" rs1 (:unless (:constant 0) "+" ,i-or-r) "]" - (:choose (:unless (:constant 0) asi) nil)))) - ,printer)) - -(defconstant load-printer - (with-ref-format `(:NAME :TAB ,ref-format ", " rd))) -(defconstant store-printer - (with-ref-format `(:NAME :TAB rd ", " ,ref-format))) - -(defmacro define-f3-inst (name op op3 &key (dest-kind 'reg) fixup load-store disassem-printer) - `(define-instruction (,name - ,@(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 +(defmacro define-f3-inst (name op op3 &key fixup load-store dest-kind) + `(define-instruction ,name (segment dst src1 &optional src2) + (:declare (type tn dst) + ,(if (or fixup load-store) + '(type (or tn (signed-byte 13) null fixup) src1 src2) + '(type (or tn (signed-byte 13) null) src1 src2))) + ,(if dest-kind + `(:emitter (emit-fp-format-3-inst segment ,op ,op3 dst src1 src2 + :load-store ,load-store + :fixup ,fixup + :odd (eq ',dest-kind 'odd-fp-reg))) + `(:emitter (emit-format-3-inst segment ,op ,op3 dst src1 src2 + :load-store ,load-store + :fixup ,fixup))))) + +) ; eval-when (compile eval) (define-f3-inst ldsb #b11 #b001001 :load-store :load) (define-f3-inst ldsh #b11 #b001010 :load-store :load) (define-f3-inst ldub #b11 #b000001 :load-store :load) (define-f3-inst lduh #b11 #b000010 :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) -(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) -(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 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 sth #b11 #b000110 :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) -(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) -(disassem:specialize (stf :disassem-control #'note-number-stack-var-ref) - 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 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) (define-f3-inst ldstub #b11 #b001101 :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) - -(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 addx #b10 #b001000) (define-f3-inst addxcc #b10 #b011000) - (define-f3-inst taddcc #b10 #b100000) (define-f3-inst taddcctv #b10 #b100010) - (define-f3-inst sub #b10 #b000100) (define-f3-inst subcc #b10 #b010100) (define-f3-inst subx #b10 #b001100) (define-f3-inst subxcc #b10 #b011100) - (define-f3-inst tsubcc #b10 #b100001) (define-f3-inst tsubcctv #b10 #b100011) - (define-f3-inst mulscc #b10 #b100100) - (define-f3-inst and #b10 #b000001) (define-f3-inst andcc #b10 #b010001) (define-f3-inst andn #b10 #b000101) (define-f3-inst andncc #b10 #b010101) (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 orn #b10 #b000110) (define-f3-inst orncc #b10 #b010110) @@ -486,267 +212,168 @@ (define-f3-inst xorcc #b10 #b010011) (define-f3-inst xnor #b10 #b000111) (define-f3-inst xnorcc #b10 #b010111) - (define-f3-inst sll #b10 #b100101) (define-f3-inst srl #b10 #b100110) (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 restore #b10 #b111101) -(define-instruction (b) - (format-2-branch (op :constant #b00) - (a :constant 0) - (cond :argument branch-condition) - (op2 :constant #b010) - (disp :argument relative-label)) - (format-2-branch (op :constant #b00) - (a :constant 0) - (cond :constant branch-cond-true) - (op2 :constant #b010) - (disp :argument relative-label))) - -(define-instruction (ba) - (format-2-branch (op :constant #b00) - (a :constant 1) - (cond :argument branch-condition) - (op2 :constant #b010) - (disp :argument relative-label)) - (format-2-branch (op :constant #b00) - (a :constant 1) - (cond :constant #b1000) - (op2 :constant #b010) - (disp :argument relative-label))) -(disassem:specialize (ba :name 'b)) - -(define-instruction (t - :disassem-printer '(:name rd :tab immed)) - (format-3-immed (op :constant #b10) - (rd :argument branch-condition) - (op3 :constant #b111010) - (rs1 :constant 0) - (immed :argument (or (signed-byte 13) (unsigned-byte 13))))) - -(define-instruction (fb) - (format-2-branch (op :constant #b00) - (a :constant 0) - (cond :argument branch-fp-condition) - (op2 :constant #b110) - (disp :argument relative-label))) - -;;; slightly complicated to handle both jal and j -(defconstant jal-printer - '(:name :tab - (:choose (rs1 (:unless (:constant 0) "+" immed)) - (:cond ((rs2 :constant 0) rs1) - ((rs1 :constant 0) rs2) - (t rs1 "+" rs2))) - (: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)))) - -;;; ---------------------------------------------------------------- + +;;;; Random instructions. + +(define-instruction ldfsr (segment src1 src2) + (:declare (type tn src1) (type (signed-byte 13) src2)) + (:emitter (emit-format-3-immed segment #b11 0 #b100001 + (reg-tn-encoding src1) 1 src2))) + +(define-instruction stfsr (segment src1 src2) + (:declare (type tn src1) (type (signed-byte 13) src2)) + (:emitter (emit-format-3-immed segment #b11 0 #b100101 + (reg-tn-encoding src1) 1 src2))) + +(define-instruction sethi (segment dst src1) + (:declare (type tn dst) + (type (or (signed-byte 22) (unsigned-byte 22) fixup) src1)) + (:emitter + (etypecase src1 + (integer + (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 + src1)) + (fixup + (note-fixup segment :sethi src1) + (emit-format-2-immed segment #b00 (reg-tn-encoding dst) #b100 0))))) + + +(define-instruction rdy (segment dst) + (:declare (type tn dst)) + (:emitter (emit-format-3-immed segment #b10 (reg-tn-encoding dst) #b101000 + 0 1 0))) + +(define-instruction wry (segment src1 &optional src2) + (:declare (type tn src1) (type (or (signed-byte 13) tn null) src2)) + (:emitter + (etypecase src2 + (null + (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 0)) + (tn + (emit-format-3-reg segment #b10 0 #b110000 (reg-tn-encoding src1) 0 0 + (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b10 0 #b110000 (reg-tn-encoding src1) 1 + src2))))) + +(define-instruction unimp (segment data) + (:declare (type (unsigned-byte 22) data)) + (:emitter (emit-format-2-unimp segment 0 0 0 data))) + +;;;; 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) -(defmacro define-unary-fp-inst (name opf &optional odd) - (let ((kind (if odd 'odd-fp-reg 'fp-reg))) - `(define-instruction (,name) - (format-3-fpop (op :constant #b10) - (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-unary-fp-inst (name opf) + `(define-instruction ,name (segment dst src1 &optional src2) + (:declare (type tn dst src1) (type (or null tn) src2)) + (:emitter (emit-fp-inst segment ,opf #b110100 dst src1 src2)))) (defmacro define-binary-fp-inst (name opf &optional (op3 #b110100)) - `(define-instruction (,name) - (format-3-fpop (op :constant #b10) - (rd :argument fp-reg) - (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)))) - + `(define-instruction ,name (segment dst src1 &optional src2) + (:declare (type tn dst src1) (type (or null tn) src2)) + (:emitter (emit-fp-inst segment ,opf ,op3 dst src1 src2)))) + ); eval-when (compile eval) + (define-unary-fp-inst fitos #b011000100) (define-unary-fp-inst fitod #b011001000) (define-unary-fp-inst fitox #b011001100) @@ -767,7 +394,7 @@ (define-unary-fp-inst fxtod #b011001011) (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 fabss #b000001001) @@ -776,6 +403,7 @@ (define-unary-fp-inst fsqrtx #b000101011) + (define-binary-fp-inst fadds #b001000001) (define-binary-fp-inst faddd #b001000010) (define-binary-fp-inst faddx #b001000011) @@ -798,197 +426,199 @@ (define-binary-fp-inst fcmpex #b001010111 #b110101) - -;;;; Pseudo-instructions, etc. - -(define-pseudo-instruction li 64 (reg value) - (etypecase value - ((signed-byte 13) - (inst add reg zero-tn value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (let ((hi (ldb (byte 22 10) 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)))) +;;;; li, jali, ji, nop, cmp, not, neg, move, and more + +(define-instruction li (segment reg value) + (:declare (type tn reg) + (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) + fixup) value)) + (:vop-var vop) + (:emitter + (assemble (segment vop) + (etypecase value + ((signed-byte 13) + (inst add reg zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (let ((hi (ldb (byte 22 10) 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. -(define-pseudo-instruction jali 64 (link tmpreg value) - (etypecase value - ((signed-byte 13) - (inst jal link zero-tn value)) - ((or (signed-byte 32) (unsigned-byte 32)) - (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)))) +(define-instruction jali (segment link tmpreg value) + (:declare (type tn link tmpreg) + (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) + fixup) value)) + (:vop-var vop) + (:emitter + (assemble (segment vop) + (etypecase value + ((signed-byte 13) + (inst jal link zero-tn value)) + ((or (signed-byte 32) (unsigned-byte 32)) + (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. -(define-pseudo-instruction ji 64 (tmpreg value) - (inst jali zero-tn tmpreg value)) - -(define-instruction (nop :disassem-printer '(:name)) - (format-2-immed (rd :constant 0) - (op2 :constant #b100) - (immed :constant 0))) - -(define-instruction (cmp - :disassem-printer - '(:name :tab rs1 ", " (:choose immed rs2))) - (format-3-reg (op :constant #b10) - (rd :constant 0) - (op3 :constant #b010100) - (rs1 :argument reg) - (rs2 :argument reg)) - (format-3-reg (op :constant #b10) - (rd :constant 0) - (op3 :constant #b010100) - (rs1 :argument reg) - (rs2 :constant 0)) - (format-3-immed (op :constant #b10) - (rd :constant 0) - (op3 :constant #b010100) - (rs1 :argument reg) - (immed :argument (signed-byte 13)))) - -(define-instruction (not - :disassem-printer - '(:name :tab (:unless (:same-as rd) rs1 ", " ) rd)) - (format-3-reg (op :constant #b10) - (rd :argument reg) - (op3 :constant #b000111) - (rs1 :argument reg) - (rs2 :constant 0)) - (format-3-reg (op :constant #b10) - (rd :argument reg) - (op3 :constant #b000111) - (rs1 :same-as rd) - (rs2 :constant 0))) - -(define-instruction (neg - :disassem-printer - '(:name :tab (:unless (:same-as rd) rs2 ", " ) rd)) - (format-3-reg (op :constant #b10) - (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))) +(define-instruction ji (segment tmpreg value) + (:declare (type tn tmpreg) + (type (or (signed-byte 13) (signed-byte 32) (unsigned-byte 32) + fixup) value)) + (:vop-var vop) + (:emitter + (assemble (segment vop) + (inst jali zero-tn tmpreg value)))) + +(define-instruction nop (segment) + (:emitter (emit-format-2-immed segment 0 0 #b100 0))) + +(define-instruction cmp (segment src1 &optional src2) + (:declare (type tn src1) (type (or null tn (signed-byte 13)) src2)) + (:emitter + (etypecase src2 + (null + (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 0)) + (tn + (emit-format-3-reg segment #b10 0 #b010100 (reg-tn-encoding src1) 0 0 + (reg-tn-encoding src2))) + (integer + (emit-format-3-immed segment #b10 0 #b010100 (reg-tn-encoding src1) 1 + src2))))) + +(define-instruction not (segment dst &optional src1) + (:declare (type tn dst) (type (or tn null) src1)) + (:emitter + (unless src1 + (setf src1 dst)) + (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000111 + (reg-tn-encoding src1) 0 0 0))) + +(define-instruction neg (segment dst &optional src1) + (:declare (type tn dst) (type (or tn null) src1)) + (:emitter + (unless src1 + (setf src1 dst)) + (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000100 + 0 0 0 (reg-tn-encoding src1)))) + +(define-instruction move (segment dst src1) + (:declare (type tn dst src1)) + (:emitter (emit-format-3-reg segment #b10 (reg-tn-encoding dst) #b000010 + 0 0 0 (reg-tn-encoding src1)))) -;;; Instructions for dumping data and header objects. - -(define-format (word-format 32) - (data (byte 32 0))) -(define-instruction (word) - (word-format (data :argument (or (unsigned-byte 32) (signed-byte 32))))) - -(define-format (short-format 16) - (data (byte 16 0))) -(define-instruction (short) - (short-format (data :argument (or (unsigned-byte 16) (signed-byte 16))))) - -(define-format (byte-format 8) - (data (byte 8 0))) -(define-instruction (byte) - (byte-format (data :argument (or (unsigned-byte 8) (signed-byte 8))))) - - -(define-format (header-object 32) - (type (byte 8 0)) - (data (byte 24 8) - :default 0 - :function (lambda (ignore) - (declare (ignore ignore)) - (ash (+ *current-position* (component-header-length)) - (- vm:word-shift))))) - -(define-instruction (function-header-word) - (header-object (type :constant vm:function-header-type))) - -(define-instruction (lra-header-word) - (header-object (type :constant vm:return-pc-header-type))) - +;;;; Instructions for dumping data and header objects. + +(define-instruction word (segment word) + (:declare (type (or (unsigned-byte 32) (signed-byte 32)) word)) + :pinned + (:emitter + (emit-word segment word))) + +(define-instruction short (segment short) + (:declare (type (or (unsigned-byte 16) (signed-byte 16)) short)) + :pinned + (:emitter + (emit-short segment short))) + +(define-instruction byte (segment byte) + (:declare (type (or (unsigned-byte 8) (signed-byte 8)) byte)) + :pinned + (:emitter + (emit-byte segment byte))) + +(define-emitter emit-header-object 32 + (byte 24 8) (byte 8 0)) + + + +(defun emit-header-data (segment type) + (emit-back-patch + segment 4 + #'(lambda (segment posn) + (emit-word segment + (logior 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 - -(eval-when (compile eval) - -(defmacro define-compute-instruction (name calculation) - (let ((add (symbolicate name "-ADD")) - (sethi (symbolicate name "-SETHI")) - (or (symbolicate name "-OR"))) - `(progn - (define-instruction (,add) - (format-3-immed - (op :constant #b10) - (rd :argument reg) - (op3 :constant #b000000) - (rs1 :argument reg) - (immed :argument label - :function (lambda (label) - (let ((result ,calculation)) - (assert (typep result '(signed-byte 13))) - result))))) - (define-instruction (,sethi) - (format-2-immed (rd :argument reg) - (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) - +;;;; Instructions for converting between code objects, functions, and lras. + + +(defun emit-compute-inst (segment vop dst src label temp calc) + (emit-chooser + ;; We emit either 12 or 4 bytes, so we maintain 8 byte alignments. + segment 12 3 + #'(lambda (segment posn delta-if-after) + (let ((delta (funcall calc label posn delta-if-after))) + (when (<= (- (ash 1 12)) delta (1- (ash 1 12))) + (emit-back-patch segment 4 + #'(lambda (segment posn) + (assemble (segment vop) + (inst add dst src + (funcall calc label posn 0))))) + t))) + #'(lambda (segment posn) + (let ((delta (funcall calc label posn 0))) + (assemble (segment vop) + (inst sethi temp (ldb (byte 22 10) delta)) + (inst or temp (ldb (byte 10 0) delta)) + (inst add dst src temp)))))) ;; code = fn - fn-ptr-type - header - label-offset + other-pointer-tag -(define-compute-instruction compute-code-from-fn - (- vm:other-pointer-type - vm:function-pointer-type - (label-position label) - (component-header-length))) +(define-instruction compute-code-from-fn (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (: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) + (- 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 -(define-compute-instruction compute-code-from-lra - (- (+ (label-position label) - (component-header-length)))) +(define-instruction compute-code-from-lra (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (: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 -(define-compute-instruction compute-lra-from-code - (+ (label-position label) - (component-header-length))) - +(define-instruction compute-lra-from-code (segment dst src label temp) + (:declare (type tn dst src temp) (type label label)) + (: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))))))