[Git][ghc/ghc][wip/keepAlive] hi
Ben Gamari
gitlab at gitlab.haskell.org
Fri Apr 24 23:54:48 UTC 2020
Ben Gamari pushed to branch wip/keepAlive at Glasgow Haskell Compiler / GHC
Commits:
e2d1c152 by Ben Gamari at 2020-04-24T19:47:42-04:00
hi
- - - - -
8 changed files:
- compiler/GHC/Builtin/Names.hs
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Stg/Lint.hs
- compiler/GHC/Types/Id/Make.hs
Changes:
=====================================
compiler/GHC/Builtin/Names.hs
=====================================
@@ -2199,14 +2199,13 @@ rootMainKey, runMainKey :: Unique
rootMainKey = mkPreludeMiscIdUnique 101
runMainKey = mkPreludeMiscIdUnique 102
-thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey,
- keepAliveIdKey :: Unique
+thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey
+ :: Unique
thenIOIdKey = mkPreludeMiscIdUnique 103
lazyIdKey = mkPreludeMiscIdUnique 104
assertErrorIdKey = mkPreludeMiscIdUnique 105
oneShotKey = mkPreludeMiscIdUnique 106
runRWKey = mkPreludeMiscIdUnique 107
-keepAliveIdKey = mkPreludeMiscIdUnique 108
traceKey :: Unique
traceKey = mkPreludeMiscIdUnique 109
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3239,9 +3239,11 @@ primop SeqOp "seq#" GenPrimOp
a -> State# s -> (# State# s, a #)
-- See Note [seq# magic] in GHC.Core.Op.ConstantFold
-pseudoop "keepAlive#"
+primop KeepAliveOp "keepAlive#" GenPrimOp
o -> p -> p
{ TODO. }
+ with
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd, strictApply1Dmd] topDiv }
primop GetSparkOp "getSpark#" GenPrimOp
State# s -> (# State# s, Int#, a #)
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -927,7 +927,7 @@ lintCoreExpr e@(App _ _)
= failWithL (text "Invalid runRW# application")
| Var fun <- fun
- , fun `hasKey` keepAliveIdKey
+ , Just KeepAliveOp <- isPrimOpId_maybe f
, [arg_ty1, arg_ty2, arg_ty3, arg_ty4, arg5, arg6] <- args
= do { fun_ty6 <- lintCoreArgs (idType fun)
[ arg_ty1, arg_ty2, arg_ty3, arg_ty4, arg5 ]
@@ -936,7 +936,7 @@ lintCoreExpr e@(App _ _)
}
| Var fun <- fun
- , fun `hasKey` keepAliveIdKey
+ , Just KeepAliveOp <- isPrimOpId_maybe f
= failWithL (text "Invalid keepAlive# application")
| otherwise
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -98,7 +98,7 @@ import GHC.Types.Basic ( Arity, RecFlag(..), isRec )
import GHC.Core.DataCon ( dataConOrigResTy )
import GHC.Builtin.Types
import GHC.Types.Unique.Supply
-import GHC.Builtin.Names ( runRWKey, keepAliveIdKey )
+import GHC.Builtin.Names ( runRWKey )
import Util
import Outputable
import FastString
@@ -398,6 +398,12 @@ lvlNonTailExpr env expr
= lvlExpr (placeJoinCeiling env) expr
-------------------------------------------
+isContPrimOp :: Id -> Bool
+isContPrimOp fn
+ | fn `hasKey` runRWKey = True
+ | Just KeepAliveOp <- isPrimOpId_maybe fn = True
+ | otherwise = Falsej
+
lvlApp :: LevelEnv
-> CoreExprWithFVs
-> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
@@ -406,7 +412,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args)
-- Try to ensure that runRW#'s continuation isn't floated out.
-- See Note [Simplification of runRW#].
-- TODO: update for keepAlive#
- | fn `hasKey` runRWKey || fn `hasKey` keepAliveIdKey
+ | isContPrimOp fn
= do { args' <- mapM (lvlExpr env) args
; return (foldl' App (lookupVar env fn) args') }
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -38,7 +38,7 @@ import GHC.Core.DataCon
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
-import GHC.Builtin.Names( runRWKey, keepAliveIdKey )
+import GHC.Builtin.Names( runRWKey )
import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd
, mkClosedStrictSig, topDmd, botDiv )
import GHC.Types.Cpr ( mkCprSig, botCpr )
@@ -1956,7 +1956,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
-- keepAlive# @arg_rep @arg_ty @out_rep @out_ty x (\s -> K[rhs]) s0
rebuildContPrimop :: SimplEnv -> ArgInfo -> SimplCont -> Maybe (SimplM (SimplFloats, OutExpr))
rebuildContPrimop env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
- | fun `hasKey` keepAliveIdKey
+ | Just KeepAliveOp <- isPrimOpId_maybe fun
, [ ValArg y
, ValArg x
, TyArg {} -- res_ty
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -868,7 +868,7 @@ cpeApp top_env expr
cpe_app env (Var f) [CpeApp (Type arg_rep), CpeApp (Type arg_ty),
CpeApp (Type _result_rep), CpeApp (Type result_ty),
CpeApp x, CpeApp y] 2
- | f `hasKey` keepAliveIdKey
+ | Just KeepAliveOp <- isPrimOpId_maybe f
= do { y' <- newVar result_ty
; s2 <- newVar realWorldStatePrimTy
; let touchId = mkPrimOpId TouchOp
@@ -878,7 +878,7 @@ cpeApp top_env expr
; pprTrace "cpe_app" (ppr expr) $ cpeBody env expr
}
cpe_app _env (Var f) args n
- | f `hasKey` keepAliveIdKey
+ | Just KeepAliveOp <- isPrimOpId_maybe f
= pprPanic "cpe_app(keepAlive#)" (ppr args $$ ppr n)
cpe_app env (Var v) args depth
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -55,7 +55,6 @@ import GHC.Core.Type
import GHC.Types.RepType
import GHC.Types.SrcLoc
import GHC.Types.Unique ( hasKey )
-import GHC.Builtin.Names ( keepAliveIdKey )
import Outputable
import GHC.Types.Module ( Module )
import qualified ErrUtils as Err
@@ -106,9 +105,7 @@ lintStgArg (StgLitArg _) = return ()
lintStgArg (StgVarArg v) = lintStgVar v
lintStgVar :: Id -> LintM ()
-lintStgVar id
- | id `hasKey` keepAliveIdKey = addErrL (text "keepAlive# not permitted in STG")
- | otherwise = checkInScope id
+lintStgVar id = checkInScope id
lintStgBinds
:: (OutputablePass a, BinderP a ~ Id)
@@ -186,6 +183,9 @@ lintStgExpr app@(StgConApp con args _arg_tys) = do
mapM_ lintStgArg args
mapM_ checkPostUnariseConArg args
+lintStgExpr (StgOpApp (StgPrimOp KeepAliveOp) _ _) =
+ addErrL (text "keepAlive# should have been desugared by CorePrep")
+
lintStgExpr (StgOpApp _ args _) =
mapM_ lintStgArg args
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -158,7 +158,6 @@ ghcPrimIds
, magicDictId
, coerceId
, proxyHashId
- , keepAliveId
]
{-
@@ -1353,8 +1352,7 @@ another gun with which to shoot yourself in the foot.
nullAddrName, seqName,
realWorldName, voidPrimIdName, coercionTokenName,
- magicDictName, coerceName, proxyName,
- keepAliveName :: Name
+ magicDictName, coerceName, proxyName :: Name
nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId
seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId
realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId
@@ -1363,7 +1361,6 @@ coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionT
magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId
coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId
proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId
-keepAliveName = mkWiredInIdName gHC_PRIM (fsLit "keepAlive#") keepAliveIdKey keepAliveId
lazyIdName, oneShotName, noinlineIdName :: Name
lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId
@@ -1422,27 +1419,6 @@ seqId = pcMiscPrelId seqName ty info
rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $
Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]
-------------------------------------------------
-keepAliveId :: Id
-keepAliveId
- = pcMiscPrelId keepAliveName ty id_info
- `setIdDetails` NoBindingId
- where
- -- keepAlive#
- -- :: forall (rep_a :: RuntimeRep) (a :: TYPE rep_a)
- -- (rep_r :: RuntimeRep) (r :: TYPE rep_r).
- -- a -> r -> r
- --
- rep_a = runtimeRep1TyVar
- a = openAlphaTyVar
- rep_r = runtimeRep2TyVar
- r = openBetaTyVar
- ty = mkInvForAllTys [rep_a, a, rep_r, r]
- $ mkVisFunTys [mkTyVarTy a, mkTyVarTy r] (mkTyVarTy r)
- id_info = noCafIdInfo
- `setStrictnessInfo` mkClosedStrictSig [topDmd, strictApply1Dmd, topDmd] topDiv
- `setArityInfo` 3
-
------------------------------------------------
lazyId :: Id -- See Note [lazyId magic]
lazyId = pcMiscPrelId lazyIdName ty info
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2d1c15280223204390ad37c4d0ecbbf9a1348fb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e2d1c15280223204390ad37c4d0ecbbf9a1348fb
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/20200424/007bd55a/attachment-0001.html>
More information about the ghc-commits
mailing list