[Git][ghc/ghc][wip/T18645] Extract definition of DsM into GHC.HsToCore.Types
Sebastian Graf
gitlab at gitlab.haskell.org
Mon Sep 7 16:02:28 UTC 2020
Sebastian Graf pushed to branch wip/T18645 at Glasgow Haskell Compiler / GHC
Commits:
e8f5cf01 by Sebastian Graf at 2020-09-07T18:02:20+02:00
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 `CheckParserDeps` 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.
Recently, 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 `CheckParserDeps`. 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.
- - - - -
8 changed files:
- compiler/GHC/Driver/Hooks.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Monad.hs
- + compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/ghc.cabal.in
Changes:
=====================================
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
=====================================
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
=====================================
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
=====================================
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
+
=====================================
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
=====================================
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
@@ -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
-
-
{-
************************************************************************
* *
=====================================
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
=====================================
compiler/ghc.cabal.in
=====================================
@@ -312,6 +312,7 @@ Library
GHC.HsToCore.PmCheck
GHC.HsToCore.Coverage
GHC.HsToCore
+ GHC.HsToCore.Types
GHC.HsToCore.Arrows
GHC.HsToCore.Binds
GHC.HsToCore.Foreign.Call
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8f5cf01892647498afe53fe4311d06633c5bafd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8f5cf01892647498afe53fe4311d06633c5bafd
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200907/b980181c/attachment-0001.html>
More information about the ghc-commits
mailing list