import Rename ( renameModule )
-import MkIface ( startIface, ifaceDecls, endIface )
+import MkIface ( writeIface )
import TcModule ( TcResults(..), typecheckModule )
import Desugar ( deSugar )
import SimplCore ( core2core )
+import OccurAnal ( occurAnalyseBinds )
import CoreLint ( endPass )
+import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders, pprStgBindings )
\end{code}
\begin{code}
-main =
+main = stderr `seq` -- Bug fix. Sigh
-- _scc_ "main"
doIt classifyOpts
\end{code}
ghcExit 1
return (error "parseModule") -- just to get the types right
- POk _ m@(HsModule mod _ _ _ _ _) ->
+ POk _ m@(HsModule mod _ _ _ _ _ _) ->
return (mod, m)
where
glaexts | opt_GlasgowExts = 1#
reportCompile mod_name "Compilation NOT required!" >>
return ();
- Just (this_mod, rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
+ Just (this_mod, rn_mod,
+ old_iface, new_iface,
+ rn_name_supply, fixity_env,
+ imported_modules) ->
-- Oh well, we've got to recompile for real
- -------------------------- Start interface file ----------------
- -- 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 this_mod iface_file_stuff >>= \ if_handle ->
-
-
-------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
typecheckModule tc_uniqs rn_name_supply
- iface_file_stuff rn_mod >>= \ maybe_tc_stuff ->
+ fixity_env rn_mod >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
-------------------------- Desugaring ----------------
_scc_ "DeSugar"
- deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code) ->
+ deSugar this_mod ds_uniqs tc_results >>= \ (desugared, rules, h_code, c_code, fe_binders) ->
-------------------------- Main Core-language transformations ----------------
_scc_ "Core2Core"
- core2core core_cmds desugared rules >>= \ (simplified, imp_rule_ids) ->
+ core2core core_cmds desugared rules >>= \ (simplified, orphan_rules) ->
-- Do the final tidy-up
tidyCorePgm tidy_uniqs this_mod
- simplified imp_rule_ids >>= \ (tidy_binds, tidy_imp_rule_ids) ->
+ simplified orphan_rules >>= \ (tidy_binds, tidy_orphan_rules) ->
+
+ -- Run the occurrence analyser one last time, so that
+ -- dead binders get dead-binder info. This is exploited by
+ -- code generators to avoid spitting out redundant bindings.
+ -- The occurrence-zapping in Simplify.simplCaseBinder means
+ -- that the Simplifier nukes useful dead-var stuff especially
+ -- in case patterns.
+ let occ_anal_tidy_binds = occurAnalyseBinds tidy_binds in
+
+ coreBindsSize occ_anal_tidy_binds `seq`
+-- TEMP: the above call zaps some space usage allocated by the
+-- simplifier, which for reasons I don't understand, persists
+-- thoroughout code generation
+
-------------------------- Convert to STG code -------------------------------
show_pass "Core2Stg" >>
_scc_ "Core2Stg"
let
- stg_binds = topCoreBindsToStg c2s_uniqs tidy_binds
+ stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds
in
-------------------------- Simplify STG code -------------------------------
let
final_ids = collectFinalStgBinders (map fst stg_binds2)
in
- ifaceDecls if_handle local_tycons local_classes
- inst_info final_ids tidy_binds imp_rule_ids >>
- endIface if_handle >>
- -- We are definitely done w/ interface-file stuff at this point:
- -- (See comments near call to "startIface".)
+ writeIface this_mod old_iface new_iface
+ local_tycons local_classes inst_info
+ final_ids occ_anal_tidy_binds tidy_orphan_rules >>
-------------------------- Code generation -------------------------------
_scc_ "CodeGen"
codeGen this_mod imported_modules
cost_centre_info
+ fe_binders
local_tycons local_classes
stg_binds2 >>= \ abstractC ->
-------------------------- Code output -------------------------------
show_pass "CodeOutput" >>
_scc_ "CodeOutput"
- codeOutput this_mod c_code h_code abstractC ncg_uniqs >>
+ codeOutput this_mod local_tycons local_classes
+ occ_anal_tidy_binds stg_binds2
+ c_code h_code abstractC
+ ncg_uniqs >>
-------------------------- Final report -------------------------------
then \ what -> hPutStr stderr ("*** "++what++":\n")
else \ what -> return ()
-ppSourceStats short (HsModule name version exports imports decls src_loc)
+ppSourceStats short (HsModule name version exports imports decls _ src_loc)
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
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)
+ 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 (NoInlineSig _ _ _) = (0,0,0,1)
+ sig_info _ = (0,0,0,0)
import_info (ImportDecl _ _ qual as spec _)
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
spec_info (Just (False, _)) = (0,0,0,0,1,0)
spec_info (Just (True, _)) = (0,0,0,0,0,1)
- data_info (TyData _ _ _ _ constrs derivs _ _)
- = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+ data_info (TyData _ _ _ _ _ nconstrs derivs _ _)
+ = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info other = (0,0)
- class_info (ClassDecl _ _ _ meth_sigs def_meths _ _ _ _ _)
+ class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _ _)
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
projects / ghc-hetmet.git / blobdiff