Commit 9bcd95ba authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Add (a) CoreM monad, (b) new Annotations feature

This patch, written by Max Bolingbroke,  does two things

1.  It adds a new CoreM monad (defined in simplCore/CoreMonad),
    which is used as the top-level monad for all the Core-to-Core
    transformations (starting at SimplCore).  It supports
       * I/O (for debug printing)
       * Unique supply
       * Statistics gathering
       * Access to the HscEnv, RuleBase, Annotations, Module
    The patch therefore refactors the top "skin" of every Core-to-Core
    pass, but does not change their functionality.

2.  It adds a completely new facility to GHC: Core "annotations".
    The idea is that you can say
       {#- ANN foo (Just "Hello") #-}
    which adds the annotation (Just "Hello") to the top level function
    foo.  These annotations can be looked up in any Core-to-Core pass,
    and are persisted into interface files.  (Hence a Core-to-Core pass
    can also query the annotations of imported things.)  Furthermore,
    a Core-to-Core pass can add new annotations (eg strictness info)
    of its own, which can be queried by importing modules.

The design of the annotation system is somewhat in flux.  It's
designed to work with the (upcoming) dynamic plug-ins mechanism,
but is meanwhile independently useful.

Do not merge to 6.10!  
parent b1f3ff48
...@@ -63,7 +63,8 @@ deSugar hsc_env ...@@ -63,7 +63,8 @@ deSugar hsc_env
tcg_fix_env = fix_env, tcg_fix_env = fix_env,
tcg_inst_env = inst_env, tcg_inst_env = inst_env,
tcg_fam_inst_env = fam_inst_env, tcg_fam_inst_env = fam_inst_env,
tcg_warns = warns, tcg_warns = warns,
tcg_anns = anns,
tcg_binds = binds, tcg_binds = binds,
tcg_fords = fords, tcg_fords = fords,
tcg_rules = rules, tcg_rules = rules,
...@@ -133,6 +134,7 @@ deSugar hsc_env ...@@ -133,6 +134,7 @@ deSugar hsc_env
mg_rdr_env = rdr_env, mg_rdr_env = rdr_env,
mg_fix_env = fix_env, mg_fix_env = fix_env,
mg_warns = warns, mg_warns = warns,
mg_anns = anns,
mg_types = type_env, mg_types = type_env,
mg_insts = insts, mg_insts = insts,
mg_fam_insts = fam_insts, mg_fam_insts = fam_insts,
......
...@@ -273,6 +273,7 @@ Library ...@@ -273,6 +273,7 @@ Library
LoadIface LoadIface
MkIface MkIface
TcIface TcIface
Annotations
BreakArray BreakArray
CmdLineParser CmdLineParser
CodeOutput CodeOutput
...@@ -326,6 +327,7 @@ Library ...@@ -326,6 +327,7 @@ Library
RnPat RnPat
RnSource RnSource
RnTypes RnTypes
CoreMonad
CSE CSE
FloatIn FloatIn
FloatOut FloatOut
...@@ -355,6 +357,7 @@ Library ...@@ -355,6 +357,7 @@ Library
WwLib WwLib
FamInst FamInst
Inst Inst
TcAnnotations
TcArrows TcArrows
TcBinds TcBinds
TcClassDcl TcClassDcl
...@@ -416,6 +419,7 @@ Library ...@@ -416,6 +419,7 @@ Library
Outputable Outputable
Panic Panic
Pretty Pretty
Serialized
State State
StringBuffer StringBuffer
Unicode Unicode
......
...@@ -14,7 +14,7 @@ This module converts Template Haskell syntax into HsSyn ...@@ -14,7 +14,7 @@ This module converts Template Haskell syntax into HsSyn
-- for details -- for details
module Convert( convertToHsExpr, convertToPat, convertToHsDecls, module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType, thRdrName ) where convertToHsType, thRdrNameGuesses ) where
import HsSyn as Hs import HsSyn as Hs
import qualified Class import qualified Class
...@@ -619,7 +619,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName ...@@ -619,7 +619,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
-- which will give confusing error messages later -- which will give confusing error messages later
-- --
-- The strict applications ensure that any buried exceptions get forced -- The strict applications ensure that any buried exceptions get forced
thRdrName _ occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
...@@ -627,6 +627,21 @@ thRdrName ctxt_ns occ TH.NameS ...@@ -627,6 +627,21 @@ thRdrName ctxt_ns occ TH.NameS
| Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
| otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ) | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
thRdrNameGuesses :: TH.Name -> [RdrName]
thRdrNameGuesses (TH.Name occ flavour)
-- This special case for NameG ensures that we don't generate duplicates in the output list
| TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
| otherwise = [ thRdrName gns occ_str flavour
| gns <- guessed_nss]
where
-- guessed_ns are the name spaces guessed from looking at the TH name
guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
| otherwise = [OccName.varName, OccName.tvName]
occ_str = TH.occString occ
isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
-- Built in syntax isn't "in scope" so an Unqual RdrName won't do -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
-- We must generate an Exact name, just as the parser does -- We must generate an Exact name, just as the parser does
......
...@@ -47,10 +47,13 @@ module HsDecls ( ...@@ -47,10 +47,13 @@ module HsDecls (
DocDecl(..), LDocDecl, docDeclDoc, DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations -- ** Deprecations
WarnDecl(..), LWarnDecl, WarnDecl(..), LWarnDecl,
-- ** Annotations
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
-- * Grouping -- * Grouping
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups
) where ) where
-- friends: -- friends:
import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
...@@ -72,6 +75,7 @@ import Util ...@@ -72,6 +75,7 @@ import Util
import SrcLoc import SrcLoc
import FastString import FastString
import Control.Monad ( liftM )
import Data.Maybe ( isJust ) import Data.Maybe ( isJust )
\end{code} \end{code}
...@@ -94,6 +98,7 @@ data HsDecl id ...@@ -94,6 +98,7 @@ data HsDecl id
| DefD (DefaultDecl id) | DefD (DefaultDecl id)
| ForD (ForeignDecl id) | ForD (ForeignDecl id)
| WarningD (WarnDecl id) | WarningD (WarnDecl id)
| AnnD (AnnDecl id)
| RuleD (RuleDecl id) | RuleD (RuleDecl id)
| SpliceD (SpliceDecl id) | SpliceD (SpliceDecl id)
| DocD (DocDecl id) | DocD (DocDecl id)
...@@ -128,6 +133,7 @@ data HsGroup id ...@@ -128,6 +133,7 @@ data HsGroup id
hs_defds :: [LDefaultDecl id], hs_defds :: [LDefaultDecl id],
hs_fords :: [LForeignDecl id], hs_fords :: [LForeignDecl id],
hs_warnds :: [LWarnDecl id], hs_warnds :: [LWarnDecl id],
hs_annds :: [LAnnDecl id],
hs_ruleds :: [LRuleDecl id], hs_ruleds :: [LRuleDecl id],
hs_docs :: [LDocDecl id] hs_docs :: [LDocDecl id]
...@@ -138,8 +144,8 @@ emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } ...@@ -138,8 +144,8 @@ emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_fords = [], hs_fixds = [], hs_defds = [], hs_annds = [],
hs_warnds = [], hs_ruleds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [],
hs_valds = error "emptyGroup hs_valds: Can't happen", hs_valds = error "emptyGroup hs_valds: Can't happen",
hs_docs = [] } hs_docs = [] }
...@@ -152,6 +158,7 @@ appendGroups ...@@ -152,6 +158,7 @@ appendGroups
hs_derivds = derivds1, hs_derivds = derivds1,
hs_fixds = fixds1, hs_fixds = fixds1,
hs_defds = defds1, hs_defds = defds1,
hs_annds = annds1,
hs_fords = fords1, hs_fords = fords1,
hs_warnds = warnds1, hs_warnds = warnds1,
hs_ruleds = rulds1, hs_ruleds = rulds1,
...@@ -163,6 +170,7 @@ appendGroups ...@@ -163,6 +170,7 @@ appendGroups
hs_derivds = derivds2, hs_derivds = derivds2,
hs_fixds = fixds2, hs_fixds = fixds2,
hs_defds = defds2, hs_defds = defds2,
hs_annds = annds2,
hs_fords = fords2, hs_fords = fords2,
hs_warnds = warnds2, hs_warnds = warnds2,
hs_ruleds = rulds2, hs_ruleds = rulds2,
...@@ -173,7 +181,8 @@ appendGroups ...@@ -173,7 +181,8 @@ appendGroups
hs_tyclds = tyclds1 ++ tyclds2, hs_tyclds = tyclds1 ++ tyclds2,
hs_instds = instds1 ++ instds2, hs_instds = instds1 ++ instds2,
hs_derivds = derivds1 ++ derivds2, hs_derivds = derivds1 ++ derivds2,
hs_fixds = fixds1 ++ fixds2, hs_fixds = fixds1 ++ fixds2,
hs_annds = annds1 ++ annds2,
hs_defds = defds1 ++ defds2, hs_defds = defds1 ++ defds2,
hs_fords = fords1 ++ fords2, hs_fords = fords1 ++ fords2,
hs_warnds = warnds1 ++ warnds2, hs_warnds = warnds1 ++ warnds2,
...@@ -192,6 +201,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ...@@ -192,6 +201,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (SigD sd) = ppr sd ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd ppr (RuleD rd) = ppr rd
ppr (WarningD wd) = ppr wd ppr (WarningD wd) = ppr wd
ppr (AnnD ad) = ppr ad
ppr (SpliceD dd) = ppr dd ppr (SpliceD dd) = ppr dd
ppr (DocD doc) = ppr doc ppr (DocD doc) = ppr doc
...@@ -202,11 +212,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where ...@@ -202,11 +212,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where
hs_derivds = deriv_decls, hs_derivds = deriv_decls,
hs_fixds = fix_decls, hs_fixds = fix_decls,
hs_warnds = deprec_decls, hs_warnds = deprec_decls,
hs_annds = ann_decls,
hs_fords = foreign_decls, hs_fords = foreign_decls,
hs_defds = default_decls, hs_defds = default_decls,
hs_ruleds = rule_decls }) hs_ruleds = rule_decls })
= vcat [ppr_ds fix_decls, ppr_ds default_decls, = vcat [ppr_ds fix_decls, ppr_ds default_decls,
ppr_ds deprec_decls, ppr_ds rule_decls, ppr_ds deprec_decls, ppr_ds ann_decls,
ppr_ds rule_decls,
ppr val_decls, ppr val_decls,
ppr_ds tycl_decls, ppr_ds inst_decls, ppr_ds tycl_decls, ppr_ds inst_decls,
ppr_ds deriv_decls, ppr_ds deriv_decls,
...@@ -1034,3 +1046,42 @@ instance OutputableBndr name => Outputable (WarnDecl name) where ...@@ -1034,3 +1046,42 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
ppr (Warning thing txt) ppr (Warning thing txt)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\end{code} \end{code}
%************************************************************************
%* *
\subsection[AnnDecl]{Annotations}
%* *
%************************************************************************
\begin{code}
type LAnnDecl name = Located (AnnDecl name)
data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name))
instance (OutputableBndr name) => Outputable (AnnDecl name) where
ppr (HsAnnotation provenance expr)
= hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]
data AnnProvenance name = ValueAnnProvenance name
| TypeAnnProvenance name
| ModuleAnnProvenance
annProvenanceName_maybe :: AnnProvenance name -> Maybe name
annProvenanceName_maybe (ValueAnnProvenance name) = Just name
annProvenanceName_maybe (TypeAnnProvenance name) = Just name
annProvenanceName_maybe ModuleAnnProvenance = Nothing
-- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough
modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after)
modifyAnnProvenanceNameM fm prov =
case prov of
ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name)
TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name)
ModuleAnnProvenance -> return ModuleAnnProvenance
pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc
pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module")
pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name
pprAnnProvenance (TypeAnnProvenance name) = ptext (sLit "ANN type") <+> ppr name
\end{code}
...@@ -18,6 +18,7 @@ import IfaceEnv ...@@ -18,6 +18,7 @@ import IfaceEnv
import HscTypes import HscTypes
import BasicTypes import BasicTypes
import NewDemand import NewDemand
import Annotations
import IfaceSyn import IfaceSyn
import Module import Module
import Name import Name
...@@ -373,6 +374,7 @@ instance Binary ModIface where ...@@ -373,6 +374,7 @@ instance Binary ModIface where
mi_exp_hash = exp_hash, mi_exp_hash = exp_hash,
mi_fixities = fixities, mi_fixities = fixities,
mi_warns = warns, mi_warns = warns,
mi_anns = anns,
mi_decls = decls, mi_decls = decls,
mi_insts = insts, mi_insts = insts,
mi_fam_insts = fam_insts, mi_fam_insts = fam_insts,
...@@ -392,6 +394,7 @@ instance Binary ModIface where ...@@ -392,6 +394,7 @@ instance Binary ModIface where
put_ bh exp_hash put_ bh exp_hash
put_ bh fixities put_ bh fixities
lazyPut bh warns lazyPut bh warns
lazyPut bh anns
put_ bh decls put_ bh decls
put_ bh insts put_ bh insts
put_ bh fam_insts put_ bh fam_insts
...@@ -413,6 +416,7 @@ instance Binary ModIface where ...@@ -413,6 +416,7 @@ instance Binary ModIface where
exp_hash <- get bh exp_hash <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh fixities <- {-# SCC "bin_fixities" #-} get bh
warns <- {-# SCC "bin_warns" #-} lazyGet bh warns <- {-# SCC "bin_warns" #-} lazyGet bh
anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
...@@ -431,6 +435,7 @@ instance Binary ModIface where ...@@ -431,6 +435,7 @@ instance Binary ModIface where
mi_usages = usages, mi_usages = usages,
mi_exports = exports, mi_exports = exports,
mi_exp_hash = exp_hash, mi_exp_hash = exp_hash,
mi_anns = anns,
mi_fixities = fixities, mi_fixities = fixities,
mi_warns = warns, mi_warns = warns,
mi_decls = decls, mi_decls = decls,
...@@ -1346,6 +1351,30 @@ instance Binary IfaceRule where ...@@ -1346,6 +1351,30 @@ instance Binary IfaceRule where
a7 <- get bh a7 <- get bh
return (IfaceRule a1 a2 a3 a4 a5 a6 a7) return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
instance Binary IfaceAnnotation where
put_ bh (IfaceAnnotation a1 a2) = do
put_ bh a1
put_ bh a2
get bh = do
a1 <- get bh
a2 <- get bh
return (IfaceAnnotation a1 a2)
instance Binary name => Binary (AnnTarget name) where
put_ bh (NamedTarget a) = do
putByte bh 0
put_ bh a
put_ bh (ModuleTarget a) = do
putByte bh 1
put_ bh a
get bh = do
h <- getByte bh
case h of
0 -> do a <- get bh
return (NamedTarget a)
_ -> do a <- get bh
return (ModuleTarget a)
instance Binary IfaceVectInfo where instance Binary IfaceVectInfo where
put_ bh (IfaceVectInfo a1 a2 a3) = do put_ bh (IfaceVectInfo a1 a2 a3) = do
put_ bh a1 put_ bh a1
......
...@@ -10,7 +10,8 @@ module IfaceSyn ( ...@@ -10,7 +10,8 @@ module IfaceSyn (
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..),
-- Misc -- Misc
ifaceDeclSubBndrs, visibleIfConDecls, ifaceDeclSubBndrs, visibleIfConDecls,
...@@ -27,12 +28,14 @@ module IfaceSyn ( ...@@ -27,12 +28,14 @@ module IfaceSyn (
import IfaceType import IfaceType
import NewDemand import NewDemand
import Annotations
import Class import Class
import NameSet import NameSet
import Name import Name
import CostCentre import CostCentre
import Literal import Literal
import ForeignCall import ForeignCall
import Serialized
import BasicTypes import BasicTypes
import Outputable import Outputable
import FastString import FastString
...@@ -163,6 +166,14 @@ data IfaceRule ...@@ -163,6 +166,14 @@ data IfaceRule
ifRuleOrph :: Maybe OccName -- Just like IfaceInst ifRuleOrph :: Maybe OccName -- Just like IfaceInst
} }
data IfaceAnnotation
= IfaceAnnotation {
ifAnnotatedTarget :: IfaceAnnTarget,
ifAnnotatedValue :: Serialized
}
type IfaceAnnTarget = AnnTarget OccName
data IfaceIdInfo data IfaceIdInfo
= NoInfo -- When writing interface file without -O = NoInfo -- When writing interface file without -O
| HasInfo [IfaceInfoItem] -- Has info, and here it is | HasInfo [IfaceInfoItem] -- Has info, and here it is
......
...@@ -8,7 +8,7 @@ Loading interface files ...@@ -8,7 +8,7 @@ Loading interface files
\begin{code} \begin{code}
module LoadIface ( module LoadIface (
loadInterface, loadInterfaceForName, loadWiredInHomeIface, loadInterface, loadInterfaceForName, loadWiredInHomeIface,
loadSrcInterface, loadSysInterface, loadOrphanModules, loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules,
findAndReadIface, readIface, -- Used when reading the module's old interface findAndReadIface, readIface, -- Used when reading the module's old interface
loadDecls, -- Should move to TcIface and be renamed loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState, initExternalPackageState,
...@@ -19,7 +19,7 @@ module LoadIface ( ...@@ -19,7 +19,7 @@ module LoadIface (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
tcIfaceFamInst, tcIfaceVectInfo ) tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
import DynFlags import DynFlags
import IfaceSyn import IfaceSyn
...@@ -34,6 +34,7 @@ import PrelNames ...@@ -34,6 +34,7 @@ import PrelNames
import PrelInfo import PrelInfo
import PrelRules import PrelRules
import Rules import Rules
import Annotations
import InstEnv import InstEnv
import FamInstEnv import FamInstEnv
import Name import Name
...@@ -134,10 +135,19 @@ loadWiredInHomeIface name ...@@ -134,10 +135,19 @@ loadWiredInHomeIface name
where where
doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name
-- | A wrapper for 'loadInterface' that throws an exception if it fails -- | Loads a system interface and throws an exception if it fails
loadSysInterface :: SDoc -> Module -> IfM lcl ModIface loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
loadSysInterface doc mod_name loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem
= do { mb_iface <- loadInterface doc mod_name ImportBySystem
-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
-- whether we should import the boot variant of the module
loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface
loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot)
-- | A wrapper for 'loadInterface' that throws an exception if it fails
loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
loadInterfaceWithException doc mod_name where_from
= do { mb_iface <- loadInterface doc mod_name where_from
; case mb_iface of ; case mb_iface of
Failed err -> ghcError (ProgramError (showSDoc err)) Failed err -> ghcError (ProgramError (showSDoc err))
Succeeded iface -> return iface } Succeeded iface -> return iface }
...@@ -232,14 +242,15 @@ loadInterface doc_str mod from ...@@ -232,14 +242,15 @@ loadInterface doc_str mod from
; return (Failed err) } ; ; return (Failed err) } ;
-- Found and parsed! -- Found and parsed!
Succeeded (iface, file_path) -- Sanity check: -- We used to have a sanity check here that looked for:
| ImportBySystem <- from, -- system-importing... -- * System importing ..
modulePackageId (mi_module iface) == thisPackage dflags, -- * a home package module ..
-- a home-package module... -- * that we know nothing about (mb_dep == Nothing)!
Nothing <- mb_dep -- that we know nothing about --
-> return (Failed (badDepMsg mod)) -- But this is no longer valid because thNameToGhcName allows users to
-- cause the system to load arbitrary interfaces (by supplying an appropriate
| otherwise -> -- Template Haskell original-name).
Succeeded (iface, file_path) ->
let let
loc_doc = text file_path loc_doc = text file_path
...@@ -267,6 +278,7 @@ loadInterface doc_str mod from ...@@ -267,6 +278,7 @@ loadInterface doc_str mod from
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface)
; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)
; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls)
(mi_vect_info iface) (mi_vect_info iface)
...@@ -274,7 +286,8 @@ loadInterface doc_str mod from ...@@ -274,7 +286,8 @@ loadInterface doc_str mod from
mi_decls = panic "No mi_decls in PIT", mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_insts in PIT", mi_insts = panic "No mi_insts in PIT",
mi_fam_insts = panic "No mi_fam_insts in PIT", mi_fam_insts = panic "No mi_fam_insts in PIT",
mi_rules = panic "No mi_rules in PIT" mi_rules = panic "No mi_rules in PIT",
mi_anns = panic "No mi_anns in PIT"
} }
} }
...@@ -290,6 +303,8 @@ loadInterface doc_str mod from ...@@ -290,6 +303,8 @@ loadInterface doc_str mod from
new_eps_fam_insts, new_eps_fam_insts,
eps_vect_info = plusVectInfo (eps_vect_info eps) eps_vect_info = plusVectInfo (eps_vect_info eps)
new_eps_vect_info, new_eps_vect_info,
eps_ann_env = extendAnnEnvList (eps_ann_env eps)
new_eps_anns,
eps_mod_fam_inst_env eps_mod_fam_inst_env
= let = let
fam_inst_env = fam_inst_env =
...@@ -307,11 +322,16 @@ loadInterface doc_str mod from ...@@ -307,11 +322,16 @@ loadInterface doc_str mod from
; return (Succeeded final_iface) ; return (Succeeded final_iface)
}}}} }}}}
{-
Used to be used for the loadInterface sanity check on system imports. That has been removed, but I'm leaving this in pending
review of this decision by SPJ - MCB 10/2008
badDepMsg :: Module -> SDoc badDepMsg :: Module -> SDoc
badDepMsg mod badDepMsg mod
= hang (ptext (sLit "Interface file inconsistency:")) = hang (ptext (sLit "Interface file inconsistency:"))
2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"), 2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"),
ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")]) ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")])
-}
----------------------------------------------------- -----------------------------------------------------
-- Loading type/class/value decls -- Loading type/class/value decls
...@@ -481,6 +501,9 @@ findAndReadIface doc_str mod hi_boot_file ...@@ -481,6 +501,9 @@ findAndReadIface doc_str mod hi_boot_file
-- Found file, so read it -- Found file, so read it
{ let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) } { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) }
-- If the interface is in the current package then if we could
-- load it would already be in the HPT and we assume that our
-- callers checked that.
; if thisPackage dflags == modulePackageId mod ; if thisPackage dflags == modulePackageId mod
&& not (isOneShot (ghcMode dflags)) && not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc)) then return (Failed (homeModError mod loc))
...@@ -550,6 +573,7 @@ initExternalPackageState ...@@ -550,6 +573,7 @@ initExternalPackageState
eps_mod_fam_inst_env eps_mod_fam_inst_env
= emptyModuleEnv,