diff options
Diffstat (limited to 'compiler/GHC/Driver/Pipeline/Monad.hs')
-rw-r--r-- | compiler/GHC/Driver/Pipeline/Monad.hs | 122 |
1 files changed, 122 insertions, 0 deletions
diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs new file mode 100644 index 0000000000..5831f923ea --- /dev/null +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +-- | The CompPipeline monad and associated ops +-- +-- Defined in separate module so that it can safely be imported from Hooks +module GHC.Driver.Pipeline.Monad ( + CompPipeline(..), evalP + , PhasePlus(..) + , PipeEnv(..), PipeState(..), PipelineOutput(..) + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface + , pipeStateDynFlags, pipeStateModIface + ) where + +import GhcPrelude + +import MonadUtils +import Outputable +import GHC.Driver.Session +import GHC.Driver.Phases +import GHC.Driver.Types +import Module +import FileCleanup (TempFileLifetime) + +import Control.Monad + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + deriving (Functor) + +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO (PipeState, a) +evalP (P f) env st = f env st + +instance Applicative CompPipeline where + pure a = P $ \_env state -> return (state, a) + (<*>) = ap + +instance Monad CompPipeline where + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +instance MonadIO CompPipeline where + liftIO m = P $ \_env state -> do a <- m; return (state, a) + +data PhasePlus = RealPhase Phase + | HscOut HscSource ModuleName HscStatus + +instance Outputable PhasePlus where + ppr (RealPhase p) = ppr p + ppr (HscOut {}) = text "HscOut" + +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + foreign_os :: [FilePath], + -- ^ additional object files resulting from compiling foreign + -- code. They come from two sources: foreign stubs, and + -- add{C,Cxx,Objc,Objcxx}File from template haskell + iface :: Maybe (ModIface, ModDetails) + -- ^ Interface generated by HscOut phase. Only available after the + -- phase runs. + } + +pipeStateDynFlags :: PipeState -> DynFlags +pipeStateDynFlags = hsc_dflags . hsc_env + +pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails) +pipeStateModIface = iface + +data PipelineOutput + = Temporary TempFileLifetime + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + deriving Show + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setForeignOs :: [FilePath] -> CompPipeline () +setForeignOs os = P $ \_env state -> + return (state{ foreign_os = os }, ()) + +setIface :: ModIface -> ModDetails -> CompPipeline () +setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ()) |