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
tcg_imp_specs = imp_specs,
tcg_dependent_files = dependent_files,
tcg_ev_binds = ev_binds,
tcg_th_cstubs = th_cstubs_var,
tcg_th_foreign_files = th_foreign_files_var,
tcg_fords = fords,
tcg_rules = rules,
tcg_vects = vects,
......@@ -180,8 +180,7 @@ deSugar hsc_env
-- past desugaring. See Note [Identity versus semantic module].
; MASSERT( id_mod == mod )
; cstubs <- readIORef th_cstubs_var
; let ds_fords' = foldl' appendStubC ds_fords (map text cstubs)
; foreign_files <- readIORef th_foreign_files_var
; let mod_guts = ModGuts {
mg_module = mod,
......@@ -203,7 +202,8 @@ deSugar hsc_env
mg_patsyns = patsyns,
mg_rules = ds_rules_for_imps,
mg_binds = ds_binds,
mg_foreign = ds_fords',
mg_foreign = ds_fords,
mg_foreign_files = foreign_files,
mg_hpc_info = ds_hpc_info,
mg_modBreaks = modBreaks,
mg_vect_decls = ds_vects,
......
......@@ -36,6 +36,7 @@ import Control.Exception
import System.Directory
import System.FilePath
import System.IO
import Control.Monad (forM)
{-
************************************************************************
......@@ -50,12 +51,16 @@ codeOutput :: DynFlags
-> FilePath
-> ModLocation
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-- ^ additional files to be compiled with with the C compiler
-> [InstalledUnitId]
-> Stream IO RawCmmGroup () -- Compiled C--
-> 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 {
-- Lint each CmmGroup as it goes past
......@@ -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
; 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;
......@@ -90,7 +99,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
HscInterpreted -> panic "codeOutput: HscInterpreted";
HscNothing -> panic "codeOutput: HscNothing"
}
; return (filenm, stubs_exist)
; return (filenm, stubs_exist, foreign_fps)
}
doOutput :: String -> (Handle -> IO a) -> IO a
......@@ -258,3 +267,15 @@ outputForeignStubs_help _fname "" _header _footer = return False
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 extension
writeFile fp file_contents
return fp
......@@ -140,7 +140,7 @@ data Phase
| LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM
| CmmCpp -- pre-process Cmm source
| 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.
-- There is no runPhase case for it.
......@@ -175,7 +175,7 @@ eqPhase LlvmLlc LlvmLlc = True
eqPhase LlvmMangle LlvmMangle = True
eqPhase CmmCpp CmmCpp = True
eqPhase Cmm Cmm = True
eqPhase MergeStub MergeStub = True
eqPhase MergeForeign MergeForeign = True
eqPhase StopLn StopLn = True
eqPhase Ccxx Ccxx = True
eqPhase Cobjcxx Cobjcxx = True
......@@ -216,8 +216,8 @@ nextPhase dflags p
LlvmOpt -> LlvmLlc
LlvmLlc -> LlvmMangle
LlvmMangle -> As False
SplitAs -> MergeStub
As _ -> MergeStub
SplitAs -> MergeForeign
As _ -> MergeForeign
Ccxx -> As False
Cc -> As False
Cobjc -> As False
......@@ -225,7 +225,7 @@ nextPhase dflags p
CmmCpp -> Cmm
Cmm -> maybeHCc
HCc -> As False
MergeStub -> StopLn
MergeForeign -> StopLn
StopLn -> panic "nextPhase: nothing after StopLn"
where maybeHCc = if platformUnregisterised (targetPlatform dflags)
then HCc
......@@ -289,7 +289,7 @@ phaseInputExt LlvmMangle = "lm_s"
phaseInputExt SplitAs = "split_s"
phaseInputExt CmmCpp = "cmm"
phaseInputExt Cmm = "cmmcpp"
phaseInputExt MergeStub = "o"
phaseInputExt MergeForeign = "o"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,
......
......@@ -86,7 +86,7 @@ preprocess :: HscEnv
preprocess hsc_env (filename, mb_phase) =
ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-}
Nothing Temporary Nothing{-no ModLocation-} []{-no foreign objects-}
-- ---------------------------------------------------------------------------
......@@ -177,7 +177,7 @@ compileOne' m_tc_result mHscMessage
(Just basename)
Persistent
(Just location)
Nothing
[]
o_time <- getModificationUTCTime object_filename
let linkable = LM o_time this_mod [DotO object_filename]
return hmi0 { hm_linkable = Just linkable }
......@@ -212,7 +212,7 @@ compileOne' m_tc_result mHscMessage
(Just basename)
Persistent
(Just location)
Nothing
[]
-- The object filename comes from the ModLocation
o_time <- getModificationUTCTime object_filename
let linkable = LM o_time this_mod [DotO object_filename]
......@@ -269,22 +269,35 @@ compileOne' m_tc_result mHscMessage
_ -> False
-----------------------------------------------------------------------------
-- stub .h and .c files (for foreign export support)
-- stub .h and .c files (for foreign export support), and cc files.
-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
-- The object file created by compiling the _stub.c file is put into a
-- temporary file, which will be later combined with the main .o file
-- (see the MergeStubs phase).
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = do
(_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing
Temporary Nothing{-no ModLocation-} Nothing
-- (see the MergeForeigns phase).
--
-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
-- from TH, that are then compiled and linked to the module. This is
-- useful to implement facilities such as inline-c.
compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compileForeign hsc_env lang stub_c = do
let phase = case lang of
LangC -> Cc
LangCxx -> Ccxx
LangObjc -> Cobjc
LangObjcxx -> Cobjcxx
(_, stub_o) <- runPipeline StopLn hsc_env
(stub_c, Just (RealPhase phase))
Nothing Temporary Nothing{-no ModLocation-} []
return stub_o
compileStub :: HscEnv -> FilePath -> IO FilePath
compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
compileEmptyStub dflags hsc_env basename location mod_name = do
-- To maintain the invariant that every Haskell file
......@@ -302,7 +315,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
(Just basename)
Persistent
(Just location)
Nothing
[]
return ()
-- ---------------------------------------------------------------------------
......@@ -530,7 +543,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
( _, out_file) <- runPipeline stop_phase' hsc_env
(src, fmap RealPhase mb_phase) Nothing output
Nothing{-no ModLocation-} Nothing
Nothing{-no ModLocation-} []
return out_file
......@@ -566,10 +579,10 @@ runPipeline
-> Maybe FilePath -- ^ original basename (if different from ^^^)
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
-> [FilePath] -- ^ foreign objects
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
mb_basename output maybe_loc foreign_os
= do let
dflags0 = hsc_dflags hsc_env0
......@@ -622,7 +635,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
debugTraceMsg dflags 4 (text "Running the pipeline")
r <- runPipeline' start_phase hsc_env env input_fn
maybe_loc maybe_stub_o
maybe_loc foreign_os
-- If we are compiling a Haskell module, and doing
-- -dynamic-too, but couldn't do the -dynamic-too fast
......@@ -636,7 +649,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
let dflags' = dynamicTooMkDynamicDynFlags dflags
hsc_env' <- newHscEnv dflags'
_ <- runPipeline' start_phase hsc_env' env input_fn
maybe_loc maybe_stub_o
maybe_loc foreign_os
return ()
return r
......@@ -646,13 +659,13 @@ runPipeline'
-> PipeEnv
-> FilePath -- ^ Input filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
-> [FilePath] -- ^ foreign objects, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline' start_phase hsc_env env input_fn
maybe_loc maybe_stub_o
maybe_loc foreign_os
= do
-- Execute the pipeline...
let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
evalP (pipeLoop start_phase input_fn) env state
......@@ -769,7 +782,7 @@ getOutputFilename stop_phase output basename dflags next_phase maybe_location
keep_bc = gopt Opt_KeepLlvmFiles dflags
myPhaseInputExt HCc = hcsuf
myPhaseInputExt MergeStub = osuf
myPhaseInputExt MergeForeign = osuf
myPhaseInputExt StopLn = osuf
myPhaseInputExt other = phaseInputExt other
......@@ -1049,12 +1062,12 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
PipeState{hsc_env=hsc_env'} <- getPipeState
(outputFilename, mStub) <- liftIO $ hscGenHardCode hsc_env' cgguts mod_summary output_fn
case mStub of
Nothing -> return ()
Just stub_c ->
do stub_o <- liftIO $ compileStub hsc_env' stub_c
setStubO stub_o
(outputFilename, mStub, foreign_files) <- liftIO $
hscGenHardCode hsc_env' cgguts mod_summary output_fn
stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
foreign_os <- liftIO $
mapM (uncurry (compileForeign hsc_env')) foreign_files
setForeignOs (maybe [] return stub_o ++ foreign_os)
return (RealPhase next_phase, outputFilename)
......@@ -1263,7 +1276,7 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
let cmdline_include_paths = includePaths dflags
let pic_c_flags = picCCOpts dflags
next_phase <- maybeMergeStub
next_phase <- maybeMergeForeign
output_fn <- phaseOutputFilename next_phase
-- we create directories for the object file, because it
......@@ -1310,7 +1323,7 @@ runPhase (RealPhase (As with_cpp)) input_fn dflags
-- of assembly files)
runPhase (RealPhase SplitAs) _input_fn dflags
= do
-- we'll handle the stub_o file in this phase, so don't MergeStub,
-- we'll handle the stub_o file in this phase, so don't MergeForeign,
-- just jump straight to StopLn afterwards.
let next_phase = StopLn
output_fn <- phaseOutputFilename next_phase
......@@ -1366,7 +1379,8 @@ runPhase (RealPhase SplitAs) _input_fn dflags
liftIO $ mapM_ assemble_file [1..n]
-- Note [pipeline-split-init]
-- If we have a stub file, it may contain constructor
-- If we have a stub file -- which will be part of foreign_os --
-- it may contain constructor
-- functions for initialisation of this module. We can't
-- simply leave the stub as a separate object file, because it
-- will never be linked in: nothing refers to it. We need to
......@@ -1377,16 +1391,18 @@ runPhase (RealPhase SplitAs) _input_fn dflags
-- To that end, we make a DANGEROUS ASSUMPTION here: the data
-- that needs to be initialised is all in the FIRST split
-- object. See Note [codegen-split-init].
PipeState{maybe_stub_o} <- getPipeState
case maybe_stub_o of
Nothing -> return ()
Just stub_o -> liftIO $ do
tmp_split_1 <- newTempName dflags osuf
let split_1 = split_obj 1
copyFile split_1 tmp_split_1
removeFile split_1
joinObjectFiles dflags [tmp_split_1, stub_o] split_1
--
-- We also merge in all the foreign objects since we're at it.
PipeState{foreign_os} <- getPipeState
if null foreign_os
then return ()
else liftIO $ do
tmp_split_1 <- newTempName dflags osuf
let split_1 = split_obj 1
copyFile split_1 tmp_split_1
removeFile split_1
joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1
-- join them into a single .o file
liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
......@@ -1524,27 +1540,26 @@ runPhase (RealPhase LlvmMangle) input_fn dflags
-----------------------------------------------------------------------------
-- merge in stub objects
runPhase (RealPhase MergeStub) input_fn dflags
runPhase (RealPhase MergeForeign) input_fn dflags
= do
PipeState{maybe_stub_o} <- getPipeState
PipeState{foreign_os} <- getPipeState
output_fn <- phaseOutputFilename StopLn
liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
case maybe_stub_o of
Nothing ->
panic "runPhase(MergeStub): no stub"
Just stub_o -> do
liftIO $ joinObjectFiles dflags [input_fn, stub_o] output_fn
if null foreign_os
then panic "runPhase(MergeForeign): no foreign objects"
else do
liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
return (RealPhase StopLn, output_fn)
-- warning suppression
runPhase (RealPhase other) _input_fn _dflags =
panic ("runPhase: don't know how to run phase " ++ show other)
maybeMergeStub :: CompPipeline Phase
maybeMergeStub
maybeMergeForeign :: CompPipeline Phase
maybeMergeForeign
= do
PipeState{maybe_stub_o} <- getPipeState
if isJust maybe_stub_o then return MergeStub else return StopLn
PipeState{foreign_os} <- getPipeState
if null foreign_os then return StopLn else return MergeForeign
getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
getLocation src_flavour mod_name = do
......
......@@ -1249,7 +1249,8 @@ hscWriteIface dflags iface no_change mod_summary = do
-- | Compile to hard-code.
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
let CgGuts{ -- This is the last use of the ModGuts in a compilation.
-- From now on, we just use the bits we need.
......@@ -1257,6 +1258,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
cg_binds = core_binds,
cg_tycons = tycons,
cg_foreign = foreign_stubs0,
cg_foreign_files = foreign_files,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
......@@ -1303,11 +1305,11 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do
return a
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" #-}
codeOutput dflags this_mod output_filename location
foreign_stubs dependencies rawcmms1
return (output_filename, stub_c_exists)
foreign_stubs foreign_files dependencies rawcmms1
return (output_filename, stub_c_exists, foreign_fps)
hscInteractive :: HscEnv
......@@ -1358,7 +1360,8 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
-- lest we reproduce #11784.
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
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 ()
where
no_loc = ModLocation{ ml_hs_file = Just filename,
......
......@@ -23,6 +23,7 @@ module HscTypes (
ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedModsVal(..), SptEntry(..),
ForeignSrcLang(..),
ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
......@@ -145,6 +146,7 @@ import ByteCodeTypes
import InteractiveEvalTypes ( Resume )
import GHCi.Message ( Pipe )
import GHCi.RemoteTypes
import GHC.ForeignSrcLang
import UniqFM
import HsSyn
......@@ -1224,6 +1226,8 @@ 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)],
-- ^ Files to be compiled with the C compiler
mg_warns :: !Warnings, -- ^ Warnings declared in the module
mg_anns :: [Annotation], -- ^ Annotations declared in this module
mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches
......@@ -1283,6 +1287,7 @@ data CgGuts
-- as part of the code-gen of tycons
cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs
cg_foreign_files :: ![(ForeignSrcLang, String)],
cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to
-- generate #includes for C code gen
cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information
......
......@@ -6,7 +6,7 @@ module PipelineMonad (
CompPipeline(..), evalP
, PhasePlus(..)
, PipeEnv(..), PipeState(..), PipelineOutput(..)
, getPipeEnv, getPipeState, setDynFlags, setModLocation, setStubO
, getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs
) where
import MonadUtils
......@@ -65,10 +65,10 @@ data PipeState = PipeState {
maybe_loc :: Maybe ModLocation,
-- ^ the ModLocation. This is discovered during compilation,
-- in the Hsc phase where we read the module header.
maybe_stub_o :: Maybe FilePath
-- ^ the stub object. This is set by the Hsc phase if a stub
-- object was created. The stub object will be joined with
-- the main compilation object using "ld -r" at the end.
foreign_os :: [FilePath]
-- ^ additional object files resulting from compiling foreign
-- code. They come from two sources: foreign stubs, and
-- add{C,Cxx,Objc,Objcxx}File from template haskell
}
data PipelineOutput
......@@ -102,6 +102,6 @@ setModLocation :: ModLocation -> CompPipeline ()
setModLocation loc = P $ \_env state ->
return (state{ maybe_loc = Just loc }, ())
setStubO :: FilePath -> CompPipeline ()
setStubO stub_o = P $ \_env state ->
return (state{ maybe_stub_o = Just stub_o }, ())
setForeignOs :: [FilePath] -> CompPipeline ()
setForeignOs os = P $ \_env state ->
return (state{ foreign_os = os }, ())
......@@ -322,6 +322,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_complete_sigs = complete_sigs
, mg_deps = deps
, mg_foreign = foreign_stubs
, mg_foreign_files = foreign_files
, mg_hpc_info = hpc_info
, mg_modBreaks = modBreaks
})
......@@ -427,6 +428,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
cg_tycons = alg_tycons,
cg_binds = all_tidy_binds,
cg_foreign = add_spt_init_code foreign_stubs,
cg_foreign_files = foreign_files,
cg_dep_pkgs = map fst $ dep_pkgs deps,
cg_hpc_info = hpc_info,
cg_modBreaks = modBreaks,
......
......@@ -214,7 +214,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
dependent_files_var <- newIORef [] ;
static_wc_var <- newIORef emptyWC ;
th_topdecls_var <- newIORef [] ;
th_cstubs_var <- newIORef [] ;
th_foreign_files_var <- newIORef [] ;
th_topnames_var <- newIORef emptyNameSet ;
th_modfinalizers_var <- newIORef [] ;
th_state_var <- newIORef Map.empty ;
......@@ -229,7 +229,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
gbl_env = TcGblEnv {
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_modfinalizers = th_modfinalizers_var,
tcg_th_state = th_state_var,
......
......@@ -54,6 +54,7 @@ module TcRnTypes(
ThStage(..), SpliceType(..), PendingStuff(..),
topStage, topAnnStage, topSpliceStage,
ThLevel, impLevel, outerLevel, thLevel,
ForeignSrcLang(..),
-- Arrows
ArrowCtxt(..),
......@@ -471,7 +472,6 @@ data FrontendResult
-- since that will actually say the specific interface you
-- want to track (and recompile if it changes)
-- | 'TcGblEnv' describes the top-level of the module at the
-- point at which the typechecker is finished work.
-- It is this structure that is handed on to the desugarer
......@@ -603,8 +603,8 @@ data TcGblEnv
tcg_th_topdecls :: TcRef [LHsDecl RdrName],
-- ^ Top-level declarations from addTopDecls
tcg_th_cstubs :: TcRef [String],
-- ^ C stubs from addCStub
tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)],
-- ^ Foreign files emitted from TH.
tcg_th_topnames :: TcRef NameSet,
-- ^ Exact names bound in top-level declarations in tcg_th_topdecls
......
......@@ -909,16 +909,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.")
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] ++)
qAddForeignFile lang str = do
var <- fmap tcg_th_foreign_files getGblEnv
updTcRef var ((lang, str) :)
qAddModFinalizer fin = do
r <- liftIO $ mkRemoteRef fin
......@@ -1111,7 +1104,7 @@ handleTHMessage msg = case msg of
hsc_env <- env_top <$> getEnv
wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
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
ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
_ -> 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
exposed-modules:
GHC.LanguageExtensions.Type
GHC.ForeignSrcLang.Type
GHC.Lexeme
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
GHC.LanguageExtensions
GHC.PackageDb
GHC.Serialized
GHC.ForeignSrcLang
build-depends: base >= 4.7 && < 4.11,
binary == 0.8.*,
......
......@@ -30,6 +30,7 @@ import GHCi.TH.Binary ()
import GHCi.BreakArray
import GHC.LanguageExtensions
import GHC.ForeignSrcLang
import GHC.Fingerprint
import Control.Concurrent