X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=df6337d08f88b728017da202360ab5540c000827;hb=e25c9d5ee995d2a2b8477f1d35bbb660aa603221;hp=84f5645f0734b4636504fe039976b68224065643;hpb=4166dff80e8ec94022a040318ff2759913fbbe06;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 84f5645..df6337d 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -9,6 +9,7 @@ module CodeOutput( codeOutput ) where
 #include "HsVersions.h"
 
 #ifndef OMIT_NATIVE_CODEGEN
+import UniqSupply	( mkSplitUniqSupply )
 import AsmCodeGen	( nativeCodeGen )
 #endif
 
@@ -19,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 )
@@ -31,10 +33,10 @@ import CmdLineOpts
 import ErrUtils		( dumpIfSet_dyn, showPass )
 import Outputable
 import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
-import TmpFiles		( newTempName )
-import UniqSupply	( mkSplitUniqSupply )
 
-import IO		( IOMode(..), hClose, openFile, Handle )
+import IOExts
+import Monad		( when )
+import IO
 \end{code}
 
 
@@ -53,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),
@@ -69,10 +71,17 @@ 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
+	                       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 ()
@@ -92,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}
 
 
@@ -110,10 +124,11 @@ outputAsm dflags filenm flat_absC
 #ifndef OMIT_NATIVE_CODEGEN
 
   = do ncg_uniqs <- mkSplitUniqSupply 'n'
-       let (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
+       let (stix_final, ncg_output_d) = _scc_ "NativeCodeGen" 
+				        nativeCodeGen flat_absC ncg_uniqs
        dumpIfSet_dyn dflags Opt_D_dump_stix "Final stix code" stix_final
        dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" ncg_output_d
-       doOutput filenm ( \f -> printForAsm f ncg_output_d)
+       _scc_ "OutputAsm" doOutput filenm ( \f -> printForAsm f ncg_output_d)
   where
 
 #else /* OMIT_NATIVE_CODEGEN */
@@ -145,6 +160,22 @@ outputJava dflags filenm mod tycons core_binds
 
 %************************************************************************
 %*									*
+\subsection{Ilx}
+%*									*
+%************************************************************************
+
+\begin{code}
+#ifdef ILX
+outputIlx dflags filename mod tycons stg_binds
+  =  doOutput filename (\ f -> printForC f pp_ilx)
+  where
+    pp_ilx = ilxGen mod tycons stg_binds
+#endif
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Foreign import/export}
 %*									*
 %************************************************************************
@@ -155,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
@@ -178,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)
+        return True
 \end{code}