import Rename ( renameModule )
import Typecheck ( typecheckModule, InstInfo )
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 Maybes ( maybeToBool, MaybeErr(..) )
import PrelInfo ( builtinNameInfo )
import RdrHsSyn ( getRawExportees )
+import Specialise ( SpecialiseData(..) )
+import StgSyn ( pprPlainStgBinding, GenStgBinding )
-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 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 MkIface ( mkInterface )
-}
\end{code}
show_pass "Reader" `thenMn_`
rdModule `thenMn`
- \ (mod_name, export_list_fns, absyn_tree) ->
+ \ (mod_name, rdr_module) ->
let
-- reader things used much later
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)) `thenMn_`
doDump opt_D_source_stats "\nSource Statistics:"
- (pp_show (ppSourceStats absyn_tree)) `thenMn_`
+ (pp_show (ppSourceStats rdr_module)) `thenMn_`
-- UniqueSupplies for later use (these are the only lower case uniques)
getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
show_pass "Renamer" `thenMn_`
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 `thenMn`
+ \ (rn_mod, 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
+ `thenMn_` writeMn stderr "\n" `thenMn_`
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ `thenMn_` writeMn stderr "\n" `thenMn_`
+ exitMn 1
else -- No renaming errors ...
+ (if (isEmptyBag rn_warns_bag) then
+ returnMn ()
+ else
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
+ `thenMn_` writeMn stderr "\n"
+ ) `thenMn_`
+
doDump opt_D_dump_rn "Renamer:"
- (pp_show (ppr pprStyle mod4)) `thenMn_`
+ (pp_show (ppr pprStyle rn_mod)) `thenMn_`
+
+-- exitMn 0
+{- LATER ... -}
-- ******* TYPECHECKER
show_pass "TypeCheck" `thenMn_`
- case (case (typecheckModule tc_uniqs final_name_funs mod4) of
+ let
+ rn_info = trace "Main.rn_info" (\ x -> Nothing, \ x -> Nothing)
+ in
+ case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_info rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
Failed (errs, warns)
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
+
+ else ( -- No typechecking errors ...
+
(if (isEmptyBag tc_warns_bag) then
returnMn ()
else
- writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
+ writeMn stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_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
-
- else ( -- No typechecking errors ...
-
case tc_results
- of { (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
+ 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) ->
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),
doDump opt_D_dump_deriv "Derived instances:"
(pp_show (ddump_deriv pprStyle)) `thenMn_`
-
-- ******* DESUGARER
show_pass "DeSugar" `thenMn_`
let
(desugared,ds_warnings)
- = deSugar ds_uniqs ds_mod_name typechecked_quad
+ = deSugar ds_uniqs ds_mod_name typechecked_quint
in
(if isEmptyBag ds_warnings then
returnMn ()
) `thenMn_`
doDump opt_D_dump_ds "Desugared:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) desugared)))
+ (map (pprCoreBinding pprStyle) desugared)))
`thenMn_`
-{- LATER ...
-
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
- core2core core_cmds switch_lookup_fn co_mod_name pprStyle
+ core2core core_cmds co_mod_name pprStyle
sm_uniqs local_tycons pragma_tycon_specs desugared
`thenMn`
SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
- (map (pprPlainCoreBinding pprStyle) simplified)))
+ (map (pprCoreBinding pprStyle) simplified)))
`thenMn_`
-- ******* STG-TO-STG SIMPLIFICATION
in
show_pass "Stg2Stg" `thenMn_`
- stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
+ stg2stg stg_cmds st_mod_name pprStyle st_uniqs stg_binds
`thenMn`
\ (stg_binds2, cost_centre_info) ->
(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
`thenMn_`
+{- LATER ...
-- ******* INTERFACE GENERATION (needs STG output)
{- let
mod_name = "_TestName_"
if_inst_info = emptyBag
in
-}
+
show_pass "Interface" `thenMn_`
let
mod_interface
- = mkInterface switch_is_on if_mod_name export_list_fns
+ = mkInterface if_mod_name export_list_fns
inlinings_env all_tycon_specs
interface_stuff
stg_binds2
in
- doOutput ProduceHi ( \ file ->
+ doOutput opt_ProduceHi ( \ file ->
ppAppendFile file 1000{-pprCols-} mod_interface )
`thenMn_`
+-}
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
show_pass "CodeGen" `thenMn_`
let
abstractC = codeGen cc_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) `thenMn_`
doDump opt_D_dump_flatC "Flat Abstract C:"
- (dumpRealC switch_is_on flat_abstractC) `thenMn_`
+ (dumpRealC flat_abstractC) `thenMn_`
-- 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_`
+ doOutput opt_ProduceS ncg_output_w `thenMn_`
doDump opt_D_dump_realC "" c_output_d `thenMn_`
- doOutput ProduceC c_output_w `thenMn_`
+ doOutput opt_ProduceC c_output_w `thenMn_`
-LATER -}
exitMn 0
- } ) } } }
+ } ) }
+
+{- LATER -}
+
+ }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
doOutput switch io_action
= case switch of
- Nothing -> returnMn ()
+ Nothing -> returnMn ()
Just fname ->
fopen fname "a+" `thenPrimIO` \ file ->
if (file == ``NULL'') then
doDump switch hdr string
= if switch
- then writeMn stderr hdr `thenMn_`
- writeMn stderr ('\n': string) `thenMn_`
+ then writeMn stderr hdr `thenMn_`
+ writeMn stderr ('\n': string) `thenMn_`
writeMn stderr "\n"
else returnMn ()
-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
projects / ghc-hetmet.git / blobdiff