diff options
| author | simonpj@microsoft.com <unknown> | 2008-10-30 12:51:08 +0000 |
|---|---|---|
| committer | simonpj@microsoft.com <unknown> | 2008-10-30 12:51:08 +0000 |
| commit | 9bcd95bad83ee937c178970e8b729732e680fe1e (patch) | |
| tree | e0cbcf15a961d05da7b12b45b9aaf0efb4672338 /compiler | |
| parent | b1f3ff48870a3a4670cb41b890b78bbfffa8a32e (diff) | |
| download | haskell-9bcd95bad83ee937c178970e8b729732e680fe1e.tar.gz | |
Add (a) CoreM monad, (b) new Annotations feature
This patch, written by Max Bolingbroke, does two things
1. It adds a new CoreM monad (defined in simplCore/CoreMonad),
which is used as the top-level monad for all the Core-to-Core
transformations (starting at SimplCore). It supports
* I/O (for debug printing)
* Unique supply
* Statistics gathering
* Access to the HscEnv, RuleBase, Annotations, Module
The patch therefore refactors the top "skin" of every Core-to-Core
pass, but does not change their functionality.
2. It adds a completely new facility to GHC: Core "annotations".
The idea is that you can say
{#- ANN foo (Just "Hello") #-}
which adds the annotation (Just "Hello") to the top level function
foo. These annotations can be looked up in any Core-to-Core pass,
and are persisted into interface files. (Hence a Core-to-Core pass
can also query the annotations of imported things.) Furthermore,
a Core-to-Core pass can add new annotations (eg strictness info)
of its own, which can be queried by importing modules.
The design of the annotation system is somewhat in flux. It's
designed to work with the (upcoming) dynamic plug-ins mechanism,
but is meanwhile independently useful.
Do not merge to 6.10!
Diffstat (limited to 'compiler')
51 files changed, 1567 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 |