1.0.41.23: ppc: Calling-convention fixes for LRA handling during return.

  * For GC purposes, seven times never clobber reg_CODE while still
within a component.

  * During return processing, store the LRA in reg_LRA instead of
reg_CODE (see previous point).

  * During fun end breakpoint processing, use reg_LRA instead of
reg_CODE to store the LRA object on ppc.

  * The upshot of this is that, during returns, the program counter
and link register can always be found within the body of reg_CODE
or reg_LRA, no matter which side of the blr instruction we check,
thus always allowing the GC to correctly update them.

diff --git a/src/assembly/ppc/assem-rtns.lisp b/src/assembly/ppc/assem-rtns.lisp
index b0b7057..d6201a7 100644 (file)
--- a/src/assembly/ppc/assem-rtns.lisp
+++ b/src/assembly/ppc/assem-rtns.lisp
@@ -169,7 +169,7 @@
   (loadw cfp-tn cur-uwp unwind-block-current-cont-slot)
   (loadw code-tn cur-uwp unwind-block-current-code-slot)
   (loadw lra cur-uwp unwind-block-entry-pc-slot)
-  (lisp-return lra lip :frob-code nil)
+  (lisp-return lra lip)
 
   DO-UWP
 

diff --git a/src/assembly/ppc/support.lisp b/src/assembly/ppc/support.lisp
index 6b60e61..a6d9cfc 100644 (file)
--- a/src/assembly/ppc/support.lisp
+++ b/src/assembly/ppc/support.lisp
@@ -40,7 +40,7 @@
             (without-scheduling ()
               (move csp-tn ocfp-tn)
               (inst nop))
-            (inst compute-code-from-lra code-tn code-tn
+            (inst compute-code-from-lra code-tn lra-tn
                   lra-label ,temp)
             (when cur-nfp
               (load-stack-tn cur-nfp ,nfp-save))))

diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp
index b490dee..229a078 100644 (file)
--- a/src/compiler/ppc/call.lisp
+++ b/src/compiler/ppc/call.lisp
@@ -258,7 +258,7 @@ default-value-8
           (note-this-location vop :single-value-return)
           (move csp-tn ocfp-tn)
           (inst nop))
-        (inst compute-code-from-lra code-tn code-tn lra-label temp))
+        (inst compute-code-from-lra code-tn lra-tn lra-label temp))
       (let ((regs-defaulted (gen-label))
             (defaulting-done (gen-label))
             (default-stack-vals (gen-label)))
@@ -314,7 +314,7 @@ default-value-8
                   (inst b defaulting-done)
                   (trace-table-entry trace-table-normal))))))
 
-        (inst compute-code-from-lra code-tn code-tn lra-label temp)))
+        (inst compute-code-from-lra code-tn lra-tn lra-label temp)))
   (values))
 
 \f
@@ -344,7 +344,7 @@ default-value-8
       (inst b variable-values)
       (inst nop))
 
-    (inst compute-code-from-lra code-tn code-tn lra-label temp)
+    (inst compute-code-from-lra code-tn lra-tn lra-label temp)
     (inst addi csp-tn csp-tn 4)
     (storew (first *register-arg-tns*) csp-tn -1)
     (inst subi start csp-tn 4)
