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

25 files changed, 221 insertions, 160 deletions

diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index f3ad8dc61b..6c939d4f79 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -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,
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index df9b7f31f3..7c6dbdab53 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -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
diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index 57b2417100..a59c452788 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -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,
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 57a50827b6..1549722af4 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 839ecca8ee..ebb9420d4b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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,
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 793839a510..4ba9d440ee 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -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
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
index 614c4fa30f..e0904b8ad3 100644
--- a/compiler/main/PipelineMonad.hs
+++ b/compiler/main/PipelineMonad.hs
@@ -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 }, ())
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index 2e603a64e4..26cee48f18 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -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,
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index cb90ba556a..0e5e07d44d 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -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,
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 1adf16058a..48c9c3577f 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -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
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index e5904943f7..8e9fd2253a 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -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)
diff --git a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
new file mode 100644
index 0000000000..f6c1a2e47a
--- /dev/null
+++ b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveGeneric #-}
+module GHC.ForeignSrcLang.Type
+  ( ForeignSrcLang(..)
+  ) where
+
+import GHC.Generics (Generic)
+
+data ForeignSrcLang
+  = LangC | LangCxx | LangObjc | LangObjcxx
+  deriving (Eq, Show, Generic)
diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal.in b/libraries/ghc-boot-th/ghc-boot-th.cabal.in
index 50b07db49d..17b25aa432 100644
--- a/libraries/ghc-boot-th/ghc-boot-th.cabal.in
+++ b/libraries/ghc-boot-th/ghc-boot-th.cabal.in
@@ -32,6 +32,7 @@ Library
 
     exposed-modules:
             GHC.LanguageExtensions.Type
+            GHC.ForeignSrcLang.Type
             GHC.Lexeme
 
     build-depends: base       >= 4.7 && < 4.11
diff --git a/libraries/ghc-boot/GHC/ForeignSrcLang.hs b/libraries/ghc-boot/GHC/ForeignSrcLang.hs
new file mode 100644
index 0000000000..9ca4f04cf7
--- /dev/null
+++ b/libraries/ghc-boot/GHC/ForeignSrcLang.hs
@@ -0,0 +1,12 @@
+{-# 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
diff --git a/libraries/ghc-boot/ghc-boot.cabal.in b/libraries/ghc-boot/ghc-boot.cabal.in
index 772b92ccdd..11febb4ac0 100644
--- a/libraries/ghc-boot/ghc-boot.cabal.in
+++ b/libraries/ghc-boot/ghc-boot.cabal.in
@@ -39,6 +39,7 @@ Library
             GHC.LanguageExtensions
             GHC.PackageDb
             GHC.Serialized
+            GHC.ForeignSrcLang
 
     build-depends: base       >= 4.7 && < 4.11,
                    binary     == 0.8.*,
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 37db0627e1..81de2fbd21 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -30,6 +30,7 @@ import GHCi.TH.Binary ()
 import GHCi.BreakArray
 
 import GHC.LanguageExtensions
+import GHC.ForeignSrcLang
 import GHC.Fingerprint
 import Control.Concurrent
 import Control.Exception
@@ -244,7 +245,7 @@ data THMessage a where
   AddDependentFile :: FilePath -> THMessage (THResult ())
   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
-  AddCStub :: String -> THMessage (THResult ())
+  AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
   ExtsEnabled :: THMessage (THResult [Extension])
 
@@ -281,7 +282,7 @@ getTHMessage = do
     15 -> THMsg <$> EndRecover <$> get
     16 -> return (THMsg RunTHDone)
     17 -> THMsg <$> AddModFinalizer <$> get
-    _  -> THMsg <$> AddCStub <$> get
+    _  -> THMsg <$> (AddForeignFile <$> get <*> get)
 
 putTHMessage :: THMessage a -> Put
 putTHMessage m = case m of
@@ -303,7 +304,7 @@ putTHMessage m = case m of
   EndRecover a                -> putWord8 15 >> put a
   RunTHDone                   -> putWord8 16
   AddModFinalizer a           -> putWord8 17 >> put a
-  AddCStub a                  -> putWord8 18 >> put a
+  AddForeignFile lang a       -> putWord8 18 >> put lang >> put a
 
 
 data EvalOpts = EvalOpts
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 8cb9accc5e..1b08501580 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -193,7 +193,7 @@ instance TH.Quasi GHCiQ where
   qRunIO m = GHCiQ $ \s -> fmap (,s) m
   qAddDependentFile file = ghcCmd (AddDependentFile file)
   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)) >>=
                          ghcCmd . AddModFinalizer
   qGetQ = GHCiQ $ \s ->
diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in
index 631eed7190..d15da5a0f5 100644
--- a/libraries/ghci/ghci.cabal.in
+++ b/libraries/ghci/ghci.cabal.in
@@ -75,6 +75,7 @@ library
         deepseq          == 1.4.*,
         filepath         == 1.4.*,
         ghc-boot         == @ProjectVersionMunged@,
+        ghc-boot-th      == @ProjectVersionMunged@,
         template-haskell == 2.12.*,
         transformers     == 0.5.*
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index c531eeffd7..466834a9a4 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -27,6 +27,7 @@ module Language.Haskell.TH.Syntax
     ( module Language.Haskell.TH.Syntax
       -- * Language extensions
     , module Language.Haskell.TH.LanguageExtensions
+    , ForeignSrcLang(..)
     ) where
 
 import Data.Data hiding (Fixity(..))
@@ -40,6 +41,7 @@ import Data.Word
 import Data.Ratio
 import GHC.Generics     ( Generic )
 import GHC.Lexeme       ( startsVarSym, startsVarId )
+import GHC.ForeignSrcLang.Type
 import Language.Haskell.TH.LanguageExtensions
 import Numeric.Natural
 
@@ -92,7 +94,7 @@ class Monad m => Quasi m where
 
   qAddTopDecls :: [Dec] -> m ()
 
-  qAddCStub :: String -> m ()
+  qAddForeignFile :: ForeignSrcLang -> String -> m ()
 
   qAddModFinalizer :: Q () -> m ()
 
@@ -133,7 +135,7 @@ instance Quasi IO where
   qRecover _ _          = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _   = badIO "addDependentFile"
   qAddTopDecls _        = badIO "addTopDecls"
-  qAddCStub    _        = badIO "addCStub"
+  qAddForeignFile _ _   = badIO "addForeignFile"
   qAddModFinalizer _    = badIO "addModFinalizer"
   qGetQ                 = badIO "getQ"
   qPutQ _               = badIO "putQ"
@@ -459,24 +461,25 @@ addDependentFile fp = Q (qAddDependentFile fp)
 addTopDecls :: [Dec] -> Q ()
 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.
+-- | 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
+-- 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
--- enclosing splice.
+-- Note that for non-C languages (for example C++) @extern "C"@ directives
+-- must be used to get symbols that we can access from Haskell.
 --
