Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/Hs/Expr.hs
    ... ... @@ -1144,6 +1144,7 @@ pprApp app
    1144 1144
    1145 1145 
         ppr_app fun args = hang (ppr_expr fun)
    1146 1146 
                               2 (pprDeeper (fsep (map pp args)))
    1147 
    +           -- pprDeeper: go deeper as we step inside an argument
    1147 1148
    1148 1149 
         pp (Left arg)  = ppr arg
    1149 1150 
         pp (Right arg) = text "@" <> ppr arg

  • compiler/GHC/Tc/Solver/Equality.hs
    ... ... @@ -35,7 +35,7 @@ import GHC.Core.TyCon
    35 35 
     import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking
    36 36 
     import GHC.Core.Coercion
    37 37 
     import GHC.Core.Reduction
    38 
    -import GHC.Core.FamInstEnv ( FamInstEnvs )
    38 
    +import GHC.Core.FamInstEnv ( FamInstEnvs )
    39 39 
     import GHC.Core
    40 40 
     import GHC.Types.Var
    41 41 
     import GHC.Types.Var.Env

  • compiler/GHC/Tc/Solver/FunDeps.hs
    ... ... @@ -3,7 +3,6 @@
    3 3
    4 4 
     -- | Solving Class constraints CDictCan
    5 5 
     module GHC.Tc.Solver.FunDeps (
    6 
    -  unifyAndEmitFunDepWanteds,
    7 6 
       tryDictFunDeps,
    8 7 
       tryEqFunDeps
    9 8 
       ) where
    ... ... @@ -35,20 +34,16 @@ import GHC.Core.Coercion.Axiom
    35 34
    36 35 
     import GHC.Builtin.Types.Literals( tryInteractTopFam, tryInteractInertFam )
    37 36 
     import GHC.Types.Name
    38 
    -import GHC.Types.Var.Set
    39 37 
     import GHC.Types.Var.Env
    40 38
    41 39 
     import GHC.Utils.Outputable
    42 40 
     import GHC.Utils.Panic
    43 41 
     import GHC.Utils.Misc( filterOut )
    44 42
    45 
    -import GHC.Data.Bag
    46 43 
     import GHC.Data.Pair
    47 44
    48 45 
     import qualified Data.Semigroup as S
    49 46
    50 
    -import Control.Monad
    51 
    -
    52 47 
     {- *********************************************************************
    53 48 
     *                                                                      *
    54 49 
     *          Functional dependencies for dictionaries
    ... ... @@ -334,10 +329,14 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
    334 329 
         do { inerts <- getInertCans
    335 330
    336 331 
            ; traceTcS "tryDictFunDepsLocal {" (ppr dict_ct)
    337 
    -       ; imp <- solveFunDeps $
    338 
    -                foldM do_interaction emptyCts $
    339 
    -                findDictsByClass (inert_dicts inerts) cls
    340 
    -       ; traceTcS "tryDictFunDepsLocal }" (text "imp =" <+> ppr imp)
    332 
    +
    333 
    +       ; let eqns :: [FunDepEqn (CtLoc, RewriterSet)]
    334 
    +             eqns = foldr ((++) . do_interaction) [] $
    335 
    +                    findDictsByClass (inert_dicts inerts) cls
    336 
    +       ; imp <- solveFunDeps work_ev eqns
    337 
    +
    338 
    +       ; traceTcS "tryDictFunDepsLocal }" $
    339 
    +         text "imp =" <+> ppr imp $$ text "eqns = " <+> ppr eqns
    341 340
    342 341 
            ; if imp then startAgainWith (CDictCan dict_ct)
    343 342 
                     else continueWith () }
    ... ... @@ -346,24 +345,17 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev })
    346 345 
         work_loc      = ctEvLoc  work_ev
    347 346 
         work_is_given = isGiven work_ev
    348 347
    349 
    -    do_interaction :: Cts -> DictCt -> TcS Cts
    350 
    -    do_interaction new_eqs1 (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted
    348 
    +    do_interaction :: DictCt -> [FunDepEqn (CtLoc, RewriterSet)]
    349 
    +    do_interaction (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted
    351 350 
           | work_is_given && isGiven inert_ev
    352 351 
             -- Do not create FDs from Given/Given interactions
    353 352 
             -- See Note [No Given/Given fundeps]
    354 353 
             -- It is possible for work_ev to be Given when inert_ev is Wanted:
    355 354 
             -- this can happen if a Given is kicked out by a unification
    356 
    -      = return new_eqs1
    355 
    +      = []
    357 356
    358 357 
           | otherwise
    359 
    -      = do { new_eqs2 <- unifyFunDepWanteds_new work_ev $
    360 
    -                         improveFromAnother (deriv_loc, inert_rewriters)
    361 
    -                                            inert_pred work_pred
    362 
    -
    363 
    -           ; traceTcS "tryDictFunDepsLocal item" $
    364 
    -             vcat [ ppr work_ev, ppr new_eqs2 ]
    365 
    -
    366 
    -           ; return (new_eqs1 `unionBags` new_eqs2) }
    358 
    +      = improveFromAnother (deriv_loc, inert_rewriters) inert_pred work_pred
    367 359 
           where
    368 360 
             inert_pred  = ctEvPred inert_ev
    369 361 
             inert_loc   = ctEvLoc inert_ev
    ... ... @@ -387,8 +379,7 @@ tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
    387 379 
            ; traceTcS "tryDictFunDepsTop {" (ppr dict_ct)
    388 380 
            ; let eqns :: [FunDepEqn (CtLoc, RewriterSet)]
    389 381 
                  eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis
    390 
    -       ; imp <- solveFunDeps $
    391 
    -                unifyFunDepWanteds_new ev eqns
    382 
    +       ; imp <- solveFunDeps ev eqns
    392 383 
            ; traceTcS "tryDictFunDepsTop }" (text "imp =" <+> ppr imp)
    393 384
    394 385 
            ; if imp then startAgainWith (CDictCan dict_ct)
    ... ... @@ -409,13 +400,6 @@ tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis })
    409 400 
             new_orig  = FunDepOrigin2 dict_pred dict_origin
    410 401 
                                       inst_pred inst_loc
    411 402
    412 
    -solveFunDeps :: TcS Cts -> TcS Bool
    413 
    -solveFunDeps generate_eqs
    414 
    -  = do { (unif_happened, _res) <- nestFunDepsTcS $
    415 
    -                                  do { eqs <- generate_eqs
    416 
    -                                     ; solveSimpleWanteds eqs }
    417 
    -       ; return unif_happened }
    418 
    -
    419 403 
     {- Note [No Given/Given fundeps]
    420 404 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    421 405 
     We do not create constraints from:
    ... ... @@ -799,7 +783,7 @@ improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs
    799 783 
       = do { traceTcS "interactFunEq improvements: " $
    800 784 
                        vcat [ text "Eqns:" <+> ppr improvement_eqns
    801 785 
                             , text "Candidates:" <+> ppr funeqs_for_tc ]
    802 
    -       ; unifyAndEmitFunDepWanteds work_ev improvement_eqns }
    786 
    +       ; solveFunDeps work_ev improvement_eqns }
    803 787 
       where
    804 788 
         work_loc      = ctEvLoc work_ev
    805 789 
         work_pred     = ctEvPred work_ev
    ... ... @@ -945,54 +929,21 @@ solving.
    945 929 
     ************************************************************************
    946 930 
     -}
    947 931
    948 
    -unifyAndEmitFunDepWanteds :: CtEvidence  -- The work item
    949 
    -                          -> [FunDepEqn (CtLoc, RewriterSet)]
    950 
    -                          -> TcS Bool   -- True <=> some unification happened
    951 
    -unifyAndEmitFunDepWanteds ev fd_eqns
    932 
    +solveFunDeps :: CtEvidence  -- The work item
    933 
    +             -> [FunDepEqn (CtLoc, RewriterSet)]
    934 
    +             -> TcS Bool
    935 
    +-- See Note [FunDep and implicit parameter reactions]
    936 
    +solveFunDeps work_ev fd_eqns
    952 937 
       | null fd_eqns
    953 
    -  = return False
    938 
    +  = return False -- common case noop
    939 
    +
    954 940 
       | otherwise
    955 
    -  = do { (fresh_tvs_s, new_eqs, unified_tvs) <- wrapUnifierX ev Nominal do_fundeps
    956 
    -
    957 
    -       -- Figure out if a "real" unification happened: See Note [unifyFunDeps]
    958 
    -       ; let unif_happened = any is_old_tv unified_tvs
    959 
    -             fresh_tvs     = mkVarSet (concat fresh_tvs_s)
    960 
    -             is_old_tv tv  = not (tv `elemVarSet` fresh_tvs)
    961 
    -
    962 
    -       ;   -- Emit the deferred constraints
    963 
    -           -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality
    964 
    -           --
    965 
    -           -- All the constraints in `cts` share the same rewriter set so,
    966 
    -           -- rather than looking at it one by one, we pass it to
    967 
    -           -- extendWorkListChildEqs; just a small optimisation.
    968 
    -       ; unless (isEmptyBag new_eqs) $
    969 
    -         updWorkListTcS (extendWorkListChildEqs ev new_eqs)
    941 
    +  = do { (unif_happened, _res)
    942 
    +             <- nestFunDepsTcS $
    943 
    +                do { (_, eqs) <- unifyForAllBody work_ev Nominal do_fundeps
    944 
    +                   ; solveSimpleWanteds eqs }
    970 945
    971 946 
            ; return unif_happened }
    972 
    -  where
    973 
    -    do_fundeps :: UnifyEnv -> TcM [[TcTyVar]]
    974 
    -    do_fundeps env = mapM (do_one env) fd_eqns
    975 
    -
    976 
    -    do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM [TcTyVar]
    977 
    -    do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })
    978 
    -      = do { (fresh_tvs, eqs') <- instantiateFunDepEqn tvs (reverse eqs)
    979 
    -                     -- (reverse eqs): See Note [Reverse order of fundep equations]
    980 
    -           ; uPairsTcM env_one eqs'
    981 
    -           ; return fresh_tvs }
    982 
    -      where
    983 
    -        env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters
    984 
    -                       , u_loc       = loc }
    985 
    -
    986 
    -unifyFunDepWanteds_new :: CtEvidence  -- The work item
    987 
    -                       -> [FunDepEqn (CtLoc, RewriterSet)]
    988 
    -                       -> TcS Cts
    989 
    --- See Note [FunDep and implicit parameter reactions]
    990 
    -unifyFunDepWanteds_new _ []
    991 
    -  = return emptyCts -- common case noop
    992 
    -
    993 
    -unifyFunDepWanteds_new ev fd_eqns
    994 
    -  = do { (_, cts) <- unifyForAllBody ev Nominal do_fundeps
    995 
    -       ; return cts }
    996 947 
       where
    997 948 
         do_fundeps :: UnifyEnv -> TcM ()
    998 949 
         do_fundeps env = mapM_ (do_one env) fd_eqns

  • compiler/GHC/Utils/Outputable.hs
    ... ... @@ -522,23 +522,21 @@ pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of
    522 522 
       _ -> runSDoc d ctx
    523 523
    524 524
    525 
    --- | Truncate a list that is longer than the current depth.
    525 
    +-- | Truncate a list that is longer than the default depth
    526 526 
     pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    527 527 
     pprDeeperList f ds
    528 528 
       | null ds   = f []
    529 529 
       | otherwise = SDoc work
    530 530 
      where
    531 
    -  work ctx@SDC{sdocStyle=PprUser q depth c}
    532 
    -   | DefaultDepth <- depth
    533 
    -   = work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c })
    534 
    -   | PartWay 0 <- depth
    535 
    -   = Pretty.text "..."
    536 
    -   | PartWay n <- depth
    531 
    +  work ctx
    537 532 
        = let
    538 533 
             go _ [] = []
    539 
    -        go i (d:ds) | i >= n    = [text "...."]
    540 
    -                    | otherwise = d : go (i+1) ds
    541 
    -     in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
    534 
    +        go i (d:ds) | i >= default_depth = [text "...."]
    535 
    +                    | otherwise     = d : go (i+1) ds
    536 
    +     in runSDoc (f (go 0 ds)) ctx
    537 
    +   where
    538 
    +     default_depth = sdocDefaultDepth ctx
    539 
    +
    542 540 
       work other_ctx = runSDoc (f ds) other_ctx
    543 541
    544 542 
     pprSetDepth :: Depth -> SDoc -> SDoc

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help