[commit: ghc] : Have prepareTerm return a preinitialized version of the term as well (b85fbf2)

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

On branch  : 

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

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

commit b85fbf24f62f308be076698dc7b07c3601aba9fd
Author: Max Bolingbroke <[email protected]>
Date:   Tue Jan 31 18:13:21 2012 +0000

    Have prepareTerm return a preinitialized version of the term as well

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

 .../supercompile/Supercompile/Drive/Process.hs     |   36 +++++++++++++++++--
 .../supercompile/Supercompile/Drive/Process1.hs    |    2 +-
 .../supercompile/Supercompile/Drive/Process2.hs    |    2 +-
 .../supercompile/Supercompile/Drive/Process3.hs    |    2 +-
 4 files changed, 35 insertions(+), 7 deletions(-)

diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs
index 52f33bd..d68d0bf 100644
--- a/compiler/supercompile/Supercompile/Drive/Process.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process.hs
@@ -265,15 +265,16 @@ tagAnnotations (_, Heap h _, k, qa) = IM.unions [go_term (extAnn x []) e | (x, h
 
 
 
-prepareTerm :: M.Map Var Term -> Term -> State
+prepareTerm :: M.Map Var Term -> Term -> (State,                        -- For use without memo-cache preinitalization
+                                          ([(State, FVedTerm)], State)) -- With preinitialization
 prepareTerm unfoldings e = pprTraceSC "unfoldings" (pPrintPrecLetRec noPrec (M.toList unfoldings) (PrettyDoc (text "<stuff>"))) $
                            pprTraceSC "all input FVs" (ppr input_fvs) $
-                           state
+                           (state, (preinit_with, preinit_state))
   where (tag_ids0, tag_ids1) = splitUniqSupply tagUniqSupply
         anned_e = toAnnedTerm tag_ids0 e
         
         ((input_fvs, tag_ids2), h_unfoldings) = mapAccumL add_one_unfolding (annedTermFreeVars anned_e, tag_ids1) (M.toList unfoldings)
-          where add_one_unfolding (input_fvs', tag_ids1) (x', e) = ((input_fvs'', tag_ids2), (x', letBound (renamedTerm anned_e)))
+          where add_one_unfolding (input_fvs', tag_ids1) (x', e) = ((input_fvs'', tag_ids2), (x', renamedTerm anned_e))
                     where (tag_unf_ids, tag_ids2) = splitUniqSupply tag_ids1
                           anned_e = toAnnedTerm tag_unf_ids e
                           input_fvs'' = input_fvs' `unionVarSet` annedFreeVars anned_e
@@ -284,7 +285,17 @@ prepareTerm unfoldings e = pprTraceSC "unfoldings" (pPrintPrecLetRec noPrec (M.t
         
         -- NB: h_fvs might contain bindings for things also in h_unfoldings, so union them in the right order
         deeds = Deeds { sizeLimit = (bLOAT_FACTOR - 1) * annedSize anned_e, stepLimit = (bLOAT_FACTOR - 1) * annedSize anned_e }
-        state = normalise (deeds, Heap (M.fromList h_unfoldings `M.union` M.fromList h_fvs) (mkInScopeSet input_fvs), [], (mkIdentityRenaming input_fvs, anned_e))
+        rn = mkIdentityRenaming input_fvs
+        ids = mkInScopeSet input_fvs
+        mk_heap how_bound = Heap (M.fromList (map (second how_bound) h_unfoldings) `M.union` M.fromList h_fvs) ids
+        
+        state = normalise (deeds, mk_heap letBound, [], (rn, anned_e))
+        
+        preinit_state = normalise (deeds, preinit_heap, [], (rn, anned_e))
+        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]
 
         -- 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
@@ -309,6 +320,23 @@ prepareTerm unfoldings e = pprTraceSC "unfoldings" (pPrintPrecLetRec noPrec (M.t
         -- It is uniquely OK to do this at *top* level because otherwise we will end up trapping specialisations
         -- lower down in the specialised output where they cannot be reused.
 
+-- 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
+  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
+                     mb_res@(Just (_, x, _)) = case v of
+                        Lambda   x e_body -> Just (accessor_e1 `app`   x',           x, e_body)
+                        TyLambda a e_body -> Just (accessor_e1 `tyApp` mkTyVarTy x', a, e_body)
+                        _                 -> Nothing
+                     (ids', rn', x') = renameNonRecBinder ids rn x
+               , Just (accessor_e2, _, e_body) <- mb_res
+               -> eta ids' accessor_e2 (rn', e_body)
+  _            -> []
+
+
 
 data SCStats = SCStats {
     stat_reduce_stops :: !Int,
diff --git a/compiler/supercompile/Supercompile/Drive/Process1.hs b/compiler/supercompile/Supercompile/Drive/Process1.hs
index 2dfb20f..336b032 100644
--- a/compiler/supercompile/Supercompile/Drive/Process1.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process1.hs
@@ -55,7 +55,7 @@ ifThenElse False _ y = y
 
 supercompile :: M.Map Var Term -> Term -> IO (SCStats, Term)
 supercompile unfoldings e = liftM (second fVedTermToTerm) $ runScpM $ fmap snd $ sc (mkLinearHistory (cofmap fst wQO)) S.empty state
-  where state = prepareTerm unfoldings e
+  where (state, _) = prepareTerm unfoldings e
 
 --
 -- == The drive loop ==
diff --git a/compiler/supercompile/Supercompile/Drive/Process2.hs b/compiler/supercompile/Supercompile/Drive/Process2.hs
index 46244a2..7ba0ee9 100644
--- a/compiler/supercompile/Supercompile/Drive/Process2.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process2.hs
@@ -330,4 +330,4 @@ foo = undefined
 
 supercompile :: M.Map Var Term -> Term -> Term
 supercompile unfoldings e = fVedTermToTerm $ unI $ runFulfilmentT $ runHistoryThreadM $ runMemoT $ runContT $ runScpM $ liftM (foo . fmap snd) $ sc 0 state
-  where state = prepareTerm unfoldings e
+  where (state, _) = prepareTerm unfoldings e
diff --git a/compiler/supercompile/Supercompile/Drive/Process3.hs b/compiler/supercompile/Supercompile/Drive/Process3.hs
index 3000f83..5977e1e 100644
--- a/compiler/supercompile/Supercompile/Drive/Process3.hs
+++ b/compiler/supercompile/Supercompile/Drive/Process3.hs
@@ -418,4 +418,4 @@ reduceForMatch state = second gc $ reduceWithFlag (case state of (_, h, k, e) ->
 
 supercompile :: M.Map Var Term -> Term -> Term
 supercompile unfoldings e = fVedTermToTerm $ runScpM (tagAnnotations state) $ liftM snd $ sc state
-  where state = prepareTerm unfoldings e
+  where (state, _) = prepareTerm unfoldings e