import Ubiq{-uitous-}
-import PreludeGlaST ( thenPrimIO, _FILE{-instances-} ) -- ToDo: STOP using this...
+import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} )
-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 )
+import SimplStg ( stg2stg )
+import CodeGen ( codeGen )
+#if ! OMIT_NATIVE_CODEGEN
+import AsmCodeGen ( dumpRealAsm, writeRealAsm )
+#endif
+import AbsCSyn ( absCNop, AbstractC )
+import AbsCUtils ( flattenAbsC )
import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
-import ErrUtils ( pprBagOfErrors )
-import Maybes ( MaybeErr(..) )
+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 UniqSupply ( mkSplitUniqSupply )
-import PprCore ( pprPlainCoreBinding )
+import PprAbsC ( dumpRealC, writeRealC )
+import PprCore ( pprCoreBinding )
import PprStyle ( PprStyle(..) )
import Pretty
import Id ( GenId ) -- instances
-import Name ( Name ) -- instances
-import ProtoName ( ProtoName ) -- instances
+import Name ( Name, RdrName ) -- instances
import PprType ( GenType, GenTyVar ) -- instances
+import RnHsSyn ( RnName ) -- instances
import TyVar ( GenTyVar ) -- instances
-import Unique ( Unique) -- instances
-
-{-
---import AbsCSyn
---import CodeGen ( codeGen )
---import CoreToStg ( topCoreBindsToStg )
---import MkIface ( mkInterface )
-
---import SimplCore ( core2core )
---import SimplStg ( stg2stg )
---import StgSyn ( pprPlainStgBinding, GenStgBinding, GenStgRhs, CostCentre,
- StgBinderInfo, StgBinding(..)
- )
-
-#if ! OMIT_NATIVE_CODEGEN
---import AsmCodeGen ( dumpRealAsm, writeRealAsm )
-#endif
--}
-
+import Unique ( Unique ) -- instances
\end{code}
\begin{code}
main
- = readMn stdin `thenMn` \ input_pgm ->
+ = hGetContents stdin >>= \ input_pgm ->
let
cmd_line_info = classifyOpts
in
\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 1.01, for Haskell 1.3" "" >>
-- ******* READER
- show_pass "Reader" `thenMn_`
- rdModule `thenMn`
-
- \ (mod_name, export_list_fns, absyn_tree) ->
+ show_pass "Reader" >>
+ rdModule >>= \ (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 absyn_tree)) `thenMn_`
+ (pp_show (ppr pprStyle rdr_module)) >>
doDump opt_D_source_stats "\nSource Statistics:"
- (pp_show (ppSourceStats absyn_tree)) `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 '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 'n' >>= \ ncg_uniqs -> -- native-code generator
-- ******* RENAMER
- show_pass "Renamer" `thenMn_`
+ show_pass "Renamer" >>
case builtinNameInfo
- of { (init_val_lookup_fn, init_tc_lookup_fn) ->
+ of { (wiredin_fm, key_fm, idinfo_fm) ->
- case (renameModule (init_val_lookup_fn, init_tc_lookup_fn)
- absyn_tree
- rn_uniqs)
- of { (mod4, import_names, final_name_funs, rn_errs_bag) ->
- let
- -- renamer things used much later
- cc_import_names = import_names
- in
+ renameModule wiredin_fm key_fm rn_uniqs rdr_module >>=
+ \ (rn_mod, rn_env, import_names,
+ version_info, instance_modules,
+ 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_` 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
+ return ()
+ else
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ >> hPutStr stderr "\n"
+ ) >>
+
doDump opt_D_dump_rn "Renamer:"
- (pp_show (ppr pprStyle mod4)) `thenMn_`
+ (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>")
+ -- "endIface" finishes the job.
+ startIface mod_name >>= \ if_handle ->
+ ifaceVersions if_handle version_info >>
+ ifaceExportList if_handle rn_mod >>
+ ifaceFixities if_handle rn_mod >>
+ ifaceInstanceModules if_handle instance_modules >>
-- ******* TYPECHECKER
- show_pass "TypeCheck" `thenMn_`
- case (case (typecheckModule tc_uniqs final_name_funs mod4) of
+ show_pass "TypeCheck" >>
+ case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
Failed (errs, warns)
of { (tc_errs_bag, tc_warns_bag, tc_results) ->
- (if (isEmptyBag tc_warns_bag) then
- returnMn ()
- else
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
- `thenMn_` writeMn stderr "\n"
- ) `thenMn_`
-
if (not (isEmptyBag tc_errs_bag)) then
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_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
+ return ()
+ else
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
+ >> hPutStr stderr "\n"
+ ) >>
+
case tc_results
- of { (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
- interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
+ of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
+ interface_stuff,
(local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
(pp_show (ppAboves [
+ ppr pprStyle recsel_binds,
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" >>
let
(desugared,ds_warnings)
- = deSugar ds_uniqs ds_mod_name typechecked_quad
+ = 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 (pprPlainCoreBinding pprStyle) desugared)))
- `thenMn_`
-
-{- LATER ...
+ (map (pprCoreBinding pprStyle) desugared)))
+ >>
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
- core2core core_cmds switch_lookup_fn co_mod_name pprStyle
+ core2core core_cmds mod_name pprStyle
sm_uniqs local_tycons pragma_tycon_specs desugared
- `thenMn`
+ >>=
\ (simplified, inlinings_env,
SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) simplified)))
- `thenMn_`
+ (map (pprCoreBinding pprStyle) simplified)))
+ >>
-- ******* STG-TO-STG SIMPLIFICATION
- show_pass "Core2Stg" `thenMn_`
+ show_pass "Core2Stg" >>
let
stg_binds = topCoreBindsToStg c2s_uniqs simplified
in
- show_pass "Stg2Stg" `thenMn_`
- stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
- `thenMn`
+ show_pass "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_`
-
- -- ******* 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 switch_is_on if_mod_name export_list_fns
- inlinings_env all_tycon_specs
- interface_stuff
- stg_binds2
- in
- doOutput 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" >>
let
- abstractC = codeGen cc_mod_name -- module name for CC labelling
+ abstractC = codeGen mod_name -- module name for CC labelling
cost_centre_info
- cc_import_names -- import names for CC registering
- switch_lookup_fn
+ import_names -- import names for CC registering
gen_tycons -- type constructors generated locally
all_tycon_specs -- tycon specialisations
stg_binds2
flat_abstractC = flattenAbsC fl_uniqs abstractC
in
doDump opt_D_dump_absC "Abstract C:"
- (dumpRealC switch_is_on abstractC) `thenMn_`
+ (dumpRealC abstractC) >>
doDump opt_D_dump_flatC "Flat Abstract C:"
- (dumpRealC switch_is_on 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
-- flat_abstractC. WDP 94/10]
let
(flat_absC_c, flat_absC_ncg) =
- case (string_switch_is_on ProduceC || switch_is_on D_dump_realC,
- string_switch_is_on ProduceS || switch_is_on D_dump_asm) of
- (True, False) -> (flat_abstractC, AbsCNop)
- (False, True) -> (AbsCNop, flat_abstractC)
- (False, False) -> (AbsCNop, AbsCNop)
+ 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"
- c_output_d = dumpRealC switch_is_on flat_absC_c
- c_output_w = (\ f -> writeRealC switch_is_on f flat_absC_c)
+ c_output_d = dumpRealC flat_absC_c
+ c_output_w = (\ f -> writeRealC f flat_absC_c)
#if OMIT_NATIVE_CODEGEN
ncg_output_d = error "*** GHC not built with a native-code generator ***"
ncg_output_w = ncg_output_d
#else
- ncg_output_d = dumpRealAsm switch_lookup_fn flat_absC_ncg ncg_uniqs
- ncg_output_w = (\ f -> writeRealAsm switch_lookup_fn f flat_absC_ncg ncg_uniqs)
+ ncg_output_d = dumpRealAsm flat_absC_ncg ncg_uniqs
+ ncg_output_w = (\ f -> writeRealAsm f flat_absC_ncg ncg_uniqs)
#endif
in
- doDump opt_D_dump_asm "" ncg_output_d `thenMn_`
- doOutput 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 ProduceC c_output_w `thenMn_`
+ doDump opt_D_dump_realC "" c_output_d >>
+ doOutput opt_ProduceC c_output_w >>
-LATER -}
- exitMn 0
- } ) } } }
+ ghcExit 0
+ } ) } }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
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` \ () ->
+ io_action file >>= \ () ->
fclose file `thenPrimIO` \ status ->
if status == 0
- then returnMn ()
+ then return ()
else error ("doOutput: closed failed: "{-++show status++" "-}++fname)
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 exports imports fixities typedecls typesigs
+ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
classdecls instdecls instsigs defdecls binds
[{-no sigs-}] src_loc)
= ppAboves (map pp_val
count_bind (NonRecBind b) = count_monobinds b
count_bind (RecBind b) = count_monobinds b
- count_monobinds EmptyMonoBinds = (0,0)
- count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
+ count_monobinds EmptyMonoBinds = (0,0)
+ count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2
count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0)
- count_monobinds (PatMonoBind p r _) = (0,1)
- count_monobinds (FunMonoBind f m _) = (0,1)
+ count_monobinds (PatMonoBind p r _) = (0,1)
+ count_monobinds (FunMonoBind f _ m _) = (0,1)
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
sig_info (InlineSig _ _) = (0,0,0,1)
sig_info _ = (0,0,0,0)
- import_info (ImportMod _ qual as spec)
+ import_info (ImportDecl _ qual as spec _)
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
qual_info False = 0
qual_info True = 1