X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMain.lhs;h=0db53649107e0cbf0e2966cd8f175962d72f9a12;hb=12899612693163154531da3285ec99c1c8ca2226;hp=918a24c16a07c52ddf7f00a9320d97e72f125168;hpb=c49d51f812da9b1c2ceca7e0dad8f2a3626041a9;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 918a24c..0db5364 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -8,16 +8,15 @@ module Main ( main ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..))) -import PreludeGlaST ( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this... - -import MainMonad import HsSyn import ReadPrefix ( rdModule ) import Rename ( renameModule ) -import Typecheck ( typecheckModule, InstInfo ) +import MkIface -- several functions +import TcModule ( typecheckModule ) import Desugar ( deSugar, DsMatchContext, pprDsWarnings ) import SimplCore ( core2core ) import CoreToStg ( topCoreBindsToStg ) @@ -29,14 +28,17 @@ import AsmCodeGen ( dumpRealAsm, writeRealAsm ) import AbsCSyn ( absCNop, AbstractC ) import AbsCUtils ( flattenAbsC ) +import CoreUnfold ( Unfolding ) import Bag ( emptyBag, isEmptyBag ) import CmdLineOpts -import ErrUtils ( pprBagOfErrors ) +import ErrUtils ( pprBagOfErrors, ghcExit ) import Maybes ( maybeToBool, MaybeErr(..) ) -import PrelInfo ( builtinNameInfo ) import RdrHsSyn ( getRawExportees ) import Specialise ( SpecialiseData(..) ) import StgSyn ( pprPlainStgBinding, GenStgBinding ) +import TcInstUtil ( InstInfo ) +import TyCon ( isDataTyCon ) +import UniqSupply ( mkSplitUniqSupply ) import PprAbsC ( dumpRealC, writeRealC ) import PprCore ( pprCoreBinding ) @@ -49,16 +51,11 @@ import PprType ( GenType, GenTyVar ) -- instances import RnHsSyn ( RnName ) -- instances import TyVar ( GenTyVar ) -- instances import Unique ( Unique ) -- instances - -{- ---import MkIface ( mkInterface ) --} - \end{code} \begin{code} main - = readMn stdin `thenMn` \ input_pgm -> + = hGetContents stdin >>= \ input_pgm -> let cmd_line_info = classifyOpts in @@ -66,81 +63,78 @@ main \end{code} \begin{code} -doIt :: ([CoreToDo], [StgToDo]) -> String -> MainIO () +doIt :: ([CoreToDo], [StgToDo]) -> String -> IO () doIt (core_cmds, stg_cmds) input_pgm - = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.3-xx" "" - `thenMn_` + = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >> -- ******* READER - show_pass "Reader" `thenMn_` - rdModule `thenMn` + show_pass "Reader" >> + _scc_ "Reader" + rdModule >>= \ (mod_name, rdr_module) -> - \ (mod_name, rdr_module) -> - - let - -- reader things used much later - ds_mod_name = mod_name - if_mod_name = mod_name - co_mod_name = mod_name - st_mod_name = mod_name - cc_mod_name = mod_name - in doDump opt_D_dump_rdr "Reader:" - (pp_show (ppr pprStyle rdr_module)) `thenMn_` + (pp_show (ppr pprStyle rdr_module)) >> doDump opt_D_source_stats "\nSource Statistics:" - (pp_show (ppSourceStats rdr_module)) `thenMn_` + (pp_show (ppSourceStats rdr_module)) >> -- UniqueSupplies for later use (these are the only lower case uniques) - getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer - getSplitUniqSupplyMn 't' `thenMn` \ tc_uniqs -> -- typechecker - getSplitUniqSupplyMn 'd' `thenMn` \ ds_uniqs -> -- desugarer - getSplitUniqSupplyMn 's' `thenMn` \ sm_uniqs -> -- core-to-core simplifier - getSplitUniqSupplyMn 'c' `thenMn` \ c2s_uniqs -> -- core-to-stg - getSplitUniqSupplyMn 'g' `thenMn` \ st_uniqs -> -- stg-to-stg passes - getSplitUniqSupplyMn 'f' `thenMn` \ fl_uniqs -> -- absC flattener - getSplitUniqSupplyMn 'n' `thenMn` \ ncg_uniqs -> -- native-code generator + mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer + mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker + mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer + mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier + mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg + mkSplitUniqSupply 'g' >>= \ st_uniqs -> -- stg-to-stg passes + mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener + mkSplitUniqSupply 'n' >>= \ ncg_uniqs -> -- native-code generator -- ******* RENAMER - show_pass "Renamer" `thenMn_` - - case builtinNameInfo - of { (wiredin_fm, key_fm, idinfo_fm) -> + show_pass "Renamer" >> + _scc_ "Renamer" - renameModule wiredin_fm key_fm rn_uniqs rdr_module `thenMn` - \ (rn_mod, import_names, - version_info, instance_modules, + renameModule rn_uniqs rdr_module >>= + \ (rn_mod, rn_env, import_names, + export_stuff, usage_stuff, rn_errs_bag, rn_warns_bag) -> if (not (isEmptyBag rn_errs_bag)) then - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - exitMn 1 + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag)) + >> hPutStr stderr "\n" >> + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) + >> hPutStr stderr "\n" >> + ghcExit 1 else -- No renaming errors ... (if (isEmptyBag rn_warns_bag) then - returnMn () + return () else - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) - `thenMn_` writeMn stderr "\n" - ) `thenMn_` + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag)) + >> hPutStr stderr "\n" + ) >> doDump opt_D_dump_rn "Renamer:" - (pp_show (ppr pprStyle rn_mod)) `thenMn_` - --- exitMn 0 -{- LATER ... -} + (pp_show (ppr pprStyle rn_mod)) >> - -- ******* TYPECHECKER - show_pass "TypeCheck" `thenMn_` + -- Safely past renaming: we can start the interface file: + -- (the iface file is produced incrementally, as we have + -- the information that we need...; we use "iface") + -- "endIface" finishes the job. let - rn_info = trace "Main.rn_info" (\ x -> Nothing, \ x -> Nothing) + (usages_map, version_info, instance_modules) = usage_stuff in - case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_info rn_mod) of + startIface mod_name >>= \ if_handle -> + ifaceUsages if_handle usages_map >> + ifaceVersions if_handle version_info >> + ifaceExportList if_handle export_stuff rn_env >> + ifaceFixities if_handle rn_mod >> + ifaceInstanceModules if_handle instance_modules >> + + -- ******* TYPECHECKER + show_pass "TypeCheck" >> + _scc_ "TypeCheck" + case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of Succeeded (stuff, warns) -> (emptyBag, warns, stuff) Failed (errs, warns) @@ -149,25 +143,25 @@ doIt (core_cmds, stg_cmds) input_pgm of { (tc_errs_bag, tc_warns_bag, tc_results) -> if (not (isEmptyBag tc_errs_bag)) then - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) - `thenMn_` writeMn stderr "\n" `thenMn_` - exitMn 1 + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag)) + >> hPutStr stderr "\n" >> + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) + >> hPutStr stderr "\n" >> + ghcExit 1 else ( -- No typechecking errors ... (if (isEmptyBag tc_warns_bag) then - returnMn () + return () else - writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) - `thenMn_` writeMn stderr "\n" - ) `thenMn_` + hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag)) + >> hPutStr stderr "\n" + ) >> case tc_results of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), - interface_stuff@(_,_,_,_,_), -- @-pat just for strictness... - (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) -> + interface_stuff@(_,local_tycons,_,_), + pragma_tycon_specs, ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" (pp_show (ppAboves [ @@ -175,87 +169,77 @@ doIt (core_cmds, stg_cmds) input_pgm ppr pprStyle class_binds, ppr pprStyle inst_binds, ppAboves (map (\ (i,e) -> ppr pprStyle (VarMonoBind i e)) const_binds), - ppr pprStyle val_binds])) `thenMn_` + ppr pprStyle val_binds])) >> doDump opt_D_dump_deriv "Derived instances:" - (pp_show (ddump_deriv pprStyle)) `thenMn_` + (pp_show (ddump_deriv pprStyle)) >> + + -- OK, now do the interface stuff that relies on typechecker output: + ifaceDecls if_handle interface_stuff >> + ifaceInstances if_handle interface_stuff >> -- ******* DESUGARER - show_pass "DeSugar" `thenMn_` + show_pass "DeSugar" >> + _scc_ "DeSugar" let (desugared,ds_warnings) - = deSugar ds_uniqs ds_mod_name typechecked_quint + = deSugar ds_uniqs mod_name typechecked_quint in (if isEmptyBag ds_warnings then - returnMn () + return () else - writeMn stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings)) - `thenMn_` writeMn stderr "\n" - ) `thenMn_` + hPutStr stderr (ppShow pprCols (pprDsWarnings pprErrorsStyle ds_warnings)) + >> hPutStr stderr "\n" + ) >> doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves (map (pprCoreBinding pprStyle) desugared))) - `thenMn_` + >> -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op) - core2core core_cmds co_mod_name pprStyle - sm_uniqs local_tycons pragma_tycon_specs desugared - `thenMn` + show_pass "Core2Core" >> + _scc_ "Core2Core" + let + local_data_tycons = filter isDataTyCon local_tycons + in + core2core core_cmds mod_name pprStyle + sm_uniqs local_data_tycons pragma_tycon_specs desugared + >>= \ (simplified, inlinings_env, SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) -> doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves (map (pprCoreBinding pprStyle) simplified))) - `thenMn_` + >> -- ******* STG-TO-STG SIMPLIFICATION - show_pass "Core2Stg" `thenMn_` + show_pass "Core2Stg" >> + _scc_ "Core2Stg" let stg_binds = topCoreBindsToStg c2s_uniqs simplified in - show_pass "Stg2Stg" `thenMn_` - stg2stg stg_cmds st_mod_name pprStyle st_uniqs stg_binds - `thenMn` + show_pass "Stg2Stg" >> + _scc_ "Stg2Stg" + stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds + >>= \ (stg_binds2, cost_centre_info) -> doDump opt_D_dump_stg "STG syntax:" (pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2))) - `thenMn_` - -{- LATER ... - -- ******* INTERFACE GENERATION (needs STG output) -{- let - mod_name = "_TestName_" - export_list_fns = (\ x -> False, \ x -> False) - inlinings_env = nullIdEnv - fixities = [] - if_global_ids = [] - if_ce = nullCE - if_tce = nullTCE - if_inst_info = emptyBag - in --} + >> - show_pass "Interface" `thenMn_` - let - mod_interface - = mkInterface if_mod_name export_list_fns - inlinings_env all_tycon_specs - interface_stuff - stg_binds2 - in - doOutput opt_ProduceHi ( \ file -> - ppAppendFile file 1000{-pprCols-} mod_interface ) - `thenMn_` --} + -- We are definitely done w/ interface-file stuff at this point: + -- (See comments near call to "startIface".) + endIface if_handle >> -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C! - show_pass "CodeGen" `thenMn_` + show_pass "CodeGen" >> + _scc_ "CodeGen" let - abstractC = codeGen cc_mod_name -- module name for CC labelling + abstractC = codeGen mod_name -- module name for CC labelling cost_centre_info import_names -- import names for CC registering gen_tycons -- type constructors generated locally @@ -265,10 +249,10 @@ doIt (core_cmds, stg_cmds) input_pgm flat_abstractC = flattenAbsC fl_uniqs abstractC in doDump opt_D_dump_absC "Abstract C:" - (dumpRealC abstractC) `thenMn_` + (dumpRealC abstractC) >> doDump opt_D_dump_flatC "Flat Abstract C:" - (dumpRealC flat_abstractC) `thenMn_` + (dumpRealC flat_abstractC) >> -- You can have C (c_output) or assembly-language (ncg_output), -- but not both. [Allowing for both gives a space leak on @@ -294,18 +278,14 @@ doIt (core_cmds, stg_cmds) input_pgm #endif in - doDump opt_D_dump_asm "" ncg_output_d `thenMn_` - doOutput opt_ProduceS ncg_output_w `thenMn_` + doDump opt_D_dump_asm "" ncg_output_d >> + doOutput opt_ProduceS ncg_output_w >> - doDump opt_D_dump_realC "" c_output_d `thenMn_` - doOutput opt_ProduceC c_output_w `thenMn_` + doDump opt_D_dump_realC "" c_output_d >> + doOutput opt_ProduceC c_output_w >> - exitMn 0 + ghcExit 0 } ) } - -{- LATER -} - - } where ------------------------------------------------------------- -- ****** printing styles and column width: @@ -329,29 +309,23 @@ doIt (core_cmds, stg_cmds) input_pgm show_pass = if opt_D_show_passes - then \ what -> writeMn stderr ("*** "++what++":\n") - else \ what -> returnMn () + then \ what -> hPutStr stderr ("*** "++what++":\n") + else \ what -> return () doOutput switch io_action = case switch of - Nothing -> returnMn () + Nothing -> return () Just fname -> - fopen fname "a+" `thenPrimIO` \ file -> - if (file == ``NULL'') then - error ("doOutput: failed to open:"++fname) - else - io_action file `thenMn` \ () -> - fclose file `thenPrimIO` \ status -> - if status == 0 - then returnMn () - else error ("doOutput: closed failed: "{-++show status++" "-}++fname) + openFile fname WriteMode >>= \ handle -> + io_action handle >> + hClose handle doDump switch hdr string = if switch - then writeMn stderr hdr `thenMn_` - writeMn stderr ('\n': string) `thenMn_` - writeMn stderr "\n" - else returnMn () + then hPutStr stderr hdr >> + hPutStr stderr ('\n': string) >> + hPutStr stderr "\n" + else return () ppSourceStats (HsModule name version exports imports fixities typedecls typesigs