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

Commits:

3 changed files:

Changes:

  • compiler/GHC/Hs/Expr.hs
    ... ... @@ -862,11 +862,9 @@ ppr_expr (HsOverLabel s l) = case ghcPass @p of
    862 862 
     ppr_expr (HsLit _ lit)       = ppr lit
    863 863 
     ppr_expr (HsOverLit _ lit)   = ppr lit
    864 864 
     ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)
    865 
    -
    866 
    -ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]
    867 
    -
    868 
    -ppr_expr e@(HsApp {})        = ppr_apps e []
    869 
    -ppr_expr e@(HsAppType {})    = ppr_apps e []
    865 
    +ppr_expr (HsPragE _ prag e)  = sep [ppr prag, ppr_lexpr e]
    866 
    +ppr_expr e@(HsApp {})        = pprApp e
    867 
    +ppr_expr e@(HsAppType {})    = pprApp e
    870 868
    871 869 
     ppr_expr (OpApp _ e1 op e2)
    872 870 
       | Just pp_op <- ppr_infix_expr (unLoc op)
    ... ... @@ -1134,21 +1132,21 @@ ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc
    1134 1132 
     ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e
    1135 1133 
     ppr_infix_hs_expansion _            = Nothing
    1136 1134
    1137 
    -ppr_apps :: (OutputableBndrId p)
    1138 
    -         => HsExpr (GhcPass p)
    1139 
    -         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]
    1140 
    -         -> SDoc
    1141 
    -ppr_apps (HsApp _ (L _ fun) arg)        args
    1142 
    -  = ppr_apps fun (Left arg : args)
    1143 
    -ppr_apps (HsAppType _ (L _ fun) arg)    args
    1144 
    -  = ppr_apps fun (Right arg : args)
    1145 
    -ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))
    1135 
    +pprApp :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc
    1136 
    +pprApp app
    1137 
    +  = go app []  -- Collect arguments and print all at once
    1146 1138 
       where
    1147 
    -    pp (Left arg)                             = ppr arg
    1148 
    -    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
    1149 
    -    --   = char '@' <> pprHsType arg
    1150 
    -    pp (Right arg)
    1151 
    -      = text "@" <> ppr arg
    1139 
    +    go fun args
    1140 
    +      = case fun of
    1141 
    +          HsApp _     (L _ fun') arg -> go fun' (Left arg  : args)
    1142 
    +          HsAppType _ (L _ fun') arg -> go fun' (Right arg : args)
    1143 
    +          _                          -> ppr_app fun args
    1144 
    +
    1145 
    +    ppr_app fun args = hang (ppr_expr fun)
    1146 
    +                          2 (pprDeeper (fsep (map pp args)))
    1147 
    +
    1148 
    +    pp (Left arg)  = ppr arg
    1149 
    +    pp (Right arg) = text "@" <> ppr arg
    1152 1150
    1153 1151 
     pprDebugParendExpr :: (OutputableBndrId p)
    1154 1152 
                        => PprPrec -> LHsExpr (GhcPass p) -> SDoc

  • compiler/GHC/Tc/Solver/Solve.hs
    ... ... @@ -42,7 +42,7 @@ import GHC.Types.Id( idType )
    42 42 
     import GHC.Types.Var( EvVar, tyVarKind )
    43 43 
     import GHC.Types.Var.Env
    44 44 
     import GHC.Types.Var.Set
    45 
    -import GHC.Types.Basic ( IntWithInf, intGtLimit )
    45 
    +import GHC.Types.Basic ( IntWithInf, mulWithInf, intGtLimit )
    46 46 
     import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet )
    47 47
    48 48 
     import GHC.Data.Bag
    ... ... @@ -1043,49 +1043,55 @@ solveSimpleGivens givens
    1043 1043
    1044 1044 
     solveSimpleWanteds :: Cts -> TcS Cts
    1045 1045 
     -- The result is not necessarily zonked
    1046 
    -solveSimpleWanteds simples
    1046 
    +solveSimpleWanteds wc
    1047 1047 
       = do { mode   <- getTcSMode
    1048 1048 
            ; dflags <- getDynFlags
    1049 1049 
            ; inerts <- getInertSet
    1050 
    +       ; let iteration_count_flag = solverIterations dflags
    1050 1051
    1051 1052 
            ; traceTcS "solveSimpleWanteds {" $
    1052 1053 
              vcat [ text "Mode:" <+> ppr mode
    1053 1054 
                   , text "Inerts:" <+> ppr inerts
    1054 
    -              , text "Wanteds to solve:" <+> ppr simples ]
    1055 
    +              , text "Wanteds to solve:" <+> ppr wc ]
    1055 1056
    1056 
    -       ; (n,wc) <- go 1 (solverIterations dflags) simples
    1057 
    +       ; wc1 <- iterateToFixpoint iteration_count_flag
    1058 
    +                  (do_solve_and_plugins iteration_count_flag) wc
    1057 1059
    1058 1060 
            ; traceTcS "solveSimpleWanteds end }" $
    1059 
    -             vcat [ text "iterations =" <+> ppr n
    1060 
    -                  , text "residual =" <+> ppr wc ]
    1061 
    -       ; return wc }
    1061 
    +             vcat [ text "residual =" <+> ppr wc1 ]
    1062 
    +       ; return wc1 }
    1062 1063 
       where
    1063 
    -    go :: Int -> IntWithInf -> Cts -> TcS (Int, Cts)
    1064 
    -    -- See Note [The solveSimpleWanteds loop]
    1065 
    -    go n limit wc
    1064 
    +    do_solve_and_plugins :: IntWithInf -> Cts -> TcS (Bool,Cts)
    1065 
    +    do_solve_and_plugins icf wc
    1066 
    +      = do { wc1 <- iterateToFixpoint (icf `mulWithInf` 10)
    1067 
    +                              do_solve wc
    1068 
    +           ; runTcPluginsWanted wc1 }
    1069 
    +
    1070 
    +    do_solve :: Cts -> TcS (Bool,Cts)
    1071 
    +    -- Try this repeatedly, until no unifications happen
    1072 
    +    -- This is potentially quadratic, because we might solve just one
    1073 
    +    -- constraint in each iteration but that seems inevitable
    1074 
    +    do_solve wc = reportUnifications (solve_simple_wanteds wc)
    1075 
    +
    1076 
    +
    1077 
    +iterateToFixpoint :: IntWithInf -> (Cts -> TcS (Bool,Cts)) -> Cts -> TcS Cts
    1078 
    +-- See Note [The solveSimpleWanteds loop]
    1079 
    +iterateToFixpoint limit do_it wc_orig
    1080 
    +  = go 1 wc_orig
    1081 
    +  where
    1082 
    +    go n wc
    1066 1083 
           | isEmptyBag wc
    1067 
    -      = return (n,wc)
    1084 
    +      = return wc
    1068 1085
    1069 1086 
           | n `intGtLimit` limit
    1070 1087 
           = failTcS $ TcRnSimplifierTooManyIterations
    1071 
    -                         simples limit (emptyWC { wc_simple = wc })
    1072 
    -      | otherwise
    1073 
    -      = do { -- Solve
    1074 
    -             traceUnificationFlag "solveSimpleWanteds1"
    1075 
    -           ; (unif_happened, wc1) <- reportUnifications $
    1076 
    -                                     solve_simple_wanteds wc
    1077 
    -           ; traceUnificationFlag "solveSimpleWanteds2"
    1078 
    -
    1079 
    -             -- Run plugins
    1080 
    -             -- NB: runTcPluginsWanted has a fast path for empty wc1,
    1081 
    -             --     which is the common case
    1082 
    -           ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
    1083 
    -
    1084 
    -           ; if unif_happened || rerun_plugin
    1085 
    -             then do { traceTcS "solveSimple going round again:" empty
    1086 
    -                     ; go (n+1) limit wc2 }   -- Loop
    1087 
    -             else return (n, wc2) }           -- Done
    1088 
    +                         wc_orig limit (emptyWC { wc_simple = wc })
    1088 1089
    1090 
    +      | otherwise
    1091 
    +      = do { (something_happened, wc1) <- do_it wc
    1092 
    +           ; if something_happened
    1093 
    +             then go (n+1) wc1
    1094 
    +             else return wc1 }
    1089 1095
    1090 1096 
     solve_simple_wanteds :: Cts -> TcS Cts
    1091 1097 
     -- Try solving these constraints

  • compiler/GHC/Types/Basic.hs
    ... ... @@ -109,7 +109,8 @@ module GHC.Types.Basic (
    109 109
    110 110 
             SuccessFlag(..), succeeded, failed, successIf,
    111 111
    112 
    -        IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit,
    112 
    +        IntWithInf, infinity, treatZeroAsInf, mkIntWithInf,
    113 
    +        intGtLimit, subWithInf, mulWithInf,
    113 114
    114 115 
             TypeOrKind(..), isTypeLevel, isKindLevel,
    115 116
    ... ... @@ -2114,8 +2115,8 @@ instance Outputable IntWithInf where
    2114 2115 
       ppr (Int n)  = int n
    2115 2116
    2116 2117 
     instance Num IntWithInf where
    2117 
    -  (+) = plusWithInf
    2118 
    -  (*) = mulWithInf
    2118 
    +  (+) = plusWithInf2
    2119 
    +  (*) = mulWithInf2
    2119 2120
    2120 2121 
       abs Infinity = Infinity
    2121 2122 
       abs (Int n)  = Int (abs n)
    ... ... @@ -2132,16 +2133,21 @@ intGtLimit _ Infinity = False
    2132 2133 
     intGtLimit n (Int m)  = n > m
    2133 2134
    2134 2135 
     -- | Add two 'IntWithInf's
    2135 
    -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf
    2136 
    -plusWithInf Infinity _        = Infinity
    2137 
    -plusWithInf _        Infinity = Infinity
    2138 
    -plusWithInf (Int a)  (Int b)  = Int (a + b)
    2136 
    +plusWithInf2 :: IntWithInf -> IntWithInf -> IntWithInf
    2137 
    +plusWithInf2 Infinity _        = Infinity
    2138 
    +plusWithInf2 _        Infinity = Infinity
    2139 
    +plusWithInf2 (Int a)  (Int b)  = Int (a + b)
    2139 2140
    2140 2141 
     -- | Multiply two 'IntWithInf's
    2141 
    -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf
    2142 
    -mulWithInf Infinity _        = Infinity
    2143 
    -mulWithInf _        Infinity = Infinity
    2144 
    -mulWithInf (Int a)  (Int b)  = Int (a * b)
    2142 
    +mulWithInf2 :: IntWithInf -> IntWithInf -> IntWithInf
    2143 
    +mulWithInf2 Infinity _        = Infinity
    2144 
    +mulWithInf2 _        Infinity = Infinity
    2145 
    +mulWithInf2 (Int a)  (Int b)  = Int (a * b)
    2146 
    +
    2147 
    +-- | Multiply an 'IntWithInfo` by an 'Int'
    2148 
    +mulWithInf :: IntWithInf -> Int -> IntWithInf
    2149 
    +mulWithInf Infinity _ = Infinity
    2150 
    +mulWithInf (Int a)  b = Int (a * b)
    2145 2151
    2146 2152 
     -- | Subtract an 'Int' from an 'IntWithInf'
    2147 2153 
     subWithInf :: IntWithInf -> Int -> IntWithInf
    ... ... @@ -2461,4 +2467,4 @@ convImportLevel NotLevelled = NormalLevel
    2461 2467
    2462 2468 
     convImportLevelSpec :: ImportDeclLevel -> ImportLevel
    2463 2469 
     convImportLevelSpec ImportDeclQuote = QuoteLevel
    2464 
    -convImportLevelSpec ImportDeclSplice = SpliceLevel
    \ No newline at end of file
    2470 
    +convImportLevelSpec ImportDeclSplice = SpliceLevel

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