X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=3ff665e422956ec48602f5842a62284d50bc3435;hb=50027272414438955dbc41696541cbd25da55883;hp=51c5a08f116e0630502eb369e2f4ad40c8da31d6;hpb=5f67848a9c686f64bd4960a40a0e109f286df74b;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 51c5a08..3ff665e 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,22 +20,23 @@ import IlxGen		( ilxGen )
 import JavaGen		( javaGen )
 import qualified PrintJava
 
+import DriverState	( v_HCHeader )
 import TyCon		( TyCon )
 import Id		( Id )
-import Class		( Class )
 import CoreSyn		( CoreBind )
+import OccurAnal	( occurAnalyseBinds )
 import StgSyn		( StgBinding )
 import AbsCSyn		( AbstractC )
 import PprAbsC		( dumpRealC, writeRealC )
-import UniqSupply	( UniqSupply )
 import Module		( Module )
 import CmdLineOpts
-import ErrUtils		( dumpIfSet_dyn )
+import ErrUtils		( dumpIfSet_dyn, showPass )
 import Outputable
 import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
 import TmpFiles		( newTempName )
 
-import IO		( IOMode(..), hClose, openFile, Handle )
+import IOExts
+import IO
 \end{code}
 
 
@@ -62,16 +64,22 @@ codeOutput dflags mod_name tycons core_binds stg_binds
 
     -- Dunno if the above comment is still meaningful now.  JRS 001024.
 
-    do let filenm = dopt_OutName dflags 
-       stub_names <- outputForeignStubs dflags c_code h_code
-       case dopt_HscLang dflags of
-          HscInterpreted -> return stub_names
-          HscAsm         -> outputAsm dflags filenm flat_abstractC
-                            >> return stub_names
-          HscC           -> outputC dflags filenm flat_abstractC	
-                            >> return stub_names
-          HscJava        -> outputJava dflags filenm mod_name tycons core_binds
-                            >> return stub_names
+    do	{ showPass dflags "CodeOutput"
+	; let filenm = dopt_OutName dflags 
+	; stub_names <- outputForeignStubs dflags c_code h_code
+	; case dopt_HscLang dflags of
+             HscInterpreted -> return stub_names
+             HscAsm         -> outputAsm dflags filenm flat_abstractC
+          		       >> return stub_names
+             HscC           -> outputC dflags filenm flat_abstractC	
+          		       >> return stub_names
+             HscJava        -> outputJava dflags filenm mod_name tycons core_binds
+          		       >> return stub_names
+#ifdef ILX
+	     HscILX         -> outputIlx dflags filenm mod_name tycons stg_binds
+			       >> return stub_names
+#endif
+	}
 
 doOutput :: String -> (Handle -> IO ()) -> IO ()
 doOutput filenm io_action
@@ -92,7 +100,10 @@ doOutput filenm io_action
 \begin{code}
 outputC dflags filenm flat_absC
   = 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
+	  writeRealC h flat_absC
 \end{code}
 
 
@@ -108,12 +119,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
-       in
+       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 */
@@ -133,16 +143,34 @@ outputAsm dflags filenm flat_absC
 
 \begin{code}
 outputJava dflags filenm mod tycons core_binds
-  = doOutput filenm (\ f -> printForUser f pp_java)
+  = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
 	-- User style printing for now to keep indentation
   where
-    java_code = javaGen mod [{- Should be imports-}] tycons core_binds
+    occ_anal_binds = occurAnalyseBinds core_binds
+	-- Make sure we have up to date dead-var information
+    java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
     pp_java   = PrintJava.compilationUnit java_code
 \end{code}
 
 
 %************************************************************************
 %*									*
+\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}
 %*									*
 %************************************************************************
@@ -178,15 +206,15 @@ outputForeignStubs dflags c_code h_code
 -- 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 
-   = newTempName suffix >>= \ fname ->
-     writeFile fname (include_prefix ++ doc_str) >>
-     return (Just suffix)
+   = 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 \"Rts.h\"\n"
+       | is_header   = "#include \"HsFFI.h\"\n"
        | otherwise   = "#include \"RtsAPI.h\"\n"
 \end{code}