From: simonmar Date: Mon, 26 Mar 2001 12:28:15 +0000 (+0000) Subject: [project @ 2001-03-26 12:28:15 by simonmar] X-Git-Tag: Approximately_9120_patches~2314 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=7d6569fbc7a7c8f9d45cf31bd6a7f699c86715fb [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. --- diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index e66aea8..9227351 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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, diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 5c61a5d..27ac252 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -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} diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index d281c95..3464c57 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $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,33 +1040,13 @@ 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 - ]) - - -- 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) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 8f695f6..3037b1b 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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) }}}}}}}