[commit: ghc] wip/dwarf-bindists, wip/pare-down-ci, wip/std-hdr-llf, wip/test-hadrian-caching, wip/validate-ci, wip/zip7-fusion: Fix two bugs in stg_ap_0_fast in profiling runtime (908b4b8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branches: wip/dwarf-bindists,wip/pare-down-ci,wip/std-hdr-llf,wip/test-hadrian-caching,wip/validate-ci,wip/zip7-fusion
Link       : http://ghc.haskell.org/trac/ghc/changeset/908b4b8659713f0b7a1704ce33c7fa30e3e0ffc3/ghc

>---------------------------------------------------------------

commit 908b4b8659713f0b7a1704ce33c7fa30e3e0ffc3
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date:   Fri Jan 18 22:35:37 2019 +0300

    Fix two bugs in stg_ap_0_fast in profiling runtime
    
    This includes two bug fixes in profiling version of stg_ap_0_fast:
    
    - PAPs allocated by stg_ap_0_fast are now correctly tagged. This
      invariant is checked in Sanity.c:checkPAP.
    
      (This was originally implemented in 2693eb11f5, later reverted with
      ab55b4ddb7 because it revealed the bug below, but it wasn't clear at
      the time whether the bug was the one below or something in the commit)
    
    - The local variable `untaggedfun` is now marked as a pointer so it
      survives GC.
    
    With this we finally fix all known bugs caught in #15508. `concprog001`
    now works reliably with prof+threaded and prof runtimes (with and
    without -debug).


>---------------------------------------------------------------

908b4b8659713f0b7a1704ce33c7fa30e3e0ffc3
 rts/Apply.cmm | 18 +++++++++++-------
 1 file changed, 11 insertions(+), 7 deletions(-)

diff --git a/rts/Apply.cmm b/rts/Apply.cmm
index 40f890d..0454fd6 100644
--- a/rts/Apply.cmm
+++ b/rts/Apply.cmm
@@ -60,7 +60,7 @@ stg_ap_0_fast ( P_ fun )
 
 again:
     W_  info;
-    W_ untaggedfun;
+    P_ untaggedfun;
     W_ arity;
     untaggedfun = UNTAG(fun);
     info = %INFO_PTR(untaggedfun);
@@ -106,6 +106,11 @@ again:
                 pap = Hp - SIZEOF_StgPAP + WDS(1);
                 SET_HDR(pap, stg_PAP_info, CCCS);
                 StgPAP_arity(pap) = arity;
+                if (arity <= TAG_MASK) {
+                  // TODO: Shouldn't this already be tagged? If not why did we
+                  // untag it at the beginning of this function?
+                  fun = untaggedfun + arity;
+                }
                 StgPAP_fun(pap)   = fun;
                 StgPAP_n_args(pap) = 0;
                 return (pap);
@@ -117,9 +122,8 @@ again:
                 return (fun);
             } else {
                 // We're going to copy this PAP, and put the new CCS in it
-                fun = untaggedfun;
                 W_ size;
-                size = SIZEOF_StgPAP + WDS(TO_W_(StgPAP_n_args(fun)));
+                size = SIZEOF_StgPAP + WDS(TO_W_(StgPAP_n_args(untaggedfun)));
                 HP_CHK_GEN(size);
                 TICK_ALLOC_PAP(size, 0);
                 // attribute this allocation to the "overhead of profiling"
@@ -127,13 +131,13 @@ again:
                 P_ pap;
                 pap = Hp - size + WDS(1);
                 // We'll lose the original PAP, so we should enter its CCS
-                ccall enterFunCCS(BaseReg "ptr", StgHeader_ccs(fun) "ptr");
+                ccall enterFunCCS(BaseReg "ptr", StgHeader_ccs(untaggedfun) "ptr");
                 SET_HDR(pap, stg_PAP_info, CCCS);
-                StgPAP_arity(pap) = StgPAP_arity(fun);
-                StgPAP_n_args(pap) = StgPAP_n_args(fun);
+                StgPAP_arity(pap) = StgPAP_arity(untaggedfun);
+                StgPAP_n_args(pap) = StgPAP_n_args(untaggedfun);
                 StgPAP_fun(pap)   = StgPAP_fun(fun);
                 W_ i;
-                i = TO_W_(StgPAP_n_args(fun));
+                i = TO_W_(StgPAP_n_args(untaggedfun));
             loop:
                 if (i == 0) {
                     return (pap);