@@ -355,7 +355,7 @@ default-value-8
     (assemble (*elsewhere*)
       (trace-table-entry trace-table-fun-prologue)
       (emit-label variable-values)
-      (inst compute-code-from-lra code-tn code-tn lra-label temp)
+      (inst compute-code-from-lra code-tn lra-tn lra-label temp)
       (do ((arg *register-arg-tns* (rest arg))
            (i 0 (1+ i)))
           ((null arg))
@@ -882,14 +882,16 @@ default-value-8
 
 ;;; Return a single value using the unknown-values convention.
 (define-vop (return-single)
-  (:args (old-fp :scs (any-reg))
-         (return-pc :scs (descriptor-reg))
+  (:args (old-fp :scs (any-reg) :to :eval)
+         (return-pc :scs (descriptor-reg) :target lra)
          (value))
   (:ignore value)
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
   (:temporary (:scs (interior-reg)) lip)
   (:vop-var vop)
   (:generator 6
     (trace-table-entry trace-table-fun-epilogue)
+    (move lra return-pc)
     ;; Clear the number stack.
     (let ((cur-nfp (current-nfp-tn vop)))
       (when cur-nfp
@@ -900,7 +902,7 @@ default-value-8
     (move csp-tn cfp-tn)
     (move cfp-tn old-fp)
     ;; Out of here.
-    (lisp-return return-pc lip :offset 2)
+    (lisp-return lra lip :offset 2)
     (trace-table-entry trace-table-normal)))
 
 ;;; Do unknown-values return of a fixed number of values.  The Values are
@@ -918,7 +920,7 @@ default-value-8
 (define-vop (return)
   (:args
    (old-fp :scs (any-reg))
-   (return-pc :scs (descriptor-reg) :to (:eval 1))
+   (return-pc :scs (descriptor-reg) :to (:eval 1) :target lra)
    (values :more t))
   (:ignore values)
   (:info nvals)
@@ -926,12 +928,14 @@ default-value-8
   (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
   (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
   (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
+  (:temporary (:sc descriptor-reg :offset lra-offset :from (:eval 1)) lra)
   (:temporary (:sc any-reg :offset nargs-offset) nargs)
   (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
   (:temporary (:scs (interior-reg)) lip)
   (:vop-var vop)
   (:generator 6
     (trace-table-entry trace-table-fun-epilogue)
+    (move lra return-pc)
     ;; Clear the number stack.
     (let ((cur-nfp (current-nfp-tn vop)))
       (when cur-nfp
@@ -943,7 +947,7 @@ default-value-8
            (move csp-tn cfp-tn)
            (move cfp-tn old-fp)
            ;; Out of here.
-           (lisp-return return-pc lip :offset 2))
+           (lisp-return lra lip :offset 2))
           (t
            ;; Establish the values pointer and values count.
            (move val-ptr cfp-tn)
@@ -957,7 +961,7 @@ default-value-8
              (dolist (reg (subseq (list a0 a1 a2 a3) nvals))
                (move reg null-tn)))
            ;; And away we go.
-           (lisp-return return-pc lip)))
+           (lisp-return lra lip)))
     (trace-table-entry trace-table-normal)))
 
 ;;; Do unknown-values return of an arbitrary number of values (passed
@@ -981,6 +985,7 @@ default-value-8
   (:vop-var vop)
   (:generator 13
     (trace-table-entry trace-table-fun-epilogue)
+    (move lra lra-arg)
     (let ((not-single (gen-label)))
       ;; Clear the number stack.
       (let ((cur-nfp (current-nfp-tn vop)))
@@ -999,7 +1004,6 @@ default-value-8
       ;; Nope, not the single case.
       (emit-label not-single)
       (move old-fp old-fp-arg)
-      (move lra lra-arg)
       (move vals vals-arg)
       (move nvals nvals-arg)
       (inst lr temp (make-fixup 'return-multiple :assembly-routine))

diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
index e8de508..8b70474 100644 (file)
--- a/src/compiler/ppc/macros.lisp
+++ b/src/compiler/ppc/macros.lisp
@@ -79,16 +79,13 @@
     ;; (loadw ,lip ,function function-code-offset function-pointer-type)
     (inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag))
     (inst mtctr ,lip)
-    (move code-tn ,function)
     (inst bctr)))
 
-(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+(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 mtlr ,lip)
-     ,@(if frob-code
-         `((move code-tn ,return-pc)))
      (inst blr)))
 
 (defmacro emit-return-pc (label)

diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp
index e31f474..e20d141 100644 (file)
--- a/src/compiler/ppc/vm.lisp
+++ b/src/compiler/ppc/vm.lisp
@@ -261,6 +261,7 @@
   (defregtn null descriptor-reg)
   (defregtn code descriptor-reg)
   (defregtn alloc any-reg)
+  (defregtn lra descriptor-reg)
 
   (defregtn nargs any-reg)
   (defregtn bsp any-reg)

diff --git a/src/runtime/breakpoint.c b/src/runtime/breakpoint.c
index 45639c4..a325693 100644 (file)
--- a/src/runtime/breakpoint.c
+++ b/src/runtime/breakpoint.c
@@ -173,10 +173,17 @@ void *handle_fun_end_breakpoint(os_context_t *context)
 
     lra = codeptr->constants[REAL_LRA_SLOT];
 
+#ifdef LISP_FEATURE_PPC
+    /* PPC now passes LRA objects in reg_LRA during return.  Other
+     * platforms should as well, but haven't been fixed yet. */
+    if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
+        *os_context_register_addr(context, reg_LRA) = lra;
+#else
 #ifdef reg_CODE
     if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL)
         *os_context_register_addr(context, reg_CODE) = lra;
 #endif
+#endif
 
     undo_fake_foreign_function_call(context);
 

diff --git a/src/runtime/ppc-assem.S b/src/runtime/ppc-assem.S
index 13175df..318d576 100644 (file)
--- a/src/runtime/ppc-assem.S
+++ b/src/runtime/ppc-assem.S
@@ -601,14 +601,14 @@ CSYMBOL(funcallable_instance_tramp) = . + 1
 
        /* Compute the correct value for reg_CODE based on the LRA.
        This is a "simple" matter of subtracting a constant from
-       reg_CODE (where the LRA is stored by the return sequence) to
+       reg_LRA (where the LRA is stored by the return sequence) to
        obtain a tagged pointer to the enclosing code component.  Both
        values are tagged OTHER_POINTER_LOWTAG, so we just have to
        account for the eight words (see calculation for
        RETURN_PC_HEADER_WIDETAG, above) between the two addresses.
        Restoring reg_CODE doesn't appear to be strictly necessary
        here, but let's observe the niceties.*/
-       addi reg_CODE, reg_CODE, -32
+       addi reg_CODE, reg_LRA, -32
 
        /* Multiple values are stored relative to reg_OCFP, which we
        set to be the current top-of-stack. */
@@ -631,7 +631,7 @@ CSYMBOL(funcallable_instance_tramp) = . + 1
 fun_end_breakpoint_multiple_values:
        /* Compute the correct value for reg_CODE.  See the
        explanation for the single-value case, above. */
-       addi reg_CODE, reg_CODE, -32
+       addi reg_CODE, reg_LRA, -32
 
        /* The actual magic trap. */
 CSYMBOL(fun_end_breakpoint_trap):

diff --git a/version.lisp-expr b/version.lisp-expr
index 5d28a90..f356232 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.41.22"
+"1.0.41.23"