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