(sb!disassem:define-arg-type add-condition
:printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
(sb!disassem:define-arg-type add-condition
:printer #("" \,= \,< \,<= \,NUV \,ZNV \,SV \,OD \,TR \,<> \,>= \,> \,UV
(sb!disassem:define-arg-type logical-condition
:printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
(sb!disassem:define-arg-type unit-condition
:printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
(sb!disassem:define-arg-type logical-condition
:printer #("" \,= \,< \,<= "" "" "" \,OD \,TR \,<> \,>= \,> "" "" "" \,EV))
(sb!disassem:define-arg-type unit-condition
:printer #("" "" \,SBZ \,SHZ \,SDC \,SBC \,SHC \,TR "" \,NBZ \,NHZ \,NDC
- `(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
- (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))
- '(:name :tab t/r "," im14 "(" s b ")"))
- (:emitter
- (emit-load/store segment ,opcode
- (reg-tn-encoding base) (reg-tn-encoding reg) 0
- (im14-encoding segment disp))))))
+ `(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
+ (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))
+ '(:name :tab t/r "," im14 "(" s b ")"))
+ (:emitter
+ (emit-load/store segment ,opcode
+ (reg-tn-encoding base) (reg-tn-encoding reg) 0
+ (im14-encoding segment disp))))))
- `(define-instruction ,name (segment index base reg &key modify scale)
- (:declare (type tn reg base index)
- (type (member t nil) modify scale))
- (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
- (op2 0))
- `(:name ,@cmplt-index-print :tab x/im5/r
- "(" s b ")" t/im5))
- (:emitter
- (emit-extended-load/store
- segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
- 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
- (reg-tn-encoding reg))))))
+ `(define-instruction ,name (segment index base reg &key modify scale)
+ (:declare (type tn reg base index)
+ (type (member t nil) modify scale))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'reg)
+ (op2 0))
+ `(:name ,@cmplt-index-print :tab x/im5/r
+ "(" s b ")" t/im5))
+ (:emitter
+ (emit-extended-load/store
+ segment #x03 (reg-tn-encoding base) (reg-tn-encoding index)
+ 0 (if scale 1 0) 0 ,opcode (if modify 1 0)
+ (reg-tn-encoding reg))))))
- `(define-instruction ,name (segment base disp reg &key modify)
- (:declare (type tn base reg)
- (type (or fixup (signed-byte 5)) disp)
- (type (member :before :after nil) modify))
- (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
- (op2 4))
- `(:name ,@cmplt-disp-print :tab x/im5/r
- "(" s b ")" t/im5))
- (:emitter
- (multiple-value-bind
- (m a)
- (ecase modify
- ((nil) (values 0 0))
- (:after (values 1 0))
- (:before (values 1 1)))
- (emit-extended-load/store segment #x03 (reg-tn-encoding base)
- (short-disp-encoding segment disp)
- 0 a 4 ,opcode m
- (reg-tn-encoding reg))))))
- (define-store-short-inst (name opcode)
- `(define-instruction ,name (segment reg base disp &key modify)
- (:declare (type tn reg base)
- (type (or fixup (signed-byte 5)) disp)
- (type (member :before :after nil) modify))
- (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
- (op2 4))
- `(:name ,@cmplt-disp-print :tab x/im5/r
- "," t/im5 "(" s b ")"))
- (:emitter
- (multiple-value-bind
- (m a)
- (ecase modify
- ((nil) (values 0 0))
- (:after (values 1 0))
- (:before (values 1 1)))
- (emit-extended-load/store segment #x03 (reg-tn-encoding base)
- (short-disp-encoding segment disp)
- 0 a 4 ,opcode m
- (reg-tn-encoding reg)))))))
+ `(define-instruction ,name (segment base disp reg &key modify)
+ (:declare (type tn base reg)
+ (type (or fixup (signed-byte 5)) disp)
+ (type (member :before :after nil) modify))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+ (op2 4))
+ `(:name ,@cmplt-disp-print :tab x/im5/r
+ "(" s b ")" t/im5))
+ (:emitter
+ (multiple-value-bind
+ (m a)
+ (ecase modify
+ ((nil) (values 0 0))
+ (:after (values 1 0))
+ (:before (values 1 1)))
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (short-disp-encoding segment disp)
+ 0 a 4 ,opcode m
+ (reg-tn-encoding reg))))))
+ (define-store-short-inst (name opcode)
+ `(define-instruction ,name (segment reg base disp &key modify)
+ (:declare (type tn reg base)
+ (type (or fixup (signed-byte 5)) disp)
+ (type (member :before :after nil) modify))
+ (:printer extended-load/store ((ext4/c ,opcode) (t/im5 nil :type 'im5)
+ (op2 4))
+ `(:name ,@cmplt-disp-print :tab x/im5/r
+ "," t/im5 "(" s b ")"))
+ (:emitter
+ (multiple-value-bind
+ (m a)
+ (ecase modify
+ ((nil) (values 0 0))
+ (:after (values 1 0))
+ (:before (values 1 1)))
+ (emit-extended-load/store segment #x03 (reg-tn-encoding base)
+ (short-disp-encoding segment disp)
+ 0 a 4 ,opcode m
+ (reg-tn-encoding reg)))))))
- (note-fixup segment :hi value)
- (assert (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)))))
+ (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)))))
- (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))
- (: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))))
- (:emitter
- (multiple-value-bind
- (cond-encoding false)
- (,conditional cond)
- (emit-conditional-branch
- segment (if false ,(+ r-opcode 2) ,r-opcode)
- (reg-tn-encoding r2) (reg-tn-encoding r1)
- 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))
- (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
- (c nil :type ',conditional))
- '(:name c n :tab r1 "," r2 "," w))
- ,@(unless (= r-opcode #x32)
- `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
- (c nil :type ',false-conditional))
- '(:name c n :tab r1 "," r2 "," w))))
- (:emitter
- (multiple-value-bind
- (cond-encoding false)
- (,conditional cond)
- (emit-conditional-branch
- segment (if false (+ ,i-opcode 2) ,i-opcode)
- (reg-tn-encoding reg) (im5-encoding imm)
- cond-encoding target nullify))))))))
+ (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))
+ (: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))))
+ (:emitter
+ (multiple-value-bind
+ (cond-encoding false)
+ (,conditional cond)
+ (emit-conditional-branch
+ segment (if false ,(+ r-opcode 2) ,r-opcode)
+ (reg-tn-encoding r2) (reg-tn-encoding r1)
+ 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))
+ (:printer branch12 ((op1 ,i-opcode) (r1 nil :type 'im5)
+ (c nil :type ',conditional))
+ '(:name c n :tab r1 "," r2 "," w))
+ ,@(unless (= r-opcode #x32)
+ `((:printer branch12 ((op1 ,(+ 2 i-opcode)) (r1 nil :type 'im5)
+ (c nil :type ',false-conditional))
+ '(:name c n :tab r1 "," r2 "," w))))
+ (:emitter
+ (multiple-value-bind
+ (cond-encoding false)
+ (,conditional cond)
+ (emit-conditional-branch
+ segment (if false (+ ,i-opcode 2) ,i-opcode)
+ (reg-tn-encoding reg) (im5-encoding imm)
+ cond-encoding target nullify))))))))
- `(define-instruction ,name (segment r1 r2 res &optional cond)
- (:declare (type tn res r1 r2))
- (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
- cond-kind
- "-CONDITION"))))
- ,@(when (= opcode #x12)
- `((:printer r3-inst ((op ,opcode) (r2 0)
- (c nil :type ',(symbolicate cond-kind
- "-CONDITION")))
- `('COPY :tab r1 "," t))))
- (:emitter
- (multiple-value-bind
- (cond false)
- (,(symbolicate cond-kind "-CONDITION") cond)
- (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
- cond (if false 1 0) ,opcode
- (reg-tn-encoding res)))))))
+ `(define-instruction ,name (segment r1 r2 res &optional cond)
+ (:declare (type tn res r1 r2))
+ (:printer r3-inst ((op ,opcode) (c nil :type ',(symbolicate
+ cond-kind
+ "-CONDITION"))))
+ ,@(when (= opcode #x12)
+ `((:printer r3-inst ((op ,opcode) (r2 0)
+ (c nil :type ',(symbolicate cond-kind
+ "-CONDITION")))
+ `('COPY :tab r1 "," t))))
+ (:emitter
+ (multiple-value-bind
+ (cond false)
+ (,(symbolicate cond-kind "-CONDITION") cond)
+ (emit-r3-inst segment #x02 (reg-tn-encoding r2) (reg-tn-encoding r1)
+ cond (if false 1 0) ,opcode
+ (reg-tn-encoding res)))))))
- `(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)
- (,(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)))))))
+ `(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)
+ (,(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)))))))
- `(define-instruction ,name (segment src posn len res &optional cond)
- (:declare (type tn res src)
- (type (or (member :variable) (integer 0 31)) posn)
- (type (integer 1 32) len))
- (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
- (op2 ,opcode))
- '(:name c :tab r2 "," cp "," t/clen "," r1))
- (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
- '('V :name c :tab r2 "," t/clen "," r1))
- (:emitter
- (etypecase posn
- ((member :variable)
- (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
- (reg-tn-encoding res)
- (extract/deposit-condition cond)
- ,(- opcode 2) 0 (- 32 len)))
- ((integer 0 31)
- (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
- (reg-tn-encoding res)
- (extract/deposit-condition cond)
- ,opcode posn (- 32 len))))))))
+ `(define-instruction ,name (segment src posn len res &optional cond)
+ (:declare (type tn res src)
+ (type (or (member :variable) (integer 0 31)) posn)
+ (type (integer 1 32) len))
+ (:printer extract/deposit-inst ((op1 #x34) (cp nil :type 'integer)
+ (op2 ,opcode))
+ '(:name c :tab r2 "," cp "," t/clen "," r1))
+ (:printer extract/deposit-inst ((op1 #x34) (op2 ,(- opcode 2)))
+ '('V :name c :tab r2 "," t/clen "," r1))
+ (:emitter
+ (etypecase posn
+ ((member :variable)
+ (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+ (reg-tn-encoding res)
+ (extract/deposit-condition cond)
+ ,(- opcode 2) 0 (- 32 len)))
+ ((integer 0 31)
+ (emit-extract/deposit-inst segment #x34 (reg-tn-encoding src)
+ (reg-tn-encoding res)
+ (extract/deposit-condition cond)
+ ,opcode posn (- 32 len))))))))
- `(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
- (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))))))))
-
+ `(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
+ (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))))))))
+
- `(define-instruction ,name (segment from to)
- (:declare (type tn from to))
- (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
- '(:name sf df :tab r "," t))
- (:emitter
- (multiple-value-bind
- (from-encoding from-double-p)
- (fp-reg-tn-encoding from)
- (multiple-value-bind
- (to-encoding to-double-p)
- (fp-reg-tn-encoding to)
- (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
- (if to-double-p 1 0) (if from-double-p 1 0)
- 1 0 0 to-encoding)))))))
-
+ `(define-instruction ,name (segment from to)
+ (:declare (type tn from to))
+ (:printer fp-class-1-inst ((op1 #x0C) (x2 ,subcode))
+ '(:name sf df :tab r "," t))
+ (:emitter
+ (multiple-value-bind
+ (from-encoding from-double-p)
+ (fp-reg-tn-encoding from)
+ (multiple-value-bind
+ (to-encoding to-double-p)
+ (fp-reg-tn-encoding to)
+ (emit-fp-class-1-inst segment #x0C from-encoding 0 ,subcode
+ (if to-double-p 1 0) (if from-double-p 1 0)
+ 1 0 0 to-encoding)))))))
+
- (result-encoding result-double-p)
- (fp-reg-tn-encoding result)
- (assert (eq r1-double-p result-double-p))
- (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
- (or (position op fbinops)
- (error "Bogus FBINOP: ~S" op))
- (if r1-double-p 1 0) 3 0 0
- result-encoding))))))
+ (result-encoding result-double-p)
+ (fp-reg-tn-encoding result)
+ (aver (eq r1-double-p result-double-p))
+ (emit-fp-class-0-inst segment #x0C r1-encoding r2-encoding
+ (or (position op fbinops)
+ (error "Bogus FBINOP: ~S" op))
+ (if r1-double-p 1 0) 3 0 0
+ result-encoding))))))
- (let ((disp (label-relative-displacement target posn)))
- (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)))))))))
+ (let ((disp (label-relative-displacement target posn)))
+ (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)))))))))
- (let ((disp (label-relative-displacement target posn)))
- (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)))))))))
+ (let ((disp (label-relative-displacement target posn)))
+ (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)))))))))
- (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 = fn - header - label-offset + other-pointer-tag
-(define-instruction compute-code-from-fn (segment src label temp dst)
+ (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)