Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/d5374d36395ef384ba8d227e083f78d671dc4878 >--------------------------------------------------------------- commit d5374d36395ef384ba8d227e083f78d671dc4878 Author: Max Bolingbroke <batterseapo...@hotmail.com> 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. _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
