diff options
30 files changed, 99 insertions, 80 deletions
diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 943efaa3fd..37a27fd75f 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -34,7 +34,7 @@ import GHC.Data.FastString import GHC.Types.ForeignCall import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout -import GHC.Core (Tickish) +import GHC.Core (CmmTickish) import qualified GHC.Types.Unique as U import GHC.Cmm.Dataflow.Block @@ -597,9 +597,6 @@ mapCollectSuccessors _ n = (n, []) -- ----------------------------------------------------------------------------- --- | Tickish in Cmm context (annotations only) -type CmmTickish = Tickish () - -- | Tick scope identifier, allowing us to reason about what -- annotations in a Cmm block should scope over. We especially take -- care to allow optimisations to reorganise blocks without losing diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index ab728dcb92..b79397a998 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -7,7 +7,7 @@ import GHC.Prelude import GHC.Cmm.CLabel import GHC.Cmm.Expr ( GlobalReg(..) ) import GHC.Settings.Config ( cProjectName, cProjectVersion ) -import GHC.Core ( Tickish, GenTickish(..) ) +import GHC.Core ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock import GHC.Unit.Module import GHC.Utils.Outputable @@ -210,7 +210,7 @@ blockToDwarf config blk | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk | otherwise = Nothing -- block was optimized out -tickToDwarf :: Tickish () -> [DwarfInfo] +tickToDwarf :: CmmTickish -> [DwarfInfo] tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss] tickToDwarf _ = [] diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index fee181ac70..2b9da7a1dd 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -19,7 +19,7 @@ module GHC.Core ( -- * Main data types Expr(..), Alt(..), Bind(..), AltCon(..), Arg, - GenTickish(..), Tickish, StgTickish, + GenTickish(..), Tickish, StgTickish, CmmTickish, XTickishId, TickishScoping(..), TickishPlacement(..), CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, @@ -275,7 +275,7 @@ data Expr b | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants] -- and Note [Why does Case have a 'Type' field?] | Cast (Expr b) Coercion - | Tick (Tickish Id) (Expr b) + | Tick Tickish (Expr b) | Type Type | Coercion Coercion deriving Data @@ -953,18 +953,27 @@ type MOutCoercion = MCoercion data TickishPass = TickishCore | TickishStg + | TickishCmm type family XBreakpoint (pass :: TickishPass) type instance XBreakpoint 'TickishCore = NoExtField -- | Keep track of the type of breakpoints in STG, for GHCi type instance XBreakpoint 'TickishStg = Type +type instance XBreakpoint 'TickishCmm = NoExtField + +type family XTickishId (pass :: TickishPass) +type instance XTickishId 'TickishCore = Id +type instance XTickishId 'TickishStg = Id +type instance XTickishId 'TickishCmm = NoExtField type Tickish = GenTickish 'TickishCore type StgTickish = GenTickish 'TickishStg +-- | Tickish in Cmm context (annotations only) +type CmmTickish = GenTickish 'TickishCmm -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint -data GenTickish pass id = +data GenTickish pass = -- | An @{-# SCC #-}@ profiling annotation, either automatically -- added by the desugarer as a result of -auto-all, or added by -- the user. @@ -991,7 +1000,8 @@ data GenTickish pass id = | Breakpoint { breakpointExt :: XBreakpoint pass , breakpointId :: !Int - , breakpointFVs :: [id] -- ^ the order of this list is important: + , breakpointFVs :: [XTickishId pass] + -- ^ the order of this list is important: -- it matches the order of the lists in the -- appropriate entry in 'GHC.ByteCode.Types.ModBreaks'. -- @@ -1021,11 +1031,16 @@ data GenTickish pass id = -- (uses same names as CCs) } -deriving instance Eq a => Eq (GenTickish 'TickishCore a) -deriving instance Ord a => Ord (GenTickish 'TickishCore a) -deriving instance Data a => Data (GenTickish 'TickishCore a) +deriving instance Eq (GenTickish 'TickishCore) +deriving instance Ord (GenTickish 'TickishCore) +deriving instance Data (GenTickish 'TickishCore) + +deriving instance Data (GenTickish 'TickishStg) + +deriving instance Eq (GenTickish 'TickishCmm) +deriving instance Ord (GenTickish 'TickishCmm) +deriving instance Data (GenTickish 'TickishCmm) -deriving instance Data a => Data (GenTickish 'TickishStg a) -- | A "counting tick" (where tickishCounts is True) is one that -- counts evaluations in some way. We cannot discard a counting tick, @@ -1035,7 +1050,7 @@ deriving instance Data a => Data (GenTickish 'TickishStg a) -- However, we still allow the simplifier to increase or decrease -- sharing, so in practice the actual number of ticks may vary, except -- that we never change the value from zero to non-zero or vice versa. -tickishCounts :: GenTickish pass id -> Bool +tickishCounts :: GenTickish pass -> Bool tickishCounts n@ProfNote{} = profNoteCount n tickishCounts HpcTick{} = True tickishCounts Breakpoint{} = True @@ -1104,7 +1119,7 @@ data TickishScoping = deriving (Eq) -- | Returns the intended scoping rule for a Tickish -tickishScoped :: GenTickish pass id -> TickishScoping +tickishScoped :: GenTickish pass -> TickishScoping tickishScoped n@ProfNote{} | profNoteScope n = CostCentreScope | otherwise = NoScope @@ -1117,7 +1132,7 @@ tickishScoped SourceNote{} = SoftScope -- | Returns whether the tick scoping rule is at least as permissive -- as the given scoping rule. -tickishScopesLike :: GenTickish pass id -> TickishScoping -> Bool +tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool tickishScopesLike t scope = tickishScoped t `like` scope where NoScope `like` _ = True _ `like` NoScope = False @@ -1136,24 +1151,24 @@ tickishScopesLike t scope = tickishScoped t `like` scope -- @tickishCounts@. Note that in principle splittable ticks can become -- floatable using @mkNoTick@ -- even though there's currently no -- tickish for which that is the case. -tickishFloatable :: GenTickish pass id -> Bool +tickishFloatable :: GenTickish pass -> Bool tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) -- | Returns @True@ for a tick that is both counting /and/ scoping and -- can be split into its (tick, scope) parts using 'mkNoScope' and -- 'mkNoTick' respectively. -tickishCanSplit :: Tickish id -> Bool +tickishCanSplit :: GenTickish pass -> Bool tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} = True tickishCanSplit _ = False -mkNoCount :: Tickish id -> Tickish id +mkNoCount :: GenTickish pass -> GenTickish pass mkNoCount n | not (tickishCounts n) = n | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" mkNoCount n@ProfNote{} = n {profNoteCount = False} mkNoCount _ = panic "mkNoCount: Undefined split!" -mkNoScope :: Tickish id -> Tickish id +mkNoScope :: GenTickish pass -> GenTickish pass mkNoScope n | tickishScoped n == NoScope = n | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" mkNoScope n@ProfNote{} = n {profNoteScope = False} @@ -1174,7 +1189,7 @@ mkNoScope _ = panic "mkNoScope: Undefined split!" -- Here there is just no operational difference between the first and -- the second version. Therefore code generation should simply -- translate the code as if it found the latter. -tickishIsCode :: GenTickish pass id -> Bool +tickishIsCode :: GenTickish pass -> Bool tickishIsCode SourceNote{} = False tickishIsCode _tickish = True -- all the rest for now @@ -1214,7 +1229,7 @@ data TickishPlacement = deriving (Eq) -- | Placement behaviour we want for the ticks -tickishPlace :: Tickish id -> TickishPlacement +tickishPlace :: GenTickish pass -> TickishPlacement tickishPlace n@ProfNote{} | profNoteCount n = PlaceRuntime | otherwise = PlaceCostCentre @@ -1224,7 +1239,8 @@ tickishPlace SourceNote{} = PlaceNonLam -- | Returns whether one tick "contains" the other one, therefore -- making the second tick redundant. -tickishContains :: Eq b => Tickish b -> Tickish b -> Bool +tickishContains :: Eq (GenTickish pass) + => GenTickish pass -> GenTickish pass -> Bool tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) = containsSpan sp1 sp2 && n1 == n2 -- compare the String last @@ -2237,8 +2253,8 @@ stripNArgs _ _ = Nothing -- | Like @collectArgs@, but also collects looks through floatable -- ticks if it means that we can find more arguments. -collectArgsTicks :: (Tickish Id -> Bool) -> Expr b - -> (Expr b, [Arg b], [Tickish Id]) +collectArgsTicks :: (Tickish -> Bool) -> Expr b + -> (Expr b, [Arg b], [Tickish]) collectArgsTicks skipTick expr = go expr [] [] where @@ -2323,7 +2339,7 @@ data AnnExpr' bndr annot | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) | AnnCast (AnnExpr bndr annot) (annot, Coercion) -- Put an annotation on the (root of) the coercion - | AnnTick (Tickish Id) (AnnExpr bndr annot) + | AnnTick Tickish (AnnExpr bndr annot) | AnnType Type | AnnCoercion Coercion @@ -2344,8 +2360,8 @@ collectAnnArgs expr go (_, AnnApp f a) as = go f (a:as) go e as = (e, as) -collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a - -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) +collectAnnArgsTicks :: (Tickish -> Bool) -> AnnExpr b a + -> (AnnExpr b a, [AnnExpr b a], [Tickish]) collectAnnArgsTicks tickishOk expr = go expr [] [] where diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index da661f1439..8baa5f26f8 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -6,6 +6,7 @@ Taken quite directly from the Peyton Jones/Lester paper. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} -- | A module concerned with finding the free variables of an expression. module GHC.Core.FVs ( @@ -289,7 +290,7 @@ rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs -tickish_fvs :: Tickish Id -> FV +tickish_fvs :: Tickish -> FV tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV diff --git a/compiler/GHC/Core/Map/Expr.hs b/compiler/GHC/Core/Map/Expr.hs index 03c0876138..b4a687f2c2 100644 --- a/compiler/GHC/Core/Map/Expr.hs +++ b/compiler/GHC/Core/Map/Expr.hs @@ -324,11 +324,11 @@ xtE (D env (Case e b ty as)) f m in xtList (xtA env1) as f } -- TODO: this seems a bit dodgy, see 'eqTickish' -type TickishMap a = Map.Map (Tickish Id) a -lkTickish :: Tickish Id -> TickishMap a -> Maybe a +type TickishMap a = Map.Map Tickish a +lkTickish :: Tickish -> TickishMap a -> Maybe a lkTickish = lookupTM -xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a +xtTickish :: Tickish -> XT a -> TickishMap a -> TickishMap a xtTickish = alterTM ------------------------ diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs index 0807675d57..5a88482b42 100644 --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -82,7 +82,7 @@ doExpr env e@(Var v) top:_ -> nameSrcSpan $ varName top _ -> noSrcSpan cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span - tick :: Tickish Id + tick :: Tickish tick = ProfNote cc True True pure $ Tick tick e | otherwise = pure e diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index 26a7c261bf..b8b434292f 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -738,7 +738,7 @@ atJoinCeiling (fs, floats, expr') where (floats', ceils) = partitionAtJoinCeiling floats -wrapTick :: Tickish Id -> FloatBinds -> FloatBinds +wrapTick :: Tickish -> FloatBinds -> FloatBinds wrapTick t (FB tops ceils defns) = FB (mapBag wrap_bind tops) (wrap_defns ceils) (M.map (M.map wrap_defns) defns) diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 74fe628a49..96c63f11a7 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2055,7 +2055,7 @@ Constructors are rather like lambdas in this way. -} occAnalApp :: OccEnv - -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) + -> (Expr CoreBndr, [Arg CoreBndr], [Tickish]) -> (UsageDetails, Expr CoreBndr) -- Naked variables (not applied) end up here too occAnalApp env (Var fun, args, ticks) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index c85b39754e..a9b5eabc30 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -981,7 +981,7 @@ ticks. More often than not, other references will be unfoldings of x_exported, and therefore carry the tick anyway. -} -type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks +type IndEnv = IdEnv (Id, [Tickish]) -- Maps local_id -> exported_id, ticks shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index f137534ec0..d3522f5478 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -5,6 +5,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where @@ -1160,7 +1161,7 @@ simplCoercion env co -- long as this is a non-scoping tick, to let case and application -- optimisations apply. -simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont +simplTick :: SimplEnv -> Tickish -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr) simplTick env tickish expr cont -- A scoped tick turns into a continuation, so that we can spot diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 2e27466c55..a8b16f8ba3 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -166,7 +166,7 @@ data SimplCont , sc_cont :: SimplCont } | TickIt -- (TickIt t K)[e] = K[ tick t e ] - (Tickish Id) -- Tick tickish <hole> + Tickish -- Tick tickish <hole> SimplCont type StaticEnv = SimplEnv -- Just the static part is relevant diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 63e52ce258..ee08e31eb5 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1125,7 +1125,7 @@ specLam env bndrs body ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } -------------- -specTickish :: SpecEnv -> Tickish Id -> Tickish Id +specTickish :: SpecEnv -> Tickish -> Tickish specTickish env (Breakpoint ext ix ids) = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env id]] -- drop vars from the list if they have a non-variable substitution. diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index 820f1f1785..06c35c1d28 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -648,7 +650,7 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ----------------------------------------------------- -} -instance Outputable id => Outputable (GenTickish pass id) where +instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where ppr (HpcTick modl ix) = hcat [text "hpc<", ppr modl, comma, diff --git a/compiler/GHC/Core/Seq.hs b/compiler/GHC/Core/Seq.hs index 4dafc9c2e8..ce145b1c9c 100644 --- a/compiler/GHC/Core/Seq.hs +++ b/compiler/GHC/Core/Seq.hs @@ -21,7 +21,7 @@ import GHC.Types.Var.Set( seqDVarSet ) import GHC.Types.Var( varType, tyVarKind ) import GHC.Core.Type( seqType, isTyVar ) import GHC.Core.Coercion( seqCo ) -import GHC.Types.Id( Id, idInfo ) +import GHC.Types.Id( idInfo ) -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the -- compiler @@ -71,7 +71,7 @@ seqExprs :: [CoreExpr] -> () seqExprs [] = () seqExprs (e:es) = seqExpr e `seq` seqExprs es -seqTickish :: Tickish Id -> () +seqTickish :: Tickish -> () seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () seqTickish HpcTick{} = () seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 81bbc9247e..07b77a5d12 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -1322,7 +1322,7 @@ Currently, it is used in GHC.Core.Rules.match, and is required to make -} exprIsLambda_maybe :: InScopeEnv -> CoreExpr - -> Maybe (Var, CoreExpr,[Tickish Id]) + -> Maybe (Var, CoreExpr,[Tickish]) -- See Note [exprIsLambda_maybe] -- The simple case: It is a lambda already diff --git a/compiler/GHC/Core/Stats.hs b/compiler/GHC/Core/Stats.hs index 46d5af5106..a25fd7b108 100644 --- a/compiler/GHC/Core/Stats.hs +++ b/compiler/GHC/Core/Stats.hs @@ -116,7 +116,7 @@ exprSize (Tick n e) = tickSize n + exprSize e exprSize (Type _) = 1 exprSize (Coercion _) = 1 -tickSize :: Tickish Id -> Int +tickSize :: Tickish -> Int tickSize (ProfNote _ _ _) = 1 tickSize _ = 1 diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 7110208d79..bcf5790b99 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -717,7 +717,7 @@ substDVarSet subst fvs | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc ------------------ -substTickish :: Subst -> Tickish Id -> Tickish Id +substTickish :: Subst -> Tickish -> Tickish substTickish subst (Breakpoint ext n ids) = Breakpoint ext n (map do_one ids) where diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 3e71d2c5b2..2c4b0b9203 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -88,7 +88,7 @@ tidyAlt env (Alt con vs rhs) (Alt con vs (tidyExpr env' rhs)) ------------ Tickish -------------- -tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +tidyTickish :: TidyEnv -> Tickish -> Tickish tidyTickish env (Breakpoint ext ix ids) = Breakpoint ext ix (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index f2772edd8b..35a32d4c5d 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -339,7 +339,7 @@ mkCast expr co -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. -mkTick :: Tickish Id -> CoreExpr -> CoreExpr +mkTick :: Tickish -> CoreExpr -> CoreExpr mkTick t orig_expr = mkTick' id id orig_expr where -- Some ticks (cost-centres) can be split in two, with the @@ -424,7 +424,7 @@ mkTick t orig_expr = mkTick' id id orig_expr -- Catch-all: Annotate where we stand _any -> top $ Tick t $ rest expr -mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr +mkTicks :: [Tickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks isSaturatedConApp :: CoreExpr -> Bool @@ -435,13 +435,13 @@ isSaturatedConApp e = go e [] go (Cast f _) as = go f as go _ _ = False -mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr +mkTickNoHNF :: Tickish -> CoreExpr -> CoreExpr mkTickNoHNF t e | exprIsHNF e = tickHNFArgs t e | otherwise = mkTick t e -- push a tick into the arguments of a HNF (call or constructor app) -tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr +tickHNFArgs :: Tickish -> CoreExpr -> CoreExpr tickHNFArgs t e = push t e where push t (App f (Type u)) = App (push t f) (Type u) @@ -449,28 +449,28 @@ tickHNFArgs t e = push t e push _t e = e -- | Strip ticks satisfying a predicate from top of an expression -stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) +stripTicksTop :: (Tickish -> Bool) -> Expr b -> ([Tickish], Expr b) stripTicksTop p = go [] where go ts (Tick t e) | p t = go (t:ts) e go ts other = (reverse ts, other) -- | Strip ticks satisfying a predicate from top of an expression, -- returning the remaining expression -stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksTopE :: (Tickish -> Bool) -> Expr b -> Expr b stripTicksTopE p = go where go (Tick t e) | p t = go e go other = other -- | Strip ticks satisfying a predicate from top of an expression, -- returning the ticks -stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksTopT :: (Tickish -> Bool) -> Expr b -> [Tickish] stripTicksTopT p = go [] where go ts (Tick t e) | p t = go (t:ts) e go ts _ = ts -- | Completely strip ticks satisfying a predicate from an -- expression. Note this is O(n) in the size of the expression! -stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksE :: (Tickish -> Bool) -> Expr b -> Expr b stripTicksE p expr = go expr where go (App e a) = App (go e) (go a) go (Lam b e) = Lam b (go e) @@ -486,7 +486,7 @@ stripTicksE p expr = go expr go_b (b, e) = (b, go e) go_a (Alt c bs e) = Alt c bs (go e) -stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksT :: (Tickish -> Bool) -> Expr b -> [Tickish] stripTicksT p expr = fromOL $ go expr where go (App e a) = go e `appOL` go a go (Lam _ e) = go e @@ -2103,7 +2103,7 @@ cheapEqExpr :: Expr b -> Expr b -> Bool cheapEqExpr = cheapEqExpr' (const False) -- | Cheap expression equality test, can ignore ticks by type. -cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool +cheapEqExpr' :: (Tickish -> Bool) -> Expr b -> Expr b -> Bool {-# INLINE cheapEqExpr' #-} cheapEqExpr' ignoreTick e1 e2 = go e1 e2 @@ -2167,7 +2167,7 @@ eqExpr in_scope e1 e2 go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2) = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 -eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool +eqTickish :: RnEnv2 -> Tickish -> Tickish -> Bool eqTickish env (Breakpoint _ lid lids) (Breakpoint _ rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids eqTickish _ l r = l == r @@ -2483,7 +2483,7 @@ tryEtaReduce bndrs body -> Type -- Type of the function to which the argument is applied -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) -- (and similarly for tyvars, coercion args) - , [Tickish Var]) + , [Tickish]) -- See Note [Eta reduction with casted arguments] ok_arg bndr (Type ty) co _ | Just tv <- getTyVar_maybe ty diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index d48686b615..ac3ddf0207 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -561,7 +561,7 @@ toIfaceOneShot id | isId id = IfaceNoOneShot --------------------- -toIfaceTickish :: Tickish Id -> Maybe IfaceTickish +toIfaceTickish :: Tickish -> Maybe IfaceTickish toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index 7b930b9c01..327e58a860 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -525,7 +525,7 @@ mkStgAltType bndr alts coreToStgApp :: Id -- Function -> [CoreArg] -- Arguments - -> [Tickish Id] -- Debug ticks + -> [Tickish] -- Debug ticks -> CtsM StgExpr coreToStgApp f args ticks = do (args', ticks') <- coreToStgArgs args @@ -585,7 +585,7 @@ coreToStgApp f args ticks = do -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- -coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish Id]) +coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs [] = return ([], []) @@ -965,7 +965,7 @@ myCollectBinders expr -- | Precondition: argument expression is an 'App', and there is a 'Var' at the -- head of the 'App' chain. -myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id]) +myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish]) myCollectArgs expr = go expr [] [] where diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 21c1fb0272..af5a6bcdc3 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -731,7 +731,7 @@ rhsToBody expr = return (emptyFloats, expr) data ArgInfo = CpeApp CoreArg | CpeCast Coercion - | CpeTick (Tickish Id) + | CpeTick Tickish instance Outputable ArgInfo where ppr (CpeApp arg) = text "app" <+> ppr arg @@ -1369,7 +1369,7 @@ data FloatingBind -- but lifted binding -- | See Note [Floating Ticks in CorePrep] - | FloatTick (Tickish Id) + | FloatTick Tickish data Floats = Floats OkToSpec (OrdList FloatingBind) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 726b69a69a..d7b12b4c40 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -385,7 +385,7 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind bindTick - :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id)) + :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe Tickish) bindTick density name pos fvs = do decl_path <- getPathEntry let @@ -1198,7 +1198,7 @@ allocTickBox boxLabel countEntries topOnly pos m = -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars - -> TM (Maybe (Tickish Id)) + -> TM (Maybe Tickish) allocATickBox boxLabel countEntries topOnly pos fvs = ifGoodTickSrcSpan pos (do let @@ -1212,7 +1212,7 @@ allocATickBox boxLabel countEntries topOnly pos fvs = mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] - -> TM (Tickish Id) + -> TM Tickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 8d0eb816c8..eee4a12d2b 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -728,7 +728,7 @@ work out well: -} -- Remark: pattern selectors only occur in unrestricted patterns so we are free -- to select Many as the multiplicity of every let-expression introduced. -mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly +mkSelectorBinds :: [[Tickish]] -- ^ ticks to add, possibly -> LPat GhcTc -- ^ The pattern -> CoreExpr -- ^ Expression to which the pattern is bound -> DsM (Id,[(Id,CoreExpr)]) @@ -991,7 +991,7 @@ mk_fail_msg dflags ctx pat * * ********************************************************************* -} -mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr +mkOptTickBox :: [Tickish] -> CoreExpr -> CoreExpr mkOptTickBox = flip (foldr Tick) mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 26694c1db4..71cbc26afc 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -1533,7 +1533,7 @@ tcIfaceExpr (IfaceTick tickish expr) = do return (Tick tickish' expr') ------------------------- -tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) +tcIfaceTickish :: IfaceTickish -> IfM lcl Tickish tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs index 0fea7a0d72..46206d786e 100644 --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -6,10 +6,10 @@ module GHC.Stg.Debug(collectDebugInformation) where import GHC.Prelude -import GHC.Core import GHC.Stg.Syntax import GHC.Types.Id +import GHC.Types.Tickish import GHC.Core.DataCon import GHC.Types.IPE import GHC.Unit.Module @@ -136,7 +136,7 @@ recordStgIdPosition id best_span ss = do let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss) lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) }) -numberDataCon :: DataCon -> [Tickish Id] -> M ConstructorNumber +numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber -- Unboxed tuples and sums do not allocate so they -- have no info tables. numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber @@ -155,7 +155,7 @@ numberDataCon dc ts = do Nothing -> NoNumber Just res -> Numbered (fst (NE.head res)) -selectTick :: [Tickish Id] -> Maybe SpanWithLabel +selectTick :: [StgTickish] -> Maybe SpanWithLabel selectTick [] = Nothing selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d) selectTick (_:ts) = selectTick ts diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index 3385f2e275..a3d8686507 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + {- | Non-global free variable analysis on STG terms. This pass annotates non-top-level closure bindings with captured variables. Global variables are not diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 0f2dd258e2..72d6760f6f 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -175,13 +175,13 @@ stgArgType (StgLitArg lit) = literalType lit -- | Strip ticks of a given type from an STG expression. -stripStgTicksTop :: (StgTickish Id -> Bool) -> GenStgExpr p -> ([StgTickish Id], GenStgExpr p) +stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p) stripStgTicksTop p = go [] where go ts (StgTick t e) | p t = go (t:ts) e go ts other = (reverse ts, other) -- | Strip ticks of a given type from an STG expression returning only the expression. -stripStgTicksTopE :: (StgTickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p +stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p stripStgTicksTopE p = go where go (StgTick t e) | p t = go e go other = other @@ -368,7 +368,7 @@ Finally for @hpc@ expressions we introduce a new STG construct. -} | StgTick - (StgTickish Id) + StgTickish (GenStgExpr pass) -- sub expression -- END of GenStgExpr @@ -420,7 +420,7 @@ important): DataCon -- Constructor. Never an unboxed tuple or sum, as those -- are not allocated. ConstructorNumber - [Tickish Id] + [StgTickish] [StgArg] -- Args {- diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 91853b5799..8047571d9f 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -1113,7 +1113,7 @@ emitEnter fun = do -- | Generate Cmm code for a tick. Depending on the type of Tickish, -- this will either generate actual Cmm instrumentation code, or -- simply pass on the annotation as a @CmmTickish@. -cgTick :: StgTickish Id -> FCode () +cgTick :: StgTickish -> FCode () cgTick tick = do { platform <- getPlatform ; case tick of diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index bc98bd279f..1310649d54 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -676,7 +676,7 @@ tcPolyCheck _prag_fn sig bind = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind) funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] - -> TcM [Tickish TcId] + -> TcM [Tickish] funBindTicks loc fun_id mod sigs | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected |