{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
module Warn.Coercion where
#if __GLASGOW_HASKELL__ >= 900
import GHC.Core.Stats
import GHC.Plugins hiding ((<>))
import GHC.Utils.Ppr.Colour
#else
import CoreStats
import GhcPlugins hiding ((<>))
import PprColour
#endif
pprWarnLargeCoerce :: [SrcSpan] -> CoreBndr -> CoreStats -> SDoc
pprWarnLargeCoerce :: [SrcSpan] -> CoreBndr -> CoreStats -> SDoc
pprWarnLargeCoerce refs :: [SrcSpan]
refs bind :: CoreBndr
bind stats :: CoreStats
stats =
let srcSpanList :: [SDoc]
srcSpanList = if [SrcSpan] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SrcSpan]
refs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 3
then Int -> [SDoc] -> [SDoc]
forall a. Int -> [a] -> [a]
take 3 ((SDoc
bullet SDoc -> SDoc -> SDoc
<+>) (SDoc -> SDoc) -> (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> [SrcSpan] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SrcSpan]
refs) [SDoc] -> [SDoc] -> [SDoc]
forall a. Semigroup a => a -> a -> a
<> [String -> SDoc
text "..."]
else (SDoc
bullet SDoc -> SDoc -> SDoc
<+>) (SDoc -> SDoc) -> (SrcSpan -> SDoc) -> SrcSpan -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpan -> SDoc) -> [SrcSpan] -> [SDoc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SrcSpan]
refs
CS{..} = CoreStats
stats
in [SDoc] -> SDoc
vcat [ String -> SDoc
text "Found a large number of coercions in GHC Core."
, Int -> SDoc -> SDoc
nest 2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text " GHC produced a a quadratic number of coercions relative to the number of terms."
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text "This can happen for expensive type families that are used outside of phantom contexts."
, SDoc
blankLine
, [SDoc] -> SDoc
hsep [ String -> SDoc
text "These coercions were introduced in"
, PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> (CoreBndr -> SDoc) -> CoreBndr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OccName -> SDoc) -> (CoreBndr -> OccName) -> CoreBndr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> OccName
forall a. NamedThing a => a -> OccName
getOccName (CoreBndr -> SDoc) -> CoreBndr -> SDoc
forall a b. (a -> b) -> a -> b
$ CoreBndr
bind
, String -> SDoc
text "at these locations:"
]
, Int -> SDoc -> SDoc
nest 4 ([SDoc] -> SDoc
vcat [SDoc]
srcSpanList)
, SDoc
blankLine
, [SDoc] -> SDoc
sep [ String -> SDoc
text "Terms:", PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
cs_tm
, String -> SDoc
text "Types:", PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
cs_ty
, String -> SDoc
text "Coercions:", PprColour -> SDoc -> SDoc
coloured PprColour
colBlueFg (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
cs_co
]
, String -> SDoc
text ""
]
shouldWarnLargeCoercion :: CoreStats -> Bool
shouldWarnLargeCoercion :: CoreStats -> Bool
shouldWarnLargeCoercion CS {Int
cs_tm :: Int
cs_tm :: CoreStats -> Int
cs_tm, Int
cs_co :: Int
cs_co :: CoreStats -> Int
cs_co} =
let quad :: Int
quad = Int
cs_tm Int -> Int -> Int
forall a. Num a => a -> a -> a
* Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase @Double 2 (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
cs_tm)
in Int
cs_co Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
quad Bool -> Bool -> Bool
&& Int
cs_co Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 100