diff options
author | Luite Stegeman <stegeman@gmail.com> | 2020-12-10 16:32:19 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-20 07:49:15 -0400 |
commit | 26328a688183e3af49b5ac315b27afc2691bbc46 (patch) | |
tree | 007b8105d2cabf52142cb8f5d7b790e888e42197 /compiler | |
parent | dd11f2d5e87ba83ca16510e3e1ac6c41c1df1647 (diff) | |
download | haskell-26328a688183e3af49b5ac315b27afc2691bbc46.tar.gz |
remove superfluous 'id' type parameter from GenTickish
The 'id' type is now determined by the pass, using the XTickishId
type family.
Diffstat (limited to 'compiler')
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 |