Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/29ab199a1b42155431e1751c5dd71ee536282e58 >--------------------------------------------------------------- commit 29ab199a1b42155431e1751c5dd71ee536282e58 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Thu Jul 5 16:42:45 2012 +0100 Fix eager value splitting with an updated value in focus >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/Split.hs | 17 ++++++++++++----- 1 files changed, 12 insertions(+), 5 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs index 5a2062b..ec5caa7 100644 --- a/compiler/supercompile/Supercompile/Drive/Split.hs +++ b/compiler/supercompile/Supercompile/Drive/Split.hs @@ -413,11 +413,18 @@ noneBracketed' tgs a = TailsUnknown (Shell { shellExtraTags = tgs, shellExtraFvs oneBracketed :: UniqSupply -> Type -> (Entered, (Heap, Stack, In AnnedTerm)) -> Bracketed (Entered, UnnormalisedState) oneBracketed ctxt_ids ty (ent, (Heap h ids, k, in_e)) | eAGER_SPLIT_VALUES - , Just (cast_by, Nothing) <- isTrivialStack_maybe k -- NB: this might find a cast even when we have an answer in the context since the state is unnormalised - , Just anned_a <- termToAnswer ids in_e -- FIXME: deal with updates arriving from isTrivialStack_maybe (but eager value splitting is on the way out) - = fmap (\(ent', (deeds, Heap h' ids', k', in_e')) -> (if isOnce ent then ent' else Many, (deeds, Heap (h' `M.union` h) ids', k', in_e'))) $ -- Push heap of positive information/new lambda-bounds down + fix hole Entereds - modifyShell (\shell -> shell { shellExtraFvs = shellExtraFvs shell `minusVarSet` fst (pureHeapVars h) LambdaBound }) $ -- Fix bracket FVs by removing anything lambda-bound above - splitAnswer ctxt_ids ids (annedToTagged (castAnnedAnswer ids anned_a cast_by)) + , Just (cast_by, mb_update) <- isTrivialStack_maybe k -- NB: this might find a cast even when we have an answer in the context since the state is unnormalised + , Just anned_a0 <- termToAnswer ids in_e -- NB: I could push extra heap into the bracketed_a1 using the mb_update if it is Just, but I don't think I usually need to + , let anned_a1 = castAnnedAnswer ids anned_a0 cast_by + bracketed_a1 = fmap (\(ent', (deeds, Heap h' ids', k', in_e')) -> (if isOnce ent then ent' else Many, (deeds, Heap (h' `M.union` h) ids', k', in_e'))) $ -- Push heap of positive information/new lambda-bounds down + fix hole Entereds + modifyShell (\shell -> shell { shellExtraFvs = shellExtraFvs shell `minusVarSet` fst (pureHeapVars h) LambdaBound }) $ -- Fix bracket FVs by removing anything lambda-bound above + splitAnswer ctxt_ids ids (annedToTagged anned_a1) + = case mb_update of + Nothing -> bracketed_a1 + Just (Tagged tg_x' x', cast_by') -> zipBracketeds (TailsUnknown shell [Hole { holeBvs = [x'], holeFiller = bracketed_a1 }]) + where shell = case cast_by' of + CastBy co co_tg -> Shell { shellExtraTags = oneResidTag tg_x' `plusResidTags` oneResidTag co_tg, shellExtraFvs = tyCoVarsOfCo co, shellWrapper = \[e'] -> letRec [(x', e')] (var x' `cast` co) } + Uncast -> Shell { shellExtraTags = oneResidTag tg_x', shellExtraFvs = emptyVarSet, shellWrapper = \[e'] -> letRec [(x', e')] (var x') } | otherwise = oneBracketed' ty (ent, (emptyDeeds, Heap h ids, k, in_e)) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
