StgToCmm: Fix isSimpleScrut when profiling is enabled.wip/andreask/fix-prof-94

When profiling is enabled we must enter functions that might represent
thunks in order for their sccs to show up in the profile.

We might allocate even if the function is already evaluated in this
case. So we can't consider any potential function thunk to be a simple
scrut when profiling.

Not doing so caused profiled binaries to segfault.

3 files changed, 31 insertions, 27 deletions

diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 7c1b5250e4..1933474392 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -209,7 +209,7 @@ argPrimRep arg = typePrimRep1 (stgArgType arg)
 mkLFArgument :: Id -> LambdaFormInfo
 mkLFArgument id
   | isUnliftedType ty      = LFUnlifted
-  | might_be_a_function ty = LFUnknown True
+  | mightBeFunTy ty = LFUnknown True
   | otherwise              = LFUnknown False
   where
     ty = idType id
@@ -237,19 +237,7 @@ mkLFThunk thunk_ty top fvs upd_flag
     LFThunk top (null fvs)
             (isUpdatable upd_flag)
             NonStandardThunk
-            (might_be_a_function thunk_ty)
-
---------------
-might_be_a_function :: Type -> Bool
--- Return False only if we are *sure* it's a data type
--- Look through newtypes etc as much as poss
-might_be_a_function ty
-  | [LiftedRep] <- typePrimRep ty
-  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
-  , isDataTyCon tc
-  = False
-  | otherwise
-  = True
+            (mightBeFunTy thunk_ty)
 
 -------------
 mkConLFInfo :: DataCon -> LambdaFormInfo
@@ -259,13 +247,13 @@ mkConLFInfo con = LFCon con
 mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
 mkSelectorLFInfo id offset updatable
   = LFThunk NotTopLevel False updatable (SelectorThunk offset)
-        (might_be_a_function (idType id))
+        (mightBeFunTy (idType id))
 
 -------------
 mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
 mkApLFInfo id upd_flag arity
   = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
-        (might_be_a_function (idType id))
+        (mightBeFunTy (idType id))
 
 -------------
 mkLFImported :: Id -> LambdaFormInfo
@@ -598,8 +586,8 @@ getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_loc
   | n_args == 0
   , Just sig <- idTagSig_maybe id
   , isTaggedSig sig -- Infered to be already evaluated by Tag Inference
-  -- When profiling we enter functions to update the SCC so we
-  -- can't use the infered enterInfo here.
+  -- When profiling we must enter all potential functions to make sure we update the SCC
+  -- even if the function itself is already evaluated.
   -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
   , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function)
   = InferedReturnIt -- See Note [Tag Inference]
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 7992e34417..98f315db75 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -46,7 +46,7 @@ import GHC.Types.Id
 import GHC.Builtin.PrimOps
 import GHC.Core.TyCon
 import GHC.Core.Type        ( isUnliftedType )
-import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs )
+import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy )
 import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
 import GHC.Types.Tickish
 import GHC.Data.Maybe
@@ -60,6 +60,7 @@ import Control.Monad ( unless, void )
 import Control.Arrow ( first )
 import Data.List     ( partition )
 import GHC.Stg.InferTags.TagSig (isTaggedSig)
+import GHC.Platform.Profile (profileIsProfiling)
 
 ------------------------------------------------------------------------
 --              cgExpr: the main function
@@ -552,7 +553,6 @@ cgCase scrut bndr alt_type alts
                     | not simple_scrut = True
                     | isSingleton alts = False
                     | up_hp_usg > 0    = False
-                    | evaluatedScrut   = False
                     | otherwise        = True
                -- cf Note [Compiling case expressions]
              gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts
@@ -568,12 +568,6 @@ cgCase scrut bndr alt_type alts
   where
     is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op
     is_cmp_op _                             = False
-    evaluatedScrut
-      | (StgApp v []) <- scrut
-      , Just sig <- idTagSig_maybe v
-      , isTaggedSig sig = True
-      | otherwise = False
-
 
 
 {- Note [GC for conditionals]
@@ -629,7 +623,10 @@ isSimpleScrut (StgLit _)           _         = return True       -- case 1# of {
 isSimpleScrut (StgApp _ [])    (PrimAlt _)   = return True       -- case x# of { 0# -> ..; ... }
 isSimpleScrut (StgApp f [])   _
   | Just sig <- idTagSig_maybe f
-  = return $! isTaggedSig sig       -- case !x of { ... }
+  , isTaggedSig sig  -- case !x of { ... }
+  = if mightBeFunTy (idType f)
+      then not . profileIsProfiling <$> getProfile
+      else pure True
 isSimpleScrut _                    _         = return False
 
 isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs
index 0d6d6b076c..7a854e4d5c 100644
--- a/compiler/GHC/Types/RepType.hs
+++ b/compiler/GHC/Types/RepType.hs
@@ -22,6 +22,9 @@ module GHC.Types.RepType
     ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),
     slotPrimRep, primRepSlot,
 
+    -- * Is this type known to be data?
+    mightBeFunTy
+
     ) where
 
 import GHC.Prelude
@@ -677,3 +680,19 @@ primRepToRuntimeRep rep = case rep of
 -- See also Note [RuntimeRep and PrimRep]
 primRepToType :: PrimRep -> Type
 primRepToType = anyTypeOfKind . mkTYPEapp . primRepToRuntimeRep
+
+--------------
+mightBeFunTy :: Type -> Bool
+-- Return False only if we are *sure* it's a data type
+-- Look through newtypes etc as much as possible. Used to
+-- decide if we need to enter a closure via a slow call.
+--
+-- AK: It would be nice to figure out and document the difference
+-- between this and isFunTy at some point.
+mightBeFunTy ty
+  | [LiftedRep] <- typePrimRep ty
+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
+  , isDataTyCon tc
+  = False
+  | otherwise
+  = True