[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: Mark rule args as non-tail-called
Marge Bot
gitlab at gitlab.haskell.org
Thu Apr 30 19:04:44 UTC 2020
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
19b701c2 by Simon Peyton Jones at 2020-04-30T07:30:13-04:00
Mark rule args as non-tail-called
This was just an omission...b I'd failed to call markAllNonTailCall on
rule args. I think this bug has been here a long time, but it's quite
hard to trigger.
Fixes #18098
- - - - -
014ef4a3 by Matthew Pickering at 2020-04-30T07:30:50-04:00
Hadrian: Improve tool-args command to support more components
There is a new command to hadrian, tool:path/to/file.hs, which returns
the options needed to compile that file in GHCi.
This is now used in the ghci script with argument `ghc/Main.hs` but its
main purpose is to support the new multi-component branch of ghcide.
- - - - -
33e73c48 by Ben Gamari at 2020-04-30T15:04:28-04:00
nonmoving: Clear bitmap after initializing block size
Previously nonmovingInitSegment would clear the bitmap before
initializing the segment's block size. This is broken since
nonmovingClearBitmap looks at the segment's block size to determine how
much bitmap to clear.
- - - - -
99b962f4 by Ben Gamari at 2020-04-30T15:04:28-04:00
nonmoving: Explicitly memoize block count
A profile cast doubt on whether the compiler hoisted the bound out the
loop as I would have expected here. It turns out it did but nevertheless
it seems clearer to just do this manually.
- - - - -
4e40c39e by Ben Gamari at 2020-04-30T15:04:28-04:00
nonmoving: Eagerly flush all capabilities' update remembered sets
(cherry picked from commit 2fa79119570b358a4db61446396889b8260d7957)
- - - - -
34fe32df by Ömer Sinan Ağacan at 2020-04-30T15:04:35-04:00
Remove OneShotInfo field of LFReEntrant, document OneShotInfo
The field is only used in withNewTickyCounterFun and it's easier to
directly pass a parameter for one-shot info to withNewTickyCounterFun
instead of passing it via LFReEntrant. This also makes !2842 simpler.
Other changes:
- New Note (by SPJ) [OneShotInfo overview] added.
- Arity argument of thunkCode removed as it's always 0.
- - - - -
6e659dec by Ömer Sinan Ağacan at 2020-04-30T15:04:35-04:00
GHC.StgToCmm.Ticky: remove a few unused stuff
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/StgToCmm/Bind.hs
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Ticky.hs
- compiler/GHC/Types/Basic.hs
- hadrian/ghci-cabal
- hadrian/ghci-stack
- hadrian/hadrian.cabal
- hadrian/hie-bios
- hadrian/src/Rules.hs
- + hadrian/src/Rules/ToolArgs.hs
- rts/sm/GC.c
- rts/sm/NonMoving.c
- rts/sm/NonMovingSweep.c
- + testsuite/tests/simplCore/should_compile/T18098.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -728,7 +728,7 @@ a right-hand side. In particular, we need to
a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot
lambda, or a non-recursive join point; and
- b) call 'markAllNonTailCalled' *unless* the binding is for a join point.
+ b) call 'markAllNonTail' *unless* the binding is for a join point.
Some examples, with how the free occurrences in e (assumed not to be a value
lambda) get marked:
@@ -1605,7 +1605,7 @@ occAnalUnfolding env mb_join_arity unf
where
env' = env `addInScope` bndrs
(usage, args') = occAnalList env' args
- final_usage = zapDetails (delDetailsList usage bndrs)
+ final_usage = markAllManyNonTail (delDetailsList usage bndrs)
unf -> (emptyDetails, unf)
@@ -1626,13 +1626,13 @@ occAnalRules env mb_join_arity bndr
| otherwise = rule { ru_args = args', ru_rhs = rhs' }
(lhs_uds, args') = occAnalList env' args
- lhs_uds' = markAllMany $
+ lhs_uds' = markAllManyNonTail $
lhs_uds `delDetailsList` bndrs
(rhs_uds, rhs') = occAnal env' rhs
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
- rhs_uds' = markAllNonTailCalledIf (not exact_join) $
+ rhs_uds' = markAllNonTailIf (not exact_join) $
markAllMany $
rhs_uds `delDetailsList` bndrs
@@ -1758,7 +1758,7 @@ occAnal env (Tick tickish body)
-- not the end of the world.
| tickish `tickishScopesLike` SoftScope
- = (markAllNonTailCalled usage, Tick tickish body')
+ = (markAllNonTail usage, Tick tickish body')
| Breakpoint _ ids <- tickish
= (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body')
@@ -1769,7 +1769,7 @@ occAnal env (Tick tickish body)
where
!(usage,body') = occAnal env body
-- for a non-soft tick scope, we can inline lambdas only
- usage_lam = markAllNonTailCalled (markAllInsideLam usage)
+ usage_lam = markAllNonTail (markAllInsideLam usage)
-- TODO There may be ways to make ticks and join points play
-- nicer together, but right now there are problems:
-- let j x = ... in tick<t> (j 1)
@@ -1780,13 +1780,13 @@ occAnal env (Tick tickish body)
occAnal env (Cast expr co)
= case occAnal env expr of { (usage, expr') ->
- let usage1 = zapDetailsIf (isRhsEnv env) usage
+ let usage1 = markAllManyNonTailIf (isRhsEnv env) usage
-- usage1: if we see let x = y `cast` co
-- then mark y as 'Many' so that we don't
-- immediately inline y again.
usage2 = addManyOccs usage1 (coVarsOfCo co)
-- usage2: see Note [Gather occurrences of coercion variables]
- in (markAllNonTailCalled usage2, Cast expr' co)
+ in (markAllNonTail usage2, Cast expr' co)
}
occAnal env app@(App _ _)
@@ -1799,7 +1799,7 @@ occAnal env app@(App _ _)
occAnal env (Lam x body)
| isTyVar x
= case occAnal env body of { (body_usage, body') ->
- (markAllNonTailCalled body_usage, Lam x body')
+ (markAllNonTail body_usage, Lam x body')
}
-- For value lambdas we do a special hack. Consider
@@ -1815,7 +1815,7 @@ occAnal env expr@(Lam _ _)
= case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->
let
expr' = mkLams tagged_bndrs body'
- usage1 = markAllNonTailCalled usage
+ usage1 = markAllNonTail usage
one_shot_gp = all isOneShotBndr tagged_bndrs
final_usage = markAllInsideLamIf (not one_shot_gp) usage1
in
@@ -1832,7 +1832,7 @@ occAnal env (Case scrut bndr ty alts)
let
alts_usage = foldr orUDs emptyDetails alts_usage_s
(alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr
- total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1
+ total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1
-- Alts can have tail calls, but the scrutinee can't
in
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
@@ -1893,7 +1893,7 @@ occAnalApp env (Var fun, args, ticks)
all_uds = fun_uds `andUDs` final_args_uds
!(args_uds, args') = occAnalArgs env args one_shots
- !final_args_uds = markAllNonTailCalled $
+ !final_args_uds = markAllNonTail $
markAllInsideLamIf (isRhsEnv env && is_exp) $
args_uds
-- We mark the free vars of the argument of a constructor or PAP
@@ -1923,7 +1923,7 @@ occAnalApp env (Var fun, args, ticks)
-- See Note [Sources of one-shot information], bullet point A']
occAnalApp env (fun, args, ticks)
- = (markAllNonTailCalled (fun_uds `andUDs` args_uds),
+ = (markAllNonTail (fun_uds `andUDs` args_uds),
mkTicks ticks $ mkApps fun' args')
where
!(fun_uds, fun') = occAnal (addAppCtxt env args) fun
@@ -2526,7 +2526,7 @@ data UsageDetails
= UD { ud_env :: !OccInfoEnv
, ud_z_many :: ZappedSet -- apply 'markMany' to these
, ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these
- , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these
+ , ud_z_no_tail :: ZappedSet } -- apply 'markNonTail' to these
-- INVARIANT: All three zapped sets are subsets of the OccInfoEnv
instance Outputable UsageDetails where
@@ -2587,28 +2587,28 @@ emptyDetails = UD { ud_env = emptyVarEnv
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails = isEmptyVarEnv . ud_env
-markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails
+markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
markAllMany ud = ud { ud_z_many = ud_env ud }
markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
-markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud }
+markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }
-markAllInsideLamIf, markAllNonTailCalledIf :: Bool -> UsageDetails -> UsageDetails
+markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
markAllInsideLamIf True ud = markAllInsideLam ud
markAllInsideLamIf False ud = ud
-markAllNonTailCalledIf True ud = markAllNonTailCalled ud
-markAllNonTailCalledIf False ud = ud
+markAllNonTailIf True ud = markAllNonTail ud
+markAllNonTailIf False ud = ud
-zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo
+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
-zapDetailsIf :: Bool -- If this is true
- -> UsageDetails -- Then do zapDetails on this
+markAllManyNonTailIf :: Bool -- If this is true
+ -> UsageDetails -- Then do markAllManyNonTail on this
-> UsageDetails
-zapDetailsIf True uds = zapDetails uds
-zapDetailsIf False uds = uds
+markAllManyNonTailIf True uds = markAllManyNonTail uds
+markAllManyNonTailIf False uds = uds
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails ud id
@@ -2674,7 +2674,7 @@ doZappingByUnique (UD { ud_z_many = many
occ1 | uniq `elemVarEnvByKey` many = markMany occ
| uniq `elemVarEnvByKey` in_lam = markInsideLam occ
| otherwise = occ
- occ2 | uniq `elemVarEnvByKey` no_tail = markNonTailCalled occ1
+ occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1
| otherwise = occ1
alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails
@@ -2700,7 +2700,7 @@ adjustRhsUsage :: Maybe JoinArity -> RecFlag
-> UsageDetails
adjustRhsUsage mb_join_arity rec_flag bndrs usage
= markAllInsideLamIf (not one_shot) $
- markAllNonTailCalledIf (not exact_join) $
+ markAllNonTailIf (not exact_join) $
usage
where
one_shot = case mb_join_arity of
@@ -2738,7 +2738,7 @@ tagLamBinder usage bndr
= (usage2, bndr')
where
occ = lookupDetails usage bndr
- bndr' = setBinderOcc (markNonTailCalled occ) bndr
+ bndr' = setBinderOcc (markNonTail occ) bndr
-- Don't try to make an argument into a join point
usage1 = usage `delDetails` bndr
usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)
@@ -2759,7 +2759,7 @@ tagNonRecBinder lvl usage binder
will_be_join = decideJoinPointHood lvl usage [binder]
occ' | will_be_join = -- must already be marked AlwaysTailCalled
ASSERT(isAlwaysTailCalled occ) occ
- | otherwise = markNonTailCalled occ
+ | otherwise = markNonTail occ
binder' = setBinderOcc occ' binder
usage' = usage `delDetails` binder
in
@@ -2930,7 +2930,7 @@ See Invariant 2a of Note [Invariants on join points] in GHC.Core
************************************************************************
-}
-markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo
+markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo
markMany IAmDead = IAmDead
markMany occ = ManyOccs { occ_tail = occ_tail occ }
@@ -2938,8 +2938,8 @@ markMany occ = ManyOccs { occ_tail = occ_tail occ }
markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }
markInsideLam occ = occ
-markNonTailCalled IAmDead = IAmDead
-markNonTailCalled occ = occ { occ_tail = NoTailCallInfo }
+markNonTail IAmDead = IAmDead
+markNonTail occ = occ { occ_tail = NoTailCallInfo }
addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -446,7 +446,7 @@ pprIdBndrInfo info
lbv_info = oneShotInfo info
has_prag = not (isDefaultInlinePragma prag_info)
- has_occ = not (isManyOccs occ_info)
+ has_occ = not (isNoOccInfo occ_info)
has_dmd = not $ isTopDmd dmd_info
has_lbv = not (hasNoOneShotInfo lbv_info)
=====================================
compiler/GHC/StgToCmm/Bind.hs
=====================================
@@ -111,7 +111,7 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body =
(_, _, fv_details) = mkVirtHeapOffsets dflags header []
-- Don't drop the non-void args until the closure info has been made
; forkClosureBody (closureCodeBody True id closure_info ccs
- (nonVoidIds args) (length args) body fv_details)
+ args body fv_details)
; return () }
@@ -358,8 +358,8 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body
-- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
-- (b) ignore Sequel from context; use empty Sequel
-- And compile the body
- closureCodeBody False bndr closure_info cc (nonVoidIds args)
- (length args) body fv_details
+ closureCodeBody False bndr closure_info cc args
+ body fv_details
-- BUILD THE OBJECT
-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
@@ -436,8 +436,7 @@ closureCodeBody :: Bool -- whether this is a top-level binding
-> Id -- the closure's name
-> ClosureInfo -- Lots of information about this closure
-> CostCentreStack -- Optional cost centre attached to closure
- -> [NonVoid Id] -- incoming args to the closure
- -> Int -- arity, including void args
+ -> [Id] -- incoming args to the closure
-> CgStgExpr
-> [(NonVoid Id, ByteOff)] -- the closure's free vars
-> FCode ()
@@ -452,31 +451,32 @@ closureCodeBody :: Bool -- whether this is a top-level binding
normal form, so there is no need to set up an update frame.
-}
-closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
- | arity == 0 -- No args i.e. thunk
+-- No args i.e. thunk
+closureCodeBody top_lvl bndr cl_info cc [] body fv_details
= withNewTickyCounterThunk
(isStaticClosure cl_info)
(closureUpdReqd cl_info)
(closureName cl_info) $
emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
- \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
+ \(_, node, _) -> thunkCode cl_info fv_details cc node body
where
lf_info = closureLFInfo cl_info
info_tbl = mkCmmInfo cl_info bndr cc
-closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
- = -- Note: args may be [], if all args are Void
- withNewTickyCounterFun
- (closureSingleEntry cl_info)
- (closureName cl_info)
- args $ do {
+closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
+ = let nv_args = nonVoidIds args
+ arity = length args
+ in
+ -- See Note [OneShotInfo overview] in GHC.Types.Basic.
+ withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)
+ nv_args $ do {
; let
lf_info = closureLFInfo cl_info
info_tbl = mkCmmInfo cl_info bndr cc
-- Emit the main entry code
- ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
+ ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $
\(_offset, node, arg_regs) -> do
-- Emit slow-entry code (for entering a closure through a PAP)
{ mkSlowEntryCode bndr cl_info arg_regs
@@ -565,15 +565,15 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
-----------------------------------------
thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
- -> LocalReg -> Int -> CgStgExpr -> FCode ()
-thunkCode cl_info fv_details _cc node arity body
+ -> LocalReg -> CgStgExpr -> FCode ()
+thunkCode cl_info fv_details _cc node body
= do { dflags <- getDynFlags
; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
node' = if node_points then Just node else Nothing
; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
-- Heap overflow check
- ; entryHeapCheck cl_info node' arity [] $ do
+ ; entryHeapCheck cl_info node' 0 [] $ do
{ -- Overwrite with black hole if necessary
-- but *after* the heap-overflow check
; tickyEnterThunk cl_info
=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -48,7 +48,7 @@ module GHC.StgToCmm.Closure (
-- ** Predicates
-- These are really just functions on LambdaFormInfo
- closureUpdReqd, closureSingleEntry,
+ closureUpdReqd,
closureReEntrant, closureFunInfo,
isToplevClosure,
@@ -201,7 +201,6 @@ argPrimRep arg = typePrimRep1 (stgArgType arg)
data LambdaFormInfo
= LFReEntrant -- Reentrant closure (a function)
TopLevelFlag -- True if top level
- OneShotInfo
!RepArity -- Arity. Invariant: always > 0
!Bool -- True <=> no fvs
ArgDescr -- Argument descriptor (should really be in ClosureInfo)
@@ -285,8 +284,7 @@ mkLFReEntrant :: TopLevelFlag -- True of top level
mkLFReEntrant _ _ [] _
= pprPanic "mkLFReEntrant" empty
mkLFReEntrant top fvs args arg_descr
- = LFReEntrant top os_info (length args) (null fvs) arg_descr
- where os_info = idOneShotInfo (head args)
+ = LFReEntrant top (length args) (null fvs) arg_descr
-------------
mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
@@ -335,7 +333,7 @@ mkLFImported id
-- the id really does point directly to the constructor
| arity > 0
- = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
+ = LFReEntrant TopLevel arity True (panic "arg_descr")
| otherwise
= mkLFArgument id -- Not sure of exact arity
@@ -384,9 +382,9 @@ tagForArity dflags arity
lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
-- Return the tag in the low order bits of a variable bound
-- to this LambdaForm
-lfDynTag dflags (LFCon con) = tagForCon dflags con
-lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
-lfDynTag _ _other = 0
+lfDynTag dflags (LFCon con) = tagForCon dflags con
+lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity
+lfDynTag _ _other = 0
-----------------------------------------------------------------------------
@@ -407,11 +405,11 @@ isLFReEntrant _ = False
-----------------------------------------------------------------------------
lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
-lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
-lfClosureType (LFCon con) = Constr (dataConTagZ con)
- (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
-lfClosureType _ = panic "lfClosureType"
+lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con) = Constr (dataConTagZ con)
+ (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel
+lfClosureType _ = panic "lfClosureType"
thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
thunkClosureType (SelectorThunk off) = ThunkSelector off
@@ -431,7 +429,7 @@ nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
-- this closure has R1 (the "Node" register) pointing to the
-- closure itself --- the "self" argument
-nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
+nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
= not no_fvs -- Certainly if it has fvs we need to point to it
|| isNotTopLevel top -- See Note [GC recovery]
-- For lex_profiling we also access the cost centre for a
@@ -566,7 +564,7 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc
-- self-recursive tail calls] in GHC.StgToCmm.Expr for more details
= JumpToIt block_id args
-getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc
_self_loop_info
| n_args == 0 -- No args at all
&& not (gopt Opt_SccProfilingOn dflags)
@@ -811,11 +809,6 @@ lfUpdatable :: LambdaFormInfo -> Bool
lfUpdatable (LFThunk _ _ upd _ _) = upd
lfUpdatable _ = False
-closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
-closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
-closureSingleEntry _ = False
-
closureReEntrant :: ClosureInfo -> Bool
closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
closureReEntrant _ = False
@@ -824,8 +817,8 @@ closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr)
-lfFunInfo (LFReEntrant _ _ arity _ arg_desc) = Just (arity, arg_desc)
-lfFunInfo _ = Nothing
+lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc)
+lfFunInfo _ = Nothing
funTag :: DynFlags -> ClosureInfo -> DynTag
funTag dflags (ClosureInfo { closureLFInfo = lf_info })
@@ -834,9 +827,9 @@ funTag dflags (ClosureInfo { closureLFInfo = lf_info })
isToplevClosure :: ClosureInfo -> Bool
isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
= case lf_info of
- LFReEntrant TopLevel _ _ _ _ -> True
- LFThunk TopLevel _ _ _ _ -> True
- _other -> False
+ LFReEntrant TopLevel _ _ _ -> True
+ LFThunk TopLevel _ _ _ _ -> True
+ _other -> False
--------------------------------------
-- Label generation
=====================================
compiler/GHC/StgToCmm/Ticky.hs
=====================================
@@ -82,27 +82,22 @@ module GHC.StgToCmm.Ticky (
tickyHeapCheck,
tickyStackCheck,
- tickyUnknownCall, tickyDirectCall,
+ tickyDirectCall,
tickyPushUpdateFrame,
tickyUpdateFrameOmitted,
tickyEnterDynCon,
- tickyEnterStaticCon,
- tickyEnterViaNode,
tickyEnterFun,
- tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value
- -- thunks only
+ tickyEnterThunk,
tickyEnterLNE,
tickyUpdateBhCaf,
- tickyBlackHole,
tickyUnboxedTupleReturn,
tickyReturnOldCon, tickyReturnNewCon,
- tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
- tickySlowCall, tickySlowCallPat,
+ tickySlowCall
) where
import GHC.Prelude
@@ -276,10 +271,8 @@ tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
-- bump of name-specific ticky counter into. On the other hand, we can
-- still track allocation their allocation.
-tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
-tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
-tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
-tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
+tickyEnterDynCon :: FCode ()
+tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk cl_info
@@ -291,7 +284,7 @@ tickyEnterThunk cl_info
registerTickyCtrAtEntryDyn ticky_ctr_lbl
bumpTickyEntryCount ticky_ctr_lbl }
where
- updatable = closureSingleEntry cl_info
+ updatable = not (closureUpdReqd cl_info)
static = isStaticClosure cl_info
ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
@@ -299,16 +292,6 @@ tickyEnterThunk cl_info
| otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
else fsLit "ENT_DYN_THK_MANY_ctr"
-tickyEnterStdThunk :: ClosureInfo -> FCode ()
-tickyEnterStdThunk = tickyEnterThunk
-
-tickyBlackHole :: Bool{-updatable-} -> FCode ()
-tickyBlackHole updatable
- = ifTicky (bumpTickyCounter ctr)
- where
- ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
- | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
-
tickyUpdateBhCaf :: ClosureInfo -> FCode ()
tickyUpdateBhCaf cl_info
= ifTicky (bumpTickyCounter ctr)
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -67,7 +67,7 @@ module GHC.Types.Basic (
OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs,
- strongLoopBreaker, weakLoopBreaker,
+ isNoOccInfo, strongLoopBreaker, weakLoopBreaker,
InsideLam(..),
OneBranch(..),
@@ -243,13 +243,80 @@ instance Outputable Alignment where
************************************************************************
-}
+{-
+Note [OneShotInfo overview]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound Ids (and only lambda-bound Ids) may be decorated with
+one-shot info. The idea is that if we see
+ (\x{one-shot}. e)
+it means that this lambda will only be applied once. In particular
+that means we can float redexes under the lambda without losing
+work. For example, consider
+ let t = expensive in
+ (\x{one-shot}. case t of { True -> ...; False -> ... })
+
+Because it's a one-shot lambda, we can safely inline t, giving
+ (\x{one_shot}. case <expensive> of of
+ { True -> ...; False -> ... })
+
+Moving parts:
+
+* Usage analysis, performed as part of demand-analysis, finds
+ out whether functions call their argument once. Consider
+ f g x = Just (case g x of { ... })
+
+ Here 'f' is lazy in 'g', but it guarantees to call it no
+ more than once. So g will get a C1(U) usage demand.
+
+* Occurrence analysis propagates this usage information
+ (in the demand signature of a function) to its calls.
+ Example, given 'f' above
+ f (\x.e) blah
+
+ Since f's demand signature says it has a C1(U) usage demand on its
+ first argument, the occurrence analyser sets the \x to be one-shot.
+ This is done via the occ_one_shots field of OccEnv.
+
+* Float-in and float-out take account of one-shot-ness
+
+* Occurrence analysis doesn't set "inside-lam" for occurrences inside
+ a one-shot lambda
+
+Other notes
+
+* A one-shot lambda can use its argument many times. To elaborate
+ the example above
+ let t = expensive in
+ (\x{one-shot}. case t of { True -> x+x; False -> x*x })
+
+ Here the '\x' is one-shot, which justifies inlining 't',
+ but x is used many times. That's absolutely fine.
+
+* It's entirely possible to have
+ (\x{one-shot}. \y{many-shot}. e)
+
+ For example
+ let t = expensive
+ g = \x -> let v = x+t in
+ \y -> x + v
+ in map (g 5) xs
+
+ Here the `\x` is a one-shot binder: `g` is applied to one argument
+ exactly once. And because the `\x` is one-shot, it would be fine to
+ float that `let t = expensive` binding inside the `\x`.
+
+ But the `\y` is most definitely not one-shot!
+-}
+
-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound
-- variable info. Sometimes we know whether the lambda binding this variable
--- is a \"one-shot\" lambda; that is, whether it is applied at most once.
+-- is a "one-shot" lambda; that is, whether it is applied at most once.
--
-- This information may be useful in optimisation, as computations may
-- safely be floated inside such a lambda without risk of duplicating
-- work.
+--
+-- See also Note [OneShotInfo overview] above.
data OneShotInfo
= NoOneShotInfo -- ^ No information
| OneShotLam -- ^ The lambda is applied at most once.
@@ -958,6 +1025,10 @@ See OccurAnal Note [Weak loop breakers]
noOccInfo :: OccInfo
noOccInfo = ManyOccs { occ_tail = NoTailCallInfo }
+isNoOccInfo :: OccInfo -> Bool
+isNoOccInfo ManyOccs { occ_tail = NoTailCallInfo } = True
+isNoOccInfo _ = False
+
isManyOccs :: OccInfo -> Bool
isManyOccs ManyOccs{} = True
isManyOccs _ = False
=====================================
hadrian/ghci-cabal
=====================================
@@ -3,5 +3,5 @@
set -e
# Replace newlines with spaces, as these otherwise break the ghci invocation on windows.
-GHC_FLAGS="$GHC_FLAGS $(TERM=dumb CABFLAGS=-v0 "hadrian/build-cabal" tool-args -q --build-root=.hadrian_ghci --flavour=ghc-in-ghci $HADRIAN_ARGS | tr '\n\r' ' ')"
-ghci $GHC_FLAGS $@ -fno-code -fwrite-interface -hidir=.hadrian_ghci/interface -O0 ghc/Main.hs +RTS -A128m
+GHC_FLAGS="$GHC_FLAGS $(TERM=dumb CABFLAGS=-v0 "hadrian/build-cabal" tool:ghc/Main.hs -q --build-root=.hadrian_ghci --flavour=ghc-in-ghci $HADRIAN_ARGS | tr '\n\r' ' ')"
+ghci $GHC_FLAGS $@ -fno-code -fwrite-interface -hidir=.hadrian_ghci/interface -O0 +RTS -A128m
=====================================
hadrian/ghci-stack
=====================================
@@ -4,4 +4,4 @@ set -e
# Replace newlines with spaces, as these otherwise break the ghci invocation on windows.
GHC_FLAGS="$GHC_FLAGS $(TERM=dumb CABFLAGS=-v0 "hadrian/build-stack" tool-args -q --build-root=.hadrian_ghci --flavour=ghc-in-ghci $HADRIAN_ARGS | tr '\n\r' ' ')"
-stack exec -- ghci $GHC_FLAGS "$@" -fno-code -fwrite-interface -hidir=.hadrian_ghci/interface -O0 ghc/Main.hs +RTS -A128m
+stack exec -- ghci $GHC_FLAGS "$@" -fno-code -fwrite-interface -hidir=.hadrian_ghci/interface -O0 +RTS -A128m
=====================================
hadrian/hadrian.cabal
=====================================
@@ -77,6 +77,7 @@ executable hadrian
, Rules.Program
, Rules.Register
, Rules.Rts
+ , Rules.ToolArgs
, Rules.Selftest
, Rules.SimpleTargets
, Rules.SourceDist
=====================================
hadrian/hie-bios
=====================================
@@ -3,7 +3,5 @@
# When run, this program will output a list of arguments which are necessary to
# load the GHC library component into GHCi. The program is used by `ghcide` in
# order to automatically set up the correct GHC API session for a project.
-TERM=dumb CABFLAGS=-v0 $PWD/hadrian/build-cabal tool-args -q --build-root=.hie-bios --flavour=ghc-in-ghci > $HIE_BIOS_OUTPUT
-echo -ighc >> $HIE_BIOS_OUTPUT
-echo "ghc/Main.hs" >> $HIE_BIOS_OUTPUT
+TERM=dumb CABFLAGS=-v0 $PWD/hadrian/build-cabal tool:$1 -q --build-root=.hie-bios --flavour=ghc-in-ghci > $HIE_BIOS_OUTPUT
=====================================
hadrian/src/Rules.hs
=====================================
@@ -24,43 +24,12 @@ import qualified Rules.Program
import qualified Rules.Register
import qualified Rules.Rts
import qualified Rules.SimpleTargets
+import Rules.ToolArgs
import Settings
import Settings.Program (programContext)
import Target
import UserSettings
--- | @tool-args@ is used by tooling in order to get the arguments necessary
--- to set up a GHC API session which can compile modules from GHC. When
--- run, the target prints out the arguments that would be passed to @ghc@
--- during normal compilation to @stdout at .
---
--- This target is called by the `ghci` script in order to load all of GHC's
--- modules into GHCi.
-toolArgsTarget :: Rules ()
-toolArgsTarget = do
- "tool-args" ~> do
- -- We can't build DLLs on Windows (yet). Actually we should only
- -- include the dynamic way when we have a dynamic host GHC, but just
- -- checking for Windows seems simpler for now.
- let fake_target = target (Context Stage0 compiler (if windowsHost then vanilla else dynamic))
- (Ghc ToolArgs Stage0) [] ["ignored"]
-
- -- need the autogenerated files so that they are precompiled
- includesDependencies Stage0 >>= need
- interpret fake_target Rules.Generate.compilerDependencies >>= need
-
- root <- buildRoot
- let dir = buildDir (vanillaContext Stage0 compiler)
- need [ root -/- dir -/- "Config.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Parser.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Parser" -/- "Lexer.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ]
- need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs" ]
-
- -- Find out the arguments that are needed to load a module into the
- -- session
- arg_list <- interpret fake_target getArgs
- liftIO $ putStrLn (intercalate "\n" arg_list)
allStages :: [Stage]
allStages = [minBound .. maxBound]
=====================================
hadrian/src/Rules/ToolArgs.hs
=====================================
@@ -0,0 +1,128 @@
+module Rules.ToolArgs(toolArgsTarget) where
+
+import qualified Rules.Generate
+import Development.Shake
+import Target
+import Context
+import Stage
+import Expression
+
+import Packages
+import Settings
+import Hadrian.Oracles.Cabal
+import Hadrian.Haskell.Cabal.Type
+import System.Directory (canonicalizePath)
+
+-- | @tool:@ is used by tooling in order to get the arguments necessary
+-- to set up a GHC API session which can compile modules from GHC. When
+-- run, the target prints out the arguments that would be passed to @ghc@
+-- during normal compilation to @stdout@ for the file passed as an
+-- argument.
+--
+-- This target is called by the `ghci.sh` script in order to load all of GHC's
+-- modules into GHCi. It is invoked with argument `tool:ghc/Main.hs` in
+-- that script so that we can load the whole library and executable
+-- components into GHCi.
+--
+-- In the future where we have multi-component ghci this code can be
+-- modified to supply the right arguments for that. At the moment it is
+-- also used for GHC's support for multi-component ghcide (see the
+-- `hadrian/hie-bios` script).
+
+
+-- | A phony target of form `tool:path/to/file.hs` which returns the
+-- options needed to compile the specific file.
+toolArgsTarget :: Rules ()
+toolArgsTarget = do
+ phonys (\s -> if "tool:" `isPrefixOf` s then Just (toolRuleBody (drop 5 s)) else Nothing)
+
+toolRuleBody :: FilePath -> Action ()
+toolRuleBody fp = do
+ mm <- dirMap
+ cfp <- liftIO $ canonicalizePath fp
+ case find (flip isPrefixOf cfp . fst) mm of
+ Just (_, (p, extra)) -> mkToolTarget extra p
+ Nothing -> fail $ "No prefixes matched " ++ show fp ++ " IN\n " ++ show mm
+
+mkToolTarget :: [String] -> Package -> Action ()
+mkToolTarget es p = do
+ -- This builds automatically generated dependencies. Not sure how to do
+ -- this generically yet.
+ allDeps
+ let fake_target = target (Context Stage0 p (if windowsHost then vanilla else dynamic))
+ (Ghc ToolArgs Stage0) [] ["ignored"]
+ arg_list <- interpret fake_target getArgs
+ liftIO $ putStrLn (intercalate "\n" (arg_list ++ es))
+allDeps :: Action ()
+allDeps = do
+ do
+ -- We can't build DLLs on Windows (yet). Actually we should only
+ -- include the dynamic way when we have a dynamic host GHC, but just
+ -- checking for Windows seems simpler for now.
+ let fake_target = target (Context Stage0 compiler (if windowsHost then vanilla else dynamic))
+ (Ghc ToolArgs Stage0) [] ["ignored"]
+
+ -- need the autogenerated files so that they are precompiled
+ includesDependencies Stage0 >>= need
+ interpret fake_target Rules.Generate.compilerDependencies >>= need
+
+ root <- buildRoot
+ let dir = buildDir (vanillaContext Stage0 compiler)
+ need [ root -/- dir -/- "Config.hs" ]
+ need [ root -/- dir -/- "GHC" -/- "Parser.hs" ]
+ need [ root -/- dir -/- "GHC" -/- "Parser" -/- "Lexer.hs" ]
+ need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Parser.hs" ]
+ need [ root -/- dir -/- "GHC" -/- "Cmm" -/- "Lexer.hs" ]
+
+-- This list is quite a lot like stage0packages but doesn't include
+-- critically the `exe:ghc` component as that depends on the GHC library
+-- which takes a while to compile.
+toolTargets :: [Package]
+toolTargets = [ array
+ , bytestring
+ , templateHaskell
+ , containers
+ , deepseq
+ , directory
+ , exceptions
+ , filepath
+ , compiler
+ , ghcCompact
+ , ghcPrim
+ --, haskeline
+ , hp2ps
+ , hsc2hs
+ , pretty
+ , process
+ , rts
+ , stm
+ , time
+ , unlit
+ , xhtml ]
+
+-- | Create a mapping from files to which component it belongs to.
+dirMap :: Action [(FilePath, (Package, [String]))]
+dirMap = do
+ auto <- concatMapM go toolTargets
+ -- Mush the ghc executable into the compiler component so the whole of ghc is not built when
+ -- configuring
+ ghc_exe <- mkGhc
+ return (auto ++ [ghc_exe])
+
+ where
+ -- Make a separate target for the exe:ghc target because otherwise
+ -- configuring would build the whole GHC library which we probably
+ -- don't want to do.
+ mkGhc = do
+ let c = (Context Stage0 compiler (if windowsHost then vanilla else dynamic))
+ cd <- readContextData c
+ fp <- liftIO $ canonicalizePath "ghc/"
+ return (fp, (compiler, "-ighc" : modules cd ++ otherModules cd ++ ["ghc/Main.hs"]))
+ go p = do
+ let c = (Context Stage0 p (if windowsHost then vanilla else dynamic))
+ -- readContextData has the effect of configuring the package so all
+ -- dependent packages will also be built.
+ cd <- readContextData c
+ ids <- liftIO $ mapM canonicalizePath [pkgPath p </> i | i <- srcDirs cd]
+ return $ map (,(p, modules cd ++ otherModules cd)) ids
+
=====================================
rts/sm/GC.c
=====================================
@@ -738,11 +738,13 @@ GarbageCollect (uint32_t collect_gen,
}
} // for all generations
- // Flush the update remembered set. See Note [Eager update remembered set
+ // Flush the update remembered sets. See Note [Eager update remembered set
// flushing] in NonMovingMark.c
if (RtsFlags.GcFlags.useNonmoving) {
RELEASE_SM_LOCK;
- nonmovingAddUpdRemSetBlocks(&gct->cap->upd_rem_set.queue);
+ for (n = 0; n < n_capabilities; n++) {
+ nonmovingAddUpdRemSetBlocks(&capabilities[n]->upd_rem_set.queue);
+ }
ACQUIRE_SM_LOCK;
}
=====================================
rts/sm/NonMoving.c
=====================================
@@ -402,10 +402,10 @@ static void nonmovingInitSegment(struct NonmovingSegment *seg, uint8_t log_block
seg->link = NULL;
seg->todo_link = NULL;
seg->next_free = 0;
- nonmovingClearBitmap(seg);
bd->nonmoving_segment.log_block_size = log_block_size;
bd->nonmoving_segment.next_free_snap = 0;
bd->u.scan = nonmovingSegmentGetBlock(seg, 0);
+ nonmovingClearBitmap(seg);
}
// Add a segment to the free list.
=====================================
rts/sm/NonMovingSweep.c
=====================================
@@ -31,12 +31,11 @@ enum SweepResult {
GNUC_ATTR_HOT static enum SweepResult
nonmovingSweepSegment(struct NonmovingSegment *seg)
{
+ const nonmoving_block_idx blk_cnt = nonmovingSegmentBlockCount(seg);
bool found_free = false;
bool found_live = false;
- for (nonmoving_block_idx i = 0;
- i < nonmovingSegmentBlockCount(seg);
- ++i)
+ for (nonmoving_block_idx i = 0; i < blk_cnt; ++i)
{
if (seg->bitmap[i] == nonmovingMarkEpoch) {
found_live = true;
=====================================
testsuite/tests/simplCore/should_compile/T18098.hs
=====================================
@@ -0,0 +1,78 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE KindSignatures #-}
+module Bug where
+
+import Control.Monad.ST (runST, ST)
+import Data.Kind (Type)
+import Data.Functor.Identity (Identity(..))
+
+gcons :: (GVector v a) => a -> Stream Identity (Chunk v a) -> v a
+gcons x tb = gmvmunstreamUnknown $ sappend (ssingleton x) tb
+{-# INLINE gcons #-}
+
+data Chunk v a = MkChunk (forall s. GVector v a => Mutable v s a -> ST s ())
+
+data Step s a = Yield a s | Done
+
+data Stream m a = forall s. Stream (s -> m (Step s a)) s
+
+data Mutable :: (Type -> Type) -> Type -> Type -> Type
+
+class GVector v a where
+ gmbasicLength :: Mutable v s a -> Int
+ gmbasicUnsafeSlice :: Mutable v s a -> Mutable v s a
+ gmbasicUnsafeNew :: ST s (Mutable v s a)
+ gmbasicUnsafeWrite :: a -> Mutable v s a -> ST s ()
+ gmbasicUnsafeGrow :: Mutable v s a -> Int -> m (Mutable v s a)
+ gbasicUnsafeFreeze :: Mutable v s a -> ST s (v a)
+
+sfoldlM :: (a -> b -> ST s a) -> (t -> Step t b) -> a -> t -> ST s a
+sfoldlM m step = foldlM_loop
+ where
+ foldlM_loop z s
+ = case step s of
+ Yield x s' -> do { z' <- m z x; foldlM_loop z' s' }
+ Done -> return z
+{-# INLINE [1] sfoldlM #-}
+
+sappend :: Stream Identity a -> Stream Identity a -> Stream Identity a
+Stream stepa ta `sappend` Stream stepb _ = Stream step (Left ta)
+ where
+ {-# INLINE [0] step #-}
+ step (Left sa) = do
+ r <- stepa sa
+ return $ case r of
+ Yield x _ -> Yield x (Left sa)
+ Done -> Done
+ step (Right sb) = do
+ r <- stepb sb
+ return $ case r of
+ Yield x _ -> Yield x (Right sb)
+ Done -> Done
+{-# INLINE [1] sappend #-}
+
+ssingleton :: Monad m => a -> Stream m (Chunk v a)
+ssingleton x = Stream (return . step) True
+ where
+ {-# INLINE [0] step #-}
+ step True = Yield (MkChunk (gmbasicUnsafeWrite x)) False
+ step False = Done
+{-# INLINE [1] ssingleton #-}
+
+gmvmunstreamUnknown :: GVector v a => Stream Identity (Chunk v a) -> v a
+gmvmunstreamUnknown (Stream vstep u)
+ = runST (do
+ v <- gmbasicUnsafeNew
+ sfoldlM copyChunk (runIdentity . vstep) (v,0) u
+ gbasicUnsafeFreeze v)
+ where
+ {-# INLINE [0] copyChunk #-}
+ copyChunk (v,i) (MkChunk f)
+ = do
+ v' <- gmbasicUnsafeGrow v (gmbasicLength v)
+ f (gmbasicUnsafeSlice v')
+ return (v',i)
+{-# INLINE gmvmunstreamUnknown #-}
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -317,3 +317,4 @@ test('T17966',
# NB: T17810: -fspecialise-aggressively
test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0'])
test('T18013', normal, multimod_compile, ['T18013', '-v0 -O'])
+test('T18098', normal, compile, ['-dcore-lint -O2'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d8b44dad5d0d417c86a2d65f14e53986fd499183...6e659dece9614de57f99e0322dad399491b620bc
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d8b44dad5d0d417c86a2d65f14e53986fd499183...6e659dece9614de57f99e0322dad399491b620bc
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/20200430/f61b54e0/attachment-0001.html>
More information about the ghc-commits
mailing list