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,
......
This diff is collapsed.
......@@ -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
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
......
......@@ -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 ->
......
......@@ -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.*
......
......@@ -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
......
-- 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
import System.IO (hFlush, stdout)
foreign import ccall f :: Int -> IO Int
foreign import ccall fc :: Int -> IO Int
do addCStub $ unlines
do addForeignFile LangC $ unlines
[ "#include <stdio.h>"
, "int f(int x) {"
, "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 = f 2 >>= print
main = do
fc 2 >>= print
hFlush stdout
fcxx 5 >>= print
hFlush stdout
-- 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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment