diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Driver/Hooks.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/HsToCore/Types.hs | 77 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Bind.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types.hs | 60 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 23 |
7 files changed, 95 insertions, 76 deletions
diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 98259e3eee..f6aca818f9 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -38,6 +38,7 @@ import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Data.OrdList import GHC.Tc.Types +import GHC.HsToCore.Types import GHC.Data.Bag import GHC.Types.Name.Reader import GHC.Types.Name diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 671e525bb1..be61777722 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -816,7 +816,7 @@ ds_prag_expr (HsPragSCC _ _ cc) expr = do mod_name <- getModule count <- goptM Opt_ProfCountEntries let nm = sl_fs cc - flavour <- ExprCC <$> getCCIndexM nm + flavour <- ExprCC <$> getCCIndexDsM nm Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) <$> dsLExpr expr else dsLExpr expr diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index e7a820a86e..0c9717d4eb 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -30,6 +30,7 @@ module GHC.HsToCore.Monad ( getGhcModeDs, dsGetFamInstEnvs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike, + getCCIndexDsM, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, @@ -73,6 +74,7 @@ import GHC.Types.Basic ( Origin ) import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon +import GHC.HsToCore.Types import GHC.HsToCore.PmCheck.Types import GHC.Types.Id import GHC.Unit.Module @@ -614,3 +616,7 @@ pprRuntimeTrace str doc expr = do message = App (Var unpackCStringId) $ Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) return $ mkApps (Var traceId) [Type (exprType expr), message, expr] + +-- | See 'getCCIndexM'. +getCCIndexDsM :: FastString -> DsM CostCentreIndex +getCCIndexDsM = getCCIndexM ds_cc_st diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs new file mode 100644 index 0000000000..26f6a6af79 --- /dev/null +++ b/compiler/GHC/HsToCore/Types.hs @@ -0,0 +1,77 @@ +-- | Various types used during desugaring. +module GHC.HsToCore.Types ( + DsM, DsLclEnv(..), DsGblEnv(..), + DsMetaEnv, DsMetaVal(..), CompleteMatches + ) where + +import Data.IORef + +import GHC.Types.CostCentre.State +import GHC.Types.Name.Env +import GHC.Types.SrcLoc +import GHC.Types.Var +import GHC.Hs (HsExpr, GhcTc) +import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) +import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Nablas) +import GHC.Core.FamInstEnv +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Unit.Module + +{- +************************************************************************ +* * + Desugarer monad +* * +************************************************************************ + +Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around +a @UniqueSupply@ and some annotations, which +presumably include source-file location information: +-} + +-- | Global read-only context and state of the desugarer. +-- The statefulness is implemented through 'IORef's. +data DsGblEnv + = DsGblEnv + { ds_mod :: Module -- For SCC profiling + , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env + , ds_unqual :: PrintUnqualified + , ds_msgs :: IORef Messages -- Warning messages + , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + -- possibly-imported things + , ds_complete_matches :: CompleteMatches + -- Additional complete pattern matches + , ds_cc_st :: IORef CostCentreState + -- Tracking indices for cost centre annotations + } + +instance ContainsModule DsGblEnv where + extractModule = ds_mod + +-- | Local state of the desugarer, extended as we lexically descend +data DsLclEnv + = DsLclEnv + { dsl_meta :: DsMetaEnv -- ^ Template Haskell bindings + , dsl_loc :: RealSrcSpan -- ^ To put in pattern-matching error msgs + , dsl_nablas :: Nablas + -- ^ See Note [Note [Long-distance information] in "GHC.HsToCore.PmCheck". + -- The set of reaching values Nablas is augmented as we walk inwards, refined + -- through each pattern match in turn + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal + +data DsMetaVal + = DsBound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type THSyntax.Var + + | DsSplice (HsExpr GhcTc) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut + +-- | Desugaring monad. See also 'TcM'. +type DsM = TcRnIf DsGblEnv DsLclEnv + diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index af9073c87f..f2a810dbca 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -681,7 +681,7 @@ funBindTicks loc fun_id mod sigs = getOccFS (Var.varName fun_id) cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str = do - flavour <- DeclCC <$> getCCIndexM cc_name + flavour <- DeclCC <$> getCCIndexTcM cc_name let cc = mkUserCC cc_name mod loc flavour return [ProfNote cc True True] | otherwise diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 3aea91fe7c..884e72f899 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -45,11 +45,7 @@ module GHC.Tc.Types( IdBindingInfo(..), ClosedTypeId, RhsNames, IsGroupClosed(..), SelfBootInfo(..), - pprTcTyThingCategory, pprPECategory, CompleteMatch, - - -- Desugaring types - DsM, DsLclEnv(..), DsGblEnv(..), - DsMetaEnv, DsMetaVal(..), CompleteMatches, + pprTcTyThingCategory, pprPECategory, CompleteMatch, CompleteMatches, -- Template Haskell ThStage(..), SpliceType(..), PendingStuff(..), @@ -105,7 +101,6 @@ import GHC.Tc.Types.Origin import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Nablas) import GHC.Data.IOEnv import GHC.Types.Name.Reader import GHC.Types.Name @@ -190,7 +185,6 @@ type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff type IfG = IfM () -- Top level type IfL = IfM IfLclEnv -- Nested -type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring -- TcRn is the type-checking and renaming monad: the main monad that -- most type-checking takes place in. The global environment is @@ -292,58 +286,6 @@ data IfLclEnv {- ************************************************************************ * * - Desugarer monad -* * -************************************************************************ - -Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around -a @UniqueSupply@ and some annotations, which -presumably include source-file location information: --} - -data DsGblEnv - = DsGblEnv - { ds_mod :: Module -- For SCC profiling - , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env - , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef Messages -- Warning messages - , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, - -- possibly-imported things - , ds_complete_matches :: CompleteMatches - -- Additional complete pattern matches - , ds_cc_st :: IORef CostCentreState - -- Tracking indices for cost centre annotations - } - -instance ContainsModule DsGblEnv where - extractModule = ds_mod - -data DsLclEnv = DsLclEnv { - dsl_meta :: DsMetaEnv, -- Template Haskell bindings - dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs - - -- See Note [Note [Long-distance information] in "GHC.HsToCore.PmCheck" - -- The set of reaching values Nablas is augmented as we walk inwards, - -- refined through each pattern match in turn - dsl_nablas :: Nablas - } - --- Inside [| |] brackets, the desugarer looks --- up variables in the DsMetaEnv -type DsMetaEnv = NameEnv DsMetaVal - -data DsMetaVal - = DsBound Id -- Bound by a pattern inside the [| |]. - -- Will be dynamically alpha renamed. - -- The Id has type THSyntax.Var - - | DsSplice (HsExpr GhcTc) -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut - - -{- -************************************************************************ -* * Global typechecker environment * * ************************************************************************ diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index b2c987794b..96bff3d261 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -138,7 +138,7 @@ module GHC.Tc.Utils.Monad( withException, -- * Stuff for cost centres. - ContainsCostCentreState(..), getCCIndexM, + getCCIndexM, getCCIndexTcM, -- * Types etc. module GHC.Tc.Types, @@ -2081,23 +2081,16 @@ discussion). We don't currently know a general solution to this problem, but we can use uninterruptibleMask_ to avoid the situation. -} --- | Environments which track 'CostCentreState' -class ContainsCostCentreState e where - extractCostCentreState :: e -> TcRef CostCentreState - -instance ContainsCostCentreState TcGblEnv where - extractCostCentreState = tcg_cc_st - -instance ContainsCostCentreState DsGblEnv where - extractCostCentreState = ds_cc_st - -- | Get the next cost centre index associated with a given name. -getCCIndexM :: (ContainsCostCentreState gbl) - => FastString -> TcRnIf gbl lcl CostCentreIndex -getCCIndexM nm = do +getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex +getCCIndexM get_ccs nm = do env <- getGblEnv - let cc_st_ref = extractCostCentreState env + let cc_st_ref = get_ccs env cc_st <- readTcRef cc_st_ref let (idx, cc_st') = getCCIndex nm cc_st writeTcRef cc_st_ref cc_st' return idx + +-- | See 'getCCIndexM'. +getCCIndexTcM :: FastString -> TcM CostCentreIndex +getCCIndexTcM = getCCIndexM tcg_cc_st |