X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=166c0990e694cb91596bbd26ddf2786efcc4de92;hb=61191e224d375f6d2c1c9b07648e4b70e66d00e2;hp=e7fb411a4896baab39424f7ac844275cafa56ecc;hpb=d3d20ba70003e869af4d9f44d70d1d403d131812;p=ghc-hetmet.git

diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index e7fb411..166c099 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -4,61 +4,216 @@
 \section{Code output phase}
 
 \begin{code}
-module CodeOutput( codeOutput ) where
+module CodeOutput( codeOutput, outputForeignStubs ) where
 
 #include "HsVersions.h"
 
-#if ! OMIT_NATIVE_CODEGEN
+#ifndef OMIT_NATIVE_CODEGEN
+import UniqSupply	( mkSplitUniqSupply )
 import AsmCodeGen	( nativeCodeGen )
 #endif
 
-import AbsCSyn		( AbstractC, absCNop )
+#ifdef ILX
+import IlxGen		( ilxGen )
+#endif
+
+#ifdef JAVA
+import JavaGen		( javaGen )
+import qualified PrintJava
+#endif
+
+import DriverState	( v_HCHeader )
+import TyCon		( TyCon )
+import Id		( Id )
+import CoreSyn		( CoreBind )
+import OccurAnal	( occurAnalyseBinds )
+import StgSyn		( StgBinding )
+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(..), hPutStr, hClose, openFile, stderr	)
+import Pretty		( Mode(..), printDoc )
+import CmdLineOpts	( DynFlags, HscLang(..), dopt_OutName )
+
+import IOExts
+import Monad		( when )
+import IO
 \end{code}
 
 
+%************************************************************************
+%*									*
+\subsection{Steering}
+%*									*
+%************************************************************************
+
 \begin{code}
-codeOutput :: Module
+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 c_code h_code flat_abstractC ncg_uniqs
+	   -> 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),
     -- but not both.  [Allowing for both gives a space leak on
     -- flat_abstractC.  WDP 94/10]
 
-    dumpIfSet opt_D_dump_stix "Final stix code" stix_final >>
+    -- 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 stub_names
+          		       >> return stub_names
+             HscJava        -> 
+#ifdef JAVA
+			       outputJava dflags filenm mod_name tycons core_binds
+          		       >> return stub_names
+#else
+                               panic "Java support not compiled into this ghc"
+#endif
+	     HscILX         -> 
+#ifdef ILX
+	                       outputIlx dflags filenm mod_name tycons stg_binds
+			       >> return stub_names
+#else
+                               panic "ILX support not compiled into this ghc"
+#endif
+	}
 
-    dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d 	>>
-    doOutput opt_ProduceS ncg_output_w 			>>
+doOutput :: String -> (Handle -> IO ()) -> IO ()
+doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
+\end{code}
 
-    dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >>
-    outputForeignStubs True{-.h output-} opt_ProduceExportHStubs stub_h_output_w	>>
 
-    dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >>
-    outputForeignStubs False{-not .h-}   opt_ProduceExportCStubs stub_c_output_w	>>
+%************************************************************************
+%*									*
+\subsection{C}
+%*									*
+%************************************************************************
 
-    dumpIfSet opt_D_dump_realC "Real C" c_output_d 	>>
-    doOutput opt_ProduceC c_output_w
+\begin{code}
+outputC dflags filenm flat_absC (stub_h_exists, _)
+  = do dumpIfSet_dyn dflags Opt_D_dump_realC "Real C" (dumpRealC 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}
+
+
+%************************************************************************
+%*									*
+\subsection{Assembler}
+%*									*
+%************************************************************************
+
+\begin{code}
+outputAsm dflags filenm flat_absC
+
+#ifndef OMIT_NATIVE_CODEGEN
 
+  = 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" (docToSDoc ncg_output_d)
+       _scc_ "OutputAsm" doOutput filenm $
+	   \f -> printDoc LeftMode f ncg_output_d
   where
-    (flat_absC_c, flat_absC_ncg) =
-	 case (maybeToBool opt_ProduceC || opt_D_dump_realC,
-	       maybeToBool opt_ProduceS || opt_D_dump_asm) of
-	     (True,  False) -> (flat_abstractC, absCNop)
-	     (False, True)  -> (absCNop, flat_abstractC)
-	     (False, False) -> (absCNop, absCNop)
-	     (True,  True)  -> error "ERROR: Can't do both .hc and .s at the same time"
 
+#else /* OMIT_NATIVE_CODEGEN */
+
+  = pprPanic "This compiler was built without a native code generator"
+	     (text "Use -fvia-C instead")
+
+#endif
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Java}
+%*									*
+%************************************************************************
+
+\begin{code}
+#ifdef 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
+    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
+#endif
+\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 dflags c_code h_code
+  = do
+	dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export header file" stub_h_output_d
+
+	stub_h_file_exists
+           <- outputForeignStubs_help (hscStubHOutName dflags) stub_h_output_w
+		("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
+
+	dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export stubs" stub_c_output_d
+
+        hc_header <- readIORef v_HCHeader
+
+	stub_c_file_exists
+           <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w
+		("#define IN_STG_CODE 0\n" ++ 
+		 hc_header ++
+		 "#include \"RtsAPI.h\"\n" ++
+		 cplusplus_hdr)
+		 cplusplus_ftr
+	   -- 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
     stub_c_output_w = showSDoc stub_c_output_d
@@ -67,39 +222,15 @@ codeOutput mod_name c_code h_code flat_abstractC ncg_uniqs
     stub_h_output_d = pprCode CStyle h_code
     stub_h_output_w = showSDoc stub_h_output_d
 
-    c_output_d = dumpRealC flat_absC_c
-    c_output_w = (\ f -> writeRealC f flat_absC_c)
-
-	-- Native code generation done here!
-#if OMIT_NATIVE_CODEGEN
-    ncg_output_d = error "*** GHC not built with a native-code generator ***"
-    ncg_output_w = ncg_output_d
-#else
-    (stix_final, ncg_output_d)
-       = nativeCodeGen flat_absC_ncg ncg_uniqs
-    ncg_output_w = (\ f -> printForAsm f ncg_output_d)
-#endif
-
+cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
+cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
 
-    -- 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 is_header switch ""      = return ()
-outputForeignStubs 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"
-
-doOutput switch io_action
-  = case switch of
-	  Nothing    -> return ()
-	  Just fname ->
-	    openFile fname WriteMode	>>= \ handle ->
-	    io_action handle		>>
-	    hClose handle
+-- 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 fname ""      header footer = return False
+outputForeignStubs_help fname doc_str header footer
+   = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
+        return True
 \end{code}