Commit a77e48d2 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

Extract definition of DsM into GHC.HsToCore.Types

`DsM` was previously defined in `GHC.Tc.Types`, along with `TcM`. But
`GHC.Tc.Types` is in the set of transitive dependencies of `GHC.Parser`,
a set which we aim to minimise. Test case `CountParserDeps` checks for
that.

Having `DsM` in that set means the parser also depends on the innards of
the pattern-match checker in `GHC.HsToCore.PmCheck.Types`, which is the
reason we have that module in the first place.

In the previous commit, we represented the `TyState` by an `InertSet`,
but that pulls the constraint solver as well as 250 more modules into
the set of dependencies, triggering failure of `CountParserDeps`.
Clearly, we want to evolve the pattern-match checker (and the desugarer)
without being concerned by this test, so this patch includes a small
refactor that puts `DsM` into its own module.
parent 69ea2fee
......@@ -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
......
......@@ -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
......
......@@ -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
-- | 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
......@@ -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
......
......@@ -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
......@@ -289,58 +283,6 @@ data IfLclEnv
if_id_env :: FastStringEnv Id -- Nested id binding
}
{-
************************************************************************
* *
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
{-
************************************************************************
* *
......
......@@ -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
......@@ -314,6 +314,7 @@ Library
GHC.HsToCore.PmCheck
GHC.HsToCore.Coverage
GHC.HsToCore
GHC.HsToCore.Types
GHC.HsToCore.Arrows
GHC.HsToCore.Binds
GHC.HsToCore.Foreign.Call
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment