[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.

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,

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}
 

ghc/compiler/main/DriverPipeline.hs

 -----------------------------------------------------------------------------
--- $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)

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)
       	  }}}}}}}