--- The accuracy of the error location can be improved by adding
--- #line pragmas in the argument. e.g.
+-- To get better errors, it is reccomended to use #line pragmas when
+-- emitting C files, e.g.
 --
 -- > {-# LANGUAGE CPP #-}
 -- > ...
--- > addCStub $ unlines
+-- > addForeignFile LangC $ unlines
 -- >   [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
 -- >   , ...
 -- >   ]
---
-addCStub :: String -> Q ()
-addCStub str = Q (qAddCStub str)
+addForeignFile :: ForeignSrcLang -> String -> Q ()
+addForeignFile lang str = Q (qAddForeignFile lang str)
 
 -- | 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.
@@ -521,7 +524,7 @@ instance Quasi Q where
   qRunIO              = runIO
   qAddDependentFile   = addDependentFile
   qAddTopDecls        = addTopDecls
-  qAddCStub           = addCStub
+  qAddForeignFile     = addForeignFile
   qAddModFinalizer    = addModFinalizer
   qGetQ               = getQ
   qPutQ               = putQ
diff --git a/testsuite/tests/th/T13366.hs b/testsuite/tests/th/T13366.hs
new file mode 100644
index 0000000000..2573235a01
--- /dev/null
+++ b/testsuite/tests/th/T13366.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -optc-DA_MACRO=1 #-}
+
+import Language.Haskell.TH.Syntax
+import System.IO (hFlush, stdout)
+
+foreign import ccall fc :: Int -> IO Int
+
+do addForeignFile LangC $ unlines
+     [ "#include <stdio.h>"
+     , "int fc(int x) {"
+     , "  printf(\"calling f(%d)\\n\",x);"
+     , "  fflush(stdout);"
+     , "  return A_MACRO + x;"
+     , "}"
+     ]
+   return []
+
+foreign import ccall fcxx :: Int -> IO Int
+
+do addForeignFile LangCxx $ unlines
+     [ "#include <iostream>"
+     , "extern \"C\" {"
+     , "  int fcxx(int x) {"
+     , "    std::cout << \"calling fcxx(\" << x << \")\" << std::endl;"
+     , "    std::cout.flush();"
+     , "    return A_MACRO + x;"
+     , "  }"
+     , "}"
+     ]
+   return []
+
+main :: IO ()
+main = do
+  fc 2 >>= print
+  hFlush stdout
+  fcxx 5 >>= print
+  hFlush stdout
diff --git a/testsuite/tests/th/T13366.stdout b/testsuite/tests/th/T13366.stdout
new file mode 100644
index 0000000000..16cfeeb9fa
--- /dev/null
+++ b/testsuite/tests/th/T13366.stdout
@@ -0,0 +1,4 @@
+calling f(2)
+3
+calling fcxx(5)
+6
diff --git a/testsuite/tests/th/TH_addCStub1.hs b/testsuite/tests/th/TH_addCStub1.hs
deleted file mode 100644
index 3a2c5c3609..0000000000
--- a/testsuite/tests/th/TH_addCStub1.hs
+++ /dev/null
@@ -1,22 +0,0 @@
--- 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
diff --git a/testsuite/tests/th/TH_addCStub1.stdout b/testsuite/tests/th/TH_addCStub1.stdout
deleted file mode 100644
index e46825eb2b..0000000000
--- a/testsuite/tests/th/TH_addCStub1.stdout
+++ /dev/null
@@ -1,2 +0,0 @@
-3
-calling f(2)
diff --git a/testsuite/tests/th/TH_addCStub2.hs b/testsuite/tests/th/TH_addCStub2.hs
deleted file mode 100644
index 10119d9370..0000000000
--- a/testsuite/tests/th/TH_addCStub2.hs
+++ /dev/null
@@ -1,22 +0,0 @@
--- 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
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index d73ad8600c..e4d4731f9a 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -71,11 +71,6 @@ def error_has(pattern):
     # the following fails only if both the command fails and the pattern is found
     return('bash -o pipefail -c \'! (! "$@" {swap12}) | grep {pattern} {swap12} &> /dev/null\' --'.format(**locals()))
 
-test('TH_addCStub1', normal, compile_and_run, ['-v0'])
-test('TH_addCStub2'
-     , [compile_cmd_prefix(error_has('TH_addCStub2.hs:13:'))]
-     , compile_fail, ['-v0'])
-
 test('TH_reifyMkName', normal, compile, ['-v0'])
 
 test('TH_reifyInstances', normal, compile, ['-v0'])
@@ -385,3 +380,4 @@ test('T13018', normal, compile, ['-v0'])
 test('T13123', normal, compile, ['-v0'])
 test('T13098', normal, compile, ['-v0'])
 test('T11046', normal, multimod_compile, ['T11046','-v0'])
+test('T13366', normal, compile_and_run, ['-lstdc++ -v0'])