X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FCodeOutput.lhs;h=3ce6bcd77524a2d1535227f976927e8c1ed305a8;hb=61663f75b09d05a083bcb2c0c3821528e129fcc2;hp=47f3b36762b635ba29249c9f6c35582a29b1554c;hpb=111cee3f1ad93816cb828e38b38521d85c3bcebb;p=ghc-hetmet.git diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 47f3b36..3ce6bcd 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -11,72 +11,157 @@ module CodeOutput( codeOutput ) where #ifndef OMIT_NATIVE_CODEGEN import AsmCodeGen ( nativeCodeGen ) #endif + #ifdef ILX import IlxGen ( ilxGen ) #endif +import JavaGen ( javaGen ) +import qualified PrintJava + import TyCon ( TyCon ) import Id ( Id ) import Class ( Class ) +import CoreSyn ( CoreBind ) 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 ) import Outputable -import IO ( IOMode(..), hPutStr, hClose, openFile ) +import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) +import TmpFiles ( newTempName ) + +import IO ( IOMode(..), hClose, openFile, Handle ) \end{code} +%************************************************************************ +%* * +\subsection{Steering} +%* * +%************************************************************************ + \begin{code} -codeOutput :: Module +codeOutput :: DynFlags + -> Module -> [TyCon] -> [Class] -- Local tycons and classes + -> [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 stg_binds c_code h_code flat_abstractC ncg_uniqs + -> IO (Maybe FilePath, Maybe FilePath) +codeOutput dflags mod_name tycons classes core_binds stg_binds + c_code h_code flat_abstractC ncg_uniqs = -- 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] + -- 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 ncg_uniqs + >> return stub_names + HscC -> outputC dflags filenm flat_abstractC + >> return stub_names + HscJava -> outputJava dflags filenm mod_name tycons core_binds + >> return stub_names + +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 filenm)) +\end{code} + + +%************************************************************************ +%* * +\subsection{C} +%* * +%************************************************************************ + +\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) +\end{code} + + +%************************************************************************ +%* * +\subsection{Assembler} +%* * +%************************************************************************ + +\begin{code} +outputAsm dflags filenm flat_absC ncg_uniqs + #ifndef OMIT_NATIVE_CODEGEN - let - (stix_final, ncg_output_d) = nativeCodeGen flat_absC_ncg ncg_uniqs - ncg_output_w = (\ f -> printForUser f ncg_output_d) - in - dumpIfSet opt_D_dump_stix "Final stix code" stix_final >> - dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >> - doOutput opt_ProduceS ncg_output_w >> -#else -#ifdef ILX - doOutput opt_ProduceS (\f -> printForUser f (ilxGen tycons stg_binds)) >> -#endif -#endif - dumpIfSet opt_D_dump_foreign "Foreign export header file" stub_h_output_d >> - outputForeignStubs True{-.h output-} opt_ProduceExportHStubs stub_h_output_w >> + = do 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) + where + (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs + +#else /* OMIT_NATIVE_CODEGEN */ + + = pprPanic "This compiler was built without a native code generator" + (text "Use -fvia-C instead") - dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >> - outputForeignStubs False{-not .h-} opt_ProduceExportCStubs stub_c_output_w >> +#endif +\end{code} - dumpIfSet opt_D_dump_realC "Real C" c_output_d >> - doOutput opt_ProduceC c_output_w +%************************************************************************ +%* * +\subsection{Java} +%* * +%************************************************************************ + +\begin{code} +outputJava dflags filenm mod tycons core_binds + = doOutput filenm (\ f -> printForUser f pp_java) + -- User style printing for now to keep indentation 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" + java_code = javaGen mod [{- Should be imports-}] tycons core_binds + pp_java = PrintJava.compilationUnit java_code +\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 + + 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 + + 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 stub_c_output_w = showSDoc stub_c_output_d @@ -85,29 +170,21 @@ codeOutput mod_name tycons classes stg_binds c_code h_code flat_abstractC ncg_un 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) - - - -- 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 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 \"Rts.h\"\n" + | otherwise = "#include \"RtsAPI.h\"\n" \end{code}