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,
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,
LoadIface
MkIface
TcIface
+ Annotations
BreakArray
CmdLineParser
CodeOutput
RnPat
RnSource
RnTypes
+ CoreMonad
CSE
FloatIn
FloatOut
WwLib
FamInst
Inst
+ TcAnnotations
TcArrows
TcBinds
TcClassDcl
Outputable
Panic
Pretty
+ Serialized
State
StringBuffer
Unicode
-- for details
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
- convertToHsType, thRdrName ) where
+ convertToHsType, thRdrNameGuesses ) where
import HsSyn as Hs
import qualified Class
-- 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)
| 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
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 )
import SrcLoc
import FastString
+import Control.Monad ( liftM )
import Data.Maybe ( isJust )
\end{code}
| DefD (DefaultDecl id)
| ForD (ForeignDecl id)
| WarningD (WarnDecl id)
+ | AnnD (AnnDecl id)
| RuleD (RuleDecl id)
| SpliceD (SpliceDecl id)
| DocD (DocDecl 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]
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 = [] }
hs_derivds = derivds1,
hs_fixds = fixds1,
hs_defds = defds1,
+ hs_annds = annds1,
hs_fords = fords1,
hs_warnds = warnds1,
hs_ruleds = rulds1,
hs_derivds = derivds2,
hs_fixds = fixds2,
hs_defds = defds2,
+ hs_annds = annds2,
hs_fords = fords2,
hs_warnds = warnds2,
hs_ruleds = rulds2,
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,
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
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,
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}
import HscTypes
import BasicTypes
import NewDemand
+import Annotations
import IfaceSyn
import Module
import Name
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,
put_ bh exp_hash
put_ bh fixities
lazyPut bh warns
+ lazyPut bh anns
put_ bh decls
put_ bh insts
put_ bh fam_insts
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
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
+ mi_anns = anns,
mi_fixities = fixities,
mi_warns = warns,
mi_decls = decls,
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
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceInst(..), IfaceFamInst(..),
-- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
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
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
\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,
#include "HsVersions.h"
import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
- tcIfaceFamInst, tcIfaceVectInfo )
+ tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations )
import DynFlags
import IfaceSyn
import PrelInfo
import PrelRules
import Rules
+import Annotations
import InstEnv
import FamInstEnv
import 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 }
; 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
; 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)
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"
}
}
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 =
; 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
-- 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))
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 }
, 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))
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}
import Id
import IdInfo
import NewDemand
+import Annotations
import CoreSyn
import CoreFVs
import Class
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 }
mi_fixities = fixities,
mi_warns = warns,
+ mi_anns = mkIfaceAnnotations anns,
mi_globals = Just rdr_env,
-- Left out deliberately: filled in by addVersionInfo
\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])]
-- Group by module and sort by occurrence
module TcIface (
tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
- tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings
+ tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings
) where
#include "HsVersions.h"
import Type
import TypeRep
import HscTypes
+import Annotations
import InstEnv
import FamInstEnv
import CoreSyn
; 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
, md_insts = insts
, md_fam_insts = fam_insts
, md_rules = rules
+ , md_anns = anns
, md_vect_info = vect_info
, md_exports = exports
}
%************************************************************************
%* *
+ 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 )
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}
--- /dev/null
+%
+% (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
+
+instance Functor AnnTarget where
+ fmap f (NamedTarget nm) = NamedTarget (f nm)
+ fmap _ (ModuleTarget mod) = ModuleTarget mod
+
+getAnnTargetName_maybe :: AnnTarget name -> Maybe name
+getAnnTargetName_maybe (NamedTarget nm) = Just nm
+getAnnTargetName_maybe _ = Nothing
+
+instance Uniquable name => Uniquable (AnnTarget name) where
+ getUnique (NamedTarget nm) = getUnique nm
+ getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0
+ -- deriveUnique prevents OccName uniques clashing with NamedTarget
+
+instance Outputable name => Outputable (AnnTarget name) where
+ ppr (NamedTarget nm) = text "Named target" <+> ppr nm
+ ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
+
+
+-- | A collection of annotations
+newtype AnnEnv = MkAnnEnv (UniqFM [Serialized])
+-- Can't use a type synonym or we hit bug #2412 due to source import
+
+emptyAnnEnv :: AnnEnv
+emptyAnnEnv = MkAnnEnv emptyUFM
+
+mkAnnEnv :: [Annotation] -> AnnEnv
+mkAnnEnv = extendAnnEnvList emptyAnnEnv
+
+extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
+extendAnnEnvList (MkAnnEnv env) anns
+ = MkAnnEnv $ addListToUFM_C (++) env $
+ map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
+
+plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
+plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
+
+-- | Find the annotations attached to the given target as 'Typeable'
+-- values of your choice. If no deserializer is specified,
+-- only transient annotations will be returned.
+findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
+findAnns deserialize (MkAnnEnv ann_env)
+ = (mapMaybe (fromSerialized deserialize))
+ . (lookupWithDefaultUFM ann_env [])
+\end{code}
\ No newline at end of file
import Control.Monad ( when )
import Data.Char
+import Data.List ( intersperse )
import System.FilePath
import System.IO ( stderr, hPutChar )
| CoreDoNothing -- Useful when building up
| CoreDoPasses [CoreToDo] -- lists of these things
+
data SimplifierMode -- See comments in SimplMonad
= SimplGently
| SimplPhase Int [String]
+instance Outputable SimplifierMode where
+ ppr SimplGently = ptext (sLit "gentle")
+ ppr (SimplPhase n ss) = int n <+> brackets (text (concat $ intersperse "," ss))
+
+
data SimplifierSwitch
= MaxSimplifierIterations Int
| NoCaseOfCase
-data FloatOutSwitches
- = FloatOutSw Bool -- True <=> float lambdas to top level
- Bool -- True <=> float constants to top level,
- -- even if they do not escape a lambda
+
+data FloatOutSwitches = FloatOutSwitches {
+ floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
+ floatOutConstants :: Bool -- ^ True <=> float constants to top level,
+ -- even if they do not escape a lambda
+ }
+
+instance Outputable FloatOutSwitches where
+ ppr = pprFloatOutSwitches
+
+pprFloatOutSwitches :: FloatOutSwitches -> SDoc
+pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
+ <+> pp_not (floatOutConstants sw) <+> text "constants"
+ where
+ pp_not True = empty
+ pp_not False = text "not"
+
+-- | Switches that specify the minimum amount of floating out
+gentleFloatOutSwitches :: FloatOutSwitches
+gentleFloatOutSwitches = FloatOutSwitches False False
+
+-- | Switches that do not specify floating out of lambdas, just of constants
+constantsOnlyFloatOutSwitches :: FloatOutSwitches
+constantsOnlyFloatOutSwitches = FloatOutSwitches False True
-- The core-to-core pass ordering is derived from the DynFlags:
-- so that overloaded functions have all their dictionary lambdas manifest
CoreDoSpecialising,
- runWhen full_laziness (CoreDoFloatOutwards (FloatOutSw False False)),
+ runWhen full_laziness (CoreDoFloatOutwards gentleFloatOutSwitches),
CoreDoFloatInwards,
]),
runWhen full_laziness
- (CoreDoFloatOutwards (FloatOutSw False -- Not lambdas
- True)), -- Float constants
+ (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
-- nofib/spectral/hartel/wang doubles in speed if you
-- do full laziness late in the day. It only happens
-- after fusion and other stuff, so the early pass doesn't
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ findGlobalAnns,
mkPrintUnqualifiedForModule,
-- * Printing
import qualified StaticFlags
import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
cleanTempDirs )
+import Annotations
import Module
import LazyUniqFM
import UniqSet
import Data.Maybe
import Data.List
import qualified Data.List as List
+import Data.Typeable ( Typeable )
+import Data.Word ( Word8 )
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
import System.Time ( ClockTime, getClockTime )
mg_binds = cm_binds coreModule,
mg_foreign = NoStubs,
mg_warns = NoWarnings,
+ mg_anns = [],
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
mg_vect_info = noVectInfo,
return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name
+findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
+findGlobalAnns deserialize target = withSession $ \hsc_env -> do
+ ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
+ return (findAnns deserialize ann_env target)
+
#ifdef GHCI
-- | get the GlobalRdrEnv for a session
getGRE :: GhcMonad m => m GlobalRdrEnv
i_str = show i
padded = replicate (length n_str - length i_str) ' ' ++ i_str
\end{code}
-
PackageInstEnv, PackageRuleBase,
+
+ -- * Annotations
+ prepareAnnotations,
+
-- * Interactive context
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
import Id
import Type
+import Annotations
import Class ( Class, classSelIds, classATs, classTyCon )
import TyCon
import DataCon ( DataCon, dataConImplicitIds, dataConWrapId )
-- ^ Get rules from modules \"below\" this one (in the dependency sense)
hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
+
+hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation]
+-- ^ Get annotations from modules \"below\" this one (in the dependency sense)
+hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps
+hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
+
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env))
-- And get its dfuns
, thing <- things ]
+\end{code}
+%************************************************************************
+%* *
+\subsection{Dealing with Annotations}
+%* *
+%************************************************************************
+
+\begin{code}
+prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
+-- ^ Deal with gathering annotations in from all possible places
+-- and combining them into a single 'AnnEnv'
+prepareAnnotations hsc_env mb_guts
+ = do { eps <- hscEPS hsc_env
+ ; let -- Extract annotations from the module being compiled if supplied one
+ mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts
+ -- Extract dependencies of the module if we are supplied one,
+ -- otherwise load annotations from all home package table
+ -- entries regardless of dependency ordering.
+ home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts
+ other_pkg_anns = eps_ann_env eps
+ ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,
+ Just home_pkg_anns,
+ Just other_pkg_anns]
+
+ ; return ann_env }
\end{code}
%************************************************************************
-- NOT STRICT! we read this field lazily from the interface file
+ mi_anns :: [IfaceAnnotation],
+ -- ^ Annotations
+
+ -- NOT STRICT! we read this field lazily from the interface file
+
-- Type, class and variable declarations
-- The hash of an Id changes if its fixity or deprecations change
-- (as well as its type of course)
md_insts :: ![Instance], -- ^ 'DFunId's for the instances in this module
md_fam_insts :: ![FamInst],
md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules
+ md_anns :: ![Annotation], -- ^ Annotations present in this module: currently
+ -- they only annotate things also declared in this module
md_vect_info :: !VectInfo -- ^ Module vectorisation information
}
md_insts = [],
md_rules = [],
md_fam_insts = [],
+ md_anns = [],
md_vect_info = noVectInfo
}
mg_binds :: ![CoreBind], -- ^ Bindings for this module
mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module
mg_warns :: !Warnings, -- ^ Warnings declared in the module
+ mg_anns :: [Annotation], -- ^ Annotations declared in this module
mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module
mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module
mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module
mi_exp_hash = fingerprint0,
mi_fixities = [],
mi_warns = NoWarnings,
+ mi_anns = [],
mi_insts = [],
mi_fam_insts = [],
mi_rules = [],
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
type PackageVectInfo = VectInfo
+type PackageAnnEnv = AnnEnv
-- | Information about other packages that we have slurped in by reading
-- their interface files
-- from all the external-package modules
eps_vect_info :: !PackageVectInfo, -- ^ The total 'VectInfo' accumulated
-- from all the external-package modules
+ eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated
+ -- from all the external-package modules
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external
-- packages, keyed off the module that declared them
+++ /dev/null
-> module HscTypes where
->
-> data Session
\ No newline at end of file
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
+ , md_anns = []
, md_exports = exports
, md_vect_info = noVectInfo
})
mg_rules = imp_rules,
mg_vect_info = vect_info,
mg_dir_imps = dir_imps,
+ mg_anns = anns,
mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
md_insts = tidy_insts,
md_fam_insts = fam_insts,
md_exports = exports,
- md_vect_info = vect_info -- is already tidy
+ md_anns = anns, -- are already tidy
+ md_vect_info = vect_info --
})
}
{ token ITgenerated_prag }
"{-#" $whitechar* (CORE|core) { token ITcore_prag }
"{-#" $whitechar* (UNPACK|unpack) { token ITunpack_prag }
+ "{-#" $whitechar* (ANN|ann) { token ITann_prag }
-- We ignore all these pragmas, but don't generate a warning for them
-- CFILES is a hugs-only thing.
| ITgenerated_prag
| ITcore_prag -- hdaume: core annotations
| ITunpack_prag
+ | ITann_prag
| ITclose_prag
| IToptions_prag String
| ITinclude_prag String
'{-# DEPRECATED' { L _ ITdeprecated_prag }
'{-# WARNING' { L _ ITwarning_prag }
'{-# UNPACK' { L _ ITunpack_prag }
+ '{-# ANN' { L _ ITann_prag }
'#-}' { L _ ITclose_prag }
'..' { L _ ITdotdot } -- reserved symbols
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
+ | annotation { unitOL $1 }
| decl { unLoc $1 }
-- Template Haskell Extension
{ toOL [ LL $ WarningD (Warning n (DeprecatedTxt (getSTRING $2)))
| n <- unLoc $1 ] }
+-----------------------------------------------------------------------------
+-- Annotations
+annotation :: { LHsDecl RdrName }
+ : '{-# ANN' name_var aexp '#-}' { LL (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc $2)) $3) }
+ | '{-# ANN' 'type' tycon aexp '#-}' { LL (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc $3)) $4) }
+ | '{-# ANN' 'module' aexp '#-}' { LL (AnnD $ HsAnnotation ModuleAnnProvenance $3) }
+
-----------------------------------------------------------------------------
-- Foreign import and export declarations
= addl (gp { hs_fords = L l d : ts }) ds
add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
= addl (gp { hs_warnds = L l d : ts }) ds
+add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
+ = addl (gp { hs_annds = L l d : ts }) ds
add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
= addl (gp { hs_ruleds = L l d : ts }) ds
-- Other classes
randomClassName, randomGenClassName, monadPlusClassName,
+ -- Annotation type checking
+ toAnnotationWrapperName,
+
-- Booleans
andName, orName
choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey
loopAName = varQual aRROW (fsLit "loop") loopAIdKey
+-- Annotation type checking
+toAnnotationWrapperName :: Name
+toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey
+
-- Other classes, needed for type defaulting
monadPlusClassName, randomClassName, randomGenClassName,
isStringClassName :: Name
fromStringClassOpKey :: Unique
fromStringClassOpKey = mkPreludeMiscIdUnique 125
+-- Annotation type checking
+toAnnotationWrapperIdKey :: Unique
+toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 126
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-399
-----------------------------------------------------
import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
makeMiniFixityEnv)
-import RnEnv ( lookupLocalDataTcNames,
- lookupLocatedTopBndrRn, lookupLocatedOccRn,
+import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn,
+ lookupTopBndrRn, lookupLocatedTopBndrRn,
lookupOccRn, newLocalsRn,
bindLocatedLocalsFV, bindPatSigTyVarsFV,
bindTyVarsRn, extendTyVarEnvFVRn,
hs_derivds = deriv_decls,
hs_fixds = fix_decls,
hs_warnds = warn_decls,
+ hs_annds = ann_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
hs_ruleds = rule_decls,
rnList rnHsRuleDecl rule_decls ;
-- Inside RULES, scoped type variables are on
(rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
- (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ;
- (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ;
+ (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
+ (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
+ (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
-- Haddock docs; no free vars
rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
hs_warnds = [], -- warns are returned in the tcg_env
-- (see below) not in the HsGroup
hs_fords = rn_foreign_decls,
+ hs_annds = rn_ann_decls,
hs_defds = rn_default_decls,
hs_ruleds = rn_rule_decls,
hs_docs = rn_docs } ;
- other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3,
- src_fvs4, src_fvs5] ;
+ other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+ src_fvs5, src_fvs6, src_fvs7] ;
src_dus = bind_dus `plusDU` usesOnly other_fvs;
-- Note: src_dus will contain *uses* for locally-defined types
-- and classes, but no *defs* for them. (Because rnTyClDecl
%*********************************************************
%* *
-\subsection{Source code declarations}
+\subsection{Annotation declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
+rnAnnDecl (HsAnnotation provenance expr) = do
+ (provenance', provenance_fvs) <- rnAnnProvenance provenance
+ (expr', expr_fvs) <- rnLExpr expr
+ return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
+
+rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
+rnAnnProvenance provenance = do
+ provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
+ return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Default declarations}
%* *
%*********************************************************
#include "HsVersions.h"
-import DynFlags ( DynFlag(..), DynFlags )
import Id ( Id, idType, idInlinePragma, zapIdOccInfo )
import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap )
import DataCon ( isUnboxedTupleCon )
import Type ( tyConAppArgs )
import CoreSyn
import VarEnv
-import CoreLint ( showPass, endPass )
import Outputable
import StaticFlags ( opt_PprStyle_Debug )
import BasicTypes ( isAlwaysActive )
%************************************************************************
\begin{code}
-cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-cseProgram dflags binds
- = do {
- showPass dflags "Common sub-expression";
- let { binds' = cseBinds emptyCSEnv binds };
- endPass dflags "Common sub-expression" Opt_D_dump_cse binds'
- }
+cseProgram :: [CoreBind] -> [CoreBind]
+cseProgram binds = cseBinds emptyCSEnv binds
cseBinds :: CSEnv -> [CoreBind] -> [CoreBind]
cseBinds _ [] = []
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[CoreMonad]{The core pipeline monad}
+
+\begin{code}
+{-# LANGUAGE UndecidableInstances #-}
+
+module CoreMonad (
+ -- * The monad
+ CoreM, runCoreM,
+
+ -- ** Reading from the monad
+ getHscEnv, getAnnEnv, getRuleBase, getModule,
+ getDynFlags, getOrigNameCache,
+
+ -- ** Writing to the monad
+ addSimplCount,
+
+ -- ** Lifting into the monad
+ liftIO, liftIOWithCount,
+ liftIO1, liftIO2, liftIO3, liftIO4,
+
+ -- ** Dealing with annotations
+ findAnnotations, addAnnotation,
+
+ -- ** Screen output
+ putMsg, putMsgS, errorMsg, errorMsgS,
+ fatalErrorMsg, fatalErrorMsgS,
+ debugTraceMsg, debugTraceMsgS,
+ dumpIfSet_dyn,
+
+#ifdef GHCI
+ -- * Getting 'Name's
+ thNameToGhcName
+#endif
+ ) where
+
+import Name
+import PrelNames ( iNTERACTIVE )
+import HscTypes
+import Module ( Module )
+import DynFlags ( DynFlags, DynFlag )
+import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount )
+import Rules ( RuleBase )
+import Annotations
+import Serialized
+
+import IOEnv hiding ( liftIO, failM, failWithM )
+import qualified IOEnv ( liftIO )
+import TcEnv ( tcLookupGlobal )
+import TcRnMonad ( TcM, initTc )
+
+import Outputable
+import qualified ErrUtils as Err
+import MonadUtils
+import Maybes
+import UniqSupply
+
+import Data.Dynamic
+import Data.IORef
+import Data.Word
+import Control.Monad
+import Control.Applicative
+
+import Prelude hiding ( read )
+
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
+import qualified Language.Haskell.TH as TH
+#endif
+\end{code}
+
+\subsection{Monad and carried data structure definitions}
+
+\begin{code}
+data CoreState = CoreState {
+ cs_uniq_supply :: UniqSupply,
+ cs_ann_env :: AnnEnv
+}
+
+data CoreReader = CoreReader {
+ cr_hsc_env :: HscEnv,
+ cr_rule_base :: RuleBase,
+ cr_module :: Module
+}
+
+data CoreWriter = CoreWriter {
+ cw_simpl_count :: SimplCount
+}
+
+emptyWriter :: DynFlags -> CoreWriter
+emptyWriter dflags = CoreWriter {
+ cw_simpl_count = zeroSimplCount dflags
+ }
+
+plusWriter :: CoreWriter -> CoreWriter -> CoreWriter
+plusWriter w1 w2 = CoreWriter {
+ cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
+ }
+
+type CoreIOEnv = IOEnv CoreReader
+
+-- | The monad used by Core-to-Core passes to access common state, register simplification
+-- statistics and so on
+newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
+
+instance Functor CoreM where
+ fmap f ma = do
+ a <- ma
+ return (f a)
+
+instance Monad CoreM where
+ return x = CoreM (\s -> nop s x)
+ mx >>= f = CoreM $ \s -> do
+ (x, s', w1) <- unCoreM mx s
+ (y, s'', w2) <- unCoreM (f x) s'
+ return (y, s'', w1 `plusWriter` w2)
+
+instance Applicative CoreM where
+ pure = return
+ (<*>) = ap
+
+-- For use if the user has imported Control.Monad.Error from MTL
+-- Requires UndecidableInstances
+instance MonadPlus IO => MonadPlus CoreM where
+ mzero = CoreM (const mzero)
+ m `mplus` n = CoreM (\rs -> unCoreM m rs `mplus` unCoreM n rs)
+
+instance MonadUnique CoreM where
+ getUniqueSupplyM = do
+ us <- getS cs_uniq_supply
+ let (us1, us2) = splitUniqSupply us
+ modifyS (\s -> s { cs_uniq_supply = us2 })
+ return us1
+
+runCoreM :: HscEnv
+ -> AnnEnv
+ -> RuleBase
+ -> UniqSupply
+ -> Module
+ -> CoreM a
+ -> IO (a, SimplCount)
+runCoreM hsc_env ann_env rule_base us mod m =
+ liftM extract $ runIOEnv reader $ unCoreM m state
+ where
+ reader = CoreReader {
+ cr_hsc_env = hsc_env,
+ cr_rule_base = rule_base,
+ cr_module = mod
+ }
+ state = CoreState {
+ cs_uniq_supply = us,
+ cs_ann_env = ann_env
+ }
+
+ extract :: (a, CoreState, CoreWriter) -> (a, SimplCount)
+ extract (value, _, writer) = (value, cw_simpl_count writer)
+
+\end{code}
+
+\subsection{Core combinators, not exported}
+
+\begin{code}
+
+nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter)
+nop s x = do
+ r <- getEnv
+ return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r)
+
+read :: (CoreReader -> a) -> CoreM a
+read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r)))
+
+getS :: (CoreState -> a) -> CoreM a
+getS f = CoreM (\s -> nop s (f s))
+
+modifyS :: (CoreState -> CoreState) -> CoreM ()
+modifyS f = CoreM (\s -> nop (f s) ())
+
+write :: CoreWriter -> CoreM ()
+write w = CoreM (\s -> return ((), s, w))
+
+\end{code}
+
+\subsection{Lifting IO into the monad}
+
+\begin{code}
+
+-- | Lift an 'IOEnv' operation into 'CoreM'
+liftIOEnv :: CoreIOEnv a -> CoreM a
+liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x))
+
+instance MonadIO CoreM where
+ liftIO = liftIOEnv . IOEnv.liftIO
+
+-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'
+liftIOWithCount :: IO (SimplCount, a) -> CoreM a
+liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)
+
+\end{code}
+
+\subsection{Reader, writer and state accessors}
+
+\begin{code}
+
+getHscEnv :: CoreM HscEnv
+getHscEnv = read cr_hsc_env
+
+getAnnEnv :: CoreM AnnEnv
+getAnnEnv = getS cs_ann_env
+
+getRuleBase :: CoreM RuleBase
+getRuleBase = read cr_rule_base
+
+getModule :: CoreM Module
+getModule = read cr_module
+
+addSimplCount :: SimplCount -> CoreM ()
+addSimplCount count = write (CoreWriter { cw_simpl_count = count })
+
+-- Convenience accessors for useful fields of HscEnv
+
+getDynFlags :: CoreM DynFlags
+getDynFlags = fmap hsc_dflags getHscEnv
+
+-- | The original name cache is the current mapping from 'Module' and
+-- 'OccName' to a compiler-wide unique 'Name'
+getOrigNameCache :: CoreM OrigNameCache
+getOrigNameCache = do
+ nameCacheRef <- fmap hsc_NC getHscEnv
+ liftIO $ fmap nsNames $ readIORef nameCacheRef
+
+\end{code}
+
+\subsection{Dealing with annotations}
+
+\begin{code}
+
+-- | Find all the annotations we currently know about for the given target. Note that no
+-- annotations will be returned if we haven't loaded information about the particular target
+-- you are inquiring about: by default, only those modules that have been imported by the
+-- program being compiled will have been loaded in this way.
+--
+-- To load the information from additional modules, you can use the functions 'DynamicLoading.forceLoadModuleInterfaces'
+-- and 'DynamicLoading.forceLoadNameModuleInterface', but be aware that doing this indiscriminantly
+-- will impose a performance penalty.
+--
+-- If no deserialization function is supplied, only transient annotations will be returned.
+findAnnotations :: Typeable a => ([Word8] -> a) -> CoreAnnTarget -> CoreM [a]
+findAnnotations deserialize target = do
+ ann_env <- getAnnEnv
+ return (findAnns deserialize ann_env target)
+
+addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
+addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
+
+addAnnotationToEnv :: Annotation -> CoreM ()
+addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAnnEnvList (cs_ann_env state) [annotation] })
+
+\end{code}
+
+\subsection{Direct screen output}
+
+\begin{code}
+
+msg :: (DynFlags -> SDoc -> IO ()) -> SDoc -> CoreM ()
+msg how doc = do
+ dflags <- getDynFlags
+ liftIO $ how dflags doc
+
+-- | Output a String message to the screen
+putMsgS :: String -> CoreM ()
+putMsgS = putMsg . text
+
+-- | Output a message to the screen
+putMsg :: SDoc -> CoreM ()
+putMsg = msg Err.putMsg
+
+-- | Output a string error to the screen
+errorMsgS :: String -> CoreM ()
+errorMsgS = errorMsg . text
+
+-- | Output an error to the screen
+errorMsg :: SDoc -> CoreM ()
+errorMsg = msg Err.errorMsg
+
+-- | Output a fatal string error to the screen. Note this does not by itself cause the compiler to die
+fatalErrorMsgS :: String -> CoreM ()
+fatalErrorMsgS = fatalErrorMsg . text
+
+-- | Output a fatal error to the screen. Note this does not by itself cause the compiler to die
+fatalErrorMsg :: SDoc -> CoreM ()
+fatalErrorMsg = msg Err.fatalErrorMsg
+
+-- | Output a string debugging message at verbosity level of @-v@ or higher
+debugTraceMsgS :: String -> CoreM ()
+debugTraceMsgS = debugTraceMsg . text
+
+-- | Outputs a debugging message at verbosity level of @-v@ or higher
+debugTraceMsg :: SDoc -> CoreM ()
+debugTraceMsg = msg (flip Err.debugTraceMsg 3)
+
+-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
+dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM ()
+dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str)
+
+\end{code}
+
+\begin{code}
+
+initTcForLookup :: HscEnv -> TcM a -> IO a
+initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc hsc_env HsSrcFile False iNTERACTIVE
+
+\end{code}
+
+\subsection{Finding TyThings}
+
+\begin{code}
+
+instance MonadThings CoreM where
+ lookupThing name = do
+ hsc_env <- getHscEnv
+ liftIO $ initTcForLookup hsc_env (tcLookupGlobal name)
+
+\end{code}
+
+\subsection{Template Haskell interoperability}
+
+\begin{code}
+
+#ifdef GHCI
+-- | Attempt to convert a Template Haskell name to one that GHC can understand. Original TH names such as those you get when you
+-- use the @'foo@ syntax will be translated to their equivalent GHC name exactly. Qualified or unqualifed TH names will be dynamically
+-- bound to names in the module being compiled, if possible. Exact TH names will be bound to the name they represent, exactly.
+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
+thNameToGhcName th_name = do
+ hsc_env <- getHscEnv
+ liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
+#endif
+
+\end{code}
#include "HsVersions.h"
-import DynFlags ( DynFlags, DynFlag(..) )
import CoreSyn
import CoreUtils ( exprIsHNF, exprIsDupable )
-import CoreLint ( showPass, endPass )
import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars )
import Id ( isOneShotBndr, idType )
import Var
actually float any bindings downwards from the top-level.
\begin{code}
-floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind]
-
-floatInwards dflags binds
- = do {
- showPass dflags "Float inwards";
- let { binds' = map fi_top_bind binds };
- endPass dflags "Float inwards" Opt_D_verbose_core2core binds'
- {- no specific flag for dumping float-in -}
- }
-
+floatInwards :: [CoreBind] -> [CoreBind]
+floatInwards = map fi_top_bind
where
fi_top_bind (NonRec binder rhs)
= NonRec binder (fiExpr [] (freeVars rhs))
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id, idType )
import Type ( isUnLiftedType )
-import CoreLint ( showPass, endPass )
import SetLevels ( Level(..), LevelledExpr, LevelledBind,
setLevels, ltMajLvl, ltLvl, isTopLvl )
import UniqSupply ( UniqSupply )
floatOutwards float_sws dflags us pgm
= do {
- showPass dflags float_msg ;
-
let { annotated_w_levels = setLevels float_sws pgm us ;
(fss, binds_s') = unzip (map floatTopBind annotated_w_levels)
} ;
int ntlets, ptext (sLit " Lets floated elsewhere; from "),
int lams, ptext (sLit " Lambda groups")]);
- endPass dflags float_msg Opt_D_verbose_core2core (concat binds_s')
- {- no specific flag for dumping float-out -}
+ return (concat binds_s')
}
- where
- float_msg = showSDoc (text "Float out" <+> parens (sws float_sws))
- sws (FloatOutSw lam const) = pp_not lam <+> text "lambdas" <> comma <+>
- pp_not const <+> text "constants"
- pp_not True = empty
- pp_not False = text "not"
floatTopBind :: LevelledBind -> (FloatStats, [CoreBind])
floatTopBind bind
#include "HsVersions.h"
import DynFlags
-import HscTypes
-import CoreLint ( showPass, endPass )
import CoreSyn
import CoreUnfold ( couldBeSmallEnoughToInline )
-import Rules ( RuleBase )
-import UniqSupply ( UniqSupply )
-import SimplMonad ( SimplCount, zeroSimplCount )
import Id
import VarEnv
import Util ( notNull )
%************************************************************************
\begin{code}
-liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts
- -> IO (SimplCount, ModGuts)
-liberateCase hsc_env _ _ guts
- = do { let dflags = hsc_dflags hsc_env
-
- ; showPass dflags "Liberate case"
- ; let { env = initEnv dflags
- ; binds' = do_prog env (mg_binds guts) }
- ; endPass dflags "Liberate case" Opt_D_verbose_core2core binds'
- {- no specific flag for dumping -}
- ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
+liberateCase :: DynFlags -> [CoreBind] -> [CoreBind]
+liberateCase dflags binds = do_prog (initEnv dflags) binds
where
do_prog _ [] = []
do_prog env (bind:binds) = bind' : do_prog env' binds
module SAT ( doStaticArgs ) where
-import DynFlags
import Var
import CoreSyn
-import CoreLint
import CoreUtils
import Type
import TcType
\end{code}
\begin{code}
-doStaticArgs :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-doStaticArgs dflags us binds = do
- showPass dflags "Static argument"
- let binds' = snd $ mapAccumL sat_bind_threaded_us us binds
- endPass dflags "Static argument" Opt_D_verbose_core2core binds'
+doStaticArgs :: UniqSupply -> [CoreBind] -> [CoreBind]
+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
where
sat_bind_threaded_us us bind =
let (us1, us2) = splitUniqSupply us
isStaticValue (Static (VarApp _)) = True
isStaticValue _ = False
-\end{code}
\ No newline at end of file
+\end{code}
initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
floatLams :: LevelEnv -> Bool
-floatLams (FloatOutSw float_lams _, _, _, _) = float_lams
+floatLams (fos, _, _, _) = floatOutLambdas fos
floatConsts :: LevelEnv -> Bool
-floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
+floatConsts (fos, _, _, _) = floatOutConstants fos
extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
-- Used when *not* cloning
import HscTypes
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
- extendRuleBaseList, pprRuleBase, ruleCheckProgram,
+ extendRuleBaseList, pprRuleBase, pprRulesForUser,
+ ruleCheckProgram, rulesOfBinds,
addSpecInfo, addIdSpecialisations )
import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import Simplify ( simplTopBinds, simplExpr )
import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
-import CoreLint ( endPassIf, endIteration )
+import CoreMonad
+import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass )
+import CoreLint ( showPass, endPass, endPassIf, endIteration )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
import DataCon
import TyCon ( tyConSelIds, tyConDataCons )
import Class ( classSelIds )
+import BasicTypes ( CompilerPhase, isActive )
import VarSet
import VarEnv
import NameEnv ( lookupNameEnv )
import CprAnalyse ( cprAnalyse )
#endif
import Vectorise ( vectorise )
+import FastString
import Util
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
-> ModGuts
-> IO ModGuts
-core2core hsc_env guts
- = do {
- ; let dflags = hsc_dflags hsc_env
- core_todos = getCoreToDo dflags
+core2core hsc_env guts = do
+ let dflags = hsc_dflags hsc_env
+
+ us <- mkSplitUniqSupply 's'
+ let (cp_us, ru_us) = splitUniqSupply us
+
+ -- COMPUTE THE ANNOTATIONS TO USE
+ ann_env <- prepareAnnotations hsc_env (Just guts)
+
+ -- COMPUTE THE RULE BASE TO USE
+ (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
- ; us <- mkSplitUniqSupply 's'
- ; let (cp_us, ru_us) = splitUniqSupply us
+ -- Get the module out of the current HscEnv so we can retrieve it from the monad.
+ -- This is very convienent for the users of the monad (e.g. plugins do not have to
+ -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
+ -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
+ -- would mean our cached value would go out of date.
+ let mod = mg_module guts
+ (guts, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+ -- FIND BUILT-IN PASSES
+ let builtin_core_todos = getCoreToDo dflags
- -- COMPUTE THE RULE BASE TO USE
- ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+ -- Note [Injecting implicit bindings]
+ let implicit_binds = getImplicitBinds (mg_types guts1)
+ guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
- -- Note [Injecting implicit bindings]
- ; let implicit_binds = getImplicitBinds (mg_types guts1)
- guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
+ -- DO THE BUSINESS
+ doCorePasses builtin_core_todos guts2
- -- DO THE BUSINESS
- ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
- (zeroSimplCount dflags)
- guts2 core_todos
+ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
- ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
- "Grand total simplifier statistics"
- (pprSimplCount stats)
+ return guts
- ; return guts3 }
+type CorePass = CoreToDo
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-> CoreExpr
-- expression typed in at the interactive prompt
simplifyExpr dflags expr
= do {
- ; showPass dflags "Simplify"
+ ; Err.showPass dflags "Simplify"
; us <- mkSplitUniqSupply 's'
; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
simplExprGently gentleSimplEnv expr
- ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
gentleSimplEnv :: SimplEnv
gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
-doCorePasses :: HscEnv
- -> RuleBase -- the imported main rule base
- -> UniqSupply -- uniques
- -> SimplCount -- simplifier stats
- -> ModGuts -- local binds in (with rules attached)
- -> [CoreToDo] -- which passes to do
- -> IO (SimplCount, ModGuts)
-
-doCorePasses hsc_env rb us stats guts []
- = return (stats, guts)
-
-doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2)
- = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2)
-
-doCorePasses hsc_env rb us stats guts (to_do : to_dos)
- = do
- let (us1, us2) = splitUniqSupply us
- (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
- doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
-
-doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
- -> ModGuts -> IO (SimplCount, ModGuts)
-doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} simplifyPgm mode sws
-doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram
-doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase
-doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards
-doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
-doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBindsU doStaticArgs
-doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm
-doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds
-doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram
-doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram
-doCorePass CoreDoGlomBinds = trBinds glomBinds
-doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} vectorise be
-doCorePass CoreDoPrintCore = observe printCore
-doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
-doCorePass CoreDoNothing = observe (\ _ _ -> return ())
-#ifdef OLD_STRICTNESS
-doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
-#else
-doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness"
+doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
+doCorePasses passes guts = foldM (flip doCorePass) guts passes
+
+doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
+doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
+ simplifyPgm mode sws
+
+doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
+ describePass "Common sub-expression" Opt_D_dump_cse $
+ doPass cseProgram
+
+doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
+ describePass "Liberate case" Opt_D_verbose_core2core $
+ doPassD liberateCase
+
+doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
+ describePass "Float inwards" Opt_D_verbose_core2core $
+ doPass floatInwards
+
+doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
+ describePassD (text "Float out" <+> parens (ppr f))
+ Opt_D_verbose_core2core $
+ doPassDUM (floatOutwards f)
+
+doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
+ describePass "Static argument" Opt_D_verbose_core2core $
+ doPassU doStaticArgs
+
+doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
+ describePass "Demand analysis" Opt_D_dump_stranal $
+ doPassDM dmdAnalPgm
+
+doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
+ describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
+ doPassU wwTopBinds
+
+doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
+ describePassR "Specialise" Opt_D_dump_spec $
+ doPassU specProgram
+
+doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
+ describePassR "SpecConstr" Opt_D_dump_spec $
+ doPassDU specConstrProgram
+
+doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
+ describePass "Vectorisation" Opt_D_dump_vect $
+ vectorise be
+
+doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
+doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
+doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
+
+#ifdef OLD_STRICTNESS
+doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
#endif
-doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
+
+doCorePass CoreDoNothing = return
+doCorePass (CoreDoPasses passes) = doCorePasses passes
#ifdef OLD_STRICTNESS
-doOldStrictness dfs binds
- = do binds1 <- saBinds dfs binds
- binds2 <- cprAnalyse dfs binds1
- return binds2
+doOldStrictness :: ModGuts -> CoreM ModGuts
+doOldStrictness guts
+ = do dfs <- getDynFlags
+ guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
+ doPassM (saBinds dfs) guts
+ guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
+ doPass cprAnalyse guts'
+ return guts''
#endif
-printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
-
-ruleCheck phase pat hsc_env us rb guts
- = do let dflags = hsc_dflags hsc_env
- showPass dflags "RuleCheck"
- printDump (ruleCheckProgram phase pat rb (mg_binds guts))
- return (zeroSimplCount dflags, guts)
-
--- Most passes return no stats and don't change rules
-trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
- -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
- -> IO (SimplCount, ModGuts)
-trBinds do_pass hsc_env us rb guts
- = do { binds' <- do_pass dflags (mg_binds guts)
- ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
- where
- dflags = hsc_dflags hsc_env
-
-trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
- -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
- -> IO (SimplCount, ModGuts)
-trBindsU do_pass hsc_env us rb guts
- = do { binds' <- do_pass dflags us (mg_binds guts)
- ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
- where
- dflags = hsc_dflags hsc_env
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Core pass combinators}
+%* *
+%************************************************************************
+
+\begin{code}
+
+dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+dontDescribePass = ($)
+
+describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+describePass name dflag pass guts = do
+ dflags <- getDynFlags
+
+ liftIO $ showPass dflags name
+ guts' <- pass guts
+ liftIO $ endPass dflags name dflag (mg_binds guts')
+
+ return guts'
+
+describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+describePassD doc = describePass (showSDoc doc)
+
+describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+describePassR name dflag pass guts = do
+ guts' <- describePass name dflag pass guts
+ dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
+ (pprRulesForUser (rulesOfBinds (mg_binds guts')))
+ return guts'
+
+printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
+
+ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
+ruleCheck current_phase pat guts = do
+ let is_active = isActive current_phase
+ rb <- getRuleBase
+ dflags <- getDynFlags
+ liftIO $ Err.showPass dflags "RuleCheck"
+ liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
+ return guts
+
+
+doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
+doPassDMS do_pass = doPassM $ \binds -> do
+ dflags <- getDynFlags
+ liftIOWithCount $ do_pass dflags binds
+
+doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDUM do_pass = doPassM $ \binds -> do
+ dflags <- getDynFlags
+ us <- getUniqueSupplyM
+ liftIO $ do_pass dflags us binds
+
+doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
+
+doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
+
+doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
+
+doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPassU do_pass = doPassDU (const do_pass)
+
+-- Most passes return no stats and don't change rules: these combinators
+-- let us lift them to the full blown ModGuts+CoreM world
+doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
+doPassM bind_f guts = do
+ binds' <- bind_f (mg_binds guts)
+ return (guts { mg_binds = binds' })
+
+doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
+doPassMG bind_f guts = do
+ binds' <- bind_f guts
+ return (guts { mg_binds = binds' })
+
+doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
-- Observer passes just peek; don't modify the bindings at all
-observe :: (DynFlags -> [CoreBind] -> IO a)
- -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
- -> IO (SimplCount, ModGuts)
-observe do_pass hsc_env us rb guts
- = do { binds <- do_pass dflags (mg_binds guts)
- ; return (zeroSimplCount dflags, guts) }
- where
- dflags = hsc_dflags hsc_env
+observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
+observe do_pass = doPassM $ \binds -> do
+ dflags <- getDynFlags
+ liftIO $ do_pass dflags binds
+ return binds
\end{code}
hpt_rule_base = mkRuleBase home_pkg_rules
imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
- ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
vcat [text "Local rules", pprRules better_rules,
text "",
-- analyser as free in f.
glomBinds dflags binds
- = do { showPass dflags "GlomBinds" ;
+ = do { Err.showPass dflags "GlomBinds" ;
let { recd_binds = [Rec (flattenBinds binds)] } ;
return recd_binds }
-- Not much point in printing the result...
%************************************************************************
\begin{code}
-simplifyPgm :: SimplifierMode
+simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
+simplifyPgm mode switches
+ = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
+ do { hsc_env <- getHscEnv
+ ; us <- getUniqueSupplyM
+ ; rb <- getRuleBase
+ ; let fam_inst_env = mg_fam_inst_env guts
+ dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
+ simplify_pgm = simplifyPgmIO dump_phase mode switches
+ hsc_env us rb fam_inst_env
+
+ ; doPassM (liftIOWithCount . simplify_pgm) guts }
+ where
+ doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
+
+simplifyPgmIO :: Bool
+ -> SimplifierMode
-> [SimplifierSwitch]
-> HscEnv
-> UniqSupply
-> RuleBase
- -> ModGuts
- -> IO (SimplCount, ModGuts) -- New bindings
+ -> FamInstEnv
+ -> [CoreBind]
+ -> IO (SimplCount, [CoreBind]) -- New bindings
-simplifyPgm mode switches hsc_env us imp_rule_base guts
+simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
= do {
- showPass dflags "Simplify";
-
(termination_msg, it_count, counts_out, binds')
- <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
+ <- do_iteration us 1 (zeroSimplCount dflags) binds ;
- dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
- "Simplifier statistics"
+ Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
+ "Simplifier statistics for following pass"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
text "",
pprSimplCount counts_out]);
- endPassIf dump_phase dflags
- ("Simplify phase " ++ phase_info ++ " done")
- Opt_D_dump_simpl_phases binds';
-
- return (counts_out, guts { mg_binds = binds' })
+ return (counts_out, binds')
}
where
dflags = hsc_dflags hsc_env
- phase_info = case mode of
- SimplGently -> "gentle"
- SimplPhase n ss -> shows n
- . showString " ["
- . showString (concat $ intersperse "," ss)
- $ "]"
-
- dump_phase = shouldDumpSimplPhase dflags mode
sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
= do {
-- Occurrence analysis
let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
- dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+ Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- Get any new rules, and extend the rule base
; simpl_env = mkSimplEnv mode sw_chkr
; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
- ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
+ ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
-- Simplify the program
-- We do this with a *case* not a *let* because lazy pattern
(binds', counts') -> do {
let { all_counts = counts `plusSimplCount` counts'
- ; herald = "Simplifier phase " ++ phase_info ++
+ ; herald = "Simplifier mode " ++ showPpr mode ++
", iteration " ++ show iteration_no ++
" out of " ++ show max_iterations
} ;
let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
-- Dump the result of this iteration
- dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
(pprSimplCount counts') ;
endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
import Name ( Name, NamedThing(..) )
import NameEnv
import Unify ( ruleMatchTyX, MatchEnv(..) )
-import BasicTypes ( Activation, CompilerPhase, isActive )
+import BasicTypes ( Activation )
import StaticFlags ( opt_PprStyle_Debug )
import Outputable
import FastString
extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo
extendSpecInfo (SpecInfo rs1 fvs1) rs2
= SpecInfo (rs2 ++ rs1) (rulesFreeVars rs2 `unionVarSet` fvs1)
+
addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo
addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2)
= SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2)
\begin{code}
-- | Report partial matches for rules beginning with the specified
-- string for the purposes of error reporting
-ruleCheckProgram :: CompilerPhase -- ^ Phase to check in
+ruleCheckProgram :: (Activation -> Bool) -- ^ Rule activation test
-> String -- ^ Rule pattern
-> RuleBase -- ^ Database of rules
-> [CoreBind] -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message
-ruleCheckProgram phase rule_pat rule_base binds
+ruleCheckProgram is_active rule_pat rule_base binds
| isEmptyBag results
= text "Rule check results: no rule application sites"
| otherwise
vcat [ p $$ line | p <- bagToList results ]
]
where
- results = unionManyBags (map (ruleCheckBind (phase, rule_pat, rule_base)) binds)
+ results = unionManyBags (map (ruleCheckBind (RuleCheckEnv is_active rule_pat rule_base)) binds)
line = text (replicate 20 '-')
-type RuleCheckEnv = (CompilerPhase, String, RuleBase) -- Phase and Pattern
+data RuleCheckEnv = RuleCheckEnv {
+ rc_is_active :: Activation -> Bool,
+ rc_pattern :: String,
+ rc_rule_base :: RuleBase
+}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
-- The Bag returned has one SDoc for each call site found
-- Produce a report for all rules matching the predicate
-- saying why it doesn't match the specified application
-ruleCheckFun (phase, pat, rule_base) fn args
+ruleCheckFun env fn args
| null name_match_rules = emptyBag
- | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules)
+ | otherwise = unitBag (ruleAppCheck_help (rc_is_active env) fn args name_match_rules)
where
- name_match_rules = filter match (getRules rule_base fn)
- match rule = pat `isPrefixOf` unpackFS (ruleName rule)
+ name_match_rules = filter match (getRules (rc_rule_base env) fn)
+ match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)
-ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
-ruleAppCheck_help phase fn args rules
+ruleAppCheck_help :: (Activation -> Bool) -> Id -> [CoreExpr] -> [CoreRule] -> SDoc
+ruleAppCheck_help is_active fn args rules
= -- The rules match the pattern, so we want to print something
vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),
vcat (map check_rule rules)]
rule_info (Rule { ru_name = name, ru_act = act,
ru_bndrs = rule_bndrs, ru_args = rule_args})
- | not (isActive phase act) = text "active only in later phase"
+ | not (is_active act) = text "active only in later phase"
| n_args < n_rule_args = text "too few arguments"
| n_mismatches == n_rule_args = text "no arguments match"
| n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"
import CoreSubst
import CoreUtils
import CoreUnfold ( couldBeSmallEnoughToInline )
-import CoreLint ( showPass, endPass )
import CoreFVs ( exprsFreeVars )
import WwLib ( mkWorkerArgs )
import DataCon ( dataConRepArity, dataConUnivTyVars )
import VarSet
import Name
import OccName ( mkSpecOcc )
-import ErrUtils ( dumpIfSet_dyn )
-import DynFlags ( DynFlags(..), DynFlag(..) )
+import DynFlags ( DynFlags(..) )
import StaticFlags ( opt_PprStyle_Debug )
import StaticFlags ( opt_SpecInlineJoinPoints )
import BasicTypes ( Activation(..) )
%************************************************************************
\begin{code}
-specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specConstrProgram dflags us binds
- = do
- showPass dflags "SpecConstr"
-
- let (binds', _) = initUs us (go (initScEnv dflags) binds)
-
- endPass dflags "SpecConstr" Opt_D_dump_spec binds'
-
- dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
- (pprRulesForUser (rulesOfBinds binds'))
-
- return binds'
+specConstrProgram :: DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]
+specConstrProgram dflags us binds = fst $ initUs us (go (initScEnv dflags) binds)
where
go _ [] = return []
go env (bind:binds) = do (env', bind') <- scTopBind env bind
#include "HsVersions.h"
-import DynFlags ( DynFlags, DynFlag(..) )
import Id ( Id, idName, idType, mkUserLocal, idCoreRules,
idInlinePragma, setInlinePragma, setIdUnfolding,
isLocalId )
import Rules
import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkPiTypes )
import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars )
-import CoreLint ( showPass, endPass )
import UniqSupply ( UniqSupply,
UniqSM, initUs_,
MonadUnique(..)
import MkId ( voidArgId, realWorldPrimId )
import FiniteMap
import Maybes ( catMaybes, isJust )
-import ErrUtils ( dumpIfSet_dyn )
import Bag
import Util
import Outputable
%************************************************************************
\begin{code}
-specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]
-specProgram dflags us binds = do
-
- showPass dflags "Specialise"
-
- let binds' = initSM us (do (binds', uds') <- go binds
- return (dumpAllDictBinds uds' binds'))
-
- endPass dflags "Specialise" Opt_D_dump_spec binds'
-
- dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations"
- (pprRulesForUser (rulesOfBinds binds'))
-
- return binds'
+specProgram :: UniqSupply -> [CoreBind] -> [CoreBind]
+specProgram us binds = initSM us (do (binds', uds') <- go binds
+ return (dumpAllDictBinds uds' binds'))
where
-- We need to start with a Subst that knows all the things
-- that are in scope, so that the substitution engine doesn't
dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
dmdAnalPgm dflags binds
= do {
- showPass dflags "Demand analysis" ;
let { binds_plus_dmds = do_prog binds } ;
-
- endPass dflags "Demand analysis"
- Opt_D_dump_stranal binds_plus_dmds ;
#ifdef OLD_STRICTNESS
-- Only if OLD_STRICTNESS is on, because only then is the old
-- strictness analyser run
saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
saBinds dflags binds
= do {
- showPass dflags "Strictness analysis";
-
-- Mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
let { (binds_w_strictness, sa_stats) = runState $ (saTopBinds binds) nullSaStats };
let { binds_w_strictness = unSaM $ saTopBindsBinds binds };
#endif
- endPass dflags "Strictness analysis" Opt_D_dump_stranal
- binds_w_strictness
+ return binds_w_strictness
}
\end{code}
import BasicTypes ( RecFlag(..), isNonRec, isNeverActive )
import VarEnv ( isEmptyVarEnv )
import Maybes ( orElse )
-import DynFlags
import WwLib
import Util ( lengthIs, notNull )
import Outputable
\end{enumerate}
\begin{code}
+wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
-wwTopBinds :: DynFlags
- -> UniqSupply
- -> [CoreBind]
- -> IO [CoreBind]
-
-wwTopBinds dflags us binds
- = do {
- showPass dflags "Worker Wrapper binds";
-
- -- Create worker/wrappers, and mark binders with their
- -- "strictness info" [which encodes their worker/wrapper-ness]
- let { binds' = workersAndWrappers us binds };
-
- endPass dflags "Worker Wrapper binds"
- Opt_D_dump_worker_wrapper binds'
- }
-\end{code}
-
-
-\begin{code}
-workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
-
-workersAndWrappers us top_binds
+wwTopBinds us top_binds
= initUs_ us $ do
top_binds' <- mapM wwBind top_binds
return (concat top_binds')
--- /dev/null
+%
+% (c) The University of Glasgow 2006
+% (c) The AQUA Project, Glasgow University, 1993-1998
+%
+\section[TcAnnotations]{Typechecking annotations}
+
+\begin{code}
+module TcAnnotations ( tcAnnotations ) where
+
+import HsSyn
+import Annotations
+import Name
+import TcRnMonad
+import SrcLoc
+import Outputable
+
+#ifdef GHCI
+import Module
+import TcExpr
+import {-# SOURCE #-} TcSplice ( runAnnotation )
+import FastString
+#endif
+
+import Control.Monad
+\end{code}
+
+\begin{code}
+tcAnnotations :: [LAnnDecl Name] -> TcM [Annotation]
+tcAnnotations = mapM tcAnnotation
+
+tcAnnotation :: LAnnDecl Name -> TcM Annotation
+#ifndef GHCI
+-- TODO: modify lexer so ANN pragmas are parsed as comments in a stage1 compiler, so developers don't see this error
+tcAnnotation (L _ (HsAnnotation _ expr)) = pprPanic "Cant do annotations without GHCi" (ppr expr)
+#else
+tcAnnotation ann@(L loc (HsAnnotation provenance expr)) = do
+ -- Work out what the full target of this annotation was
+ mod <- getModule
+ let target = annProvenanceToTarget mod provenance
+
+ -- Run that annotation and construct the full Annotation data structure
+ setSrcSpan loc $ addErrCtxt (annCtxt ann) $ addExprErrCtxt expr $ runAnnotation target expr
+
+annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name
+annProvenanceToTarget _ (ValueAnnProvenance name) = NamedTarget name
+annProvenanceToTarget _ (TypeAnnProvenance name) = NamedTarget name
+annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
+
+annCtxt :: OutputableBndr id => LAnnDecl id -> SDoc
+annCtxt ann
+ = hang (ptext (sLit "In the annotation:")) 4 (ppr ann)
+#endif
+\end{code}
\ No newline at end of file
}
\end{code}
+\begin{code}
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+ lookupThing = tcLookupGlobal
+\end{code}
+
%************************************************************************
%* *
Extending the global environment
\begin{code}
instance Outputable ThStage where
- ppr Comp = text "Comp"
+ ppr (Comp l) = text "Comp" <+> int l
ppr (Brack l _ _) = text "Brack" <+> int l
ppr (Splice l) = text "Splice" <+> int l
thLevel :: ThStage -> ThLevel
-thLevel Comp = topLevel
+thLevel (Comp l) = l
thLevel (Splice l) = l
thLevel (Brack l _ _) = l
| bind_lvl == topLevel -- GHC restriction on top level splices
= failWithTc $
sep [ptext (sLit "GHC stage restriction:") <+> pp_thing,
- nest 2 (ptext (sLit "is used in a top-level splice, and must be imported, not defined locally"))]
+ nest 2 (ptext (sLit "is used in") <+> use_lvl_doc <> ptext (sLit ", and must be imported, not defined locally"))]
| otherwise -- Badly staged
= failWithTc $ -- E.g. \x -> $(f x)
ptext (sLit "but used at stage") <+> ppr use_lvl]
where
use_lvl = thLevel use_stage
-
+ use_lvl_doc | use_lvl == thLevel topStage = ptext (sLit "a top-level splice")
+ | use_lvl == thLevel topAnnStage = ptext (sLit "an annotation")
+ | otherwise = panic "checkWellStaged"
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, tcSyntaxOp, addExprErrCtxt ) where
#include "HsVersions.h"
-- to do so himself.
tcPolyExpr expr res_ty
- = addErrCtxt (exprCtxt expr) $
+ = addExprErrCtxt expr $
(do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
tcPolyExprNC expr res_ty
Boring and alphabetical:
\begin{code}
-exprCtxt (L _ expr)
+addExprErrCtxt :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a
+addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr))
+
+exprCtxt expr
= hang (ptext (sLit "In the expression:")) 4 (ppr expr)
fieldCtxt field_name
import FamInst
import InstEnv
import FamInstEnv
+import TcAnnotations
import TcBinds
import TcDefaults
import TcEnv
-- Even tcSimplifyTop may do some unification.
traceTc (text "Tc9") ;
let { (tcg_env, _) = tc_envs
- ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
- tcg_rules = rules, tcg_fords = fords } = tcg_env
+ ; TcGblEnv { tcg_type_env = type_env,
+ tcg_binds = binds,
+ tcg_rules = rules,
+ tcg_fords = fords } = tcg_env
; all_binds = binds `unionBags` inst_binds } ;
failIfErrsM ; -- Don't zonk if there have been errors
Nothing -> return ()
-- Rename the declarations
- ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
+ ; (tcg_env, HsGroup {
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fords = _,
+ hs_defds = _, -- Todo: check no foreign decls, no rules,
+ hs_ruleds = _, -- no default decls and no annotation decls
+ hs_annds = _,
+ hs_valds = val_binds }) <- rnTopSrcDecls first_group
; setGblEnv tcg_env $ do {
- -- Todo: check no foreign decls, no rules, no default decls
-- Typecheck type/class decls
; traceTc (text "Tc2")
- ; let tycl_decls = hs_tyclds rn_group
; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
; setGblEnv tcg_env $ do {
-- Typecheck instance decls
; traceTc (text "Tc3")
; (tcg_env, inst_infos, _deriv_binds)
- <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
+ <- tcInstDecls1 tycl_decls inst_decls deriv_decls
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
; traceTc (text "Tc5")
- ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+ ; val_ids <- tcHsBootSigs val_binds
-- Wrap up
-- No simplification or zonking to do
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
+ hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
traceTc (text "Tc7") ;
(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+ -- Annotations
+ annotations <- tcAnnotations annotation_decls ;
+
-- Rules
rules <- tcRules rule_decls ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
inst_binds `unionBags`
- foe_binds ;
+ foe_binds;
-- Extend the GblEnv with the (as yet un-zonked)
-- bindings, rules, foreign decls
tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
tcg_rules = tcg_rules tcg_env ++ rules,
+ tcg_anns = tcg_anns tcg_env ++ annotations,
tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
return (tcg_env', tcl_env)
}}}}}}
tcg_rn_decls = maybe_rn_syntax emptyRnGroup,
tcg_binds = emptyLHsBinds,
- tcg_warns = NoWarnings,
+ tcg_warns = NoWarnings,
+ tcg_anns = [],
tcg_insts = [],
tcg_fam_insts= [],
tcg_rules = [],
TcTyThing(..), pprTcTyThingCategory, RefinementVisibility(..),
-- Template Haskell
- ThStage(..), topStage, topSpliceStage,
+ ThStage(..), topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, topLevel,
-- Arrows
import Type
import Coercion
import TcType
+import Annotations
import InstEnv
import FamInstEnv
import IOEnv
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_warns :: Warnings, -- ...Warnings and deprecations
+ tcg_anns :: [Annotation], -- ...Annotations
tcg_insts :: [Instance], -- ...Instances
tcg_fam_insts :: [FamInst], -- ...Family instances
tcg_rules :: [LRuleDecl Id], -- ...Rules
data ThStage
- = Comp -- Ordinary compiling, at level topLevel
+ = Comp ThLevel -- Ordinary compiling, usually at level topLevel but annotations use a lower level
| Splice ThLevel -- Inside a splice
| Brack ThLevel -- Inside brackets;
(TcRef [PendingSplice]) -- accumulate pending splices here
(TcRef LIE) -- and type constraints here
-topStage, topSpliceStage :: ThStage
-topStage = Comp
+topStage, topAnnStage, topSpliceStage :: ThStage
+topStage = Comp topLevel
+topAnnStage = Comp (topLevel - 1)
topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
---------------------------
| ProcOrigin -- Arising from a proc expression
| ImplicOrigin SDoc -- An implication constraint
| EqOrigin -- A type equality
+ | AnnOrigin -- An annotation
instance Outputable InstOrigin where
ppr (OccurrenceOf name) = hsep [ptext (sLit "a use of"), quotes (ppr name)]
ppr (SigOrigin info) = pprSkolInfo info
ppr EqOrigin = ptext (sLit "a type equality")
ppr InstSigOrigin = panic "ppr InstSigOrigin"
+ ppr AnnOrigin = ptext (sLit "an annotation")
\end{code}
tcSimplifyDeriv, tcSimplifyDefault,
bindInstsOfLocalFuns,
+
+ tcSimplifyStagedExpr,
misMatchMsg
) where
import SrcLoc
import DynFlags
import FastString
+
import Control.Monad
import Data.List
\end{code}
doc = ptext (sLit "default declaration")
\end{code}
+@tcSimplifyStagedExpr@ performs a simplification but does so at a new
+stage. This is used when typechecking annotations and splices.
+
+\begin{code}
+
+tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds)
+-- Type check an expression that runs at a top level stage as if
+-- it were going to be spliced and then simplify it
+tcSimplifyStagedExpr stage tc_action
+ = setStage stage $ do {
+ -- Typecheck the expression
+ (thing', lie) <- getLIE tc_action
+
+ -- Solve the constraints
+ ; const_binds <- tcSimplifyTop lie
+
+ ; return (thing', const_binds) }
+
+\end{code}
+
%************************************************************************
%* *
-- for details
module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
- runQuasiQuoteExpr, runQuasiQuotePat ) where
+ lookupThName_maybe,
+ runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
import TypeRep
import Name
import NameEnv
+import PrelNames
import HscTypes
import OccName
import Var
import Module
+import Annotations
import TcRnMonad
import Class
+import Inst
import TyCon
import DataCon
import Id
import DsMeta
import DsExpr
import DsMonad hiding (Splice)
+import Serialized
import ErrUtils
import SrcLoc
import Outputable
-- THSyntax gives access to internal functions and data types
import qualified Language.Haskell.TH.Syntax as TH
+#ifdef GHCI
+-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
+import GHC.Desugar ( AnnotationWrapper(..) )
+#endif
+
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
import System.IO.Error
\end{code}
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
-- None of these functions add constraints to the LIE
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+
runQuasiQuoteExpr :: HsQuasiQuote Name -> TcM (LHsExpr RdrName)
runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
+runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
#ifndef GHCI
tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x)
tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x)
kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x)
+lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n)
+
runQuasiQuoteExpr q = pprPanic "Cant do runQuasiQuoteExpr without GHCi" (ppr q)
runQuasiQuotePat q = pprPanic "Cant do runQuasiQuotePat without GHCi" (ppr q)
+runAnnotation _ q = pprPanic "Cant do runAnnotation without GHCi" (ppr q)
#else
\end{code}
Just next_level ->
case level of {
- Comp -> do { e <- tcTopSplice expr res_ty
+ Comp _ -> do { e <- tcTopSplice expr res_ty
; return (unLoc e) } ;
Brack _ ps_var lie_var -> do
tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id)
-- Type check an expression that is the body of a top-level splice
-- (the caller will compile and run it)
-tcTopSpliceExpr expr meta_ty
- = checkNoErrs $ -- checkNoErrs: must not try to run the thing
- -- if the type checker fails!
+tcTopSpliceExpr expr meta_ty
+ = checkNoErrs $ -- checkNoErrs: must not try to run the thing
+ -- if the type checker fails!
+ do { (expr', const_binds) <- tcSimplifyStagedExpr topSpliceStage $
+ (recordThUse >> tcMonoExpr expr meta_ty)
+ -- Zonk it and tie the knot of dictionary bindings
+ ; zonkTopLExpr (mkHsDictLet const_binds expr') }
+\end{code}
- setStage topSpliceStage $ do
-
- do { recordThUse -- Record that TH is used (for pkg depdendency)
+%************************************************************************
+%* *
+ Annotations
+%* *
+%************************************************************************
- -- Typecheck the expression
- ; (expr', lie) <- getLIE (tcMonoExpr expr meta_ty)
-
- -- Solve the constraints
- ; const_binds <- tcSimplifyTop lie
-
- -- And zonk it
- ; zonkTopLExpr (mkHsDictLet const_binds expr') }
+\begin{code}
+runAnnotation target expr = do
+ expr_ty <- newFlexiTyVarTy liftedTypeKind
+
+ -- Find the classes we want instances for in order to call toAnnotationWrapper
+ typeable_class <- tcLookupClass typeableClassName
+ data_class <- tcLookupClass dataClassName
+
+ -- Check the instances we require live in another module (we want to execute it..)
+ -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
+ -- also resolves the LIE constraints to detect e.g. instance ambiguity
+ ((wrapper, expr'), const_binds) <- tcSimplifyStagedExpr topAnnStage $ do
+ expr' <- tcPolyExprNC expr expr_ty
+ -- By instantiating the call >here< it gets registered in the
+ -- LIE consulted by tcSimplifyStagedExpr
+ -- and hence ensures the appropriate dictionary is bound by const_binds
+ wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
+ return (wrapper, expr')
+
+ -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
+ loc <- getSrcSpanM
+ to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
+ let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
+ wrapped_expr' = mkHsDictLet const_binds $
+ L loc (HsApp specialised_to_annotation_wrapper_expr expr')
+
+ -- If we have type checking problems then potentially zonking
+ -- (and certainly compilation) may fail. Give up NOW!
+ failIfErrsM
+
+ -- Zonk the type variables out of that raw expression. Note that
+ -- in particular we don't call recordThUse, since we don't
+ -- necessarily use any code or definitions from that package.
+ zonked_wrapped_expr' <- zonkTopLExpr wrapped_expr'
+
+ -- Run the appropriately wrapped expression to get the value of
+ -- the annotation and its dictionaries. The return value is of
+ -- type AnnotationWrapper by construction, so this conversion is
+ -- safe
+ flip runMetaAW zonked_wrapped_expr' $ \annotation_wrapper ->
+ case annotation_wrapper of
+ AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
+ -- Got the value and dictionaries: build the serialized value and
+ -- call it a day. We ensure that we seq the entire serialized value
+ -- in order that any errors in the user-written code for the
+ -- annotation are exposed at this point. This is also why we are
+ -- doing all this stuff inside the context of runMeta: it has the
+ -- facilities to deal with user error in a meta-level expression
+ seqSerialized serialized `seq` Annotation {
+ ann_target = target,
+ ann_value = serialized
+ }
\end{code}
-- Run the expression
; traceTc (text "About to run" <+> ppr zonked_q_expr)
- ; result <- runMeta convert zonked_q_expr
+ ; result <- runMetaQ convert zonked_q_expr
; traceTc (text "Got result" <+> ppr result)
; showSplice desc zonked_q_expr (ppr result)
; return result
Just next_level -> do
{ case level of {
- Comp -> do { (t,k) <- kcTopSpliceType hs_expr
+ Comp _ -> do { (t,k) <- kcTopSpliceType hs_expr
; return (unLoc t, k) } ;
Brack _ ps_var lie_var -> do
%************************************************************************
\begin{code}
+runMetaAW :: (AnnotationWrapper -> output)
+ -> LHsExpr Id -- Of type AnnotationWrapper
+ -> TcM output
+runMetaAW k = runMeta False (\_ -> return . Right . k)
+ -- We turn off showing the code in meta-level exceptions because doing so exposes
+ -- the toAnnotationWrapper function that we slap around the users code
+
+runQThen :: (SrcSpan -> input -> Either Message output)
+ -> SrcSpan
+ -> TH.Q input
+ -> TcM (Either Message output)
+runQThen f expr_span what = TH.runQ what >>= (return . f expr_span)
+
+runMetaQ :: (SrcSpan -> input -> Either Message output)
+ -> LHsExpr Id
+ -> TcM output
+runMetaQ = runMeta True . runQThen
+
runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName))
-> LHsExpr Id -- Of type (Q Exp)
-> TcM (LHsExpr RdrName)
-runMetaE = runMeta
+runMetaE = runMetaQ
runMetaP :: (SrcSpan -> TH.Pat -> Either Message (Pat RdrName))
-> LHsExpr Id -- Of type (Q Pat)
-> TcM (Pat RdrName)
-runMetaP = runMeta
+runMetaP = runMetaQ
runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName))
-> LHsExpr Id -- Of type (Q Type)
-> TcM (LHsType RdrName)
-runMetaT = runMeta
+runMetaT = runMetaQ
runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName])
-> LHsExpr Id -- Of type Q [Dec]
-> TcM [LHsDecl RdrName]
-runMetaD = runMeta
+runMetaD = runMetaQ
-runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn)
+runMeta :: Bool -- Whether code should be printed in the exception message
+ -> (SrcSpan -> input -> TcM (Either Message output))
-> LHsExpr Id -- Of type X
- -> TcM hs_syn -- Of type t
-runMeta convert expr
+ -> TcM output -- Of type t
+runMeta show_code run_and_convert expr
= do { -- Desugar
ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
; either_tval <- tryAllM $
setSrcSpan expr_span $ -- Set the span so that qLocation can
-- see where this splice is
- do { th_syn <- TH.runQ (unsafeCoerce# hval)
- ; case convert expr_span th_syn of
+ do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
+ ; case mb_result of
Left err -> failWithTc err
- Right hs_syn -> return hs_syn }
+ Right result -> return $! result }
; case either_tval of
Right v -> return v
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
nest 2 (text (Panic.showException exn)),
- nest 2 (text "Code:" <+> ppr expr)]
+ if show_code then nest 2 (text "Code:" <+> ppr expr) else empty]
\end{code}
Note [Exceptions in TH]
ppr_ns _ = panic "reify/ppr_ns"
lookupThName :: TH.Name -> TcM Name
-lookupThName th_name@(TH.Name occ flavour)
- = do { mb_ns <- mapM lookup [ thRdrName gns occ_str flavour
- | gns <- guessed_nss]
- ; case catMaybes mb_ns of
- [] -> failWithTc (notInScope th_name)
- (n:_) -> return n } -- Pick the first that works
- -- E.g. reify (mkName "A") will pick the class A
- -- in preference to the data constructor A
+lookupThName th_name = do
+ mb_name <- lookupThName_maybe th_name
+ case mb_name of
+ Nothing -> failWithTc (notInScope th_name)
+ Just name -> return name
+
+lookupThName_maybe th_name
+ = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+ -- Pick the first that works
+ -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
+ ; return (listToMaybe names) }
where
lookup rdr_name
= do { -- Repeat much of lookupOccRn, becase we want
| otherwise -- Unqual, Qual
-> lookupSrcOcc_maybe rdr_name }
- -- 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
-
tcLookupTh :: Name -> TcM TcTyThing
-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
-- it gives a reify-related error message on failure, whereas in the normal
import RdrName ( RdrName )
import TcRnTypes( TcM, TcId )
import TcType ( BoxyRhoType )
+import Annotations ( Annotation, CoreAnnTarget )
+import qualified Language.Haskell.TH as TH
tcSpliceExpr :: HsSplice Name
-> BoxyRhoType
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+
runQuasiQuoteExpr :: HsQuasiQuote Name.Name -> TcM (LHsExpr RdrName)
runQuasiQuotePat :: HsQuasiQuote Name -> TcM (LPat RdrName)
+runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation
\end{code}
import Data.Word
import Data.IORef
import Data.Char ( ord, chr )
+import Data.Typeable
import Control.Monad ( when )
import System.IO as IO
import System.IO.Unsafe ( unsafeInterleaveIO )
get bh = do i <- get bh; return (BinPtr i)
-- -----------------------------------------------------------------------------
+-- Instances for Data.Typeable stuff
+
+instance Binary TyCon where
+ put_ bh ty_con = do
+ let s = tyConString ty_con
+ put_ bh s
+ get bh = do
+ s <- get bh
+ return (mkTyCon s)
+
+instance Binary TypeRep where
+ put_ bh type_rep = do
+ let (ty_con, child_type_reps) = splitTyConApp type_rep
+ put_ bh ty_con
+ put_ bh child_type_reps
+ get bh = do
+ ty_con <- get bh
+ child_type_reps <- get bh
+ return (mkTyConApp ty_con child_type_reps)
+
+-- -----------------------------------------------------------------------------
-- Lazy reading/writing
lazyPut :: Binary a => BinHandle -> a -> IO ()
--
-- The IO Monad with an environment
--
+{-# LANGUAGE UndecidableInstances #-}
module IOEnv (
IOEnv, -- Instance of Monad
import Data.Typeable
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO ( fixIO )
+import Control.Monad
import MonadUtils
----------------------------------------------------------------------
----------------------------------------------------------------------
+-- MonadPlus
+----------------------------------------------------------------------
+
+-- For use if the user has imported Control.Monad.Error from MTL
+-- Requires UndecidableInstances
+instance MonadPlus IO => MonadPlus (IOEnv env) where
+ mzero = IOEnv (const mzero)
+ m `mplus` n = IOEnv (\env -> unIOEnv m env `mplus` unIOEnv n env)
+
+----------------------------------------------------------------------
-- Accessing input/output
----------------------------------------------------------------------
, MonadFix(..)
, MonadIO(..)
+ , liftIO1, liftIO2, liftIO3, liftIO4
+
, mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M
, mapAccumLM
, mapSndM
, concatMapM
+ , mapMaybeM
, anyM, allM
, foldlM, foldrM
) where
-- Imports
----------------------------------------------------------------------------------------
+import Maybes
+
#if HAVE_APPLICATIVE
import Control.Applicative
#endif
#endif
----------------------------------------------------------------------------------------
+-- Lift combinators
+-- These are used throughout the compiler
+----------------------------------------------------------------------------------------
+
+-- | Lift an 'IO' operation with 1 argument into another monad
+liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
+liftIO1 = (.) liftIO
+
+-- | Lift an 'IO' operation with 2 arguments into another monad
+liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c
+liftIO2 = ((.).(.)) liftIO
+
+-- | Lift an 'IO' operation with 3 arguments into another monad
+liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d
+liftIO3 = ((.).((.).(.))) liftIO
+
+-- | Lift an 'IO' operation with 4 arguments into another monad
+liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e
+liftIO4 = (((.).(.)).((.).(.))) liftIO
+
+----------------------------------------------------------------------------------------
-- Common functions
--- These are used throught the compiler
+-- These are used throughout the compiler
----------------------------------------------------------------------------------------
-- | mapAndUnzipM for triples
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs)
+-- | Monadic version of mapMaybe
+mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
+mapMaybeM f = liftM catMaybes . mapM f
+
-- | Monadic version of 'any', aborts the computation at the first @True@ value
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
-- | Monadic version of foldr
foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a
foldrM _ z [] = return z
-foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
+foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
\ No newline at end of file
printSDoc, printErrs, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
- showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
+ showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showPpr,
showSDocUnqual, showsPrecSDoc,
pprInfixVar, pprPrefixVar,
showSDocDebug :: SDoc -> String
showSDocDebug d = show (d PprDebug)
+
+showPpr :: Outputable a => a -> String
+showPpr = showSDoc . ppr
\end{code}
\begin{code}
--- /dev/null
+--
+-- (c) The University of Glasgow 2002-2006
+--
+-- Serialized values
+
+{-# LANGUAGE ScopedTypeVariables #-}
+module Serialized (
+ -- * Main Serialized data type
+ Serialized,
+ seqSerialized,
+
+ -- * Going into and out of 'Serialized'
+ toSerialized, fromSerialized,
+
+ -- * Handy serialization functions
+ serializeWithData, deserializeWithData,
+ ) where
+
+import Binary
+import Outputable
+import FastString
+import Util
+
+import Data.Bits
+import Data.Word ( Word8 )
+
+#if __GLASGOW_HASKELL__ > 609
+import Data.Data
+#else
+import Data.Generics
+#endif
+import Data.Typeable
+
+
+-- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
+data Serialized = Serialized TypeRep [Word8]
+
+instance Outputable Serialized where
+ ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type)
+
+instance Binary Serialized where
+ put_ bh (Serialized the_type bytes) = do
+ put_ bh the_type
+ put_ bh bytes
+ get bh = do
+ the_type <- get bh
+ bytes <- get bh
+ return (Serialized the_type bytes)
+
+-- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
+toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized
+toSerialized serialize what = Serialized (typeOf what) (serialize what)
+
+-- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
+-- Otherwise return @Nothing@.
+fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
+fromSerialized deserialize (Serialized the_type bytes)
+ | the_type == typeOf (undefined :: a) = Just (deserialize bytes)
+ | otherwise = Nothing
+
+-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
+seqSerialized :: Serialized -> ()
+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
+
+
+-- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
+serializeWithData :: Data a => a -> [Word8]
+serializeWithData what = serializeWithData' what []
+
+serializeWithData' :: Data a => a -> [Word8] -> [Word8]
+serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
+ (\x -> (serializeConstr (constrRep (toConstr what)), x))
+ what
+
+-- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
+deserializeWithData :: Data a => [Word8] -> a
+deserializeWithData = snd . deserializeWithData'
+
+deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
+deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
+ gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
+ (\x -> (bytes, x))
+ (repConstr (dataTypeOf (undefined :: a)) constr_rep)
+
+
+serializeConstr :: ConstrRep -> [Word8] -> [Word8]
+serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix
+serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i
+serializeConstr (FloatConstr d) = serializeWord8 3 . serializeDouble d
+serializeConstr (StringConstr s) = serializeWord8 4 . serializeString s
+
+deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
+deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
+ case constr_ix of
+ 1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix)
+ 2 -> deserializeInteger bytes $ \i -> k (IntConstr i)
+ 3 -> deserializeDouble bytes $ \d -> k (FloatConstr d)
+ 4 -> deserializeString bytes $ \s -> k (StringConstr s)
+ x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
+
+
+serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8]
+serializeFixedWidthNum what = go (bitSize what) what
+ where
+ go :: Int -> a -> [Word8] -> [Word8]
+ go size current rest
+ | size <= 0 = rest
+ | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
+
+deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b
+deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k
+ where
+ go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
+ go size bytes k
+ | size <= 0 = k 0 bytes
+ | otherwise = case bytes of
+ (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
+ [] -> error "deserializeFixedWidthNum: unexpected end of stream"
+
+
+serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
+serializeEnum = serializeInt . fromEnum
+
+deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
+deserializeEnum bytes k = deserializeInt bytes (k . toEnum)
+
+
+serializeWord8 :: Word8 -> [Word8] -> [Word8]
+serializeWord8 x = (x:)
+
+deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
+deserializeWord8 (byte:bytes) k = k byte bytes
+deserializeWord8 [] _ = error "deserializeWord8: unexpected end of stream"
+
+
+serializeInt :: Int -> [Word8] -> [Word8]
+serializeInt = serializeFixedWidthNum
+
+deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
+deserializeInt = deserializeFixedWidthNum
+
+
+serializeDouble :: Double -> [Word8] -> [Word8]
+serializeDouble = serializeString . show
+
+deserializeDouble :: [Word8] -> (Double -> [Word8] -> a) -> a
+deserializeDouble bytes k = deserializeString bytes (k . read)
+
+
+serializeInteger :: Integer -> [Word8] -> [Word8]
+serializeInteger = serializeString . show
+
+deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
+deserializeInteger bytes k = deserializeString bytes (k . read)
+
+
+serializeString :: String -> [Word8] -> [Word8]
+serializeString = serializeList serializeEnum
+
+deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
+deserializeString = deserializeList deserializeEnum
+
+
+serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
+serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)
+
+deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
+ -> [Word8] -> ([a] -> [Word8] -> b) -> b
+deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
+ where
+ go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
+ go len bytes k
+ | len <= 0 = k [] bytes
+ | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
\ No newline at end of file
import VectType
import VectCore
-import DynFlags
import HscTypes hiding ( MonadThings(..) )
import Module ( PackageId )
-import CoreLint ( showPass, endPass )
import CoreSyn
import CoreUtils
import CoreFVs
-import SimplMonad ( SimplCount, zeroSimplCount )
-import Rules ( RuleBase )
+import CoreMonad ( CoreM, getHscEnv, liftIO )
import DataCon
import TyCon
import Type
import Control.Monad ( liftM, liftM2, zipWithM )
import Data.List ( sortBy, unzip4 )
-vectorise :: PackageId -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
- -> IO (SimplCount, ModGuts)
-vectorise backend hsc_env _ _ guts
+vectorise :: PackageId -> ModGuts -> CoreM ModGuts
+vectorise backend guts = do
+ hsc_env <- getHscEnv
+ liftIO $ vectoriseIO backend hsc_env guts
+
+vectoriseIO :: PackageId -> HscEnv -> ModGuts -> IO ModGuts
+vectoriseIO backend hsc_env guts
= do
- showPass dflags "Vectorisation"
eps <- hscEPS hsc_env
let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps
Just (info', guts') <- initV backend hsc_env guts info (vectModule guts)
- endPass dflags "Vectorisation" Opt_D_dump_vect (mg_binds guts')
- return (zeroSimplCount dflags, guts' { mg_vect_info = info' })
- where
- dflags = hsc_dflags hsc_env
+ return (guts' { mg_vect_info = info' })
vectModule :: ModGuts -> VM ModGuts
vectModule guts
</sect3>
</sect2>
+ <sect2 id="annotation-pragmas">
+ <title>ANN pragmas</title>
+
+ <para>GHC offers the ability to annotate various code constructs with additional
+ data by using three pragmas. This data can then be inspected at a later date by
+ using GHC-as-a-library.</para>
+
+ <sect3 id="ann-pragma">
+ <title>Annotating values</title>
+
+ <indexterm><primary>ANN</primary></indexterm>
+
+ <para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value
+ binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal>
+ to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>).
+ By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal>
+ you would do this:</para>
+
+<programlisting>
+{-# ANN foo (Just "Hello") #-}
+foo = ...
+</programlisting>
+
+ <para>
+ A number of restrictions apply to use of annotations:
+ <itemizedlist>
+ <listitem><para>The binder being annotated must be at the top level (i.e. no nested binders)</para></listitem>
+ <listitem><para>The binder being annotated must be declared in the current module</para></listitem>
+ <listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem>
+ <listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the
+ expression being annotated with, so for example you cannot run a function from the module being compiled.</para>
+
+ <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be
+ (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem>
+ </itemizedlist>
+
+ If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC">
+ please give the GHC team a shout</ulink>.
+ </para>
+
+ <para>However, apart from these restrictions, many things are allowed, including expressions which not fully evaluated!
+ Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para>
+
+<programlisting>
+{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-}
+f = ...
+</programlisting>
+ </sect3>
+
+ <sect3 id="typeann-pragma">
+ <title>Annotating types</title>
+
+ <indexterm><primary>ANN type</primary></indexterm>
+ <indexterm><primary>ANN</primary></indexterm>
+
+ <para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para>
+
+<programlisting>
+{-# ANN type Foo (Just "A `Maybe String' annotation") #-}
+data Foo = ...
+</programlisting>
+ </sect3>
+
+ <sect3 id="modann-pragma">
+ <title>Annotating modules</title>
+
+ <indexterm><primary>ANN module</primary></indexterm>
+ <indexterm><primary>ANN</primary></indexterm>
+
+ <para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para>
+
+<programlisting>
+{-# ANN module (Just "A `Maybe String' annotation") #-}
+</programlisting>
+ </sect3>
+ </sect2>
+
<sect2 id="line-pragma">
<title>LINE pragma</title>
projects / ghc-hetmet.git / commitdiff