[project @ 2001-08-31 13:51:45 by sewardj]

[ghc-hetmet.git] / ghc / compiler / main / CodeOutput.lhs

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index c320964..f100d57 100644 (file)
--- 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,13 +71,16 @@ 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
        }
 
@@ -97,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}
 
 
@@ -177,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
@@ -200,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}