liftIO1, liftIO2, liftIO3, liftIO4,
-- ** Dealing with annotations
- findAnnotations, addAnnotation,
+ findAnnotations, deserializeAnnotations, addAnnotation,
+ -- ** Debug output
+ endPass, endPassIf, endIteration,
+
-- ** Screen output
putMsg, putMsgS, errorMsg, errorMsgS,
fatalErrorMsg, fatalErrorMsgS,
#endif
) where
-import Name
+#ifdef GHCI
+import Name( Name )
+#endif
+import CoreSyn
+import PprCore
+import CoreUtils
+import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
import Module ( Module )
import TcRnMonad ( TcM, initTc )
import Outputable
+import FastString
import qualified ErrUtils as Err
-import MonadUtils
import Maybes
import UniqSupply
+import LazyUniqFM ( UniqFM )
import Data.Dynamic
import Data.IORef
import Data.Word
import Control.Monad
-import Control.Applicative
import Prelude hiding ( read )
#endif
\end{code}
-\subsection{Monad and carried data structure definitions}
+%************************************************************************
+%* *
+ Debug output
+%* *
+%************************************************************************
+
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a conveneint place. place for them. They print out
+stuff before and after core passes, and do Core Lint when necessary.
+
+\begin{code}
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endPass = dumpAndLint Err.dumpIfSet_core
+
+endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
+
+-- Same as endPass but doesn't dump Core even with -dverbose-core2core
+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
+endIteration = dumpAndLint Err.dumpIfSet_dyn
+
+dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
+ -> DynFlags -> String -> DynFlag
+ -> [CoreBind] -> [CoreRule] -> IO ()
+dumpAndLint dump dflags pass_name dump_flag binds rules
+ = do { -- Report result size if required
+ -- This has the side effect of forcing the intermediate to be evaluated
+ ; Err.debugTraceMsg dflags 2 $
+ (text " Result size =" <+> int (coreBindsSize binds))
+
+ -- Report verbosely, if required
+ ; dump dflags dump_flag pass_name
+ (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
+
+ -- Type check
+ ; lintCoreBindings dflags pass_name binds }
+ where
+ pp_rules = vcat [ blankLine
+ , ptext (sLit "------ Local rules for imported ids --------")
+ , pprRules rules ]
+\end{code}
+
+
+%************************************************************************
+%* *
+ Monad and carried data structure definitions
+%* *
+%************************************************************************
\begin{code}
data CoreState = CoreState {
\end{code}
-\subsection{Core combinators, not exported}
+
+%************************************************************************
+%* *
+ Core combinators, not exported
+%* *
+%************************************************************************
\begin{code}
\end{code}
-\subsection{Reader, writer and state accessors}
+
+%************************************************************************
+%* *
+ Reader, writer and state accessors
+%* *
+%************************************************************************
\begin{code}
\end{code}
-\subsection{Dealing with annotations}
+
+%************************************************************************
+%* *
+ Dealing with annotations
+%* *
+%************************************************************************
\begin{code}
ann_env <- getAnnEnv
return (findAnns deserialize ann_env target)
+-- | Deserialize all annotations of a given type. This happens lazily, that is
+-- no deserialization will take place until the [a] is actually demanded and
+-- the [a] can also be empty (the UniqFM is not filtered).
+deserializeAnnotations :: Typeable a => ([Word8] -> a) -> CoreM (UniqFM [a])
+deserializeAnnotations deserialize = do
+ ann_env <- getAnnEnv
+ return (deserializeAnns deserialize ann_env)
+
addAnnotation :: Typeable a => (a -> [Word8]) -> CoreAnnTarget -> a -> CoreM ()
addAnnotation serialize target what = addAnnotationToEnv $ Annotation { ann_target = target, ann_value = toSerialized serialize what }
\end{code}
-\subsection{Direct screen output}
+
+%************************************************************************
+%* *
+ Direct screen output
+%* *
+%************************************************************************
\begin{code}
-- | 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}
\end{code}
-\subsection{Finding TyThings}
-\begin{code}
+%************************************************************************
+%* *
+ 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}
+%************************************************************************
+%* *
+ 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.
+-- | 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}
projects / ghc-hetmet.git / blobdiff