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

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 6c64a5c..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,20 +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, absCNop )
+import AbsCSyn		( AbstractC )
 import PprAbsC		( dumpRealC, writeRealC )
-import UniqSupply	( UniqSupply )
-import Module		( Module, moduleString )
+import Module		( Module )
 import CmdLineOpts
-import Maybes		( maybeToBool )
-import ErrUtils		( doIfSet, dumpIfSet )
+import ErrUtils		( dumpIfSet_dyn, showPass )
 import Outputable
-import IO		( IOMode(..), hClose, openFile )
+import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
+import TmpFiles		( newTempName )
+
+import IOExts
+import IO
 \end{code}
 
 
@@ -43,37 +47,47 @@ import IO		( IOMode(..), hClose, openFile )
 %************************************************************************
 
 \begin{code}
-codeOutput :: Module
-	   -> [TyCon] -> [Class]	-- Local tycons and classes
+codeOutput :: DynFlags
+	   -> Module
+	   -> [TyCon]			-- Local tycons
 	   -> [CoreBind]		-- Core bindings
 	   -> [(StgBinding,[Id])]	-- The STG program with SRTs
 	   -> SDoc 		-- C stubs for foreign exported functions
 	   -> SDoc		-- Header file prototype for foreign exported functions
 	   -> AbstractC		-- Compiled abstract C
-	   -> UniqSupply
-	   -> IO ()
-codeOutput mod_name tycons classes core_binds stg_binds 
-	   c_code h_code flat_abstractC ncg_uniqs
+	   -> IO (Maybe FilePath, Maybe FilePath)
+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),
     -- but not both.  [Allowing for both gives a space leak on
     -- flat_abstractC.  WDP 94/10]
 
-    do  {
-	outputForeignStubs c_code h_code ;
-	case opt_OutputLanguage of {
-	  Nothing     -> return ()	-- No -olang=xxx flag; so no-op
-	; Just "asm"  -> outputAsm flat_abstractC ncg_uniqs	
-	; Just "C"    -> outputC flat_abstractC	
-	; Just "java" -> outputJava mod_name tycons core_binds
-	; Just foo    -> pprPanic "Don't understand output language" (quotes (text foo))
-	} }
-
+    -- Dunno if the above comment is still meaningful now.  JRS 001024.
+
+    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 io_action
-  = (do	handle <- openFile opt_OutputFile WriteMode
+doOutput :: String -> (Handle -> IO ()) -> IO ()
+doOutput filenm io_action
+  = (do	handle <- openFile filenm WriteMode
 	io_action handle
 	hClose handle)
-    `catch` (\err -> pprPanic "Failed to open or write code output file" (text opt_OutputFile))
+    `catch` (\err -> pprPanic "Failed to open or write code output file" 
+			      (text filenm))
 \end{code}
 
 
@@ -84,10 +98,12 @@ doOutput io_action
 %************************************************************************
 
 \begin{code}
-outputC flat_absC
-  = do 
-       dumpIfSet opt_D_dump_realC "Real C" (dumpRealC flat_absC)
-       doOutput (\ h -> writeRealC h flat_absC)
+outputC dflags filenm flat_absC
+  = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC flat_absC)
+       header <- readIORef v_HCHeader
+       doOutput filenm $ \ h -> do
+	  hPutStr h header
+	  writeRealC h flat_absC
 \end{code}
 
 
@@ -98,14 +114,17 @@ outputC flat_absC
 %************************************************************************
 
 \begin{code}
-outputAsm flat_absC ncg_uniqs
+outputAsm dflags filenm flat_absC
+
 #ifndef OMIT_NATIVE_CODEGEN
 
-  = do	dumpIfSet opt_D_dump_stix "Final stix code" stix_final
-	dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d
-	doOutput (\ f -> printForAsm f ncg_output_d)
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+       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
+       _scc_ "OutputAsm" doOutput filenm ( \f -> printForAsm f ncg_output_d)
   where
-    (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs
 
 #else /* OMIT_NATIVE_CODEGEN */
 
@@ -123,29 +142,55 @@ outputAsm flat_absC ncg_uniqs
 %************************************************************************
 
 \begin{code}
-outputJava mod tycons core_binds
-  = doOutput (\ f -> printForUser f pp_java)
+outputJava dflags filenm mod tycons core_binds
+  = 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}
 %*									*
 %************************************************************************
 
 \begin{code}
-outputForeignStubs c_code h_code
+outputForeignStubs dflags c_code h_code
   = do
-	dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d
-	outputForeignStubs_help True{-.h output-} opt_ProduceExportHStubs stub_h_output_w
+	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
+
+	dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export stubs" stub_c_output_d
 
-	dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d
-	outputForeignStubs_help False{-not .h-}   opt_ProduceExportCStubs stub_c_output_w
+        maybe_stub_c_file
+           <- outputForeignStubs_help False{-not .h-} stub_c_output_w
+
+        return (maybe_stub_h_file, maybe_stub_c_file)
   where
     -- C stubs for "foreign export"ed functions.
     stub_c_output_d = pprCode CStyle c_code
@@ -159,14 +204,17 @@ outputForeignStubs 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 switch ""      = return ()
-outputForeignStubs_help is_header switch doc_str =
-  case switch of
-    Nothing    -> return ()
-    Just fname -> writeFile fname (include_prefix ++ doc_str)
- where
-  include_prefix
-   | is_header   = "#include \"Rts.h\"\n"
-   | otherwise   = "#include \"RtsAPI.h\"\n"
+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"
 \end{code}