X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FMain.lhs;h=8bd7f2438582aa8afc754450f49bd07098154118;hb=26741ec416bae2c502ef00a2ba0e79050a32cb67;hp=ef89a619c4ed529d737ac55a94dcd6916add2cfb;hpb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;p=ghc-hetmet.git diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index ef89a61..8bd7f24 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -8,9 +8,7 @@ module Main ( main ) where -import Ubiq{-uitous-} - -import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} ) +IMP_Ubiq(){-uitous-} import HsSyn @@ -33,11 +31,11 @@ import Bag ( emptyBag, isEmptyBag ) import CmdLineOpts 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 ) @@ -66,10 +64,11 @@ main doIt :: ([CoreToDo], [StgToDo]) -> String -> IO () doIt (core_cmds, stg_cmds) input_pgm - = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >> + = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >> -- ******* READER show_pass "Reader" >> + _scc_ "Reader" rdModule >>= \ (mod_name, rdr_module) -> doDump opt_D_dump_rdr "Reader:" @@ -79,24 +78,22 @@ doIt (core_cmds, stg_cmds) input_pgm (pp_show (ppSourceStats rdr_module)) >> -- UniqueSupplies for later use (these are the only lower case uniques) - mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer - mkSplitUniqSupply 't' >>= \ 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 '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" >> + _scc_ "Renamer" - case builtinNameInfo - of { (wiredin_fm, key_fm, idinfo_fm) -> - - renameModule wiredin_fm key_fm rn_uniqs rdr_module >>= + renameModule rn_uniqs rdr_module >>= \ (rn_mod, rn_env, import_names, - version_info, instance_modules, + export_fn, usage_stuff, rn_errs_bag, rn_warns_bag) -> if (not (isEmptyBag rn_errs_bag)) then @@ -122,14 +119,19 @@ doIt (core_cmds, stg_cmds) input_pgm -- (the iface file is produced incrementally, as we have -- the information that we need...; we use "iface") -- "endIface" finishes the job. + let + (usages_map, version_info, instance_modules) = usage_stuff + in startIface mod_name >>= \ if_handle -> + ifaceUsages if_handle usages_map >> ifaceVersions if_handle version_info >> - ifaceExportList if_handle rn_mod >> + ifaceExportList if_handle export_fn rn_mod >> 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) @@ -156,8 +158,8 @@ doIt (core_cmds, stg_cmds) input_pgm case tc_results of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), - interface_stuff, - (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 [ @@ -176,6 +178,7 @@ doIt (core_cmds, stg_cmds) input_pgm -- ******* DESUGARER show_pass "DeSugar" >> + _scc_ "DeSugar" let (desugared,ds_warnings) = deSugar ds_uniqs mod_name typechecked_quint @@ -192,8 +195,13 @@ doIt (core_cmds, stg_cmds) input_pgm >> -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op) + show_pass "Core2Core" >> + _scc_ "Core2Core" + let + local_data_tycons = filter isDataTyCon local_tycons + in core2core core_cmds mod_name pprStyle - sm_uniqs local_tycons pragma_tycon_specs desugared + sm_uniqs local_data_tycons pragma_tycon_specs desugared >>= \ (simplified, inlinings_env, @@ -205,11 +213,13 @@ doIt (core_cmds, stg_cmds) input_pgm -- ******* STG-TO-STG SIMPLIFICATION show_pass "Core2Stg" >> + _scc_ "Core2Stg" let stg_binds = topCoreBindsToStg c2s_uniqs simplified in show_pass "Stg2Stg" >> + _scc_ "Stg2Stg" stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds >>= @@ -225,6 +235,7 @@ doIt (core_cmds, stg_cmds) input_pgm -- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C! show_pass "CodeGen" >> + _scc_ "CodeGen" let abstractC = codeGen mod_name -- module name for CC labelling cost_centre_info @@ -272,7 +283,7 @@ doIt (core_cmds, stg_cmds) input_pgm doOutput opt_ProduceC c_output_w >> ghcExit 0 - } ) } } + } ) } where ------------------------------------------------------------- -- ****** printing styles and column width: @@ -303,15 +314,9 @@ doIt (core_cmds, stg_cmds) input_pgm = case switch of Nothing -> return () Just fname -> - fopen fname "a+" `thenPrimIO` \ file -> - if (file == ``NULL'') then - error ("doOutput: failed to open:"++fname) - else - io_action file >>= \ () -> - fclose file `thenPrimIO` \ status -> - if status == 0 - then return () - else error ("doOutput: closed failed: "{-++show status++" "-}++fname) + openFile fname WriteMode >>= \ handle -> + io_action handle >> + hClose handle doDump switch hdr string = if switch