Simplify the foreign-export stub processing.
- DynFlags now has fields for the stub.h and stub.c filenames, for
consistency with the normal hsc output file name.
- codeOutput puts the stubs into these files rather than dreaming
up new temporary names for them
- now we don't have to move the stubs into the right place in
DriverPipeline.
- we do however have to inject the correct #includes into the stub.c
file when it is generated: I'm now injecting the same includes as
the .hc file gets plus "RtsAPI.h", which is probably more correct
than the hacky hardcoded "Stg.h" we had before.
stgToDo :: [StgToDo],
hscLang :: HscLang,
hscOutName :: String, -- name of the output file
+ hscStubHOutName :: String, -- name of the .stub_h output file
+ hscStubCOutName :: String, -- name of the .stub_c output file
verbosity :: Int, -- verbosity level
cppFlag :: Bool, -- preprocess with cpp?
stolen_x86_regs :: Int,
coreToDo = [], stgToDo = [],
hscLang = HscC,
hscOutName = "",
+ hscStubHOutName = "", hscStubCOutName = "",
verbosity = 0,
cppFlag = False,
stolen_x86_regs = 4,
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
-import TmpFiles ( newTempName )
import IOExts
+import Monad ( when )
import IO
\end{code}
-> SDoc -- C stubs for foreign exported functions
-> SDoc -- Header file prototype for foreign exported functions
-> AbstractC -- Compiled abstract C
- -> IO (Maybe FilePath, Maybe FilePath)
+ -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags mod_name tycons core_binds stg_binds
c_code h_code flat_abstractC
= -- You can have C (c_output) or assembly-language (ncg_output),
%************************************************************************
\begin{code}
-outputC dflags filenm flat_absC (maybe_stub_h, _)
+outputC dflags filenm flat_absC (stub_h_exists, _)
= do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
header <- readIORef v_HCHeader
doOutput filenm $ \ h -> do
hPutStr h header
- case maybe_stub_h of
- Nothing -> return ()
- Just filename -> hPutStrLn h ("#include \"" ++ filename ++ "\"")
+ when stub_h_exists $
+ hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
writeRealC h flat_absC
\end{code}
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file" stub_h_output_d
- maybe_stub_h_file
- <- outputForeignStubs_help True{-.h output-} stub_h_output_w
+ stub_h_file_exists
+ <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
+ "#include \"HsFFI.h\"\n"
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export stubs" stub_c_output_d
- maybe_stub_c_file
- <- outputForeignStubs_help False{-not .h-} stub_c_output_w
+ hc_header <- readIORef v_HCHeader
- return (maybe_stub_h_file, maybe_stub_c_file)
+ stub_c_file_exists
+ <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
+ (hc_header ++ "#include \"RtsAPI.h\"\n")
+
+ return (stub_h_file_exists, stub_c_file_exists)
where
-- C stubs for "foreign export"ed functions.
stub_c_output_d = pprCode CStyle c_code
-- Don't use doOutput for dumping the f. export stubs
-- since it is more than likely that the stubs file will
-- turn out to be empty, in which case no file should be created.
-outputForeignStubs_help is_header "" = return Nothing
-outputForeignStubs_help is_header doc_str
- = do fname <- newTempName suffix
- writeFile fname (include_prefix ++ doc_str)
- return (Just fname)
- where
- suffix
- | is_header = "h_stub"
- | otherwise = "c_stub"
- include_prefix
- | is_header = "#include \"HsFFI.h\"\n"
- | otherwise = "#include \"RtsAPI.h\"\n"
+outputForeignStubs_help fname "" injects = return False
+outputForeignStubs_help fname doc_str injects
+ = do writeFile fname (injects ++ doc_str)
+ return True
\end{code}
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.58 2001/03/23 17:04:56 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.59 2001/03/26 12:28:15 simonmar Exp $
--
-- GHC Driver
--
-- get the DynFlags
dyn_flags <- readIORef v_DynFlags
+ let dyn_flags' = dyn_flags { hscOutName = output_fn,
+ hscStubCOutName = basename ++ "_stub.c",
+ hscStubHOutName = basename ++ "_stub.h" }
+
-- run the compiler!
pcs <- initPersistentCompilerState
result <- hscMain OneShot
- dyn_flags{ hscOutName = output_fn }
- mod
+ dyn_flags' mod
location{ ml_hspp_file=Just input_fn }
source_unchanged
False
return False;
};
- HscRecomp pcs details iface maybe_stub_h maybe_stub_c
+ HscRecomp pcs details iface stub_h_exists stub_c_exists
_maybe_interpreted_code -> do
-- deal with stubs
- maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
+ maybe_stub_o <- compileStub dyn_flags' stub_c_exists
case maybe_stub_o of
Nothing -> return ()
Just stub_o -> add v_Ld_inputs stub_o
#endif
HscInterpreted -> return (error "no output file")
+ let (basename, _) = splitFilename input_fn
+ dyn_flags' = dyn_flags { hscOutName = output_fn,
+ hscStubCOutName = basename ++ "_stub.c",
+ hscStubHOutName = basename ++ "_stub.h" }
+
-- run the compiler
- hsc_result <- hscMain ghci_mode dyn_flags{ hscOutName = output_fn }
+ hsc_result <- hscMain ghci_mode dyn_flags'
(ms_mod summary) location
source_unchanged have_object old_iface hst hit pcs
HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
HscRecomp pcs details iface
- maybe_stub_h maybe_stub_c maybe_interpreted_code -> do
+ stub_h_exists stub_c_exists maybe_interpreted_code -> do
- let (basename, _) = splitFilename input_fn
- maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c
+ let
+ maybe_stub_o <- compileStub dyn_flags' stub_c_exists
let stub_unlinked = case maybe_stub_o of
Nothing -> []
Just stub_o -> [ DotO stub_o ]
-----------------------------------------------------------------------------
-- stub .h and .c files (for foreign export support)
-dealWithStubs basename maybe_stub_h maybe_stub_c
-
- = do let stub_h = basename ++ "_stub.h"
- let stub_c = basename ++ "_stub.c"
-
- -- copy the .stub_h file into the current dir if necessary
- case maybe_stub_h of
- Nothing -> return ()
- Just tmp_stub_h -> do
- runSomething "Copy stub .h file"
- ("cp " ++ tmp_stub_h ++ ' ':stub_h)
-
- -- copy the .stub_c file into the current dir, and compile it, if necessary
- case maybe_stub_c of
- Nothing -> return Nothing
- Just tmp_stub_c -> do -- copy the _stub.c file into the current dir
- runSomething "Copy stub .c file"
- (unwords [
- "rm -f", stub_c, "&&",
- "echo \'#include \"Stg.h\"\n#include \""++stub_h++"\"\' >"++stub_c, " &&",
- "cat", tmp_stub_c, ">> ", stub_c
- ])
-
- -- compile the _stub.c file w/ gcc
- pipeline <- genPipeline (StopBefore Ln) "" True
- defaultHscLang stub_c
- stub_o <- runPipeline pipeline stub_c False{-no linking-}
- False{-no -o option-}
-
- return (Just stub_o)
+compileStub dflags stub_c_exists
+ | not stub_c_exists = return Nothing
+ | stub_c_exists = do
+ -- compile the _stub.c file w/ gcc
+ let stub_c = hscStubCOutName dflags
+ pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang stub_c
+ stub_o <- runPipeline pipeline stub_c False{-no linking-}
+ False{-no -o option-}
+
+ return (Just stub_o)
| HscRecomp PersistentCompilerState -- updated PCS
ModDetails -- new details (HomeSymbolTable additions)
ModIface -- new iface (if any compilation was done)
- (Maybe String) -- generated stub_h filename (in TMPDIR)
- (Maybe String) -- generated stub_c filename (in TMPDIR)
+ Bool -- stub_h exists
+ Bool -- stub_c exists
(Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
(ppr nm)
in mi_module str_mi
- ; (maybe_stub_h_filename, maybe_stub_c_filename,
- maybe_bcos, final_iface )
+ ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
<- if toInterp
then do
----------------- Generate byte code ------------------
mkFinalIface ghci_mode dflags location
maybe_checked_iface new_iface tidy_details
- return ( Nothing, Nothing,
- Just (bcos,itbl_env), final_iface )
+ return ( False, False, Just (bcos,itbl_env), final_iface )
else do
----------------- Convert to STG ------------------
local_tycons stg_binds
------------------ Code output -----------------------
- (maybe_stub_h_name, maybe_stub_c_name)
+ (stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod local_tycons
binds stg_binds
c_code h_code abstractC
- return ( maybe_stub_h_name, maybe_stub_c_name,
- Nothing, final_iface )
+ return (stub_h_exists, stub_c_exists, Nothing, final_iface)
; let final_details = tidy_details {md_binds = []}
; return (HscRecomp pcs_simpl
final_details
final_iface
- maybe_stub_h_filename maybe_stub_c_filename
+ stub_h_exists stub_c_exists
maybe_bcos)
}}}}}}}
projects / ghc-hetmet.git / commitdiff