diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile
index 3905677c7756af3fe8201c98635883f0d7c9f86a..0923f10f1ec1ea373ed11e1871a44036fabe7c85 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 188dde5721825cbf77bb5276cc964dc339687f6a..e7a563e058acb2c888facceeb67c660418345b68 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 cf2655cc0ad26de73a60ed7f141cb802c4f5011b..ccaeac86c9654ed7cd3ae4cb04e81d21ecbda531 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 a61e0472349a391ce01971656be75723f0e4ecda..37a46aaa8c013f2e57d51ad4eece5ea90c8eeeb8 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 3efd09c9d60aa732fb60adf7d6014200e8236583..4ffef76d063697b678ef14c5d2ce95ac71d2b0fd 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 >>