module Language.HERMIT.Plugin
(
HermitPass
, hermitPlugin
, CorePass(..)
, getCorePass
, ghcPasses
, PhaseInfo(..)
) where
import GhcPlugins
import Data.List
import System.IO
type HermitPass = PhaseInfo -> [CommandLineOption] -> ModGuts -> CoreM ModGuts
hermitPlugin :: HermitPass -> Plugin
hermitPlugin hp = defaultPlugin { installCoreToDos = install }
where
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install opts todos = do
reinitializeGlobals
liftIO $ hSetBuffering stdout NoBuffering
let (m_opts, _h_opts) = partition (isInfixOf ":") opts
passes = map getCorePass todos
allPasses = foldr (\ (n,p,seen,notyet) r -> mkPass n seen notyet : p : r)
[mkPass (length todos) passes []]
(zip4 [0..] todos (inits passes) (tails passes))
mkPass n ps ps' = CoreDoPluginPass ("HERMIT" ++ show n) $ modFilter hp (PhaseInfo n ps ps') m_opts
return allPasses
modFilter :: HermitPass -> HermitPass
modFilter hp pInfo opts guts
| null modOpts && not (null opts) = return guts
| otherwise = hp pInfo (filter (not . null) modOpts) guts
where modOpts = filterOpts opts guts
filterOpts :: [CommandLineOption] -> ModGuts -> [CommandLineOption]
filterOpts opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ]
where modName = moduleNameString $ moduleName $ mg_module guts
len = length modName + 1
data CorePass = FloatInwards
| LiberateCase
| PrintCore
| StaticArgs
| Strictness
| WorkerWrapper
| Specialising
| SpecConstr
| CSE
| Vectorisation
| Desugar
| DesugarOpt
| Tidy
| Prep
| Simplify
| FloatOutwards
| RuleCheck
| Passes
| PluginPass String
| NoOp
| Unknown
deriving (Read, Show, Eq)
ghcPasses :: [(CorePass, CoreToDo)]
ghcPasses = [ (FloatInwards , CoreDoFloatInwards)
, (LiberateCase , CoreLiberateCase)
, (PrintCore , CoreDoPrintCore)
, (StaticArgs , CoreDoStaticArgs)
, (Strictness , CoreDoStrictness)
, (WorkerWrapper, CoreDoWorkerWrapper)
, (Specialising , CoreDoSpecialising)
, (SpecConstr , CoreDoSpecConstr)
, (CSE , CoreCSE)
, (Vectorisation, CoreDoVectorisation)
, (Desugar , CoreDesugar)
, (DesugarOpt , CoreDesugarOpt)
, (Tidy , CoreTidy)
, (Prep , CorePrep)
, (NoOp , CoreDoNothing)
]
getCorePass :: CoreToDo -> CorePass
getCorePass CoreDoFloatInwards = FloatInwards
getCorePass CoreLiberateCase = LiberateCase
getCorePass CoreDoPrintCore = PrintCore
getCorePass CoreDoStaticArgs = StaticArgs
getCorePass CoreDoStrictness = Strictness
getCorePass CoreDoWorkerWrapper = WorkerWrapper
getCorePass CoreDoSpecialising = Specialising
getCorePass CoreDoSpecConstr = SpecConstr
getCorePass CoreCSE = CSE
getCorePass CoreDoVectorisation = Vectorisation
getCorePass CoreDesugar = Desugar
getCorePass CoreDesugarOpt = DesugarOpt
getCorePass CoreTidy = Tidy
getCorePass CorePrep = Prep
getCorePass (CoreDoSimplify {}) = Simplify
getCorePass (CoreDoFloatOutwards {}) = FloatOutwards
getCorePass (CoreDoRuleCheck {}) = RuleCheck
getCorePass (CoreDoPasses {}) = Passes
getCorePass (CoreDoPluginPass nm _) = PluginPass nm
getCorePass CoreDoNothing = NoOp
data PhaseInfo =
PhaseInfo { phaseNum :: Int
, phasesDone :: [CorePass]
, phasesLeft :: [CorePass]
}
deriving (Read, Show, Eq)