import PlainCore ( CoreExpr, CoreBinding, pprPlainCoreBinding,
PlainCoreProgram(..), PlainCoreBinding(..)
)
-import Pretty ( PprStyle(..), ppShow, ppAboves, ppAppendFile
- IF_ATTACK_PRAGMAS(COMMA ppAbove)
- )
+import Pretty
+
#ifdef USE_NEW_READER
import ReadPrefix2 ( rdModule )
#else
-- ****** help functions:
switch_is_on switch = switchIsOn switch_lookup_fn switch
- -- essentially, converts SwBool answer to Bool
string_switch_is_on switch
= maybeToBool (stringSwitchSet switch_lookup_fn switch)
+ show_pass
+ = if switch_is_on D_show_passes
+ then \ what -> writeMn stderr ("*** "++what++":\n")
+ else \ what -> returnMn ()
+
doOutput switch io_action
= BSCC("doOutput")
case (stringSwitchSet switch_lookup_fn switch) of
#endif {- Data Parallel Haskell -}
-- ******* READER
+ show_pass "Read" `thenMn_`
#ifdef USE_NEW_READER
BSCC("rdModule")
rdModule
cc_mod_name = mod_name
-- also: export_list_fns
in
+ doDump D_source_stats "\nSource Statistics:"
+ (pp_show (ppSourceStats absyn_tree)) `thenMn_`
+
doDump D_dump_rif2hs "Parsed, Haskellised:"
- (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
+ (pp_show (ppr pprStyle absyn_tree)) `thenMn_`
-- UniqueSupplies for later use
getSplitUniqSupplyMn 'r' `thenMn` \ rn_uniqs -> -- renamer
ncg_uniqs = {-mkUniqueSupplyGrimily-} pre_ncg_uniqs
in
-- ******* RENAMER
+ show_pass "Rename" `thenMn_`
BIND BSCC("Renamer")
renameModule switch_is_on
(init_val_lookup_fn, init_tc_lookup_fn)
else -- No renaming errors, carry on with...
-- ******* TYPECHECKER
+ show_pass "TypeCheck" `thenMn_`
BIND (case BSCC("TypeChecker")
typecheckModule switch_is_on tc_uniqs final_name_funs mod4
ESCC
BIND tc_results
_TO_ (typechecked_quad@(class_binds, inst_binds, val_binds, const_binds),
interface_stuff@(_,_,_,_,_), -- @-pat just for strictness...
- tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
+ pragma_tycon_specs, {-UNUSED:big_env,-} this_mod_env, ddump_deriv) ->
let
-- big_tce = getE_TCE big_env
-- big_elts = rngTCE big_tce
--NOT REALLY USED:
-- doDump D_dump_type_info "" (pp_show (printTypeInfoForPop big_tce)) `thenMn_`
-- ******* DESUGARER
+ show_pass "DeSugar" `thenMn_`
let
(desugared,ds_warnings)
= BSCC("DeSugarer")
-- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op)
core2core core_cmds switch_lookup_fn co_mod_name pprStyle
- sm_uniqs local_tycons tycon_specs desugared
+ sm_uniqs local_tycons pragma_tycon_specs desugared
`thenMn` \ (simplified, inlinings_env,
- SpecData _ _ _ gen_tycons all_tycon_specs
- spec_errs spec_warn spec_tyerrs) ->
+ SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
doDump D_dump_simpl "Simplified:" (pp_show (ppAboves
(map (pprPlainCoreBinding pprStyle) simplified))) `thenMn_`
#endif
-- ******* STG-TO-STG SIMPLIFICATION
+ show_pass "Core2Stg" `thenMn_`
let
#ifndef DPH
stg_binds = BSCC("Core2Stg")
ESCC
#endif {- Data Parallel Haskell -}
in
-
+ show_pass "Stg2Stg" `thenMn_`
stg2stg stg_cmds switch_lookup_fn st_mod_name pprStyle st_uniqs stg_binds
`thenMn` \ (stg_binds2, cost_centre_info) ->
if_tce = nullTCE
if_inst_info = emptyBag
in
--} let
+-}
+ show_pass "Interface" `thenMn_`
+ let
mod_interface
= BSCC("MkInterface")
mkInterface switch_is_on if_mod_name export_list_fns
ESCC `thenMn_`
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
+ show_pass "CodeGen" `thenMn_`
let
abstractC = BSCC("CodeGen")
codeGen cc_mod_name -- module name for CC labelling
#endif {- Data Parallel Haskell -}
exitMn 0
{-)-} BEND ) BEND BEND BEND BEND
+
+
+ppSourceStats (Module name exports imports fixities typedecls typesigs
+ classdecls instdecls instsigs defdecls binds
+ [{-no sigs-}] src_loc)
+ = ppAboves (map pp_val
+ [("ExportAll ", export_all), -- 1 if no export list
+ ("ExportDecls ", export_ds),
+ ("ExportModules ", export_ms),
+ ("ImportAll ", import_all),
+ ("ImportPartial ", import_partial),
+ (" PartialDecls ", partial_decls),
+ ("ImportHiding ", import_hiding),
+ (" HidingDecls ", hiding_decls),
+ ("FixityDecls ", fixity_ds),
+ ("DefaultDecls ", defalut_ds),
+ ("TypeDecls ", type_ds),
+ ("DataDecls ", data_ds),
+ ("DataConstrs ", data_constrs),
+ ("DataDerivings ", data_derivs),
+ ("ClassDecls ", class_ds),
+ ("ClassMethods ", class_method_ds),
+ ("DefaultMethods ", default_method_ds),
+ ("InstDecls ", inst_ds),
+ ("InstMethods ", inst_method_ds),
+ ("TypeSigs ", bind_tys),
+ ("ValBinds ", val_bind_ds),
+ ("FunBinds ", fn_bind_ds),
+ ("InlineMeths ", method_inlines),
+ ("InlineBinds ", bind_inlines),
+ ("SpecialisedData ", data_specs),
+ ("SpecialisedInsts ", inst_specs),
+ ("SpecialisedMeths ", method_specs),
+ ("SpecialisedBinds ", bind_specs)
+ ])
+ where
+ pp_val (str, 0) = ppNil
+ pp_val (str, n) = ppBesides [ppStr str, ppInt n]
+
+ (export_decls, export_mods) = getRawIEStrings exports
+ type_decls = filter is_type_decl typedecls
+ data_decls = filter is_data_decl typedecls
+
+ export_ds = length export_decls
+ export_ms = length export_mods
+ export_all = if export_ds == 0 && export_ms == 0 then 1 else 0
+
+ fixity_ds = length fixities
+ defalut_ds = length defdecls
+ type_ds = length type_decls
+ data_ds = length data_decls
+ class_ds = length classdecls
+ inst_ds = length instdecls
+
+ (val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
+ = count_binds binds
+
+ (import_all, import_partial, partial_decls, import_hiding, hiding_decls)
+ = foldr add5 (0,0,0,0,0) (map import_info imports)
+ (data_constrs, data_derivs)
+ = foldr add2 (0,0) (map data_info data_decls)
+ (class_method_ds, default_method_ds)
+ = foldr add2 (0,0) (map class_info classdecls)
+ (inst_method_ds, method_specs, method_inlines)
+ = foldr add3 (0,0,0) (map inst_info instdecls)
+
+ data_specs = length (filter is_data_spec_sig typesigs)
+ inst_specs = length (filter is_inst_spec_sig instsigs)
+
+
+ count_binds EmptyBinds = (0,0,0,0,0)
+ count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
+ count_binds (SingleBind b) = case count_bind b of
+ (vs,fs) -> (vs,fs,0,0,0)
+ count_binds (BindWith b sigs) = case (count_bind b, count_sigs sigs) of
+ ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is)
+
+ count_bind EmptyBind = (0,0)
+ 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 (PatMonoBind (VarPatIn n) r _) = (1,0)
+ 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 (Sig _ _ _ _) = (1,0,0,0)
+ sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
+ sig_info (SpecSig _ _ _ _) = (0,0,1,0)
+ sig_info (InlineSig _ _ _) = (0,0,0,1)
+ sig_info _ = (0,0,0,0)
+
+ import_info (ImportAll _ _) = (1,0,0,0,0)
+ import_info (ImportSome _ ds _) = (0,1,length ds,0,0)
+ import_info (ImportButHide _ ds _) = (0,0,0,1,length ds)
+
+ data_info (TyData _ _ _ constrs derivs _ _)
+ = (length constrs, length derivs)
+
+ class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
+ = case count_sigs meth_sigs of
+ (_,classops,_,_) ->
+ (classops, addpr (count_monobinds def_meths))
+
+ inst_info (InstDecl _ _ _ inst_meths _ _ _ inst_sigs _ _)
+ = case count_sigs inst_sigs of
+ (_,_,ss,is) ->
+ (addpr (count_monobinds inst_meths), ss, is)
+
+ is_type_decl (TySynonym _ _ _ _ _) = True
+ is_type_decl _ = False
+ is_data_decl (TyData _ _ _ _ _ _ _) = True
+ is_data_decl _ = False
+ is_data_spec_sig (SpecDataSig _ _ _) = True
+ is_data_spec_sig _ = False
+ is_inst_spec_sig (InstSpecSig _ _ _) = True
+
+ addpr (x,y) = x+y
+ add1 x1 y1 = x1+y1
+ add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
+ add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
+ add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
+ add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff