Support adding objects from TH
authorAlec Theriault <alec.theriault@gmail.com>
Sun, 25 Mar 2018 17:59:27 +0000 (13:59 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sun, 25 Mar 2018 18:33:22 +0000 (14:33 -0400)
The user facing TH interface changes are:

  * 'addForeignFile' is renamed to 'addForeignSource'
  * 'qAddForeignFile'/'addForeignFile' now expect 'FilePath's
  * 'RawObject' is now a constructor for 'ForeignSrcLang'
  * 'qAddTempFile'/'addTempFile' let you request a temporary file
    from the compiler.

Test Plan: unsure about this, added a TH test

Reviewers: goldfire, bgamari, angerman

Reviewed By: bgamari, angerman

Subscribers: hsyl20, mboes, carter, simonmar, bitonic, ljli, rwbarton, thomie

GHC Trac Issues: #14298

Differential Revision: https://phabricator.haskell.org/D4217

13 files changed:
compiler/main/CodeOutput.hs
compiler/main/DriverPipeline.hs
compiler/main/HscTypes.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
libraries/ghc-boot-th/GHC/ForeignSrcLang/Type.hs
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/TH.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/th/T13366.hs
testsuite/tests/th/T14298.hs [new file with mode: 0644]
testsuite/tests/th/T14298.stdout [new file with mode: 0644]
testsuite/tests/th/all.T

index fc854e4..478de59 100644 (file)
@@ -38,7 +38,6 @@ import Control.Exception
 import System.Directory
 import System.FilePath
 import System.IO
-import Control.Monad (forM)
 
 {-
 ************************************************************************
@@ -53,7 +52,7 @@ codeOutput :: DynFlags
            -> FilePath
            -> ModLocation
            -> ForeignStubs
-           -> [(ForeignSrcLang, String)]
+           -> [(ForeignSrcLang, FilePath)]
            -- ^ additional files to be compiled with with the C compiler
            -> [InstalledUnitId]
            -> Stream IO RawCmmGroup ()                       -- Compiled C--
@@ -61,7 +60,7 @@ codeOutput :: DynFlags
                   (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
                   [(ForeignSrcLang, FilePath)]{-foreign_fps-})
 
-codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
+codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
   cmm_stream
   =
     do  {
@@ -89,10 +88,6 @@ codeOutput dflags this_mod filenm location foreign_stubs foreign_files pkg_deps
                 }
 
         ; 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;
@@ -270,14 +265,3 @@ 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 TFL_CurrentModule extension
-   writeFile fp file_contents
-   return fp
index e631cbb..2789ee4 100644 (file)
@@ -302,12 +302,14 @@ compileOne' m_tc_result mHscMessage
 -- useful to implement facilities such as inline-c.
 
 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
               LangObjcxx -> Cobjcxx
+              RawObject -> panic "compileForeign: should be unreachable"
         (_, stub_o) <- runPipeline StopLn hsc_env
                        (stub_c, Just (RealPhase phase))
                        Nothing (Temporary TFL_GhcSession)
index cc72752..3087755 100644 (file)
@@ -1278,7 +1278,7 @@ 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)],
+        mg_foreign_files :: ![(ForeignSrcLang, FilePath)],
         -- ^ Files to be compiled with the C compiler
         mg_warns     :: !Warnings,       -- ^ Warnings declared in the module
         mg_anns      :: [Annotation],    -- ^ Annotations declared in this module
@@ -1339,7 +1339,7 @@ data CgGuts
                 -- as part of the code-gen of tycons
 
         cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs
-        cg_foreign_files :: ![(ForeignSrcLang, String)],
+        cg_foreign_files :: ![(ForeignSrcLang, FilePath)],
         cg_dep_pkgs  :: ![InstalledUnitId], -- ^ Dependent packages, used to
                                             -- generate #includes for C code gen
         cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information
index a2afe43..00c2256 100644 (file)
@@ -638,7 +638,7 @@ data TcGblEnv
         tcg_th_topdecls :: TcRef [LHsDecl GhcPs],
         -- ^ Top-level declarations from addTopDecls
 
