[Git][ghc/ghc][wip/keepAlive] 6 commits: XXX: Don't apply Note [dodgy unsafeCoerce 1] to join points
Ben Gamari
gitlab at gitlab.haskell.org
Tue Apr 28 14:00:49 UTC 2020
Ben Gamari pushed to branch wip/keepAlive at Glasgow Haskell Compiler / GHC
Commits:
3a3b8290 by Ben Gamari at 2020-04-25T00:39:40+00:00
XXX: Don't apply Note [dodgy unsafeCoerce 1] to join points
- - - - -
0aab3dc6 by Ben Gamari at 2020-04-27T20:13:36+00:00
A new approach
To avoid violating the let/app invariant we now give keepAlive# the
type:
keepAlive# :: o -> State# RW -> (State# RW -> p) -> p
The awkward argument ordering probably ought to be changed but was
driven by a desire to stay as close to runRW's implementation as
possible for the time being.
- - - - -
999419ec by Ben Gamari at 2020-04-27T23:44:06+00:00
Fix occur analysis
- - - - -
d43307b5 by Ben Gamari at 2020-04-28T02:42:12+00:00
Fix warning
- - - - -
00d7411a by Ben Gamari at 2020-04-28T02:42:34+00:00
Fix eta expansion
- - - - -
d7c7772e by Ben Gamari at 2020-04-28T02:42:53+00:00
Fix potential loop
- - - - -
15 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/OccurAnal.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/StgToCmm/Expr.hs
- + compiler/GHC/StgToCmm/Expr.hs-boot
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/Types/Id/Make.hs
- libraries/base/Foreign/Marshal/Alloc.hs
- libraries/base/GHC/ForeignPtr.hs
- libraries/ghc-compact/GHC/Compact/Serialized.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -89,7 +89,7 @@ defaults
-- conditions. Now that `foreign import prim` exists, only those primops
-- which have both internal and external implementations ought to be
-- this file. The rest aren't really primops, since they don't need
--- bespoke compiler support but just a general way to interface with
+-- bespoke iompiler support but just a general way to interface with
-- C--. They are just foreign calls.
--
-- Unfortunately, for the time being most of the primops which should be
@@ -3240,10 +3240,10 @@ primop SeqOp "seq#" GenPrimOp
-- See Note [seq# magic] in GHC.Core.Op.ConstantFold
primop KeepAliveOp "keepAlive#" GenPrimOp
- o -> p -> p
+ o -> State# RealWorld -> (State# RealWorld -> p) -> p
{ TODO. }
with
- strictness = { \ _arity -> mkClosedStrictSig [topDmd, strictApply1Dmd] topDiv }
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictApply1Dmd] topDiv }
primop GetSparkOp "getSpark#" GenPrimOp
State# s -> (# State# s, Int#, a #)
=====================================
compiler/GHC/Core.hs
=====================================
@@ -450,7 +450,7 @@ which will generate a @case@ if necessary
The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in
GHC.Core.Make.
-For discussion of some implications of the let/app invariant primops see
+For discussion of some implications of the let/app invariant on primops see
Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.
Note [Case expression invariants]
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.Opt.Monad
import Bag
import GHC.Types.Literal
import GHC.Core.DataCon
+import GHC.Builtin.PrimOps ( PrimOp(KeepAliveOp) )
import GHC.Builtin.Types.Prim
import GHC.Tc.Utils.TcType ( isFloatingTy )
import GHC.Types.Var as Var
@@ -927,16 +928,30 @@ lintCoreExpr e@(App _ _)
= failWithL (text "Invalid runRW# application")
| Var fun <- fun
- , 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 ]
- ; arg6_ty <- lintJoinLams 0 (Just fun) arg6 -- f :: State# RW -> (# State# RW, o #)
- ; lintValApp arg6 fun_ty6 arg6_ty
+ , Just KeepAliveOp <- isPrimOpId_maybe fun
+ , arg_rep : arg_ty : res_rep : res_ty : arg : s : k : rest <- args
+ = pprTrace "keepAlive Lint" empty $
+ do { fun_ty1 <- lintCoreArgs (idType fun)
+ [ arg_rep, arg_ty, res_rep, res_ty, arg, s ]
+ ; let lintRunRWCont :: CoreArg -> LintM LintedType
+ lintRunRWCont (Cast expr co) = do
+ ty <- lintRunRWCont expr
+ lintCastExpr expr ty co
+ lintRunRWCont expr@(Lam _ _) = do
+ lintJoinLams 1 (Just fun) expr
+ lintRunRWCont (Var v)
+ | isJoinId v
+ , idJoinArity v == 1
+ = return (idType v)
+ lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other
+ -- TODO: Look through ticks?
+ ; k_ty <- lintRunRWCont k
+ ; fun_ty2 <- lintValApp k fun_ty1 k_ty
+ ; lintCoreArgs fun_ty2 rest
}
| Var fun <- fun
- , Just KeepAliveOp <- isPrimOpId_maybe f
+ , Just KeepAliveOp <- isPrimOpId_maybe fun
= failWithL (text "Invalid keepAlive# application")
| otherwise
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -40,6 +40,7 @@ import Digraph ( SCC(..), Node(..)
, stronglyConnCompFromEdgedVerticesUniq
, stronglyConnCompFromEdgedVerticesUniqR )
import GHC.Builtin.Names( runRWKey )
+import GHC.Builtin.PrimOps( PrimOp(KeepAliveOp) )
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
@@ -1890,6 +1891,14 @@ occAnalApp env (Var fun, args, ticks)
, let (usage, arg') = occAnalRhs env (Just 1) arg
= (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
+ | Just KeepAliveOp <- isPrimOpId_maybe fun
+ , [r1, t1, r2, t2, x, s, k] <- args
+ , let (usages, xs) = occAnalArgs env [r1, t1, r2, t2, x, s] [[], []]
+ , let (k_usage, k') = occAnalRhs env (Just 1) k
+ = ( markAllNonTailCalled usages `andUDs` k_usage
+ , mkTicks ticks $ mkApps (Var fun) (xs ++ [k'])
+ )
+
| otherwise
= (all_uds, mkTicks ticks $ mkApps fun' args')
where
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -96,9 +96,10 @@ import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType
, mightBeUnliftedType, closeOverKindsDSet )
import GHC.Types.Basic ( Arity, RecFlag(..), isRec )
import GHC.Core.DataCon ( dataConOrigResTy )
+import GHC.Builtin.Names ( runRWKey )
+import GHC.Builtin.PrimOps ( PrimOp(KeepAliveOp) )
import GHC.Builtin.Types
import GHC.Types.Unique.Supply
-import GHC.Builtin.Names ( runRWKey )
import Util
import Outputable
import FastString
@@ -402,7 +403,7 @@ isContPrimOp :: Id -> Bool
isContPrimOp fn
| fn `hasKey` runRWKey = True
| Just KeepAliveOp <- isPrimOpId_maybe fn = True
- | otherwise = Falsej
+ | otherwise = False
lvlApp :: LevelEnv
-> CoreExprWithFVs
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -37,8 +37,9 @@ import GHC.Core.DataCon
, StrictnessMark (..) )
import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
import GHC.Core
-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
+import GHC.Builtin.PrimOps ( PrimOp(SeqOp, KeepAliveOp) )
import GHC.Builtin.Names( runRWKey )
+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd
, mkClosedStrictSig, topDmd, botDiv )
import GHC.Types.Cpr ( mkCprSig, botCpr )
@@ -61,7 +62,6 @@ import FastString
import Util
import ErrUtils
import GHC.Types.Module ( moduleName, pprModuleName )
-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
{-
@@ -1955,9 +1955,11 @@ 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
+rebuildContPrimop env (ArgInfo { ai_fun = fun, ai_args = rev_args })
+ (ApplyToVal { sc_arg = k, sc_env = k_se, sc_cont = cont})
| Just KeepAliveOp <- isPrimOpId_maybe fun
- , [ ValArg y
+ , not (contIsStop cont) -- Don't fiddle around if the continuation is boring
+ , [ ValArg s0
, ValArg x
, TyArg {} -- res_ty
, TyArg {} -- res_rep
@@ -1965,27 +1967,30 @@ rebuildContPrimop env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
, TyArg {as_arg_ty=arg_rep}
] <- rev_args
= Just $ do
- { let ty' = contResultType cont
- ; j <- newJoinId [] ty'
+ { s <- newId (fsLit "s") realWorldStatePrimTy
+ ; let k_env = (k_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ k_cont = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
+ , sc_env = k_env, sc_cont = cont }
+ ; k' <- simplExprC k_env k k_cont
; let env' = zapSubstEnv env
- ; y' <- simplExprC env' y cont
- ; let bind = NonRec j y'
+ ; s0' <- simplExpr env' s0
; x' <- simplExpr env' x
; arg_rep' <- simplType env' arg_rep
; arg_ty' <- simplType env' arg_ty
- ; let call' = mkApps (Var fun)
+ ; let ty' = contResultType cont
+ call' = mkApps (Var fun)
[ mkTyArg arg_rep', mkTyArg arg_ty'
, mkTyArg (getRuntimeRep ty'), mkTyArg ty'
, x'
- , Var j
+ , s0'
+ , Lam s k'
]
- ; --pprTrace "rebuild keepAlive" (ppr fun $$ ppr rev_args $$ ppr cont) $
- return (emptyFloats env `extendFloats` bind, call') }
+ ; return (emptyFloats env, call') }
-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
-- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ])
rebuildContPrimop env (ArgInfo { ai_fun = fun, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont })
| fun `hasKey` runRWKey
, not (contIsStop cont) -- Don't fiddle around if the continuation is boring
, [ TyArg {}, TyArg {} ] <- rev_args
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -24,9 +24,9 @@ import GHC.Core.Opt.OccurAnal
import GHC.Driver.Types
import GHC.Builtin.Names
-import GHC.Builtin.PrimOps ( PrimOp(TouchOp) )
import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
-import GHC.Types.Id.Make ( mkPrimOpId, realWorldPrimId )
+import GHC.Builtin.PrimOps ( PrimOp(KeepAliveOp) )
+import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Core.Utils
import GHC.Core.Arity
import GHC.Core.FVs
@@ -58,7 +58,7 @@ import GHC.Driver.Ways
import Util
import Outputable
import FastString
-import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName )
+import GHC.Types.Name ( mkSystemVarName, NamedThing(..), nameSrcSpan, isInternalName )
import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
import Data.Bits
import MonadUtils ( mapAccumLM )
@@ -781,18 +781,10 @@ runRW# strict (which we do in GHC.Types.Id.Make), this can't happen
Note [CorePrep handling of keepAlive#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Lower keepAlive# applications to touch#. Specifically:
+TODO
keepAlive# @a @r @b x k s0
-is lowered to:
-
- case k s of _b0 { (# y, s1 #) ->
- case touch# @a x s1 of s2 { _ ->
- (# y, s2 #)
- }
- }
-
-}
cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
@@ -866,16 +858,30 @@ cpeApp top_env expr
-- See Note [CorePrep handling of keepAlive#]
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
+ CpeApp (Type result_rep), CpeApp (Type result_ty),
+ CpeApp x, CpeApp s, CpeApp y] _n
| Just KeepAliveOp <- isPrimOpId_maybe f
- = do { y' <- newVar result_ty
- ; s2 <- newVar realWorldStatePrimTy
- ; let touchId = mkPrimOpId TouchOp
- expr = Case y y' result_ty [(DEFAULT, [], rhs1)]
- rhs1 = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, x, Var realWorldPrimId]
- in Case scrut s2 result_ty [(DEFAULT, [], Var y')]
- ; pprTrace "cpe_app" (ppr expr) $ cpeBody env expr
+ = do { uniq <- getUniqueM
+ ; let name = mkSystemVarName uniq (fsLit "$j")
+ ty = (mkVisFunTy realWorldStatePrimTy result_ty)
+ id_info = vanillaIdInfo `setArityInfo` 1
+ bndr = mkLocalVar (JoinId 1) name ty id_info
+ -- We need to transform the application into ANF so we must bind
+ -- the continuation. However, since it might contain join points
+ -- we must join-bind it. We must eta expand to ensure that we meet
+ -- the required join arity.
+ ; (bndr', rhs) <- cpeJoinPair env bndr $ case etaExpandToJoinPoint 1 y of
+ (bndrs, body) -> mkLams bndrs body
+ ; (x_floats, x') <- cpeArg env evalDmd x arg_ty
+ ; (s_floats, s') <- cpeArg env evalDmd s realWorldStatePrimTy
+ ; let body = pprTrace "cpe_app" (ppr expr) $
+ Let (NonRec bndr' rhs) $
+ mkApps (Var f)
+ [ Type arg_rep, Type arg_ty
+ , Type result_rep, Type result_ty
+ , x', s', Var bndr
+ ]
+ ; return (x_floats `appendFloats` s_floats, body)
}
cpe_app _env (Var f) args n
| Just KeepAliveOp <- isPrimOpId_maybe f
=====================================
compiler/GHC/Stg/Lint.hs
=====================================
@@ -54,7 +54,6 @@ import ErrUtils ( MsgDoc, Severity(..), mkLocMessage )
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Types.SrcLoc
-import GHC.Types.Unique ( hasKey )
import Outputable
import GHC.Types.Module ( Module )
import qualified ErrUtils as Err
@@ -183,9 +182,6 @@ 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/StgToCmm/Expr.hs
=====================================
@@ -364,6 +364,7 @@ assignment.
-}
cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
| isUnliftedType (idType v) -- Note [Dodgy unsafeCoerce 1]
+ , not $ isJoinId v -- TODO: necessary as idInfoToAmode panics on LneLoc
= -- assignment suffices for unlifted types
do { platform <- getPlatform
; unless (reps_compatible platform) $
=====================================
compiler/GHC/StgToCmm/Expr.hs-boot
=====================================
@@ -0,0 +1,6 @@
+module GHC.StgToCmm.Expr ( cgExpr ) where
+
+import GHC.Stg.Syntax
+import GHC.StgToCmm.Monad
+
+cgExpr :: CgStgExpr -> FCode ReturnKind
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -26,6 +26,7 @@ module GHC.StgToCmm.Prim (
import GhcPrelude hiding ((<*>))
+import {-# SOURCE #-} GHC.StgToCmm.Expr ( cgExpr )
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Foreign
import GHC.StgToCmm.Env
@@ -38,6 +39,7 @@ import GHC.StgToCmm.Prof ( costCentreFrom )
import GHC.Driver.Session
import GHC.Platform
import GHC.Types.Basic
+import GHC.Types.Id.Make ( realWorldPrimId )
import GHC.Cmm.BlockId
import GHC.Cmm.Graph
import GHC.Stg.Syntax
@@ -82,6 +84,16 @@ cgOpApp (StgFCallOp fcall ty) stg_args res_ty
= cgForeignCall fcall ty stg_args res_ty
-- Note [Foreign call results]
+cgOpApp (StgPrimOp KeepAliveOp) args _res_ty
+ | [x, s, StgVarArg k] <- args = do
+ { emitComment $ fsLit "keepAlive#"
+ ; r <- cgExpr (StgApp k [s])
+ ; cmm_args <- getNonVoidArgAmodes [x, StgVarArg realWorldPrimId]
+ ; emitPrimCall [] MO_Touch cmm_args
+ ; return r
+ }
+ | otherwise = pprPanic "ill-formed keepAlive#" (ppr args)
+
cgOpApp (StgPrimOp primop) args res_ty = do
dflags <- getDynFlags
cmm_args <- getNonVoidArgAmodes args
@@ -1522,6 +1534,8 @@ emitPrimOp dflags = \case
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ KeepAliveOp -> panic "keepAlive# should have been desugared by CorePrep"
+
where
platform = targetPlatform dflags
alwaysExternal = \_ -> PrimopCmmEmit_External
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -76,7 +76,7 @@ import GHC.Driver.Session
import Outputable
import FastString
import ListSetOps
-import GHC.Types.Var (VarBndr(Bndr), setIdDetails)
+import GHC.Types.Var (VarBndr(Bndr))
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe ( maybeToList )
=====================================
libraries/base/Foreign/Marshal/Alloc.hs
=====================================
@@ -68,7 +68,6 @@ import GHC.IO.Exception
import GHC.Real
import GHC.Ptr
import GHC.Base
-import GHC.Prim ( keepAlive# )
-- exported functions
-- ------------------
@@ -131,7 +130,7 @@ allocaBytes (I# size) action = IO $ \ s0 ->
case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
let addr = Ptr (byteArrayContents# barr#) in
case action addr of { IO action' ->
- keepAlive# barr# (action' s2)
+ keepAlive# barr# s2 action'
}}}
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
@@ -140,7 +139,7 @@ allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
let addr = Ptr (byteArrayContents# barr#) in
case action addr of { IO action' ->
- keepAlive# barr# (action' s2)
+ keepAlive# barr# s2 action'
}}}
-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
=====================================
libraries/base/GHC/ForeignPtr.hs
=====================================
@@ -55,7 +55,6 @@ import GHC.Base
import GHC.IORef
import GHC.STRef ( STRef(..) )
import GHC.Ptr ( Ptr(..), FunPtr(..) )
-import GHC.Prim ( keepAlive# )
import Unsafe.Coerce ( unsafeCoerce, unsafeCoerceUnlifted )
@@ -412,7 +411,7 @@ withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
-- 'Storable' class.
withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->
case f (unsafeForeignPtrToPtr fo) of
- IO action# -> keepAlive# r (action# s)
+ IO action# -> keepAlive# r s action#
touchForeignPtr :: ForeignPtr a -> IO ()
=====================================
libraries/ghc-compact/GHC/Compact/Serialized.hs
=====================================
@@ -90,7 +90,7 @@ withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do
(# s', rootAddr #) -> (# s', Ptr rootAddr #) )
blockList <- mkBlockList buffer
let serialized = SerializedCompact blockList rootPtr
- IO (\s1 -> case func serialized of IO action' -> keepAlive# buffer (action' s1))
+ IO (\s1 -> case func serialized of IO action' -> keepAlive# buffer s1 action')
fixupPointers :: Addr# -> Addr# -> State# RealWorld ->
(# State# RealWorld, Maybe (Compact a) #)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e2d1c15280223204390ad37c4d0ecbbf9a1348fb...d7c7772eccd9a3c9e3e0882a935f232f42f5b3f0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e2d1c15280223204390ad37c4d0ecbbf9a1348fb...d7c7772eccd9a3c9e3e0882a935f232f42f5b3f0
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/20200428/3ef84afa/attachment-0001.html>
More information about the ghc-commits
mailing list