Commit ceb91477 authored by Alec Theriault's avatar Alec Theriault Committed by Ben Gamari

Support adding objects from TH

The user facing TH interface changes are:

  * 'addForeignFile' is renamed to 'addForeignSource'
  * 'qAddForeignFile'/'addForeignFile' now expect 'FilePath's
  * 'RawObject' is now a constructor for 'ForeignSrcLang'
  * 'qAddTempFile'/'addTempFile' let you request a temporary file
    from the compiler.

Test Plan: unsure about this, added a TH test

Reviewers: goldfire, bgamari, angerman

Reviewed By: bgamari, angerman

Subscribers: hsyl20, mboes, carter, simonmar, bitonic, ljli, rwbarton, thomie

GHC Trac Issues: #14298

Differential Revision: https://phabricator.haskell.org/D4217
parent affdea82
......@@ -38,7 +38,6 @@ import Control.Exception
import System.Directory
import System.FilePath
import System.IO
import Control.Monad (forM)
{-
************************************************************************
......@@ -53,7 +52,7 @@ codeOutput :: DynFlags
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> [(ForeignSrcLang, FilePath)]
-- ^ additional files to be compiled with with the C compiler
-> [InstalledUnitId]
-> Stream IO RawCmmGroup () -- Compiled C--
......@@ -61,7 +60,7 @@ codeOutput :: DynFlags
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
[(ForeignSrcLang, FilePath)]{-foreign_fps-})
codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
cmm_stream
=
do {
......@@ -89,10 +88,6 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
}
; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
; foreign_fps <- forM foreign_files $ \(lang, file_contents) -> do
{ fp <- outputForeignFile dflags lang file_contents;
; return (lang, fp);
}
; case hscTarget dflags of {
HscAsm -> outputAsm dflags this_mod location filenm
linted_cmm_stream;
......@@ -270,14 +265,3 @@ outputForeignStubs_help fname doc_str header footer
= do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
return True
outputForeignFile :: DynFlags -> ForeignSrcLang -> String -> IO FilePath
outputForeignFile dflags lang file_contents
= do
extension <- case lang of
LangC -> return "c"
LangCxx -> return "cpp"
LangObjc -> return "m"
LangObjcxx -> return "mm"
fp <- newTempName dflags TFL_CurrentModule extension
writeFile fp file_contents
return fp
......@@ -302,12 +302,14 @@ compileOne' m_tc_result mHscMessage
-- useful to implement facilities such as inline-c.
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign _ RawObject object_file = return object_file
compileForeign hsc_env lang stub_c = do
let phase = case lang of
LangC -> Cc
LangCxx -> Ccxx
LangObjc -> Cobjc
LangObjcxx -> Cobjcxx
RawObject -> panic "compileForeign: should be unreachable"
(_, stub_o) <- runPipeline StopLn hsc_env
(stub_c, Just (RealPhase phase))
Nothing (Temporary TFL_GhcSession)
......
......@@ -1278,7 +1278,7 @@ data ModGuts
-- See Note [Overall plumbing for rules] in Rules.hs
mg_binds :: !CoreProgram, -- ^ Bindings for this module
mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module
mg_foreign_files :: ![(ForeignSrcLang, String)],
mg_foreign_files :: ![(ForeignSrcLang, FilePath)],
-- ^ Files to be compiled with the C compiler
mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module
......@@ -1339,7 +1339,7 @@ data CgGuts
-- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
cg_foreign_files :: ![(ForeignSrcLang, String)],
cg_foreign_files :: ![(ForeignSrcLang, FilePath)],
cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to
-- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
......
......@@ -638,7 +638,7 @@ data TcGblEnv
tcg_th_topdecls :: TcRef [LHsDecl GhcPs],
-- ^ Top-level declarations from addTopDecls
tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)],
tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)],
-- ^ Foreign files emitted from TH.
tcg_th_topnames :: TcRef NameSet,
......
......@@ -46,6 +46,7 @@ import SrcLoc
import THNames
import TcUnify
import TcEnv
import FileCleanup ( newTempName, TempFileLifetime(..) )
import Control.Monad
......@@ -879,6 +880,10 @@ instance TH.Quasi TcM where
dep_files <- readTcRef ref
writeTcRef ref (fp:dep_files)
qAddTempFile suffix = do
dflags <- getDynFlags
liftIO $ newTempName dflags TFL_GhcSession suffix
qAddTopDecls thds = do
l <- getSrcSpanM
let either_hval = convertToHsDecls l thds
......@@ -912,9 +917,9 @@ instance TH.Quasi TcM where
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.")
qAddForeignFile lang str = do
qAddForeignFilePath lang fp = do
var <- fmap tcg_th_foreign_files getGblEnv
updTcRef var ((lang, str) :)
updTcRef var ((lang, fp) :)
qAddModFinalizer fin = do
r <- liftIO $ mkRemoteRef fin
......@@ -1118,12 +1123,13 @@ handleTHMessage msg = case msg of
ReifyModule m -> wrapTHResult $ TH.qReifyModule m
ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
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
AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
_ -> panic ("handleTHMessage: unexpected message " ++ show msg)
......
......@@ -6,5 +6,5 @@ module GHC.ForeignSrcLang.Type
import GHC.Generics (Generic)
data ForeignSrcLang
= LangC | LangCxx | LangObjc | LangObjcxx
= LangC | LangCxx | LangObjc | LangObjcxx | RawObject
deriving (Eq, Show, Generic)
......@@ -235,10 +235,11 @@ data THMessage a where
ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
AddDependentFile :: FilePath -> THMessage (THResult ())
AddTempFile :: String -> THMessage (THResult FilePath)
AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
AddCorePlugin :: String -> THMessage (THResult ())
AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())
IsExtEnabled :: Extension -> THMessage (THResult Bool)
ExtsEnabled :: THMessage (THResult [Extension])
......@@ -268,14 +269,15 @@ getTHMessage = do
8 -> THMsg <$> ReifyModule <$> get
9 -> THMsg <$> ReifyConStrictness <$> get
10 -> THMsg <$> AddDependentFile <$> get
11 -> THMsg <$> AddTopDecls <$> get
12 -> THMsg <$> (IsExtEnabled <$> get)
13 -> THMsg <$> return ExtsEnabled
14 -> THMsg <$> return StartRecover
15 -> THMsg <$> EndRecover <$> get
16 -> return (THMsg RunTHDone)
17 -> THMsg <$> AddModFinalizer <$> get
18 -> THMsg <$> (AddForeignFile <$> get <*> get)
11 -> THMsg <$> AddTempFile <$> get
12 -> THMsg <$> AddTopDecls <$> get
13 -> THMsg <$> (IsExtEnabled <$> get)
14 -> THMsg <$> return ExtsEnabled
15 -> THMsg <$> return StartRecover
16 -> THMsg <$> EndRecover <$> get
17 -> return (THMsg RunTHDone)
18 -> THMsg <$> AddModFinalizer <$> get
19 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
_ -> THMsg <$> AddCorePlugin <$> get
putTHMessage :: THMessage a -> Put
......@@ -291,15 +293,16 @@ putTHMessage m = case m of
ReifyModule a -> putWord8 8 >> put a
ReifyConStrictness a -> putWord8 9 >> put a
AddDependentFile a -> putWord8 10 >> put a
AddTopDecls a -> putWord8 11 >> put a
IsExtEnabled a -> putWord8 12 >> put a
ExtsEnabled -> putWord8 13
StartRecover -> putWord8 14
EndRecover a -> putWord8 15 >> put a
RunTHDone -> putWord8 16
AddModFinalizer a -> putWord8 17 >> put a
AddForeignFile lang a -> putWord8 18 >> put lang >> put a
AddCorePlugin a -> putWord8 19 >> put a
AddTempFile a -> putWord8 11 >> put a
AddTopDecls a -> putWord8 12 >> put a
IsExtEnabled a -> putWord8 13 >> put a
ExtsEnabled -> putWord8 14
StartRecover -> putWord8 15
EndRecover a -> putWord8 16 >> put a
RunTHDone -> putWord8 17
AddModFinalizer a -> putWord8 18 >> put a
AddForeignFilePath lang a -> putWord8 19 >> put lang >> put a
AddCorePlugin a -> putWord8 20 >> put a
data EvalOpts = EvalOpts
......
......@@ -195,8 +195,9 @@ instance TH.Quasi GHCiQ where
qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
qLocation = fromMaybe noLoc . qsLocation <$> getState
qAddDependentFile file = ghcCmd (AddDependentFile file)
qAddTempFile suffix = ghcCmd (AddTempFile suffix)
qAddTopDecls decls = ghcCmd (AddTopDecls decls)
qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
ghcCmd . AddModFinalizer
qAddCorePlugin str = ghcCmd (AddCorePlugin str)
......
......@@ -84,9 +84,11 @@ class (MonadIO m, Fail.MonadFail m) => Quasi m where
qAddDependentFile :: FilePath -> m ()
qAddTempFile :: String -> m FilePath
qAddTopDecls :: [Dec] -> m ()
qAddForeignFile :: ForeignSrcLang -> String -> m ()
qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
qAddModFinalizer :: Q () -> m ()
......@@ -128,8 +130,9 @@ instance Quasi IO where
qLocation = badIO "currentLocation"
qRecover _ _ = badIO "recover" -- Maybe we could fix this?
qAddDependentFile _ = badIO "addDependentFile"
qAddTempFile _ = badIO "addTempFile"
qAddTopDecls _ = badIO "addTopDecls"
qAddForeignFile _ _ = badIO "addForeignFile"
qAddForeignFilePath _ _ = badIO "addForeignFilePath"
qAddModFinalizer _ = badIO "addModFinalizer"
qAddCorePlugin _ = badIO "addCorePlugin"
qGetQ = badIO "getQ"
......@@ -445,11 +448,23 @@ runIO m = Q (qRunIO m)
addDependentFile :: FilePath -> Q ()
addDependentFile fp = Q (qAddDependentFile fp)
-- | Obtain a temporary file path with the given suffix. The compiler will
-- delete this file after compilation.
addTempFile :: String -> Q FilePath
addTempFile suffix = Q (qAddTempFile suffix)
-- | Add additional top-level declarations. The added declarations will be type
-- checked along with the current declaration group.
addTopDecls :: [Dec] -> Q ()
addTopDecls ds = Q (qAddTopDecls ds)
-- |
addForeignFile :: ForeignSrcLang -> String -> Q ()
addForeignFile = addForeignSource
{-# DEPRECATED addForeignFile
"Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
#-} -- deprecated in 8.6
-- | Emit a foreign file which will be compiled and linked to the object for
-- the current module. Currently only languages that can be compiled with
-- the C compiler are supported, and the flags passed as part of -optc will
......@@ -463,12 +478,30 @@ addTopDecls ds = Q (qAddTopDecls ds)
--
-- > {-# LANGUAGE CPP #-}
-- > ...
-- > addForeignFile LangC $ unlines
-- > addForeignSource LangC $ unlines
-- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
-- > , ...
-- > ]
addForeignFile :: ForeignSrcLang -> String -> Q ()
addForeignFile lang str = Q (qAddForeignFile lang str)
addForeignSource :: ForeignSrcLang -> String -> Q ()
addForeignSource lang src = do
let suffix = case lang of
LangC -> "c"
LangCxx -> "cpp"
LangObjc -> "m"
LangObjcxx -> "mm"
RawObject -> "a"
path <- addTempFile suffix
runIO $ writeFile path src
addForeignFilePath lang path
-- | Same as 'addForeignSource', but expects to recieve a path pointing to the
-- foreign file instead of a 'String' of its contents. Consider using this in
-- conjunction with 'addTempFile'.
--
-- This is a good alternative to 'addForeignSource' when you are trying to
-- directly link in an object file.
addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
-- | 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.
......@@ -524,8 +557,9 @@ instance Quasi Q where
qLookupName = lookupName
qLocation = location
qAddDependentFile = addDependentFile
qAddTempFile = addTempFile
qAddTopDecls = addTopDecls
qAddForeignFile = addForeignFile
qAddForeignFilePath = addForeignFilePath
qAddModFinalizer = addModFinalizer
qAddCorePlugin = addCorePlugin
qGetQ = getQ
......
......@@ -7,7 +7,7 @@ import System.IO (hFlush, stdout)
foreign import ccall fc :: Int -> IO Int
do addForeignFile LangC $ unlines
do addForeignSource LangC $ unlines
[ "#include <stdio.h>"
, "int fc(int x) {"
, " printf(\"calling f(%d)\\n\",x);"
......@@ -19,7 +19,7 @@ do addForeignFile LangC $ unlines
foreign import ccall fcxx :: Int -> IO Int
do addForeignFile LangCxx $ unlines
do addForeignSource LangCxx $ unlines
[ "#include <iostream>"
, "extern \"C\" {"
, " int fcxx(int x) {"
......
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH.Syntax
import System.IO (hFlush, stdout)
foreign import ccall foo :: Int -> IO Int
do fpIn <- addTempFile "c"
let cSrc = (unlines [ "#include <stdio.h>"
, "int foo(int x) {"
, " printf(\"calling f(%d)\\n\",x);"
, " fflush(stdout);"
, " return 1 + x;"
, "}"
])
runIO $ writeFile fpIn cSrc
addForeignFilePath LangC fpIn
return []
main :: IO ()
main = do
foo 2 >>= print
hFlush stdout
......@@ -408,3 +408,4 @@ test('T14869', normal, compile,
['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
test('T14888', normal, compile,
['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
test('T14298', normal, compile_and_run, ['-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