diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 9 | ||||
| -rw-r--r-- | libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs | 8 | ||||
| -rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/th/T16180.hs | 25 | ||||
| -rw-r--r-- | testsuite/tests/th/T16180.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
6 files changed, 45 insertions, 9 deletions
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index f1a5cb46e0..5fe2362973 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -306,11 +306,12 @@ compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileForeign _ RawObject object_file = return object_file compileForeign hsc_env lang stub_c = do let phase = case lang of - LangC -> Cc - LangCxx -> Ccxx - LangObjc -> Cobjc + LangC -> Cc + LangCxx -> Ccxx + LangObjc -> Cobjc LangObjcxx -> Cobjcxx - RawObject -> panic "compileForeign: should be unreachable" + LangAsm -> As True -- allow CPP + RawObject -> panic "compileForeign: should be unreachable" (_, stub_o) <- runPipeline StopLn hsc_env (stub_c, Just (RealPhase phase)) Nothing (Temporary TFL_GhcSession) diff --git a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs index 3106141de7..c40f6f91df 100644 --- a/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs +++ b/libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs @@ -6,6 +6,12 @@ module GHC.ForeignSrcLang.Type import Prelude -- See note [Why do we import Prelude here?] import GHC.Generics (Generic) +-- | Foreign formats supported by GHC via TH data ForeignSrcLang - = LangC | LangCxx | LangObjc | LangObjcxx | RawObject + = LangC -- ^ C + | LangCxx -- ^ C++ + | LangObjc -- ^ Objective C + | LangObjcxx -- ^ Objective C++ + | LangAsm -- ^ Assembly language (.s) + | RawObject -- ^ Object (.o) deriving (Eq, Show, Generic) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 705222a2f9..3ff6393794 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -503,11 +503,12 @@ addForeignFile = addForeignSource addForeignSource :: ForeignSrcLang -> String -> Q () addForeignSource lang src = do let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" LangObjcxx -> "mm" - RawObject -> "a" + LangAsm -> "s" + RawObject -> "a" path <- addTempFile suffix runIO $ writeFile path src addForeignFilePath lang path diff --git a/testsuite/tests/th/T16180.hs b/testsuite/tests/th/T16180.hs new file mode 100644 index 0000000000..2a4b80c976 --- /dev/null +++ b/testsuite/tests/th/T16180.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Language.Haskell.TH.Syntax +import Foreign.C.String + +$(do + -- some architectures require a "_" symbol prefix... + -- GHC defines a LEADING_UNDERSCORE CPP constant to indicate this. + addForeignSource LangAsm + "#if defined(LEADING_UNDERSCORE)\n\ + \.global \"_mydata\"\n\ + \_mydata:\n\ + \#else\n\ + \.global \"mydata\"\n\ + \mydata:\n\ + \#endif\n\ + \.ascii \"Hello world\\0\"\n" + return []) + +foreign import ccall "&mydata" mystring :: CString + +main :: IO () +main = putStrLn =<< peekCString mystring diff --git a/testsuite/tests/th/T16180.stdout b/testsuite/tests/th/T16180.stdout new file mode 100644 index 0000000000..a378710ebf --- /dev/null +++ b/testsuite/tests/th/T16180.stdout @@ -0,0 +1,2 @@ +Hello world + diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 6783bb6c78..9ddf28345e 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -467,3 +467,4 @@ test('T15437', expect_broken(15437), multimod_compile, test('T15985', normal, compile, ['']) test('T16133', normal, compile_fail, ['']) test('T15471', normal, multimod_compile, ['T15471.hs', '-v0']) +test('T16180', normal, compile_and_run, ['']) |