[Git][ghc/ghc][wip/keepAlive-optionB] 14 commits: testsuite: A few minor perf notes fixes
Ben Gamari
gitlab at gitlab.haskell.org
Fri Sep 11 16:58:50 UTC 2020
Ben Gamari pushed to branch wip/keepAlive-optionB at Glasgow Haskell Compiler / GHC
Commits:
8546d595 by GHC GitLab CI at 2020-09-11T15:48:25+00:00
testsuite: A few minor perf notes fixes
- - - - -
ac5a62c6 by Ben Gamari at 2020-09-11T16:00:45+00:00
genprimopcode: Add a second levity-polymorphic tyvar
- - - - -
1e15c7f1 by GHC GitLab CI at 2020-09-11T16:00:45+00:00
keepAlive primop
- - - - -
c28ce393 by Ben Gamari at 2020-09-11T16:00:45+00:00
base: Use keepAlive# in alloca, et al.
- - - - -
3da4865f by GHC GitLab CI at 2020-09-11T16:00:45+00:00
Simplify: Factor out runRW rule
- - - - -
459dc1da by GHC GitLab CI at 2020-09-11T16:00:45+00:00
Simplify
- - - - -
2e1f1254 by GHC GitLab CI at 2020-09-11T16:00:45+00:00
hadrian: Don't include -fdiagnostics-color in argument hash
Otherwise the input hash will vary with whether colors are requested,
which changed with `isatty`.
Fixes #17983.
- - - - -
f41ff8c0 by Ben Gamari at 2020-09-11T16:00:45+00:00
base: Use keepAlive# in withForeignPtr
- - - - -
7461cdc1 by GHC GitLab CI at 2020-09-11T16:00:45+00:00
base: Make ForeignPtrContents of ForeignPtr strict
As mentioned in #17290, there are strong benefits to the
`ForeignPtrContents` field of `ForeignPtr` being strict. In particular,
when looking at the reproducer for #17746, I noticed that the
`ForeignPtrContents` was being allocated on every call to
`withForeignPtr` just to be `touch#`'d'. This is a pretty large
overhead for something like `withForeignPtr` that should be free.
This required updating the `bytestring` submodule to avoid a bottoming
`ForeignPtrContents` in `Data.ByteString.Internal`
Fixes #17290.
- - - - -
742f9d60 by GHC GitLab CI at 2020-09-11T16:00:45+00:00
Clarify types of splitFunTy
- - - - -
1546c02a by GHC GitLab CI at 2020-09-11T16:00:45+00:00
Lint
- - - - -
eba1b94a by GHC GitLab CI at 2020-09-11T16:00:46+00:00
Simplify
- - - - -
c2974e07 by GHC GitLab CI at 2020-09-11T16:00:46+00:00
simplify
- - - - -
63f502b4 by GHC GitLab CI at 2020-09-11T16:00:46+00:00
Eliminate spurious ForeignPtrContents allocations
- - - - -
16 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/StgToCmm/Prim.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Target.hs
- libraries/base/Foreign/ForeignPtr/Imp.hs
- libraries/base/Foreign/Marshal/Alloc.hs
- libraries/base/GHC/ForeignPtr.hs
- libraries/bytestring
- testsuite/driver/perf_notes.py
- testsuite/driver/runtests.py
- utils/genprimopcode/Main.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3320,6 +3320,20 @@ primop NumSparks "numSparks#" GenPrimOp
has_side_effects = True
out_of_line = True
+
+------------------------------------------------------------------------
+section "Controlling object lifetime"
+ {Ensuring that objects don't die a premature death.}
+------------------------------------------------------------------------
+
+-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.
+primop KeepAliveOp "keepAlive#" GenPrimOp
+ o -> State# RealWorld -> (State# RealWorld -> p) -> p
+ { TODO. }
+ with
+ strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictApply1Dmd] topDiv }
+
+
------------------------------------------------------------------------
section "Tag to enum stuff"
{Convert back and forth between values of enumerated types
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.Opt.Monad
import GHC.Data.Bag
import GHC.Types.Literal
import GHC.Core.DataCon
+import GHC.Builtin.PrimOps ( PrimOp(KeepAliveOp) )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types ( multiplicityTy )
import GHC.Tc.Utils.TcType ( isFloatingTy, isTyFamFree )
@@ -910,17 +911,33 @@ lintCoreExpr e@(Let (Rec pairs) body)
bndrs = map fst pairs
lintCoreExpr e@(App _ _)
- | Var fun <- fun
- , fun `hasKey` runRWKey
+ -- Special linting for keepAlive#
+ | Var fun_id <- fun
+ , Just KeepAliveOp <- isPrimOpId_maybe fun_id
+ , arg_rep : arg_ty : k_rep : k_ty : arg : s : k : rest <- args
+ = do { (fun_ty1, ue1) <- lintCoreArgs (idType fun_id, zeroUE) [arg_rep, arg_ty, k_rep, k_ty, arg, s]
+ -- See Note [Linting of runRW#]
+ ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
+ lintRunRWCont expr@(Lam _ _) = do
+ lintJoinLams 1 (Just fun_id) expr
+ lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other
+ -- TODO: Look through ticks?
+ ; (arg2_ty, ue2) <- lintRunRWCont k
+ ; app_ty <- lintValApp k fun_ty1 arg2_ty ue1 ue2
+ ; lintCoreArgs app_ty rest }
+
+ -- Special linting for runRW#
+ | Var fun_id <- fun
+ , fun_id `hasKey` runRWKey
-- N.B. we may have an over-saturated application of the form:
-- runRW (\s -> \x -> ...) y
, arg_ty1 : arg_ty2 : arg3 : rest <- args
- = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) arg_ty1
+ = do { fun_pair1 <- lintCoreArg (idType fun_id, zeroUE) arg_ty1
; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2
-- See Note [Linting of runRW#]
; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)
lintRunRWCont expr@(Lam _ _) = do
- lintJoinLams 1 (Just fun) expr
+ lintJoinLams 1 (Just fun_id) expr
lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other
-- TODO: Look through ticks?
; (arg3_ty, ue3) <- lintRunRWCont arg3
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -68,7 +68,7 @@ import GHC.Utils.Misc
import GHC.Utils.Error
import GHC.Unit.Module ( moduleName, pprModuleName )
import GHC.Core.Multiplicity
-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
+import GHC.Builtin.PrimOps ( PrimOp (SeqOp, KeepAliveOp) )
{-
@@ -1975,29 +1975,9 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
= rebuildCall env (addTyArgTo info arg_ty hole_ty) cont
---------- The runRW# rule. Do this after absorbing all arguments ------
--- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.
---
--- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
--- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])
-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
- (ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_cont = cont, sc_hole_ty = fun_ty })
- | fun_id `hasKey` runRWKey
- , not (contIsStop cont) -- Don't fiddle around if the continuation is boring
- , [ TyArg {}, TyArg {} ] <- rev_args
- = do { s <- newId (fsLit "s") Many realWorldStatePrimTy
- ; let (m,_,_) = splitFunTy fun_ty
- env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
- ty' = contResultType cont
- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
- , sc_env = env', sc_cont = cont
- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
- -- cont' applies to s, then K
- ; body' <- simplExprC env' arg cont'
- ; let arg' = Lam s body'
- rr' = getRuntimeRep ty'
- call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
- ; return (emptyFloats env, call') }
+rebuildCall env arg_info cont
+ | Just do_it <- rebuildContOpCall env arg_info cont
+ = do_it
rebuildCall env fun_info
(ApplyToVal { sc_arg = arg, sc_env = arg_se
@@ -2034,6 +2014,88 @@ rebuildCall env fun_info
rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
= rebuild env (argInfoExpr fun rev_args) cont
+-- | Simplifications of runRW# and keepAlive#
+rebuildContOpCall :: SimplEnv -> ArgInfo -> SimplCont -> Maybe (SimplM (SimplFloats, OutExpr))
+rebuildContOpCall _env _arg_info cont
+ | contIsStop cont -- Don't fiddle around if the continuation is boring
+ = Nothing
+
+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.
+--
+-- N.B. runRW# :: forall (r :: RuntimeRep) (o :: TYPE r).
+-- (State# RealWorld -> o) -> o
+--
+-- K[ runRW# rr ty body ]
+-- ~>
+-- runRW rr' ty' (\s. K[ body s ])
+rebuildContOpCall
+ env
+ (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
+ (ApplyToVal { sc_arg = arg, sc_env = arg_se
+ , sc_cont = cont, sc_hole_ty = fun_ty })
+ | fun_id `hasKey` runRWKey
+ , [ TyArg {}, TyArg {} ] <- rev_args
+ = Just $
+ do { s <- newId (fsLit "s") Many realWorldStatePrimTy
+ ; let (m,_,_) = splitFunTy fun_ty
+ env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ ty' = contResultType cont
+ k'_ty = mkVisFunTy m realWorldStatePrimTy ty'
+ cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
+ , sc_env = env', sc_cont = cont
+ , sc_hole_ty = k'_ty }
+ -- cont' applies to s, then K
+ ; body' <- simplExprC env' arg cont'
+ ; let arg' = Lam s body'
+ rr' = getRuntimeRep ty'
+ call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']
+ ; return (emptyFloats env, call') }
+
+-- See Note [Simplification of keepAlive#] in GHC.CoreToStg.Prep.
+--
+-- K[keepAlive# @a_rep @a @r_rep @r x s k]
+-- ~>
+-- keepAlive# @a_rep @a @r_rep @r x s K[k]
+rebuildContOpCall
+ env
+ (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
+ (ApplyToVal { sc_arg = k, sc_env = k_se
+ , sc_cont = cont })
+ | Just KeepAliveOp <- isPrimOpId_maybe fun_id
+ , [ ValArg {as_arg=s0}
+ , ValArg {as_arg=x}
+ , TyArg {} -- res_ty
+ , TyArg {} -- res_rep
+ , TyArg {as_arg_ty=arg_ty}
+ , TyArg {as_arg_ty=arg_rep}
+ ] <- rev_args
+ = Just $
+ do { --let (m,_,_) = splitFunTy fun_ty
+ let m = Many
+ ; s <- newId (fsLit "s") m realWorldStatePrimTy
+ ; let k_env = (k_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+ ty' = contResultType cont
+ k'_ty = mkVisFunTy m realWorldStatePrimTy ty'
+ k_cont = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
+ , sc_env = k_env, sc_cont = cont
+ , sc_hole_ty = k'_ty }
+ ; k' <- simplExprC k_env k k_cont
+ ; let env' = zapSubstEnv env
+ ; 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_id)
+ [ mkTyArg arg_rep', mkTyArg arg_ty'
+ , mkTyArg (getRuntimeRep ty'), mkTyArg ty'
+ , x'
+ , s0'
+ , Lam s k'
+ ]
+ ; return (emptyFloats env, call') }
+
+rebuildContOpCall _ _ _ = Nothing
+
{- Note [Trying rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1120,14 +1120,15 @@ In the compiler we maintain the invariant that all saturated applications of
See #11714.
-}
-splitFunTy :: Type -> (Type, Type, Type)
--- ^ Attempts to extract the argument and result types from a type, and
--- panics if that is not possible. See also 'splitFunTy_maybe'
+splitFunTy :: Type -> (Mult, Type, Type)
+-- ^ Attempts to extract the multiplicity, argument and result types from a
+-- type, and panics if that is not possible. See also 'splitFunTy_maybe'
splitFunTy = expectJust "splitFunTy" . splitFunTy_maybe
{-# INLINE splitFunTy_maybe #-}
-splitFunTy_maybe :: Type -> Maybe (Type, Type, Type)
--- ^ Attempts to extract the argument and result types from a type
+splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type)
+-- ^ Attempts to extract the multiplicity, argument and result types from a
+-- type.
splitFunTy_maybe ty
| FunTy _ w arg res <- coreFullView ty = Just (w, arg, res)
| otherwise = Nothing
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1644,6 +1644,8 @@ app_ok primop_ok fun args
-> False -- for the special cases for SeqOp and DataToTagOp
| DataToTagOp <- op
-> False
+ | KeepAliveOp <- op
+ -> False
| otherwise
-> primop_ok op -- Check the primop itself
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -26,7 +26,8 @@ import GHC.Core.Opt.OccurAnal
import GHC.Driver.Types
import GHC.Driver.Ppr
import GHC.Builtin.Names
-import GHC.Types.Id.Make ( realWorldPrimId )
+import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
+import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )
import GHC.Core.Utils
import GHC.Core.Opt.Arity
import GHC.Core.FVs
@@ -46,6 +47,7 @@ import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Builtin.Types
+import GHC.Builtin.PrimOps
import GHC.Core.DataCon
import GHC.Types.Basic
import GHC.Unit
@@ -775,6 +777,38 @@ cpeApp top_env expr
-- rather than the far superior "f x y". Test case is par01.
= let (terminal, args', depth') = collect_args arg
in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
+
+ cpe_app env
+ (Var f)
+ args
+ n
+ | Just KeepAliveOp <- isPrimOpId_maybe f
+ , CpeApp (Type arg_rep)
+ : CpeApp (Type arg_ty)
+ : CpeApp (Type _result_rep)
+ : CpeApp (Type result_ty)
+ : CpeApp arg
+ : CpeApp s0
+ : CpeApp k
+ : rest <- pprTrace "cpe_app keepAlive#" (ppr args) args
+ = do { pprTraceM "cpe_app(keepAlive#)" (ppr n)
+ ; y <- newVar result_ty
+ ; s2 <- newVar realWorldStatePrimTy
+ ; -- beta reduce if possible
+ ; (floats, k') <- case k of
+ Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2)
+ _ -> cpe_app env k (CpeApp s0 : rest) (n-1)
+ ; let touchId = mkPrimOpId TouchOp
+ expr = Case k' y result_ty [(DEFAULT, [], rhs)]
+ rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]
+ in Case scrut s2 result_ty [(DEFAULT, [], Var y)]
+ ; pprTraceM "cpe_app(keepAlive)" (ppr expr)
+ ; (floats', expr') <- cpeBody env expr
+ ; return (floats `appendFloats` floats', expr')
+ }
+ | Just KeepAliveOp <- isPrimOpId_maybe f
+ = panic "invalid keepAlive# application"
+
cpe_app env (Var f) (CpeApp _runtimeRep at Type{} : CpeApp _type at Type{} : CpeApp arg : rest) n
| f `hasKey` runRWKey
-- N.B. While it may appear that n == 1 in the case of runRW#
@@ -1064,10 +1098,26 @@ Breaking our desired invariant. Ultimately we decided to simply accept that
the continuation may not be a manifest lambda.
+Note [Simplification of keepAlive#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The keepAlive# primop benefits from a similar optimisation to that described in
+Note [Simplification of runRW#] above. Specifically, we transform:
+
+ K[keepAlive# @a_rep @a @r_rep @r x s k]
+ ~>
+ keepAlive# @a_rep @a @r_rep @r x s K[k]
+
+The reasons are similar to those described in Note [Simplification of runRW#].
+
+-}
+
+
-- ---------------------------------------------------------------------------
-- CpeArg: produces a result satisfying CpeArg
-- ---------------------------------------------------------------------------
+{-
Note [ANF-ising literal string arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1518,6 +1518,8 @@ emitPrimOp dflags primop = case primop of
TraceMarkerOp -> alwaysExternal
SetThreadAllocationCounter -> alwaysExternal
+ KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"
+
where
profile = targetProfile dflags
platform = profilePlatform profile
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -35,6 +35,9 @@ compileAndLinkHs = (builder (Ghc CompileHs) ||^ builder (Ghc LinkHs)) ? do
hasDynamic = elem dynamic ways
mconcat [ arg "-Wall"
, not useColor ? builder (Ghc CompileHs) ?
+ -- N.B. Target.trackArgument ignores this argument from the
+ -- input hash to avoid superfluous recompilation, avoiding
+ -- #18672.
arg "-fdiagnostics-color=never"
, (hasVanilla && hasDynamic) ? builder (Ghc CompileHs) ?
platformSupportsSharedLibs ? way vanilla ?
=====================================
hadrian/src/Target.hs
=====================================
@@ -21,11 +21,12 @@ type Target = H.Target Context Builder
trackArgument :: Target -> String -> Bool
trackArgument target arg = case builder target of
Make _ -> not $ threadArg arg
- Ghc _ _ -> not $ verbosityArg arg
+ Ghc _ _ -> not $ verbosityArg arg || diagnosticsColorArg arg
Cabal _ _ -> not $ verbosityArg arg || cabal_configure_ignore arg
_ -> True
where
threadArg s = dropWhileEnd isDigit s `elem` ["-j", "MAKEFLAGS=-j", "THREADS="]
verbosityArg s = dropWhileEnd isDigit s == "-v"
+ diagnosticsColorArg s = "-fdiagnostics-color=" `isPrefixOf` s -- N.B. #18672
cabal_configure_ignore s =
s `elem` [ "--configure-option=--quiet", "--configure-option=--disable-option-checking" ]
=====================================
libraries/base/Foreign/ForeignPtr/Imp.hs
=====================================
@@ -66,31 +66,6 @@ newForeignPtr finalizer p
addForeignPtrFinalizer finalizer fObj
return fObj
-withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
--- ^This is a way to look at the pointer living inside a
--- foreign object. This function takes a function which is
--- applied to that pointer. The resulting 'IO' action is then
--- executed. The foreign object is kept alive at least during
--- the whole action, even if it is not used directly
--- inside. Note that it is not safe to return the pointer from
--- the action and use it after the action completes. All uses
--- of the pointer should be inside the
--- 'withForeignPtr' bracket. The reason for
--- this unsafeness is the same as for
--- 'unsafeForeignPtrToPtr' below: the finalizer
--- may run earlier than expected, because the compiler can only
--- track usage of the 'ForeignPtr' object, not
--- a 'Ptr' object made from it.
---
--- This function is normally used for marshalling data to
--- or from the object pointed to by the
--- 'ForeignPtr', using the operations from the
--- 'Storable' class.
-withForeignPtr fo io
- = do r <- io (unsafeForeignPtrToPtr fo)
- touchForeignPtr fo
- return r
-
-- | This variant of 'newForeignPtr' adds a finalizer that expects an
-- environment in addition to the finalized pointer. The environment
-- that will be passed to the finalizer is fixed by the second argument to
=====================================
libraries/base/Foreign/Marshal/Alloc.hs
=====================================
@@ -116,19 +116,6 @@ alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b
alloca =
allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a))
--- Note [NOINLINE for touch#]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously
--- fragile in the presence of simplification (see #14346). In particular, the
--- simplifier may drop the continuation containing the touch# if it can prove
--- that the action passed to allocaBytes will not return. The hack introduced to
--- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the
--- simplifier can't see the divergence.
---
--- These can be removed once #14375 is fixed, which suggests that we instead do
--- away with touch# in favor of a primitive that will capture the scoping left
--- implicit in the case of touch#.
-
-- |@'allocaBytes' n f@ executes the computation @f@, passing as argument
-- a pointer to a temporarily allocated block of memory of @n@ bytes.
-- The block of memory is sufficiently aligned for any of the basic
@@ -142,13 +129,9 @@ allocaBytes (I# size) action = IO $ \ s0 ->
case newPinnedByteArray# size s0 of { (# s1, mbarr# #) ->
case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) ->
let addr = Ptr (byteArrayContents# barr#) in
- case action addr of { IO action' ->
- case action' s2 of { (# s3, r #) ->
- case touch# barr# s3 of { s4 ->
- (# s4, r #)
- }}}}}
--- See Note [NOINLINE for touch#]
-{-# NOINLINE allocaBytes #-}
+ case action addr of { IO action' ->
+ keepAlive# barr# s2 action'
+ }}}
allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 ->
@@ -156,12 +139,8 @@ 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' ->
- case action' s2 of { (# s3, r #) ->
- case touch# barr# s3 of { s4 ->
- (# s4, r #)
- }}}}}
--- See Note [NOINLINE for touch#]
-{-# NOINLINE allocaBytesAligned #-}
+ keepAlive# barr# s2 action'
+ }}}
-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
-- to the size needed to store values of type @b at . The returned pointer
=====================================
libraries/base/GHC/ForeignPtr.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Unsafe #-}
{-# OPTIONS_HADDOCK not-home #-}
@@ -24,7 +25,7 @@ module GHC.ForeignPtr
(
-- * Types
ForeignPtr(..),
- ForeignPtrContents(..),
+ ForeignPtrContents(PlainForeignPtr, FinalPtr, MallocPtr, PlainPtr),
Finalizers(..),
FinalizerPtr,
FinalizerEnvPtr,
@@ -46,6 +47,7 @@ module GHC.ForeignPtr
castForeignPtr,
plusForeignPtr,
-- * Finalization
+ withForeignPtr,
touchForeignPtr,
finalizeForeignPtr
-- * Commentary
@@ -79,7 +81,7 @@ import Unsafe.Coerce ( unsafeCoerce, unsafeCoerceUnlifted )
-- type argument of 'ForeignPtr' should normally be an instance of
-- class 'Storable'.
--
-data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents
+data ForeignPtr a = ForeignPtr Addr# !ForeignPtrContents
-- The Addr# in the ForeignPtr object is intentionally stored
-- separately from the finalizer. The primary aim of the
-- representation is to make withForeignPtr efficient; in fact,
@@ -116,11 +118,11 @@ data Finalizers
-- > Prohibited | PlainPtr | FinalPtr |
-- > +------------+-----------------+
data ForeignPtrContents
- = PlainForeignPtr !(IORef Finalizers)
+ = PlainForeignPtr_ !(IORef Finalizers)
-- ^ The pointer refers to unmanaged memory that was allocated by
-- a foreign function (typically using @malloc@). The finalizer
-- frequently calls the C function @free@ or some variant of it.
- | FinalPtr
+ | FinalPtr_
-- ^ The pointer refers to unmanaged memory that should not be freed when
-- the 'ForeignPtr' becomes unreachable. Functions that add finalizers
-- to a 'ForeignPtr' throw exceptions when the 'ForeignPtr' is backed by
@@ -128,7 +130,7 @@ data ForeignPtrContents
-- See Note [Why FinalPtr].
--
-- @since 4.15
- | MallocPtr (MutableByteArray# RealWorld) !(IORef Finalizers)
+ | MallocPtr_ (MutableByteArray# RealWorld) !(IORef Finalizers)
-- ^ The pointer refers to a byte array.
-- The 'MutableByteArray#' field means that the 'MutableByteArray#' is
-- reachable (by GC) whenever the 'ForeignPtr' is reachable. When the
@@ -153,7 +155,7 @@ data ForeignPtrContents
-- > incrBad (ForeignPtr p (MallocPtr m _)) = do
-- > f <- newIORef NoFinalizers
-- > pure (ForeignPtr p (MallocPtr m f))
- | PlainPtr (MutableByteArray# RealWorld)
+ | PlainPtr_ (MutableByteArray# RealWorld)
-- ^ The pointer refers to a byte array. Finalization is not
-- supported. This optimizes @MallocPtr@ by avoiding the allocation
-- of a @MutVar#@ when it is known that no one will add finalizers to
@@ -161,6 +163,31 @@ data ForeignPtrContents
-- throw exceptions when the 'ForeignPtr' is backed by 'PlainPtr'.
-- The invariants that apply to 'MallocPtr' apply to 'PlainPtr' as well.
+plainPtr :: MutableByteArray# RealWorld -> ForeignPtrContents
+plainPtr = PlainPtr_
+{-# INLINE [1] plainPtr #-}
+
+mallocPtr :: MutableByteArray# RealWorld -> IORef Finalizers -> ForeignPtrContents
+mallocPtr = MallocPtr_
+{-# INLINE [1] mallocPtr #-}
+
+finalPtr :: ForeignPtrContents
+finalPtr = FinalPtr_
+{-# INLINE [1] finalPtr #-}
+
+plainForeignPtr :: IORef Finalizers -> ForeignPtrContents
+plainForeignPtr = PlainForeignPtr_
+{-# INLINE [1] plainForeignPtr #-}
+
+pattern PlainPtr mba <- PlainPtr_ mba where
+ PlainPtr mba = plainPtr mba
+pattern MallocPtr mba fin <- MallocPtr_ mba fin where
+ MallocPtr mba bin = mallocPtr mba bin
+pattern FinalPtr <- FinalPtr_ where
+ FinalPtr = finalPtr
+pattern PlainForeignPtr fin <- PlainForeignPtr_ fin where
+ PlainForeignPtr fin = plainForeignPtr fin
+
-- Note [Why FinalPtr]
--
-- FinalPtr exists as an optimization for foreign pointers created
@@ -503,6 +530,39 @@ newForeignPtr_ (Ptr obj) = do
r <- newIORef NoFinalizers
return (ForeignPtr obj (PlainForeignPtr r))
+withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+-- ^This is a way to look at the pointer living inside a
+-- foreign object. This function takes a function which is
+-- applied to that pointer. The resulting 'IO' action is then
+-- executed. The foreign object is kept alive at least during
+-- the whole action, even if it is not used directly
+-- inside. Note that it is not safe to return the pointer from
+-- the action and use it after the action completes. All uses
+-- of the pointer should be inside the
+-- 'withForeignPtr' bracket. The reason for
+-- this unsafeness is the same as for
+-- 'unsafeForeignPtrToPtr' below: the finalizer
+-- may run earlier than expected, because the compiler can only
+-- track usage of the 'ForeignPtr' object, not
+-- a 'Ptr' object made from it.
+--
+-- This function is normally used for marshalling data to
+-- or from the object pointed to by the
+-- 'ForeignPtr', using the operations from the
+-- 'Storable' class.
+withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s ->
+ case f (unsafeForeignPtrToPtr fo) of
+ IO action# -> keepAlive# r s action#
+
+{-# RULES "keepAlive#/PlainForeignPtr" forall s k ref .
+ keepAlive# (plainForeignPtr ref) s k = keepAlive# ref s k #-}
+{-# RULES "keepAlive#/FinalPtr" forall s k .
+ keepAlive# finalPtr s k = k s #-}
+{-# RULES "keepAlive#/MallocPtr" forall s k mba x .
+ keepAlive# (mallocPtr mba x) s k = keepAlive# mba s k #-}
+{-# RULES "keepAlive#/PlainPtr" forall s k mba .
+ keepAlive# (plainPtr mba) s k = keepAlive# mba s k #-}
+
touchForeignPtr :: ForeignPtr a -> IO ()
-- ^This function ensures that the foreign object in
-- question is alive at the given place in the sequence of IO
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit e6cb01e2ec0bfdd19298418c85f220925a9fa307
+Subproject commit e0f2db500f2abd35d2837b9b930d9acfc677be2e
=====================================
testsuite/driver/perf_notes.py
=====================================
@@ -311,7 +311,7 @@ def append_perf_stat(stats: List[PerfStat],
max_tries: int=5
) -> bool:
# Append to git note
- print('Appending ' + str(len(stats)) + ' stats to git notes.')
+ print('Appending %d stats to git note namespace %s.' % (len(stats), namespace))
stats_str = format_perf_stat(stats)
def try_append():
try:
=====================================
testsuite/driver/runtests.py
=====================================
@@ -511,11 +511,7 @@ else:
# Write perf stats if any exist or if a metrics file is specified.
stats_metrics = [stat for (_, stat, __) in t.metrics] # type: List[PerfStat]
- if hasMetricsFile:
- print('Appending ' + str(len(stats_metrics)) + ' stats to file: ' + config.metrics_file)
- with open(config.metrics_file, 'a') as f:
- f.write("\n" + Perf.format_perf_stat(stats_metrics))
- elif inside_git_repo() and any(stats_metrics):
+ if inside_git_repo() and any(stats_metrics):
if is_worktree_dirty():
print()
print(str_warn('Performance Metrics NOT Saved') + \
@@ -524,6 +520,11 @@ else:
else:
Perf.append_perf_stat(stats_metrics)
+ if hasMetricsFile:
+ print('Appending %d stats to file: %s' % (len(stats_metrics), config.metrics_file))
+ with open(config.metrics_file, 'a') as f:
+ f.write("\n" + Perf.format_perf_stat(stats_metrics))
+
# Write summary
if config.summary_file:
with open(config.summary_file, 'w') as f:
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -503,6 +503,7 @@ gen_latex_doc (Info defaults entries)
tvars = tvars_of typ
tbinds [] = ". "
tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs)
+ tbinds ("p":tbs) = "(p::?) " ++ (tbinds tbs)
tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs)
tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2
tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2
@@ -852,6 +853,7 @@ ppTyVar "b" = "betaTyVar"
ppTyVar "c" = "gammaTyVar"
ppTyVar "s" = "deltaTyVar"
ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar"
+ppTyVar "p" = "runtimeRep2TyVar, openBetaTyVar"
ppTyVar _ = error "Unknown type var"
ppType :: Ty -> String
@@ -885,6 +887,7 @@ ppType (TyVar "b") = "betaTy"
ppType (TyVar "c") = "gammaTy"
ppType (TyVar "s") = "deltaTy"
ppType (TyVar "o") = "openAlphaTy"
+ppType (TyVar "p") = "openBetaTy"
ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x
ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ad5a0272c76ddd89e1c9ed335cb5bed460121d19...63f502b45c38078c8625d1e453105eb05bf48366
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ad5a0272c76ddd89e1c9ed335cb5bed460121d19...63f502b45c38078c8625d1e453105eb05bf48366
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/20200911/76392d7a/attachment-0001.html>
More information about the ghc-commits
mailing list