diff options
author | Tobias Dammers <tdammers@gmail.com> | 2018-01-30 17:04:47 +0100 |
---|---|---|
committer | Tobias Dammers <tdammers@gmail.com> | 2018-02-06 10:31:05 +0100 |
commit | e6472a2787a3a1c7c465f142dc6d60da6a54b9d6 (patch) | |
tree | 48964d33b16fb1a8eb40fc9bc19a484885f5e168 | |
parent | d74b37d56538823c425d653e45a92f4fdbec9f28 (diff) | |
download | haskell-e6472a2787a3a1c7c465f142dc6d60da6a54b9d6.tar.gz |
Performance improvements based on Trac #11735 and #14683.
Summary:
This includes:
- Refactoring coercionKind / coercionKindRole
- Caching role in NthCo constructor and mkNthCo
- Discard reflexive casts during Simplify
- Additional SCC's to hunt down performance bottlenecks in Coercion,
CoreTidy, and Simplify
Reviewers: goldfire, bgamari
Subscribers: rwbarton, thomie, carter
Differential Revision: https://phabricator.haskell.org/D4385
-rw-r--r-- | compiler/main/TidyPgm.hs | 61 |
1 files changed, 42 insertions, 19 deletions
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index ce8ac53919..c1bc57ffe8 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -337,58 +337,80 @@ tidyProgram hsc_env (ModGuts { mg_module = mod = Err.withTiming (pure dflags) (text "CoreTidy"<+>brackets (ppr mod)) (const ()) $ - do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags - ; expose_all = gopt Opt_ExposeAllUnfoldings dflags - ; print_unqual = mkPrintUnqualified dflags rdr_env + do { let { omit_prags = + {-#SCC "omit_prags" #-} + gopt Opt_OmitInterfacePragmas dflags + ; expose_all = + {-#SCC "expose_all" #-} + gopt Opt_ExposeAllUnfoldings dflags + ; print_unqual = + {-#SCC "print_unqual" #-} + mkPrintUnqualified dflags rdr_env } - ; let { type_env = typeEnvFromEntities [] tcs fam_insts + ; let { type_env = {-#SCC "type_env" #-} + typeEnvFromEntities [] tcs fam_insts ; implicit_binds - = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ + = {-#SCC "implicit_binds" #-} + concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ concatMap getTyConImplicitBinds (typeEnvTyCons type_env) } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags expose_all + <- {-# SCC "chooseExternalIds" #-} + chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_rules (vectInfoVar vect_info) ; let { (trimmed_binds, trimmed_rules) - = findExternalRules omit_prags binds imp_rules unfold_env } + = {-#SCC "findExternalRules" #-} + findExternalRules omit_prags binds imp_rules unfold_env } ; (tidy_env, tidy_binds) - <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds + <- {-#SCC "tidyTopBinds" #-} + tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds - ; let { final_ids = [ id | id <- bindersOfBinds tidy_binds, + ; let { final_ids = {-#SCC "final_ids" #-} + [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] - ; type_env1 = extendTypeEnvWithIds type_env final_ids + ; type_env1 = {-#SCC "type_env1" #-} + extendTypeEnvWithIds type_env final_ids - ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts + ; tidy_cls_insts = {-#SCC "tidy_cls_insts" #-} + map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts -- A DFunId will have a binding in tidy_binds, and so will now be in -- tidy_type_env, replete with IdInfo. Its name will be unchanged since -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the -- tidy_cls_insts. Similarly the Ids inside a PatSyn. - ; tidy_rules = tidyRules tidy_env trimmed_rules + ; tidy_rules = {-#SCC "tidy_rules" #-} + tidyRules tidy_env trimmed_rules -- You might worry that the tidy_env contains IdInfo-rich stuff -- and indeed it does, but if omit_prags is on, ext_rules is -- empty - ; tidy_vect_info = tidyVectInfo tidy_env vect_info + ; tidy_vect_info = {-#SCC "tidy_vect_info" #-} + tidyVectInfo tidy_env vect_info -- Tidy the Ids inside each PatSyn, very similarly to DFunIds -- and then override the PatSyns in the type_env with the new tidy ones -- This is really the only reason we keep mg_patsyns at all; otherwise -- they could just stay in type_env - ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns - ; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1 + ; tidy_patsyns = {-#SCC "tidy_patsyns" #-} + map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns + ; type_env2 = {-#SCC "type_env2" #-} + extendTypeEnvWithPatSyns tidy_patsyns type_env1 - ; tidy_type_env = tidyTypeEnv omit_prags type_env2 + ; tidy_type_env = {-#SCC "tidy_type_env" #-} + tidyTypeEnv omit_prags type_env2 } -- See Note [Grand plan for static forms] in StaticPtrTable. ; (spt_entries, tidy_binds') <- + {-#SCC "sptCreateStaticBinds" #-} sptCreateStaticBinds hsc_env mod tidy_binds - ; let { spt_init_code = sptModuleInitCode mod spt_entries + ; let { spt_init_code = {-#SCC "spt_init_code" #-} + sptModuleInitCode mod spt_entries ; add_spt_init_code = + {-#SCC "add_spt_init_code" #-} case hscTarget dflags of -- If we are compiling for the interpreter we will insert -- any necessary SPT entries dynamically @@ -411,7 +433,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + ; {-#SCC "endPassIO" #-} + endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules -- If the endPass didn't print the rules, but ddump-rules is -- on, print now @@ -421,7 +444,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod (pprRulesForUser dflags tidy_rules) -- Print one-line size info - ; let cs = coreBindsStats tidy_binds + ; let cs = {-#SCC "coreBindStats" #-} coreBindsStats tidy_binds ; when (dopt Opt_D_dump_core_stats dflags) (putLogMsg dflags NoReason SevDump noSrcSpan (defaultDumpStyle dflags) |