Add (a) CoreM monad, (b) new Annotations feature
authorsimonpj@microsoft.com <unknown>
Thu, 30 Oct 2008 12:51:08 +0000 (12:51 +0000)
committersimonpj@microsoft.com <unknown>
Thu, 30 Oct 2008 12:51:08 +0000 (12:51 +0000)
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!

52 files changed:
compiler/deSugar/Desugar.lhs
compiler/ghc.cabal.in
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsDecls.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/iface/TcIface.lhs-boot
compiler/main/Annotations.lhs [new file with mode: 0644]
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/HscTypes.lhs-boot [deleted file]
compiler/main/TidyPgm.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/rename/RnSource.lhs
compiler/simplCore/CSE.lhs
compiler/simplCore/CoreMonad.lhs [new file with mode: 0644]
compiler/simplCore/FloatIn.lhs
compiler/simplCore/FloatOut.lhs
compiler/simplCore/LiberateCase.lhs
compiler/simplCore/SAT.lhs
compiler/simplCore/SetLevels.lhs
compiler/simplCore/SimplCore.lhs
compiler/specialise/Rules.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/StrictAnal.lhs
compiler/stranal/WorkWrap.lhs
compiler/typecheck/TcAnnotations.lhs [new file with mode: 0644]
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcSplice.lhs-boot
compiler/utils/Binary.hs
compiler/utils/IOEnv.hs
compiler/utils/MonadUtils.hs
compiler/utils/Outputable.lhs
compiler/utils/Serialized.hs [new file with mode: 0644]
compiler/vectorise/Vectorise.hs
docs/users_guide/glasgow_exts.xml

index 45baa67..8387146 100644 (file)
@@ -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,
index ae7d05c..3cd35d2 100644 (file)
@@ -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
index 4a35fda..f3401f2 100644 (file)
@@ -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
index f559d4b..644050e 100644 (file)
@@ -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}
index 58c8373..9926b95 100644 (file)
@@ -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
index c33d1f5..7ef13a3 100644 (file)
@@ -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
index 50fa933..8cd88ef 100644 (file)
@@ -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}
 
 
index 7edf0a6..285f171 100644 (file)
@@ -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
index 42dd3a8..7f74cf2 100644 (file)
@@ -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
 %*                                                                     *
 %************************************************************************
index 51ab255..c8ad717 100644 (file)
@@ -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 (file)
index 0000000..4cb7785
--- /dev/null
@@ -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
index 1ee8d73..df9efcb 100644 (file)
@@ -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
index 0d2cca1..e8ea87c 100644 (file)
@@ -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
index 50c92d3..086f6e8 100644 (file)
@@ -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}
-
index 059fe9c..03bcca5 100644 (file)
@@ -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 (file)
index c80d231..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-> module HscTypes where
->
-> data Session
\ No newline at end of file
index 01d47e6..16f389b 100644 (file)
@@ -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 --
                               })
        }
 
index c813e36..0dd36ff 100644 (file)
@@ -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
index 2f1166d..d9df620 100644 (file)
@@ -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
index e875bf5..ccf9756 100644 (file)
@@ -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
 
index 2258682..21dd848 100644 (file)
@@ -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
 -----------------------------------------------------
index 521d715..f49e299 100644 (file)
@@ -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}
 %*                                                     *
 %*********************************************************
 
index 1386197..8b5825b 100644 (file)
@@ -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 (file)
index 0000000..f480eb3
--- /dev/null
@@ -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}
index 8dbec27..1146c77 100644 (file)
@@ -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))
index f1b1903..6562c84 100644 (file)
@@ -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
index 9fe6b87..4b1055b 100644 (file)
@@ -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
index 329c95c..ca25156 100644 (file)
@@ -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}
index e20bc83..270ce17 100644 (file)
@@ -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
index 5b52d2d..5c3c789 100644 (file)
@@ -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'' ;
 
index 2d95ae7..f2e118d 100644 (file)
@@ -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"
index 0280255..23127f4 100644 (file)
@@ -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
index c4a4936..4d8efdd 100644 (file)
@@ -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
index 2290b1c..198e80b 100644 (file)
@@ -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
index 0463205..a5efe30 100644 (file)
@@ -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}
 
index faa26fe..438afd6 100644 (file)
@@ -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 (file)
index 0000000..17ebbb1
--- /dev/null
@@ -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
index d038845..9afe28f 100644 (file)
@@ -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" 
index 2eb10ef..540292c 100644 (file)
@@ -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
index 789ffbc..325b9db 100644 (file)
@@ -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)
     }}}}}}
