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

ppc32, ppc64: remove LRA

Browse source 
TODO:
put return-pc-passing-location into the LR special register.
flag-based multiple value returns.
This commit is contained in:
Stas Boukarev 2026-02-27 01:02:06 +03:00
parent b75e1fa8c6
commit 2cfca0fa32
45 changed files with 285 additions and 292 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/assembly/ppc/arith.lisp
View file

@ -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-/=)

8
src/assembly/ppc/assem-rtns.lisp
View file

@ -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))

10
src/assembly/ppc/support.lisp
View file

@ -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)))

3
src/assembly/ppc/tramps.lisp
View file

@ -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))

5
src/assembly/ppc64/arith.lisp
View file

@ -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

7
src/assembly/ppc64/assem-rtns.lisp
View file

@ -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.

13
src/assembly/ppc64/support.lisp
View file

@ -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)))

5
src/assembly/ppc64/tramps.lisp
View file

@ -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.

4
src/code/class.lisp
View file

@ -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.

43
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 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

2
src/code/gc.lisp
View file

@ -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)

2
src/code/pred.lisp
View file

@ -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)

2
src/code/print.lisp
View file

@ -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)))

2
src/code/stubs.lisp
View file

@ -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))

2
src/compiler/assem.lisp
View file

@ -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))

4
src/compiler/generic/early-objdef.lisp
View file

@ -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

2
src/compiler/generic/late-objdef.lisp
View file

@ -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")

2
src/compiler/generic/type-vops.lisp
View file

@ -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))

2
src/compiler/generic/vm-typetran.lisp
View file

@ -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.

6
src/compiler/ir2tran.lisp
View file

@ -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

9
src/compiler/pack.lisp
View file

@ -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))

93
src/compiler/ppc/call.lisp
View file

@ -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)

13
src/compiler/ppc/macros.lisp
View file

@ -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

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

@ -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)))

3
src/compiler/ppc64/c-call.lisp
View file

@ -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)))))

107
src/compiler/ppc64/call.lisp
View file

@ -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)

35
src/compiler/ppc64/insts.lisp
View file

@ -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))))

25
src/compiler/ppc64/macros.lisp
View file

@ -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

13
src/compiler/ppc64/nlx.lisp
View file

@ -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)))

3
src/compiler/ppc64/show.lisp
View file

@ -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))

4
src/compiler/target-disassem.lisp
View file

@ -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*))

10
src/compiler/tn.lisp
View file

@ -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))

4
src/runtime/backtrace.c
View file

@ -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;

19
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
#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);

17
src/runtime/interrupt.c
View file

@ -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,

4
src/runtime/pmrgc.c
View file

@ -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

24
src/runtime/ppc-assem.S
View file

@ -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

25
src/runtime/ppc64-assem.S
View file

@ -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

4
tests/backtrace.impure.lisp
View file

@ -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))))

3
tests/compare-and-swap.impure.lisp
View file

@ -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)))

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

@ -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)

4
tests/debug.impure.lisp
View file

@ -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))

6
xperfecthash30.lisp-expr
View file

@ -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))")

6
xperfecthash61.lisp-expr
View file

@ -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))")

3
xperfecthash63.lisp-expr
View file

@ -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)))