From 2cfca0fa32e708e27d4e86928d8601b851a439b9 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Fri, 27 Feb 2026 01:02:06 +0300 Subject: [PATCH] ppc32, ppc64: remove LRA TODO: put return-pc-passing-location into the LR special register. flag-based multiple value returns. --- src/assembly/ppc/arith.lisp | 6 ++ src/assembly/ppc/assem-rtns.lisp | 8 +- src/assembly/ppc/support.lisp | 10 +-- src/assembly/ppc/tramps.lisp | 3 +- src/assembly/ppc64/arith.lisp | 5 +- src/assembly/ppc64/assem-rtns.lisp | 7 +- src/assembly/ppc64/support.lisp | 13 +-- src/assembly/ppc64/tramps.lisp | 5 +- src/code/class.lisp | 4 +- src/code/debug-int.lisp | 43 +++++----- src/code/gc.lisp | 2 +- src/code/pred.lisp | 2 +- src/code/print.lisp | 2 +- src/code/stubs.lisp | 2 +- src/compiler/assem.lisp | 2 +- src/compiler/generic/early-objdef.lisp | 4 +- src/compiler/generic/late-objdef.lisp | 2 +- src/compiler/generic/type-vops.lisp | 2 +- src/compiler/generic/vm-typetran.lisp | 2 +- src/compiler/ir2tran.lisp | 6 +- src/compiler/pack.lisp | 9 ++- src/compiler/ppc/call.lisp | 93 ++++++++++----------- src/compiler/ppc/macros.lisp | 13 +-- src/compiler/ppc/nlx.lisp | 8 +- src/compiler/ppc64/c-call.lisp | 3 +- src/compiler/ppc64/call.lisp | 107 +++++++++++++------------ src/compiler/ppc64/insts.lisp | 35 +++----- src/compiler/ppc64/macros.lisp | 25 +----- src/compiler/ppc64/nlx.lisp | 13 +-- src/compiler/ppc64/show.lisp | 3 +- src/compiler/target-disassem.lisp | 4 +- src/compiler/tn.lisp | 10 ++- src/runtime/backtrace.c | 4 +- src/runtime/gencgc.c | 19 +++-- src/runtime/interrupt.c | 17 ++++ src/runtime/pmrgc.c | 4 +- src/runtime/ppc-assem.S | 24 +----- src/runtime/ppc64-assem.S | 25 +----- tests/backtrace.impure.lisp | 4 +- tests/compare-and-swap.impure.lisp | 3 +- tests/compiler-ir.pure.lisp | 5 +- tests/debug.impure.lisp | 4 +- xperfecthash30.lisp-expr | 6 ++ xperfecthash61.lisp-expr | 6 ++ xperfecthash63.lisp-expr | 3 + 45 files changed, 285 insertions(+), 292 deletions(-) diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp index 12832edde..22d87f4b2 100644 --- a/src/assembly/ppc/arith.lisp +++ b/src/assembly/ppc/arith.lisp @@ -53,6 +53,7 @@ (inst add temp2 temp2 temp) (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FUN (tail-call-fallback-fun two-arg-+) @@ -96,6 +97,7 @@ (inst sub temp2 temp temp2) (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FUN (tail-call-fallback-fun two-arg--) @@ -168,6 +170,7 @@ (storew lo res bignum-digits-offset other-pointer-lowtag))) ;; Out of here GO-HOME + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FUN (tail-call-fallback-fun two-arg-*) @@ -332,6 +335,7 @@ RETURN-NIL (inst mr res null-tn) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FN (tail-call-fallback-fun eql) @@ -363,6 +367,7 @@ (inst beq :cr1 RETURN-T) (inst mr res null-tn) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FN (tail-call-fallback-fun two-arg-=) @@ -393,6 +398,7 @@ (inst beq :cr1 RETURN-NIL) (load-symbol res t) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FN (tail-call-fallback-fun two-arg-/=) diff --git a/src/assembly/ppc/assem-rtns.lisp b/src/assembly/ppc/assem-rtns.lisp index 610df91b9..5900c7957 100644 --- a/src/assembly/ppc/assem-rtns.lisp +++ b/src/assembly/ppc/assem-rtns.lisp @@ -102,7 +102,8 @@ (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset)) + (:temp a3 descriptor-reg a3-offset) + (:temp lra descriptor-reg lra-offset)) ;; Calculate NARGS (as a fixnum) @@ -132,8 +133,9 @@ DONE ;; We are done. Do the jump. - (loadw temp lexenv closure-fun-slot fun-pointer-lowtag) - (lisp-jump temp lip)) + (inst mtlr lra) + (loadw lip lexenv closure-fun-slot fun-pointer-lowtag) + (lisp-jump lip lip)) diff --git a/src/assembly/ppc/support.lisp b/src/assembly/ppc/support.lisp index 7972e87c7..0598fcc7f 100644 --- a/src/assembly/ppc/support.lisp +++ b/src/assembly/ppc/support.lisp @@ -35,14 +35,13 @@ (note-next-instruction ,vop :call-site) (load-asm-rtn-addr ,jump ',name) (inst mtlr ,jump) - (inst blr) - (emit-return-pc lra-label) + (inst blrl) + (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 lra-tn - lra-label ,temp) + (inst compute-code-from-lip code-tn lra-tn lra-label ,temp) (when cur-nfp (load-stack-tn cur-nfp ,nfp-save)))) `((:temporary (:scs (non-descriptor-reg) :from (:eval 0) :to (:eval 1)) @@ -60,7 +59,8 @@ (:raw `((inst blr))) (:full-call - `((lisp-return (make-random-tn (sc-or-lose 'descriptor-reg) lra-offset) + `((inst mflr (make-random-tn (sc-or-lose 'descriptor-reg) lra-offset)) + (lisp-return (make-random-tn (sc-or-lose 'descriptor-reg) lra-offset) (make-random-tn (sc-or-lose 'interior-reg) lip-offset) :offset 2))) (:none))) diff --git a/src/assembly/ppc/tramps.lisp b/src/assembly/ppc/tramps.lisp index df23b98a2..cb9b17c0b 100644 --- a/src/assembly/ppc/tramps.lisp +++ b/src/assembly/ppc/tramps.lisp @@ -19,7 +19,7 @@ (inst word nil-value)) UNDEFINED-TRAMP - (inst addi code-tn lip-tn (- fun-pointer-lowtag + (inst addi code-tn lip-tn (- other-pointer-lowtag (ash simple-fun-insts-offset word-shift))) (inst cmpwi nargs-tn 16) @@ -30,6 +30,7 @@ (inst add csp-tn cfp-tn nargs-tn) FINISH-FRAME-SETUP (storew ocfp-tn cfp-tn 0) + (inst mflr lra-tn) (storew lra-tn cfp-tn 1) (error-call nil 'undefined-fun-error fdefn-tn)) diff --git a/src/assembly/ppc64/arith.lisp b/src/assembly/ppc64/arith.lisp index 79d4550dc..ff6c47de9 100644 --- a/src/assembly/ppc64/arith.lisp +++ b/src/assembly/ppc64/arith.lisp @@ -55,6 +55,7 @@ (inst add temp2 temp2 temp) (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FUN (tail-call-fallback-fun two-arg-+) @@ -93,6 +94,7 @@ (inst sub temp2 temp temp2) (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset)) (storew temp2 res bignum-digits-offset other-pointer-lowtag)) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FUN (tail-call-fallback-fun two-arg--) @@ -146,11 +148,13 @@ ;; one word bignum (with-fixed-allocation (res pa-flag temp bignum-widetag (1+ bignum-digits-offset)) (storew lo res bignum-digits-offset other-pointer-lowtag)) + (inst mflr lra) (lisp-return lra lip :offset 2) TWO-WORD-BIGNUM (with-fixed-allocation (res pa-flag temp bignum-widetag (+ bignum-digits-offset 2)) (storew lo res bignum-digits-offset other-pointer-lowtag) (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)) + (inst mflr lra) (lisp-return lra lip :offset 2) DO-STATIC-FUN (tail-call-fallback-fun two-arg-*) @@ -179,7 +183,6 @@ ;;;; Comparison - (macrolet ((define-cond-assem-rtn (name translate static-fn inst) `(define-assembly-routine diff --git a/src/assembly/ppc64/assem-rtns.lisp b/src/assembly/ppc64/assem-rtns.lisp index a245bce01..acd6f1c5f 100644 --- a/src/assembly/ppc64/assem-rtns.lisp +++ b/src/assembly/ppc64/assem-rtns.lisp @@ -103,7 +103,8 @@ (:temp a0 descriptor-reg a0-offset) (:temp a1 descriptor-reg a1-offset) (:temp a2 descriptor-reg a2-offset) - (:temp a3 descriptor-reg a3-offset)) + (:temp a3 descriptor-reg a3-offset) + (:temp lra descriptor-reg lra-offset)) ;; Calculate NARGS (as a fixnum) @@ -135,7 +136,9 @@ DONE ;; We are done. Do the jump. (loadw lip lexenv closure-fun-slot fun-pointer-lowtag) ; RAW ADDR - (inst mtctr lip) (inst bctr)) + (inst mtctr lip) + (inst mtlr lra) + (inst bctr)) ;;;; Non-local exit noise. diff --git a/src/assembly/ppc64/support.lisp b/src/assembly/ppc64/support.lisp index 0e27c4379..e470ca3c2 100644 --- a/src/assembly/ppc64/support.lisp +++ b/src/assembly/ppc64/support.lisp @@ -18,6 +18,7 @@ (let ((jump (make-symbol "JUMP"))) (values `((inst addi ,jump null-tn (make-fixup ',name :assembly-routine)) + (inst mtlr ,jump) (inst blrl)) `((:temporary (:sc any-reg) ,jump))))) @@ -31,18 +32,17 @@ (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 addi ,jump null-tn (make-fixup ',name :assembly-routine)) + (emit-alignment 3 :long-nop) (inst mtlr ,jump) - (inst blr) - (emit-return-pc lra-label) + (inst blrl) + (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 lra-tn - lra-label ,temp) + (inst compute-code-from-lip 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)) @@ -60,7 +60,8 @@ (:raw `((inst blr))) (:full-call - `((lisp-return (make-random-tn (sc-or-lose 'descriptor-reg) lra-offset) + `((inst mflr (make-random-tn (sc-or-lose 'descriptor-reg) lra-offset)) + (lisp-return (make-random-tn (sc-or-lose 'descriptor-reg) lra-offset) (make-random-tn (sc-or-lose 'interior-reg) lip-offset) :offset 2))) (:none))) diff --git a/src/assembly/ppc64/tramps.lisp b/src/assembly/ppc64/tramps.lisp index 1b6a2ed7a..9fbf602d1 100644 --- a/src/assembly/ppc64/tramps.lisp +++ b/src/assembly/ppc64/tramps.lisp @@ -25,8 +25,7 @@ ;; to load header constants since there is no PC-relative load form, ;; but there are no constants, and this routine can't be GC'ed so it's ;; not for that either. - (inst addi code-tn lip-tn (- fun-pointer-lowtag - (ash simple-fun-insts-offset word-shift))) + (inst addi code-tn lip-tn (- (ash simple-fun-insts-offset word-shift))) (inst cmpwi nargs-tn (fixnumize register-arg-count)) (inst bgt NO-STACK-ARGS) @@ -36,6 +35,7 @@ (inst add csp-tn cfp-tn nargs-tn) FINISH-FRAME-SETUP (storew ocfp-tn cfp-tn 0) + (inst mflr lra-tn) (storew lra-tn cfp-tn 1) (error-call nil 'undefined-fun-error fdefn-tn)) @@ -107,6 +107,7 @@ (inst ld r12 r12 0)) ;; load the size argument into the first C argument register (inst ld r3 lip -8) + (inst mtctr r12) (inst bctrl) ;; We're back. diff --git a/src/code/class.lisp b/src/code/class.lisp index 23ddfff87..626c3dc4d 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -952,7 +952,7 @@ between the ~A definition and the ~A definition" (declaim (type cons **non-instance-classoid-types**)) (defglobal **non-instance-classoid-types** '(symbol system-area-pointer weak-pointer code-component - #-(or x86 x86-64 arm64 riscv loongarch64) lra + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) lra fdefn random-class)) (defun classoid-non-instance-p (classoid) @@ -1053,7 +1053,7 @@ between the ~A definition and the ~A definition" (code-component :codes (,sb-vm:code-header-widetag) :predicate code-component-p :prototype-form (fun-code-header #'identity)) - #-(or x86 x86-64 arm64 riscv loongarch64) + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (lra :codes (,sb-vm:return-pc-widetag) :predicate lra-p ;; Make the PROTOTYPE slot unbound. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 07f3ac722..642aeb397 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -645,7 +645,7 @@ (word (int-sap pc))))))) (unless (= base-ptr 0) (%make-lisp-obj (logior base-ptr other-pointer-lowtag)))))) -#+(or arm64 riscv loongarch64) +#+(or arm64 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 x86 x86-64 arm64 riscv loongarch64) +#-(or x86 x86-64 arm64 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 arm64 riscv loongarch64) +#+(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (defun compute-calling-frame (caller ra up-frame &optional savedp) - (declare (type system-area-pointer caller #-(or arm64 riscv loongarch64) ra)) + (declare (type system-area-pointer caller #-(or ppc ppc64 arm64 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 riscv loongarch64) ra - #+(or arm64 riscv loongarch64) (int-sap (get-lisp-obj-address ra))))) + (foreign-function-backtrace-name #-(or arm64 riscv loongarch64 ppc64 ppc) ra + #+(or arm64 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 arm64 loongarch64) + #+(or arm64 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 arm64 loongarch64) + (cond #-(or riscv arm64 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 arm64 ppc64 x86 x86-64 loongarch64) +#+(or riscv arm64 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 arm64 ppc64 x86 x86-64 loongarch64) +#-(or riscv arm64 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 arm64 riscv loongarch64) + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (catch-entry-offset () (let* ((lra (catch-ref catch-block-entry-pc-slot)) (component (catch-ref catch-block-code-slot)) @@ -1366,15 +1366,18 @@ register." (* (- (1+ (get-header-data lra)) (code-header-words component)) n-word-bytes))) - #+(or x86 x86-64 arm64 riscv loongarch64) + #+(or x86 x86-64 arm64 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) + (component #+(or riscv loongarch64 ppc64 ppc) (catch-ref catch-block-code-slot) #+(or x86 x86-64 arm64) - (code-header-from-pc ra))) + (code-header-from-pc ra)) + #+ppc64 + (component (%make-lisp-obj (logior (ash component n-fixnum-tag-bits) + other-pointer-lowtag)))) (- (sap-int ra) (- (get-lisp-obj-address component) other-pointer-lowtag) @@ -3890,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 arm64 riscv loongarch64) lra - #+(or arm64 riscv loongarch64) fixnum + (declare (type #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) lra + #+(or arm64 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, @@ -3929,11 +3932,11 @@ register." (with-pinned-objects (code-object) (let ((dst-start (sap+ (code-instructions code-object) start-offset))) - #-(or x86 x86-64 arm64 riscv loongarch64) + #-(or x86 x86-64 arm64 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 arm64 riscv loongarch64) + #+(or x86 x86-64 arm64 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) @@ -3947,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 arm64 riscv loongarch64) + #+(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (let ((dst-start #+(or x86 x86-64) dst-start #+(or arm64 riscv loongarch64) (%make-lisp-obj (sap-int dst-start)))) (values dst-start code-object trap-offset)) - #-(or x86 x86-64 arm64 riscv loongarch64) + #-(or x86 x86-64 arm64 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 diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 2ca61868e..d4f206e4d 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -71,7 +71,7 @@ and submit it as a patch." (cond ((not (sb-vm:is-lisp-pointer (get-lisp-obj-address object))) 0) ((eq object nil) (ash sb-vm::sizeof-nil-in-words sb-vm:word-shift)) ((simple-fun-p object) (code-object-size (fun-code-header object))) - #-(or x86 x86-64 arm64 riscv loongarch64) ((lra-p object) 1) + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) ((lra-p object) 1) (t (with-alien ((sizer (function unsigned unsigned) :extern "primitive_object_size")) (with-pinned-objects (object) diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 4613aa88a..212052935 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -108,7 +108,7 @@ (def-type-predicate-wrapper integerp) (def-type-predicate-wrapper listp) (def-type-predicate-wrapper long-float-p) - #-(or x86 x86-64 arm64 riscv loongarch64) (def-type-predicate-wrapper lra-p) + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (def-type-predicate-wrapper lra-p) (def-type-predicate-wrapper null) (def-type-predicate-wrapper numberp) (sb-c::when-vop-existsp (:translate pointerp) diff --git a/src/code/print.lisp b/src/code/print.lisp index 6e99d5f0b..c8f6302ce 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1975,7 +1975,7 @@ variable: an unreadable object representing the error is printed instead.") (format stream " {~X..~X}" a (+ (logandc2 a sb-vm:lowtag-mask) (code-object-size component)))))) -#-(or x86 x86-64 arm64 riscv loongarch64) +#-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (defmethod print-object ((lra lra) stream) (print-unreadable-object (lra stream :identity t) (write-string "return PC object" stream))) diff --git a/src/code/stubs.lisp b/src/code/stubs.lisp index 0a4988602..887d1cbcd 100644 --- a/src/code/stubs.lisp +++ b/src/code/stubs.lisp @@ -166,7 +166,7 @@ (def symbol-package-id) (def symbol-hash) (def symbol-%info) ; primitive reader always needs a stub - #-(or x86 x86-64 arm64 riscv loongarch64) (def lra-code-header) + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (def lra-code-header) (def %make-lisp-obj) #+x86-64 (def single-float-copysign (float float2)) diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 888a1a5ed..7bfa89cfc 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1001,7 +1001,7 @@ (emit-byte segment pattern))) ;; EMIT-LONG-NOP does not exist for most backends. ;; Better to get an ECASE error than undefined-function. - #+x86-64 + #+(or x86-64 ppc64) ((eql :long-nop) (sb-vm:emit-long-nop segment amount))) (values)) diff --git a/src/compiler/generic/early-objdef.lisp b/src/compiler/generic/early-objdef.lisp index 23e3506db..7c388cfd6 100644 --- a/src/compiler/generic/early-objdef.lisp +++ b/src/compiler/generic/early-objdef.lisp @@ -209,8 +209,8 @@ simple-fun-widetag ; 3A 41 closure-widetag ; 3E 45 - #-(or x86 x86-64 arm64 riscv loongarch64) return-pc-widetag ; 42 49 - #+(or x86 x86-64 arm64 riscv loongarch64) lra-widetag-notused + #-(or x86 x86-64 arm64 riscv loongarch64 ppc ppc64) return-pc-widetag ; 42 49 + #+(or x86 x86-64 arm64 riscv loongarch64 ppc ppc64) lra-widetag-notused value-cell-widetag ; 46 4D character-widetag ; 4A 51 diff --git a/src/compiler/generic/late-objdef.lisp b/src/compiler/generic/late-objdef.lisp index d8cdb9dcb..e9d4c88fe 100644 --- a/src/compiler/generic/late-objdef.lisp +++ b/src/compiler/generic/late-objdef.lisp @@ -61,7 +61,7 @@ ;; Like closure, but these can also have a layout pointer in the high header bytes. (funcallable-instance "funinstance" "lose" "short_boxed") ;; These have a scav and trans function, but no size function. - #-(or x86 x86-64 arm64 riscv loongarch64) + #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (return-pc "return_pc_header" "return_pc_header" "lose") (value-cell "boxed") diff --git a/src/compiler/generic/type-vops.lisp b/src/compiler/generic/type-vops.lisp index 4e6334d1b..eec63ddd7 100644 --- a/src/compiler/generic/type-vops.lisp +++ b/src/compiler/generic/type-vops.lisp @@ -113,7 +113,7 @@ (define-type-vop code-component-p (code-header-widetag)) -#-(or x86 x86-64 arm64 riscv loongarch64) +#-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (define-type-vop lra-p (return-pc-widetag)) (define-type-vop fdefn-p (fdefn-widetag)) diff --git a/src/compiler/generic/vm-typetran.lisp b/src/compiler/generic/vm-typetran.lisp index 98b8b862f..aa0bca5e2 100644 --- a/src/compiler/generic/vm-typetran.lisp +++ b/src/compiler/generic/vm-typetran.lisp @@ -118,7 +118,7 @@ (define-type-predicate simd-pack-256-p simd-pack-256) (define-type-predicate weak-pointer-p weak-pointer) (define-type-predicate code-component-p code-component) -#-(or x86 x86-64 arm64) (define-type-predicate lra-p lra) +#-(or x86 x86-64 arm64 ppc64 ppc) (define-type-predicate lra-p lra) (define-type-predicate fdefn-p fdefn) ;;; Unlike the un-%'ed versions, these are true type predicates, ;;; accepting any type object. diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 349926fa5..6783d5fa9 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -979,7 +979,9 @@ (ir2-environment-return-pc this-env) (ir2-environment-return-pc-pass (environment-info - (lambda-environment fun))))) + (lambda-environment fun)))) + #+(or ppc ppc64) + (vop sb-vm::move-to-lr node block (ir2-environment-return-pc this-env))) (values)) @@ -1650,6 +1652,8 @@ (vop emit-label node block lab) (setf (ir2-environment-cfp-saved-pc env) lab)) + #+(or ppc ppc64) + (vop sb-vm::move-from-lr node block (ir2-environment-return-pc-pass env)) #-fp-and-pc-standard-save (emit-move node block diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index a8bd4ced3..813b599d7 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -855,7 +855,8 @@ ;; will lead to race conditions in the debugger ;; involving backtraces from asynchronous ;; interrupts. - (setf (tn-sc tn) (tn-sc save-tn)))) + (setf (tn-offset tn) (tn-offset save-tn) + (tn-sc tn) (tn-sc save-tn)))) (decf (tn-cost tn) penalty)))))) (do ((tn (ir2-component-normal-tns (component-info component)) @@ -896,7 +897,8 @@ (cond ((not (save-tn-p tn))) ((conflicts-in-sc tn (tn-sc tn) (tn-offset tn)) (sb-c::deletef-in tn-next (ir2-component-wired-tns 2comp) tn) - (setf (tn-sc tn) (tn-sc (tn-save-tn tn)))) + (setf (tn-offset tn) (tn-offset (tn-save-tn tn)) + (tn-sc tn) (tn-sc (tn-save-tn tn)))) (t (pack-wired-tn tn) (when callback @@ -922,7 +924,8 @@ ;; lead to some useless loads in some code, and ;; race conditions in the debugger involving ;; backtraces from asynchronous interrupts. - (setf (tn-sc tn) (tn-sc save-tn))))))))) + (setf (tn-offset tn) (tn-offset save-tn) + (tn-sc tn) (tn-sc save-tn))))))))) (declaim (end-block)) diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp index e89c8ccdd..f8b3cdc67 100644 --- a/src/compiler/ppc/call.lisp +++ b/src/compiler/ppc/call.lisp @@ -13,15 +13,10 @@ (defconstant arg-count-sc (make-sc+offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number lexenv-offset)) -;;; Make a passing location TN for a local call return PC. If -;;; standard is true, then use the standard (full call) location, -;;; otherwise use any legal location. Even in the non-standard case, -;;; this may be restricted by a desire to use a subroutine call -;;; instruction. +;;; Make a passing location TN for a local call return PC. (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 @@ -44,11 +39,12 @@ control-stack-arg-scn 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 @@ -118,8 +114,6 @@ (inst .skip (* (1- simple-fun-insts-offset) n-word-bytes)) (let ((entry-point (gen-label))) (emit-label entry-point) - ;; FIXME alpha port has a ### note here saying we should "save it - ;; on the stack" so that GC sees it. No idea what "it" is -dan 20020110 (inst compute-code-from-lip code-tn lip-tn entry-point temp)))) (define-vop (xep-setup-sp) @@ -225,9 +219,6 @@ default-value-8 br defaulting-done nop |# -;;; differences from alpha: (1) alpha tests for lra-label before -;;; compute-code-from-lra and skips if nil. (2) loop termination is -;;; different when clearing stack defaults (defun default-unknown-values (vop values nvals move-temp temp lra-label) (declare (type (or tn-ref null) values) @@ -238,7 +229,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 lra-tn lra-label temp)) + (inst compute-code-from-lip code-tn lra-tn lra-label temp)) (let ((regs-defaulted (gen-label)) (defaulting-done (gen-label)) (default-stack-vals (gen-label))) @@ -292,7 +283,7 @@ default-value-8 (store-stack-tn (cdr def) null-tn))) (inst b defaulting-done)))))) - (inst compute-code-from-lra code-tn lra-tn lra-label temp))) + (inst compute-code-from-lip code-tn lra-tn lra-label temp))) (values)) @@ -322,7 +313,7 @@ default-value-8 (inst b variable-values) (inst nop)) - (inst compute-code-from-lra code-tn lra-tn lra-label temp) + (inst compute-code-from-lip code-tn lra-tn lra-label temp) (inst addi csp-tn csp-tn 4) (storew (first *register-arg-tns*) csp-tn -1) (inst subi start csp-tn 4) @@ -332,7 +323,7 @@ default-value-8 (assemble (:elsewhere) (emit-label variable-values) - (inst compute-code-from-lra code-tn lra-tn lra-label temp) + (inst compute-code-from-lip code-tn lra-tn lra-label temp) (do ((arg *register-arg-tns* (rest arg)) (i 0 (1+ i))) ((null arg)) @@ -366,6 +357,15 @@ default-value-8 (emit-label trampoline-label)) (emit-label start-label)) +(define-vop (move-to-lr) + (:args (return-pc :scs (descriptor-reg))) + (:generator 0 + (inst mtlr return-pc))) + +(define-vop (move-from-lr) + (:results (return-pc :scs (descriptor-reg))) + (:generator 0 + (inst mflr return-pc))) ;;;; Local call with unknown values convention return: @@ -409,11 +409,9 @@ 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) - (emit-return-pc label) + (inst bl target) + (emit-label label) (default-unknown-values vop values nvals move-temp temp label) ;; alpha uses (maybe-load-stack-nfp-tn cur-nfp nfp-save temp) ;; instead of the clause below @@ -449,11 +447,9 @@ 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) - (emit-return-pc label) + (inst bl target) + (emit-label label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) (when cur-nfp @@ -479,7 +475,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))) @@ -489,11 +484,9 @@ 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) - (emit-return-pc label) + (inst bl target) + (emit-label label) (note-this-location vop :known-return) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -507,17 +500,18 @@ 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) + (:temporary (:scs (interior-reg)) lip) (: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 @@ -525,7 +519,7 @@ default-value-8 (- (bytes-needed-for-non-descriptor-stack-frame) number-stack-displacement)))) (move cfp-tn old-fp-temp) - (inst j return-pc-temp (- n-word-bytes other-pointer-lowtag)))) + (lisp-return lra lip))) ;;;; Full call: @@ -604,6 +598,7 @@ default-value-8 step-instrumenting) (:ignore + ,@(unless (eq return :tail) '(return-pc-pass)) ,@(unless (or variable (eq return :tail)) '(arg-locs)) ,@(unless variable '(args))) @@ -677,8 +672,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)))))) @@ -714,10 +708,7 @@ default-value-8 (inst addi 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 mr old-fp-pass cfp-tn)) @@ -806,20 +797,20 @@ default-value-8 (note-this-location vop :call-site) (inst mtctr entry-point) - ;; this following line is questionable. or else the alpha - ;; code (which doesn't do it) is questionable - ;; (inst mr code-tn function) - (inst bctr)) + ,@(if (eq return :tail) + '((inst mtlr return-pc-pass) + (inst bctr)) + '((inst bctrl)))) ,@(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) diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp index b508d37c7..5485150a2 100644 --- a/src/compiler/ppc/macros.lisp +++ b/src/compiler/ppc/macros.lisp @@ -89,8 +89,6 @@ (defmacro lisp-jump (function lip) "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." `(progn - ;; something is deeply bogus. look at this - ;; (loadw ,lip ,function function-code-offset function-pointer-type) (inst addi ,lip ,function (- (* n-word-bytes simple-fun-insts-offset) fun-pointer-lowtag)) (inst mtctr ,lip) (inst bctr))) @@ -98,18 +96,9 @@ (defmacro lisp-return (return-pc lip &key (offset 0)) "Return to RETURN-PC." `(progn - (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag)) + (inst addi ,lip ,return-pc (* ,offset 4)) (inst mtlr ,lip) (inst blr))) - -(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))) - - ;;;; Stack TN's diff --git a/src/compiler/ppc/nlx.lisp b/src/compiler/ppc/nlx.lisp index 92790352e..1f5286465 100644 --- a/src/compiler/ppc/nlx.lisp +++ b/src/compiler/ppc/nlx.lisp @@ -168,7 +168,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) @@ -222,7 +222,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))) @@ -239,7 +239,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))) @@ -276,6 +276,6 @@ (:ignore block start count) (:vop-var vop) (:generator 0 - (emit-return-pc label) + (emit-label label) (note-this-location vop :non-local-entry))) diff --git a/src/compiler/ppc64/c-call.lisp b/src/compiler/ppc64/c-call.lisp index 4c0765c53..f62de1b26 100644 --- a/src/compiler/ppc64/c-call.lisp +++ b/src/compiler/ppc64/c-call.lisp @@ -192,8 +192,9 @@ (when cur-nfp (store-stack-tn nfp-save cur-nfp)) (inst lr temp (make-fixup "call_into_c" :foreign)) - (inst mtctr temp) (move cfunc function) + (emit-alignment 3 :long-nop) + (inst mtctr temp) (inst bctrl) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) diff --git a/src/compiler/ppc64/call.lisp b/src/compiler/ppc64/call.lisp index 1c1d729d7..e90780b28 100644 --- a/src/compiler/ppc64/call.lisp +++ b/src/compiler/ppc64/call.lisp @@ -13,15 +13,10 @@ (defconstant arg-count-sc (make-sc+offset immediate-arg-scn nargs-offset)) (defconstant closure-sc (make-sc+offset descriptor-reg-sc-number lexenv-offset)) -;;; Make a passing location TN for a local call return PC. If -;;; standard is true, then use the standard (full call) location, -;;; otherwise use any legal location. Even in the non-standard case, -;;; this may be restricted by a desire to use a subroutine call -;;; instruction. +;;; Make a passing location TN for a local call return PC. (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 @@ -44,11 +39,12 @@ control-stack-arg-scn 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 @@ -118,8 +114,6 @@ (inst .skip (* (1- simple-fun-insts-offset) n-word-bytes)) (let ((entry-point (gen-label))) (emit-label entry-point) - ;; FIXME alpha port has a ### note here saying we should "save it - ;; on the stack" so that GC sees it. No idea what "it" is -dan 20020110 (inst compute-code-from-lip code-tn lip-tn entry-point temp)))) (define-vop (xep-setup-sp) @@ -225,9 +219,6 @@ default-value-8 br defaulting-done nop |# -;;; differences from alpha: (1) alpha tests for lra-label before -;;; compute-code-from-lra and skips if nil. (2) loop termination is -;;; different when clearing stack defaults (defun default-unknown-values (vop values nvals move-temp temp lra-label) (declare (type (or tn-ref null) values) @@ -236,9 +227,10 @@ default-value-8 (progn (sb-assem:without-scheduling () (note-this-location vop :single-value-return) + ;(inst isel csp-tn ocfp-tn csp-tn ) (move csp-tn ocfp-tn) (inst nop)) - (inst compute-code-from-lra code-tn lra-tn lra-label temp)) + (inst compute-code-from-lip code-tn lra-tn lra-label temp)) (let ((regs-defaulted (gen-label)) (defaulting-done (gen-label)) (default-stack-vals (gen-label))) @@ -292,7 +284,7 @@ default-value-8 (store-stack-tn (cdr def) null-tn))) (inst b defaulting-done)))))) - (inst compute-code-from-lra code-tn lra-tn lra-label temp))) + (inst compute-code-from-lip code-tn lra-tn lra-label temp))) (values)) @@ -322,7 +314,7 @@ default-value-8 (inst b variable-values) (inst nop)) - (inst compute-code-from-lra code-tn lra-tn lra-label temp) + (inst compute-code-from-lip code-tn lra-tn lra-label temp) (inst addi csp-tn csp-tn n-word-bytes) (storew (first *register-arg-tns*) csp-tn -1) (inst subi start csp-tn n-word-bytes) @@ -332,7 +324,7 @@ default-value-8 (assemble (:elsewhere) (emit-label variable-values) - (inst compute-code-from-lra code-tn lra-tn lra-label temp) + (inst compute-code-from-lip code-tn lra-tn lra-label temp) (do ((arg *register-arg-tns* (rest arg)) (i 0 (1+ i))) ((null arg)) @@ -409,17 +401,27 @@ 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) - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (inst nop) + (inst bl target) + (emit-label label) (default-unknown-values vop values nvals move-temp temp label) ;; alpha uses (maybe-load-stack-nfp-tn cur-nfp nfp-save temp) ;; instead of the clause below (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) +(define-vop (move-to-lr) + (:args (return-pc :scs (descriptor-reg))) + (:generator 0 + (inst mtlr return-pc))) + +(define-vop (move-from-lr) + (:results (return-pc :scs (descriptor-reg))) + (:generator 0 + (inst mflr return-pc))) + ;;; Non-TR local call for a variable number of return values passed according ;;; to the unknown values convention. The results are the start of the values @@ -449,11 +451,11 @@ 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) - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (inst nop) + (inst bl target) + (emit-label label) (note-this-location vop :unknown-return) (receive-unknown-values values-start nvals start count label temp) (when cur-nfp @@ -479,7 +481,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))) @@ -489,11 +490,11 @@ 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) - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (inst nop) + (inst bl target) + (emit-label label) (note-this-location vop :known-return) (when cur-nfp (load-stack-tn cur-nfp nfp-save))))) @@ -507,17 +508,18 @@ 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) + (:temporary (:scs (interior-reg)) lip) (: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 @@ -525,8 +527,7 @@ default-value-8 (- (bytes-needed-for-non-descriptor-stack-frame) number-stack-displacement)))) (move cfp-tn old-fp-temp) - ;; return to the instruction immediately following the LRA header - (inst j return-pc-temp (- n-word-bytes other-pointer-lowtag)))) + (lisp-return lra lip))) ;;;; Full call: @@ -601,6 +602,7 @@ default-value-8 step-instrumenting) (:ignore + ,@(unless (eq return :tail) '(return-pc-pass)) ,@(unless (or variable (eq return :tail)) '(arg-locs)) ,@(unless variable '(args))) @@ -668,8 +670,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 +708,7 @@ default-value-8 (inst addi 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 mr old-fp-pass cfp-tn)) @@ -771,21 +769,24 @@ default-value-8 (return))) (note-this-location vop :call-site) - (inst mtctr entry-point) - ;; this following line is questionable. or else the alpha - ;; code (which doesn't do it) is questionable - ;; (inst mr code-tn function) - (inst bctr)) + + ,@(if (eq return :tail) + '((inst mtlr return-pc-pass) + (inst mtctr entry-point) + (inst bctr)) + '((emit-alignment 3 :long-nop) + (inst mtctr entry-point) + (inst bctrl)))) ,@(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) diff --git a/src/compiler/ppc64/insts.lisp b/src/compiler/ppc64/insts.lisp index 603ce837a..be1d36d21 100644 --- a/src/compiler/ppc64/insts.lisp +++ b/src/compiler/ppc64/insts.lisp @@ -1211,6 +1211,7 @@ (:emitter (emit-d-form-inst segment 3 (valid-tcond-encoding tcond) (reg-tn-encoding ra) si))) (define-instruction isel (segment rt ra rb bc) + (:printer a ((op 31) (xo 15) (rc 0))) (:emitter (emit-a-form-inst segment 31 (reg-tn-encoding rt) @@ -2288,13 +2289,6 @@ (:delay 0) (:emitter (emit-header-data segment simple-fun-widetag))) - -(define-instruction lra-header-word (segment) - :pinned - (:delay 0) - (:emitter - (emit-header-data segment return-pc-widetag))) - ;;;; Instructions for converting between code objects, functions, and lras. (defun emit-compute-inst (segment vop dst src label temp calc) @@ -2332,22 +2326,7 @@ (label-position label posn delta-if-after) (component-header-length)))))) -;; code = lra - other-pointer-tag - header - label-offset + code-tn-lowtag -(define-instruction compute-code-from-lra (segment dst src label temp) - (:declare (type tn dst src temp) (type label label)) - (:attributes variable-length) - (:dependencies (reads src) (writes dst) (writes temp)) - (:delay 0) - (:vop-var vop) - (:emitter - (emit-compute-inst segment vop dst src label temp - #'(lambda (label posn delta-if-after) - (- code-tn-lowtag - (label-position label posn delta-if-after) - (component-header-length) - other-pointer-lowtag))))) - -;; lra = code - code-tn-lowtag + header + label-offset + other-pointer-tag +;; lra = code - code-tn-lowtag + header + label-offset (define-instruction compute-lra-from-code (segment dst src label temp) (:declare (type tn dst src temp) (type label label)) (:attributes variable-length) @@ -2359,7 +2338,6 @@ #'(lambda (label posn delta-if-after) (+ (label-position label posn delta-if-after) (component-header-length) - other-pointer-lowtag (- code-tn-lowtag)))))) ;;; Unboxed constant support @@ -2481,3 +2459,12 @@ (inst* segment 'lis temp (ldb (byte 15 16) offset)) (inst* segment 'ori temp (ldb (byte 16 16) offset)) temp)))))) + +(defun emit-long-nop (segment amount) + (declare (type sb-assem:segment segment) + (type index amount)) + (if (= amount 4) + (assemble (segment) + (inst nop)) + (loop repeat amount + do (emit-byte segment 0)))) diff --git a/src/compiler/ppc64/macros.lisp b/src/compiler/ppc64/macros.lisp index e0f0721fa..870c52780 100644 --- a/src/compiler/ppc64/macros.lisp +++ b/src/compiler/ppc64/macros.lisp @@ -84,32 +84,15 @@ ;;; Macros to handle the fact that we cannot use the machine native call and ;;; return instructions. - -(defmacro lisp-jump (function lip) - "Jump to the lisp function FUNCTION. LIP is an interior-reg temporary." - `(progn - ;; something is deeply bogus. look at this - ;; (loadw ,lip ,function function-code-offset function-pointer-type) - (inst addi ,lip ,function (- (* n-word-bytes simple-fun-insts-offset) fun-pointer-lowtag)) - (inst mtctr ,lip) - (inst bctr))) - (defmacro lisp-return (return-pc lip &key (offset 0)) "Return to RETURN-PC." `(progn - (inst addi ,lip ,return-pc - (+ (- other-pointer-lowtag) n-word-bytes (* ,offset 4))) + (inst addi ,lip ,return-pc (* ,offset 4)) (inst mtlr ,lip) + ;; (inst cmpd null-tn ,(if (zerop offset) + ;; 'csp-tn + ;; 'null-tn)) (inst blr))) - -(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))) - - ;;;; Stack TN's diff --git a/src/compiler/ppc64/nlx.lisp b/src/compiler/ppc64/nlx.lisp index 22b76ffde..24378ac14 100644 --- a/src/compiler/ppc64/nlx.lisp +++ b/src/compiler/ppc64/nlx.lisp @@ -168,7 +168,8 @@ (:save-p :force-to-stack) (:vop-var vop) (:generator 30 - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (emit-label label) (note-this-location vop :non-local-entry) (cond ((zerop nvals)) ((= nvals 1) @@ -222,7 +223,8 @@ (:save-p :force-to-stack) (:vop-var vop) (:generator 30 - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (emit-label label) (note-this-location vop :non-local-entry) (move res value) (load-stack-tn csp-tn sp))) @@ -239,7 +241,8 @@ (:save-p :force-to-stack) (:vop-var vop) (:generator 30 - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (emit-label label) (note-this-location vop :non-local-entry) ;; Setup results, and test for the zero value case. @@ -276,6 +279,6 @@ (:ignore block start count) (:vop-var vop) (:generator 0 - (emit-return-pc label) + (emit-alignment 3 :long-nop) + (emit-label label) (note-this-location vop :non-local-entry))) - diff --git a/src/compiler/ppc64/show.lisp b/src/compiler/ppc64/show.lisp index 6486c42f0..1baf8d708 100644 --- a/src/compiler/ppc64/show.lisp +++ b/src/compiler/ppc64/show.lisp @@ -35,8 +35,9 @@ (move nl0 object) (inst lr temp (make-fixup "call_into_c" :foreign)) (inst mr lip temp) - (inst mtctr lip) (inst lr cfunc (make-fixup "debug_print" :foreign)) + (emit-alignment 3 :long-nop) + (inst mtctr lip) (inst bctrl) (when cur-nfp (load-stack-tn cur-nfp nfp-save)) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 4d47956df..81ae01d35 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -355,7 +355,7 @@ (type alignment size)) (zerop (logand (1- size) address))) -#-(or x86 x86-64 arm64 riscv loongarch64) +#-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) (progn (defconstant lra-size (words-to-bytes 1)) (defun lra-hook (chunk stream dstate) @@ -1381,7 +1381,7 @@ (format stream "#X~2,'0x" (sap-ref-8 sap (+ offs start-offs)))))) (defvar *default-dstate-hooks* - (list* #-(or x86 x86-64 arm64 riscv loongarch64) #'lra-hook nil)) + (list* #-(or x86 x86-64 arm64 riscv loongarch64 ppc64 ppc) #'lra-hook nil)) ;;; Make a disassembler-state object. (defun make-dstate (&optional (fun-hooks *default-dstate-hooks*)) diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 91695ff72..1b3bede9a 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -600,7 +600,15 @@ (sc-name sc))) (when (and (not (sc-save-p alt)) (eq (sb-kind (sc-sb alt)) :unbounded)) - (setf (tn-sc tn) alt) + (cond #-fp-and-pc-standard-save + ((let ((save-tn (tn-save-tn tn))) + (when (and save-tn (eq (tn-kind save-tn) :specified-save)) + (setf (tn-offset tn) (tn-offset save-tn) + (tn-sc tn) (tn-sc save-tn)) + t))) + (t + (setf (tn-sc tn) alt))) + (return))))) (values)) diff --git a/src/runtime/backtrace.c b/src/runtime/backtrace.c index 6da31b986..d1465a48e 100644 --- a/src/runtime/backtrace.c +++ b/src/runtime/backtrace.c @@ -505,12 +505,12 @@ int lisp_frame_previous(struct thread *thread, struct call_info *info) } } else if (fixnump(lra)) { info->code = -#ifdef reg_CODE +#if defined reg_CODE && !(defined(LISP_FEATURE_PPC64) || defined(LISP_FEATURE_PPC)) (struct code*)native_pointer(this_frame->code); #else (struct code*)component_ptr_from_pc((char *)lra); #endif -#ifdef reg_LRA +#if defined reg_LRA && !(defined(LISP_FEATURE_PPC64) || defined(LISP_FEATURE_PPC)) info->pc = lra; #else info->pc = (char*)native_pointer(lra) - (char*)info->code; diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 9f0d278ee..cc529ef00 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -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 +#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 +#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. * @@ -2063,16 +2063,18 @@ static void NO_SANITIZE_MEMORY preserve_pointer(os_context_register_t word, void lispobj* found = search_dynamic_space((void*)word); if (found) gc_mark_obj(compute_lispobj(found)); } -#ifdef LISP_FEATURE_SOFT_CARD_MARKS + static void sticky_preserve_pointer(os_context_register_t register_word, void* arg) { // registers can be wider than words. This could accept uword_t as the arg type // but I like it to be directly callable with os_context_register. uword_t word = register_word; +#ifdef LISP_FEATURE_SOFT_CARD_MARKS if (is_lisp_pointer(word)) impart_mark_stickiness(word); +#endif preserve_pointer(word, arg); } -#endif + #endif /* Pin an unambiguous descriptor object which may or may not be a pointer. @@ -3047,7 +3049,7 @@ static void __attribute__((unused)) maybe_pin_code(lispobj addr) { } #endif -#if defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 +#if defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC static void semiconservative_pin_stack(struct thread* th, generation_index_t gen) { /* Stack can only pin code, since it contains return addresses. @@ -3071,7 +3073,7 @@ static void semiconservative_pin_stack(struct thread* th, if (gen == 0) sticky_preserve_pointer(word, (void*)1); else preserve_pointer(word, (void*)1); } -#elif defined LISP_FEATURE_PPC64 +#elif defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC static int boxed_registers[] = BOXED_REGISTERS; for (j = (int)(sizeof boxed_registers / sizeof boxed_registers[0])-1; j >= 0; --j) { lispobj word = *os_context_register_addr(context, boxed_registers[j]); @@ -3429,7 +3431,7 @@ garbage_collect_generation(generation_index_t generation, int raise, * sticky card mark on any page (in any generation) * referenced from the stack. */ conservative_stack_scan(th, generation, cur_thread_approx_stackptr); -#elif defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 +#elif defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC // Pin code if needed semiconservative_pin_stack(th, generation); #elif defined reg_LINK_RETURN @@ -3511,7 +3513,8 @@ garbage_collect_generation(generation_index_t generation, int raise, if (conservative_stack) { struct thread *th; for_each_thread(th) { -#if !defined(LISP_FEATURE_MIPS) && !defined(reg_LINK_RETURN) // interrupt contexts already pinned everything they see +#if !defined(LISP_FEATURE_MIPS) && !defined(reg_LINK_RETURN) \ + && !defined(LISP_FEATURE_PPC) && !defined(LISP_FEATURE_PPC64) // interrupt contexts already pinned everything they see scavenge_interrupt_contexts(th); #endif scavenge_control_stack(th); diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index d83312266..4292d1f5d 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -782,6 +782,23 @@ 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 +static void +build_fake_control_stack_frames(struct thread *th, os_context_t *context) +{ + lispobj* csp = (lispobj *)(*os_context_register_addr(context, reg_CSP)); + lispobj cfp = (lispobj)(*os_context_register_addr(context, reg_CFP)); + access_control_frame_pointer(th) = csp; + +#ifdef LISP_FEATURE_PPC64 + access_control_frame_pointer(th)[1] = ALIGN_DOWN(os_context_pc(context), 16); +#else + access_control_frame_pointer(th)[1] = os_context_pc(context); +#endif + + access_control_frame_pointer(th)[0] = cfp; + access_control_stack_pointer(th) = csp; +} #else static void build_fake_control_stack_frames(struct thread __attribute__((unused)) *th, diff --git a/src/runtime/pmrgc.c b/src/runtime/pmrgc.c index 89951003a..73cefdeca 100644 --- a/src/runtime/pmrgc.c +++ b/src/runtime/pmrgc.c @@ -421,7 +421,7 @@ static void impart_mark_stickiness(lispobj word) } } -#if !GENCGC_IS_PRECISE || defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 +#if !GENCGC_IS_PRECISE || defined LISP_FEATURE_MIPS || defined LISP_FEATURE_PPC64 || defined LISP_FEATURE_PPC static void preserve_pointer(os_context_register_t object, __attribute__((unused)) void* arg) { /* The mark-region GC never filters based on type tags, @@ -456,7 +456,9 @@ static void preserve_pointer(os_context_register_t object, static void sticky_preserve_pointer(os_context_register_t register_word, void* arg) { uword_t word = register_word; +#ifdef LISP_FEATURE_SOFT_CARD_MARKS if (is_lisp_pointer(word)) impart_mark_stickiness(word); +#endif preserve_pointer(word, arg); } #endif diff --git a/src/runtime/ppc-assem.S b/src/runtime/ppc-assem.S index 941d76fa2..86f08d1c8 100644 --- a/src/runtime/ppc-assem.S +++ b/src/runtime/ppc-assem.S @@ -410,26 +410,12 @@ x: lwz reg_A2,8(reg_CFP) lwz reg_A3,12(reg_CFP) - /* Calculate LRA */ -#ifdef LISP_FEATURE_DARWIN - lis reg_LRA,ha16(lra) - addi reg_LRA,reg_LRA,lo16(lra) -#else - lis reg_LRA,lra@h - ori reg_LRA,reg_LRA,lra@l -#endif - addi reg_LRA,reg_LRA,OTHER_POINTER_LOWTAG - /* Function is an indirect closure */ lwz reg_CODE,SIMPLE_FUN_SELF_OFFSET(reg_LEXENV) addi reg_LIP,reg_CODE,SIMPLE_FUN_INSTS_OFFSET mtctr reg_LIP slwi reg_NARGS,reg_NL2,2 - bctr - - .align 3 -lra: - .long RETURN_PC_WIDETAG + bctrl /* Blow off any extra values. */ mr reg_CSP,reg_OCFP @@ -484,6 +470,7 @@ lra: mr reg_CFP,reg_CSP la reg_CSP,32(reg_CSP) stw reg_OCFP,0(reg_CFP) + stw reg_LIP,4(reg_CFP) stw reg_CODE,8(reg_CFP) /* The pseudo-atomic mechanism wants to use reg_NL3, but that may be an outgoing C argument. Copy reg_NL3 to something that's @@ -493,11 +480,6 @@ lra: /* Turn on pseudo-atomic */ BEGIN_PSEUDO_ATOMIC - /* Convert the return address to an offset and save it on the stack. */ - sub reg_NFP,reg_LIP,reg_CODE - la reg_NFP,OTHER_POINTER_LOWTAG(reg_NFP) - stw reg_NFP,4(reg_CFP) - #ifdef LISP_FEATURE_SB_THREAD /* Store Lisp state */ stw reg_BSP,THREAD_BINDING_STACK_POINTER_OFFSET(reg_THREAD) @@ -586,8 +568,6 @@ lra: /* Get the return address back. */ lwz reg_LIP,4(reg_CFP) lwz reg_CODE,8(reg_CFP) - add reg_LIP,reg_CODE,reg_LIP - la reg_LIP,-OTHER_POINTER_LOWTAG(reg_LIP) /* Debugger expects LR to be valid when we come out of PA */ mtlr reg_LIP diff --git a/src/runtime/ppc64-assem.S b/src/runtime/ppc64-assem.S index b57bfe88e..59d6b63d1 100644 --- a/src/runtime/ppc64-assem.S +++ b/src/runtime/ppc64-assem.S @@ -169,22 +169,15 @@ Low Address /* load gc_card_mark */ ld reg_CARDTABLE, (-LIST_POINTER_LOWTAG-16)(reg_NULL) - /* Calculate LRA */ - lis reg_LRA,lra@h - ori reg_LRA,reg_LRA,lra@l - addi reg_LRA,reg_LRA,OTHER_POINTER_LOWTAG - /* Function is an indirect closure */ addi reg_NL0,reg_LEXENV,SIMPLE_FUN_SELF_OFFSET ld reg_CODE,0(reg_NL0) addi reg_LIP,reg_CODE,0 - mtctr reg_LIP sldi reg_NARGS, reg_NL2, N_FIXNUM_TAG_BITS - bctr - .align 3 -lra: - .quad RETURN_PC_WIDETAG + .p2align 3,,0x60000000 + mtctr reg_LIP + bctrl /* Blow off any extra values. */ mr reg_CSP,reg_OCFP @@ -238,6 +231,7 @@ lra: mr reg_CFP,reg_CSP la reg_CSP,32(reg_CSP) std reg_OCFP,0(reg_CFP) + std reg_LIP,8(reg_CFP) std reg_CODE,16(reg_CFP) /* The pseudo-atomic mechanism wants to use reg_NL3, but that may be an outgoing C argument. Copy reg_NL3 to something that's @@ -247,13 +241,6 @@ lra: /* Turn on pseudo-atomic */ BEGIN_PSEUDO_ATOMIC - /* Convert the return address to an offset and save it on the stack. */ - sub reg_NFP,reg_LIP,reg_CODE -#if N_FIXNUM_TAG_BITS == 3 - sldi reg_NFP,reg_NFP,1 -#endif - std reg_NFP,8(reg_CFP) - /* Store Lisp state */ std reg_BSP,THREAD_BINDING_STACK_POINTER_OFFSET(reg_THREAD) std reg_CSP,THREAD_CONTROL_STACK_POINTER_OFFSET(reg_THREAD) @@ -331,11 +318,7 @@ lra: /* Get the return address back. */ ld reg_LIP,8(reg_CFP) -#if N_FIXNUM_TAG_BITS == 3 - srdi reg_LIP,reg_LIP,1 -#endif ld reg_CODE,16(reg_CFP) - add reg_LIP,reg_CODE,reg_LIP /* Debugger expects LR to be valid when we come out of PA */ mtlr reg_LIP diff --git a/tests/backtrace.impure.lisp b/tests/backtrace.impure.lisp index e44bb7c3b..a1473bc93 100644 --- a/tests/backtrace.impure.lisp +++ b/tests/backtrace.impure.lisp @@ -263,7 +263,7 @@ (defun throw-test () (throw 'no-such-tag t)) (with-test (:name (:backtrace :throw :no-such-tag) - :fails-on (or :mips :ppc :ppc64 :riscv (and :sparc :linux))) + :fails-on (or :mips :ppc :riscv (and :sparc :linux))) (assert-backtrace #'throw-test '((throw-test)))) (funcall (checked-compile @@ -276,7 +276,7 @@ (bar x) (bar v))))) :allow-style-warnings t)) -(with-test (:name (:backtrace :bug-308926) :skipped-on :interpreter) +(with-test (:name (:backtrace :bug-308926) :skipped-on :interpreter :fails-on (:or :ppc :ppc64)) (assert-backtrace (lambda () (bug-308926 13)) '(((flet bar :in bug-308926) 13) (bug-308926 &rest t)))) diff --git a/tests/compare-and-swap.impure.lisp b/tests/compare-and-swap.impure.lisp index 1944d9ce4..289d771ef 100644 --- a/tests/compare-and-swap.impure.lisp +++ b/tests/compare-and-swap.impure.lisp @@ -628,7 +628,8 @@ (format t "Double-width compare-and-swap NOT TESTED~%"))) (test-util:with-test (:name :cas-sap-ref-smoke-test - :skipped-on (not :sb-thread)) + :skipped-on (not :sb-thread) + :broken-on :ppc) (let ((data (make-array 1 :element-type 'sb-vm:word))) (sb-sys:with-pinned-objects (data) (let ((sap (sb-sys:vector-sap data))) diff --git a/tests/compiler-ir.pure.lisp b/tests/compiler-ir.pure.lisp index 0fe575489..0ec8660dd 100644 --- a/tests/compiler-ir.pure.lisp +++ b/tests/compiler-ir.pure.lisp @@ -480,7 +480,7 @@ 1))) (with-test (:name :sign-extend - :fails-on (or :riscv :loongarch64)) + :fails-on (or :ppc :riscv :loongarch64)) (assert (= (count 'sb-c::mask-signed-field (ir-calls `(lambda (a) @@ -541,7 +541,8 @@ (assert (not (ir-full-calls `(lambda (x) (logbitp 0 (+ x 3))))))) -(with-test (:name :modarith-unknown-types) +(with-test (:name :modarith-unknown-types + :fails-on :ppc) (assert (not (ir-full-calls `(lambda (x) (logand (+ x 10) 20))))) (assert (not (ir-full-calls `(lambda (m x) diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp index 72ecf8ca0..77cc01a7f 100644 --- a/tests/debug.impure.lisp +++ b/tests/debug.impure.lisp @@ -1333,8 +1333,8 @@ ;; 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 arm64 riscv loongarch64) = - #-(or x86 x86-64 arm64 riscv loongarch64) > + (assert (#+(or x86 x86-64 arm64 riscv loongarch64 ppc ppc64) = + #-(or x86 x86-64 arm64 riscv loongarch64 ppc ppc64) > (loop for ptr from (+ base (* 2 sb-vm:n-word-bytes)) below limit count (properly-tagged-p ptr)) n)) diff --git a/xperfecthash30.lisp-expr b/xperfecthash30.lisp-expr index 8aff84f9e..3b4cd38a0 100644 --- a/xperfecthash30.lisp-expr +++ b/xperfecthash30.lisp-expr @@ -644,6 +644,9 @@ (let ((b (& val #x7))) (let ((a (>> (<< val 3) 29))) (^ a (aref tab b))))))") +(#(22301E9 806FCD7 DDACDA4 14AB411F) + "(SB-VM::UNDEFINED-TRAMP SB-VM::UNDEFINED-ALIEN-TRAMP SB-VM::RETURN-VALUES-LIST SB-VM::CALL-SYMBOL)" + "((& (>> val 3) 3))") (#(2272EB9 2D83FFB 4F39EEA D4575D9 152FF428 1812BD4D 1B8B3DFE) "(:ALLOW-OTHER-KEYS :SLOTS :VARIABLE-LENGTH-P :LENGTH :LOWTAG :WIDETAG :NAME)" "((& (>> val 19) 7))") @@ -1352,6 +1355,9 @@ (#(91ED00E A697378 10FA655D 12B87111 1750C880 1AB41F21) "(SB-C:RETURN-SINGLE RETURN SB-C:KNOWN-RETURN SB-C:TAIL-CALL SB-C:TAIL-CALL-NAMED SB-C:STATIC-TAIL-CALL-NAMED)" "((& (- (>> val 2) (>> val 13)) 7))") +(#(92447CE DB121C2 102153B3 105D4415 13D924E0) + "(NIL :LOAD-FP :SAVE-FP :FROB-NFP :LOAD-NARGS)" + "((& (^ (>> val 5) (>> val 19)) 7))") (#(92447CE DB121C2 102153B3 105D4415 13D924E0 1EE57DB1) "(NIL :LOAD-FP :SAVE-FP :FROB-NFP :COMP-LRA :LOAD-NARGS)" "((& (^ (>> val 4) (>> val 21)) 7))") diff --git a/xperfecthash61.lisp-expr b/xperfecthash61.lisp-expr index bdc8ff494..1102a42be 100644 --- a/xperfecthash61.lisp-expr +++ b/xperfecthash61.lisp-expr @@ -42,6 +42,9 @@ (#(0 DB121C2 53D924E0 9EE57DB1 B05D4415 C92447CE) "(NIL :LOAD-FP :SAVE-FP :FROB-NFP :COMP-LRA :LOAD-NARGS)" "((& (+ (>> val 3) (>> val 4)) 7))") +(#(0 DB121C2 53D924E0 B05D4415 C92447CE) + "(NIL :LOAD-FP :SAVE-FP :FROB-NFP :LOAD-NARGS)" + "((& (+ (>> val 2) (>> val 27)) 7))") (#(0 120FC1D0 2C444648 488BF057 97EE124C AD4575D9 EBD01872) "(:VERSION :TYPE :NAME :DIRECTORY :DEVICE :HOST NIL)" "((& (+ (>> val 5) (>> val 12)) 7))") @@ -1316,6 +1319,9 @@ (let ((b (& val #x7))) (let ((a (>> val 29))) (^ a (aref tab b))))))") +(#(822301E9 94AB411F A806FCD7 EDDACDA4) + "(SB-VM::UNDEFINED-TRAMP SB-VM::UNDEFINED-ALIEN-TRAMP SB-VM::RETURN-VALUES-LIST SB-VM::CALL-SYMBOL)" + "((& (>> val 3) 3))") (#(831D9492 952EFA09 9DFD6B68 DC33E6FC) "#(:LT :GT :EQ :SO)" "((& (>> val 4) 3))") diff --git a/xperfecthash63.lisp-expr b/xperfecthash63.lisp-expr index c95c99ae5..6a239cd15 100644 --- a/xperfecthash63.lisp-expr +++ b/xperfecthash63.lisp-expr @@ -1273,6 +1273,9 @@ (#(35455F60 4E3391D6 5256235A 6AC11619 A37EFB8E A7D5BCEA) "(SB-VM::NOISE SB-VM::IMMEDIATE-CONSTANT CONSTANT SB-VM::STACK SB-VM::FLOAT-REGISTERS SB-VM::REGISTERS)" "((& (>> val 26) 7))") +(#(359CB801 4D28C61A 53351B33 A2DD0906 B9B79FF6) + "(FUNCTION SB-IMPL::PREDICATE SB-IMPL::KEY SB-IMPL::TEST SB-IMPL::TEST-NOT)" + "((& (^ (>> val 3) (>> val 6)) 7))") (#(359CB801 5DAB18D0 625827B9 7D5DAB1C BF38ADF8 C2B3EDA3 C7436840 D2821F1C E391E233 EBD01872 F1F25102) "(:PURE :INITIAL-OFFSET :NAMED :TYPE :PRINT-OBJECT :PRINT-FUNCTION :INCLUDE :PREDICATE :COPIER :CONSTRUCTOR :CONC-NAME)" "((let ((tab #a((8) (unsigned-byte 8) 0 5 8 11 4 1 0 5)))