Commit 0fac488c authored by bitonic's avatar bitonic Committed by Ben Gamari

Allow compilation of C/C++/ObjC/ObjC++ files with module from TH

The main goal is to easily allow the inline-c project (and
similar projects such as inline-java) to emit C/C++ files to
be compiled and linked with the current module.

Moreover, `addCStub` is removed, since it's quite fragile. Most
notably, the C stubs end up in the file generated by
`CodeOutput.outputForeignStubs`, which is tuned towards
generating a file for stubs coming from `capi` and Haskell-to-C
exports.

Reviewers: simonmar, austin, goldfire, facundominguez, dfeuer, bgamari

Reviewed By: dfeuer, bgamari

Subscribers: snowleopard, rwbarton, dfeuer, thomie, duncan, mboes

Differential Revision: https://phabricator.haskell.org/D3280
parent de62f587
...@@ -97,7 +97,7 @@ deSugar hsc_env ...@@ -97,7 +97,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_th_foreign_files = th_foreign_files_var,
tcg_fords = fords, tcg_fords = fords,
tcg_rules = rules, tcg_rules = rules,
tcg_vects = vects, tcg_vects = vects,
...@@ -180,8 +180,7 @@ deSugar hsc_env ...@@ -180,8 +180,7 @@ 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 ; foreign_files <- readIORef th_foreign_files_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,
...@@ -203,7 +202,8 @@ deSugar hsc_env ...@@ -203,7 +202,8 @@ 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_foreign_files = foreign_files,
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,
......
...@@ -36,6 +36,7 @@ import Control.Exception ...@@ -36,6 +36,7 @@ import Control.Exception
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.IO import System.IO
import Control.Monad (forM)
{- {-
************************************************************************ ************************************************************************
...@@ -50,12 +51,16 @@ codeOutput :: DynFlags ...@@ -50,12 +51,16 @@ codeOutput :: DynFlags
-> FilePath -> FilePath
-> ModLocation -> ModLocation
-> ForeignStubs -> ForeignStubs
-> [(ForeignSrcLang, String)]
-- ^ additional files to be compiled with with the C compiler
-> [InstalledUnitId] -> [InstalledUnitId]
-> Stream IO RawCmmGroup () -- Compiled C-- -> Stream IO RawCmmGroup () -- Compiled C--
-> IO (FilePath, -> IO (FilePath,
(Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})) (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
[(ForeignSrcLang, FilePath)]{-foreign_fps-})
codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
cmm_stream
= =
do { do {
-- Lint each CmmGroup as it goes past -- Lint each CmmGroup as it goes past
...@@ -82,6 +87,10 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream ...@@ -82,6 +87,10 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
} }
; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs ; 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 { ; case hscTarget dflags of {
HscAsm -> outputAsm dflags this_mod location filenm HscAsm -> outputAsm dflags this_mod location filenm
linted_cmm_stream; linted_cmm_stream;
...@@ -90,7 +99,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream ...@@ -90,7 +99,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
HscInterpreted -> panic "codeOutput: HscInterpreted"; HscInterpreted -> panic "codeOutput: HscInterpreted";
HscNothing -> panic "codeOutput: HscNothing" HscNothing -> panic "codeOutput: HscNothing"
} }
; return (filenm, stubs_exist) ; return (filenm, stubs_exist, foreign_fps)
} }
doOutput :: String -> (Handle -> IO a) -> IO a doOutput :: String -> (Handle -> IO a) -> IO a
...@@ -258,3 +267,15 @@ outputForeignStubs_help _fname "" _header _footer = return False ...@@ -258,3 +267,15 @@ outputForeignStubs_help _fname "" _header _footer = return False
outputForeignStubs_help fname doc_str header footer outputForeignStubs_help fname doc_str header footer
= do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n") = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
return True 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 extension
writeFile fp file_contents
return fp
...@@ -140,7 +140,7 @@ data Phase ...@@ -140,7 +140,7 @@ data Phase
| LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM
| CmmCpp -- pre-process Cmm source | CmmCpp -- pre-process Cmm source
| Cmm -- parse & compile Cmm code | Cmm -- parse & compile Cmm code
| MergeStub -- merge in the stub object file | MergeForeign -- merge in the foreign object files
-- The final phase is a pseudo-phase that tells the pipeline to stop. -- The final phase is a pseudo-phase that tells the pipeline to stop.
-- There is no runPhase case for it. -- There is no runPhase case for it.
...@@ -175,7 +175,7 @@ eqPhase LlvmLlc LlvmLlc = True ...@@ -175,7 +175,7 @@ eqPhase LlvmLlc LlvmLlc = True
eqPhase LlvmMangle LlvmMangle = True eqPhase LlvmMangle LlvmMangle = True
eqPhase CmmCpp CmmCpp = True eqPhase CmmCpp CmmCpp = True
eqPhase Cmm Cmm = True eqPhase Cmm Cmm = True
eqPhase MergeStub MergeStub = True eqPhase MergeForeign MergeForeign = True
eqPhase StopLn StopLn = True eqPhase StopLn StopLn = True
eqPhase Ccxx Ccxx = True eqPhase Ccxx Ccxx = True
eqPhase Cobjcxx Cobjcxx = True eqPhase Cobjcxx Cobjcxx = True
...@@ -216,8 +216,8 @@ nextPhase dflags p ...@@ -216,8 +216,8 @@ nextPhase dflags p
LlvmOpt -> LlvmLlc LlvmOpt -> LlvmLlc
LlvmLlc -> LlvmMangle LlvmLlc -> LlvmMangle
LlvmMangle -> As False LlvmMangle -> As False
SplitAs -> MergeStub SplitAs -> MergeForeign
As _ -> MergeStub As _ -> MergeForeign
Ccxx -> As False Ccxx -> As False
Cc -> As False Cc -> As False
Cobjc -> As False Cobjc -> As False
...@@ -225,7 +225,7 @@ nextPhase dflags p ...@@ -225,7 +225,7 @@ nextPhase dflags p
CmmCpp -> Cmm CmmCpp -> Cmm
Cmm -> maybeHCc Cmm -> maybeHCc
HCc -> As False HCc -> As False
MergeStub -> StopLn MergeForeign -> StopLn
StopLn -> panic "nextPhase: nothing after StopLn" StopLn -> panic "nextPhase: nothing after StopLn"
where maybeHCc = if platformUnregisterised (targetPlatform dflags) where maybeHCc = if platformUnregisterised (targetPlatform dflags)
then HCc then HCc
...@@ -289,7 +289,7 @@ phaseInputExt LlvmMangle = "lm_s" ...@@ -289,7 +289,7 @@ phaseInputExt LlvmMangle = "lm_s"
phaseInputExt SplitAs = "split_s" phaseInputExt SplitAs = "split_s"
phaseInputExt CmmCpp = "cmm" phaseInputExt CmmCpp = "cmm"
phaseInputExt Cmm = "cmmcpp" phaseInputExt Cmm = "cmmcpp"
phaseInputExt MergeStub = "o" phaseInputExt MergeForeign = "o"
phaseInputExt StopLn = "o" phaseInputExt StopLn = "o"
haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,
......
This diff is collapsed.
...@@ -1249,7 +1249,8 @@ hscWriteIface dflags iface no_change mod_summary = do ...@@ -1249,7 +1249,8 @@ hscWriteIface dflags iface no_change mod_summary = do
-- | Compile to hard-code. -- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
-> IO (FilePath, Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
-- ^ @Just f@ <=> _stub.c is f
hscGenHardCode hsc_env cgguts mod_summary output_filename = do hscGenHardCode hsc_env cgguts mod_summary output_filename = do
let CgGuts{ -- This is the last use of the ModGuts in a compilation. let CgGuts{ -- This is the last use of the ModGuts in a compilation.
-- From now on, we just use the bits we need. -- From now on, we just use the bits we need.
...@@ -1257,6 +1258,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do ...@@ -1257,6 +1258,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
cg_binds = core_binds, cg_binds = core_binds,
cg_tycons = tycons, cg_tycons = tycons,
cg_foreign = foreign_stubs0, cg_foreign = foreign_stubs0,
cg_foreign_files = foreign_files,
cg_dep_pkgs = dependencies, cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
...@@ -1303,11 +1305,11 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do ...@@ -1303,11 +1305,11 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
return a return a
rawcmms1 = Stream.mapM dump rawcmms0 rawcmms1 = Stream.mapM dump rawcmms0
(output_filename, (_stub_h_exists, stub_c_exists)) (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)
<- {-# SCC "codeOutput" #-} <- {-# SCC "codeOutput" #-}
codeOutput dflags this_mod output_filename location codeOutput dflags this_mod output_filename location
foreign_stubs dependencies rawcmms1 foreign_stubs foreign_files dependencies rawcmms1
return (output_filename, stub_c_exists) return (output_filename, stub_c_exists, foreign_fps)
hscInteractive :: HscEnv hscInteractive :: HscEnv
...@@ -1358,7 +1360,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do ...@@ -1358,7 +1360,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
-- lest we reproduce #11784. -- lest we reproduce #11784.
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
cmm_mod = mkModule (thisPackage dflags) mod_name cmm_mod = mkModule (thisPackage dflags) mod_name
_ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] rawCmms _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
rawCmms
return () return ()
where where
no_loc = ModLocation{ ml_hs_file = Just filename, no_loc = ModLocation{ ml_hs_file = Just filename,
......
...@@ -23,6 +23,7 @@ module HscTypes ( ...@@ -23,6 +23,7 @@ module HscTypes (
ModDetails(..), emptyModDetails, ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedModsVal(..), SptEntry(..), ImportedMods, ImportedModsVal(..), SptEntry(..),
ForeignSrcLang(..),
ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary, ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath, msHsFilePath, msHiFilePath, msObjFilePath,
...@@ -145,6 +146,7 @@ import ByteCodeTypes ...@@ -145,6 +146,7 @@ import ByteCodeTypes
import InteractiveEvalTypes ( Resume ) import InteractiveEvalTypes ( Resume )
import GHCi.Message ( Pipe ) import GHCi.Message ( Pipe )
import GHCi.RemoteTypes import GHCi.RemoteTypes
import GHC.ForeignSrcLang
import UniqFM import UniqFM
import HsSyn import HsSyn
...@@ -1224,6 +1226,8 @@ data ModGuts ...@@ -1224,6 +1226,8 @@ data ModGuts
-- See Note [Overall plumbing for rules] in Rules.hs -- See Note [Overall plumbing for rules] in Rules.hs
mg_binds :: !CoreProgram, -- ^ Bindings for this module mg_binds :: !CoreProgram, -- ^ Bindings for this module
mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module
mg_foreign_files :: ![(ForeignSrcLang, String)],
-- ^ Files to be compiled with the C compiler
mg_warns :: !Warnings, -- ^ Warnings declared in the module mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module mg_anns :: [Annotation], -- ^ Annotations declared in this module
mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
...@@ -1283,6 +1287,7 @@ data CgGuts ...@@ -1283,6 +1287,7 @@ data CgGuts
-- as part of the code-gen of tycons -- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
cg_foreign_files :: ![(ForeignSrcLang, String)],
cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to
-- generate #includes for C code gen -- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
......
...@@ -6,7 +6,7 @@ module PipelineMonad ( ...@@ -6,7 +6,7 @@ module PipelineMonad (
CompPipeline(..), evalP CompPipeline(..), evalP
, PhasePlus(..) , PhasePlus(..)
, PipeEnv(..), PipeState(..), PipelineOutput(..) , PipeEnv(..), PipeState(..), PipelineOutput(..)
, getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs
) where ) where
import MonadUtils import MonadUtils
...@@ -65,10 +65,10 @@ data PipeState = PipeState { ...@@ -65,10 +65,10 @@ data PipeState = PipeState {
maybe_loc :: Maybe ModLocation, maybe_loc :: Maybe ModLocation,
-- ^ the ModLocation. This is discovered during compilation, -- ^ the ModLocation. This is discovered during compilation,
-- in the Hsc phase where we read the module header. -- in the Hsc phase where we read the module header.
maybe_stub_o :: Maybe FilePath foreign_os :: [FilePath]
-- ^ the stub object. This is set by the Hsc phase if a stub -- ^ additional object files resulting from compiling foreign
-- object was created. The stub object will be joined with -- code. They come from two sources: foreign stubs, and
-- the main compilation object using "ld -r" at the end. -- add{C,Cxx,Objc,Objcxx}File from template haskell
} }
data PipelineOutput data PipelineOutput
...@@ -102,6 +102,6 @@ setModLocation :: ModLocation -> CompPipeline () ...@@ -102,6 +102,6 @@ setModLocation :: ModLocation -> CompPipeline ()
setModLocation loc = P $ \_env state -> setModLocation loc = P $ \_env state ->
return (state{ maybe_loc = Just loc }, ()) return (state{ maybe_loc = Just loc }, ())
setStubO :: FilePath -> CompPipeline () setForeignOs :: [FilePath] -> CompPipeline ()
setStubO stub_o = P $ \_env state -> setForeignOs os = P $ \_env state ->
return (state{ maybe_stub_o = Just stub_o }, ()) return (state{ foreign_os = os }, ())
...@@ -322,6 +322,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -322,6 +322,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_complete_sigs = complete_sigs , mg_complete_sigs = complete_sigs
, mg_deps = deps , mg_deps = deps
, mg_foreign = foreign_stubs , mg_foreign = foreign_stubs
, mg_foreign_files = foreign_files
, mg_hpc_info = hpc_info , mg_hpc_info = hpc_info
, mg_modBreaks = modBreaks , mg_modBreaks = modBreaks
}) })
...@@ -427,6 +428,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -427,6 +428,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
cg_tycons = alg_tycons, cg_tycons = alg_tycons,
cg_binds = all_tidy_binds, cg_binds = all_tidy_binds,
cg_foreign = add_spt_init_code foreign_stubs, cg_foreign = add_spt_init_code foreign_stubs,
cg_foreign_files = foreign_files,
cg_dep_pkgs = map fst $ dep_pkgs deps, cg_dep_pkgs = map fst $ dep_pkgs deps,
cg_hpc_info = hpc_info, cg_hpc_info = hpc_info,
cg_modBreaks = modBreaks, cg_modBreaks = modBreaks,
......
...@@ -214,7 +214,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this ...@@ -214,7 +214,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_foreign_files_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 ;
...@@ -229,7 +229,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this ...@@ -229,7 +229,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_foreign_files = th_foreign_files_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,
......
...@@ -54,6 +54,7 @@ module TcRnTypes( ...@@ -54,6 +54,7 @@ module TcRnTypes(
ThStage(..), SpliceType(..), PendingStuff(..), ThStage(..), SpliceType(..), PendingStuff(..),
topStage, topAnnStage, topSpliceStage, topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel, ThLevel, impLevel, outerLevel, thLevel,
ForeignSrcLang(..),
-- Arrows -- Arrows
ArrowCtxt(..), ArrowCtxt(..),
...@@ -471,7 +472,6 @@ data FrontendResult ...@@ -471,7 +472,6 @@ data FrontendResult
-- since that will actually say the specific interface you -- since that will actually say the specific interface you
-- want to track (and recompile if it changes) -- want to track (and recompile if it changes)
-- | 'TcGblEnv' describes the top-level of the module at the -- | 'TcGblEnv' describes the top-level of the module at the
-- point at which the typechecker is finished work. -- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer -- It is this structure that is handed on to the desugarer
...@@ -603,8 +603,8 @@ data TcGblEnv ...@@ -603,8 +603,8 @@ 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], tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)],
-- ^ C stubs from addCStub -- ^ Foreign files emitted from TH.
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,16 +909,9 @@ instance TH.Quasi TcM where ...@@ -909,16 +909,9 @@ 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 qAddForeignFile lang str = do
l <- getSrcSpanM var <- fmap tcg_th_foreign_files getGblEnv
r <- case l of updTcRef var ((lang, str) :)
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
...@@ -1111,7 +1104,7 @@ handleTHMessage msg = case msg of ...@@ -1111,7 +1104,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 AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang 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)
......
{-# LANGUAGE DeriveGeneric #-}
module GHC.ForeignSrcLang.Type
( ForeignSrcLang(..)
) where
import GHC.Generics (Generic)
data ForeignSrcLang
= LangC | LangCxx | LangObjc | LangObjcxx
deriving (Eq, Show, Generic)
...@@ -32,6 +32,7 @@ Library ...@@ -32,6 +32,7 @@ Library
exposed-modules: exposed-modules:
GHC.LanguageExtensions.Type GHC.LanguageExtensions.Type
GHC.ForeignSrcLang.Type
GHC.Lexeme GHC.Lexeme
build-depends: base >= 4.7 && < 4.11 build-depends: base >= 4.7 && < 4.11
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | See @GHC.LanguageExtensions@ for an explanation
-- on why this is needed
module GHC.ForeignSrcLang
( module GHC.ForeignSrcLang.Type
) where
import Data.Binary
import GHC.ForeignSrcLang.Type
instance Binary ForeignSrcLang
...@@ -39,6 +39,7 @@ Library ...@@ -39,6 +39,7 @@ Library
GHC.LanguageExtensions GHC.LanguageExtensions
GHC.PackageDb GHC.PackageDb
GHC.Serialized GHC.Serialized
GHC.ForeignSrcLang
build-depends: base >= 4.7 && < 4.11, build-depends: base >= 4.7 && < 4.11,
binary == 0.8.*, binary == 0.8.*,
......
...@@ -30,6 +30,7 @@ import GHCi.TH.Binary () ...@@ -30,6 +30,7 @@ import GHCi.TH.Binary ()
import GHCi.BreakArray import GHCi.BreakArray
import GHC.LanguageExtensions import GHC.LanguageExtensions
import GHC.ForeignSrcLang
import GHC.Fingerprint import GHC.Fingerprint
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
...@@ -244,7 +245,7 @@ data THMessage a where ...@@ -244,7 +245,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 ()) AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
IsExtEnabled :: Extension -> THMessage (THResult Bool) IsExtEnabled :: Extension -> THMessage (THResult Bool)
ExtsEnabled :: THMessage (THResult [Extension]) ExtsEnabled :: THMessage (THResult [Extension])
...@@ -281,7 +282,7 @@ getTHMessage = do ...@@ -281,7 +282,7 @@ getTHMessage = do
15 -> THMsg <$> EndRecover <$> get 15 -> THMsg <$> EndRecover <$> get
16 -> return (THMsg RunTHDone) 16 -> return (THMsg RunTHDone)
17 -> THMsg <$> AddModFinalizer <$> get 17 -> THMsg <$> AddModFinalizer <$> get
_ -> THMsg <$> AddCStub <$> get _ -> THMsg <$> (AddForeignFile <$> get <*> get)
putTHMessage :: THMessage a -> Put putTHMessage :: THMessage a -> Put
putTHMessage m = case m of putTHMessage m = case m of
...@@ -303,7 +304,7 @@ putTHMessage m = case m of ...@@ -303,7 +304,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 AddForeignFile lang a -> putWord8 18 >> put lang >> put a
data EvalOpts = EvalOpts data EvalOpts = EvalOpts
......
...@@ -193,7 +193,7 @@ instance TH.Quasi GHCiQ where ...@@ -193,7 +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) qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
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 ->
......
...@@ -75,6 +75,7 @@ library ...@@ -75,6 +75,7 @@ library
deepseq == 1.4.*, deepseq == 1.4.*,
filepath == 1.4.*, filepath == 1.4.*,
ghc-boot == @ProjectVersionMunged@, ghc-boot == @ProjectVersionMunged@,
ghc-boot-th == @ProjectVersionMunged@,
template-haskell == 2.12.*, template-haskell == 2.12.*,
transformers == 0.5.* transformers == 0.5.*
......
...@@ -27,6 +27,7 @@ module Language.Haskell.TH.Syntax ...@@ -27,6 +27,7 @@ module Language.Haskell.TH.Syntax
( module Language.Haskell.TH.Syntax ( module Language.Haskell.TH.Syntax
-- * Language extensions -- * Language extensions
, module Language.Haskell.TH.LanguageExtensions , module Language.Haskell.TH.LanguageExtensions
, ForeignSrcLang(..)
) where ) where
import Data.Data hiding (Fixity(..)) import Data.Data hiding (Fixity(..))
...@@ -40,6 +41,7 @@ import Data.Word ...@@ -40,6 +41,7 @@ import Data.Word
import Data.Ratio import Data.Ratio
import GHC.Generics ( Generic ) import GHC.Generics ( Generic )
import GHC.Lexeme ( startsVarSym, startsVarId ) import GHC.Lexeme ( startsVarSym, startsVarId )
import GHC.ForeignSrcLang.Type
import Language.Haskell.TH.LanguageExtensions import Language.Haskell.TH.LanguageExtensions
import Numeric.Natural import Numeric.Natural
...@@ -92,7 +94,7 @@ class Monad m => Quasi m where ...@@ -92,7 +94,7 @@ class Monad m => Quasi m where
qAddTopDecls :: [Dec] -> m () qAddTopDecls :: [Dec] -> m ()
qAddCStub :: String -> m () qAddForeignFile :: ForeignSrcLang -> String -> m ()
qAddModFinalizer :: Q () -> m () qAddModFinalizer :: Q () -> m ()
...@@ -133,7 +135,7 @@ instance Quasi IO where ...@@ -133,7 +135,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" qAddForeignFile _ _ = badIO "addForeignFile"
qAddModFinalizer _ = badIO "addModFinalizer" qAddModFinalizer _ = badIO "addModFinalizer"
qGetQ = badIO "getQ" qGetQ = badIO "getQ"
qPutQ _ = badIO "putQ" qPutQ _ = badIO "putQ"
...@@ -459,24 +461,25 @@ addDependentFile fp = Q (qAddDependentFile fp) ...@@ -459,24 +461,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 -- | Emit a foreign file which will be compiled and linked to the object for
-- object file of the current module. -- 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
-- be also applied to the C compiler invocation that will compile them.
-- --
-- Compilation errors in the given string are reported next to the line of the -- Note that for non-C languages (for example C++) @extern "C"@ directives
-- enclosing splice. -- must be used to get symbols that we can access from Haskell.
-- --
-- The accuracy of the error location can be improved by adding -- To get better errors, it is reccomended to use #line pragmas when
-- #line pragmas in the argument. e.g. -- emitting C files, e.g.
-- --
-- > {-# LANGUAGE CPP #-}