[commit: ghc] supercompiler: Some comments + changes in how often we instance-match (8b7e0b3)
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/8b7e0b3f29453f196f350054643f6d95ade1c6e5 >--------------------------------------------------------------- commit 8b7e0b3f29453f196f350054643f6d95ade1c6e5 Author: Max Bolingbroke <[email protected]> Date: Thu Sep 27 15:19:49 2012 +0100 Some comments + changes in how often we instance-match >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process3.hs | 14 ++++++++++---- .../supercompile/Supercompile/Evaluator/Syntax.hs | 3 +-- compiler/supercompile/Supercompile/StaticFlags.hs | 9 +++++++-- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 7427aec..742e683 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -579,7 +579,12 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state -- up with a FIXME: continue RightGivesTypeGen rn_l s rn_r -> trace "typegen" $ (True, do { (deeds, e') <- memo_opt s ; (_, e'_r) <- renameSCResult (case s of (_, Heap _ ids, _, _) -> ids) (rn_r, e') - ; when (not sC_ROLLBACK || is_ancestor) $ do + -- OH MY GOD: + -- - If we do memo-rollback or sc-rollback then we CAN'T overwrite old fulfilments + -- because they might end up pointing to a promise which gets rolled back + -- - So we can *either* overwrite old fulfilments, or not RB to ancestors (e.g. upon type gen) + -- - But overwriting old fulfilments is the main thing we wanted to achieve, so we better make that choice :( + ; when (not sC_ROLLBACK && not is_ancestor) $ do (_, e'_l) <- renameSCResult (case s of (_, Heap _ ids, _, _) -> ids) (rn_l, e') refulfillM p e'_l ; return (deeds, e'_r) })) $ @@ -591,9 +596,10 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state , p_sibling <- p_parent:p_siblings ] ++ [ (p_root, False, emptyInScopeSet) | p_root <- unparented_ps ] - , let inst_mtch | not iNSTANCE_MATCHING = NoInstances - | is_ancestor = AllInstances - | otherwise = InstancesOfGeneralised + , let inst_mtch = case iNSTANCE_MATCHING of + NoInstances -> NoInstances + InstancesOfGeneralised -> InstancesOfGeneralised + AllInstances -> if is_ancestor then AllInstances else InstancesOfGeneralised mm = MSGMode { msgCommonHeapVars = common_h_vars } -- mm = MM { matchInstanceMatching = inst_mtch, matchCommonHeapVars = common_h_vars } --, Just (heap_inst, k_inst, rn_lr) <- [-- (\res -> if isNothing res then pprTraceSC "no match:" (ppr (fun p)) res else pprTraceSC "match!" (ppr (fun p)) res) $ diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index eac6b5c..2c81a73 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -11,6 +11,7 @@ import Supercompile.Core.Size import Supercompile.Core.Syntax import Supercompile.Core.Tag +import Supercompile.StaticFlags import Supercompile.Utilities import Id (Id, idType, zapIdOccInfo) @@ -208,8 +209,6 @@ qaToAnswer qa = case qa of Answer a -> Just a; Question _ -> Nothing type Generalised = Bool -data InstanceMatching = NoInstances | InstancesOfGeneralised | AllInstances - mayInstantiate :: InstanceMatching -> Generalised -> Bool mayInstantiate NoInstances _ = False mayInstantiate InstancesOfGeneralised gen = gen diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs index 166c328..f682bde 100644 --- a/compiler/supercompile/Supercompile/StaticFlags.hs +++ b/compiler/supercompile/Supercompile/StaticFlags.hs @@ -19,8 +19,13 @@ data Superinlinability = ForEverything | ForRecursion | ForNothing sUPERINLINABILITY :: Superinlinability sUPERINLINABILITY = parseEnum "-fsupercompiler-superinlinability" ForRecursion [("", ForRecursion), ("recursion", ForRecursion), ("everything", ForEverything), ("nothing", ForNothing)] -iNSTANCE_MATCHING :: Bool -iNSTANCE_MATCHING = not $ lookUp $ fsLit "-fsupercompiler-no-instance-matching" +data InstanceMatching = NoInstances | InstancesOfGeneralised | AllInstances + +-- I've decided that allowing arbitrary tiebacks to any ancestor state overlaps too much with the combination +-- of MSG-based generalisation+rollback, and has the potential to lose more useful optimisation than that combo does. +-- Matching back to generalised stuff is still a good idea, but we need to propagate generalised flags more agressively (FIXME) +iNSTANCE_MATCHING :: InstanceMatching +iNSTANCE_MATCHING = parseEnum "-fsupercompiler-instance-matching" InstancesOfGeneralised [("full", AllInstances), ("generalised", InstancesOfGeneralised), ("none", NoInstances)] -- This is not remotely safe: fLOAT_TO_MATCH :: Bool