[commit: ghc] : Memo table preinitialization in Process3 (d1b4982)

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

On branch  : 

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

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

commit d1b498227c32c7b51fb3ec61b85ca01e6ce6f333
Author: Max Bolingbroke <[email protected]>
Date:   Wed Feb 1 14:30:55 2012 +0000

    Memo table preinitialization in Process3

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

 .../supercompile/Supercompile/Drive/Process.hs     |   11 +++++----
 .../supercompile/Supercompile/Drive/Process3.hs    |   21 +++++++++++++++----
 compiler/supercompile/Supercompile/StaticFlags.hs  |    3 ++
 3 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index d68d0bf..9445c30 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -295,7 +295,9 @@ prepareTerm unfoldings e = pprTraceSC "unfoldings" (pPrintPrecLetRec noPrec (M.t
         preinit_heap = mk_heap internallyBound
 
         -- NB: we assume that unfoldings are guaranteed to be cheap and hence duplicatiable. I think this is reasonable.
-        preinit_with = [(gc (normalise (maxBound, preinit_heap, [], anned_e')), accessor_e) | (x', anned_e) <- h_unfoldings, (accessor_e, anned_e') <- eta ids (var x') anned_e]
+        preinit_with = [(gc (normalise (maxBound, heap', [], anned_e')), accessor_e)
+                       | (x', anned_e) <- h_unfoldings
+                       , (heap', accessor_e, anned_e') <- eta preinit_heap (var x') anned_e]
 
         -- FIXME: instead of adding unfoldings as Let, (in order to sidestep the bug where Let stuff will be underspecialised)
         -- we should add it them as normal bindings but pre-initialise the memo cache. Of course this will be bad in the case
@@ -322,8 +324,8 @@ prepareTerm unfoldings e = pprTraceSC "unfoldings" (pPrintPrecLetRec noPrec (M.t
 
 -- Especially when we do eager value splitting, we might never actually match against the RHS of a binding like (map = \f xs -> ...).
 -- This "hack" is designed to work around this issue by doing some eager value splitting of our own on lambdas.
-eta :: InScopeSet -> FVedTerm -> In AnnedTerm -> [(FVedTerm, In AnnedTerm)]
-eta ids accessor_e0 in_e = (accessor_e0, in_e) : case termToAnswer ids in_e of
+eta :: Heap -> FVedTerm -> In AnnedTerm -> [(Heap, FVedTerm, In AnnedTerm)]
+eta heap@(Heap h ids) accessor_e0 in_e = (heap, accessor_e0, in_e) : case termToAnswer ids in_e of
   Just anned_a | (a_cast, (rn, v)) <- extract anned_a
                , let accessor_e1 = case a_cast of Uncast      -> accessor_e0
                                                   CastBy co _ -> accessor_e0 `cast` mkSymCo ids co
@@ -333,11 +335,10 @@ eta ids accessor_e0 in_e = (accessor_e0, in_e) : case termToAnswer ids in_e of
                         _                 -> Nothing
                      (ids', rn', x') = renameNonRecBinder ids rn x
                , Just (accessor_e2, _, e_body) <- mb_res
-               -> eta ids' accessor_e2 (rn', e_body)
+               -> eta (Heap (M.insert x' lambdaBound h) ids') accessor_e2 (rn', e_body)
   _            -> []
 
 
-
 data SCStats = SCStats {
     stat_reduce_stops :: !Int,
     stat_sc_stops :: !Int
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 5977e1e..9ca615d 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -68,8 +68,8 @@ data MemoState = MS {
     hNames   :: Stream Name
   }
 
-promise :: (State, State) -> MemoState -> (Promise, MemoState)
-promise (state, reduced_state) ms = (p, ms')
+promise :: MemoState -> (State, State) -> (MemoState, Promise)
+promise ms (state, reduced_state) = (ms', p)
   where (vs_list, h_ty) = stateAbsVars (Just (stateLambdaBounders reduced_state)) state
         h_name :< h_names' = hNames ms
         x = mkLocalId h_name h_ty
@@ -330,7 +330,7 @@ memo opt state
                                      ; res <- addParentM p (opt (Just (getOccString (varName (fun p))))) state
                                      ; traceRenderM "<sc }" (fun p, PrettyDoc (pPrintFullState quietStatePrettiness state), res)
                                      ; fulfillM p res }, s { scpMemoState = ms' })
-                where (p, ms') = promise (state, reduced_state) (scpMemoState s)
+                where (ms', p) = promise (scpMemoState s) (state, reduced_state)
   where (state_did_reduce, reduced_state) = reduceForMatch state
         
         -- The idea here is to prevent the supercompiler from building loops when doing instance matching. Without
@@ -417,5 +417,16 @@ reduceForMatch :: State -> (Bool, State)
 reduceForMatch state = second gc $ reduceWithFlag (case state of (_, h, k, e) -> (maxBound, h, k, e)) -- Reduce ignoring deeds for better normalisation
 
 supercompile :: M.Map Var Term -> Term -> Term
-supercompile unfoldings e = fVedTermToTerm $ runScpM (tagAnnotations state) $ liftM snd $ sc state
-  where (state, _) = prepareTerm unfoldings e
+supercompile unfoldings e = fVedTermToTerm $ runScpM (tagAnnotations state) $ do
+    the_state <- if pREINITALIZE_MEMO_TABLE
+                  then preinitalise preinit_with >> return preinit_state
+                  else return state
+    liftM snd $ sc the_state
+  where (state, (preinit_with, preinit_state)) = prepareTerm unfoldings e
+
+preinitalise :: [(State, FVedTerm)] -> ScpM ()
+preinitalise states_fulfils = do
+    ps_es' <- ScpM $ StateT $ \s -> do
+          let (ms', ps_es') = mapAccumL (\ms (state, e') -> second (flip (,) e') $ promise ms (state, snd (reduceForMatch state))) (scpMemoState s) states_fulfils
+          return (ps_es', s { scpMemoState = ms' })
+    mapM_ (\(p, e') -> fulfillM p (emptyDeeds, e')) ps_es'
diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs
index 6379636..c9addba 100644
--- a/compiler/supercompile/Supercompile/StaticFlags.hs
+++ b/compiler/supercompile/Supercompile/StaticFlags.hs
@@ -42,6 +42,9 @@ pOSITIVE_INFORMATION :: Bool
 pOSITIVE_INFORMATION = lookUp $ fsLit "-fsupercompiler-positive-information"
 --pOSITIVE_INFORMATION = True
 
+pREINITALIZE_MEMO_TABLE :: Bool
+pREINITALIZE_MEMO_TABLE = not $ lookUp $ fsLit "-fsupercompiler-no-preinitalize"
+
 data DeedsPolicy = FCFS | Proportional
                  deriving (Read)