summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2022-07-08 23:18:04 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-08-06 06:13:17 -0400
commit1f6c56ae9aa4ab4977ba376ac901d5256bf0aba0 (patch)
tree475a1912e36bd8bb37ae31906b4cfcfa62341ebd
parentff11d579dd1ff8f138a24f698517f3cbcff219f7 (diff)
downloadhaskell-1f6c56ae9aa4ab4977ba376ac901d5256bf0aba0.tar.gz
StgToCmm: Fix isSimpleScrut when profiling is enabled.
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.
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs24
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs16
-rw-r--r--compiler/GHC/Types/RepType.hs19
3 files changed, 32 insertions, 27 deletions
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index d935bb4b99..fc76664d94 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -208,7 +208,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
@@ -236,19 +236,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
@@ -258,13 +246,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
@@ -597,8 +585,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 9494a3c57d..0e7c52f68d 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -45,7 +45,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
@@ -59,6 +59,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
@@ -551,7 +552,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
@@ -567,12 +567,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]
@@ -628,7 +622,11 @@ 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)
+ -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
+ 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 2c0d93afb5..4aca238713 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
@@ -674,3 +677,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