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 {
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,
......@@ -309,6 +311,7 @@ defaultDynFlags = DynFlags {
coreToDo = [], stgToDo = [],
hscLang = HscC,
hscOutName = "",
hscStubHOutName = "", hscStubCOutName = "",
verbosity = 0,
cppFlag = False,
stolen_x86_regs = 4,
......
......@@ -33,9 +33,9 @@ import CmdLineOpts
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}
......@@ -55,7 +55,7 @@ codeOutput :: DynFlags
-> 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),
......@@ -98,14 +98,13 @@ doOutput filenm io_action
%************************************************************************
\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}
......@@ -184,16 +183,20 @@ outputForeignStubs dflags c_code h_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
......@@ -207,17 +210,9 @@ outputForeignStubs dflags c_code h_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
--
......@@ -487,11 +487,14 @@ run_phase Hsc basename suff input_fn output_fn
-- 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
......@@ -510,11 +513,11 @@ run_phase Hsc basename suff input_fn output_fn
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
......@@ -981,8 +984,13 @@ compile ghci_mode summary source_unchanged have_object
#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
......@@ -992,10 +1000,10 @@ compile ghci_mode summary source_unchanged have_object
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 ]
......@@ -1032,32 +1040,12 @@ compile ghci_mode summary source_unchanged have_object
-----------------------------------------------------------------------------
-- 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
])
compileStub dflags stub_c_exists
| not stub_c_exists = return Nothing
| stub_c_exists = do
-- compile the _stub.c file w/ gcc
pipeline <- genPipeline (StopBefore Ln) "" True
defaultHscLang stub_c
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-}
......
......@@ -99,8 +99,8 @@ data HscResult
| 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
......@@ -298,8 +298,7 @@ hscRecomp ghci_mode dflags have_object
(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 ------------------
......@@ -314,8 +313,7 @@ hscRecomp ghci_mode dflags have_object
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 ------------------
......@@ -338,13 +336,12 @@ hscRecomp ghci_mode dflags have_object
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 = []}
......@@ -353,7 +350,7 @@ hscRecomp ghci_mode dflags have_object
; return (HscRecomp pcs_simpl
final_details
final_iface
maybe_stub_h_filename maybe_stub_c_filename
stub_h_exists stub_c_exists
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