Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler
http://hackage.haskell.org/trac/ghc/changeset/cf0f6dd1280fa37f27a2a1491ba8079d8d9fc4c9 >--------------------------------------------------------------- commit cf0f6dd1280fa37f27a2a1491ba8079d8d9fc4c9 Author: Max Bolingbroke <batterseapo...@hotmail.com> Date: Tue Jan 17 14:32:01 2012 +0000 Fix map-map fusion >_> >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/Split.hs | 11 +++++++---- compiler/supercompile/Supercompile/StaticFlags.hs | 8 ++++---- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs index 73cb876..e80ba39 100644 --- a/compiler/supercompile/Supercompile/Drive/Split.hs +++ b/compiler/supercompile/Supercompile/Drive/Split.hs @@ -409,6 +409,9 @@ noneBracketed :: Tag -> Out FVedTerm -> Bracketed a noneBracketed tg a = TailsUnknown (Shell { shellExtraTags = oneResidTag tg, shellExtraFvs = freeVars a, shellWrapper = \[] -> a }) [] -- NB: I could use normalise here to make my life easier if transitiveInline didn't treat Bracketed heaps specially +-- +-- NB: it is VERY IMPORTANT that you use oneBracketed' instead in contexts where you might want to use the tails of the bracketed. +-- In particular, if you use oneBracketed to prepare the branches of a case expression then map-map fusion won't work! 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 @@ -1098,7 +1101,7 @@ splitStackFrame ctxt_ids ids kf scruts bracketed_hole scruts' = x':scruts -- 0) Manufacture context identifier - (ctxt_id, ctxt_ids0) = takeUniqFromSupply ctxt_ids + ctxt_id = uniqFromSupply ctxt_ids -- 1) Construct the floats for each case alternative -- We have to carefully zap OccInfo here because one of the case binders might be marked as dead, @@ -1119,9 +1122,9 @@ splitStackFrame ctxt_ids ids kf scruts bracketed_hole `M.union` M.fromList [(x, lambdaBound) | x <- x':alt_bvs]) -- NB: x' might be in scruts and union is left-biased alt_rns alt_cons alt_bvss -- NB: don't need to grab deeds for these just yet, due to the funny contract for transitiveInline alt_bvss = map altConBoundVars alt_cons' - bracketed_alts = zipWith3Equal "bracketed_alts" (\alt_h alt_ids alt_in_e -> oneBracketed ctxt_ids0 ty' (Once ctxt_id, (Heap alt_h alt_ids, [], alt_in_e))) alt_hs alt_idss alt_in_es - StrictLet x' in_e -> zipBracketeds $ TailsKnown ty' (\_final_ty' -> shell emptyVarSet $ \[e_hole, e_body] -> let_ x' e_hole e_body) [TailishHole False $ Hole [] bracketed_hole, TailishHole True $ Hole [x'] $ oneBracketed ctxt_ids0 ty' (Once ctxt_id, (Heap (M.singleton x' lambdaBound) ids, [], in_e))] - where (ctxt_id, ctxt_ids0) = takeUniqFromSupply ctxt_ids + bracketed_alts = zipWith3Equal "bracketed_alts" (\alt_h alt_ids alt_in_e -> oneBracketed' ty' (Once ctxt_id, (emptyDeeds, Heap alt_h alt_ids, [], alt_in_e))) alt_hs alt_idss alt_in_es + StrictLet x' in_e -> zipBracketeds $ TailsKnown ty' (\_final_ty' -> shell emptyVarSet $ \[e_hole, e_body] -> let_ x' e_hole e_body) [TailishHole False $ Hole [] bracketed_hole, TailishHole True $ Hole [x'] $ oneBracketed' ty' (Once ctxt_id, (emptyDeeds, Heap (M.singleton x' lambdaBound) ids, [], in_e))] + where ctxt_id = uniqFromSupply ctxt_ids ty' = inTermType ids in_e PrimApply pop tys' in_vs in_es -> zipBracketeds $ TailsUnknown (shell emptyVarSet $ primOp pop tys') (zipWith Hole (repeat []) $ bracketed_vs ++ bracketed_hole : bracketed_es) where -- 0) Manufacture context identifier (actually, an infinite number of them) diff --git a/compiler/supercompile/Supercompile/StaticFlags.hs b/compiler/supercompile/Supercompile/StaticFlags.hs index d436137..aa04c3b 100644 --- a/compiler/supercompile/Supercompile/StaticFlags.hs +++ b/compiler/supercompile/Supercompile/StaticFlags.hs @@ -26,8 +26,8 @@ eAGER_SPLIT_VALUES = iNSTANCE_MATCHING -- For correctness given that we do insta --eAGER_SPLIT_VALUES = False rEFINE_ALTS :: Bool ---rEFINE_ALTS = True -rEFINE_ALTS = False +rEFINE_ALTS = True +--rEFINE_ALTS = False dEEDS :: Bool dEEDS = "--deeds" `elem` aRGS @@ -39,8 +39,8 @@ bOUND_STEPS = "--bound-steps" `elem` aRGS -- For debugging very long-running supercompilation dEPTH_LIIMT :: Maybe Int -dEPTH_LIIMT = Nothing ---dEPTH_LIIMT = Just 40 +--dEPTH_LIIMT = Nothing +dEPTH_LIIMT = Just 80 data DeedsPolicy = FCFS | Proportional deriving (Read) _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
