Commit 3f87866a authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix dll-split problem with patch 'Make Core Lint check for locally-bound GlobalId'

The trouble was that my changes made a lot more files transitively link with
DynFlags, which is the root module for the revolting Windows dll-split stuff.

Anyway this patch fixes it, in a good way:

 - Make GHC/Hooks *not* import DsMonad, because DsMonad imports too
   much other stuff (notably tcLookup variants).  Really, Hooks depends
   only on *types* not *code*.

 - To do this I need the DsM type, and the types it depends on,
   not to be part of DsMonad.  So I moved it to TcRnTypes, which is
   where the similar pieces for the TcM and IfM monads live.

 - We can then delete DsMonad.hs-boot

 - There are a bunch of knock-on change, of no great significance
parent 48222831
......@@ -78,7 +78,7 @@ dsBracket :: HsBracket Name -> [PendingTcSplice] -> DsM CoreExpr
dsBracket brack splices
= dsExtendMetaEnv new_bit (do_brack brack)
where
new_bit = mkNameEnv [(n, Splice (unLoc e)) | PendSplice n e <- splices]
new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendSplice n e <- splices]
do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 }
do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 }
......@@ -970,8 +970,8 @@ repSplice :: HsSplice Name -> DsM (Core a)
repSplice (HsSplice n _)
= do { mb_val <- dsLookupMetaEnv n
; case mb_val of
Just (Splice e) -> do { e' <- dsExpr e
; return (MkC e') }
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') }
_ -> pprPanic "HsSplice" (ppr n) }
-- Should not happen; statically checked
......@@ -994,8 +994,8 @@ repE (HsVar x) =
; case mb_val of
Nothing -> do { str <- globalVar x
; repVarOrCon x str }
Just (Bound y) -> repVarOrCon x (coreVar y)
Just (Splice e) -> do { e' <- dsExpr e
Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
......@@ -1434,7 +1434,7 @@ addBinds :: [GenSymBind] -> DsM a -> DsM a
-- Add a list of fresh names for locally bound entities to the
-- meta environment (which is part of the state carried around
-- by the desugarer monad)
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m
addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal)
dupBinder (new, old)
......@@ -1469,9 +1469,9 @@ lookupOcc :: Name -> DsM (Core TH.Name)
lookupOcc n
= do { mb_val <- dsLookupMetaEnv n ;
case mb_val of
Nothing -> globalVar n
Just (Bound x) -> return (coreVar x)
Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n)
Nothing -> globalVar n
Just (DsBound x) -> return (coreVar x)
Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
}
globalVar :: Name -> DsM (Core TH.Name)
......
......@@ -7,6 +7,7 @@
-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
module DsMonad (
DsM, mapM, mapAndUnzipM,
......@@ -64,10 +65,10 @@ import DynFlags
import ErrUtils
import FastString
import Maybes
import GHC.Fingerprint
import Data.IORef
import Control.Monad
import GHC.Fingerprint
{-
************************************************************************
......@@ -115,17 +116,11 @@ orFail _ _ = CanFail
{-
************************************************************************
* *
Monad stuff
Monad functions
* *
************************************************************************
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:
-}
type DsM result = TcRnIf DsGblEnv DsLclEnv result
-- Compatibility functions
fixDs :: (a -> DsM a) -> DsM a
fixDs = fixM
......@@ -135,62 +130,6 @@ type DsWarning = (SrcSpan, SDoc)
-- and we'll do the print_unqual stuff later on to turn it
-- into a Doc.
-- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
-- variables found in 'Data.Array.Parallel'.
--
data PArrBuiltin
= PArrBuiltin
{ lengthPVar :: Var -- ^ lengthP
, replicatePVar :: Var -- ^ replicateP
, singletonPVar :: Var -- ^ singletonP
, mapPVar :: Var -- ^ mapP
, filterPVar :: Var -- ^ filterP
, zipPVar :: Var -- ^ zipP
, crossMapPVar :: Var -- ^ crossMapP
, indexPVar :: Var -- ^ (!:)
, emptyPVar :: Var -- ^ emptyP
, appPVar :: Var -- ^ (+:+)
, enumFromToPVar :: Var -- ^ enumFromToP
, enumFromThenToPVar :: Var -- ^ enumFromThenToP
}
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_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim'
-- iff '-fvectorise' flag was given as well as
-- exported entities of 'Data.Array.Parallel' iff
-- '-XParallelArrays' was given; otherwise, empty
, ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays'
, ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))]
-- ^ Bindings resulted from floating static forms
}
instance ContainsModule DsGblEnv where
extractModule = ds_mod
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan -- to put in pattern-matching error msgs
}
-- Inside [| |] brackets, the desugarer looks
-- up variables in the DsMetaEnv
type DsMetaEnv = NameEnv DsMetaVal
data DsMetaVal
= Bound Id -- Bound by a pattern inside the [| |].
-- Will be dynamically alpha renamed.
-- The Id has type THSyntax.Var
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> DsM a
......@@ -302,8 +241,8 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_static_binds = static_binds_var
}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv
, ds_loc = noSrcSpan
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = noSrcSpan
}
in (gbl_env, lcl_env)
......@@ -366,11 +305,10 @@ getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDynFlags >>= return . ghcMode
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
getSrcSpanDs = do { env <- getLclEnv; return (dsl_loc env) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {dsl_loc = new_loc}) thing_inside
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
......@@ -489,14 +427,14 @@ dsGetFamInstEnvs
; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
dsGetMetaEnv = do { env <- getLclEnv; return (ds_meta env) }
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
= updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
-- | Gets a reference to the SPT entries created so far.
dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))])
......
module DsMonad (DsM) where
import TcRnTypes
data DsGblEnv
data DsLclEnv
type DsM result = TcRnIf DsGblEnv DsLclEnv result
{-
Some notes about this boot file (from Edsko):
DsMonad has a (transitive) dependency on Hooks in at least two ways:
once through Finder, which imports Packages, which imports Hooks; but
that's easily solved, because Finder can import PackageState
instead. However, it is less obvious to me how to resolve the
following import cycle
- DsMonad imports tcIfaceGlobal from TcIface
- TcIface imports (loadWiredInHomeIface, loadInterface, loadDecls,
findAndReadIface) from LoadIface
- LoadIFace imports Hooks
(There might be still others, this is the most direct one at the moment.)
(Just to be clear, Hooks imports DsMonad because it needs the DsM type
for the dsForeignsHook.)
I'm sure this cycle can be broken somehow, but I'm not familiar enough
with this part of the compiler to see if there is a natural point to
do it.
-}
......@@ -473,12 +473,10 @@ compiler_stage2_dll0_MODULES = \
Avail \
Bag \
BasicTypes \
BinIface \
Binary \
BooleanFormula \
BreakArray \
BufWrite \
BuildTyCl \
Class \
CmdLineParser \
CmmType \
......@@ -489,7 +487,6 @@ compiler_stage2_dll0_MODULES = \
Constants \
CoreArity \
CoreFVs \
CoreLint \
CoreSubst \
CoreSyn \
CoreTidy \
......@@ -501,7 +498,6 @@ compiler_stage2_dll0_MODULES = \
Demand \
Digraph \
DriverPhases \
DsMonad \
DynFlags \
Encoding \
ErrUtils \
......@@ -512,7 +508,6 @@ compiler_stage2_dll0_MODULES = \
FastMutInt \
FastString \
FastTypes \
Finder \
Fingerprint \
FiniteMap \
ForeignCall \
......@@ -532,7 +527,6 @@ compiler_stage2_dll0_MODULES = \
IOEnv \
Id \
IdInfo \
IfaceEnv \
IfaceSyn \
IfaceType \
InstEnv \
......@@ -541,7 +535,6 @@ compiler_stage2_dll0_MODULES = \
Lexer \
ListSetOps \
Literal \
LoadIface \
Maybes \
MkCore \
MkId \
......@@ -564,7 +557,6 @@ compiler_stage2_dll0_MODULES = \
Platform \
PlatformConstants \
PprCore \
PrelInfo \
PrelNames \
PrelRules \
Pretty \
......@@ -576,11 +568,8 @@ compiler_stage2_dll0_MODULES = \
StaticFlags \
StringBuffer \
TcEvidence \
TcIface \
TcRnMonad \
TcRnTypes \
TcType \
TcTypeNats \
TrieMap \
TyCon \
Type \
......
-- \section[Hooks]{Low level API hooks}
-- NB: this module is SOURCE-imported by DynFlags, and should primarily
-- refer to *types*, rather than *code*
-- If you import too muchhere , then the revolting compiler_stage2_dll0_MODULES
-- stuff in compiler/ghc.mk makes DynFlags link to too much stuff
module Hooks ( Hooks
, emptyHooks
, lookupHook
......@@ -27,7 +32,6 @@ import HscTypes
import HsDecls
import HsBinds
import HsExpr
import {-# SOURCE #-} DsMonad
import OrdList
import Id
import TcRnTypes
......
-- (c) The University of Glasgow 2006
{-# LANGUAGE CPP, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
module TcEnv(
TyThing(..), TcTyThing(..), TcId,
......
......@@ -36,7 +36,7 @@ import TcPatSyn( tcPatSynBuilderOcc )
import TcPat
import TcMType
import TcType
import DsMonad hiding (Splice)
import DsMonad
import Id
import ConLike
import DataCon
......
......@@ -36,6 +36,10 @@ module TcRnTypes(
TcTypeEnv, TcIdBinder(..), TcTyThing(..), PromotionErr(..),
pprTcTyThingCategory, pprPECategory,
-- Desugaring types
DsM, DsLclEnv(..), DsGblEnv(..), PArrBuiltin(..),
DsMetaEnv, DsMetaVal(..),
-- Template Haskell
ThStage(..), PendingStuff(..), topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel,
......@@ -88,7 +92,7 @@ module TcRnTypes(
pprArising, pprArisingAt,
-- Misc other types
TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds, HoleSort(..)
TcId, TcIdSet, HoleSort(..)
) where
......@@ -130,6 +134,7 @@ import DynFlags
import Outputable
import ListSetOps
import FastString
import GHC.Fingerprint
import Data.Set (Set)
import Control.Monad (ap, liftM)
......@@ -153,27 +158,19 @@ import qualified Language.Haskell.TH as TH
The monad itself has to be defined here, because it is mentioned by ErrCtxt
-}
-- | Type alias for 'IORef'; the convention is we'll use this for mutable
-- bits of data in 'TcGblEnv' which are updated during typechecking and
-- returned at the end.
type TcRef a = IORef a
-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'?
type TcId = Id
type TcIdSet = IdSet
type TcRnIf a b = IOEnv (Env a b)
type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff
type IfG = IfM () -- Top level
type IfL = IfM IfLclEnv -- Nested
-- | Type-checking and renaming monad: the main monad that most type-checking
-- takes place in. The global environment is 'TcGblEnv', which tracks
-- all of the top-level type-checking information we've accumulated while
-- checking a module, while the local environment is 'TcLclEnv', which
-- tracks local information as we move inside expressions.
type TcRn = TcRnIf TcGblEnv TcLclEnv
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
-- 'TcGblEnv', which tracks all of the top-level type-checking
-- information we've accumulated while checking a module, while the
-- local environment is 'TcLclEnv', which tracks local information as
-- we move inside expressions.
-- | Historical "renaming monad" (now it's just 'TcRn').
type RnM = TcRn
......@@ -181,26 +178,6 @@ type RnM = TcRn
-- | Historical "type-checking monad" (now it's just 'TcRn').
type TcM = TcRn
{-
Representation of type bindings to uninstantiated meta variables used during
constraint solving.
-}
data TcTyVarBind = TcTyVarBind TcTyVar TcType
type TcTyVarBinds = Bag TcTyVarBind
instance Outputable TcTyVarBind where
ppr (TcTyVarBind tv ty) = ppr tv <+> text ":=" <+> ppr ty
{-
************************************************************************
* *
The main environment types
* *
************************************************************************
-}
-- We 'stack' these envs through the Reader like monad infastructure
-- as we move into an expression (although the change is focused in
-- the lcl type).
......@@ -226,6 +203,125 @@ instance ContainsDynFlags (Env gbl lcl) where
instance ContainsModule gbl => ContainsModule (Env gbl lcl) where
extractModule env = extractModule (env_gbl env)
{-
************************************************************************
* *
The interface environments
Used when dealing with IfaceDecls
* *
************************************************************************
-}
data IfGblEnv
= IfGblEnv {
-- The type environment for the module being compiled,
-- in case the interface refers back to it via a reference that
-- was originally a hi-boot file.
-- We need the module name so we can test when it's appropriate
-- to look in this env.
if_rec_types :: Maybe (Module, IfG TypeEnv)
-- Allows a read effect, so it can be in a mutable
-- variable; c.f. handling the external package type env
-- Nothing => interactive stuff, no loops possible
}
data IfLclEnv
= IfLclEnv {
-- The module for the current IfaceDecl
-- So if we see f = \x -> x
-- it means M.f = \x -> x, where M is the if_mod
if_mod :: Module,
-- The field is used only for error reporting
-- if (say) there's a Lint error in it
if_loc :: SDoc,
-- Where the interface came from:
-- .hi file, or GHCi state, or ext core
-- plus which bit is currently being examined
if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings
-- (and coercions)
if_id_env :: UniqFM 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:
-}
-- If '-XParallelArrays' is given, the desugarer populates this table with the corresponding
-- variables found in 'Data.Array.Parallel'.
--
data PArrBuiltin
= PArrBuiltin
{ lengthPVar :: Var -- ^ lengthP
, replicatePVar :: Var -- ^ replicateP
, singletonPVar :: Var -- ^ singletonP
, mapPVar :: Var -- ^ mapP
, filterPVar :: Var -- ^ filterP
, zipPVar :: Var -- ^ zipP
, crossMapPVar :: Var -- ^ crossMapP
, indexPVar :: Var -- ^ (!:)
, emptyPVar :: Var -- ^ emptyP
, appPVar :: Var -- ^ (+:+)
, enumFromToPVar :: Var -- ^ enumFromToP
, enumFromThenToPVar :: Var -- ^ enumFromThenToP
}
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_dph_env :: GlobalRdrEnv -- exported entities of 'Data.Array.Parallel.Prim'
-- iff '-fvectorise' flag was given as well as
-- exported entities of 'Data.Array.Parallel' iff
-- '-XParallelArrays' was given; otherwise, empty
, ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays'
, ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))]
-- ^ Bindings resulted from floating static forms
}
instance ContainsModule DsGblEnv where
extractModule = ds_mod
data DsLclEnv = DsLclEnv {
dsl_meta :: DsMetaEnv, -- Template Haskell bindings
dsl_loc :: SrcSpan -- to put in pattern-matching error msgs
}
-- 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 Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
{-
************************************************************************
* *
Global typechecker environment
* *
************************************************************************
-}
-- | 'TcGblEnv' describes the top-level of the module at the
-- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer
......@@ -480,47 +576,6 @@ We gather two sorts of usage information
is unnecessary. This info isn't present in Names.
************************************************************************
* *
The interface environments
Used when dealing with IfaceDecls
* *
************************************************************************
-}
data IfGblEnv
= IfGblEnv {
-- The type environment for the module being compiled,
-- in case the interface refers back to it via a reference that
-- was originally a hi-boot file.
-- We need the module name so we can test when it's appropriate
-- to look in this env.
if_rec_types :: Maybe (Module, IfG TypeEnv)
-- Allows a read effect, so it can be in a mutable
-- variable; c.f. handling the external package type env
-- Nothing => interactive stuff, no loops possible
}
data IfLclEnv
= IfLclEnv {
-- The module for the current IfaceDecl
-- So if we see f = \x -> x
-- it means M.f = \x -> x, where M is the if_mod
if_mod :: Module,
-- The field is used only for error reporting
-- if (say) there's a Lint error in it
if_loc :: SDoc,
-- Where the interface came from:
-- .hi file, or GHCi state, or ext core
-- plus which bit is currently being examined
if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings
-- (and coercions)
if_id_env :: UniqFM Id -- Nested id binding
}
{-
************************************************************************
* *
The local typechecker environment
......@@ -619,6 +674,14 @@ pass it inwards.
-}
-- | Type alias for 'IORef'; the convention is we'll use this for mutable
-- bits of data in 'TcGblEnv' which are updated during typechecking and
-- returned at the end.
type TcRef a = IORef a
-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'?
type TcId = Id
type TcIdSet = IdSet
---------------------------
-- Template Haskell stages and levels
---------------------------
......
......@@ -77,7 +77,7 @@ import TcEvidence( TcEvBinds(..) )
import Id
import IdInfo
import DsExpr
import DsMonad hiding (Splice)
import DsMonad
import Serialized
import ErrUtils
import SrcLoc
......