[commit: ghc] supercompiler: Fix subtle bugs introduced by recent changes (bindMany was bogus, for example..) (6b0f6e3)
Max Bolingbroke <[email protected]>
| Newsgroups | gmane.comp.lang.haskell.cvs.ghc |
|---|---|
| Message-ID | <[email protected]> |
Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : supercompiler http://hackage.haskell.org/trac/ghc/changeset/6b0f6e31c174f8f6aa452cb19cece4fca3e8e12e >--------------------------------------------------------------- commit 6b0f6e31c174f8f6aa452cb19cece4fca3e8e12e Author: Max Bolingbroke <[email protected]> Date: Tue Aug 2 16:54:00 2011 +0100 Fix subtle bugs introduced by recent changes (bindMany was bogus, for example..) >--------------------------------------------------------------- compiler/supercompile/Supercompile/Drive/Split.hs | 32 ++++++++++---------- .../supercompile/Supercompile/Evaluator/Syntax.hs | 4 +- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/compiler/supercompile/Supercompile/Drive/Split.hs b/compiler/supercompile/Supercompile/Drive/Split.hs index b310db6..2b69ff2 100644 --- a/compiler/supercompile/Supercompile/Drive/Split.hs +++ b/compiler/supercompile/Supercompile/Drive/Split.hs @@ -371,30 +371,30 @@ oneBracketed ty x = TailsKnown ty (\_ -> Shell { shellExtraFvs = emptyVarSet, sh zipBracketeds :: Bracketed (Bracketed a) -> Bracketed a zipBracketeds (TailsUnknown bshell bholes) = TailsUnknown (Shell shell_fvs (\es -> shell_wrapper es [])) holes - where (shell_fvs, shell_wrapper, holes) = foldr go (shellExtraFvs bshell, \[] es' -> shellWrapper bshell es', []) bholes + where (shell_fvs, shell_wrapper, holes) = foldr go (shellExtraFvs bshell, \[] rev_es' -> shellWrapper bshell (reverse rev_es'), []) bholes go (Hole bvs bracketed) (shell_extra_fvs, shell_wrapper, holes) = (shell_extra_fvs `unionVarSet` nonRecBindersFreeVars bvs (bracketedExtraFvs rbracketed), - \es es' -> case splitBy (bracketedHoles rbracketed) es of - (es_here, es_later) -> shell_wrapper es_later (shellWrapper (bracketedShell rbracketed) es_here:es'), - holes ++ bracketedHoles rbracketed) + \es rev_es' -> case splitBy (bracketedHoles rbracketed) es of + (es_here, es_later) -> shell_wrapper es_later (shellWrapper (bracketedShell rbracketed) es_here:rev_es'), + bracketedHoles rbracketed ++ holes) where rbracketed = rigidizeBracketed bracketed zipBracketeds (TailsKnown bty mk_bshell bholes) = case ei_holes of Left holes -> TailsUnknown (Shell (mk_shell_fvs bty) (\es -> mk_shell_wrapper bty es [])) holes Right holes -> TailsKnown bty (\ty -> Shell (mk_shell_fvs ty) (\es -> mk_shell_wrapper ty es [])) holes - where (mk_shell_fvs, mk_shell_wrapper, ei_holes) = foldr go (\ty -> shellExtraFvs (mk_bshell ty), \ty [] es' -> shellWrapper (mk_bshell ty) es', Right []) bholes + where (mk_shell_fvs, mk_shell_wrapper, ei_holes) = foldr go (\ty -> shellExtraFvs (mk_bshell ty), \ty [] rev_es' -> shellWrapper (mk_bshell ty) (reverse rev_es'), Right []) bholes go (TailishHole is_tail (Hole bvs bracketed)) (shell_extra_fvs, shell_wrapper, ei_holes) = case bracketed of - TailsKnown _ty mk_shell holes - | is_tail, Right old_holes <- ei_holes + TailsKnown _ty mk_shell holes' + | is_tail, Right holes <- ei_holes -> (\ty -> shell_extra_fvs ty `unionVarSet` nonRecBindersFreeVars bvs (shellExtraFvs (mk_shell ty)), - \ty es es' -> case splitBy holes es of - (es_here, es_later) -> shell_wrapper ty es_later (shellWrapper (mk_shell ty) es_here:es'), - Right (old_holes ++ holes)) + \ty es rev_es' -> case splitBy holes' es of + (es_here, es_later) -> shell_wrapper ty es_later (shellWrapper (mk_shell ty) es_here:rev_es'), + Right (holes' ++ holes)) _ -> (\ty -> shell_extra_fvs ty `unionVarSet` nonRecBindersFreeVars bvs (bracketedExtraFvs rbracketed), - \ty es es' -> case splitBy (bracketedHoles rbracketed) es of - (es_here, es_later) -> shell_wrapper ty es_later (shellWrapper (bracketedShell rbracketed) es_here:es'), - case ei_holes of Left old_holes -> Left (old_holes ++ bracketedHoles rbracketed) - Right old_holes | is_tail -> Left (map tailishHole old_holes ++ bracketedHoles rbracketed) - | otherwise -> Right (old_holes ++ map (TailishHole False) (bracketedHoles rbracketed))) + \ty es rev_es' -> case splitBy (bracketedHoles rbracketed) es of + (es_here, es_later) -> shell_wrapper ty es_later (shellWrapper (bracketedShell rbracketed) es_here:rev_es'), + case ei_holes of Left holes -> Left (holes ++ bracketedHoles rbracketed) + Right holes | is_tail -> Left (bracketedHoles rbracketed ++ map tailishHole holes) + | otherwise -> Right (map (TailishHole False) (bracketedHoles rbracketed) ++ holes)) where rbracketed = rigidizeBracketed bracketed modifyTails :: forall a b. (Type -> Type) -> ([a] -> (b, [a])) -> Bracketed a -> Maybe (b, Bracketed a) @@ -956,7 +956,7 @@ splitStackFrame ctxt_ids ids kf scruts bracketed_hole CastIt co' -> zipBracketeds $ TailsUnknown (Shell (tyCoVarsOfCo co') $ \[e] -> e `cast` co') [Hole [] bracketed_hole] Scrutinise x' ty' (rn, alts) -> -- (if null k_remaining then id else traceRender ("splitStack: FORCED SPLIT", M.keysSet entered_hole, [x' | Tagged _ (Update x') <- k_remaining])) $ -- (if not (null k_not_inlined) then traceRender ("splitStack: generalise", k_not_inlined) else id) $ - zipBracketeds $ TailsKnown ty' (\final_ty' -> Shell (tyVarsOfType final_ty') $ \(e_hole:es_alts) -> case_ e_hole x' final_ty' (alt_cons' `zip` es_alts)) (TailishHole False (Hole [] bracketed_hole) : zipWith (\alt_bvs -> TailishHole True . Hole (x':alt_bvs)) alt_bvss bracketed_alts) + zipBracketeds $ TailsKnown ty' (\final_ty' -> Shell (tyVarsOfType final_ty') $ \(e_hole:es_alts) -> case_ e_hole x' final_ty' (alt_cons' `zip` es_alts)) (TailishHole False (Hole [] bracketed_hole) : zipWithEqual "Scrutinise" (\alt_bvs -> TailishHole True . Hole (x':alt_bvs)) alt_bvss bracketed_alts) where (alt_cons, alt_es) = unzip alts -- 0) Manufacture context identifier diff --git a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs index 6a5c195..4020466 100644 --- a/compiler/supercompile/Supercompile/Evaluator/Syntax.hs +++ b/compiler/supercompile/Supercompile/Evaluator/Syntax.hs @@ -342,9 +342,9 @@ bindManyMixedLiftedness get_fvs = go go xes = case takeFirst (\(x, _) -> isUnLiftedType (idType x)) xes of Nothing -> letRec xes Just ((x, e), rest_xes) -> go xes_above . let_ x e . go xes_below - where (xes_above, xes_below) = partition_one (get_fvs e) rest_xes + where (xes_above, xes_below) = partition_one (unitVarSet x) rest_xes partition_one bvs_below xes | bvs_below' == bvs_below = (xes_above, xes_below) | otherwise = second (xes_below ++) $ partition_one bvs_below' xes_above - where (xes_below, xes_above) = partition (\(x, _) -> x `elemVarSet` bvs_below) xes + where (xes_below, xes_above) = partition (\(_, e) -> get_fvs e `intersectsVarSet` bvs_below) xes bvs_below' = bvs_below `unionVarSet` mkVarSet (map fst xes_below)