[Git][ghc/ghc][wip/T18098] Mark rule args as non-tail-called
Simon Peyton Jones
gitlab at gitlab.haskell.org
Wed Apr 29 14:20:07 UTC 2020
Simon Peyton Jones pushed to branch wip/T18098 at Glasgow Haskell Compiler / GHC
Commits:
375769d2 by Simon Peyton Jones at 2020-04-29T15:19:18+01: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
- - - - -
5 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Types/Basic.hs
- + 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/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(..),
@@ -958,6 +958,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
=====================================
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/-/commit/375769d212839751356455a22535f6162877339b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/375769d212839751356455a22535f6162877339b
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/20200429/795116ea/attachment-0001.html>
More information about the ghc-commits
mailing list