Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch :
http://hackage.haskell.org/trac/ghc/changeset/71462ae6b17b6fdd5ed87390894c0e5fb30c73a6 >--------------------------------------------------------------- commit 71462ae6b17b6fdd5ed87390894c0e5fb30c73a6 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Fri Jul 1 13:32:55 2011 +0100 Fix construction of the initial heap from the unfoldings: FVs of unfoldings were not bound >--------------------------------------------------------------- .../supercompile/Supercompile/Drive/Process.hs | 31 +++++++++++-------- 1 files changed, 18 insertions(+), 13 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Process.hs b/compiler/supercompile/Supercompile/Drive/Process.hs index e56c40b..2ea0870 100644 --- a/compiler/supercompile/Supercompile/Drive/Process.hs +++ b/compiler/supercompile/Supercompile/Drive/Process.hs @@ -89,19 +89,24 @@ instance Monoid SCStats where supercompile :: M.Map Var Term -> Term -> (SCStats, Term) -supercompile unfoldings e = pprTraceSC "all input FVs" (ppr input_fvs) $ second fVedTermToTerm $ runScpM $ liftM snd $ sc (mkHistory (cofmap fst wQO)) S.empty state - where anned_e = toAnnedTerm tag_ids e - input_fvs = annedTermFreeVars anned_e - state = normalise ((bLOAT_FACTOR - 1) * annedSize anned_e, Heap (M.fromDistinctAscList anned_h_kvs) (mkInScopeSet input_fvs), [], (mkIdentityRenaming input_fvs, anned_e)) - - (tag_ids, anned_h_kvs) = mapAccumL add_one_heap_binding tagUniqSupply (varSetElems input_fvs) - where add_one_heap_binding tag_ids0 x' = (tag_ids2, (x', hb)) - where (hb, tag_ids2) = case M.lookup x' unfoldings of - Nothing | let (i, tag_ids1) = takeUniqFromSupply tag_ids0 - -> (environmentallyBound (mkTag (getKey i)), tag_ids1) - Just e | let (tag_unf_ids, tag_ids1) = splitUniqSupply tag_ids0 - anned_e = toAnnedTerm tag_unf_ids e - -> (letBound (mkIdentityRenaming (annedFreeVars anned_e), anned_e), tag_ids1) +supercompile unfoldings e = pprTraceSC "unfoldings" (ppr (M.keys unfoldings)) $ + pprTraceSC "all input FVs" (ppr input_fvs) $ + second fVedTermToTerm $ runScpM $ liftM snd $ sc (mkHistory (cofmap fst wQO)) S.empty 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 (mkIdentityRenaming (annedFreeVars anned_e), 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 + + (_, h_fvs) = mapAccumL add_one_fv tag_ids2 (varSetElems input_fvs) + where add_one_fv tag_ids2 x' = (tag_ids3, (x', environmentallyBound (mkTag (getKey i)))) + where (i, tag_ids3) = takeUniqFromSupply tag_ids2 + + -- NB: h_fvs might contain bindings for things also in h_unfoldings, so union them in the right order + state = normalise ((bLOAT_FACTOR - 1) * annedSize anned_e, Heap (M.fromList h_unfoldings `M.union` M.fromList h_fvs) (mkInScopeSet input_fvs), [], (mkIdentityRenaming input_fvs, anned_e)) -- -- == Bounded multi-step reduction == _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
