Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-constraint-solver
http://hackage.haskell.org/trac/ghc/changeset/60b97e5e9ac448961f97078d69610be7c699ec9d >--------------------------------------------------------------- commit 60b97e5e9ac448961f97078d69610be7c699ec9d Author: Dimitrios Vytiniotis <[email protected]> Date: Mon Sep 26 20:26:36 2011 +0100 More progress in the TcSimplify wiring. >--------------------------------------------------------------- compiler/typecheck/TcSMonad.lhs | 15 ++++++++---- compiler/typecheck/TcSimplify.lhs | 43 +++++++++++++++++++++++++++--------- 2 files changed, 42 insertions(+), 16 deletions(-) diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 93ac294..e44665f 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -26,7 +26,7 @@ module TcSMonad ( getWantedLoc, TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality - traceFireTcS, bumpStepCountTcS, doWithInertsTcS, + traceFireTcS, bumpStepCountTcS, doWithInert, {- tryTcS, nestImplicTcS, recoverTcS, DV: Will figure out later -} wrapErrTcS, wrapWarnTcS, @@ -676,10 +676,15 @@ traceFireTcS depth doc <> brackets (int depth) <+> doc ; TcM.dumpTcRn msg } -doWithInertsTcS :: InertSet -> TcS a -> TcS a --- Just use this inert set to do stuff -doWithInertsTcS inert action - = updInertSetTcS_ (\_ -> inert) >> action +doWithInert :: InertSet -> TcS a -> TcS a +-- Just use this inert set to do stuff but pop back to the original inert in the end +doWithInert inert action + = do { is_orig <- getInertTcS + ; updInertSetTcS_ (\_ -> inert) + ; res <- action + ; updInertSetTcS_ (\_ -> is_orig) + ; return res } + runTcS :: SimplContext -> Untouchables -- Untouchables diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 3ba6bf7..882acac 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -743,12 +743,17 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols vcat [ text "n =" <+> ppr n , text "implics =" <+> ppr implics ] - ; (insolubles, unsolved_cans) <- extractUnsolvedTcS - -- unsolved_cans contains either Wanted or Derived! - -- NB: the TcS inerts are thinner now! + -- Get the inerts and extract the unsolved + -- NB: unsolved_cans contains either Wanted or Derived + ; inerts <- getInertTcS + ; let (thinner_inerts, insolubles, unsolved_cans) = extractUnsolved inerts + + -- Solve nested implications using the thinner given-only inerts + -- We pass on the unsolved (unsolved_cans) simply as an argument. ; (implic_eqs, unsolved_implics) - <- solveNestedImplications unsolved_cans implics + <- doWithInert thinner_inerts $ + solveNestedImplications unsolved_cans implics -- Apply defaulting rules if and only if there -- no floated equalities. If there are, they may @@ -762,15 +767,31 @@ solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols , text "unsolved_flats =" <+> ppr unsolved_cans , text "unsolved_implics =" <+> ppr unsolved_implics ] - ; already_there <- solveInteractThese improve_eqs -- DV: How to do this correctly? - ; if already_there then - return (WC { wc_insol = insolubles - , wc_flat = unsolved_cans - , wc_impl = unsolved_implics }) - else + -- Try to solve the improvement equalities + -- Use the thinner inerts (which contain no unsolved). If you find some unsolved + -- after interacting the floated equalities or the defaulting equalities then + -- just stop because you are making no progress. Otherwise go on! + + ; should_go_on <- do { solveInteractWanted improve_eqs + ; -- Now the inerts may contain more unsolved + ; (_, insols,unsols) <- getInertTcS >> extractUnsolved + -- A crude test: if we have produced more unsolved stop + -- but if the number of unsolved is down we keep iterating + ; return (lengthBag unsols < lengthBag unsolved_cans) } + + ; if should_go_on then simpl_loop (n+1) unsolved_implics + else -- Return the constraints prior to defaulting/floating + return $ WC { wc_insol = insolubles + , wc_flat = unsolved_cans + , wc_implics = unsolved_implics } } - {- + + + {- DV: This used to be the old code but I detest the fact that we use a flag from + the inner guts of the simplifier (improve_eqs_already_in_inert). So I want + to avoid this somehow in the code above. + ; (improve_eqs_already_in_inert, inert_with_improvement) <- solveInteract inert improve_eqs _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