-        tcg_th_foreign_files :: TcRef [(ForeignSrcLang, String)],
+        tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)],
         -- ^ Foreign files emitted from TH.
 
         tcg_th_topnames :: TcRef NameSet,
index 30ad509..f518a42 100644 (file)
@@ -46,6 +46,7 @@ import SrcLoc
 import THNames
 import TcUnify
 import TcEnv
+import FileCleanup ( newTempName, TempFileLifetime(..) )
 
 import Control.Monad
 
@@ -879,6 +880,10 @@ instance TH.Quasi TcM where
     dep_files <- readTcRef ref
     writeTcRef ref (fp:dep_files)
 
+  qAddTempFile suffix = do
+    dflags <- getDynFlags
+    liftIO $ newTempName dflags TFL_GhcSession suffix
+
   qAddTopDecls thds = do
       l <- getSrcSpanM
       let either_hval = convertToHsDecls l thds
@@ -912,9 +917,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.")
 
-  qAddForeignFile lang str = do
+  qAddForeignFilePath lang fp = do
     var <- fmap tcg_th_foreign_files getGblEnv
-    updTcRef var ((lang, str) :)
+    updTcRef var ((lang, fp) :)
 
   qAddModFinalizer fin = do
       r <- liftIO $ mkRemoteRef fin
@@ -1118,12 +1123,13 @@ handleTHMessage msg = case msg of
   ReifyModule m -> wrapTHResult $ TH.qReifyModule m
   ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
   AddModFinalizer r -> do
     hsc_env <- env_top <$> getEnv
     wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
   AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
   AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
-  AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str
+  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
   IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
   ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
   _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
index f6c1a2e..4841de8 100644 (file)
@@ -6,5 +6,5 @@ module GHC.ForeignSrcLang.Type
 import GHC.Generics (Generic)
 
 data ForeignSrcLang
-  = LangC | LangCxx | LangObjc | LangObjcxx
+  = LangC | LangCxx | LangObjc | LangObjcxx | RawObject
   deriving (Eq, Show, Generic)
index 380edf6..f69fff2 100644 (file)
@@ -235,10 +235,11 @@ data THMessage a where
   ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness])
 
   AddDependentFile :: FilePath -> THMessage (THResult ())
+  AddTempFile :: String -> THMessage (THResult FilePath)
   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
   AddCorePlugin :: String -> THMessage (THResult ())
   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
-  AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
+  AddForeignFilePath :: ForeignSrcLang -> FilePath -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
   ExtsEnabled :: THMessage (THResult [Extension])
 
@@ -268,14 +269,15 @@ getTHMessage = do
     8  -> THMsg <$> ReifyModule <$> get
     9  -> THMsg <$> ReifyConStrictness <$> get
     10 -> THMsg <$> AddDependentFile <$> get
-    11 -> THMsg <$> AddTopDecls <$> get
-    12 -> THMsg <$> (IsExtEnabled <$> get)
-    13 -> THMsg <$> return ExtsEnabled
-    14 -> THMsg <$> return StartRecover
-    15 -> THMsg <$> EndRecover <$> get
-    16 -> return (THMsg RunTHDone)
-    17 -> THMsg <$> AddModFinalizer <$> get
-    18 -> THMsg <$> (AddForeignFile <$> get <*> get)
+    11 -> THMsg <$> AddTempFile <$> get
+    12 -> THMsg <$> AddTopDecls <$> get
+    13 -> THMsg <$> (IsExtEnabled <$> get)
+    14 -> THMsg <$> return ExtsEnabled
+    15 -> THMsg <$> return StartRecover
+    16 -> THMsg <$> EndRecover <$> get
+    17 -> return (THMsg RunTHDone)
+    18 -> THMsg <$> AddModFinalizer <$> get
+    19 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
     _  -> THMsg <$> AddCorePlugin <$> get
 
 putTHMessage :: THMessage a -> Put
