X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=inline;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=27ac2523dc788fda7cf07ba9594987f90ea1df4f;hb=f4eba96b198baf4499ca6ccd7242d9daa41337ac;hp=a8a1a0a3b354097b6794cc4ac5eb15440ab69976;hpb=bca9dd54c2b39638cb4638aaccf6015a104a1df5;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index a8a1a0a..27ac252 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,21 +20,23 @@ import IlxGen ( ilxGen ) import JavaGen ( javaGen ) import qualified PrintJava +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 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 UniqSupply ( mkSplitUniqSupply ) -import IO ( IOMode(..), hClose, openFile, Handle ) +import IOExts +import Monad ( when ) +import IO \end{code} @@ -52,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), @@ -61,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 stub_names + >> 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 @@ -89,9 +98,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} @@ -107,10 +121,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 */ @@ -130,16 +145,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} %* * %************************************************************************ @@ -150,16 +183,20 @@ 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 + (hc_header ++ "#include \"RtsAPI.h\"\n") + + 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 @@ -173,17 +210,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 - = newTempName suffix >>= \ fname -> - writeFile fname (include_prefix ++ doc_str) >> - return (Just suffix) - 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}