[commit: ghc] supercompiler: Check for triviality in renaming before returning a type generalisation (d1417a28)
Max Bolingbroke <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/d1417a283b5e55afa3fbff94aaa7ea18373d4fb8 >--------------------------------------------------------------- commit d1417a283b5e55afa3fbff94aaa7ea18373d4fb8 Author: Max Bolingbroke <[email protected]> Date: Tue Jul 17 14:58:18 2012 +0100 Check for triviality in renaming before returning a type generalisation >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/MSG.hs | 10 +++++++++- 1 files changed, 9 insertions(+), 1 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index 2779634..7038075 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -467,12 +467,20 @@ msgMatch inst_mtch ((_, Heap h_l _, rn_l, k_l), (heap@(Heap _ ids), k, qa), (dee -- 2) Do both heaps only contain lambdaBounds? , isPureHeapEmpty h_l , isPureHeapEmpty h_r - = Just (RightGivesTypeGen rn_l (deeds_r, heap, k, qa) rn_r) + -- 3) Are both type substitutions non-trivial? If they are trivial then we risk not making any progress after we generalise away the type info + , let state = (deeds_r, heap, k, qa) + fvs = stateFreeVars state + , isTypeRenamingNonTrivial rn_l fvs + , isTypeRenamingNonTrivial rn_r fvs + = Just (RightGivesTypeGen rn_l state rn_r) -- No information gained in this case :-( | otherwise = Nothing +isTypeRenamingNonTrivial :: Renaming -> FreeVars -> Bool +isTypeRenamingNonTrivial rn fvs = (\f -> foldVarSet f False fvs) $ \x rest -> (isTyVar x && isNothing (getTyVar_maybe (lookupTyVarSubst rn x))) || rest + msg :: MSGMode -> State -> State -> MSG' MSGResult msg mm (deeds_l, heap_l, k_l, qa_l) (deeds_r, heap_r, k_r, qa_r) = -- (\res -> traceRender ("msg", M.keysSet h_l, residualiseDriveState (Heap h_l prettyIdSupply, k_l, in_e_l), M.keysSet h_r, residualiseDriveState (Heap h_r prettyIdSupply, k_r, in_e_r), res) res) $ -- TODO: test for multiple solutions? Attempt to choose best?