Commit b9bebd8c authored by Facundo Domínguez's avatar Facundo Domínguez

Implement addCStub in template-haskell.

Summary:
addCStub allows injecting C code in the current module to be included
in the final object file.

Test Plan: ./validate

Reviewers: simonpj, goldfire, austin, bgamari

Reviewed By: bgamari

Subscribers: bitonic, duncan, mboes, thomie

Differential Revision: https://phabricator.haskell.org/D3106
parent afaf6d58
...@@ -289,6 +289,7 @@ deSugar hsc_env ...@@ -289,6 +289,7 @@ deSugar hsc_env
tcg_imp_specs = imp_specs, tcg_imp_specs = imp_specs,
tcg_dependent_files = dependent_files, tcg_dependent_files = dependent_files,
tcg_ev_binds = ev_binds, tcg_ev_binds = ev_binds,
tcg_th_cstubs = th_cstubs_var,
tcg_fords = fords, tcg_fords = fords,
tcg_rules = rules, tcg_rules = rules,
tcg_vects = vects, tcg_vects = vects,
...@@ -373,6 +374,9 @@ deSugar hsc_env ...@@ -373,6 +374,9 @@ deSugar hsc_env
-- past desugaring. See Note [Identity versus semantic module]. -- past desugaring. See Note [Identity versus semantic module].
; MASSERT( id_mod == mod ) ; MASSERT( id_mod == mod )
; cstubs <- readIORef th_cstubs_var
; let ds_fords' = foldl' appendStubC ds_fords (map text cstubs)
; let mod_guts = ModGuts { ; let mod_guts = ModGuts {
mg_module = mod, mg_module = mod,
mg_hsc_src = hsc_src, mg_hsc_src = hsc_src,
...@@ -393,7 +397,7 @@ deSugar hsc_env ...@@ -393,7 +397,7 @@ deSugar hsc_env
mg_patsyns = patsyns, mg_patsyns = patsyns,
mg_rules = ds_rules_for_imps, mg_rules = ds_rules_for_imps,
mg_binds = ds_binds, mg_binds = ds_binds,
mg_foreign = ds_fords, mg_foreign = ds_fords',
mg_hpc_info = ds_hpc_info, mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks, mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects, mg_vect_decls = ds_vects,
......
...@@ -217,6 +217,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this ...@@ -217,6 +217,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
dependent_files_var <- newIORef [] ; dependent_files_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ; static_wc_var <- newIORef emptyWC ;
th_topdecls_var <- newIORef [] ; th_topdecls_var <- newIORef [] ;
th_cstubs_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ; th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ; th_modfinalizers_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ; th_state_var <- newIORef Map.empty ;
...@@ -231,6 +232,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this ...@@ -231,6 +232,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
gbl_env = TcGblEnv { gbl_env = TcGblEnv {
tcg_th_topdecls = th_topdecls_var, tcg_th_topdecls = th_topdecls_var,
tcg_th_cstubs = th_cstubs_var,
tcg_th_topnames = th_topnames_var, tcg_th_topnames = th_topnames_var,
tcg_th_modfinalizers = th_modfinalizers_var, tcg_th_modfinalizers = th_modfinalizers_var,
tcg_th_state = th_state_var, tcg_th_state = th_state_var,
......
...@@ -608,6 +608,9 @@ data TcGblEnv ...@@ -608,6 +608,9 @@ data TcGblEnv
tcg_th_topdecls :: TcRef [LHsDecl RdrName], tcg_th_topdecls :: TcRef [LHsDecl RdrName],
-- ^ Top-level declarations from addTopDecls -- ^ Top-level declarations from addTopDecls
tcg_th_cstubs :: TcRef [String],
-- ^ C stubs from addCStub
tcg_th_topnames :: TcRef NameSet, tcg_th_topnames :: TcRef NameSet,
-- ^ Exact names bound in top-level declarations in tcg_th_topdecls -- ^ Exact names bound in top-level declarations in tcg_th_topdecls
......
...@@ -909,6 +909,17 @@ instance TH.Quasi TcM where ...@@ -909,6 +909,17 @@ instance TH.Quasi TcM where
hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU.")) hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
2 (text "Probable cause: you used mkName instead of newName to generate a binding.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
qAddCStub str = do
l <- getSrcSpanM
r <- case l of
UnhelpfulSpan _ -> pprPanic "qAddCStub: Unhelpful location" (ppr l)
RealSrcSpan s -> return s
let filename = unpackFS (srcSpanFile r)
linePragma = "#line " ++ show (srcSpanStartLine r)
++ " " ++ show filename
th_cstubs_var <- fmap tcg_th_cstubs getGblEnv
updTcRef th_cstubs_var ([linePragma, str] ++)
qAddModFinalizer fin = do qAddModFinalizer fin = do
r <- liftIO $ mkRemoteRef fin r <- liftIO $ mkRemoteRef fin
fref <- liftIO $ mkForeignRef r (freeRemoteRef r) fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
...@@ -1100,6 +1111,7 @@ handleTHMessage msg = case msg of ...@@ -1100,6 +1111,7 @@ handleTHMessage msg = case msg of
hsc_env <- env_top <$> getEnv hsc_env <- env_top <$> getEnv
wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
AddCStub str -> wrapTHResult $ TH.qAddCStub str
IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
_ -> panic ("handleTHMessage: unexpected message " ++ show msg) _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
......
...@@ -237,6 +237,7 @@ data THMessage a where ...@@ -237,6 +237,7 @@ data THMessage a where
AddDependentFile :: FilePath -> THMessage (THResult ()) AddDependentFile :: FilePath -> THMessage (THResult ())
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddTopDecls :: [TH.Dec] -> THMessage (THResult ()) AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
AddCStub :: String -> THMessage (THResult ())
IsExtEnabled :: Extension -> THMessage (THResult Bool) IsExtEnabled :: Extension -> THMessage (THResult Bool)
ExtsEnabled :: THMessage (THResult [Extension]) ExtsEnabled :: THMessage (THResult [Extension])
...@@ -272,7 +273,8 @@ getTHMessage = do ...@@ -272,7 +273,8 @@ getTHMessage = do
14 -> THMsg <$> return StartRecover 14 -> THMsg <$> return StartRecover
15 -> THMsg <$> EndRecover <$> get 15 -> THMsg <$> EndRecover <$> get
16 -> return (THMsg RunTHDone) 16 -> return (THMsg RunTHDone)
_ -> THMsg <$> AddModFinalizer <$> get 17 -> THMsg <$> AddModFinalizer <$> get
_ -> THMsg <$> AddCStub <$> get
putTHMessage :: THMessage a -> Put putTHMessage :: THMessage a -> Put
putTHMessage m = case m of putTHMessage m = case m of
...@@ -294,6 +296,7 @@ putTHMessage m = case m of ...@@ -294,6 +296,7 @@ putTHMessage m = case m of
EndRecover a -> putWord8 15 >> put a EndRecover a -> putWord8 15 >> put a
RunTHDone -> putWord8 16 RunTHDone -> putWord8 16
AddModFinalizer a -> putWord8 17 >> put a AddModFinalizer a -> putWord8 17 >> put a
AddCStub a -> putWord8 18 >> put a
data EvalOpts = EvalOpts data EvalOpts = EvalOpts
......
...@@ -193,6 +193,7 @@ instance TH.Quasi GHCiQ where ...@@ -193,6 +193,7 @@ instance TH.Quasi GHCiQ where
qRunIO m = GHCiQ $ \s -> fmap (,s) m qRunIO m = GHCiQ $ \s -> fmap (,s) m
qAddDependentFile file = ghcCmd (AddDependentFile file) qAddDependentFile file = ghcCmd (AddDependentFile file)
qAddTopDecls decls = ghcCmd (AddTopDecls decls) qAddTopDecls decls = ghcCmd (AddTopDecls decls)
qAddCStub str = ghcCmd (AddCStub str)
qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
ghcCmd . AddModFinalizer ghcCmd . AddModFinalizer
qGetQ = GHCiQ $ \s -> qGetQ = GHCiQ $ \s ->
......
...@@ -92,6 +92,8 @@ class Monad m => Quasi m where ...@@ -92,6 +92,8 @@ class Monad m => Quasi m where
qAddTopDecls :: [Dec] -> m () qAddTopDecls :: [Dec] -> m ()
qAddCStub :: String -> m ()
qAddModFinalizer :: Q () -> m () qAddModFinalizer :: Q () -> m ()
qGetQ :: Typeable a => m (Maybe a) qGetQ :: Typeable a => m (Maybe a)
...@@ -131,6 +133,7 @@ instance Quasi IO where ...@@ -131,6 +133,7 @@ instance Quasi IO where
qRecover _ _ = badIO "recover" -- Maybe we could fix this? qRecover _ _ = badIO "recover" -- Maybe we could fix this?
qAddDependentFile _ = badIO "addDependentFile" qAddDependentFile _ = badIO "addDependentFile"
qAddTopDecls _ = badIO "addTopDecls" qAddTopDecls _ = badIO "addTopDecls"
qAddCStub _ = badIO "addCStub"
qAddModFinalizer _ = badIO "addModFinalizer" qAddModFinalizer _ = badIO "addModFinalizer"
qGetQ = badIO "getQ" qGetQ = badIO "getQ"
qPutQ _ = badIO "putQ" qPutQ _ = badIO "putQ"
...@@ -456,6 +459,25 @@ addDependentFile fp = Q (qAddDependentFile fp) ...@@ -456,6 +459,25 @@ addDependentFile fp = Q (qAddDependentFile fp)
addTopDecls :: [Dec] -> Q () addTopDecls :: [Dec] -> Q ()
addTopDecls ds = Q (qAddTopDecls ds) addTopDecls ds = Q (qAddTopDecls ds)
-- | Add an additional C stub. The added stub will be built and included in the
-- object file of the current module.
--
-- Compilation errors in the given string are reported next to the line of the
-- enclosing splice.
--
-- The accuracy of the error location can be improved by adding
-- #line pragmas in the argument. e.g.
--
-- > {-# LANGUAGE CPP #-}
-- > ...
-- > addCStub $ unlines
-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
-- > , ...
-- > ]
--
addCStub :: String -> Q ()
addCStub str = Q (qAddCStub str)
-- | Add a finalizer that will run in the Q monad after the current module has -- | Add a finalizer that will run in the Q monad after the current module has
-- been type checked. This only makes sense when run within a top-level splice. -- been type checked. This only makes sense when run within a top-level splice.
-- --
...@@ -499,6 +521,7 @@ instance Quasi Q where ...@@ -499,6 +521,7 @@ instance Quasi Q where
qRunIO = runIO qRunIO = runIO
qAddDependentFile = addDependentFile qAddDependentFile = addDependentFile
qAddTopDecls = addTopDecls qAddTopDecls = addTopDecls
qAddCStub = addCStub
qAddModFinalizer = addModFinalizer qAddModFinalizer = addModFinalizer
qGetQ = getQ qGetQ = getQ
qPutQ = putQ qPutQ = putQ
......
-- Tests that addCStub includes the C code in the final object file and that
-- -optc options are passed when building it.
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -optc-DA_MACRO=1 #-}
import Language.Haskell.TH.Syntax
foreign import ccall f :: Int -> IO Int
do addCStub $ unlines
[ "#include <stdio.h>"
, "int f(int x) {"
, " printf(\"calling f(%d)\\n\",x);"
, " return A_MACRO + x;"
, "}"
]
return []
main :: IO ()
main = f 2 >>= print
-- Tests that a reasonable error is reported when addCStub is used with
-- incorrect C code.
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -optc-DA_MACRO=1 #-}
import Language.Haskell.TH.Syntax
foreign import ccall f :: Int -> IO Int
do addCStub $ unlines
[ "#include <stdio.h>"
, "int f(int x {"
, " printf(\"calling f(%d)\\n\",x);"
, " return A_MACRO + x;"
, "}"
]
return []
main :: IO ()
main = f 2 >>= print
TH_addCStub2.hs:13:13:
expected ‘;’, ‘,’ or ‘)’ before ‘{’ token
[ "#include <stdio.h>"
^
`gcc' failed in phase `C Compiler'. (Exit code: 1)
...@@ -63,6 +63,9 @@ test('TH_reifyDecl2', normal, compile, ['-v0']) ...@@ -63,6 +63,9 @@ test('TH_reifyDecl2', normal, compile, ['-v0'])
test('TH_reifyLocalDefs', normal, compile, ['-v0']) test('TH_reifyLocalDefs', normal, compile, ['-v0'])
test('TH_reifyLocalDefs2', normal, compile, ['-v0']) test('TH_reifyLocalDefs2', normal, compile, ['-v0'])
test('TH_addCStub1', normal, compile_and_run, ['-v0'])
test('TH_addCStub2', normal, compile_fail, ['-v0'])
test('TH_reifyMkName', normal, compile, ['-v0']) test('TH_reifyMkName', normal, compile, ['-v0'])
test('TH_reifyInstances', normal, compile, ['-v0']) test('TH_reifyInstances', normal, compile, ['-v0'])
......
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