diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-12-19 10:35:27 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-12-19 15:29:35 +0000 |
commit | 10ed31980f30bf2a0091b6f4cef11e0f2f633f22 (patch) | |
tree | efe00463657258f63a2e8e0f13ec05e5291cc999 | |
parent | a100763cc5c6c9736a00ca57b2ec3c721311eecb (diff) | |
download | haskell-10ed31980f30bf2a0091b6f4cef11e0f2f633f22.tar.gz |
Stop runRW# being magic
Triggered by thinking about Trac #14596, I found that runRW#
does not need to be a "magic" wired-in Id, now that we have
levity polymorphism.
This patch stops it being wired-in.
-rw-r--r-- | compiler/basicTypes/MkId.hs | 67 | ||||
-rw-r--r-- | compiler/coreSyn/CorePrep.hs | 43 | ||||
-rw-r--r-- | compiler/prelude/PrelNames.hs | 4 | ||||
-rw-r--r-- | libraries/ghc-prim/GHC/Magic.hs | 5 |
4 files changed, 50 insertions, 69 deletions
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 433f70a04f..38c772c935 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -29,7 +29,7 @@ module MkId ( wiredInIds, ghcPrimIds, unsafeCoerceName, unsafeCoerceId, realWorldPrimId, voidPrimId, voidArgId, - nullAddrId, seqId, lazyId, lazyIdKey, runRWId, + nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, magicDictId, coerceId, proxyHashId, noinlineId, noinlineIdName, @@ -145,7 +145,7 @@ wiredInIds ++ errorIds -- Defined in MkCore magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, runRWId, noinlineId] +magicIds = [lazyId, oneShotId, noinlineId] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -1187,10 +1187,9 @@ magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDict coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId -lazyIdName, oneShotName, runRWName, noinlineIdName :: Name +lazyIdName, oneShotName, noinlineIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -runRWName = mkWiredInIdName gHC_MAGIC (fsLit "runRW#") runRWKey runRWId noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId ------------------------------------------------ @@ -1289,27 +1288,6 @@ oneShotId = pcMiscPrelId oneShotName ty info , body, x'] $ Var body `App` Var x -runRWId :: Id -- See Note [runRW magic] in this module -runRWId = pcMiscPrelId runRWName ty info - where - info = noCafIdInfo `setInlinePragInfo` neverInlinePragma - `setStrictnessInfo` strict_sig - `setArityInfo` 1 - strict_sig = mkClosedStrictSig [strictApply1Dmd] topRes - -- Important to express its strictness, - -- since it is not inlined until CorePrep - -- Also see Note [runRW arg] in CorePrep - - -- State# RealWorld - stateRW = mkTyConApp statePrimTyCon [realWorldTy] - -- o - ret_ty = openAlphaTy - -- State# RealWorld -> o - arg_ty = stateRW `mkFunTy` ret_ty - -- (State# RealWorld -> o) -> o - ty = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $ - arg_ty `mkFunTy` ret_ty - -------------------------------------------------------------------------------- magicDictId :: Id -- See Note [magicDictId magic] magicDictId = pcMiscPrelId magicDictName ty info @@ -1464,45 +1442,6 @@ when we serialize an expression to the interface format, and we DON'T want use its fingerprints. -Note [runRW magic] -~~~~~~~~~~~~~~~~~~ -Some definitions, for instance @runST@, must have careful control over float out -of the bindings in their body. Consider this use of @runST@, - - f x = runST ( \ s -> let (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' ) - -If we inline @runST@, we'll get: - - f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -And now if we allow the @newArray#@ binding to float out to become a CAF, -we end up with a result that is totally and utterly wrong: - - f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in \ x -> - let (_, s'') = fill_in_array_or_something a x s' - in freezeArray# a s'' - -All calls to @f@ will share a {\em single} array! Clearly this is nonsense and -must be prevented. - -This is what @runRW#@ gives us: by being inlined extremely late in the -optimization (right before lowering to STG, in CorePrep), we can ensure that -no further floating will occur. This allows us to safely inline things like -@runST@, which are otherwise needlessly expensive (see #10678 and #5916). - -While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@ -to be open-kinded, - - runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) - => (State# RealWorld -> (# State# RealWorld, o #)) - -> (# State# RealWorld, o #) - - Note [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 79f378cd56..f618a60514 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -825,6 +825,7 @@ cpeApp top_env expr in cpe_app env terminal (args' ++ args) (depth + depth' - 1) cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1 | f `hasKey` runRWKey + -- See Note [runRW magic] -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this -- is why we return a CorePrepEnv as well) = case arg of @@ -918,11 +919,51 @@ isLazyExpr (Tick _ e) = isLazyExpr e isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey isLazyExpr _ = False +{- Note [runRW magic] +~~~~~~~~~~~~~~~~~~~~~ +Some definitions, for instance @runST@, must have careful control over float out +of the bindings in their body. Consider this use of @runST@, + + f x = runST ( \ s -> let (a, s') = newArray# 100 [] s + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' ) + +If we inline @runST@, we'll get: + + f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} + (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +And now if we allow the @newArray#@ binding to float out to become a CAF, +we end up with a result that is totally and utterly wrong: + + f = let (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! + in \ x -> + let (_, s'') = fill_in_array_or_something a x s' + in freezeArray# a s'' + +All calls to @f@ will share a {\em single} array! Clearly this is nonsense and +must be prevented. + +This is what @runRW#@ gives us: by being inlined extremely late in the +optimization (right before lowering to STG, in CorePrep), we can ensure that +no further floating will occur. This allows us to safely inline things like +@runST@, which are otherwise needlessly expensive (see #10678 and #5916). + +'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE +pragma. It is levity-polymorphic. + + runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r) + => (State# RealWorld -> (# State# RealWorld, o #)) + -> (# State# RealWorld, o #) + +It needs no special treatment in GHC except this special inlining here +in CorePrep (and in ByteCodeGen). + -- --------------------------------------------------------------------------- -- CpeArg: produces a result satisfying CpeArg -- --------------------------------------------------------------------------- -{- Note [ANF-ising literal string arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index fe70b3d2e0..d5fc5b3136 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -216,6 +216,7 @@ basicKnownKeyNames -- See Note [TyConRepNames for non-wired-in TyCons] ioTyConName, ioDataConName, runMainIOName, + runRWName, -- Type representation types trModuleTyConName, trModuleDataConName, @@ -886,8 +887,9 @@ and it's convenient to write them all down in one place. wildCardName :: Name wildCardName = mkSystemVarName wildCardKey (fsLit "wild") -runMainIOName :: Name +runMainIOName, runRWName :: Name runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey +runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey orderingTyConName, ltDataConName, eqDataConName, gtDataConName :: Name orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey diff --git a/libraries/ghc-prim/GHC/Magic.hs b/libraries/ghc-prim/GHC/Magic.hs index 2d4de6fb70..7d6f60e411 100644 --- a/libraries/ghc-prim/GHC/Magic.hs +++ b/libraries/ghc-prim/GHC/Magic.hs @@ -114,11 +114,10 @@ oneShot f = f runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o --- See Note [runRW magic] in MkId +-- See Note [runRW magic] in CorePrep +{-# NOINLINE runRW# #-} -- runRW# is inlined manually in CorePrep #if !defined(__HADDOCK_VERSION__) runRW# m = m realWorld# #else runRW# = runRW# -- The realWorld# is too much for haddock #endif -{-# NOINLINE runRW# #-} --- This is inlined manually in CorePrep |