index eedf00b..6df6e28 100644 (file)
@@ -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    = [],
index 7b4f85a..c48cd8b 100644 (file)
@@ -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}
index 97976a2..932cb68 100644 (file)
@@ -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}
+
 
 %************************************************************************
 %*                                                                     *
index b4cb316..0ce334a 100644 (file)
@@ -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
index c9bab4b..9b13356 100644 (file)
@@ -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}
index 80d10cb..4f48a42 100644 (file)
@@ -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 ()
index 61345ca..305e30e 100644 (file)
@@ -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
 ----------------------------------------------------------------------
 
index 85d8642..28613a4 100644 (file)
@@ -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
index 548dc2c..fb0270f 100644 (file)
@@ -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 (file)
index 0000000..9a0e4c5
--- /dev/null
@@ -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
index 92a19d5..cd1f429 100644 (file)
@@ -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
index 78983eb..393cbf5 100644 (file)
@@ -7139,6 +7139,83 @@ happen.
       </sect3>
     </sect2>
 
+    <sect2 id="annotation-pragmas">
+      <title>ANN pragmas</title>
+      
+      <para>GHC offers the ability to annotate various code constructs with additional
+      data by using three pragmas.  This data can then be inspected at a later date by
+      using GHC-as-a-library.</para>
+            
+      <sect3 id="ann-pragma">
+        <title>Annotating values</title>
+        
+        <indexterm><primary>ANN</primary></indexterm>
+        
+        <para>Any expression that has both <literal>Typeable</literal> and <literal>Data</literal> instances may be attached to a top-level value
+        binding using an <literal>ANN</literal> pragma. In particular, this means you can use <literal>ANN</literal>
+        to annotate data constructors (e.g. <literal>Just</literal>) as well as normal values (e.g. <literal>take</literal>).
+        By way of example, to annotate the function <literal>foo</literal> with the annotation <literal>Just "Hello"</literal>
+        you would do this:</para>
+        
+<programlisting>
+{-# ANN foo (Just "Hello") #-}
+foo = ...
+</programlisting>
+        
+        <para>
+          A number of restrictions apply to use of annotations:
+          <itemizedlist>
+            <listitem><para>The binder being annotated must be at the top level (i.e. no nested binders)</para></listitem>
+            <listitem><para>The binder being annotated must be declared in the current module</para></listitem>
+            <listitem><para>The expression you are annotating with must have a type with <literal>Typeable</literal> and <literal>Data</literal> instances</para></listitem>
+            <listitem><para>The <ulink linkend="using-template-haskell">Template Haskell staging restrictions</ulink> apply to the
+            expression being annotated with, so for example you cannot run a function from the module being compiled.</para>
+            
+            <para>To be precise, the annotation <literal>{-# ANN x e #-}</literal> is well staged if and only if <literal>$(e)</literal> would be 
+            (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - <literal>$([|1|])</literal> is fine as an annotation, albeit redundant).</para></listitem>
+          </itemizedlist>
+          
+          If you feel strongly that any of these restrictions are too onerous, <ulink url="http://hackage.haskell.org/trac/ghc/wiki/MailingListsAndIRC">
+          please give the GHC team a shout</ulink>.
+        </para>
+        
+        <para>However, apart from these restrictions, many things are allowed, including expressions which not fully evaluated!
+        Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine:</para>
+        
+<programlisting>
+{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-}
+f = ...
+</programlisting>
+      </sect3>
+      
+      <sect3 id="typeann-pragma">
+        <title>Annotating types</title>
+        
+        <indexterm><primary>ANN type</primary></indexterm>
+        <indexterm><primary>ANN</primary></indexterm>
+        
+        <para>You can annotate types with the <literal>ANN</literal> pragma by using the <literal>type</literal> keyword. For example:</para>
+        
+<programlisting>
+{-# ANN type Foo (Just "A `Maybe String' annotation") #-}
+data Foo = ...
+</programlisting>
+      </sect3>
+      
+      <sect3 id="modann-pragma">
+        <title>Annotating modules</title>
+        
+        <indexterm><primary>ANN module</primary></indexterm>
+        <indexterm><primary>ANN</primary></indexterm>
+        
+        <para>You can annotate modules with the <literal>ANN</literal> pragma by using the <literal>module</literal> keyword. For example:</para>
+        
+<programlisting>
+{-# ANN module (Just "A `Maybe String' annotation") #-}
+</programlisting>
+      </sect3>
+    </sect2>
+
     <sect2 id="line-pragma">
       <title>LINE pragma</title>