Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/0b86b7a8f86e296e374c220b6539e1f51a9d60c9 >--------------------------------------------------------------- commit 0b86b7a8f86e296e374c220b6539e1f51a9d60c9 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Fri Apr 20 17:39:06 2012 +0100 Some FIXMEs about common-heap-vars optimisation in presence of MSG >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/MSG.hs | 8 +++++++- .../supercompile/Supercompile/Drive/Process3.hs | 6 +++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/MSG.hs b/compiler/supercompile/Supercompile/Drive/MSG.hs index ebbc313..aa1bd64 100644 --- a/compiler/supercompile/Supercompile/Drive/MSG.hs +++ b/compiler/supercompile/Supercompile/Drive/MSG.hs @@ -132,13 +132,13 @@ data MSGState = MSGState { -- INVARIANT: incoming base variable has *no* extra information beyond Name and Type/Kind msgPend :: RnEnv2 -> Var -> Pending -> MSG Var msgPend rn2 x0 pending = MSG $ \_ s -> Right $ case lookupUpdatePending s of + Right x -> (s, x) Left mk_s -> (s { msgInScopeSet = extendInScopeSet ids' x2, msgPending = (x2, pending) : msgPending s }, x2) where s = mk_s x2 -- This use of rn2 is necessary to ensure new common vars don't clash with rigid binders x1 = uniqAway (rnInScopeSet rn2) x0 (ids', x2) = uniqAway' (msgInScopeSet s) x1 - Right x -> (s, x) where lookupUpdatePending s = case pending of PendingVar x_l x_r -> case mb_x_l_map >>= flip lookupVarEnv x_r of @@ -308,6 +308,12 @@ type MSGResult = ((Deeds, Heap, Renaming, Stack), (Heap, Stack, Anned QA), (Deed -- we're going to satisfy the demand for the States on both sides by driving the (instantiable) -- common State. +-- FIXME: MSG is currently breaking the "common heap vars" optimisation +-- To make sure that it continues to work we need the property that: +-- 1. For every variable bound in the outgoing heap/stack of the {left,right} and common outgoing states.. +-- 2. ..IF it is in the {left,right} incoming InScopeSet.. +-- 3. ..then the thing it is bound in the {left,right} incoming state MUST have the same meaning as the new binding. + msg :: MSGMode -- ^ How to match -> State -- ^ Tieback semantics -> State -- ^ This semantics diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs index 5b8e041..9460ea4 100644 --- a/compiler/supercompile/Supercompile/Drive/Process3.hs +++ b/compiler/supercompile/Supercompile/Drive/Process3.hs @@ -261,6 +261,7 @@ sc' mb_h state = {-# SCC "sc'" #-} case mb_h of (speculateM (reduce state) $ \state -> my_split state sc) (\shallow_h shallow_state shallow_rb -> trce shallow_h shallow_state $ case msg (MSGMode { msgCommonHeapVars = S.empty }) shallow_state state of + -- FIXME: use common heap vars once I fix the MSG issue preventing this optimisation (just supply shallow_state InScopeSet!) -- FIXME: better? In particular, could rollback and then MSG Just (_, (heap@(Heap _ ids), k, qa), (deeds_r, heap_r, rn_r, k_r)) -> pprTrace "MSG success" (pPrintFullState quietStatePrettiness (deeds, heap, k, qa) $$ @@ -363,7 +364,10 @@ memo opt init_state = {-# SCC "memo'" #-} memo_opt init_state | let (parented_ps, unparented_ps) = trainToList (promises (scpMemoState s)) , (p, is_ancestor, common_h_vars) <- [ (p_sibling, fun p_parent == fun p_sibling, common_h_vars) | (p_parent, p_siblings) <- parented_ps - , let common_h_vars = case meaning p_parent of (_, Heap h _, _, _) -> M.keysSet h + , let common_h_vars = S.empty + -- FIXME: the use of MSG prevents this optimisation (for now) + -- FIXME: shouldn't I just use the parent InScopeSet anyway?? + -- case meaning p_parent of (_, Heap h _, _, _) -> M.keysSet h , p_sibling <- p_parent:p_siblings ] ++ [ (p_root, False, S.empty) | p_root <- unparented_ps ] _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
