diff options
author | Luite Stegeman <stegeman@gmail.com> | 2020-12-10 14:19:02 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-03-20 07:49:15 -0400 |
commit | dd11f2d5e87ba83ca16510e3e1ac6c41c1df1647 (patch) | |
tree | 66550e7e66b679ae9ec31cab237d7bbced67b2ee | |
parent | ceef490b25dbff93860b121c58b0191b1a0c07bf (diff) | |
download | haskell-dd11f2d5e87ba83ca16510e3e1ac6c41c1df1647.tar.gz |
Save the type of breakpoints in the Breakpoint tick in STG
GHCi needs to know the types of all breakpoints, but it's
not possible to get the exprType of any expression in STG.
This is preparation for the upcoming change to make GHCi
bytecode from STG instead of Core.
-rw-r--r-- | compiler/GHC/Cmm/Parser.y | 2 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/Dwarf.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/PPC/CodeGen.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/CmmToAsm/X86/CodeGen.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core.hs | 44 | ||||
-rw-r--r-- | compiler/GHC/Core/FVs.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Core/Lint.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/OccurAnal.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Ppr.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Core/Subst.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/Tidy.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Core/Utils.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/CoreToByteCode.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/CoreToStg.hs | 30 | ||||
-rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Coverage.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Stg/FVs.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 2 |
23 files changed, 97 insertions, 55 deletions
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 92e981a841..ceb5ba8bad 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -224,7 +224,7 @@ import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame ) -import GHC.Core ( Tickish(SourceNote) ) +import GHC.Core ( GenTickish(SourceNote) ) import GHC.Cmm.Opt import GHC.Cmm.Graph diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 7e03549b24..ab728dcb92 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(..) ) +import GHC.Core ( Tickish, GenTickish(..) ) import GHC.Cmm.DebugBlock import GHC.Unit.Module import GHC.Utils.Outputable diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index 01a3a67333..d547412935 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -57,7 +57,7 @@ import GHC.Cmm.Switch import GHC.Cmm.CLabel import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph -import GHC.Core ( Tickish(..) ) +import GHC.Core ( GenTickish(..) ) import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -- The rest: diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 60d19f43c1..7699b0c692 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -72,7 +72,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel -import GHC.Core ( Tickish(..) ) +import GHC.Core ( GenTickish(..) ) import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol ) -- The rest: diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 168e33e189..fee181ac70 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -6,6 +6,12 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} + + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -13,7 +19,8 @@ module GHC.Core ( -- * Main data types Expr(..), Alt(..), Bind(..), AltCon(..), Arg, - Tickish(..), TickishScoping(..), TickishPlacement(..), + GenTickish(..), Tickish, StgTickish, + TickishScoping(..), TickishPlacement(..), CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, @@ -117,6 +124,7 @@ import GHC.Unit.Module import GHC.Types.Basic import GHC.Types.Unique.Set import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan ) +import GHC.Hs.Extension ( NoExtField ) import GHC.Utils.Binary import GHC.Utils.Misc @@ -941,9 +949,22 @@ type MOutCoercion = MCoercion -- | Allows attaching extra information to points in expressions +-- | Used as a data type index for the GenTickish annotations +data TickishPass + = TickishCore + | TickishStg + +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 Tickish = GenTickish 'TickishCore +type StgTickish = GenTickish 'TickishStg + -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint -data Tickish id = +data GenTickish pass id = -- | An @{-# SCC #-}@ profiling annotation, either automatically -- added by the desugarer as a result of -auto-all, or added by -- the user. @@ -968,7 +989,8 @@ data Tickish id = -- NB. we must take account of these Ids when (a) counting free variables, -- and (b) substituting (don't substitute for them) | Breakpoint - { breakpointId :: !Int + { breakpointExt :: XBreakpoint pass + , breakpointId :: !Int , breakpointFVs :: [id] -- ^ the order of this list is important: -- it matches the order of the lists in the -- appropriate entry in 'GHC.ByteCode.Types.ModBreaks'. @@ -999,7 +1021,11 @@ data Tickish id = -- (uses same names as CCs) } - deriving (Eq, Ord, Data) +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 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, @@ -1009,7 +1035,7 @@ data Tickish id = -- 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 :: Tickish id -> Bool +tickishCounts :: GenTickish pass id -> Bool tickishCounts n@ProfNote{} = profNoteCount n tickishCounts HpcTick{} = True tickishCounts Breakpoint{} = True @@ -1078,7 +1104,7 @@ data TickishScoping = deriving (Eq) -- | Returns the intended scoping rule for a Tickish -tickishScoped :: Tickish id -> TickishScoping +tickishScoped :: GenTickish pass id -> TickishScoping tickishScoped n@ProfNote{} | profNoteScope n = CostCentreScope | otherwise = NoScope @@ -1091,7 +1117,7 @@ tickishScoped SourceNote{} = SoftScope -- | Returns whether the tick scoping rule is at least as permissive -- as the given scoping rule. -tickishScopesLike :: Tickish id -> TickishScoping -> Bool +tickishScopesLike :: GenTickish pass id -> TickishScoping -> Bool tickishScopesLike t scope = tickishScoped t `like` scope where NoScope `like` _ = True _ `like` NoScope = False @@ -1110,7 +1136,7 @@ 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 :: Tickish id -> Bool +tickishFloatable :: GenTickish pass id -> Bool tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) -- | Returns @True@ for a tick that is both counting /and/ scoping and @@ -1148,7 +1174,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 :: Tickish id -> Bool +tickishIsCode :: GenTickish pass id -> Bool tickishIsCode SourceNote{} = False tickishIsCode _tickish = True -- all the rest for now diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs index bf5dab7bc3..da661f1439 100644 --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -290,7 +290,7 @@ exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs tickish_fvs :: Tickish Id -> FV -tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids +tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV {- @@ -779,8 +779,8 @@ freeVars = go , AnnTick tickish expr2 ) where expr2 = go expr - tickishFVs (Breakpoint _ ids) = mkDVarSet ids - tickishFVs _ = emptyDVarSet + tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 89914e967f..f3c69defef 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -857,10 +857,10 @@ lintCoreExpr (Cast expr co) lintCoreExpr (Tick tickish expr) = do case tickish of - Breakpoint _ ids -> forM_ ids $ \id -> do - checkDeadIdOcc id - lookupIdInScope id - _ -> return () + Breakpoint _ _ ids -> forM_ ids $ \id -> do + checkDeadIdOcc id + lookupIdInScope id + _ -> return () markAllJoinsBadIf block_joins $ lintCoreExpr expr where block_joins = not (tickish `tickishScopesLike` SoftScope) diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 3f31ae258b..74fe628a49 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -1929,7 +1929,7 @@ occAnal env (Tick tickish body) | tickish `tickishScopesLike` SoftScope = (markAllNonTail usage, Tick tickish body') - | Breakpoint _ ids <- tickish + | Breakpoint _ _ ids <- tickish = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body') -- never substitute for any of the Ids in a Breakpoint diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 13f0fdc46c..f137534ec0 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1254,8 +1254,8 @@ simplTick env tickish expr cont simplTickish env tickish - | Breakpoint n ids <- tickish - = Breakpoint n (map (getDoneId . substId env) ids) + | Breakpoint ext n ids <- tickish + = Breakpoint ext n (map (getDoneId . substId env) ids) | otherwise = tickish -- Push type application and coercion inside a tick diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index c2510b97c0..63e52ce258 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -1126,8 +1126,8 @@ specLam env bndrs body -------------- specTickish :: SpecEnv -> Tickish Id -> Tickish Id -specTickish env (Breakpoint ix ids) - = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]] +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. -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index ddfa2ea2a6..820f1f1785 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -1,4 +1,7 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -fno-warn-orphans #-} {- @@ -645,13 +648,13 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ----------------------------------------------------- -} -instance Outputable id => Outputable (Tickish id) where +instance Outputable id => Outputable (GenTickish pass id) where ppr (HpcTick modl ix) = hcat [text "hpc<", ppr modl, comma, ppr ix, text ">"] - ppr (Breakpoint ix vars) = + ppr (Breakpoint _ext ix vars) = hcat [text "break<", ppr ix, text ">", diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 918733a725..7110208d79 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -718,8 +718,8 @@ substDVarSet subst fvs ------------------ substTickish :: Subst -> Tickish Id -> Tickish Id -substTickish subst (Breakpoint n ids) - = Breakpoint n (map do_one ids) +substTickish subst (Breakpoint ext n ids) + = Breakpoint ext n (map do_one ids) where do_one = getIdFromTrivialExpr . lookupIdSubst subst substTickish _subst other = other diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index a1b66ec3f8..3e71d2c5b2 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -89,7 +89,8 @@ tidyAlt env (Alt con vs rhs) ------------ Tickish -------------- tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id -tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) +tidyTickish env (Breakpoint ext ix ids) + = Breakpoint ext ix (map (tidyVarOcc env) ids) tidyTickish _ other_tickish = other_tickish ------------ Rules -------------- diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index b87ab11453..f2772edd8b 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -2168,7 +2168,7 @@ eqExpr in_scope e1 e2 = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool -eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) +eqTickish env (Breakpoint _ lid lids) (Breakpoint _ rid rids) = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids eqTickish _ l r = l == r diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index b1ebac9231..23bb018806 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -418,7 +418,7 @@ schemeR_wrk fvs nm original_body (args, body) -- introduce break instructions for ticked expressions schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList schemeER_wrk d p rhs - | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs + | AnnTick (Breakpoint _ext tick_no fvs) (_annot, newRhs) <- rhs = do code <- schemeE d 0 p newRhs cc_arr <- getCCArray this_mod <- moduleName <$> getCurrentModule @@ -616,7 +616,7 @@ schemeE d s p (AnnLet binds (_,body)) = do -- call exprFreeVars on a deAnnotated expression, this may not be the -- best way to calculate the free vars but it seemed like the least -- intrusive thing to do -schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs) +schemeE d s p exp@(AnnTick (Breakpoint _ext _id _fvs) _rhs) | isLiftedTypeKind (typeKind ty) = do id <- newId ty -- Todo: is emptyVarSet correct on the next line? diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index bfe9a6c89b..7b930b9c01 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -413,13 +413,14 @@ coreToStgExpr expr@(Lam _ _) text "Unexpected value lambda:" $$ ppr expr coreToStgExpr (Tick tick expr) - = do case tick of - HpcTick{} -> return () - ProfNote{} -> return () - SourceNote{} -> return () - Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen" + = do stg_tick <- case tick of + HpcTick m i -> return (HpcTick m i) + ProfNote cc cnt sc -> return (ProfNote cc cnt sc) + SourceNote span nm -> return (SourceNote span nm) + Breakpoint{} -> + panic "coreToStgExpr: breakpoint should not happen" expr2 <- coreToStgExpr expr - return (StgTick tick expr2) + return (StgTick stg_tick expr2) coreToStgExpr (Cast expr _) = coreToStgExpr expr @@ -568,7 +569,12 @@ coreToStgApp f args ticks = do TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args') _other -> StgApp f args' - tapp = foldr StgTick app (ticks ++ ticks') + convert_tick (Breakpoint _ bid fvs) = res_ty `seq` Breakpoint res_ty bid fvs + convert_tick (HpcTick m i) = HpcTick m i + convert_tick (SourceNote span nm) = SourceNote span nm + convert_tick (ProfNote cc cnt scope) = ProfNote cc cnt scope + add_tick !t !e = StgTick t e + tapp = foldr add_tick app (map convert_tick ticks ++ ticks') -- Forcing these fixes a leak in the code generator, noticed while -- profiling for trac #4367 @@ -579,7 +585,7 @@ coreToStgApp f args ticks = do -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- -coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id]) +coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish Id]) coreToStgArgs [] = return ([], []) @@ -594,7 +600,13 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token coreToStgArgs (Tick t e : args) = ASSERT( not (tickishIsCode t) ) do { (args', ts) <- coreToStgArgs (e : args) - ; return (args', t:ts) } + ; let convert_tick (Breakpoint _ bid fvs) = + let !ty = exprType e in Breakpoint ty bid fvs + convert_tick (HpcTick m i) = HpcTick m i + convert_tick (SourceNote span nm) = SourceNote span nm + convert_tick (ProfNote cc cnt scope) = ProfNote cc cnt scope + !t' = convert_tick t + ; return (args', t':ts) } coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, ticks) <- coreToStgArgs args diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 5395a737d6..21c1fb0272 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -610,9 +610,9 @@ cpeRhsE env (Tick tickish expr) = do { body <- cpeBodyNF env expr ; return (emptyFloats, mkTick tickish' body) } where - tickish' | Breakpoint n fvs <- tickish + tickish' | Breakpoint ext n fvs <- tickish -- See also 'substTickish' - = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) + = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs) | otherwise = tickish diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index dca2b09f7d..726b69a69a 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -1239,7 +1239,7 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do count = countEntries && gopt Opt_ProfCountEntries dflags return $ ProfNote cc count True{-scopes-} - Breakpoints -> Breakpoint <$> addMixEntry me <*> pure ids + Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids SourceNotes | RealSrcSpan pos' _ <- pos -> return $ SourceNote pos' cc_name diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 14afbeeb14..f4e681420c 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -817,7 +817,7 @@ dffvExpr :: CoreExpr -> DFFV () dffvExpr (Var v) = insert v dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e) = dffvExpr e dffvExpr (Cast e _) = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index ce40307420..3385f2e275 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -47,7 +47,7 @@ import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Var.Set -import GHC.Core ( Tickish(Breakpoint) ) +import GHC.Core ( GenTickish(Breakpoint) ) import GHC.Utils.Misc import Data.Maybe ( mapMaybe ) @@ -139,8 +139,8 @@ expr env = go where (e', fvs) = go e fvs' = unionDVarSet (tickish tick) fvs - tickish (Breakpoint _ ids) = mkDVarSet ids - tickish _ = emptyDVarSet + tickish (Breakpoint _ _ ids) = mkDVarSet ids + tickish _ = emptyDVarSet go_bind dc bind body = (dc bind' body', fvs) where diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index 53e4b07c69..0f2dd258e2 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -68,7 +68,7 @@ module GHC.Stg.Syntax ( import GHC.Prelude -import GHC.Core ( AltCon, Tickish ) +import GHC.Core ( AltCon, StgTickish ) import GHC.Types.CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) import Data.Data ( Data ) @@ -175,13 +175,13 @@ stgArgType (StgLitArg lit) = literalType lit -- | Strip ticks of a given type from an STG expression. -stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) +stripStgTicksTop :: (StgTickish Id -> Bool) -> GenStgExpr p -> ([StgTickish Id], 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 :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p +stripStgTicksTopE :: (StgTickish Id -> 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 - (Tickish Id) + (StgTickish Id) (GenStgExpr pass) -- sub expression -- END of GenStgExpr diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 0e0990b901..91853b5799 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 :: Tickish Id -> FCode () +cgTick :: StgTickish Id -> 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 e19491e93a..bc98bd279f 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -28,7 +28,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) -import GHC.Core (Tickish (..)) +import GHC.Core (Tickish, GenTickish (..)) import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session import GHC.Data.FastString |