X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=f100d57c9bf0259b77f031ccbd2f739a4d61537a;hb=7d7df883026588cbcd40c57319d6cc268810408d;hp=33357fcbc2ddd16fb491601c034c8003d289d8c6;hpb=788faebb40b51d37e73ed94dfc99460d39a1a811;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 33357fc..f100d57 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -20,6 +20,7 @@ import IlxGen		( ilxGen )
 import JavaGen		( javaGen )
 import qualified PrintJava
 
+import DriverState	( v_HCHeader )
 import TyCon		( TyCon )
 import Id		( Id )
 import CoreSyn		( CoreBind )
@@ -32,10 +33,10 @@ import CmdLineOpts
 import ErrUtils		( dumpIfSet_dyn, showPass )
 import Outputable
 import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
-import TmpFiles		( newTempName )
 
-import IO		( IOMode(..), hClose, openFile, Handle )
-import IO		( hPutStr, stderr) 	-- Debugging
+import IOExts
+import Monad		( when )
+import IO
 \end{code}
 
 
@@ -54,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),
@@ -70,20 +71,22 @@ codeOutput dflags mod_name tycons core_binds stg_binds
              HscInterpreted -> return stub_names
              HscAsm         -> outputAsm dflags filenm flat_abstractC
           		       >> return stub_names
-             HscC           -> outputC dflags filenm flat_abstractC	
+             HscC           -> outputC dflags filenm flat_abstractC stub_names
           		       >> return stub_names
              HscJava        -> outputJava dflags filenm mod_name tycons core_binds
           		       >> return stub_names
+	     HscILX         -> 
 #ifdef ILX
-	     HscILX         -> outputIlx dflags filenm mod_name tycons stg_binds
+	                       outputIlx dflags filenm mod_name tycons stg_binds
 			       >> return stub_names
+#else
+                               panic "ILX support not compiled into this ghc"
 #endif
 	}
 
 doOutput :: String -> (Handle -> IO ()) -> IO ()
 doOutput filenm io_action
-  = (do	hPutStr stderr ("Writing to" ++ filenm)
-	handle <- openFile filenm WriteMode
+  = (do	handle <- openFile filenm WriteMode
 	io_action handle
 	hClose handle)
     `catch` (\err -> pprPanic "Failed to open or write code output file" 
@@ -98,9 +101,14 @@ doOutput filenm io_action
 %************************************************************************
 
 \begin{code}
-outputC dflags filenm flat_absC
+outputC dflags filenm flat_absC (stub_h_exists, _)
   = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
-       doOutput filenm (\ h -> writeRealC h flat_absC)
+       header <- readIORef v_HCHeader
+       doOutput filenm $ \ h -> do
+	  hPutStr h header
+	  when stub_h_exists $ 
+	     hPutStrLn h ("#include \"" ++ (hscStubHOutName dflags) ++ "\"")
+	  writeRealC h flat_absC
 \end{code}
 
 
@@ -178,16 +186,25 @@ 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
+		("#define IN_STG_CODE 0\n" ++ 
+		 hc_header ++
+		 "#include \"RtsAPI.h\"\n")
+	   -- we're adding the default hc_header to the stub file, but this
+	   -- isn't really HC code, so we need to define IN_STG_CODE==0 to
+	   -- avoid the register variables etc. being enabled.
+
+        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
@@ -201,17 +218,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 ++ "\n")
+        return True
 \end{code}