From: simonpj Date: Fri, 21 Apr 2000 12:57:54 +0000 (+0000) Subject: [project @ 2000-04-21 12:57:54 by simonpj] X-Git-Tag: Approximately_9120_patches~4632 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c30bd911e1ae6f43cb8a4573305b76c257b0300c;p=ghc-hetmet.git [project @ 2000-04-21 12:57:54 by simonpj] /home/simonpj/tmp/msg --- diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 3905677..0923f10 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.73 2000/03/31 03:09:35 hwloidl Exp $ +# $Id: Makefile,v 1.74 2000/04/21 12:57:54 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -37,7 +37,7 @@ $(HS_PROG) :: $(HS_SRCS) DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser usageSP cprAnalysis + profiling parser usageSP cprAnalysis javaGen ifeq ($(GhcWithNativeCodeGen),YES) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 188dde5..e7a563e 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -27,7 +27,7 @@ import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply, UniqSupply ) -import CmdLineOpts ( opt_ProduceC, opt_EmitCExternDecls ) +import CmdLineOpts ( opt_OutputLanguage, opt_EmitCExternDecls ) import Maybes ( maybeToBool ) import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..) ) import Panic ( panic ) @@ -330,7 +330,7 @@ flatAbsC (CSwitch discrim alts deflt) returnFlt ( (tag, alt_heres), alt_tops ) flatAbsC stmt@(COpStmt results (CCallOp ccall) args vol_regs) - | isCandidate && maybeToBool opt_ProduceC + | isCandidate && opt_OutputLanguage == Just "C" -- Urgh = returnFlt (stmt, tdef) where (isCandidate, isDyn) = diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index cf2655c..ccaeac8 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -133,11 +133,9 @@ module CmdLineOpts ( opt_NoImplicitPrelude, opt_OmitBlackHoling, opt_OmitInterfacePragmas, - opt_ProduceC, opt_ProduceExportCStubs, opt_ProduceExportHStubs, opt_ProduceHi, - opt_ProduceS, opt_NoPruneDecls, opt_ReportCompile, opt_SourceUnchanged, @@ -145,6 +143,9 @@ module CmdLineOpts ( opt_Unregisterised, opt_Verbose, + opt_OutputLanguage, + opt_OutputFile, + -- Code generation opt_UseVanillaRegs, opt_UseFloatRegs, @@ -412,11 +413,20 @@ opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check") opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") -opt_ProduceC = lookup_str "-C=" opt_ProduceExportCStubs = lookup_str "-F=" opt_ProduceExportHStubs = lookup_str "-FH=" opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time +-- Language for output: "C", "asm", "java", maybe more +-- Nothing => don't output anything +opt_OutputLanguage :: Maybe String +opt_OutputLanguage = lookup_str "-olang=" + +opt_OutputFile :: String +opt_OutputFile = case lookup_str "-ofile=" of + Nothing -> panic "No output file specified (-ofile=xxx)" + Just f -> f + -- Simplifier switches opt_SimplNoPreInlining = lookUp SLIT("-fno-pre-inlining") -- NoPreInlining is there just to see how bad things @@ -439,7 +449,6 @@ opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::F opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for opt_UF_DearOp = ( 4 :: Int) -opt_ProduceS = lookup_str "-S=" opt_ReportCompile = lookUp SLIT("-freport-compile") opt_NoPruneDecls = lookUp SLIT("-fno-prune-decls") opt_SourceUnchanged = lookUp SLIT("-fsource-unchanged") diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index a61e047..37a46aa 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -11,13 +11,18 @@ 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 PprAbsC ( dumpRealC, writeRealC ) @@ -31,52 +36,117 @@ import IO ( IOMode(..), hPutStr, hClose, openFile ) \end{code} +%************************************************************************ +%* * +\subsection{Steering} +%* * +%************************************************************************ + \begin{code} codeOutput :: 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 +codeOutput 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] + 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)) + } } + + +doOutput io_action + = (do handle <- openFile opt_OutputFile WriteMode + io_action handle + hClose handle) + `catch` (\err -> pprPanic "Failed to open or write code output file" (text opt_OutputFile)) +\end{code} + + +%************************************************************************ +%* * +\subsection{C} +%* * +%************************************************************************ + +\begin{code} +outputC flat_absC + = do + dumpIfSet opt_D_dump_realC "Real C" (dumpRealC flat_absC) + doOutput (\ h -> writeRealC h flat_absC) +\end{code} + + +%************************************************************************ +%* * +\subsection{Assembler} +%* * +%************************************************************************ + +\begin{code} +outputAsm flat_absC ncg_uniqs #ifndef OMIT_NATIVE_CODEGEN - let - (stix_final, ncg_output_d) = nativeCodeGen flat_absC_ncg ncg_uniqs - ncg_output_w = (\ f -> printForAsm 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 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) + where + (stix_final, ncg_output_d) = nativeCodeGen flat_absC ncg_uniqs + +#else /* OMIT_NATIVE_CODEGEN */ + + = do hPutStrLn stderr "This compiler was built without a native code generator" + hPutStrLn stderr "Use -fvia-C instead" + +#endif +\end{code} - dumpIfSet opt_D_dump_foreign "Foreign export stubs" stub_c_output_d >> - outputForeignStubs False{-not .h-} opt_ProduceExportCStubs stub_c_output_w >> - dumpIfSet opt_D_dump_realC "Real C" c_output_d >> - doOutput opt_ProduceC c_output_w +%************************************************************************ +%* * +\subsection{Java} +%* * +%************************************************************************ +\begin{code} +outputJava mod tycons core_binds + = doOutput (\ 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 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 opt_D_dump_foreign "Foreign export stubs" stub_c_output_d + outputForeignStubs_help False{-not .h-} opt_ProduceExportCStubs stub_c_output_w + 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,15 +155,12 @@ 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 = +-- 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) @@ -101,13 +168,5 @@ outputForeignStubs is_header switch doc_str = 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 \end{code} diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 3efd09c..4ffef76 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -208,7 +208,8 @@ doIt (core_cmds, stg_cmds) -------------------------- Code output ------------------------------- show_pass "CodeOutput" >> _scc_ "CodeOutput" - codeOutput this_mod local_tycons local_classes stg_binds2 + codeOutput this_mod local_tycons local_classes + tidy_binds stg_binds2 c_code h_code abstractC ncg_uniqs >>