Commit 17558690 authored by Facundo Domínguez's avatar Facundo Domínguez Committed by Ben Gamari

Implement TH addCorePlugin.

This allows template-haskell code to add plugins to the compilation
pipeline. Otherwise, the user would have to pass -fplugin=... to ghc.

For now, plugin modules in the current package can't be used. This is
because when TH runs, it is too late to let GHC know that the plugin
modules needed to be compiled first.

Test Plan: ./validate

Reviewers: simonpj, bgamari, austin, goldfire

Reviewed By: bgamari

Subscribers: angerman, rwbarton, mboes, thomie

GHC Trac Issues: #13608

Differential Revision: https://phabricator.haskell.org/D3821
parent a9d417da
......@@ -91,6 +91,7 @@ module DynFlags (
opt_windres, opt_lo, opt_lc, opt_lcc,
-- ** Manipulating DynFlags
addPluginModuleName,
defaultDynFlags, -- Settings -> DynFlags
defaultWays,
interpWays,
......
......@@ -1032,16 +1032,19 @@ compileCore simplify fn = do
Just modSummary -> do
-- Now we have the module name;
-- parse, typecheck and desugar the module
mod_guts <- coreModule `fmap`
-- TODO: space leaky: call hsc* directly?
(desugarModule =<< typecheckModule =<< parseModule modSummary)
(tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
do tm <- typecheckModule =<< parseModule modSummary
let tcg = fst (tm_internals tm)
(,) tcg . coreModule <$> desugarModule tm
liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
if simplify
then do
-- If simplify is true: simplify (hscSimplify), then tidy
-- (tidyProgram).
hsc_env <- getSession
simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
simpl_guts <- liftIO $ do
plugins <- readIORef (tcg_th_coreplugins tcg)
hscSimplify hsc_env plugins mod_guts
tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
return $ Left tidy_guts
else
......
......@@ -85,6 +85,7 @@ module HscMain
import GhcPrelude
import Data.Data hiding (Fixity, TyCon)
import DynFlags (addPluginModuleName)
import Id
import GHCi ( addSptEntry )
import GHCi.RemoteTypes ( ForeignHValue )
......@@ -753,7 +754,8 @@ finish hsc_env summary tc_result mb_old_hash = do
-- and generate a simple interface.
then mk_simple_iface
else do
desugared_guts <- hscSimplify' desugared_guts0
plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
desugared_guts <- hscSimplify' plugins desugared_guts0
(iface, changed, details, cgguts) <-
liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
return (iface, changed, details, HscRecomp cgguts summary)
......@@ -1188,14 +1190,18 @@ hscGetSafeMode tcg_env = do
-- Simplifiers
--------------------------------------------------------------
hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify hsc_env plugins modguts =
runHsc hsc_env $ hscSimplify' plugins modguts
hscSimplify' :: ModGuts -> Hsc ModGuts
hscSimplify' ds_result = do
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' plugins ds_result = do
hsc_env <- getHscEnv
let hsc_env_with_plugins = hsc_env
{ hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
}
{-# SCC "Core2Core" #-}
liftIO $ core2core hsc_env ds_result
liftIO $ core2core hsc_env_with_plugins ds_result
--------------------------------------------------------------
-- Interface generators
......@@ -1578,7 +1584,9 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
{- Simplify -}
simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
simpl_mg <- liftIO $ do
plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
hscSimplify hsc_env plugins ds_result
{- Tidy -}
(tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
......
......@@ -221,6 +221,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
th_foreign_files_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ;
th_coreplugins_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ;
th_remote_state_var <- newIORef Nothing ;
let {
......@@ -237,6 +238,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
tcg_th_foreign_files = th_foreign_files_var,
tcg_th_topnames = th_topnames_var,
tcg_th_modfinalizers = th_modfinalizers_var,
tcg_th_coreplugins = th_coreplugins_var,
tcg_th_state = th_state_var,
tcg_th_remote_state = th_remote_state_var,
......
......@@ -651,6 +651,9 @@ data TcGblEnv
-- They are computations in the @TcM@ monad rather than @Q@ because we
-- set them to use particular local environments.
tcg_th_coreplugins :: TcRef [String],
-- ^ Core plugins added by Template Haskell code.
tcg_th_state :: TcRef (Map TypeRep Dynamic),
tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
-- ^ Template Haskell state
......
......@@ -35,6 +35,7 @@ import GhcPrelude
import HsSyn
import Annotations
import Finder
import Name
import TcRnMonad
import TcType
......@@ -920,6 +921,22 @@ instance TH.Quasi TcM where
fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
addModFinalizerRef fref
qAddCorePlugin plugin = do
hsc_env <- env_top <$> getEnv
r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
let err = hang
(text "addCorePlugin: invalid plugin module "
<+> text (show plugin)
)
2
(text "Plugins in the current package can't be specified.")
case r of
Found {} -> addErr err
FoundMultiple {} -> addErr err
_ -> return ()
th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
updTcRef th_coreplugins_var (plugin:)
qGetQ :: forall a. Typeable a => TcM (Maybe a)
qGetQ = do
th_state_var <- fmap tcg_th_state getGblEnv
......@@ -1104,6 +1121,7 @@ handleTHMessage msg = case msg of
AddModFinalizer r -> do
hsc_env <- env_top <$> getEnv
wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str
IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
......
......@@ -230,6 +230,18 @@ would invoke GHC like this:
Linking Test ...
$
Alternatively, core plugins can be specified with Template Haskell.
::
addCorePlugin "Foo.Plugin"
This inserts the plugin as a core-to-core pass. Unlike `-fplugin=(module)`,
the plugin module can't reside in the same package as the module calling
:th-ref:`Language.Haskell.TH.Syntax.addCorePlugin`. This way, the
implementation can expect the plugin to be built by the time
it is needed.
Plugin modules live in a separate namespace from
the user import namespace. By default, these two namespaces are
the same; however, there are a few command line options which
......
......@@ -240,6 +240,7 @@ data THMessage a where
AddDependentFile :: FilePath -> THMessage (THResult ())
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddCorePlugin :: String -> THMessage (THResult ())
AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
IsExtEnabled :: Extension -> THMessage (THResult Bool)
......@@ -278,7 +279,8 @@ getTHMessage = do
15 -> THMsg <$> EndRecover <$> get
16 -> return (THMsg RunTHDone)
17 -> THMsg <$> AddModFinalizer <$> get
_ -> THMsg <$> (AddForeignFile <$> get <*> get)
18 -> THMsg <$> (AddForeignFile <$> get <*> get)
_ -> THMsg <$> AddCorePlugin <$> get
putTHMessage :: THMessage a -> Put
putTHMessage m = case m of
......@@ -301,6 +303,7 @@ putTHMessage m = case m of
RunTHDone -> putWord8 16
AddModFinalizer a -> putWord8 17 >> put a
AddForeignFile lang a -> putWord8 18 >> put lang >> put a
AddCorePlugin a -> putWord8 19 >> put a
data EvalOpts = EvalOpts
......
......@@ -199,6 +199,7 @@ instance TH.Quasi GHCiQ where
qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
ghcCmd . AddModFinalizer
qAddCorePlugin str = ghcCmd (AddCorePlugin str)
qGetQ = GHCiQ $ \s ->
let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
......
......@@ -90,6 +90,8 @@ class (MonadIO m, Fail.MonadFail m) => Quasi m where
qAddModFinalizer :: Q () -> m ()
qAddCorePlugin :: String -> m ()
qGetQ :: Typeable a => m (Maybe a)
qPutQ :: Typeable a => a -> m ()
......@@ -129,6 +131,7 @@ instance Quasi IO where
qAddTopDecls _ = badIO "addTopDecls"
qAddForeignFile _ _ = badIO "addForeignFile"
qAddModFinalizer _ = badIO "addModFinalizer"
qAddCorePlugin _ = badIO "addCorePlugin"
qGetQ = badIO "getQ"
qPutQ _ = badIO "putQ"
qIsExtEnabled _ = badIO "isExtEnabled"
......@@ -476,6 +479,16 @@ addForeignFile lang str = Q (qAddForeignFile lang str)
addModFinalizer :: Q () -> Q ()
addModFinalizer act = Q (qAddModFinalizer (unQ act))
-- | Adds a core plugin to the compilation pipeline.
--
-- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc
-- in the command line. The major difference is that the plugin module @m@
-- must not belong to the current package. When TH executes, it is too late
-- to tell the compiler that we needed to compile first a plugin module in the
-- current package.
addCorePlugin :: String -> Q ()
addCorePlugin plugin = Q (qAddCorePlugin plugin)
-- | Get state from the 'Q' monad. Note that the state is local to the
-- Haskell module in which the Template Haskell expression is executed.
getQ :: Typeable a => Q (Maybe a)
......@@ -514,6 +527,7 @@ instance Quasi Q where
qAddTopDecls = addTopDecls
qAddForeignFile = addForeignFile
qAddModFinalizer = addModFinalizer
qAddCorePlugin = addCorePlugin
qGetQ = getQ
qPutQ = putQ
qIsExtEnabled = isExtEnabled
......
......@@ -16,6 +16,11 @@ plugins07:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -O plugins07.hs -package-db rule-defining-plugin/pkg.plugins07/local.package.conf -hide-all-packages -package base -plugin-package rule-defining-plugin -fplugin=RuleDefiningPlugin
./plugins07
.PHONY: plugins08
plugins08:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins08.hs -package-db simple-plugin/pkg.plugins08/local.package.conf
./plugins08
# -package (should work for backwards compatibility)
.PHONY: T10420
T10420:
......
......@@ -34,6 +34,11 @@ test('plugins07',
pre_cmd('$MAKE -s --no-print-directory -C rule-defining-plugin package.plugins07 TOP={top}')],
run_command, ['$MAKE -s --no-print-directory plugins07'])
test('plugins08',
[extra_files(['simple-plugin/']),
pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins08 TOP={top}')],
run_command, ['$MAKE -s --no-print-directory plugins08'])
test('T10420',
[extra_files(['rule-defining-plugin/']),
pre_cmd('$MAKE -s --no-print-directory -C rule-defining-plugin package.T10420 TOP={top}')],
......
-- Tests a plugin added with TH.addCorePlugin
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Simple.DataStructures
import Language.Haskell.TH.Syntax
do addCorePlugin "Simple.Plugin"
return []
{-# ANN theMessage (ReplaceWith "Right") #-}
{-# NOINLINE theMessage #-}
theMessage = "Wrong"
main = do
putStrLn "Program Started"
putStrLn theMessage
putStrLn "Program Ended"
Simple Plugin Passes Queried
Got options:
Simple Plugin Pass Run
Performing Replacement
Program Started
Right
Program Ended
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment