[commit: ghc] supercompiler: Record generalisation info in children tree (d5374d3)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : supercompiler

http://hackage.haskell.org/trac/ghc/changeset/d5374d36395ef384ba8d227e083f78d671dc4878

>---------------------------------------------------------------

commit d5374d36395ef384ba8d227e083f78d671dc4878
Author: Max Bolingbroke <[email protected]>
Date:   Tue Jan 17 14:31:47 2012 +0000

    Record generalisation info in children tree

>---------------------------------------------------------------

 .../supercompile/Supercompile/Drive/Process.hs     |   14 +++++++-------
 .../supercompile/Supercompile/Drive/Process3.hs    |   17 ++++++++---------
 2 files changed, 15 insertions(+), 16 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index b72875f..c53acf8 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -95,13 +95,13 @@ mK_GENERALISER :: State -> State -> Generaliser
 --          | otherwise  = wqo1
 
 
-type ParentChildren = M.Map (Maybe Var) [(Var, State)]
+type ParentChildren = M.Map (Maybe Var) [(Var, (State, Bool))]
 
 emptyParentChildren :: ParentChildren
 emptyParentChildren = M.empty
 
-addChild :: Maybe Var -> Var -> State -> ParentChildren -> ParentChildren
-addChild mb_parent child child_state = M.alter (\mb_children -> Just ((child, child_state) : (mb_children `orElse` []))) mb_parent
+addChild :: Maybe Var -> Var -> State -> Bool -> ParentChildren -> ParentChildren
+addChild mb_parent child child_state gen = M.alter (\mb_children -> Just ((child, (child_state, gen)) : (mb_children `orElse` []))) mb_parent
 
 childrenSummary :: ParentChildren -> String
 childrenSummary parent_children = unlines [maybe "<root>" varString mb_parent ++ ": " ++ intercalate " " (map show child_counts)  | (mb_parent, child_counts :: [Int]) <- ordered_counts]
@@ -111,7 +111,7 @@ childrenSummary parent_children = unlines [maybe "<root>" varString mb_parent ++
 -- NB: there may be many deepest paths, but this function only returns one of them
 deepestPath :: [(Var, FVedTerm)] -> ParentChildren -> SDoc
 deepestPath fulfils parent_children = maybe empty (\(_, states) -> show_meaning_chain M.empty states $$ show_fulfils_chain (map fst states)) (M.lookup Nothing deepest)
-  where deepest :: M.Map (Maybe Var) (Int, [(Var, State)])
+  where deepest :: M.Map (Maybe Var) (Int, [(Var, (State, Bool))])
         deepest = flip M.map parent_children $ \children -> maximumBy (comparing fst) [(depth + 1, (fun, state):states) | (fun, state) <- children, let (depth, states) = M.findWithDefault (0, []) (Just fun) deepest]
 
         fulfils_map :: M.Map Var FVedTerm
@@ -120,10 +120,10 @@ deepestPath fulfils parent_children = maybe empty (\(_, states) -> show_meaning_
         show_fulfils_chain :: [Var] -> SDoc
         show_fulfils_chain = flip (pPrintPrecLetRec noPrec) (PrettyDoc (text "...")) . mapMaybe (\x -> fmap ((,) x) $ M.lookup x fulfils_map)
 
-        show_meaning_chain :: M.Map Var Bool -> [(Var, State)] -> SDoc
+        show_meaning_chain :: M.Map Var Bool -> [(Var, (State, Bool))] -> SDoc
         show_meaning_chain _         [] = empty
-        show_meaning_chain known_bvs ((fun, state@(_, Heap h _, _, _)):states)
-          = hang (ppr fun) 2 (pPrintFullState (quietStatePrettiness { excludeBindings = unchanged_bvs }) state) $$
+        show_meaning_chain known_bvs ((fun, (state@(_, Heap h _, _, _), gen)):states)
+          = hang (ppr fun <+> (if gen then text "(GENERALISED)" else empty)) 2 (pPrintFullState (quietStatePrettiness { excludeBindings = unchanged_bvs }) state) $$
             show_meaning_chain known_bvs' states
           where known_bvs'  = M.map (maybe False (termIsValue . snd) . heapBindingTerm) h
                 unchanged_bvs = M.keysSet (M.filter id (M.intersectionWith (==) known_bvs known_bvs'))
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index b96eb30..1960b45 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -143,7 +143,7 @@ scpDepth = length . scpParents
 traceRenderM :: Outputable a => String -> a -> ScpM ()
 traceRenderM msg x = ScpM $ StateT $ \s -> ReaderT $ \env -> pprTraceSC (replicate (scpDepth env) ' ' ++ msg) (pPrint x) $ pure ((), s) -- TODO: include depth, refine to ScpM monad only
 
-addParentM :: Promise -> (State -> ScpM (Deeds, FVedTerm)) -> State -> ScpM (Deeds, FVedTerm)
+addParentM :: Promise -> (State -> ScpM (Bool, (Deeds, FVedTerm))) -> State -> ScpM (Deeds, FVedTerm)
 addParentM p opt state = ScpM $ StateT $ \s -> ReaderT $ add_parent s
   where
     add_parent s env
@@ -152,9 +152,8 @@ addParentM p opt state = ScpM $ StateT $ \s -> ReaderT $ add_parent s
       = return ((deeds, e), s)
       | otherwise
       = trace ("depth: " ++ show (scpDepth env) ++ ' ' : showSDoc (parens (hsep (map ppr (scpParents env))))) $
-        unReaderT (unStateT (unScpM (opt state))
-                            (s { scpParentChildren = addChild (safeHead (scpParents env)) (fun p) (meaning p) (scpParentChildren s) }))
-                  (env { scpParents = fun p : scpParents env })
+        unReaderT (unStateT (unScpM (opt state)) s)
+                  (env { scpParents = fun p : scpParents env }) >>= \((gen, res), s') -> return (res, s' { scpParentChildren = addChild (safeHead (scpParents env)) (fun p) (meaning p) gen (scpParentChildren s') })
 
 fulfillM :: Promise -> (Deeds, FVedTerm) -> ScpM (Deeds, FVedTerm)
 fulfillM p res = ScpM $ StateT $ \s -> case fulfill p res (scpFulfilmentState s) of (res', fs') -> return (res', s { scpFulfilmentState = fs' })
@@ -175,7 +174,7 @@ speculateM state mcont = ScpM $ StateT $ \s -> ReaderT $ \env -> case speculate
 sc :: State -> ScpM (Deeds, FVedTerm)
 sc = memo sc' . gc -- Garbage collection necessary because normalisation might have made some stuff dead
 
-sc' :: Maybe String -> State -> ScpM (Deeds, FVedTerm)
+sc' :: Maybe String -> State -> ScpM (Bool, (Deeds, FVedTerm))
 sc' mb_h state = case mb_h of
   Nothing -> speculateM (reduce state) $ \state -> my_split state sc
   Just h  -> terminateM h state (speculateM (reduce state) $ \state -> my_split state sc)
@@ -191,8 +190,8 @@ sc' mb_h state = case mb_h of
                                                    (case unMatch (match' (reduceForMatch shallow_state) (reduceForMatch state)) of Left why -> text why))
     trce1 state = pPrintFullState quietStatePrettiness state $$ pPrintFullState quietStatePrettiness (reduceForMatch state)
 
-    my_generalise gen = liftM (\splt -> insert_tags . splt) . generalise gen
-    my_split      opt =                 insert_tags . split opt
+    my_generalise gen = liftM (\splt -> liftM ((,) True)  . insert_tags . splt) . generalise gen
+    my_split      opt =                 liftM ((,) False) . insert_tags . split opt
     --insert_tags = liftM (\(_, deeds, e') -> (deeds, e'))
     insert_tags mx = do
       (resid_tags, deeds, e') <- mx
@@ -228,10 +227,10 @@ sc' mb_h state = case mb_h of
 -- So we should probably work out why the existing supercompiler never builds dumb loops like this, so
 -- we can carefully preserve that property when making the Arjan modification.
 
-memo :: (Maybe String -> State -> ScpM (Deeds, FVedTerm))
+memo :: (Maybe String -> State -> ScpM (Bool, (Deeds, FVedTerm)))
      ->  State -> ScpM (Deeds, FVedTerm)
 memo opt state
-  | skip_tieback = opt Nothing state
+  | skip_tieback = liftM snd $ opt Nothing state
   | otherwise = join $ ScpM $ StateT $ \(ScpState ms hist fs resid_tags parent_children) ->
     -- NB: If tb contains a dead PureHeap binding (hopefully impossible) then it may have a free variable that
     -- I can't rename, so "rename" will cause an error. Not observed in practice yet.