@@ -291,15 +293,16 @@ putTHMessage m = case m of
   ReifyModule a               -> putWord8 8  >> put a
   ReifyConStrictness a        -> putWord8 9  >> put a
   AddDependentFile a          -> putWord8 10 >> put a
-  AddTopDecls a               -> putWord8 11 >> put a
-  IsExtEnabled a              -> putWord8 12 >> put a
-  ExtsEnabled                 -> putWord8 13
-  StartRecover                -> putWord8 14
-  EndRecover a                -> putWord8 15 >> put a
-  RunTHDone                   -> putWord8 16
-  AddModFinalizer a           -> putWord8 17 >> put a
-  AddForeignFile lang a       -> putWord8 18 >> put lang >> put a
-  AddCorePlugin a             -> putWord8 19 >> put a
+  AddTempFile a               -> putWord8 11 >> put a
+  AddTopDecls a               -> putWord8 12 >> put a
+  IsExtEnabled a              -> putWord8 13 >> put a
+  ExtsEnabled                 -> putWord8 14
+  StartRecover                -> putWord8 15
+  EndRecover a                -> putWord8 16 >> put a
+  RunTHDone                   -> putWord8 17
+  AddModFinalizer a           -> putWord8 18 >> put a
+  AddForeignFilePath lang a   -> putWord8 19 >> put lang >> put a
+  AddCorePlugin a             -> putWord8 20 >> put a
 
 
 data EvalOpts = EvalOpts
index 905e003..aebc32c 100644 (file)
@@ -195,8 +195,9 @@ instance TH.Quasi GHCiQ where
   qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
   qLocation = fromMaybe noLoc . qsLocation <$> getState
   qAddDependentFile file = ghcCmd (AddDependentFile file)
+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
-  qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
   qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
                          ghcCmd . AddModFinalizer
   qAddCorePlugin str = ghcCmd (AddCorePlugin str)
index 7589619..3a3cf60 100644 (file)
@@ -84,9 +84,11 @@ class (MonadIO m, Fail.MonadFail m) => Quasi m where
 
   qAddDependentFile :: FilePath -> m ()
 
+  qAddTempFile :: String -> m FilePath
+
   qAddTopDecls :: [Dec] -> m ()
 
-  qAddForeignFile :: ForeignSrcLang -> String -> m ()
+  qAddForeignFilePath :: ForeignSrcLang -> String -> m ()
 
   qAddModFinalizer :: Q () -> m ()
 
@@ -128,8 +130,9 @@ instance Quasi IO where
   qLocation             = badIO "currentLocation"
   qRecover _ _          = badIO "recover" -- Maybe we could fix this?
   qAddDependentFile _   = badIO "addDependentFile"
+  qAddTempFile _        = badIO "addTempFile"
   qAddTopDecls _        = badIO "addTopDecls"
-  qAddForeignFile _ _   = badIO "addForeignFile"
+  qAddForeignFilePath _ _ = badIO "addForeignFilePath"
   qAddModFinalizer _    = badIO "addModFinalizer"
   qAddCorePlugin _      = badIO "addCorePlugin"
   qGetQ                 = badIO "getQ"
@@ -445,11 +448,23 @@ runIO m = Q (qRunIO m)
 addDependentFile :: FilePath -> Q ()
 addDependentFile fp = Q (qAddDependentFile fp)
 
+-- | Obtain a temporary file path with the given suffix. The compiler will
+-- delete this file after compilation.
+addTempFile :: String -> Q FilePath
+addTempFile suffix = Q (qAddTempFile suffix)
+
 -- | Add additional top-level declarations. The added declarations will be type
 -- checked along with the current declaration group.
 addTopDecls :: [Dec] -> Q ()
 addTopDecls ds = Q (qAddTopDecls ds)
 
