[commit: ghc] master: Tag the FUN before making a PAP (#13767) (f9c6d53)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f9c6d53fe997f1c560cda6f346f4b201711df37c/ghc

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

commit f9c6d53fe997f1c560cda6f346f4b201711df37c
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Mon Jul 3 16:54:00 2017 -0400

    Tag the FUN before making a PAP (#13767)
    
    Pointers to FUNs are not guaranteed to be tagged in general, because
    the compiler doesn't always know the arity of a FUN when it needs to
    reference it, e.g. with -O0 when the function is in another module.
    
    However, there's one case where we can put the correct tag on a FUN:
    when it is referenced by a PAP, because when building the PAP we know
    the arity and we can tag the pointer correctly.  The AutoApply code
    does this, and the sanity checker checks it, but the interpreter did
    not respect this invariant.  This patch fixes it.
    
    Test Plan:
    ```
    (cd ghc && make 2 GhcDebugged=YES)
    ./inplace/bin/ghc-stage2 --interpreter +RTS -DS
    ```
    
    Reviewers: niteria, bgamari, austin, erikd
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #13767
    
    Differential Revision: https://phabricator.haskell.org/D3680


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

f9c6d53fe997f1c560cda6f346f4b201711df37c
 rts/Interpreter.c | 14 ++++++++++++--
 1 file changed, 12 insertions(+), 2 deletions(-)

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 9291473..a2f0b58 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -406,8 +406,18 @@ eval_obj:
     case FUN_STATIC:
 #if defined(PROFILING)
         if (cap->r.rCCCS != obj->header.prof.ccs) {
+            int arity = get_fun_itbl(obj)->f.arity;
+            // Tag the function correctly.  We guarantee that pap->fun
+            // is correctly tagged (this is checked by
+            // Sanity.c:checkPAP()), but we don't guarantee that every
+            // pointer to a FUN is tagged on the stack or elsewhere,
+            // so we fix the tag here. (#13767)
+            // For full details of the invariants on tagging, see
+            // https://ghc.haskell.org/trac/ghc/wiki/Commentary/Rts/HaskellExecution/PointerTagging
             tagged_obj =
-                newEmptyPAP(cap, tagged_obj, get_fun_itbl(obj)->f.arity);
+                newEmptyPAP(cap,
+                            arity <= TAG_MASK ? obj + arity : obj,
+                            arity);
         }
 #endif
         break;
@@ -424,7 +434,7 @@ eval_obj:
         ASSERT(((StgBCO *)obj)->arity > 0);
 #if defined(PROFILING)
         if (cap->r.rCCCS != obj->header.prof.ccs) {
-            tagged_obj = newEmptyPAP(cap, tagged_obj, ((StgBCO *)obj)->arity);
+            tagged_obj = newEmptyPAP(cap, obj, ((StgBCO *)obj)->arity);
         }
 #endif
         break;