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
tcg_fix_env = fix_env,
tcg_inst_env = inst_env,
tcg_fam_inst_env = fam_inst_env,
tcg_warns = warns,
tcg_warns = warns,
tcg_anns = anns,
tcg_binds = binds,
tcg_fords = fords,
tcg_rules = rules,
......@@ -133,6 +134,7 @@ deSugar hsc_env
mg_rdr_env = rdr_env,
mg_fix_env = fix_env,
mg_warns = warns,
mg_anns = anns,
mg_types = type_env,
mg_insts = insts,
mg_fam_insts = fam_insts,
......
......@@ -273,6 +273,7 @@ Library
LoadIface
MkIface
TcIface
Annotations
BreakArray
CmdLineParser
CodeOutput
......@@ -326,6 +327,7 @@ Library
RnPat
RnSource
RnTypes
CoreMonad
CSE
FloatIn
FloatOut
......@@ -355,6 +357,7 @@ Library
WwLib
FamInst
Inst
TcAnnotations
TcArrows
TcBinds
TcClassDcl
......@@ -416,6 +419,7 @@ Library
Outputable
Panic
Pretty
Serialized
State
StringBuffer
Unicode
......
......@@ -14,7 +14,7 @@ This module converts Template Haskell syntax into HsSyn
-- for details
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType, thRdrName ) where
convertToHsType, thRdrNameGuesses ) where
import HsSyn as Hs
import qualified Class
......@@ -619,7 +619,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
-- which will give confusing error messages later
--
-- 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.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)
......@@ -627,6 +627,21 @@ thRdrName ctxt_ns occ TH.NameS
| Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
| 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
-- 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
......
......@@ -47,10 +47,13 @@ module HsDecls (
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
WarnDecl(..), LWarnDecl,
-- ** Annotations
AnnDecl(..), LAnnDecl,
AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM,
-- * Grouping
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
) where
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups
) where
-- friends:
import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
......@@ -72,6 +75,7 @@ import Util
import SrcLoc
import FastString
import Control.Monad ( liftM )
import Data.Maybe ( isJust )
\end{code}
......@@ -94,6 +98,7 @@ data HsDecl id
| DefD (DefaultDecl id)
| ForD (ForeignDecl id)
| WarningD (WarnDecl id)
| AnnD (AnnDecl id)
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
| DocD (DocDecl id)
......@@ -128,6 +133,7 @@ data HsGroup id
hs_defds :: [LDefaultDecl id],
hs_fords :: [LForeignDecl id],
hs_warnds :: [LWarnDecl id],
hs_annds :: [LAnnDecl id],
hs_ruleds :: [LRuleDecl id],
hs_docs :: [LDocDecl id]
......@@ -138,8 +144,8 @@ emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }
emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut }
emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [],
hs_fixds = [], hs_defds = [], hs_fords = [],
hs_warnds = [], hs_ruleds = [],
hs_fixds = [], hs_defds = [], hs_annds = [],
hs_fords = [], hs_warnds = [], hs_ruleds = [],
hs_valds = error "emptyGroup hs_valds: Can't happen",
hs_docs = [] }
......@@ -152,6 +158,7 @@ appendGroups
hs_derivds = derivds1,
hs_fixds = fixds1,
hs_defds = defds1,
hs_annds = annds1,
hs_fords = fords1,
hs_warnds = warnds1,
hs_ruleds = rulds1,
......@@ -163,6 +170,7 @@ appendGroups
hs_derivds = derivds2,
hs_fixds = fixds2,
hs_defds = defds2,
hs_annds = annds2,
hs_fords = fords2,
hs_warnds = warnds2,
hs_ruleds = rulds2,
......@@ -173,7 +181,8 @@ appendGroups
hs_tyclds = tyclds1 ++ tyclds2,
hs_instds = instds1 ++ instds2,
hs_derivds = derivds1 ++ derivds2,
hs_fixds = fixds1 ++ fixds2,
hs_fixds = fixds1 ++ fixds2,
hs_annds = annds1 ++ annds2,
hs_defds = defds1 ++ defds2,
hs_fords = fords1 ++ fords2,
hs_warnds = warnds1 ++ warnds2,
......@@ -192,6 +201,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (SigD sd) = ppr sd
ppr (RuleD rd) = ppr rd
ppr (WarningD wd) = ppr wd
ppr (AnnD ad) = ppr ad
ppr (SpliceD dd) = ppr dd
ppr (DocD doc) = ppr doc
......@@ -202,11 +212,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where
hs_derivds = deriv_decls,
hs_fixds = fix_decls,
hs_warnds = deprec_decls,
hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_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_ds tycl_decls, ppr_ds inst_decls,
ppr_ds deriv_decls,
......@@ -1034,3 +1046,42 @@ instance OutputableBndr name => Outputable (WarnDecl name) where
ppr (Warning thing txt)
= hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
\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
import HscTypes
import BasicTypes
import NewDemand
import Annotations
import IfaceSyn
import Module
import Name
......@@ -373,6 +374,7 @@ instance Binary ModIface where
mi_exp_hash = exp_hash,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = anns,
mi_decls = decls,
mi_insts = insts,
mi_fam_insts = fam_insts,
......@@ -392,6 +394,7 @@ instance Binary ModIface where
put_ bh exp_hash
put_ bh fixities
lazyPut bh warns
lazyPut bh anns
put_ bh decls
put_ bh insts
put_ bh fam_insts
......@@ -413,6 +416,7 @@ instance Binary ModIface where
exp_hash <- get bh
fixities <- {-# SCC "bin_fixities" #-} get bh
warns <- {-# SCC "bin_warns" #-} lazyGet bh
anns <- {-# SCC "bin_anns" #-} lazyGet bh
decls <- {-# SCC "bin_tycldecls" #-} get bh
insts <- {-# SCC "bin_insts" #-} get bh
fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
......@@ -431,6 +435,7 @@ instance Binary ModIface where
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
mi_anns = anns,
mi_fixities = fixities,
mi_warns = warns,
mi_decls = decls,
......@@ -1346,6 +1351,30 @@ instance Binary IfaceRule where
a7 <- get bh
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
put_ bh (IfaceVectInfo a1 a2 a3) = do
put_ bh a1
......
......@@ -10,7 +10,8 @@ module IfaceSyn (
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..),
-- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
......@@ -27,12 +28,14 @@ module IfaceSyn (
import IfaceType
import NewDemand
import Annotations
import Class
import NameSet
import Name
import CostCentre
import Literal
import ForeignCall
import Serialized
import BasicTypes
import Outputable
import FastString
......@@ -163,6 +166,14 @@ data IfaceRule
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
data IfaceAnnotation
= IfaceAnnotation {
ifAnnotatedTarget :: IfaceAnnTarget,
ifAnnotatedValue :: Serialized
}
type IfaceAnnTarget = AnnTarget OccName
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
| HasInfo [IfaceInfoItem] -- Has info, and here it is
......
......@@ -8,7 +8,7 @@ Loading interface files
\begin{code}
module LoadIface (
loadInterface, loadInterfaceForName, loadWiredInHomeIface,
loadSrcInterface, loadSysInterface, loadOrphanModules,
loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules,
findAndReadIface, readIface, -- Used when reading the module's old interface
loadDecls, -- Should move to TcIface and be renamed
initExternalPackageState,
......@@ -19,7 +19,7 @@ module LoadIface (
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
tcIfaceFamInst, tcIfaceVectInfo )
tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
import DynFlags
import IfaceSyn
......@@ -34,6 +34,7 @@ import PrelNames
import PrelInfo
import PrelRules
import Rules
import Annotations
import InstEnv
import FamInstEnv
import Name
......@@ -134,10 +135,19 @@ loadWiredInHomeIface name
where
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 doc mod_name
= do { mb_iface <- loadInterface doc mod_name ImportBySystem
loadSysInterface doc mod_name = loadInterfaceWithException 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
Failed err -> ghcError (ProgramError (showSDoc err))
Succeeded iface -> return iface }
......@@ -232,14 +242,15 @@ loadInterface doc_str mod from
; return (Failed err) } ;
-- Found and parsed!
Succeeded (iface, file_path) -- Sanity check:
| ImportBySystem <- from, -- system-importing...
modulePackageId (mi_module iface) == thisPackage dflags,
-- a home-package module...
Nothing <- mb_dep -- that we know nothing about
-> return (Failed (badDepMsg mod))
| otherwise ->
-- We used to have a sanity check here that looked for:
-- * System importing ..
-- * a home package module ..
-- * that we know nothing about (mb_dep == Nothing)!
--
-- But this is no longer valid because thNameToGhcName allows users to
-- cause the system to load arbitrary interfaces (by supplying an appropriate
-- Template Haskell original-name).
Succeeded (iface, file_path) ->
let
loc_doc = text file_path
......@@ -267,6 +278,7 @@ loadInterface doc_str mod from
; new_eps_insts <- mapM tcIfaceInst (mi_insts iface)
; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts 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)
(mi_vect_info iface)
......@@ -274,7 +286,8 @@ loadInterface doc_str mod from
mi_decls = panic "No mi_decls in PIT",
mi_insts = panic "No mi_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
new_eps_fam_insts,
eps_vect_info = plusVectInfo (eps_vect_info eps)
new_eps_vect_info,
eps_ann_env = extendAnnEnvList (eps_ann_env eps)
new_eps_anns,
eps_mod_fam_inst_env
= let
fam_inst_env =
......@@ -307,11 +322,16 @@ loadInterface doc_str mod from
; 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 mod
= hang (ptext (sLit "Interface file inconsistency:"))
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")])
-}
-----------------------------------------------------
-- Loading type/class/value decls
......@@ -481,6 +501,9 @@ findAndReadIface doc_str mod hi_boot_file
-- Found file, so read it
{ 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
&& not (isOneShot (ghcMode dflags))
then return (Failed (homeModError mod loc))
......@@ -550,6 +573,7 @@ initExternalPackageState
eps_mod_fam_inst_env
= emptyModuleEnv,
eps_vect_info = noVectInfo,
eps_ann_env = emptyAnnEnv,
eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
, n_insts_in = 0, n_insts_out = 0
, n_rules_in = length builtinRules, n_rules_out = 0 }
......@@ -636,6 +660,7 @@ pprModIface iface
, vcat (map pprExport (mi_exports iface))
, pprDeps (mi_deps iface)
, vcat (map pprUsage (mi_usages iface))
, vcat (map pprIfaceAnnotation (mi_anns iface))
, pprFixities (mi_fixities iface)
, vcat (map pprIfaceDecl (mi_decls iface))
, vcat (map ppr (mi_insts iface))
......@@ -724,6 +749,10 @@ pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt
pprWarns (WarnSome prs) = ptext (sLit "Warnings")
<+> vcat (map pprWarning prs)
where pprWarning (name, txt) = ppr name <+> ppr txt
pprIfaceAnnotation :: IfaceAnnotation -> SDoc
pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
= ppr target <+> ptext (sLit "annotated by") <+> ppr serialized
\end{code}
......
......@@ -56,6 +56,7 @@ import LoadIface
import Id
import IdInfo
import NewDemand
import Annotations
import CoreSyn
import CoreFVs
import Class
......@@ -220,6 +221,7 @@ mkIface_ hsc_env maybe_old_fingerprint
ModDetails{ md_insts = insts,
md_fam_insts = fam_insts,
md_rules = rules,
md_anns = anns,
md_vect_info = vect_info,
md_types = type_env,
md_exports = exports }
......@@ -265,6 +267,7 @@ mkIface_ hsc_env maybe_old_fingerprint
mi_fixities = fixities,
mi_warns = warns,
mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
-- Left out deliberately: filled in by addVersionInfo
......@@ -904,6 +907,17 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
-- one-shot mode), but that's even more bogus!
\end{code}
\begin{code}
mkIfaceAnnotations :: [Annotation] -> [IfaceAnnotation]
mkIfaceAnnotations = map mkIfaceAnnotation
mkIfaceAnnotation :: Annotation -> IfaceAnnotation
mkIfaceAnnotation (Annotation { ann_target = target, ann_value = serialized }) = IfaceAnnotation {
ifAnnotatedTarget = fmap nameOccName target,
ifAnnotatedValue = serialized
}
\end{code}
\begin{code}
mkIfaceExports :: [AvailInfo]
-> [(Module, [GenAvailInfo OccName])]
......
......@@ -9,7 +9,7 @@ Type checking of type signatures in interface files
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings
tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
) where
#include "HsVersions.h"
......@@ -22,6 +22,7 @@ import TcRnMonad
import Type
import TypeRep
import HscTypes
import Annotations
import InstEnv
import FamInstEnv
import CoreSyn
......@@ -201,10 +202,11 @@ typecheckIface iface
; let type_env = mkNameEnv names_w_things
; writeMutVar tc_env_var type_env
-- Now do those rules and instances
-- Now do those rules, instances and annotations
; insts <- mapM tcIfaceInst (mi_insts iface)
; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
; rules <- tcIfaceRules ignore_prags (mi_rules iface)
; anns <- tcIfaceAnnotations (mi_anns iface)
-- Vectorisation information
; vect_info <- tcIfaceVectInfo (mi_module iface) type_env
......@@ -220,6 +222,7 @@ typecheckIface iface
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
, md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
}
......@@ -612,6 +615,34 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
\end{code}
%************************************************************************
%* *
Annotations
%* *
%************************************************************************
\begin{code}
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
tcIfaceAnnotations = mapM tcIfaceAnnotation
tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
tcIfaceAnnotation (IfaceAnnotation target serialized) = do
target' <- tcIfaceAnnTarget target
return $ Annotation {
ann_target = target',
ann_value = serialized
}
tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
tcIfaceAnnTarget (NamedTarget occ) = do
name <- lookupIfaceTop occ
return $ NamedTarget name
tcIfaceAnnTarget (ModuleTarget mod) = do
return $ ModuleTarget mod
\end{code}
%************************************************************************
%* *
Vectorisation information
......
\begin{code}
module TcIface where
import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule )
import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
import TypeRep ( TyThing )
import TcRnTypes ( IfL )
import InstEnv ( Instance )
......@@ -8,11 +8,13 @@ import FamInstEnv ( FamInst )
import CoreSyn ( CoreRule )
import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo )
import Module ( Module )
import Annotations ( Annotation )
tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing
tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]
tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceInst :: IfaceInst -> IfL Instance
tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
\end{code}
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\begin{code}
module Annotations (
-- * Main Annotation data types
Annotation(..),
AnnTarget(..), CoreAnnTarget,
getAnnTargetName_maybe,
-- * AnnEnv for collecting and querying Annotations
AnnEnv,
mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns
) where
import Name
import Module ( Module )
import Outputable
import LazyUniqFM
import Serialized
import Unique
import Control.Monad
import Data.Typeable
import Data.Maybe
import Data.Word ( Word8 )
-- | Represents an annotation after it has been sufficiently desugared from
-- it's initial form of 'HsDecls.AnnDecl'
data Annotation = Annotation {
ann_target :: CoreAnnTarget, -- ^ The target of the annotation
ann_value :: Serialized -- ^ 'Serialized' version of the annotation that
-- allows recovery of its value or can
-- be persisted to an interface file
}
-- | An annotation target
data AnnTarget name
= NamedTarget name -- ^ We are annotating something with a name:
-- a type or identifier
| ModuleTarget Module -- ^ We are annotating a particular module
-- | The kind of annotation target found in the middle end of the compiler
type CoreAnnTarget = AnnTarget Name