+-- |
+addForeignFile :: ForeignSrcLang -> String -> Q ()
+addForeignFile = addForeignSource
+{-# DEPRECATED addForeignFile
+               "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead"
+  #-} -- deprecated in 8.6
+
 -- | 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
@@ -463,12 +478,30 @@ addTopDecls ds = Q (qAddTopDecls ds)
 --
 -- > {-# LANGUAGE CPP #-}
 -- > ...
--- > addForeignFile LangC $ unlines
+-- > addForeignSource LangC $ unlines
 -- >   [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__
 -- >   , ...
 -- >   ]
-addForeignFile :: ForeignSrcLang -> String -> Q ()
-addForeignFile lang str = Q (qAddForeignFile lang str)
+addForeignSource :: ForeignSrcLang -> String -> Q ()
+addForeignSource lang src = do
+  let suffix = case lang of
+                 LangC -> "c"
+                 LangCxx -> "cpp"
+                 LangObjc -> "m"
+                 LangObjcxx -> "mm"
+                 RawObject -> "a"
+  path <- addTempFile suffix
+  runIO $ writeFile path src
+  addForeignFilePath lang path
+
+-- | Same as 'addForeignSource', but expects to recieve a path pointing to the
+-- foreign file instead of a 'String' of its contents. Consider using this in
+-- conjunction with 'addTempFile'.
+--
+-- This is a good alternative to 'addForeignSource' when you are trying to
+-- directly link in an object file.
+addForeignFilePath :: ForeignSrcLang -> FilePath -> Q ()
+addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp)
 
 -- | 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.
@@ -524,8 +557,9 @@ instance Quasi Q where
   qLookupName         = lookupName
   qLocation           = location
   qAddDependentFile   = addDependentFile
+  qAddTempFile        = addTempFile
   qAddTopDecls        = addTopDecls
-  qAddForeignFile     = addForeignFile
+  qAddForeignFilePath = addForeignFilePath
   qAddModFinalizer    = addModFinalizer
   qAddCorePlugin      = addCorePlugin
   qGetQ               = getQ
index 2573235..6a3bda3 100644 (file)
@@ -7,7 +7,7 @@ import System.IO (hFlush, stdout)
 
 foreign import ccall fc :: Int -> IO Int
 
-do addForeignFile LangC $ unlines
+do addForeignSource LangC $ unlines
      [ "#include <stdio.h>"
      , "int fc(int x) {"
      , "  printf(\"calling f(%d)\\n\",x);"
@@ -19,7 +19,7 @@ do addForeignFile LangC $ unlines
 
 foreign import ccall fcxx :: Int -> IO Int
 
-do addForeignFile LangCxx $ unlines
+do addForeignSource LangCxx $ unlines
      [ "#include <iostream>"
      , "extern \"C\" {"
      , "  int fcxx(int x) {"
diff --git a/testsuite/tests/th/T14298.hs b/testsuite/tests/th/T14298.hs
new file mode 100644 (file)
index 0000000..7896e49
--- /dev/null
@@ -0,0 +1,24 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+import Language.Haskell.TH.Syntax
+import System.IO (hFlush, stdout)
+
+foreign import ccall foo :: Int -> IO Int
+
+do fpIn <- addTempFile "c"
+   let cSrc = (unlines [ "#include <stdio.h>"
+                       , "int foo(int x) {"
+                       , "  printf(\"calling f(%d)\\n\",x);"
+                       , "  fflush(stdout);"
+                       , "  return 1 + x;"
+                       , "}"
+                       ])
+   runIO $ writeFile fpIn cSrc
+   addForeignFilePath LangC fpIn
+   return []
+
+main :: IO ()
+main = do
+  foo 2 >>= print
+  hFlush stdout
diff --git a/testsuite/tests/th/T14298.stdout b/testsuite/tests/th/T14298.stdout
new file mode 100644 (file)
index 0000000..2ab79e8
--- /dev/null
@@ -0,0 +1,2 @@
+calling f(2)
+3
index f391012..b5fd6d8 100644 (file)
@@ -408,3 +408,4 @@ test('T14869', normal, compile,
     ['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
 test('T14888', normal, compile,
     ['-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags])
+test('T14298', normal, compile_and_run, ['-v0'])