Commit 7d6569fb authored by simonmar's avatar simonmar
Browse files

[project @ 2001-03-26 12:28:15 by simonmar]

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.
parent 83247823
...@@ -289,6 +289,8 @@ data DynFlags = DynFlags { ...@@ -289,6 +289,8 @@ data DynFlags = DynFlags {
stgToDo :: [StgToDo], stgToDo :: [StgToDo],
hscLang :: HscLang, hscLang :: HscLang,
hscOutName :: String, -- name of the output file 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 verbosity :: Int, -- verbosity level
cppFlag :: Bool, -- preprocess with cpp? cppFlag :: Bool, -- preprocess with cpp?
stolen_x86_regs :: Int, stolen_x86_regs :: Int,
...@@ -309,6 +311,7 @@ defaultDynFlags = DynFlags { ...@@ -309,6 +311,7 @@ defaultDynFlags = DynFlags {
coreToDo = [], stgToDo = [], coreToDo = [], stgToDo = [],
hscLang = HscC, hscLang = HscC,
hscOutName = "", hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
verbosity = 0, verbosity = 0,
cppFlag = False, cppFlag = False,
stolen_x86_regs = 4, stolen_x86_regs = 4,
......
...@@ -33,9 +33,9 @@ import CmdLineOpts ...@@ -33,9 +33,9 @@ import CmdLineOpts
import ErrUtils ( dumpIfSet_dyn, showPass ) import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable import Outputable
import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
import TmpFiles ( newTempName )
import IOExts import IOExts
import Monad ( when )
import IO import IO
\end{code} \end{code}
...@@ -55,7 +55,7 @@ codeOutput :: DynFlags ...@@ -55,7 +55,7 @@ codeOutput :: DynFlags
-> SDoc -- C stubs for foreign exported functions -> SDoc -- C stubs for foreign exported functions
-> SDoc -- Header file prototype for foreign exported functions -> SDoc -- Header file prototype for foreign exported functions
-> AbstractC -- Compiled abstract C -> 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 codeOutput dflags mod_name tycons core_binds stg_binds
c_code h_code flat_abstractC c_code h_code flat_abstractC
= -- You can have C (c_output) or assembly-language (ncg_output), = -- You can have C (c_output) or assembly-language (ncg_output),
...@@ -98,14 +98,13 @@ doOutput filenm io_action ...@@ -98,14 +98,13 @@ doOutput filenm io_action
%************************************************************************ %************************************************************************
\begin{code} \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) = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
header <- readIORef v_HCHeader header <- readIORef v_HCHeader
doOutput filenm $ \ h -> do doOutput filenm $ \ h -> do
hPutStr h header hPutStr h header
case maybe_stub_h of when stub_h_exists $
Nothing -> return () hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
Just filename -> hPutStrLn h ("#include \"" ++ filename ++ "\"")
writeRealC h flat_absC writeRealC h flat_absC
\end{code} \end{code}
...@@ -184,16 +183,20 @@ outputForeignStubs dflags c_code h_code ...@@ -184,16 +183,20 @@ outputForeignStubs dflags c_code h_code
dumpIfSet_dyn dflags Opt_D_dump_foreign dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file" stub_h_output_d "Foreign export header file" stub_h_output_d
maybe_stub_h_file stub_h_file_exists
<- outputForeignStubs_help True{-.h output-} stub_h_output_w <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
"#include \"HsFFI.h\"\n"
dumpIfSet_dyn dflags Opt_D_dump_foreign dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export stubs" stub_c_output_d "Foreign export stubs" stub_c_output_d
maybe_stub_c_file hc_header <- readIORef v_HCHeader
<- outputForeignStubs_help False{-not .h-} stub_c_output_w
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 where
-- C stubs for "foreign export"ed functions. -- C stubs for "foreign export"ed functions.
stub_c_output_d = pprCode CStyle c_code stub_c_output_d = pprCode CStyle c_code
...@@ -207,17 +210,9 @@ outputForeignStubs dflags c_code h_code ...@@ -207,17 +210,9 @@ outputForeignStubs dflags c_code h_code
-- Don't use doOutput for dumping the f. export stubs -- Don't use doOutput for dumping the f. export stubs
-- since it is more than likely that the stubs file will -- since it is more than likely that the stubs file will
-- turn out to be empty, in which case no file should be created. -- turn out to be empty, in which case no file should be created.
outputForeignStubs_help is_header "" = return Nothing outputForeignStubs_help fname "" injects = return False
outputForeignStubs_help is_header doc_str outputForeignStubs_help fname doc_str injects
= do fname <- newTempName suffix = do writeFile fname (injects ++ doc_str)
writeFile fname (include_prefix ++ doc_str) return True
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"
\end{code} \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 -- GHC Driver
-- --
...@@ -487,11 +487,14 @@ run_phase Hsc basename suff input_fn output_fn ...@@ -487,11 +487,14 @@ run_phase Hsc basename suff input_fn output_fn
-- get the DynFlags -- get the DynFlags
dyn_flags <- readIORef v_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! -- run the compiler!
pcs <- initPersistentCompilerState pcs <- initPersistentCompilerState
result <- hscMain OneShot result <- hscMain OneShot
dyn_flags{ hscOutName = output_fn } dyn_flags' mod
mod
location{ ml_hspp_file=Just input_fn } location{ ml_hspp_file=Just input_fn }
source_unchanged source_unchanged
False False
...@@ -510,11 +513,11 @@ run_phase Hsc basename suff input_fn output_fn ...@@ -510,11 +513,11 @@ run_phase Hsc basename suff input_fn output_fn
return 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 _maybe_interpreted_code -> do
-- deal with stubs -- 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 case maybe_stub_o of
Nothing -> return () Nothing -> return ()
Just stub_o -> add v_Ld_inputs stub_o Just stub_o -> add v_Ld_inputs stub_o
...@@ -981,8 +984,13 @@ compile ghci_mode summary source_unchanged have_object ...@@ -981,8 +984,13 @@ compile ghci_mode summary source_unchanged have_object
#endif #endif
HscInterpreted -> return (error "no output file") 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 -- run the compiler
hsc_result <- hscMain ghci_mode dyn_flags{ hscOutName = output_fn } hsc_result <- hscMain ghci_mode dyn_flags'
(ms_mod summary) location (ms_mod summary) location
source_unchanged have_object old_iface hst hit pcs source_unchanged have_object old_iface hst hit pcs
...@@ -992,10 +1000,10 @@ compile ghci_mode summary source_unchanged have_object ...@@ -992,10 +1000,10 @@ compile ghci_mode summary source_unchanged have_object
HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
HscRecomp pcs details iface 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 let
maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c maybe_stub_o <- compileStub dyn_flags' stub_c_exists
let stub_unlinked = case maybe_stub_o of let stub_unlinked = case maybe_stub_o of
Nothing -> [] Nothing -> []
Just stub_o -> [ DotO stub_o ] Just stub_o -> [ DotO stub_o ]
...@@ -1032,33 +1040,13 @@ compile ghci_mode summary source_unchanged have_object ...@@ -1032,33 +1040,13 @@ compile ghci_mode summary source_unchanged have_object
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- stub .h and .c files (for foreign export support) -- stub .h and .c files (for foreign export support)
dealWithStubs basename maybe_stub_h maybe_stub_c compileStub dflags stub_c_exists
| not stub_c_exists = return Nothing
= do let stub_h = basename ++ "_stub.h" | stub_c_exists = do
let stub_c = basename ++ "_stub.c" -- compile the _stub.c file w/ gcc
let stub_c = hscStubCOutName dflags
-- copy the .stub_h file into the current dir if necessary pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang stub_c
case maybe_stub_h of stub_o <- runPipeline pipeline stub_c False{-no linking-}
Nothing -> return () False{-no -o option-}
Just tmp_stub_h -> do
runSomething "Copy stub .h file" return (Just stub_o)
("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)
...@@ -99,8 +99,8 @@ data HscResult ...@@ -99,8 +99,8 @@ data HscResult
| HscRecomp PersistentCompilerState -- updated PCS | HscRecomp PersistentCompilerState -- updated PCS
ModDetails -- new details (HomeSymbolTable additions) ModDetails -- new details (HomeSymbolTable additions)
ModIface -- new iface (if any compilation was done) ModIface -- new iface (if any compilation was done)
(Maybe String) -- generated stub_h filename (in TMPDIR) Bool -- stub_h exists
(Maybe String) -- generated stub_c filename (in TMPDIR) Bool -- stub_c exists
(Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
...@@ -298,8 +298,7 @@ hscRecomp ghci_mode dflags have_object ...@@ -298,8 +298,7 @@ hscRecomp ghci_mode dflags have_object
(ppr nm) (ppr nm)
in mi_module str_mi in mi_module str_mi
; (maybe_stub_h_filename, maybe_stub_c_filename, ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface )
maybe_bcos, final_iface )
<- if toInterp <- if toInterp
then do then do
----------------- Generate byte code ------------------ ----------------- Generate byte code ------------------
...@@ -314,8 +313,7 @@ hscRecomp ghci_mode dflags have_object ...@@ -314,8 +313,7 @@ hscRecomp ghci_mode dflags have_object
mkFinalIface ghci_mode dflags location mkFinalIface ghci_mode dflags location
maybe_checked_iface new_iface tidy_details maybe_checked_iface new_iface tidy_details
return ( Nothing, Nothing, return ( False, False, Just (bcos,itbl_env), final_iface )
Just (bcos,itbl_env), final_iface )
else do else do
----------------- Convert to STG ------------------ ----------------- Convert to STG ------------------
...@@ -338,13 +336,12 @@ hscRecomp ghci_mode dflags have_object ...@@ -338,13 +336,12 @@ hscRecomp ghci_mode dflags have_object
local_tycons stg_binds local_tycons stg_binds
------------------ Code output ----------------------- ------------------ Code output -----------------------
(maybe_stub_h_name, maybe_stub_c_name) (stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod local_tycons <- codeOutput dflags this_mod local_tycons
binds stg_binds binds stg_binds
c_code h_code abstractC c_code h_code abstractC
return ( maybe_stub_h_name, maybe_stub_c_name, return (stub_h_exists, stub_c_exists, Nothing, final_iface)
Nothing, final_iface )
; let final_details = tidy_details {md_binds = []} ; let final_details = tidy_details {md_binds = []}
...@@ -353,7 +350,7 @@ hscRecomp ghci_mode dflags have_object ...@@ -353,7 +350,7 @@ hscRecomp ghci_mode dflags have_object
; return (HscRecomp pcs_simpl ; return (HscRecomp pcs_simpl
final_details final_details
final_iface final_iface
maybe_stub_h_filename maybe_stub_c_filename stub_h_exists stub_c_exists
maybe_bcos) maybe_bcos)
}}}}}}} }}}}}}}
......
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