[Git][ghc/ghc][master] Transform some StgRhsClosure into StgRhsCon after unarisation (#25166)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Sep 6 20:40:47 UTC 2024
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
5456e02e by Sylvain Henry at 2024-09-06T11:57:01+02:00
Transform some StgRhsClosure into StgRhsCon after unarisation (#25166)
Before unarisation we may have code like:
Test.foo :: Test.D
[GblId, Unf=OtherCon []] =
\u []
case (# |_| #) [GHC.Types.(##)] of sat_sAw [Occ=Once1] {
__DEFAULT -> Test.D [GHC.Types.True sat_sAw];
};
After unarisation we get:
Test.foo :: Test.D
[GblId, Unf=OtherCon []] =
{} \u [] Test.D [GHC.Types.True 2#];
Notice that it's still an Updatable closure for no reason anymore. This
patch transforms appropriate StgRhsClosures into StgRhsCons after
unarisation, allowing these closures to be statically allocated. Now we
get the expected:
Test.foo :: Test.D
[GblId, Unf=OtherCon []] =
Test.D! [GHC.Types.True 2#];
Fix #25166
To avoid duplicating code, this patch refactors the mk(Top)StgRhs
functions and put them in a GHC.Stg.Make module alongside the new
mk(Top)StgRhsCon_maybe functions.
- - - - -
15 changed files:
- compiler/GHC/CoreToStg.hs
- compiler/GHC/Driver/Config/Stg/Pipeline.hs
- + compiler/GHC/Stg/Make.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/Stg/Stats.hs
- compiler/GHC/Stg/Syntax.hs
- compiler/GHC/Stg/Unarise.hs
- compiler/GHC/Stg/Utils.hs
- compiler/GHC/StgToCmm/DataCon.hs
- compiler/GHC/Types/CostCentre.hs
- compiler/ghc.cabal.in
- testsuite/tests/codeGen/should_compile/Makefile
- + testsuite/tests/codeGen/should_compile/T25166.hs
- + testsuite/tests/codeGen/should_compile/T25166.stdout
- testsuite/tests/codeGen/should_compile/all.T
Changes:
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -27,7 +27,8 @@ import GHC.Core.DataCon
import GHC.Stg.Syntax
import GHC.Stg.Debug
-import GHC.Stg.Utils
+import GHC.Stg.Make
+import GHC.Stg.Utils (allowTopLevelConApp)
import GHC.Types.RepType
import GHC.Types.Id.Make ( coercionTokenId )
@@ -36,16 +37,13 @@ import GHC.Types.Id.Info
import GHC.Types.CostCentre
import GHC.Types.Tickish
import GHC.Types.Var.Env
-import GHC.Types.Name ( isExternalName, nameModule_maybe )
+import GHC.Types.Name ( isExternalName )
import GHC.Types.Basic ( Arity, TypeOrConstraint(..) )
import GHC.Types.Literal
import GHC.Types.ForeignCall
import GHC.Types.IPE
-import GHC.Types.Demand ( isAtMostOnceDmd )
-import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
import GHC.Unit.Module
-import GHC.Data.FastString
import GHC.Platform ( Platform )
import GHC.Platform.Ways
import GHC.Builtin.PrimOps
@@ -338,10 +336,12 @@ coreToTopStgRhs
-> CtsM (CollectedCCs, (Id, StgRhs))
coreToTopStgRhs opts this_mod ccs (bndr, rhs)
- = do { new_rhs <- coreToPreStgRhs rhs
+ = do { new_rhs <- coreToMkStgRhs bndr rhs
; let (stg_rhs, ccs') =
- mkTopStgRhs opts this_mod ccs bndr new_rhs
+ mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))
+ (coreToStg_AutoSccsOnIndividualCafs opts)
+ this_mod ccs bndr new_rhs
stg_arity =
stgRhsArity stg_rhs
@@ -372,7 +372,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs)
-- coreToStgExpr panics if the input expression is a value lambda. CorePrep
-- ensures that value lambdas only exist as the RHS of bindings, which we
--- handle with the function coreToPreStgRhs.
+-- handle with the function coreToMkStgRhs.
coreToStgExpr
:: HasDebugCallStack => CoreExpr
@@ -685,166 +685,24 @@ coreToStgRhs :: (Id,CoreExpr)
-> CtsM StgRhs
coreToStgRhs (bndr, rhs) = do
- new_rhs <- coreToPreStgRhs rhs
+ new_rhs <- coreToMkStgRhs bndr rhs
return (mkStgRhs bndr new_rhs)
--- Represents the RHS of a binding for use with mk(Top)StgRhs.
-data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks
-
-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
-coreToPreStgRhs expr
- = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
- do { body' <- coreToStgExpr body
- ; return (PreStgRhs args' body' (exprType body)) }
- where
- (args, body) = myCollectBinders expr
- args' = filterStgBinders args
-
--- Generate a top-level RHS. Any new cost centres generated for CAFs will be
--- appended to `CollectedCCs` argument.
-mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
- -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
-
-mkTopStgRhs CoreToStgOpts
- { coreToStg_platform = platform
- , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
- , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
- } this_mod ccs bndr (PreStgRhs bndrs rhs typ)
- | not (null bndrs)
- = -- The list of arguments is non-empty, so not CAF
- ( StgRhsClosure noExtFieldSilent
- dontCareCCS
- ReEntrant
- bndrs rhs typ
- , ccs )
-
- -- After this point we know that `bndrs` is empty,
- -- so this is not a function binding
- | StgConApp con mn args _ <- unticked_rhs
- , -- Dynamic StgConApps are updatable
- not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)
- = -- CorePrep does this right, but just to make sure
- assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
- (ppr bndr $$ ppr con $$ ppr args)
- ( StgRhsCon dontCareCCS con mn ticks args typ, ccs )
-
- -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
- | opt_AutoSccsOnIndividualCafs
- = ( StgRhsClosure noExtFieldSilent
- caf_ccs
- upd_flag [] rhs typ
- , collectCC caf_cc caf_ccs ccs )
-
- | otherwise
- = ( StgRhsClosure noExtFieldSilent
- all_cafs_ccs
- upd_flag [] rhs typ
- , ccs )
-
- where
- (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
- upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
- | otherwise = Updatable
-
- -- CAF cost centres generated for -fcaf-all
- caf_cc = mkAutoCC bndr modl
- caf_ccs = mkSingletonCCS caf_cc
- -- careful: the binder might be :Main.main,
- -- which doesn't belong to module mod_name.
- -- bug #249, tests prof001, prof002
- modl | Just m <- nameModule_maybe (idName bndr) = m
- | otherwise = this_mod
-
- -- default CAF cost centre
- (_, all_cafs_ccs) = getAllCAFsCC this_mod
-
--- Generate a non-top-level RHS. Cost-centre is always currentCCS,
--- see Note [Cost-centre initialization plan].
-mkStgRhs :: Id -> PreStgRhs -> StgRhs
-mkStgRhs bndr (PreStgRhs bndrs rhs typ)
- | not (null bndrs)
- = StgRhsClosure noExtFieldSilent
- currentCCS
- ReEntrant
- bndrs rhs typ
-
- -- After this point we know that `bndrs` is empty,
- -- so this is not a function binding
-
- | isJoinId bndr -- Must be a nullary join point
- = -- It might have /type/ arguments (T18328),
- -- so its JoinArity might be >0
- StgRhsClosure noExtFieldSilent
- currentCCS
- ReEntrant -- ignored for LNE
- [] rhs typ
-
- | StgConApp con mn args _ <- unticked_rhs
- = StgRhsCon currentCCS con mn ticks args typ
-
- | otherwise
- = StgRhsClosure noExtFieldSilent
- currentCCS
- upd_flag [] rhs typ
- where
- (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
- upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
- | otherwise = Updatable
-
- {-
- SDM: disabled. Eval/Apply can't handle functions with arity zero very
- well; and making these into simple non-updatable thunks breaks other
- assumptions (namely that they will be entered only once).
-
- upd_flag | isPAP env rhs = ReEntrant
- | otherwise = Updatable
-
--- Detect thunks which will reduce immediately to PAPs, and make them
--- non-updatable. This has several advantages:
---
--- - the non-updatable thunk behaves exactly like the PAP,
---
--- - the thunk is more efficient to enter, because it is
--- specialised to the task.
---
--- - we save one update frame, one stg_update_PAP, one update
--- and lots of PAP_enters.
---
--- - in the case where the thunk is top-level, we save building
--- a black hole and furthermore the thunk isn't considered to
--- be a CAF any more, so it doesn't appear in any SRTs.
---
--- We do it here, because the arity information is accurate, and we need
--- to do it before the SRT pass to save the SRT entries associated with
--- any top-level PAPs.
-
-isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
- where
- arity = stgArity f (lookupBinding env f)
-isPAP env _ = False
-
--}
-
-{- ToDo:
- upd = if isOnceDem dem
- then (if isNotTop toplev
- then SingleEntry -- HA! Paydirt for "dem"
- else
- (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
- Updatable)
- else Updatable
- -- For now we forbid SingleEntry CAFs; they tickle the
- -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
- -- and I don't understand why. There's only one SE_CAF (well,
- -- only one that tickled a great gaping bug in an earlier attempt
- -- at ClosureInfo.getEntryConvention) in the whole of nofib,
- -- specifically Main.lvl6 in spectral/cryptarithm2.
- -- So no great loss. KSW 2000-07.
--}
+coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs
+coreToMkStgRhs bndr expr = do
+ let (args, body) = myCollectBinders expr
+ let args' = filterStgBinders args
+ extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
+ body' <- coreToStgExpr body
+ let mk_rhs = MkStgRhs
+ { rhs_args = args'
+ , rhs_expr = body'
+ , rhs_type = exprType body
+ , rhs_is_join = isJoinId bndr
+ }
+ pure mk_rhs
-- ---------------------------------------------------------------------------
-- A monad for the core-to-STG pass
@@ -933,15 +791,6 @@ lookupBinding env v = case lookupVarEnv env v of
Just xx -> xx
Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound
-getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
-getAllCAFsCC this_mod =
- let
- span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
- all_cafs_cc = mkAllCafsCC this_mod span
- all_cafs_ccs = mkSingletonCCS all_cafs_cc
- in
- (all_cafs_cc, all_cafs_ccs)
-
-- Misc.
filterStgBinders :: [Var] -> [Var]
=====================================
compiler/GHC/Driver/Config/Stg/Pipeline.hs
=====================================
@@ -7,6 +7,7 @@ import GHC.Prelude
import Control.Monad (guard)
import GHC.Stg.Pipeline
+import GHC.Stg.Utils
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Stg.Lift
@@ -15,15 +16,19 @@ import GHC.Driver.DynFlags
-- | Initialize STG pretty-printing options from DynFlags
initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
-initStgPipelineOpts dflags for_bytecode = StgPipelineOpts
- { stgPipeline_lint = do
- guard $ gopt Opt_DoStgLinting dflags
- Just $ initDiagOpts dflags
- , stgPipeline_pprOpts = initStgPprOpts dflags
- , stgPipeline_phases = getStgToDo for_bytecode dflags
- , stgPlatform = targetPlatform dflags
- , stgPipeline_forBytecode = for_bytecode
- }
+initStgPipelineOpts dflags for_bytecode =
+ let !platform = targetPlatform dflags
+ !ext_dyn_refs = gopt Opt_ExternalDynamicRefs dflags
+ in StgPipelineOpts
+ { stgPipeline_lint = do
+ guard $ gopt Opt_DoStgLinting dflags
+ Just $ initDiagOpts dflags
+ , stgPipeline_pprOpts = initStgPprOpts dflags
+ , stgPipeline_phases = getStgToDo for_bytecode dflags
+ , stgPlatform = platform
+ , stgPipeline_forBytecode = for_bytecode
+ , stgPipeline_allowTopLevelConApp = allowTopLevelConApp platform ext_dyn_refs
+ }
-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
getStgToDo
=====================================
compiler/GHC/Stg/Make.hs
=====================================
@@ -0,0 +1,172 @@
+module GHC.Stg.Make
+ ( MkStgRhs (..)
+ , mkTopStgRhs
+ , mkStgRhs
+ , mkStgRhsCon_maybe
+ , mkTopStgRhsCon_maybe
+ )
+where
+
+import GHC.Prelude
+import GHC.Unit.Module
+
+import GHC.Core.DataCon
+import GHC.Core.Type (Type)
+
+import GHC.Stg.Syntax
+import GHC.Stg.Utils (stripStgTicksTop)
+
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.CostCentre
+import GHC.Types.Demand ( isAtMostOnceDmd )
+import GHC.Types.Tickish
+
+-- Represents the RHS of a binding for use with mk(Top)StgRhs and
+-- mk(Top)StgRhsCon_maybe.
+data MkStgRhs = MkStgRhs
+ { rhs_args :: [Id] -- ^ Empty for thunks
+ , rhs_expr :: StgExpr -- ^ RHS expression
+ , rhs_type :: Type -- ^ RHS type (only used in the JS backend: layering violation)
+ , rhs_is_join :: !Bool -- ^ Is it a RHS for a join-point?
+ }
+
+
+-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
+-- appended to `CollectedCCs` argument.
+mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
+ -> Bool -> Module -> CollectedCCs
+ -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
+mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
+ -- try to make a StgRhsCon first
+ | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs
+ = ( rhs_con, ccs )
+
+ | not (null bndrs)
+ = -- The list of arguments is non-empty, so not CAF
+ ( StgRhsClosure noExtFieldSilent
+ dontCareCCS
+ ReEntrant
+ bndrs rhs typ
+ , ccs )
+
+ -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+ | opt_AutoSccsOnIndividualCafs
+ = ( StgRhsClosure noExtFieldSilent
+ caf_ccs
+ upd_flag [] rhs typ
+ , collectCC caf_cc caf_ccs ccs )
+
+ | otherwise
+ = ( StgRhsClosure noExtFieldSilent
+ all_cafs_ccs
+ upd_flag [] rhs typ
+ , ccs )
+
+ where
+ upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+ | otherwise = Updatable
+
+ -- CAF cost centres generated for -fcaf-all
+ caf_cc = mkAutoCC bndr modl
+ caf_ccs = mkSingletonCCS caf_cc
+ -- careful: the binder might be :Main.main,
+ -- which doesn't belong to module mod_name.
+ -- bug #249, tests prof001, prof002
+ modl | Just m <- nameModule_maybe (idName bndr) = m
+ | otherwise = this_mod
+
+ -- default CAF cost centre
+ (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialization plan].
+mkStgRhs :: Id -> MkStgRhs -> StgRhs
+mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
+ -- try to make a StgRhsCon first
+ | Just rhs_con <- mkStgRhsCon_maybe mk_rhs
+ = rhs_con
+
+ | otherwise
+ = StgRhsClosure noExtFieldSilent
+ currentCCS
+ upd_flag bndrs rhs typ
+ where
+ upd_flag | is_join = JumpedTo
+ | not (null bndrs) = ReEntrant
+ | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
+ | otherwise = Updatable
+
+ {-
+ SDM: disabled. Eval/Apply can't handle functions with arity zero very
+ well; and making these into simple non-updatable thunks breaks other
+ assumptions (namely that they will be entered only once).
+
+ upd_flag | isPAP env rhs = ReEntrant
+ | otherwise = Updatable
+
+-- Detect thunks which will reduce immediately to PAPs, and make them
+-- non-updatable. This has several advantages:
+--
+-- - the non-updatable thunk behaves exactly like the PAP,
+--
+-- - the thunk is more efficient to enter, because it is
+-- specialised to the task.
+--
+-- - we save one update frame, one stg_update_PAP, one update
+-- and lots of PAP_enters.
+--
+-- - in the case where the thunk is top-level, we save building
+-- a black hole and furthermore the thunk isn't considered to
+-- be a CAF any more, so it doesn't appear in any SRTs.
+--
+-- We do it here, because the arity information is accurate, and we need
+-- to do it before the SRT pass to save the SRT entries associated with
+-- any top-level PAPs.
+
+isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
+ where
+ arity = stgArity f (lookupBinding env f)
+isPAP env _ = False
+
+-}
+
+{- ToDo:
+ upd = if isOnceDem dem
+ then (if isNotTop toplev
+ then SingleEntry -- HA! Paydirt for "dem"
+ else
+ (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
+ Updatable)
+ else Updatable
+ -- For now we forbid SingleEntry CAFs; they tickle the
+ -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+ -- and I don't understand why. There's only one SE_CAF (well,
+ -- only one that tickled a great gaping bug in an earlier attempt
+ -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+ -- specifically Main.lvl6 in spectral/cryptarithm2.
+ -- So no great loss. KSW 2000-07.
+-}
+
+
+-- | Try to make a non top-level StgRhsCon if appropriate
+mkStgRhsCon_maybe :: MkStgRhs -> Maybe StgRhs
+mkStgRhsCon_maybe (MkStgRhs bndrs rhs typ is_join)
+ | [] <- bndrs
+ , not is_join
+ , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs
+ = Just (StgRhsCon currentCCS con mn ticks args typ)
+
+ | otherwise = Nothing
+
+
+-- | Try to make a top-level StgRhsCon if appropriate
+mkTopStgRhsCon_maybe :: (DataCon -> [StgArg] -> Bool) -> MkStgRhs -> Maybe StgRhs
+mkTopStgRhsCon_maybe allow_static_con_app (MkStgRhs bndrs rhs typ is_join)
+ | [] <- bndrs
+ , not is_join -- shouldn't happen at top-level
+ , (ticks, StgConApp con mn args _) <- stripStgTicksTop (not . tickishIsCode) rhs
+ , allow_static_con_app con args
+ = Just (StgRhsCon dontCareCCS con mn ticks args typ)
+
+ | otherwise = Nothing
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -31,6 +31,8 @@ import GHC.Stg.CSE ( stgCse )
import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams )
import GHC.Unit.Module ( Module )
+import GHC.Core.DataCon (DataCon)
+
import GHC.Utils.Error
import GHC.Types.Var
import GHC.Types.Var.Set
@@ -52,6 +54,12 @@ data StgPipelineOpts = StgPipelineOpts
, stgPipeline_pprOpts :: !StgPprOpts
, stgPlatform :: !Platform
, stgPipeline_forBytecode :: !Bool
+
+ , stgPipeline_allowTopLevelConApp :: Module -> DataCon -> [StgArg] -> Bool
+ -- ^ Is a top-level (static) StgConApp allowed or not. If not, use dynamic allocation.
+ --
+ -- This is typically used to support dynamic linking on Windows and the
+ -- -fexternal-dynamic-refs flag. See GHC.Stg.Utils.allowTopLevelConApp.
}
newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
@@ -136,7 +144,7 @@ stg2stg logger extra_vars opts this_mod binds
StgUnarise -> do
us <- getUniqueSupplyM
liftIO (stg_linter False "Pre-unarise" binds)
- let binds' = {-# SCC "StgUnarise" #-} unarise us binds
+ let binds' = {-# SCC "StgUnarise" #-} unarise us (stgPipeline_allowTopLevelConApp opts this_mod) binds
liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
liftIO (stg_linter True "Unarise" binds')
return binds'
=====================================
compiler/GHC/Stg/Stats.hs
=====================================
@@ -46,6 +46,7 @@ data CounterType
| ReEntrantBinds Bool{-ditto-}
| SingleEntryBinds Bool{-ditto-}
| UpdatableBinds Bool{-ditto-}
+ | JoinPointBinds Bool{-ditto-}
deriving (Eq, Ord)
type Count = Int
@@ -94,6 +95,7 @@ showStgStats prog
s (ReEntrantBinds _) = "ReEntrantBindsBinds_Nested "
s (SingleEntryBinds _) = "SingleEntryBinds_Nested "
s (UpdatableBinds _) = "UpdatableBinds_Nested "
+ s (JoinPointBinds _) = "JoinPointBinds_Nested "
gatherStgStats :: [StgTopBinding] -> StatEnv
gatherStgStats binds = combineSEs (map statTopBinding binds)
@@ -132,6 +134,7 @@ statRhs top (_, StgRhsClosure _ _ u _ body _)
ReEntrant -> ReEntrantBinds top
Updatable -> UpdatableBinds top
SingleEntry -> SingleEntryBinds top
+ JumpedTo -> JoinPointBinds top
)
{-
=====================================
compiler/GHC/Stg/Syntax.hs
=====================================
@@ -54,7 +54,6 @@ module GHC.Stg.Syntax (
-- utils
stgRhsArity, freeVarsOfRhs,
- isDllConApp,
stgArgType,
stgArgRep,
stgArgRep1,
@@ -87,17 +86,14 @@ import GHC.Core.Ppr( {- instances -} )
import GHC.Types.ForeignCall ( ForeignCall )
import GHC.Types.Id
-import GHC.Types.Name ( isDynLinkName )
import GHC.Types.Tickish ( StgTickish )
import GHC.Types.Var.Set
import GHC.Types.Literal ( Literal, literalType )
import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe )
-import GHC.Unit.Module ( Module )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
-import GHC.Platform
import GHC.Builtin.PrimOps ( PrimOp, PrimCall )
import Data.ByteString ( ByteString )
@@ -138,51 +134,6 @@ data StgArg
= StgVarArg Id
| StgLitArg Literal
--- | Does this constructor application refer to anything in a different
--- *Windows* DLL?
--- If so, we can't allocate it statically
-isDllConApp
- :: Platform
- -> Bool -- is Opt_ExternalDynamicRefs enabled?
- -> Module
- -> DataCon
- -> [StgArg]
- -> Bool
-isDllConApp platform ext_dyn_refs this_mod con args
- | not ext_dyn_refs = False
- | platformOS platform == OSMinGW32
- = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args
- | otherwise = False
- where
- -- NB: typePrimRep1 is legit because any free variables won't have
- -- unlifted type (there are no unlifted things at top level)
- is_dll_arg :: StgArg -> Bool
- is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v))
- && isDynLinkName platform this_mod (idName v)
- is_dll_arg _ = False
-
--- True of machine addresses; these are the things that don't work across DLLs.
--- The key point here is that VoidRep comes out False, so that a top level
--- nullary GADT constructor is False for isDllConApp
---
--- data T a where
--- T1 :: T Int
---
--- gives
---
--- T1 :: forall a. (a~Int) -> T a
---
--- and hence the top-level binding
---
--- $WT1 :: T Int
--- $WT1 = T1 Int (Coercion (Refl Int))
---
--- The coercion argument here gets VoidRep
-isAddrRep :: PrimOrVoidRep -> Bool
-isAddrRep (NVRep AddrRep) = True
-isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript
-isAddrRep _ = False
-
-- | Type of an @StgArg@
--
-- Very half baked because we have lost the type arguments.
@@ -721,24 +672,35 @@ UpdateFlag
This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
-A @ReEntrant@ closure may be entered multiple times, but should not be updated
-or blackholed. An @Updatable@ closure should be updated after evaluation (and
-may be blackholed during evaluation). A @SingleEntry@ closure will only be
-entered once, and so need not be updated but may safely be blackholed.
-}
-data UpdateFlag = ReEntrant | Updatable | SingleEntry
+data UpdateFlag
+ = ReEntrant
+ -- ^ A @ReEntrant@ closure may be entered multiple times, but should not
+ -- be updated or blackholed.
+ | Updatable
+ -- ^ An @Updatable@ closure should be updated after evaluation (and may be
+ -- blackholed during evaluation).
+ | SingleEntry
+ -- ^ A @SingleEntry@ closure will only be entered once, and so need not be
+ -- updated but may safely be blackholed.
+ | JumpedTo
+ -- ^ A @JumpedTo@ (join-point) closure is entered once or multiple times
+ -- but has no heap-allocated associated closure.
+ deriving (Show,Eq)
instance Outputable UpdateFlag where
ppr u = char $ case u of
ReEntrant -> 'r'
Updatable -> 'u'
SingleEntry -> 's'
+ JumpedTo -> 'j'
isUpdatable :: UpdateFlag -> Bool
isUpdatable ReEntrant = False
isUpdatable SingleEntry = False
isUpdatable Updatable = True
+isUpdatable JumpedTo = False
{-
************************************************************************
=====================================
compiler/GHC/Stg/Unarise.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE MultiWayIf #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-2012
@@ -401,6 +402,7 @@ import GHC.Utils.Panic
import GHC.Types.RepType
import GHC.Stg.Syntax
import GHC.Stg.Utils
+import GHC.Stg.Make
import GHC.Core.Type
import GHC.Builtin.Types.Prim (intPrimTy)
import GHC.Builtin.Types
@@ -442,10 +444,14 @@ import Data.List (mapAccumL)
-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
-- (i.e. no unboxed tuples, sums or voids)
--
-newtype UnariseEnv = UnariseEnv { ue_rho :: (VarEnv UnariseVal) }
+data UnariseEnv = UnariseEnv
+ { ue_rho :: (VarEnv UnariseVal)
+ , ue_allow_static_conapp :: DataCon -> [StgArg] -> Bool
+ }
-initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv
+initUnariseEnv :: VarEnv UnariseVal -> (DataCon -> [StgArg] -> Bool) -> UnariseEnv
initUnariseEnv = UnariseEnv
+
data UnariseVal
= MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
| UnaryVal OutStgArg -- See Note [Renaming during unarisation].
@@ -477,27 +483,57 @@ lookupRho env v = lookupVarEnv (ue_rho env) v
--------------------------------------------------------------------------------
-unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
-unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds)
+unarise :: UniqSupply -> (DataCon -> [StgArg] -> Bool) -> [StgTopBinding] -> [StgTopBinding]
+unarise us is_dll_con_app binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv is_dll_con_app)) binds)
unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
unariseTopBinding rho (StgTopLifted bind)
- = StgTopLifted <$> unariseBinding rho bind
+ = StgTopLifted <$> unariseBinding rho True bind
unariseTopBinding _ bind at StgTopStringLit{} = return bind
-unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
-unariseBinding rho (StgNonRec x rhs)
- = StgNonRec x <$> unariseRhs rho rhs
-unariseBinding rho (StgRec xrhss)
- = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
+unariseBinding :: UnariseEnv -> Bool -> StgBinding -> UniqSM StgBinding
+unariseBinding rho top_level (StgNonRec x rhs)
+ = StgNonRec x <$> unariseRhs rho top_level rhs
+unariseBinding rho top_level (StgRec xrhss)
+ = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho top_level rhs) xrhss
-unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
-unariseRhs rho (StgRhsClosure ext ccs update_flag args expr typ)
+unariseRhs :: UnariseEnv -> Bool -> StgRhs -> UniqSM StgRhs
+unariseRhs rho top_level (StgRhsClosure ext ccs update_flag args expr typ)
= do (rho', args1) <- unariseFunArgBinders rho args
expr' <- unariseExpr rho' expr
- return (StgRhsClosure ext ccs update_flag args1 expr' typ)
-
-unariseRhs rho (StgRhsCon ccs con mu ts args typ)
+ -- Unarisation can lead to a StgRhsClosure becoming a StgRhsCon.
+ -- Hence, we call `mk(Top)StgRhsCon_maybe` rather than just building
+ -- another `StgRhsClosure`.
+ --
+ -- For example with unboxed sums (#25166):
+ --
+ -- foo = \u [] case (# | _ | #) [(##)] of tag { __DEFAULT -> D [True tag] }
+ --
+ -- ====> {unarisation}
+ --
+ -- foo = D [True 2#]
+ --
+ -- Transforming an appropriate StgRhsClosure into a StgRhsCon is
+ -- important as top-level StgRhsCon are statically allocated.
+ --
+ let mk_rhs = MkStgRhs
+ { rhs_args = args1
+ , rhs_expr = expr'
+ , rhs_type = typ
+ , rhs_is_join = update_flag == JumpedTo
+ }
+ if | top_level
+ , Just rhs_con <- mkTopStgRhsCon_maybe (ue_allow_static_conapp rho) mk_rhs
+ -> pure rhs_con
+
+ | not top_level
+ , Just rhs_con <- mkStgRhsCon_maybe mk_rhs
+ -> pure rhs_con
+
+ | otherwise
+ -> pure (StgRhsClosure ext ccs update_flag args1 expr' typ)
+
+unariseRhs rho _top (StgRhsCon ccs con mu ts args typ)
= assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
return (StgRhsCon ccs con mu ts (unariseConArgs rho args) typ)
@@ -576,10 +612,10 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts)
-- dead after unarise (checked in GHC.Stg.Lint)
unariseExpr rho (StgLet ext bind e)
- = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
+ = StgLet ext <$> unariseBinding rho False bind <*> unariseExpr rho e
unariseExpr rho (StgLetNoEscape ext bind e)
- = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
+ = StgLetNoEscape ext <$> unariseBinding rho False bind <*> unariseExpr rho e
unariseExpr rho (StgTick tick e)
= StgTick tick <$> unariseExpr rho e
=====================================
compiler/GHC/Stg/Utils.hs
=====================================
@@ -9,9 +9,12 @@ module GHC.Stg.Utils
, idArgs
, mkUnarisedId, mkUnarisedIds
+
+ , allowTopLevelConApp
) where
import GHC.Prelude
+import GHC.Platform
import GHC.Types.Id
import GHC.Core.Type
@@ -22,6 +25,8 @@ import GHC.Types.Tickish
import GHC.Types.Unique.Supply
import GHC.Types.RepType
+import GHC.Types.Name ( isDynLinkName )
+import GHC.Unit.Module ( Module )
import GHC.Stg.Syntax
import GHC.Utils.Outputable
@@ -122,3 +127,54 @@ stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE p = go
where go (StgTick t e) | p t = go e
go other = other
+
+-- | Do we allow the given top-level (static) ConApp?
+allowTopLevelConApp
+ :: Platform
+ -> Bool -- is Opt_ExternalDynamicRefs enabled?
+ -> Module
+ -> DataCon
+ -> [StgArg]
+ -> Bool
+allowTopLevelConApp platform ext_dyn_refs this_mod con args
+ -- we're not using dynamic linking
+ | not ext_dyn_refs = True
+ -- if the target OS is Windows, we only allow top-level ConApps if they don't
+ -- reference external names (Windows DLLs have a problem with static cross-DLL
+ -- refs)
+ | platformOS platform == OSMinGW32 = not is_external_con_app
+ -- otherwise, allowed
+ -- Sylvain: shouldn't this be False when (ext_dyn_refs && is_external_con_app)?
+ | otherwise = True
+ where
+ is_external_con_app = isDynLinkName platform this_mod (dataConName con) || any is_dll_arg args
+
+ -- NB: typePrimRep1 is legit because any free variables won't have
+ -- unlifted type (there are no unlifted things at top level)
+ is_dll_arg :: StgArg -> Bool
+ is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep1 (idType v))
+ && isDynLinkName platform this_mod (idName v)
+ is_dll_arg _ = False
+
+-- True of machine addresses; these are the things that don't work across DLLs.
+-- The key point here is that VoidRep comes out False, so that a top level
+-- nullary GADT constructor is True for allowTopLevelConApp
+--
+-- data T a where
+-- T1 :: T Int
+--
+-- gives
+--
+-- T1 :: forall a. (a~Int) -> T a
+--
+-- and hence the top-level binding
+--
+-- $WT1 :: T Int
+-- $WT1 = T1 Int (Coercion (Refl Int))
+--
+-- The coercion argument here gets VoidRep
+isAddrRep :: PrimOrVoidRep -> Bool
+isAddrRep (NVRep AddrRep) = True
+isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript
+isAddrRep _ = False
+
=====================================
compiler/GHC/StgToCmm/DataCon.hs
=====================================
@@ -19,6 +19,7 @@ import GHC.Prelude
import GHC.Platform
+import GHC.Stg.Utils (allowTopLevelConApp)
import GHC.Stg.Syntax
import GHC.Core ( AltCon(..) )
@@ -48,7 +49,6 @@ import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad (mapMaybeM)
-import Control.Monad
import Data.Char
import GHC.StgToCmm.Config (stgToCmmPlatform)
import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)
@@ -90,10 +90,8 @@ cgTopRhsCon cfg id con mn args
gen_code =
do { profile <- getProfile
; this_mod <- getModuleName
- ; when (platformOS platform == OSMinGW32) $
- -- Windows DLLs have a problem with static cross-DLL refs.
- massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))
- ; assert (args `lengthIs` countConRepArgs con ) return ()
+ ; massert (allowTopLevelConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args))
+ ; massert (args `lengthIs` countConRepArgs con )
; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)
-- LAY IT OUT
; let
=====================================
compiler/GHC/Types/CostCentre.hs
=====================================
@@ -4,6 +4,7 @@ module GHC.Types.CostCentre (
CostCentre(..), CcName, CCFlavour,
mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour,
mkLateCCFlavour, mkCallerCCFlavour,
+ getAllCAFsCC,
pprCostCentre,
CostCentreStack,
@@ -393,3 +394,13 @@ instance Binary CostCentre where
-- ok, because we only need the SrcSpan when declaring the
-- CostCentre in the original module, it is not used by importing
-- modules.
+
+getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
+getAllCAFsCC this_mod =
+ let
+ span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+ all_cafs_cc = mkAllCafsCC this_mod span
+ all_cafs_ccs = mkSingletonCCS all_cafs_cc
+ in
+ (all_cafs_cc, all_cafs_ccs)
+
=====================================
compiler/ghc.cabal.in
=====================================
@@ -702,6 +702,7 @@ Library
GHC.Stg.InferTags.Rewrite
GHC.Stg.InferTags.TagSig
GHC.Stg.InferTags.Types
+ GHC.Stg.Make
GHC.Stg.Pipeline
GHC.Stg.Stats
GHC.Stg.Subst
=====================================
testsuite/tests/codeGen/should_compile/Makefile
=====================================
@@ -77,3 +77,6 @@ T17648:
-fcatch-nonexhaustive-cases T17648.hs -v0 -fforce-recomp
'$(TEST_HC)' --show-iface T17648.hi | tr -d '\n\r' | \
grep -F 'f :: T GHC.Types.Int -> () [TagSig' >/dev/null
+
+T25166:
+ '$(TEST_HC)' -O2 -dno-typeable-binds -ddump-cmm T25166.hs | awk '/foo_closure/{flag=1}/}]/{flag=0}flag'
=====================================
testsuite/tests/codeGen/should_compile/T25166.hs
=====================================
@@ -0,0 +1,7 @@
+module Test where
+
+data A = A | B | C
+
+data D = D !Bool {-# UNPACK #-} !A
+
+foo = D True B
=====================================
testsuite/tests/codeGen/should_compile/T25166.stdout
=====================================
@@ -0,0 +1,6 @@
+[section ""data" . Test.foo_closure" {
+ Test.foo_closure:
+ const Test.D_con_info;
+ const GHC.Types.True_closure+2;
+ const 2;
+ const 3;
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -139,5 +139,7 @@ test('callee-no-local', [
['-ddump-cmm-raw']
)
+test('T25166', [req_cmm], makefile_test, [])
+
# dump Core to ensure that d is defined as: d = D 10## RUBBISH(IntRep)
test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5456e02ee97ea2f8b156bdbadd982611274bef0d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5456e02ee97ea2f8b156bdbadd982611274bef0d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240906/739ea8c0/attachment-0001.html>
More information about the ghc-commits
mailing list