Skip to content
Snippets Groups Projects
Commit d46d9882 authored by sof's avatar sof
Browse files

[project @ 1997-09-04 20:18:21 by sof] 

tidy up
parent 3e5d7e36
No related merge requests found
Hide whitespace changes
Inline Side-by-side
ghc/compiler/main/Main.lhs
+ 41
− 107
View file @ d46d9882
......@@ -28,7 +28,7 @@ import Desugar ( deSugar, pprDsWarnings
)
import SimplCore ( core2core )
import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders )
import StgSyn ( collectFinalStgBinders, pprStgBindings )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
#if ! OMIT_NATIVE_CODEGEN
......@@ -40,17 +40,16 @@ import AbsCUtils ( flattenAbsC )
import CoreUnfold ( Unfolding )
import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
import ErrUtils ( pprBagOfErrors, ghcExit )
import ErrUtils ( pprBagOfErrors, ghcExit, doIfSet, dumpIfSet )
import Maybes ( maybeToBool, MaybeErr(..) )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
import StgSyn ( GenStgBinding )
import TcInstUtil ( InstInfo )
import TyCon ( isDataTyCon )
import UniqSupply ( mkSplitUniqSupply )
import PprAbsC ( dumpRealC, writeRealC )
import PprCore ( pprCoreBinding )
import Outputable ( PprStyle(..), Outputable(..) )
import Pretty
import Id ( GenId ) -- instances
......@@ -58,6 +57,9 @@ import Name ( Name ) -- instances
import PprType ( GenType, GenTyVar ) -- instances
import TyVar ( GenTyVar ) -- instances
import Unique ( Unique ) -- instances
import Outputable ( PprStyle(..), Outputable(..), pprDumpStyle, pprErrorsStyle )
\end{code}
\begin{code}
......@@ -74,17 +76,21 @@ main =
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
= doDump opt_Verbose ("Glasgow Haskell Compiler, version " ++ show PROJECTVERSION ++ ", for Haskell 1.4") "" >>
= doIfSet opt_Verbose
(hPutStr stderr ("Glasgow Haskell Compiler, version " ++
show PROJECTVERSION ++
", for Haskell 1.4")) >>
-- ******* READER
show_pass "Reader" >>
_scc_ "Reader"
rdModule >>= \ (mod_name, rdr_module) ->
doDump opt_D_dump_rdr "Reader:"
(pp_show (ppr pprStyle rdr_module)) >>
dumpIfSet opt_D_dump_rdr "Reader"
(ppr pprDumpStyle rdr_module) >>
doDump opt_D_source_stats "\nSource Statistics:"
(pp_show (ppSourceStats rdr_module)) >>
dumpIfSet opt_D_source_stats "Source Statistics"
(ppSourceStats rdr_module) >>
-- UniqueSupplies for later use (these are the only lower case uniques)
-- _scc_ "spl-rn"
......@@ -108,23 +114,17 @@ doIt (core_cmds, stg_cmds) input_pgm
show_pass "Renamer" >>
_scc_ "Renamer"
renameModule rn_uniqs rdr_module >>=
\ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
checkErrors rn_errs_bag rn_warns_bag >>
renameModule rn_uniqs rdr_module >>=
\ maybe_rn_stuff ->
case maybe_rn_stuff of {
Nothing -> -- Hurrah! Renamer reckons that there's no need to
-- go any further
ghcExit 0 ;
-- Oh well, we've got to recompile for real
return ();
Just (rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
-- Oh well, we've got to recompile for real
doDump opt_D_dump_rn "Renamer:"
(pp_show (ppr pprStyle rn_mod)) >>
-- 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<blah>")
......@@ -134,63 +134,35 @@ doIt (core_cmds, stg_cmds) input_pgm
-- ******* TYPECHECKER
show_pass "TypeCheck" >>
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_name_supply rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
Failed (errs, warns)
-> (errs, warns, error "tc_results"))
of { (tc_errs_bag, tc_warns_bag, tc_results) ->
checkErrors tc_errs_bag tc_warns_bag >>
typecheckModule tc_uniqs rn_name_supply rn_mod >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
case tc_results
of { (all_binds,
local_tycons, local_classes, inst_info, pragma_tycon_specs,
ddump_deriv) ->
Just (all_binds,
local_tycons, local_classes, inst_info, pragma_tycon_specs,
ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
(pp_show (ppr pprStyle all_binds)) >>
doDump opt_D_dump_deriv "Derived instances:"
(pp_show (ddump_deriv pprStyle)) >>
-- ******* DESUGARER
show_pass "DeSugar" >>
_scc_ "DeSugar"
let
(desugared,ds_warnings)
= deSugar ds_uniqs mod_name all_binds
in
(if isEmptyBag ds_warnings then
return ()
else
hPutStr stderr (pp_show (pprDsWarnings pprErrorsStyle ds_warnings))
>> hPutStr stderr "\n"
) >>
doDump opt_D_dump_ds "Desugared:" (pp_show (vcat
(map (pprCoreBinding pprStyle) desugared)))
>>
deSugar ds_uniqs mod_name all_binds >>= \ desugared ->
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
-- ******* CORE-TO-CORE SIMPLIFICATION
show_pass "Core2Core" >>
_scc_ "Core2Core"
let
local_data_tycons = filter isDataTyCon local_tycons
in
core2core core_cmds mod_name pprStyle
core2core core_cmds mod_name
sm_uniqs local_data_tycons pragma_tycon_specs desugared
>>=
\ (simplified,
SpecData _ _ _ gen_data_tycons all_tycon_specs _ _ _) ->
doDump opt_D_dump_simpl "Simplified:" (pp_show (vcat
(map (pprCoreBinding pprStyle) simplified)))
>>
-- ******* STG-TO-STG SIMPLIFICATION
show_pass "Core2Stg" >>
......@@ -201,13 +173,12 @@ doIt (core_cmds, stg_cmds) input_pgm
show_pass "Stg2Stg" >>
_scc_ "Stg2Stg"
stg2stg stg_cmds mod_name pprStyle st_uniqs stg_binds
stg2stg stg_cmds mod_name st_uniqs stg_binds
>>=
\ (stg_binds2, cost_centre_info) ->
doDump opt_D_dump_stg "STG syntax:"
(pp_show (vcat (map (pprPlainStgBinding pprStyle) stg_binds2)))
dumpIfSet opt_D_dump_stg "STG syntax:"
(pprStgBindings pprDumpStyle stg_binds2)
>>
-- Dump instance decls and type signatures into the interface file
......@@ -234,10 +205,10 @@ doIt (core_cmds, stg_cmds) input_pgm
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
doDump opt_D_dump_absC "Abstract C:"
dumpIfSet opt_D_dump_absC "Abstract C"
(dumpRealC abstractC) >>
doDump opt_D_dump_flatC "Flat Abstract C:"
dumpIfSet opt_D_dump_flatC "Flat Abstract C"
(dumpRealC flat_abstractC) >>
show_pass "CodeOutput" >>
......@@ -266,19 +237,15 @@ doIt (core_cmds, stg_cmds) input_pgm
#endif
in
doDump opt_D_dump_asm "" ncg_output_d >>
doOutput opt_ProduceS ncg_output_w >>
dumpIfSet opt_D_dump_asm "Asm code" ncg_output_d >>
doOutput opt_ProduceS ncg_output_w >>
doDump opt_D_dump_realC "" c_output_d >>
doOutput opt_ProduceC c_output_w >>
dumpIfSet opt_D_dump_realC "Real C" c_output_d >>
doOutput opt_ProduceC c_output_w >>
ghcExit 0
} } }
} }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
-------------------------------------------------------------
-- ****** help functions:
......@@ -295,39 +262,6 @@ doIt (core_cmds, stg_cmds) input_pgm
io_action handle >>
hClose handle
doDump switch hdr string
= if switch
then hPutStr stderr ("\n\n" ++ (take 80 $ repeat '=')) >>
hPutStr stderr ('\n': hdr) >>
hPutStr stderr ('\n': string) >>
hPutStr stderr "\n"
else return ()
pprCols = (80 :: Int) -- could make configurable
(pprStyle, pprErrorsStyle)
| opt_PprStyle_All = (PprShowAll, PprShowAll)
| opt_PprStyle_Debug = (PprDebug, PprDebug)
| opt_PprStyle_User = (PprQuote, PprQuote)
| otherwise = (PprDebug, PprQuote)
pp_show p = show p -- ToDo: use pprCols
checkErrors errs_bag warns_bag
| not (isEmptyBag errs_bag)
= hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle errs_bag))
>> hPutStr stderr "\n" >>
hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag))
>> hPutStr stderr "\n" >>
ghcExit 1
| not (isEmptyBag warns_bag)
= hPutStr stderr (pp_show (pprBagOfErrors pprErrorsStyle warns_bag)) >>
hPutStr stderr "\n"
| otherwise = return ()
ppSourceStats (HsModule name version exports imports fixities decls src_loc)
= vcat (map pp_val
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment