diff options
52 files changed, 1644 insertions, 391 deletions
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 45baa67125..8387146f17 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -63,7 +63,8 @@ deSugar hsc_env tcg_fix_env = fix_env, tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, - tcg_warns = warns, + tcg_warns = warns, + tcg_anns = anns, tcg_binds = binds, tcg_fords = fords, tcg_rules = rules, @@ -133,6 +134,7 @@ deSugar hsc_env mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_warns = warns, + mg_anns = anns, mg_types = type_env, mg_insts = insts, mg_fam_insts = fam_insts, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ae7d05c6dc..3cd35d2128 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -273,6 +273,7 @@ Library LoadIface MkIface TcIface + Annotations BreakArray CmdLineParser CodeOutput @@ -326,6 +327,7 @@ Library RnPat RnSource RnTypes + CoreMonad CSE FloatIn FloatOut @@ -355,6 +357,7 @@ Library WwLib FamInst Inst + TcAnnotations TcArrows TcBinds TcClassDcl @@ -416,6 +419,7 @@ Library Outputable Panic Pretty + Serialized State StringBuffer Unicode diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 4a35fda355..f3401f214f 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -14,7 +14,7 @@ This module converts Template Haskell syntax into HsSyn -- for details module Convert( convertToHsExpr, convertToPat, convertToHsDecls, - convertToHsType, thRdrName ) where + convertToHsType, thRdrNameGuesses ) where import HsSyn as Hs import qualified Class @@ -619,7 +619,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName _ occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) +thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) @@ -627,6 +627,21 @@ thRdrName ctxt_ns occ TH.NameS | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ) +thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName +thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) + +thRdrNameGuesses :: TH.Name -> [RdrName] +thRdrNameGuesses (TH.Name occ flavour) + -- This special case for NameG ensures that we don't generate duplicates in the output list + | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod] + | otherwise = [ thRdrName gns occ_str flavour + | gns <- guessed_nss] + where + -- guessed_ns are the name spaces guessed from looking at the TH name + guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName] + | otherwise = [OccName.varName, OccName.tvName] + occ_str = TH.occString occ + isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name -- Built in syntax isn't "in scope" so an Unqual RdrName won't do -- We must generate an Exact name, just as the parser does diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index f559d4b395..644050e6b2 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -47,10 +47,13 @@ module HsDecls ( DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations WarnDecl(..), LWarnDecl, + -- ** Annotations + AnnDecl(..), LAnnDecl, + AnnProvenance(..), annProvenanceName_maybe, modifyAnnProvenanceNameM, -- * Grouping - HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, -) where + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups + ) where -- friends: import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) @@ -72,6 +75,7 @@ import Util import SrcLoc import FastString +import Control.Monad ( liftM ) import Data.Maybe ( isJust ) \end{code} @@ -94,6 +98,7 @@ data HsDecl id | DefD (DefaultDecl id) | ForD (ForeignDecl id) | WarningD (WarnDecl id) + | AnnD (AnnDecl id) | RuleD (RuleDecl id) | SpliceD (SpliceDecl id) | DocD (DocDecl id) @@ -128,6 +133,7 @@ data HsGroup id hs_defds :: [LDefaultDecl id], hs_fords :: [LForeignDecl id], hs_warnds :: [LWarnDecl id], + hs_annds :: [LAnnDecl id], hs_ruleds :: [LRuleDecl id], hs_docs :: [LDocDecl id] @@ -138,8 +144,8 @@ emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], - hs_fixds = [], hs_defds = [], hs_fords = [], - hs_warnds = [], hs_ruleds = [], + hs_fixds = [], hs_defds = [], hs_annds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_valds = error "emptyGroup hs_valds: Can't happen", hs_docs = [] } @@ -152,6 +158,7 @@ appendGroups hs_derivds = derivds1, hs_fixds = fixds1, hs_defds = defds1, + hs_annds = annds1, hs_fords = fords1, hs_warnds = warnds1, hs_ruleds = rulds1, @@ -163,6 +170,7 @@ appendGroups hs_derivds = derivds2, hs_fixds = fixds2, hs_defds = defds2, + hs_annds = annds2, hs_fords = fords2, hs_warnds = warnds2, hs_ruleds = rulds2, @@ -173,7 +181,8 @@ appendGroups hs_tyclds = tyclds1 ++ tyclds2, hs_instds = instds1 ++ instds2, hs_derivds = derivds1 ++ derivds2, - hs_fixds = fixds1 ++ fixds2, + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, hs_defds = defds1 ++ defds2, hs_fords = fords1 ++ fords2, hs_warnds = warnds1 ++ warnds2, @@ -192,6 +201,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ppr (SigD sd) = ppr sd ppr (RuleD rd) = ppr rd ppr (WarningD wd) = ppr wd + ppr (AnnD ad) = ppr ad ppr (SpliceD dd) = ppr dd ppr (DocD doc) = ppr doc @@ -202,11 +212,13 @@ instance OutputableBndr name => Outputable (HsGroup name) where hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_warnds = deprec_decls, + hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls }) = vcat [ppr_ds fix_decls, ppr_ds default_decls, - ppr_ds deprec_decls, ppr_ds rule_decls, + ppr_ds deprec_decls, ppr_ds ann_decls, + ppr_ds rule_decls, ppr val_decls, ppr_ds tycl_decls, ppr_ds inst_decls, ppr_ds deriv_decls, @@ -1034,3 +1046,42 @@ instance OutputableBndr name => Outputable (WarnDecl name) where ppr (Warning thing txt) = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} + +%************************************************************************ +%* * +\subsection[AnnDecl]{Annotations} +%* * +%************************************************************************ + +\begin{code} +type LAnnDecl name = Located (AnnDecl name) + +data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name)) + +instance (OutputableBndr name) => Outputable (AnnDecl name) where + ppr (HsAnnotation provenance expr) + = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + + +data AnnProvenance name = ValueAnnProvenance name + | TypeAnnProvenance name + | ModuleAnnProvenance + +annProvenanceName_maybe :: AnnProvenance name -> Maybe name +annProvenanceName_maybe (ValueAnnProvenance name) = Just name +annProvenanceName_maybe (TypeAnnProvenance name) = Just name +annProvenanceName_maybe ModuleAnnProvenance = Nothing + +-- TODO: Replace with Traversable instance when GHC bootstrap version rises high enough +modifyAnnProvenanceNameM :: Monad m => (before -> m after) -> AnnProvenance before -> m (AnnProvenance after) +modifyAnnProvenanceNameM fm prov = + case prov of + ValueAnnProvenance name -> liftM ValueAnnProvenance (fm name) + TypeAnnProvenance name -> liftM TypeAnnProvenance (fm name) + ModuleAnnProvenance -> return ModuleAnnProvenance + +pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc +pprAnnProvenance ModuleAnnProvenance = ptext (sLit "ANN module") +pprAnnProvenance (ValueAnnProvenance name) = ptext (sLit "ANN") <+> ppr name +pprAnnProvenance (TypeAnnProvenance name) = ptext (sLit "ANN type") <+> ppr name +\end{code} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 58c837376a..9926b95d24 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -18,6 +18,7 @@ import IfaceEnv import HscTypes import BasicTypes import NewDemand +import Annotations import IfaceSyn import Module import Name @@ -373,6 +374,7 @@ instance Binary ModIface where mi_exp_hash = exp_hash, mi_fixities = fixities, mi_warns = warns, + mi_anns = anns, mi_decls = decls, mi_insts = insts, mi_fam_insts = fam_insts, @@ -392,6 +394,7 @@ instance Binary ModIface where put_ bh exp_hash put_ bh fixities lazyPut bh warns + lazyPut bh anns put_ bh decls put_ bh insts put_ bh fam_insts @@ -413,6 +416,7 @@ instance Binary ModIface where exp_hash <- get bh fixities <- {-# SCC "bin_fixities" #-} get bh warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh insts <- {-# SCC "bin_insts" #-} get bh fam_insts <- {-# SCC "bin_fam_insts" #-} get bh @@ -431,6 +435,7 @@ instance Binary ModIface where mi_usages = usages, mi_exports = exports, mi_exp_hash = exp_hash, + mi_anns = anns, mi_fixities = fixities, mi_warns = warns, mi_decls = decls, @@ -1346,6 +1351,30 @@ instance Binary IfaceRule where a7 <- get bh return (IfaceRule a1 a2 a3 a4 a5 a6 a7) +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> do a <- get bh + return (NamedTarget a) + _ -> do a <- get bh + return (ModuleTarget a) + instance Binary IfaceVectInfo where put_ bh (IfaceVectInfo a1 a2 a3) = do put_ bh a1 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index c33d1f5ee6..7ef13a37e1 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -10,7 +10,8 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), - IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), -- Misc ifaceDeclSubBndrs, visibleIfConDecls, @@ -27,12 +28,14 @@ module IfaceSyn ( import IfaceType import NewDemand +import Annotations import Class import NameSet import Name import CostCentre import Literal import ForeignCall +import Serialized import BasicTypes import Outputable import FastString @@ -163,6 +166,14 @@ data IfaceRule ifRuleOrph :: Maybe OccName -- Just like IfaceInst } +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: Serialized + } + +type IfaceAnnTarget = AnnTarget OccName + data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 50fa933582..8cd88efa5d 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -8,7 +8,7 @@ Loading interface files \begin{code} module LoadIface ( loadInterface, loadInterfaceForName, loadWiredInHomeIface, - loadSrcInterface, loadSysInterface, loadOrphanModules, + loadSrcInterface, loadSysInterface, loadUserInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, @@ -19,7 +19,7 @@ module LoadIface ( #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst, tcIfaceVectInfo ) + tcIfaceFamInst, tcIfaceVectInfo, tcIfaceAnnotations ) import DynFlags import IfaceSyn @@ -34,6 +34,7 @@ import PrelNames import PrelInfo import PrelRules import Rules +import Annotations import InstEnv import FamInstEnv import Name @@ -134,10 +135,19 @@ loadWiredInHomeIface name where doc = ptext (sLit "Need home interface for wired-in thing") <+> ppr name --- | A wrapper for 'loadInterface' that throws an exception if it fails +-- | Loads a system interface and throws an exception if it fails loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -loadSysInterface doc mod_name - = do { mb_iface <- loadInterface doc mod_name ImportBySystem +loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem + +-- | Loads a user interface and throws an exception if it fails. The first parameter indicates +-- whether we should import the boot variant of the module +loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface is_boot doc mod_name = loadInterfaceWithException doc mod_name (ImportByUser is_boot) + +-- | A wrapper for 'loadInterface' that throws an exception if it fails +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException doc mod_name where_from + = do { mb_iface <- loadInterface doc mod_name where_from ; case mb_iface of Failed err -> ghcError (ProgramError (showSDoc err)) Succeeded iface -> return iface } @@ -232,14 +242,15 @@ loadInterface doc_str mod from ; return (Failed err) } ; -- Found and parsed! - Succeeded (iface, file_path) -- Sanity check: - | ImportBySystem <- from, -- system-importing... - modulePackageId (mi_module iface) == thisPackage dflags, - -- a home-package module... - Nothing <- mb_dep -- that we know nothing about - -> return (Failed (badDepMsg mod)) - - | otherwise -> + -- We used to have a sanity check here that looked for: + -- * System importing .. + -- * a home package module .. + -- * that we know nothing about (mb_dep == Nothing)! + -- + -- But this is no longer valid because thNameToGhcName allows users to + -- cause the system to load arbitrary interfaces (by supplying an appropriate + -- Template Haskell original-name). + Succeeded (iface, file_path) -> let loc_doc = text file_path @@ -267,6 +278,7 @@ loadInterface doc_str mod from ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) (mi_vect_info iface) @@ -274,7 +286,8 @@ loadInterface doc_str mod from mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", mi_fam_insts = panic "No mi_fam_insts in PIT", - mi_rules = panic "No mi_rules in PIT" + mi_rules = panic "No mi_rules in PIT", + mi_anns = panic "No mi_anns in PIT" } } @@ -290,6 +303,8 @@ loadInterface doc_str mod from new_eps_fam_insts, eps_vect_info = plusVectInfo (eps_vect_info eps) new_eps_vect_info, + eps_ann_env = extendAnnEnvList (eps_ann_env eps) + new_eps_anns, eps_mod_fam_inst_env = let fam_inst_env = @@ -307,11 +322,16 @@ loadInterface doc_str mod from ; return (Succeeded final_iface) }}}} +{- +Used to be used for the loadInterface sanity check on system imports. That has been removed, but I'm leaving this in pending +review of this decision by SPJ - MCB 10/2008 + badDepMsg :: Module -> SDoc badDepMsg mod = hang (ptext (sLit "Interface file inconsistency:")) 2 (sep [ptext (sLit "home-package module") <+> quotes (ppr mod) <+> ptext (sLit "is needed,"), ptext (sLit "but is not listed in the dependencies of the interfaces directly imported by the module being compiled")]) +-} ----------------------------------------------------- -- Loading type/class/value decls @@ -481,6 +501,9 @@ findAndReadIface doc_str mod hi_boot_file -- Found file, so read it { let { file_path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) } + -- If the interface is in the current package then if we could + -- load it would already be in the HPT and we assume that our + -- callers checked that. ; if thisPackage dflags == modulePackageId mod && not (isOneShot (ghcMode dflags)) then return (Failed (homeModError mod loc)) @@ -550,6 +573,7 @@ initExternalPackageState eps_mod_fam_inst_env = emptyModuleEnv, eps_vect_info = noVectInfo, + eps_ann_env = emptyAnnEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 , n_rules_in = length builtinRules, n_rules_out = 0 } @@ -636,6 +660,7 @@ pprModIface iface , vcat (map pprExport (mi_exports iface)) , pprDeps (mi_deps iface) , vcat (map pprUsage (mi_usages iface)) + , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) , vcat (map pprIfaceDecl (mi_decls iface)) , vcat (map ppr (mi_insts iface)) @@ -724,6 +749,10 @@ pprWarns (WarnAll txt) = ptext (sLit "Warn all") <+> ppr txt pprWarns (WarnSome prs) = ptext (sLit "Warnings") <+> vcat (map pprWarning prs) where pprWarning (name, txt) = ppr name <+> ppr txt + +pprIfaceAnnotation :: IfaceAnnotation -> SDoc +pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) + = ppr target <+> ptext (sLit "annotated by") <+> ppr serialized \end{code} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 7edf0a62a3..285f17197d 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -56,6 +56,7 @@ import LoadIface import Id import IdInfo import NewDemand +import Annotations import CoreSyn import CoreFVs import Class @@ -220,6 +221,7 @@ mkIface_ hsc_env maybe_old_fingerprint ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, + md_anns = anns, md_vect_info = vect_info, md_types = type_env, md_exports = exports } @@ -265,6 +267,7 @@ mkIface_ hsc_env maybe_old_fingerprint mi_fixities = fixities, mi_warns = warns, + mi_anns = mkIfaceAnnotations anns, mi_globals = Just rdr_env, -- Left out deliberately: filled in by addVersionInfo @@ -905,6 +908,17 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names \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 diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 42dd3a8ac2..7f74cf2cd2 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -9,7 +9,7 @@ Type checking of type signatures in interface files module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, - tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings + tcIfaceVectInfo, tcIfaceAnnotations, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" @@ -22,6 +22,7 @@ import TcRnMonad import Type import TypeRep import HscTypes +import Annotations import InstEnv import FamInstEnv import CoreSyn @@ -201,10 +202,11 @@ typecheckIface iface ; let type_env = mkNameEnv names_w_things ; writeMutVar tc_env_var type_env - -- Now do those rules and instances + -- Now do those rules, instances and annotations ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env @@ -220,6 +222,7 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules + , md_anns = anns , md_vect_info = vect_info , md_exports = exports } @@ -614,6 +617,34 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd %************************************************************************ %* * + 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 %* * %************************************************************************ diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index 51ab25592e..c8ad717918 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -1,6 +1,6 @@ \begin{code} module TcIface where -import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule ) +import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) import TypeRep ( TyThing ) import TcRnTypes ( IfL ) import InstEnv ( Instance ) @@ -8,11 +8,13 @@ import FamInstEnv ( FamInst ) import CoreSyn ( CoreRule ) import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) import Module ( Module ) +import Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} diff --git a/compiler/main/Annotations.lhs b/compiler/main/Annotations.lhs new file mode 100644 index 0000000000..4cb7785d48 --- /dev/null +++ b/compiler/main/Annotations.lhs @@ -0,0 +1,92 @@ +% +% (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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1ee8d7392f..df9efcbde2 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -91,6 +91,7 @@ import Data.IORef ( readIORef ) import Control.Monad ( when ) import Data.Char +import Data.List ( intersperse ) import System.FilePath import System.IO ( stderr, hPutChar ) @@ -908,18 +909,44 @@ data CoreToDo -- These are diff core-to-core passes, | 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: @@ -1017,7 +1044,7 @@ getCoreToDo dflags -- so that overloaded functions have all their dictionary lambdas manifest CoreDoSpecialising, - runWhen full_laziness (CoreDoFloatOutwards (FloatOutSw False False)), + runWhen full_laziness (CoreDoFloatOutwards gentleFloatOutSwitches), CoreDoFloatInwards, @@ -1047,8 +1074,7 @@ getCoreToDo dflags ]), 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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0d2cca1ec4..e8ea87c6b3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -74,6 +74,7 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + findGlobalAnns, mkPrintUnqualifiedForModule, -- * Printing @@ -278,6 +279,7 @@ import StaticFlagParser import qualified StaticFlags import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) +import Annotations import Module import LazyUniqFM import UniqSet @@ -304,6 +306,8 @@ import System.Directory ( getModificationTime, doesFileExist, 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 ) @@ -1173,6 +1177,7 @@ mkModGuts coreModule = ModGuts { 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, @@ -2412,6 +2417,11 @@ lookupGlobalName name = withSession $ \hsc_env -> do 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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 50c92d3e3a..086f6e895a 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -1050,4 +1050,3 @@ showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " i_str = show i padded = replicate (length n_str - length i_str) ' ' ++ i_str \end{code} - diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 059fe9c698..03bcca5e1e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -45,6 +45,10 @@ module HscTypes ( PackageInstEnv, PackageRuleBase, + + -- * Annotations + prepareAnnotations, + -- * Interactive context InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, @@ -121,6 +125,7 @@ import Var import Id import Type +import Annotations import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) @@ -623,6 +628,12 @@ hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -- ^ 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)) @@ -657,7 +668,32 @@ hptSomeThingsBelowUs extract include_hi_boot hsc_env deps -- 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} %************************************************************************ @@ -760,6 +796,11 @@ data ModIface -- 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) @@ -818,6 +859,8 @@ data ModDetails 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 } @@ -827,6 +870,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], + md_anns = [], md_vect_info = noVectInfo } @@ -865,6 +909,7 @@ data ModGuts 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 @@ -978,6 +1023,7 @@ emptyModIface mod mi_exp_hash = fingerprint0, mi_fixities = [], mi_warns = NoWarnings, + mi_anns = [], mi_insts = [], mi_fam_insts = [], mi_rules = [], @@ -1608,6 +1654,7 @@ type PackageRuleBase = RuleBase 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 @@ -1659,6 +1706,8 @@ data ExternalPackageState -- 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 diff --git a/compiler/main/HscTypes.lhs-boot b/compiler/main/HscTypes.lhs-boot deleted file mode 100644 index c80d2313cd..0000000000 --- a/compiler/main/HscTypes.lhs-boot +++ /dev/null @@ -1,3 +0,0 @@ -> module HscTypes where -> -> data Session
\ No newline at end of file diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 01d47e6214..16f389bf14 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -142,6 +142,7 @@ mkBootModDetails hsc_env exports type_env insts fam_insts , md_insts = insts' , md_fam_insts = fam_insts , md_rules = [] + , md_anns = [] , md_exports = exports , md_vect_info = noVectInfo }) @@ -260,6 +261,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, 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, @@ -326,7 +328,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, 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 -- }) } diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index c813e36145..0dd36ff050 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -261,6 +261,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } { 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. @@ -490,6 +491,7 @@ data Token | ITgenerated_prag | ITcore_prag -- hdaume: core annotations | ITunpack_prag + | ITann_prag | ITclose_prag | IToptions_prag String | ITinclude_prag String diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 2f1166d420..d9df620de9 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -264,6 +264,7 @@ incorrect. '{-# DEPRECATED' { L _ ITdeprecated_prag } '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@ -561,6 +562,7 @@ topdecl :: { OrdList (LHsDecl RdrName) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | annotation { unitOL $1 } | decl { unLoc $1 } -- Template Haskell Extension @@ -926,6 +928,13 @@ deprecation :: { OrdList (LHsDecl RdrName) } { 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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index e875bf5bf5..ccf9756073 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -349,6 +349,8 @@ add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds = 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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 2258682e5b..21dd848744 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -203,6 +203,9 @@ basicKnownKeyNames -- Other classes randomClassName, randomGenClassName, monadPlusClassName, + -- Annotation type checking + toAnnotationWrapperName, + -- Booleans andName, orName @@ -781,6 +784,10 @@ appAName = varQual aRROW (fsLit "app") appAIdKey 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 @@ -1249,6 +1256,10 @@ loopAIdKey = mkPreludeMiscIdUnique 124 fromStringClassOpKey :: Unique fromStringClassOpKey = mkPreludeMiscIdUnique 125 +-- Annotation type checking +toAnnotationWrapperIdKey :: Unique +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 126 + ---------------- Template Haskell ------------------- -- USES IdUniques 200-399 ----------------------------------------------------- diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 521d71541c..f49e299648 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -22,8 +22,8 @@ import RnHsSyn 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, @@ -102,6 +102,7 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, 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, @@ -180,8 +181,9 @@ rnSrcDecls group@(HsGroup {hs_valds = val_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 ; @@ -194,12 +196,13 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, 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 @@ -338,7 +341,26 @@ dupWarnDecl (L loc _) rdr_name %********************************************************* %* * -\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} %* * %********************************************************* diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 1386197eba..8b5825bf6a 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -10,14 +10,12 @@ module CSE ( #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 ) @@ -178,14 +176,8 @@ happen now that we don't look inside INLINEs (which wrappers are). %************************************************************************ \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 _ [] = [] diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs new file mode 100644 index 0000000000..f480eb3ce7 --- /dev/null +++ b/compiler/simplCore/CoreMonad.lhs @@ -0,0 +1,341 @@ +% +% (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} diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 8dbec27bf5..1146c77031 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -16,10 +16,8 @@ module FloatIn ( floatInwards ) where #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 @@ -34,16 +32,8 @@ Top-level interface function, @floatInwards@. Note that we do not 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)) diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index f1b190316b..6562c84e8c 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -16,7 +16,6 @@ import ErrUtils ( dumpIfSet_dyn ) 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 ) @@ -116,8 +115,6 @@ floatOutwards :: FloatOutSwitches 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) } ; @@ -132,15 +129,8 @@ floatOutwards float_sws dflags us pgm 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 diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index 9fe6b87481..4b1055bbed 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -9,13 +9,8 @@ module LiberateCase ( liberateCase ) where #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 ) @@ -122,17 +117,8 @@ and the level of @h@ is zero (NB not one). %************************************************************************ \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 diff --git a/compiler/simplCore/SAT.lhs b/compiler/simplCore/SAT.lhs index 329c95ca11..ca251568a7 100644 --- a/compiler/simplCore/SAT.lhs +++ b/compiler/simplCore/SAT.lhs @@ -52,10 +52,8 @@ essential to make this work well! module SAT ( doStaticArgs ) where -import DynFlags import Var import CoreSyn -import CoreLint import CoreUtils import Type import TcType @@ -78,11 +76,8 @@ import FastString \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 @@ -428,4 +423,4 @@ isStaticValue :: Staticness App -> Bool isStaticValue (Static (VarApp _)) = True isStaticValue _ = False -\end{code}
\ No newline at end of file +\end{code} diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index e20bc833c7..270ce17095 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -691,10 +691,10 @@ initialEnv :: FloatOutSwitches -> LevelEnv 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 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 5b52d2d2d7..5c3c789c79 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -22,7 +22,8 @@ import CoreSyn 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 ) @@ -34,8 +35,9 @@ import CoreUtils ( coreBindsSize ) 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 @@ -43,6 +45,7 @@ import Id import DataCon import TyCon ( tyConSelIds, tyConDataCons ) import Class ( classSelIds ) +import BasicTypes ( CompilerPhase, isActive ) import VarSet import VarEnv import NameEnv ( lookupNameEnv ) @@ -57,6 +60,7 @@ import StrictAnal ( saBinds ) import CprAnalyse ( cprAnalyse ) #endif import Vectorise ( vectorise ) +import FastString import Util import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) @@ -78,32 +82,43 @@ core2core :: HscEnv -> 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 @@ -112,14 +127,14 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do -- 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' @@ -128,93 +143,165 @@ simplifyExpr dflags 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} @@ -317,7 +404,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) 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 "", @@ -435,7 +522,7 @@ glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] -- 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... @@ -450,43 +537,46 @@ glomBinds dflags binds %************************************************************************ \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 @@ -509,7 +599,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts = 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 @@ -522,7 +612,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts ; 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 @@ -539,7 +629,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts (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 } ; @@ -560,7 +650,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts 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'' ; diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 2d95ae7d81..f2e118dd3d 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -54,7 +54,7 @@ import VarSet 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 @@ -184,6 +184,7 @@ mkSpecInfo rules = SpecInfo rules (rulesFreeVars rules) 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) @@ -807,12 +808,12 @@ This pass runs over the tree (without changing it) and reports such. \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 @@ -821,10 +822,14 @@ ruleCheckProgram phase rule_pat rule_base binds 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 @@ -853,15 +858,15 @@ ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc -- 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)] @@ -885,7 +890,7 @@ ruleAppCheck_help phase fn args 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" diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 0280255510..23127f440f 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -20,7 +20,6 @@ import CoreSyn import CoreSubst import CoreUtils import CoreUnfold ( couldBeSmallEnoughToInline ) -import CoreLint ( showPass, endPass ) import CoreFVs ( exprsFreeVars ) import WwLib ( mkWorkerArgs ) import DataCon ( dataConRepArity, dataConUnivTyVars ) @@ -33,8 +32,7 @@ import VarEnv 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(..) ) @@ -451,19 +449,8 @@ unbox the strict fields, becuase T is polymorphic!) %************************************************************************ \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 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index c4a4936f51..4d8efdd8c5 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -14,7 +14,6 @@ module Specialise ( specProgram ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..) ) import Id ( Id, idName, idType, mkUserLocal, idCoreRules, idInlinePragma, setInlinePragma, setIdUnfolding, isLocalId ) @@ -36,7 +35,6 @@ import CoreSyn import Rules import CoreUtils ( exprIsTrivial, applyTypeToArgs, mkPiTypes ) import CoreFVs ( exprFreeVars, exprsFreeVars, idFreeVars ) -import CoreLint ( showPass, endPass ) import UniqSupply ( UniqSupply, UniqSM, initUs_, MonadUnique(..) @@ -45,7 +43,6 @@ import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) -import ErrUtils ( dumpIfSet_dyn ) import Bag import Util import Outputable @@ -578,20 +575,9 @@ Hence, the invariant is this: %************************************************************************ \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 diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 2290b1cfd6..198e80bacc 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -77,11 +77,7 @@ To think about 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 diff --git a/compiler/stranal/StrictAnal.lhs b/compiler/stranal/StrictAnal.lhs index 04632053ce..a5efe30d39 100644 --- a/compiler/stranal/StrictAnal.lhs +++ b/compiler/stranal/StrictAnal.lhs @@ -95,8 +95,6 @@ strict workers. 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 }; @@ -106,8 +104,7 @@ saBinds dflags binds 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} diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index faa26feab8..438afd6cf5 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -36,7 +36,6 @@ import Unique ( hasKey ) import BasicTypes ( RecFlag(..), isNonRec, isNeverActive ) import VarEnv ( isEmptyVarEnv ) import Maybes ( orElse ) -import DynFlags import WwLib import Util ( lengthIs, notNull ) import Outputable @@ -70,30 +69,9 @@ info for exported values). \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') diff --git a/compiler/typecheck/TcAnnotations.lhs b/compiler/typecheck/TcAnnotations.lhs new file mode 100644 index 0000000000..17ebbb13ea --- /dev/null +++ b/compiler/typecheck/TcAnnotations.lhs @@ -0,0 +1,53 @@ +% +% (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 diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d0388456e7..9afe28fdba 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -204,6 +204,11 @@ tcLookupFamInst tycon tys } \end{code} +\begin{code} +instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where + lookupThing = tcLookupGlobal +\end{code} + %************************************************************************ %* * Extending the global environment @@ -522,13 +527,13 @@ tcExtendRules lcl_rules thing_inside \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 @@ -544,7 +549,7 @@ checkWellStaged pp_thing bind_lvl use_stage | 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) @@ -553,7 +558,9 @@ checkWellStaged pp_thing bind_lvl use_stage 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" diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 2eb10ef8ce..540292cbb4 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -12,7 +12,7 @@ -- 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" @@ -80,7 +80,7 @@ tcPolyExpr, tcPolyExprNC -- 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 @@ -1245,7 +1245,10 @@ checkMissingFields data_con rbinds 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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 789ffbcb83..325b9db3f3 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -45,6 +45,7 @@ import Inst import FamInst import InstEnv import FamInstEnv +import TcAnnotations import TcBinds import TcDefaults import TcEnv @@ -390,8 +391,10 @@ tcRnSrcDecls boot_iface decls -- 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 @@ -468,26 +471,32 @@ tcRnHsBootDecls decls 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 @@ -770,6 +779,7 @@ tcTopSrcDecls boot_details 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 @@ -820,6 +830,9 @@ tcTopSrcDecls boot_details traceTc (text "Tc7") ; (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + -- Annotations + annotations <- tcAnnotations annotation_decls ; + -- Rules rules <- tcRules rule_decls ; @@ -829,12 +842,13 @@ tcTopSrcDecls boot_details 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) }}}}}} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index eedf00bd4c..6df6e28128 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -102,7 +102,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this 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 = [], diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 7b4f85a2e1..c48cd8b75f 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -21,7 +21,7 @@ module TcRnTypes( TcTyThing(..), pprTcTyThingCategory, RefinementVisibility(..), -- Template Haskell - ThStage(..), topStage, topSpliceStage, + ThStage(..), topStage, topAnnStage, topSpliceStage, ThLevel, impLevel, topLevel, -- Arrows @@ -45,6 +45,7 @@ import HscTypes import Type import Coercion import TcType +import Annotations import InstEnv import FamInstEnv import IOEnv @@ -215,6 +216,7 @@ data TcGblEnv 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 @@ -373,13 +375,14 @@ impLevel = 0 -- Imported things; they can be used inside a top level splice 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 --------------------------- @@ -890,6 +893,7 @@ data InstOrigin | 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)] @@ -914,4 +918,5 @@ instance Outputable InstOrigin where 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} diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 97976a2c95..932cb68f42 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -16,6 +16,8 @@ module TcSimplify ( tcSimplifyDeriv, tcSimplifyDefault, bindInstsOfLocalFuns, + + tcSimplifyStagedExpr, misMatchMsg ) where @@ -58,6 +60,7 @@ import Util import SrcLoc import DynFlags import FastString + import Control.Monad import Data.List \end{code} @@ -3014,6 +3017,26 @@ tcSimplifyDefault theta = do 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} + %************************************************************************ %* * diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index b4cb3166e2..0ce334a5c6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -14,7 +14,8 @@ TcSplice: Template Haskell splices -- for details module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket, - runQuasiQuoteExpr, runQuasiQuotePat ) where + lookupThName_maybe, + runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where #include "HsVersions.h" @@ -41,12 +42,15 @@ import TcIface 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 @@ -55,6 +59,7 @@ import TysWiredIn import DsMeta import DsExpr import DsMonad hiding (Splice) +import Serialized import ErrUtils import SrcLoc import Outputable @@ -69,6 +74,11 @@ import qualified Language.Haskell.TH as TH -- 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} @@ -164,8 +174,11 @@ tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) 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) @@ -173,8 +186,11 @@ tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) 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} @@ -285,7 +301,7 @@ tcSpliceExpr (HsSplice name expr) res_ty 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 @@ -344,23 +360,74 @@ tcTopSplice expr res_ty = 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} @@ -420,7 +487,7 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ -- 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 @@ -456,7 +523,7 @@ kcSpliceType (HsSplice name hs_expr) 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 @@ -537,30 +604,49 @@ tcSpliceDecls expr %************************************************************************ \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 @@ -587,10 +673,10 @@ runMeta convert expr ; 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 @@ -603,7 +689,7 @@ runMeta convert expr 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] @@ -722,14 +808,17 @@ reify th_name 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 @@ -743,11 +832,6 @@ lookupThName th_name@(TH.Name occ flavour) | 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 diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index c9bab4bbfc..9b133566ea 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -6,6 +6,8 @@ import Name ( Name ) 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 @@ -17,6 +19,9 @@ tcBracket :: HsBracket Name 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} diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 80d10cba66..4f48a424b3 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -75,6 +75,7 @@ import Data.Int 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 ) @@ -565,6 +566,27 @@ instance Binary (Bin a) where 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 () diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 61345ca246..305e30eed7 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -3,6 +3,7 @@ -- -- The IO Monad with an environment -- +{-# LANGUAGE UndecidableInstances #-} module IOEnv ( IOEnv, -- Instance of Monad @@ -31,6 +32,7 @@ import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) import Data.Typeable import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( fixIO ) +import Control.Monad import MonadUtils ---------------------------------------------------------------------- @@ -132,6 +134,16 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) ---------------------------------------------------------------------- +-- 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 ---------------------------------------------------------------------- diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 85d8642313..28613a4284 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -9,10 +9,13 @@ module MonadUtils , MonadFix(..) , MonadIO(..) + , liftIO1, liftIO2, liftIO3, liftIO4 + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M , mapAccumLM , mapSndM , concatMapM + , mapMaybeM , anyM, allM , foldlM, foldrM ) where @@ -33,6 +36,8 @@ module MonadUtils -- Imports ---------------------------------------------------------------------------------------- +import Maybes + #if HAVE_APPLICATIVE import Control.Applicative #endif @@ -77,8 +82,29 @@ instance MonadIO IO where liftIO = id #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 @@ -117,6 +143,10 @@ mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } 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 @@ -136,4 +166,4 @@ foldlM = foldM -- | 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 diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 548dc2ca8b..fb0270f169 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -36,7 +36,7 @@ module Outputable ( printSDoc, printErrs, hPrintDump, printDump, printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, - showSDoc, showSDocForUser, showSDocDebug, showSDocDump, + showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showPpr, showSDocUnqual, showsPrecSDoc, pprInfixVar, pprPrefixVar, @@ -333,6 +333,9 @@ showSDocDump d = show (d PprDump) showSDocDebug :: SDoc -> String showSDocDebug d = show (d PprDebug) + +showPpr :: Outputable a => a -> String +showPpr = showSDoc . ppr \end{code} \begin{code} diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs new file mode 100644 index 0000000000..9a0e4c5d17 --- /dev/null +++ b/compiler/utils/Serialized.hs @@ -0,0 +1,174 @@ +-- +-- (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 diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 92a19d562c..cd1f429454 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -7,16 +7,13 @@ import VectUtils 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 @@ -37,18 +34,18 @@ import FastString 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 diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 78983eb06b..393cbf50ac 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -7139,6 +7139,83 @@ happen. </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> |