module HERMIT.Plugin.Builder
(
HERMITPass
, buildPlugin
, CorePass(..)
, getCorePass
, ghcPasses
, PassInfo(..)
, getPassFlag
) where
import Data.IORef
import Data.List
import HERMIT.GHC
import HERMIT.Kernel
import System.IO
type HERMITPass = IORef (Maybe (AST, ASTMap)) -> PassInfo -> [CommandLineOption] -> ModGuts -> CoreM ModGuts
buildPlugin :: HERMITPass -> Plugin
buildPlugin hp = defaultPlugin { installCoreToDos = install }
where
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install opts todos = do
reinitializeGlobals
liftIO $ hSetBuffering stdout NoBuffering
#ifdef mingw32_HOST_OS
liftIO $ hSetEncoding stdout utf8
liftIO initStaticOpts
#endif
store <- liftIO $ newIORef (Nothing :: Maybe (ModuleName, IORef (Maybe (AST, ASTMap))))
let todos' = flattenTodos todos
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 store hp (PassInfo n ps ps') opts
return allPasses
modFilter :: IORef (Maybe (ModuleName, IORef (Maybe (AST, ASTMap))))
-> HERMITPass
-> PassInfo
-> [CommandLineOption]
-> ModGuts -> CoreM ModGuts
modFilter store hp pInfo opts guts
| null modOpts && notNull opts = return guts
| otherwise = do mb <- liftIO $ readIORef store
modStore <- case mb of
Just (nm,ref) | nm == modName -> return ref
_ -> liftIO $ do
ref <- newIORef Nothing
writeIORef store $ Just (modName, ref)
return ref
hp modStore pInfo (h_opts ++ filter notNull modOpts) guts
where modOpts = filterOpts m_opts modName
(m_opts, h_opts) = partition (isInfixOf ":") opts
modName = moduleName $ mg_module guts
filterOpts :: [CommandLineOption] -> ModuleName -> [CommandLineOption]
filterOpts opts mname = [ opt | nm <- opts
, let mopt = if modName `isPrefixOf` nm
then Just (drop len nm)
else if "*:" `isPrefixOf` nm
then Just (drop 2 nm)
else Nothing
, Just opt <- [mopt]
]
where modName = moduleNameString mname
len = lengthFS (moduleNameFS mname) + 1
#if __GLASGOW_HASKELL__ >= 710
data CorePass = CallArity
| CSE
#else
data CorePass = CSE
#endif
| Desugar
| DesugarOpt
| FloatInwards
| FloatOutwards
| LiberateCase
| Prep
| PrintCore
| RuleCheck
| Simplify
| SpecConstr
| Specialising
| StaticArgs
| Strictness
| Tidy
| Vectorisation
| WorkerWrapper
| 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)
#if __GLASGOW_HASKELL__ >= 710
, (CallArity , CoreDoCallArity)
#endif
, (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
#if __GLASGOW_HASKELL__ >= 710
getCorePass CoreDoCallArity = CallArity
#endif
flattenTodos :: [CoreToDo] -> [CoreToDo]
flattenTodos = concatMap f
where f (CoreDoPasses ps) = flattenTodos ps
f CoreDoNothing = []
f other = [other]
data PassInfo =
PassInfo { passNum :: Int
, passesDone :: [CorePass]
, passesLeft :: [CorePass]
}
deriving (Read, Show, Eq)
getPassFlag :: [CommandLineOption] -> Maybe (Int, [CommandLineOption])
getPassFlag opts = case partition ("-p" `isPrefixOf`) opts of
([],_) -> Nothing
(ps,r) -> Just (read (drop 2 (last ps)), r)