common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

sparc: remove LRA

Browse source
This commit is contained in:
Stas Boukarev 2026-03-01 04:02:07 +03:00
parent 54ea7a25b4
commit b7de739ff6
22 changed files with 174 additions and 176 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
src/assembly/sparc/arith.lisp
View file

@ -46,10 +46,10 @@
(lisp-return lra :offset 2)
DO-STATIC-FUN
(inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
(inst ld lip-tn null-tn (static-fun-offset 'two-arg-+))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)
@ -90,10 +90,10 @@
(lisp-return lra :offset 2)
DO-STATIC-FUN
(inst ld code-tn null-tn (static-fun-offset 'two-arg--))
(inst ld lip-tn null-tn (static-fun-offset 'two-arg--))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)
@ -193,10 +193,10 @@
(lisp-return lra :offset 2)
DO-STATIC-FUN
(inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
(inst ld lip-tn null-tn (static-fun-offset 'two-arg-*))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)
@ -412,10 +412,10 @@
(inst cmp x y)
DO-STATIC-FN
(inst ld code-tn null-tn (static-fun-offset ',static-fn))
(inst ld lip-tn null-tn (static-fun-offset ',static-fn))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)
@ -458,10 +458,10 @@
(lisp-return lra :offset 2)
DO-STATIC-FN
(inst ld code-tn null-tn (static-fun-offset 'eql))
(inst ld lip-tn null-tn (static-fun-offset 'eql))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)
@ -494,10 +494,10 @@
(lisp-return lra :offset 2)
DO-STATIC-FN
(inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
(inst ld lip-tn null-tn (static-fun-offset 'two-arg-=))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)
@ -530,10 +530,10 @@
(lisp-return lra :offset 2)
DO-STATIC-FN
(inst ld code-tn null-tn (static-fun-offset 'two-arg-/=))
(inst ld lip-tn null-tn (static-fun-offset 'two-arg-/=))
(inst li nargs (fixnumize 2))
(inst move ocfp cfp-tn)
(inst j code-tn
(inst j lip-tn
(- (* simple-fun-insts-offset n-word-bytes) fun-pointer-lowtag))
(inst move cfp-tn csp-tn)

10
src/assembly/sparc/assem-rtns.lisp
View file

@ -154,8 +154,8 @@
DONE
;; We are done. Do the jump.
(loadw temp lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump temp))
(loadw lip-tn lexenv closure-fun-slot fun-pointer-lowtag)
(lisp-jump lip-tn))
@ -179,6 +179,7 @@
(inst b :eq error))
(load-symbol-value cur-uwp *current-unwind-protect-block*)
(loadw target-uwp block unwind-block-uwp-slot)
(inst cmp cur-uwp target-uwp)
(inst b :ne do-uwp)
@ -189,10 +190,9 @@
DO-EXIT
(loadw cfp-tn cur-uwp unwind-block-cfp-slot)
(loadw code-tn cur-uwp unwind-block-code-slot)
(loadw lra cur-uwp unwind-block-entry-pc-slot)
(lisp-return lra :frob-code nil)
(inst j lra)
(loadw code-tn cur-uwp unwind-block-code-slot)
DO-UWP
(loadw next-uwp cur-uwp unwind-block-uwp-slot)

8
src/assembly/sparc/support.lisp
View file

@ -33,17 +33,15 @@
(cur-nfp (current-nfp-tn ,vop)))
(when cur-nfp
(store-stack-tn ,nfp-save cur-nfp))
(inst compute-lra-from-code ,lra code-tn lra-label ,temp)
(note-next-instruction ,vop :call-site)
(inst ji ,temp (make-fixup ',name :assembly-routine))
(inst jali ,lra ,temp (make-fixup ',name :assembly-routine))
(inst nop)
(emit-return-pc lra-label)
(emit-label lra-label)
(note-this-location ,vop :single-value-return)
(without-scheduling ()
(move csp-tn ocfp-tn)
(inst nop))
(inst compute-code-from-lra code-tn code-tn
lra-label ,temp)
(inst compute-code-from-lra code-tn ,lra lra-label ,temp)
(when cur-nfp
(load-stack-tn cur-nfp ,nfp-save))))
`((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1))

12
src/assembly/sparc/tramps.lisp
View file

@ -33,9 +33,9 @@
(inst word nil-value))
(loadw lexenv-tn cname-tn fdefn-fun-slot other-pointer-lowtag)
(loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst j code-tn (- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag))
(loadw lip-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst j lip-tn (- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag))
(inst nop)))
(define-assembly-routine
@ -52,7 +52,7 @@
(inst word nil-value))
(loadw lexenv-tn lexenv-tn funcallable-instance-function-slot fun-pointer-lowtag)
(loadw code-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst j code-tn (- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag))
(loadw lip-tn lexenv-tn closure-fun-slot fun-pointer-lowtag)
(inst j lip-tn (- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag))
(inst nop)))

42
src/code/debug-int.lisp
View file

@ -645,7 +645,7 @@
(word (int-sap pc)))))))
(unless (= base-ptr 0) (%make-lisp-obj (logior base-ptr other-pointer-lowtag))))))
#+(or arm arm64 riscv loongarch64 ppc64 ppc)
#+(or arm arm64 sparc riscv loongarch64 ppc64 ppc)
(defun compute-lra-data-from-pc (pc)
(declare (type integer pc))
(let* ((pc-sap (int-sap (ash pc n-fixnum-tag-bits)))
@ -893,7 +893,7 @@
;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
;;; calls into C. In this case, the code object is stored on the stack
;;; after the LRA, and the LRA is the word offset.
#-(or arm x86 x86-64 arm64 riscv loongarch64 ppc64 ppc)
#-(or arm x86 x86-64 arm64 sparc riscv loongarch64 ppc64 ppc)
(defun compute-calling-frame (caller lra up-frame &optional savedp)
(declare (type system-area-pointer caller)
(ignore savedp))
@ -946,9 +946,9 @@
(if up-frame (1+ (frame-number up-frame)) 0)
escaped))))))
#+(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#+(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(defun compute-calling-frame (caller ra up-frame &optional savedp)
(declare (type system-area-pointer caller #-(or ppc ppc64 arm arm64 riscv loongarch64) ra))
(declare (type system-area-pointer caller #-(or ppc ppc64 arm arm64 sparc riscv loongarch64) ra))
(when (control-stack-pointer-valid-p caller)
;; First check for an escaped frame.
(multiple-value-bind (code pc-offset escaped off-stack assembly-routine-p)
@ -973,8 +973,8 @@
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
(foreign-function-backtrace-name #-(or arm64 arm riscv loongarch64 ppc64 ppc) ra
#+(or arm64 arm riscv loongarch64 ppc64 ppc) (int-sap (get-lisp-obj-address ra)))))
(foreign-function-backtrace-name #-(or arm64 sparc arm riscv loongarch64 ppc64 ppc) ra
#+(or arm64 sparc arm riscv loongarch64 ppc64 ppc) (int-sap (get-lisp-obj-address ra)))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
@ -1124,7 +1124,7 @@
(code (code-object-from-context context))
assembly-routine-p)
(/noshow0 "got CODE")
#+(or arm arm64 loongarch64 ppc64 ppc)
#+(or arm arm64 sparc loongarch64 ppc64 ppc)
(when (eq code sb-fasl:*assembler-routines*)
(unless (memq (assembly-routine-name-from-pc code (code-pc-offset pc code))
'(sb-vm::undefined-tramp sb-vm::undefined-alien-tramp
@ -1170,7 +1170,7 @@
(setf pc-offset 0))))
(/noshow0 "returning from FIND-ESCAPED-FRAME")
(return
(cond #-(or riscv arm arm64 loongarch64 ppc64 ppc)
(cond #-(or riscv arm arm64 sparc loongarch64 ppc64 ppc)
((eq (%code-debug-info code) :bpt-lra)
(let ((real-lra (code-header-ref code real-lra-slot)))
(values (lra-code-header real-lra)
@ -1195,12 +1195,12 @@ register."
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
;;; undefined-function.
#+(or riscv arm arm64 ppc ppc64 x86 x86-64 loongarch64)
#+(or riscv arm arm64 sparc ppc ppc64 x86 x86-64 loongarch64)
(defun code-object-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
(code-header-from-pc (context-pc context)))
#-(or riscv arm arm64 ppc ppc64 x86 x86-64 loongarch64)
#-(or riscv arm arm64 sparc ppc ppc64 x86 x86-64 loongarch64)
(defun code-object-from-context (context)
(declare (type (sb-alien:alien (* os-context-t)) context))
;; The GC constraint on the program counter on precisely-scavenged
@ -1356,7 +1356,7 @@ register."
(fp (frame-pointer frame)))
(labels ((catch-ref (slot)
(sap-ref-lispobj catch (* slot n-word-bytes)))
#-(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#-(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(catch-entry-offset ()
(let* ((lra (catch-ref catch-block-entry-pc-slot))
(component (catch-ref catch-block-code-slot))
@ -1366,12 +1366,12 @@ register."
(* (- (1+ (get-header-data lra))
(code-header-words component))
n-word-bytes)))
#+(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#+(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(catch-entry-offset ()
(let* ((ra (sap-ref-sap
catch (* catch-block-entry-pc-slot
n-word-bytes)))
(component #+(or riscv loongarch64 ppc64 ppc arm)
(component #+(or riscv loongarch64 ppc64 ppc arm sparc)
(catch-ref catch-block-code-slot)
#+(or x86 x86-64 arm64)
(code-header-from-pc ra))
@ -3893,8 +3893,8 @@ register."
;;; state of the program, not merely a return PC location.
;;; (I tried changing this to DEFUN-CACHED, which failed a regression test)
(defun make-bpt-lra (real-lra &optional known-return-p)
(declare (type #-(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc) lra
#+(or arm arm64 riscv loongarch64 ppc64 ppc) fixnum
(declare (type #-(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc) lra
#+(or arm arm64 sparc riscv loongarch64 ppc64 ppc) fixnum
#+(or x86 x86-64) system-area-pointer real-lra))
(let* ((src-start
;; Just trap when using the known return values convention,
@ -3907,7 +3907,7 @@ register."
(start-offset
(+ n-word-bytes ; Jump Table prefix word
;; Alignment padding, LRA header.
#-(or x86 x86-64 arm arm64 riscv loongarch64)
#-(or x86 x86-64 arm arm64 sparc riscv loongarch64)
(* 2 n-word-bytes)))
;; TRAP-OFFSET is the distance from CODE-INSTRUCTIONS to the
;; actual magic fun_end breakpoint trap.
@ -3932,11 +3932,11 @@ register."
(with-pinned-objects (code-object)
(let ((dst-start
(sap+ (code-instructions code-object) start-offset)))
#-(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#-(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(progn
(setf (code-header-ref code-object real-lra-slot) real-lra)
(setf (code-header-ref code-object known-return-p-slot) known-return-p))
#+(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#+(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(multiple-value-bind (offset code)
(compute-lra-data-from-pc real-lra)
(setf (code-header-ref code-object real-lra-slot) code)
@ -3950,11 +3950,11 @@ register."
;; CODE-OBJECT is implicitly pinned after leaving
;; WITH-PINNED-OBJECTS (and would be pinned even if the W-P-O
;; were deleted), so it's OK to return a SAP into CODE-OBJECT.
#+(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#+(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(let ((dst-start #+(or x86 x86-64) dst-start
#+(or arm arm64 riscv loongarch64 ppc64 ppc) (%make-lisp-obj (sap-int dst-start))))
#+(or arm arm64 sparc riscv loongarch64 ppc64 ppc) (%make-lisp-obj (sap-int dst-start))))
(values dst-start code-object trap-offset))
#-(or x86 x86-64 arm arm64 riscv loongarch64 ppc64 ppc)
#-(or x86 x86-64 arm arm64 sparc riscv loongarch64 ppc64 ppc)
(let* ((lra-header (sap+ dst-start (* -1 n-word-bytes)))
;; Compute the LRA->code backpointer in words
(delta (ash (sap- lra-header

4
src/compiler/codegen.lisp
View file

@ -64,7 +64,7 @@
;;; the TN used for passing the return PC in a local call to the function
;;; designated by 2ENV
#+(or mips sparc)
#+mips
(defun callee-return-pc-tn (2env)
(ir2-environment-return-pc-pass 2env))
@ -349,7 +349,7 @@
(assemble-sections
asmstream
(ir2-component-entries ir2-component)
(make-segment (default-segment-run-scheduler) skew))
(make-segment nil skew))
(values segment text-length fun-table
(asmstream-elsewhere-label asmstream) fixup-notes
(sb-assem::get-allocation-points asmstream))))))

104
src/compiler/sparc/call.lisp
View file

@ -21,9 +21,8 @@
;;; this may be restricted by a desire to use a subroutine call
;;; instruction.
(defun make-return-pc-passing-location (standard)
(if standard
(make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number lra-offset)
(make-restricted-tn *backend-t-primitive-type* descriptor-reg-sc-number)))
(declare (ignore standard))
(make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number lra-offset))
;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
;;; location to pass OLD-FP in. This is (obviously) wired in the
@ -47,11 +46,12 @@
ocfp-save-offset)))
(defun make-return-pc-save-location (env)
(specify-save-tn
(environment-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
(make-wired-tn *backend-t-primitive-type*
control-stack-arg-scn
lra-save-offset)))
(let ((ptype *backend-t-primitive-type*))
(specify-save-tn
(environment-debug-live-tn
(make-wired-tn ptype descriptor-reg-sc-number lra-offset)
env)
(make-wired-tn ptype control-stack-arg-scn lra-save-offset))))
;;; Make a TN for the standard argument count passing location. We
;;; only need to make the standard location, since a count is never
@ -121,7 +121,7 @@
(inst .skip (* (1- simple-fun-insts-offset) n-word-bytes))
;; The start of the actual code.
;; Fix CODE, cause the function object was passed in.
(inst compute-code-from-fn code-tn code-tn start-lab temp)))
(inst compute-code-from-fn code-tn lip-tn start-lab temp)))
(define-vop (xep-setup-sp)
(:vop-var vop)
@ -235,7 +235,7 @@ default-value-8
(note-this-location vop :single-value-return)
(move csp-tn ocfp-tn)
(inst nop))
(inst compute-code-from-lra code-tn code-tn lra-label temp))
(inst compute-code-from-lra code-tn lra-tn lra-label temp))
(let ((regs-defaulted (gen-label))
(defaulting-done (gen-label))
(default-stack-vals (gen-label)))
@ -246,7 +246,7 @@ default-value-8
(if (> nvals register-arg-count)
(inst subcc temp nargs-tn (fixnumize register-arg-count))
(move csp-tn ocfp-tn)))
(inst compute-code-from-lra code-tn lra-tn lra-label temp)
;; Do the single value calse.
(do ((i 1 (1+ i))
(val (tn-ref-across values) (tn-ref-across val)))
@ -257,6 +257,7 @@ default-value-8
(move ocfp-tn csp-tn))
(emit-label regs-defaulted)
(inst compute-code-from-lra code-tn lra-tn lra-label temp)
(when (> nvals register-arg-count)
(collect ((defaults))
(do ((i register-arg-count (1+ i))
@ -288,9 +289,7 @@ default-value-8
(emit-label (car def))
(when (null (cdr remaining))
(inst b defaulting-done))
(store-stack-tn (cdr def) null-tn))))))))
(inst compute-code-from-lra code-tn code-tn lra-label temp)))
(store-stack-tn (cdr def) null-tn))))))))))
(values))
@ -319,7 +318,7 @@ default-value-8
(inst b variable-values)
(inst nop))
(inst compute-code-from-lra code-tn code-tn lra-label temp)
(inst compute-code-from-lra code-tn lra-tn lra-label temp)
(inst add csp-tn 4)
(storew (first *register-arg-tns*) csp-tn -1)
(inst sub start csp-tn 4)
@ -329,7 +328,7 @@ default-value-8
(assemble (:elsewhere)
(emit-label variable-values)
(inst compute-code-from-lra code-tn code-tn lra-label temp)
(inst compute-code-from-lra code-tn lra-tn lra-label temp)
(do ((arg *register-arg-tns* (rest arg))
(i 0 (1+ i)))
((null arg))
@ -359,9 +358,12 @@ default-value-8
;;; points, local-call entry points, and tail-call entry points. The default
;;; does nothing.
(defun emit-block-header (start-label trampoline-label fall-thru-p alignp)
(declare (ignore fall-thru-p alignp))
(declare (ignore alignp))
(when (and fall-thru-p trampoline-label)
(inst b start-label))
(when trampoline-label
(emit-label trampoline-label))
(emit-label trampoline-label)
(storew lra-tn cfp-tn lra-save-offset))
(emit-label start-label))
@ -407,12 +409,10 @@ default-value-8
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
(callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst call target)
(inst nop)
(emit-return-pc label)
(emit-label label)
(default-unknown-values vop values nvals move-temp temp label)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
@ -445,12 +445,10 @@ default-value-8
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
(callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst call target)
(inst nop)
(emit-return-pc label)
(emit-label label)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count label temp)
(when cur-nfp
@ -476,7 +474,6 @@ default-value-8
(:ignore args res save)
(:vop-var vop)
(:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 5
(let ((label (gen-label))
(cur-nfp (current-nfp-tn vop)))
@ -486,12 +483,10 @@ default-value-8
(when callee-nfp
(maybe-load-stack-tn callee-nfp nfp)))
(maybe-load-stack-tn cfp-tn fp)
(inst compute-lra-from-code
(callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst b target)
(inst call target)
(inst nop)
(emit-return-pc label)
(emit-label label)
(note-this-location vop :known-return)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save)))))
@ -505,24 +500,24 @@ default-value-8
;;; MAYBE-LOAD-STACK-TN.
(define-vop (known-return)
(:args (old-fp :target old-fp-temp)
(return-pc :target return-pc-temp)
(return-pc :target lra)
(vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) old-fp-temp)
(:temporary (:sc descriptor-reg :from (:argument 1)) return-pc-temp)
(:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
(:move-args :known-return)
(:info val-locs)
(:ignore val-locs vals)
(:vop-var vop)
(:generator 6
(maybe-load-stack-tn old-fp-temp old-fp)
(maybe-load-stack-tn return-pc-temp return-pc)
(maybe-load-stack-tn lra return-pc)
(move csp-tn cfp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
(inst add nsp-tn cur-nfp
(- (bytes-needed-for-non-descriptor-stack-frame)
number-stack-displacement))))
(inst j return-pc-temp (- n-word-bytes other-pointer-lowtag))
(inst j lra 8)
(move cfp-tn old-fp-temp)))
@ -670,8 +665,7 @@ default-value-8
:load-return-pc)
(when cur-nfp
:frob-nfp))
'(:comp-lra
(when cur-nfp
'((when cur-nfp
:frob-nfp)
:save-fp
:load-fp))))))
@ -707,10 +701,7 @@ default-value-8
(inst add nsp-tn cur-nfp
(- (bytes-needed-for-non-descriptor-stack-frame)
number-stack-displacement))))
`((:comp-lra
(inst compute-lra-from-code
return-pc-pass code-tn lra-label temp))
(:frob-nfp
`((:frob-nfp
(store-stack-tn nfp-save cur-nfp))
(:save-fp
(inst move old-fp-pass cfp-tn))
@ -777,20 +768,21 @@ default-value-8
(return)))
(note-this-location vop :call-site)
(inst j function
(- (ash simple-fun-insts-offset word-shift)
fun-pointer-lowtag))
(inst move code-tn function))
,@(if (eq return :tail)
'((inst j function
(- (ash simple-fun-insts-offset word-shift) fun-pointer-lowtag)))
'((inst jmpl return-pc-pass function (- (ash simple-fun-insts-offset word-shift) fun-pointer-lowtag))))
(inst move lip-tn function))
,@(ecase return
(:fixed
'((emit-return-pc lra-label)
'((emit-label lra-label)
(default-unknown-values vop values nvals move-temp
temp lra-label)
(when cur-nfp
(load-stack-tn cur-nfp nfp-save))))
(:unknown
'((emit-return-pc lra-label)
'((emit-label lra-label)
(note-this-location vop :unknown-return)
(receive-unknown-values values-start nvals start count
lra-label temp)
@ -856,11 +848,13 @@ default-value-8
;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
(:args (old-fp :scs (any-reg))
(return-pc :scs (descriptor-reg))
(return-pc :scs (descriptor-reg) :target lra)
(value))
(:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
(:ignore value)
(:vop-var vop)
(:generator 6
(move lra return-pc)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
@ -871,7 +865,7 @@ default-value-8
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Out of here.
(lisp-return return-pc :offset 2)))
(lisp-return lra :offset 2)))
;;; Do unknown-values return of a fixed number of values. The Values are
;;; required to be set up in the standard passing locations. Nvals is the
@ -888,7 +882,7 @@ default-value-8
(define-vop (return)
(:args
(old-fp :scs (any-reg))
(return-pc :scs (descriptor-reg) :to (:eval 1))
(return-pc :scs (descriptor-reg) :to (:eval 1) :target lra)
(values :more t))
(:ignore values)
(:info nvals)
@ -900,8 +894,10 @@ default-value-8
(:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
(:temporary (:sc any-reg :offset nargs-offset) nargs)
(:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
(:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 1)) lra)
(:vop-var vop)
(:generator 6
(move lra return-pc)
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
@ -913,7 +909,7 @@ default-value-8
(move csp-tn cfp-tn)
(move cfp-tn old-fp)
;; Out of here.
(lisp-return return-pc :offset 2))
(lisp-return lra :offset 2))
(t
;; Establish the values pointer and values count.
(move val-ptr cfp-tn)
@ -927,7 +923,7 @@ default-value-8
(dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
(move reg null-tn)))
;; And away we go.
(lisp-return return-pc)))))
(lisp-return lra)))))
;;; Do unknown-values return of an arbitrary number of values (passed on the
;;; stack.) We check for the common case of a single return value, and do that
@ -951,6 +947,7 @@ default-value-8
(:vop-var vop)
(:generator 13
(move lra lra-arg)
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
@ -967,12 +964,11 @@ default-value-8
;; Return with one value.
(move csp-tn cfp-tn)
(move cfp-tn old-fp-arg)
(lisp-return lra-arg :offset 2)
(lisp-return lra :offset 2)
;; Nope, not the single case.
(emit-label not-single)
(move old-fp old-fp-arg)
(move lra lra-arg)
(move vals vals-arg)
(move nvals nvals-arg)
(inst ji temp (make-fixup 'return-multiple :assembly-routine))

40
src/compiler/sparc/insts.lisp
View file

@ -208,7 +208,7 @@ Otherwise, use the Sparc register names")
(define-instruction-format
(format-1 32 :default-printer '(:name :tab disp))
(op :field (byte 2 30) :value 1)
(disp :field (byte 30 0)))
(disp :field (byte 30 0) :type 'relative-label))
(define-instruction-format
(format-2-immed 32 :default-printer '(:name :tab immed ", " rd))
@ -1116,6 +1116,17 @@ Otherwise, use the Sparc register names")
(declare (type (or label null) target))
(emit-relative-branch segment 0 #b010 cond-or-target target))))))
(define-instruction call (segment target)
(:declare (type label target))
(:printer format-1 ((op #b01)))
(:attributes branch)
(:delay 1)
(:emitter
(emit-back-patch segment 4
(lambda (segment posn)
(emit-format-1
segment #b01 (ash (- (label-position target) posn) -2))))))
(define-instruction bp (segment cond-or-target &optional target pred cc)
(:declare (type (or label branch-condition) cond-or-target)
(type (or label null) target))
@ -1514,6 +1525,16 @@ Otherwise, use the Sparc register names")
(inst sethi tmpreg value)
(inst jal link tmpreg value))))))
(define-instruction jmpl (segment link target offset)
(:declare (type tn link target)
(type (signed-byte 13) offset))
(:attributes branch)
(:dependencies (writes link))
(:delay 1)
(:emitter
(emit-format-3-immed segment #b10 (reg-tn-encoding link) #b111000
(reg-tn-encoding target) 1 offset)))
;;; Jump to a full 32-bit address. Tmpreg is trashed.
(define-instruction ji (segment tmpreg value)
(:declare (type tn tmpreg)
@ -1674,8 +1695,7 @@ Otherwise, use the Sparc register names")
(label-position label posn delta-if-after)
(component-header-length))))))
;; code = lra - other-pointer-tag - header - label-offset + other-pointer-tag
;; = lra - (header + label-offset)
;; code = lra - (header + label-offset) + other-pointer-lowtag
(define-instruction compute-code-from-lra (segment dst src label temp)
(:declare (type tn dst src temp) (type label label))
(:attributes variable-length)
@ -1685,11 +1705,12 @@ Otherwise, use the Sparc register names")
(: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)))))))
(+ (- 8
(+ (label-position label posn delta-if-after)
(component-header-length)))
other-pointer-lowtag)))))
;; lra = code + other-pointer-tag + header + label-offset - other-pointer-tag
;; = code + header + label-offset
;; lra = code + header + label-offset - other-pointer-lowtag
(define-instruction compute-lra-from-code (segment dst src label temp)
(:declare (type tn dst src temp) (type label label))
(:attributes variable-length)
@ -1699,8 +1720,9 @@ Otherwise, use the Sparc register names")
(: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))))))
(- (+ (label-position label posn delta-if-after)
(component-header-length))
other-pointer-lowtag)))))
;;; Sparc V9 additions

19
src/compiler/sparc/macros.lisp
View file

@ -77,24 +77,13 @@
`(progn
(inst j ,fun
(- (ash simple-fun-insts-offset word-shift) fun-pointer-lowtag))
(move code-tn ,fun)))
(inst nop)))
(defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
(defmacro lisp-return (return-pc &key (offset 0))
"Return to RETURN-PC."
`(progn
(inst j ,return-pc
(- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
,(if frob-code
`(move code-tn ,return-pc)
'(inst nop))))
(defmacro emit-return-pc (label)
"Emit a return-pc header word. LABEL is the label to use for this return-pc."
`(progn
(emit-alignment n-lowtag-bits)
(emit-label ,label)
(inst lra-header-word)))
(inst j ,return-pc (+ 8 (* ,offset n-word-bytes)))
(inst nop)))
;;;; stack TN's

8
src/compiler/sparc/nlx.lisp
View file

@ -161,7 +161,7 @@
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)
(cond ((zerop nvals))
((= nvals 1)
@ -215,7 +215,7 @@
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)
(move res value)
(load-stack-tn csp-tn sp)))
@ -232,7 +232,7 @@
(:save-p :force-to-stack)
(:vop-var vop)
(:generator 30
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)
(let ((loop (gen-label))
(done (gen-label)))
@ -269,6 +269,6 @@
(:ignore block start count)
(:vop-var vop)
(:generator 0
(emit-return-pc label)
(emit-label label)
(note-this-location vop :non-local-entry)))

5
src/compiler/sparc/vm.lisp
View file

@ -56,7 +56,7 @@
(defreg nl4 12) ; %o4
(defreg nl5 13) ; %o5
(defreg nsp 14) ; %o6
(defreg nargs 15) ; %o7
(defreg lra 15) ; %o7
;; Locals. These are preserved when we call into C.
(defreg a0 16) ; %l0
@ -66,7 +66,7 @@
(defreg a4 20) ; %l4
(defreg a5 21) ; %l5
(defreg ocfp 22) ; %l6
(defreg lra 23) ; %l7
(defreg nargs 23) ; %l7
;; Ins. These are preserved just like locals.
(defreg cname 24) ; %i0
@ -270,6 +270,7 @@
(defregtn null descriptor-reg)
(defregtn code descriptor-reg)
(defregtn lip descriptor-reg)
(defregtn lra descriptor-reg)
(defregtn thread any-reg)
(defregtn nargs any-reg)

5
src/runtime/backtrace.c
View file

@ -491,6 +491,7 @@ int lisp_frame_previous(struct thread *thread, struct call_info *info)
if (info->frame == NULL || info->frame == this_frame)
return 0;
lra = info->lra;
if (lra == NIL) {
/* We were interrupted. Find the correct signal context. */
free_ici = fixnum_value(read_TLS(FREE_INTERRUPT_CONTEXT_INDEX,thread));
@ -505,12 +506,12 @@ int lisp_frame_previous(struct thread *thread, struct call_info *info)
}
} else if (fixnump(lra)) {
info->code =
#if defined reg_CODE && !(defined(LISP_FEATURE_PPC64) || defined(LISP_FEATURE_PPC) || defined(LISP_FEATURE_ARM))
#if defined reg_CODE && !(defined(LISP_FEATURE_PPC64) || defined(LISP_FEATURE_PPC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_SPARC))
(struct code*)native_pointer(this_frame->code);
#else
(struct code*)component_ptr_from_pc((char *)lra);
#endif
#if defined reg_LRA && !(defined(LISP_FEATURE_PPC64) || defined(LISP_FEATURE_PPC) || defined(LISP_FEATURE_ARM))
#if defined reg_LRA && !(defined(LISP_FEATURE_PPC64) || defined(LISP_FEATURE_PPC) || defined(LISP_FEATURE_ARM) || defined(LISP_FEATURE_SPARC))
info->pc = lra;
#else
info->pc = (char*)native_pointer(lra) - (char*)info->code;

6
src/runtime/gencgc.c
View file

@ -1451,7 +1451,7 @@ static lispobj conservative_root_p(lispobj addr, page_index_t addr_page_index)
&& plausible_tag_p(addr)) return AMBIGUOUS_POINTER;
return 0;
}
#elif defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC || defined LISP_FEATURE_ARM
#elif defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC
/* Consider interior pointers to code as roots.
* But most other pointers are *unambiguous* conservative roots.
* This is not "less conservative" per se, than the non-precise code,
@ -2007,7 +2007,7 @@ static void impart_mark_stickiness(lispobj word)
}
#endif
#if !GENCGC_IS_PRECISE || defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC || defined LISP_FEATURE_PPC
#if !GENCGC_IS_PRECISE || defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC
/* Take a possible pointer to a Lisp object and mark its page in the
* page_table so that it will not be relocated during a GC.
*
@ -3135,7 +3135,7 @@ static void pin_call_chain_and_boxed_registers(struct thread* th) {
maybe_pin_code(os_context_pc(context));
#endif
#ifdef LISP_FEATURE_LOONGARCH64
#if defined LISP_FEATURE_LOONGARCH64 || defined LISP_FEATURE_SPARC
/* It can't call a tagged pointer directly (neither can ARM64,
* but it has a different call sequence for tail calls) */
maybe_pin_code((lispobj)*os_context_register_addr(context, reg_LIP));

2
src/runtime/interrupt.c
View file

@ -782,7 +782,7 @@ build_fake_control_stack_frames(struct thread *th, os_context_t *context)
access_control_frame_pointer(th)[0] = cfp;
access_control_stack_pointer(th) = csp + 2;
}
#elif defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC || defined LISP_FEATURE_ARM
#elif defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC || defined LISP_FEATURE_ARM || defined LISP_FEATURE_SPARC
static void
build_fake_control_stack_frames(struct thread *th, os_context_t *context)
{

4
src/runtime/linux-os.c
View file

@ -306,12 +306,16 @@ sigsegv_handler(int signal, siginfo_t *info, os_context_t *context)
sbcl_fallback_sigsegv_handler(signal, info, context);
}
void interrupt_handle_now_handler(int signal, siginfo_t *info, os_context_t *context);
void
os_install_interrupt_handlers(void)
{
if (INSTALL_SIG_MEMORY_FAULT_HANDLER) {
ll_install_handler(SIG_MEMORY_FAULT, sigsegv_handler);
}
#if defined LISP_FEATURE_SPARC || defined LISP_FEATURE_MIPS
ll_install_handler(SIGBUS, interrupt_handle_now_handler);
#endif
}
char *os_get_runtime_executable_path()

6
src/runtime/sparc-arch.c
View file

@ -230,6 +230,8 @@ static void handle_allocation_trap(os_context_t *context, unsigned int *pc)
undo_fake_foreign_function_call(context);
}
void save_context_for_ldb(os_context_t *context);
static void sigill_handler(int signal, siginfo_t *siginfo,
os_context_t *context)
{
@ -238,8 +240,10 @@ static void sigill_handler(int signal, siginfo_t *siginfo,
unsigned int inst;
unsigned int* pc = (unsigned int*) siginfo->si_addr;
if (!gc_managed_heap_space_p((lispobj)pc))
if (!gc_managed_heap_space_p((lispobj)pc)) {
save_context_for_ldb(context);
lose("Illegal instruction not in lisp: %p [%x]\n", pc, *pc);
}
inst = *pc;
trap = inst & 0xff;

21
src/runtime/sparc-assem.S
View file

@ -23,7 +23,6 @@
andcc temp, temp, reg_ZERO ; \
tne PSEUDO_ATOMIC_TRAP
/* FIXME */
#define FRAMESIZE 0x48
#define ST_FLUSH_WINDOWS 0x03
.seg "text"
@ -78,19 +77,11 @@ call_into_lisp:
ld [reg_CFP+16], reg_A4
ld [reg_CFP+20], reg_A5
/* Calculate LRA */
set lra + OTHER_POINTER_LOWTAG, reg_LRA
/* Indirect closure */
ld [reg_LEXENV+CLOSURE_FUN_OFFSET], reg_CODE
jmp reg_CODE+SIMPLE_FUN_INSTS_OFFSET
ld [reg_LEXENV+CLOSURE_FUN_OFFSET], reg_LIP
jmpl reg_LIP + SIMPLE_FUN_INSTS_OFFSET, reg_LRA
nop
.align 8
lra:
.word RETURN_PC_WIDETAG
/* Blow off any extra values. */
mov reg_OCFP, reg_CSP
nop
@ -124,16 +115,12 @@ call_into_c:
mov reg_CSP, reg_CFP
add reg_CSP, 32, reg_CSP
st reg_OCFP, [reg_CFP]
st reg_LIP, [reg_CFP+4]
st reg_CODE, [reg_CFP+8]
/* Turn on pseudo-atomic. */
BEGIN_PSEUDO_ATOMIC
/* Convert the return address to an offset and save it on the stack. */
sub reg_LIP, reg_CODE, reg_L0
add reg_L0, OTHER_POINTER_LOWTAG, reg_L0
st reg_L0, [reg_CFP+4]
/* Store LISP state */
store(reg_BSP,current_binding_stack_pointer)
store(reg_CSP,current_control_stack_pointer)
@ -174,8 +161,6 @@ call_into_c:
/* Get the return address back. */
ld [reg_CFP+4], reg_LIP
ld [reg_CFP+8], reg_CODE
add reg_LIP, reg_CODE, reg_LIP
sub reg_LIP, OTHER_POINTER_LOWTAG, reg_LIP
/* No longer atomic. */
END_PSEUDO_ATOMIC(reg_NL2)

7
src/runtime/sparc-lispregs.h
View file

@ -42,7 +42,7 @@
#define reg_NL4 OREG(4)
#define reg_NL5 OREG(5)
#define reg_NSP OREG(6)
#define reg_NARGS OREG(7)
#define reg_LRA OREG(7)
#define reg_A0 LREG(0)
#define reg_A1 LREG(1)
@ -51,7 +51,7 @@
#define reg_A4 LREG(4)
#define reg_A5 LREG(5)
#define reg_OCFP LREG(6)
#define reg_LRA LREG(7)
#define reg_NARGS LREG(7)
#define reg_CNAME IREG(0)
#define reg_LEXENV IREG(1)
@ -60,3 +60,6 @@
#define reg_CFUNC IREG(4)
#define reg_CODE IREG(5)
#define reg_LIP IREG(7)
#define reg_RA reg_LRA
#define reg_LINK_RETURN reg_LRA

3
tests/backtrace.impure.lisp
View file

@ -202,6 +202,7 @@
;; bug 353: This test fails at least most of the time for x86/linux
;; ca. 0.8.20.16. -- WHN
(with-test (:name (:backtrace :undefined-function :bug-353)
:fails-on :sparc
:skipped-on :interpreter)
(assert-backtrace
(lambda () (test #'not-optimized))
@ -263,7 +264,7 @@
(defun throw-test ()
(throw 'no-such-tag t))
(with-test (:name (:backtrace :throw :no-such-tag)
:fails-on (or :arm :mips :ppc :riscv (and :sparc :linux)))
:fails-on (or :arm :mips :ppc :riscv))
(assert-backtrace #'throw-test '((throw-test))))
(funcall (checked-compile

2
tests/chill.impure.lisp
View file

@ -1,7 +1,7 @@
#+parallel-test-runner (setq run-tests::*allowed-inputs* :any)
(with-test (:name (:chill :loads-quietly)
:fails-on sparc)
:fails-on :sparc)
(handler-bind (#-sb-devel (warning (lambda (c) (error "Caught warning: ~A" c))))
(load "../src/cold/chill.lisp")))

6
tests/compiler-ir.pure.lisp
View file

@ -480,7 +480,7 @@
1)))
(with-test (:name :sign-extend
:fails-on (or :ppc :riscv :loongarch64))
:fails-on (or :ppc :riscv :loongarch64 :sparc :mips))
(assert (= (count 'sb-c::mask-signed-field
(ir-calls
`(lambda (a)
@ -535,14 +535,14 @@
(assert (node-tail-p combination))))
(with-test (:name :evenp+arithmetic
:fails-on (or :arm :riscv :loongarch64 :ppc64 :ppc))
:fails-on (or :arm :riscv :loongarch64 :ppc64 :ppc :sparc :mips))
(assert (not (ir-full-calls `(lambda (x)
(evenp (+ x 3))))))
(assert (not (ir-full-calls `(lambda (x)
(logbitp 0 (+ x 3)))))))
(with-test (:name :modarith-unknown-types
:fails-on (or :arm :ppc))
:fails-on (or :arm :ppc :sparc :mips))
(assert (not (ir-full-calls `(lambda (x)
(logand (+ x 10) 20)))))
(assert (not (ir-full-calls `(lambda (m x)

8
tests/debug.impure.lisp
View file

@ -1329,13 +1329,7 @@
(function int unsigned unsigned))
ptr base)
1)))
;; For architectures that don't use LRAs, there are exactly 'n-entries'
;; properly tagged interior pointers. For those which do use LRAs,
;; there are at least that many, because we allow pointing to LRAs,
;; but they aren't enumerable so we don't know the actual count.
(assert (#+(or x86 x86-64 arm arm64 riscv loongarch64 ppc ppc64) =
#-(or x86 x86-64 arm arm64 riscv loongarch64 ppc ppc64) >
(loop for ptr from (+ base (* 2 sb-vm:n-word-bytes))
(assert (= (loop for ptr from (+ base (* 2 sb-vm:n-word-bytes))
below limit count (properly-tagged-p ptr))
n))
;; Verify that the binary search algorithm for simple-fun-index works.