{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Types.Demand (
Boxity(..),
Card(C_00, C_01, C_0N, C_10, C_11, C_1N), CardNonAbs, CardNonOnce,
Demand(AbsDmd, BotDmd, (:*)),
SubDemand(Prod, Poly), mkProd, viewProd,
absDmd, topDmd, botDmd, seqDmd, topSubDmd,
lubCard, lubDmd, lubSubDmd,
plusCard, plusDmd, plusSubDmd,
multCard, multDmd, multSubDmd,
isAbs, isUsedOnce, isStrict,
isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,
isTopDmd, isWeakDmd, onlyBoxedArguments,
evalDmd,
lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,
oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd,
peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,
mkWorkerDemand,
argOneShots, argsOneShots, saturatedByOneShots,
unboxDeeplyDmd,
Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,
DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,
reuseEnv,
DmdType(..), dmdTypeDepth,
nopDmdType, botDmdType,
lubDmdType, plusDmdType, multDmdType, discardArgDmds,
peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
DmdSig(..), mkDmdSigForArity, mkClosedDmdSig,
splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig,
nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig,
prependArgsDmdSig, etaConvertDmdSig,
DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,
TypeShape(..), trimToType, trimBoxity,
seqDemand, seqDemandList, seqDmdType, seqDmdSig,
zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig
) where
import GHC.Prelude
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Data.Maybe ( orElse )
import GHC.Core.Type ( Type )
import GHC.Core.TyCon ( isNewTyCon, isClassTyCon )
import GHC.Core.DataCon ( splitDataProductType_maybe, StrictnessMark, isMarkedStrict )
import GHC.Core.Multiplicity ( scaledThing )
import GHC.Utils.Binary
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Data.Coerce (coerce)
import Data.Function
import GHC.Utils.Trace
String -> SDoc -> Any -> Any
_ = String -> SDoc -> Any -> Any
forall a. String -> SDoc -> a -> a
pprTrace
boxedWins :: Boxity -> Boxity -> Boxity
boxedWins :: Boxity -> Boxity -> Boxity
boxedWins Boxity
Unboxed Boxity
Unboxed = Boxity
Unboxed
boxedWins Boxity
_ !Boxity
_ = Boxity
Boxed
_unboxedWins :: Boxity -> Boxity -> Boxity
_unboxedWins :: Boxity -> Boxity -> Boxity
_unboxedWins Boxity
Boxed Boxity
Boxed = Boxity
Boxed
_unboxedWins Boxity
_ !Boxity
_ = Boxity
Unboxed
lubBoxity :: Boxity -> Boxity -> Boxity
lubBoxity :: Boxity -> Boxity -> Boxity
lubBoxity = Boxity -> Boxity -> Boxity
boxedWins
plusBoxity :: Boxity -> Boxity -> Boxity
plusBoxity :: Boxity -> Boxity -> Boxity
plusBoxity = Boxity -> Boxity -> Boxity
boxedWins
newtype Card = Card Int
deriving Card -> Card -> Bool
(Card -> Card -> Bool) -> (Card -> Card -> Bool) -> Eq Card
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Card -> Card -> Bool
== :: Card -> Card -> Bool
$c/= :: Card -> Card -> Bool
/= :: Card -> Card -> Bool
Eq
type CardNonAbs = Card
type CardNonOnce = Card
pattern C_00 :: Card
pattern $mC_00 :: forall {r}. Card -> ((# #) -> r) -> ((# #) -> r) -> r
$bC_00 :: Card
C_00 = Card 0b001
pattern C_10 :: Card
pattern $mC_10 :: forall {r}. Card -> ((# #) -> r) -> ((# #) -> r) -> r
$bC_10 :: Card
C_10 = Card 0b000
pattern C_11 :: Card
pattern $mC_11 :: forall {r}. Card -> ((# #) -> r) -> ((# #) -> r) -> r
$bC_11 :: Card
C_11 = Card 0b010
pattern C_01 :: Card
pattern $mC_01 :: forall {r}. Card -> ((# #) -> r) -> ((# #) -> r) -> r
$bC_01 :: Card
C_01 = Card 0b011
pattern C_1N :: Card
pattern $mC_1N :: forall {r}. Card -> ((# #) -> r) -> ((# #) -> r) -> r
$bC_1N :: Card
C_1N = Card 0b110
pattern C_0N :: Card
pattern $mC_0N :: forall {r}. Card -> ((# #) -> r) -> ((# #) -> r) -> r
$bC_0N :: Card
C_0N = Card 0b111
{-# COMPLETE C_00, C_01, C_0N, C_10, C_11, C_1N :: Card #-}
_botCard, topCard :: Card
_botCard :: Card
_botCard = Card
C_10
topCard :: Card
topCard = Card
C_0N
isStrict :: Card -> Bool
isStrict :: Card -> Bool
isStrict (Card Int
c) = Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b001 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
isAbs :: Card -> Bool
isAbs :: Card -> Bool
isAbs (Card Int
c) = Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b110 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
isUsedOnce :: Card -> Bool
isUsedOnce :: Card -> Bool
isUsedOnce (Card Int
c) = Int
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b100 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
isCardNonAbs :: Card -> Bool
isCardNonAbs :: Card -> Bool
isCardNonAbs = Bool -> Bool
not (Bool -> Bool) -> (Card -> Bool) -> Card -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Card -> Bool
isAbs
isCardNonOnce :: Card -> Bool
isCardNonOnce :: Card -> Bool
isCardNonOnce Card
n = Card -> Bool
isAbs Card
n Bool -> Bool -> Bool
|| Bool -> Bool
not (Card -> Bool
isUsedOnce Card
n)
oneifyCard :: Card -> Card
oneifyCard :: Card -> Card
oneifyCard Card
C_0N = Card
C_01
oneifyCard Card
C_1N = Card
C_11
oneifyCard Card
c = Card
c
lubCard :: Card -> Card -> Card
lubCard :: Card -> Card -> Card
lubCard (Card Int
a) (Card Int
b) = Int -> Card
Card (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b)
plusCard :: Card -> Card -> Card
plusCard :: Card -> Card -> Card
plusCard (Card Int
a) (Card Int
b)
= Int -> Card
Card (Int
bit0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
bit1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
bitN)
where
bit0 :: Int
bit0 = (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
b) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b001
bit1 :: Int
bit1 = (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b010
bitN :: Int
bitN = ((Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
b) Int
1) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b100
multCard :: Card -> Card -> Card
multCard :: Card -> Card -> Card
multCard (Card Int
a) (Card Int
b)
= Int -> Card
Card (Int
bit0 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
bit1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
bitN)
where
bit0 :: Int
bit0 = (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b001
bit1 :: Int
bit1 = (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
b) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b010
bitN :: Int
bitN = (Int
a Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int -> Int -> Int
forall a. Bits a => a -> Int -> a
shiftL Int
bit1 Int
1 Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0b100
data Demand
= BotDmd
| AbsDmd
| D !CardNonAbs !SubDemand
deriving Demand -> Demand -> Bool
(Demand -> Demand -> Bool)
-> (Demand -> Demand -> Bool) -> Eq Demand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Demand -> Demand -> Bool
== :: Demand -> Demand -> Bool
$c/= :: Demand -> Demand -> Bool
/= :: Demand -> Demand -> Bool
Eq
viewDmdPair :: Demand -> (Card, SubDemand)
viewDmdPair :: Demand -> (Card, SubDemand)
viewDmdPair Demand
BotDmd = (Card
C_10, SubDemand
botSubDmd)
viewDmdPair Demand
AbsDmd = (Card
C_00, SubDemand
seqSubDmd)
viewDmdPair (D Card
n SubDemand
sd) = (Card
n, SubDemand
sd)
pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand
pattern n $m:* :: forall {r}.
HasDebugCallStack =>
Demand -> (Card -> SubDemand -> r) -> ((# #) -> r) -> r
$b:* :: HasDebugCallStack => Card -> SubDemand -> Demand
:* sd <- (viewDmdPair -> (n, sd)) where
Card
C_10 :* SubDemand
sd = Demand
BotDmd Demand -> (Demand -> Demand) -> Demand
forall a b. a -> (a -> b) -> b
& Bool -> SDoc -> Demand -> Demand
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (SubDemand
sd SubDemand -> SubDemand -> Bool
forall a. Eq a => a -> a -> Bool
== SubDemand
botSubDmd) (String -> SDoc
text String
"B /=" SDoc -> SDoc -> SDoc
<+> SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
sd)
Card
C_00 :* SubDemand
sd = Demand
AbsDmd Demand -> (Demand -> Demand) -> Demand
forall a b. a -> (a -> b) -> b
& Bool -> SDoc -> Demand -> Demand
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (SubDemand
sd SubDemand -> SubDemand -> Bool
forall a. Eq a => a -> a -> Bool
== SubDemand
seqSubDmd) (String -> SDoc
text String
"A /=" SDoc -> SDoc -> SDoc
<+> SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
sd)
Card
n :* SubDemand
sd = Card -> SubDemand -> Demand
D Card
n SubDemand
sd Demand -> (Demand -> Demand) -> Demand
forall a b. a -> (a -> b) -> b
& Bool -> SDoc -> Demand -> Demand
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Card -> Bool
isCardNonAbs Card
n) (Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
n SDoc -> SDoc -> SDoc
$$ SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
sd)
{-# COMPLETE (:*) #-}
data SubDemand
= Poly !Boxity !CardNonOnce
| Call !CardNonAbs !SubDemand
| Prod !Boxity ![Demand]
instance Eq SubDemand where
SubDemand
d1 == :: SubDemand -> SubDemand -> Bool
== SubDemand
d2 = case SubDemand
d1 of
Prod Boxity
b1 [Demand]
ds1
| Just (Boxity
b2, [Demand]
ds2) <- Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd ([Demand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
ds1) SubDemand
d2 -> Boxity
b1 Boxity -> Boxity -> Bool
forall a. Eq a => a -> a -> Bool
== Boxity
b2 Bool -> Bool -> Bool
&& [Demand]
ds1 [Demand] -> [Demand] -> Bool
forall a. Eq a => a -> a -> Bool
== [Demand]
ds2
Call Card
n1 SubDemand
sd1
| Just (Card
n2, SubDemand
sd2) <- SubDemand -> Maybe (Card, SubDemand)
viewCall SubDemand
d2 -> Card
n1 Card -> Card -> Bool
forall a. Eq a => a -> a -> Bool
== Card
n2 Bool -> Bool -> Bool
&& SubDemand
sd1 SubDemand -> SubDemand -> Bool
forall a. Eq a => a -> a -> Bool
== SubDemand
sd2
Poly Boxity
b1 Card
n1
| Poly Boxity
b2 Card
n2 <- SubDemand
d2 -> Boxity
b1 Boxity -> Boxity -> Bool
forall a. Eq a => a -> a -> Bool
== Boxity
b2 Bool -> Bool -> Bool
&& Card
n1 Card -> Card -> Bool
forall a. Eq a => a -> a -> Bool
== Card
n2
SubDemand
_ -> Bool
False
topSubDmd, botSubDmd, seqSubDmd :: SubDemand
topSubDmd :: SubDemand
topSubDmd = Boxity -> Card -> SubDemand
Poly Boxity
Boxed Card
C_0N
botSubDmd :: SubDemand
botSubDmd = Boxity -> Card -> SubDemand
Poly Boxity
Unboxed Card
C_10
seqSubDmd :: SubDemand
seqSubDmd = Boxity -> Card -> SubDemand
Poly Boxity
Unboxed Card
C_00
polyFieldDmd :: Boxity -> CardNonOnce -> Demand
polyFieldDmd :: Boxity -> Card -> Demand
polyFieldDmd Boxity
_ Card
C_00 = Demand
AbsDmd
polyFieldDmd Boxity
_ Card
C_10 = Demand
BotDmd
polyFieldDmd Boxity
Boxed Card
C_0N = Demand
topDmd
polyFieldDmd Boxity
b Card
n = Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Boxity -> Card -> SubDemand
Poly Boxity
b Card
n Demand -> (Demand -> Demand) -> Demand
forall a b. a -> (a -> b) -> b
& Bool -> SDoc -> Demand -> Demand
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Card -> Bool
isCardNonOnce Card
n) (Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
n)
mkProd :: Boxity -> [Demand] -> SubDemand
mkProd :: Boxity -> [Demand] -> SubDemand
mkProd Boxity
b [Demand]
ds
| (Demand -> Bool) -> [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Demand
AbsDmd) [Demand]
ds = Boxity -> Card -> SubDemand
Poly Boxity
b Card
C_00
| (Demand -> Bool) -> [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Demand
BotDmd) [Demand]
ds = Boxity -> Card -> SubDemand
Poly Boxity
b Card
C_10
| dmd :: Demand
dmd@(Card
n :* Poly Boxity
b2 Card
m):[Demand]
_ <- [Demand]
ds
, Card
n Card -> Card -> Bool
forall a. Eq a => a -> a -> Bool
== Card
m
, Boxity
b Boxity -> Boxity -> Bool
forall a. Eq a => a -> a -> Bool
== Boxity
b2
, (Demand -> Bool) -> [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Demand
dmd) [Demand]
ds
= Boxity -> Card -> SubDemand
Poly Boxity
b Card
n
| Bool
otherwise = Boxity -> [Demand] -> SubDemand
Prod Boxity
b [Demand]
ds
viewProd :: Arity -> SubDemand -> Maybe (Boxity, [Demand])
viewProd :: Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd Int
n (Prod Boxity
b [Demand]
ds)
| [Demand]
ds [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
n = (Boxity, [Demand]) -> Maybe (Boxity, [Demand])
forall a. a -> Maybe a
Just (Boxity
b, [Demand]
ds)
viewProd Int
n (Poly Boxity
b Card
card)
| let !ds :: [Demand]
ds = Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
n (Demand -> [Demand]) -> Demand -> [Demand]
forall a b. (a -> b) -> a -> b
$! Boxity -> Card -> Demand
polyFieldDmd Boxity
b Card
card
= (Boxity, [Demand]) -> Maybe (Boxity, [Demand])
forall a. a -> Maybe a
Just (Boxity
b, [Demand]
ds)
viewProd Int
_ SubDemand
_
= Maybe (Boxity, [Demand])
forall a. Maybe a
Nothing
{-# INLINE viewProd #-}
mkCall :: CardNonAbs -> SubDemand -> SubDemand
mkCall :: Card -> SubDemand -> SubDemand
mkCall Card
C_1N sd :: SubDemand
sd@(Poly Boxity
Boxed Card
C_1N) = SubDemand
sd
mkCall Card
C_0N sd :: SubDemand
sd@(Poly Boxity
Boxed Card
C_0N) = SubDemand
sd
mkCall Card
n SubDemand
cd = Bool -> SDoc -> SubDemand -> SubDemand
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Card -> Bool
isCardNonAbs Card
n) (Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
n SDoc -> SDoc -> SDoc
$$ SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
cd) (SubDemand -> SubDemand) -> SubDemand -> SubDemand
forall a b. (a -> b) -> a -> b
$
Card -> SubDemand -> SubDemand
Call Card
n SubDemand
cd
viewCall :: SubDemand -> Maybe (Card, SubDemand)
viewCall :: SubDemand -> Maybe (Card, SubDemand)
viewCall (Call Card
n SubDemand
sd) = (Card, SubDemand) -> Maybe (Card, SubDemand)
forall a. a -> Maybe a
Just (Card
n :: Card, SubDemand
sd)
viewCall (Poly Boxity
_ Card
n) = (Card, SubDemand) -> Maybe (Card, SubDemand)
forall a. a -> Maybe a
Just (Card
n :: Card, Boxity -> Card -> SubDemand
Poly Boxity
Boxed Card
n)
viewCall SubDemand
_ = Maybe (Card, SubDemand)
forall a. Maybe a
Nothing
topDmd, absDmd, botDmd, seqDmd :: Demand
topDmd :: Demand
topDmd = Card
C_0N HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
topSubDmd
absDmd :: Demand
absDmd = Demand
AbsDmd
botDmd :: Demand
botDmd = Demand
BotDmd
seqDmd :: Demand
seqDmd = Card
C_11 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
seqSubDmd
unboxDeeplySubDmd :: SubDemand -> SubDemand
unboxDeeplySubDmd :: SubDemand -> SubDemand
unboxDeeplySubDmd (Poly Boxity
_ Card
n) = Boxity -> Card -> SubDemand
Poly Boxity
Unboxed Card
n
unboxDeeplySubDmd (Prod Boxity
_ [Demand]
ds) = Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
strictMap Demand -> Demand
unboxDeeplyDmd [Demand]
ds)
unboxDeeplySubDmd call :: SubDemand
call@Call{} = SubDemand
call
unboxDeeplyDmd :: Demand -> Demand
unboxDeeplyDmd :: Demand -> Demand
unboxDeeplyDmd Demand
AbsDmd = Demand
AbsDmd
unboxDeeplyDmd Demand
BotDmd = Demand
BotDmd
unboxDeeplyDmd (D Card
n SubDemand
sd) = Card -> SubDemand -> Demand
D Card
n (SubDemand -> SubDemand
unboxDeeplySubDmd SubDemand
sd)
lubSubDmd :: SubDemand -> SubDemand -> SubDemand
lubSubDmd :: SubDemand -> SubDemand -> SubDemand
lubSubDmd (Poly Boxity
Unboxed Card
C_10) SubDemand
d2 = SubDemand
d2
lubSubDmd SubDemand
d1 (Poly Boxity
Unboxed Card
C_10) = SubDemand
d1
lubSubDmd (Prod Boxity
b1 [Demand]
ds1) (Poly Boxity
b2 Card
n2)
| let !d :: Demand
d = Boxity -> Card -> Demand
polyFieldDmd Boxity
b2 Card
n2
= Boxity -> [Demand] -> SubDemand
mkProd (Boxity -> Boxity -> Boxity
lubBoxity Boxity
b1 Boxity
b2) ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
strictMap (Demand -> Demand -> Demand
lubDmd Demand
d) [Demand]
ds1)
lubSubDmd (Prod Boxity
b1 [Demand]
ds1) (Prod Boxity
b2 [Demand]
ds2)
| [Demand] -> [Demand] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Demand]
ds1 [Demand]
ds2
= Boxity -> [Demand] -> SubDemand
mkProd (Boxity -> Boxity -> Boxity
lubBoxity Boxity
b1 Boxity
b2) ((Demand -> Demand -> Demand) -> [Demand] -> [Demand] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith Demand -> Demand -> Demand
lubDmd [Demand]
ds1 [Demand]
ds2)
lubSubDmd (Call Card
n1 SubDemand
sd1) sd2 :: SubDemand
sd2@(Poly Boxity
_ Card
n2)
| Card -> Bool
isAbs Card
n2 = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
lubCard Card
n2 Card
n1) SubDemand
sd1
| Bool
otherwise = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
lubCard Card
n2 Card
n1) (SubDemand -> SubDemand -> SubDemand
lubSubDmd SubDemand
sd1 SubDemand
sd2)
lubSubDmd (Call Card
n1 SubDemand
d1) (Call Card
n2 SubDemand
d2)
| Bool
otherwise = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
lubCard Card
n1 Card
n2) (SubDemand -> SubDemand -> SubDemand
lubSubDmd SubDemand
d1 SubDemand
d2)
lubSubDmd (Poly Boxity
b1 Card
n1) (Poly Boxity
b2 Card
n2) = Boxity -> Card -> SubDemand
Poly (Boxity -> Boxity -> Boxity
lubBoxity Boxity
b1 Boxity
b2) (Card -> Card -> Card
lubCard Card
n1 Card
n2)
lubSubDmd sd1 :: SubDemand
sd1@Poly{} SubDemand
sd2 = SubDemand -> SubDemand -> SubDemand
lubSubDmd SubDemand
sd2 SubDemand
sd1
lubSubDmd SubDemand
_ SubDemand
_ = SubDemand
topSubDmd
lubDmd :: Demand -> Demand -> Demand
lubDmd :: Demand -> Demand -> Demand
lubDmd (Card
n1 :* SubDemand
sd1) (Card
n2 :* SubDemand
sd2) = Card -> Card -> Card
lubCard Card
n1 Card
n2 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand -> SubDemand -> SubDemand
lubSubDmd SubDemand
sd1 SubDemand
sd2
multSubDmd :: Card -> SubDemand -> SubDemand
multSubDmd :: Card -> SubDemand -> SubDemand
multSubDmd Card
C_11 SubDemand
sd = SubDemand
sd
multSubDmd Card
C_00 SubDemand
_ = SubDemand
seqSubDmd
multSubDmd Card
C_10 (Poly Boxity
_ Card
n) = if Card -> Bool
isStrict Card
n then SubDemand
botSubDmd else SubDemand
seqSubDmd
multSubDmd Card
C_10 (Call Card
n SubDemand
_) = if Card -> Bool
isStrict Card
n then SubDemand
botSubDmd else SubDemand
seqSubDmd
multSubDmd Card
n (Poly Boxity
b Card
m) = Boxity -> Card -> SubDemand
Poly Boxity
b (Card -> Card -> Card
multCard Card
n Card
m)
multSubDmd Card
n (Call Card
n' SubDemand
sd) = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
multCard Card
n Card
n') SubDemand
sd
multSubDmd Card
n (Prod Boxity
b [Demand]
ds) = Boxity -> [Demand] -> SubDemand
mkProd Boxity
b ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
strictMap (Card -> Demand -> Demand
multDmd Card
n) [Demand]
ds)
multDmd :: Card -> Demand -> Demand
multDmd :: Card -> Demand -> Demand
multDmd Card
C_10 (Card
n :* SubDemand
_) = if Card -> Bool
isStrict Card
n then Demand
BotDmd else Demand
AbsDmd
multDmd Card
n (Card
C_10 :* SubDemand
_) = if Card -> Bool
isStrict Card
n then Demand
BotDmd else Demand
AbsDmd
multDmd Card
n (Card
m :* SubDemand
sd) = Card -> Card -> Card
multCard Card
n Card
m HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Card -> SubDemand -> SubDemand
multSubDmd Card
n SubDemand
sd
plusSubDmd :: SubDemand -> SubDemand -> SubDemand
plusSubDmd :: SubDemand -> SubDemand -> SubDemand
plusSubDmd (Poly Boxity
Unboxed Card
C_00) SubDemand
d2 = SubDemand
d2
plusSubDmd SubDemand
d1 (Poly Boxity
Unboxed Card
C_00) = SubDemand
d1
plusSubDmd (Prod Boxity
b1 [Demand]
ds1) (Poly Boxity
b2 Card
n2)
| let !d :: Demand
d = Boxity -> Card -> Demand
polyFieldDmd Boxity
b2 Card
n2
= Boxity -> [Demand] -> SubDemand
mkProd (Boxity -> Boxity -> Boxity
plusBoxity Boxity
b1 Boxity
b2) ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
strictMap (Demand -> Demand -> Demand
plusDmd Demand
d) [Demand]
ds1)
plusSubDmd (Prod Boxity
b1 [Demand]
ds1) (Prod Boxity
b2 [Demand]
ds2)
| [Demand] -> [Demand] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Demand]
ds1 [Demand]
ds2
= Boxity -> [Demand] -> SubDemand
mkProd (Boxity -> Boxity -> Boxity
plusBoxity Boxity
b1 Boxity
b2) ((Demand -> Demand -> Demand) -> [Demand] -> [Demand] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
strictZipWith Demand -> Demand -> Demand
plusDmd [Demand]
ds1 [Demand]
ds2)
plusSubDmd (Call Card
n1 SubDemand
sd1) sd2 :: SubDemand
sd2@(Poly Boxity
_ Card
n2)
| Card -> Bool
isAbs Card
n2 = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
plusCard Card
n2 Card
n1) SubDemand
sd1
| Bool
otherwise = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
plusCard Card
n2 Card
n1) (SubDemand -> SubDemand -> SubDemand
lubSubDmd SubDemand
sd1 SubDemand
sd2)
plusSubDmd (Call Card
n1 SubDemand
sd1) (Call Card
n2 SubDemand
sd2)
| Bool
otherwise = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
plusCard Card
n1 Card
n2) (SubDemand -> SubDemand -> SubDemand
lubSubDmd SubDemand
sd1 SubDemand
sd2)
plusSubDmd (Poly Boxity
b1 Card
n1) (Poly Boxity
b2 Card
n2) = Boxity -> Card -> SubDemand
Poly (Boxity -> Boxity -> Boxity
plusBoxity Boxity
b1 Boxity
b2) (Card -> Card -> Card
plusCard Card
n1 Card
n2)
plusSubDmd sd1 :: SubDemand
sd1@Poly{} SubDemand
sd2 = SubDemand -> SubDemand -> SubDemand
plusSubDmd SubDemand
sd2 SubDemand
sd1
plusSubDmd SubDemand
_ SubDemand
_ = SubDemand
topSubDmd
plusDmd :: Demand -> Demand -> Demand
plusDmd :: Demand -> Demand -> Demand
plusDmd (Card
n1 :* SubDemand
sd1) (Card
n2 :* SubDemand
sd2) = Card -> Card -> Card
plusCard Card
n1 Card
n2 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand -> SubDemand -> SubDemand
plusSubDmd SubDemand
sd1 SubDemand
sd2
isTopDmd :: Demand -> Bool
isTopDmd :: Demand -> Bool
isTopDmd Demand
dmd = Demand
dmd Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Demand
topDmd
isAbsDmd :: Demand -> Bool
isAbsDmd :: Demand -> Bool
isAbsDmd (Card
n :* SubDemand
_) = Card -> Bool
isAbs Card
n
isStrictDmd :: Demand -> Bool
isStrictDmd :: Demand -> Bool
isStrictDmd (Card
n :* SubDemand
_) = Card -> Bool
isStrict Card
n
isStrUsedDmd :: Demand -> Bool
isStrUsedDmd :: Demand -> Bool
isStrUsedDmd (Card
n :* SubDemand
_) = Card -> Bool
isStrict Card
n Bool -> Bool -> Bool
&& Bool -> Bool
not (Card -> Bool
isAbs Card
n)
isUsedOnceDmd :: Demand -> Bool
isUsedOnceDmd :: Demand -> Bool
isUsedOnceDmd (Card
n :* SubDemand
_) = Card -> Bool
isUsedOnce Card
n
isWeakDmd :: Demand -> Bool
isWeakDmd :: Demand -> Bool
isWeakDmd dmd :: Demand
dmd@(Card
n :* SubDemand
_) = Bool -> Bool
not (Card -> Bool
isStrict Card
n) Bool -> Bool -> Bool
&& Demand -> Bool
is_plus_idem_dmd Demand
dmd
where
is_plus_idem_card :: Card -> Bool
is_plus_idem_card = Card -> Bool
isCardNonOnce
is_plus_idem_dmd :: Demand -> Bool
is_plus_idem_dmd Demand
AbsDmd = Bool
True
is_plus_idem_dmd Demand
BotDmd = Bool
True
is_plus_idem_dmd (Card
n :* SubDemand
sd) = Card -> Bool
is_plus_idem_card Card
n Bool -> Bool -> Bool
&& SubDemand -> Bool
is_plus_idem_sub_dmd SubDemand
sd
is_plus_idem_sub_dmd :: SubDemand -> Bool
is_plus_idem_sub_dmd (Poly Boxity
_ Card
n) = Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Card -> Bool
isCardNonOnce Card
n) Bool
True
is_plus_idem_sub_dmd (Prod Boxity
_ [Demand]
ds) = (Demand -> Bool) -> [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Demand -> Bool
is_plus_idem_dmd [Demand]
ds
is_plus_idem_sub_dmd (Call Card
n SubDemand
_) = Card -> Bool
is_plus_idem_card Card
n
evalDmd :: Demand
evalDmd :: Demand
evalDmd = Card
C_1N HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
topSubDmd
strictOnceApply1Dmd :: Demand
strictOnceApply1Dmd :: Demand
strictOnceApply1Dmd = Card
C_11 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Card -> SubDemand -> SubDemand
mkCall Card
C_11 SubDemand
topSubDmd
strictManyApply1Dmd :: Demand
strictManyApply1Dmd :: Demand
strictManyApply1Dmd = Card
C_1N HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Card -> SubDemand -> SubDemand
mkCall Card
C_1N SubDemand
topSubDmd
lazyApply1Dmd :: Demand
lazyApply1Dmd :: Demand
lazyApply1Dmd = Card
C_01 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Card -> SubDemand -> SubDemand
mkCall Card
C_01 SubDemand
topSubDmd
lazyApply2Dmd :: Demand
lazyApply2Dmd :: Demand
lazyApply2Dmd = Card
C_01 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Card -> SubDemand -> SubDemand
mkCall Card
C_01 (Card -> SubDemand -> SubDemand
mkCall Card
C_11 SubDemand
topSubDmd)
oneifyDmd :: Demand -> Demand
oneifyDmd :: Demand -> Demand
oneifyDmd Demand
AbsDmd = Demand
AbsDmd
oneifyDmd Demand
BotDmd = Demand
BotDmd
oneifyDmd (Card
n :* SubDemand
sd) = Card -> Card
oneifyCard Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
sd
strictifyDmd :: Demand -> Demand
strictifyDmd :: Demand -> Demand
strictifyDmd Demand
AbsDmd = Demand
seqDmd
strictifyDmd Demand
BotDmd = Demand
BotDmd
strictifyDmd (Card
n :* SubDemand
sd) = Card -> Card -> Card
plusCard Card
C_10 Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
sd
strictifyDictDmd :: Type -> Demand -> Demand
strictifyDictDmd :: Type -> Demand -> Demand
strictifyDictDmd Type
ty (Card
n :* Prod Boxity
b [Demand]
ds)
| Bool -> Bool
not (Card -> Bool
isAbs Card
n)
, Just [Type]
field_tys <- Type -> Maybe [Type]
as_non_newtype_dict Type
ty
= Card
C_1N HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Boxity -> [Demand] -> SubDemand
mkProd Boxity
b ((Type -> Demand -> Demand) -> [Type] -> [Demand] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Demand -> Demand
strictifyDictDmd [Type]
field_tys [Demand]
ds)
where
as_non_newtype_dict :: Type -> Maybe [Type]
as_non_newtype_dict Type
ty
| Just (TyCon
tycon, [Type]
_arg_tys, DataCon
_data_con, (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing -> [Type]
inst_con_arg_tys)
<- Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
ty
, Bool -> Bool
not (TyCon -> Bool
isNewTyCon TyCon
tycon)
, TyCon -> Bool
isClassTyCon TyCon
tycon
= [Type] -> Maybe [Type]
forall a. a -> Maybe a
Just [Type]
inst_con_arg_tys
| Bool
otherwise
= Maybe [Type]
forall a. Maybe a
Nothing
strictifyDictDmd Type
_ Demand
dmd = Demand
dmd
lazifyDmd :: Demand -> Demand
lazifyDmd :: Demand -> Demand
lazifyDmd Demand
AbsDmd = Demand
AbsDmd
lazifyDmd Demand
BotDmd = Demand
AbsDmd
lazifyDmd (Card
n :* SubDemand
sd) = Card -> Card -> Card
multCard Card
C_01 Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand -> SubDemand
lazifySubDmd SubDemand
sd
lazifySubDmd :: SubDemand -> SubDemand
lazifySubDmd :: SubDemand -> SubDemand
lazifySubDmd (Poly Boxity
b Card
n) = Boxity -> Card -> SubDemand
Poly Boxity
b (Card -> Card -> Card
multCard Card
C_01 Card
n)
lazifySubDmd (Prod Boxity
b [Demand]
sd) = Boxity -> [Demand] -> SubDemand
mkProd Boxity
b ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
strictMap Demand -> Demand
lazifyDmd [Demand]
sd)
lazifySubDmd (Call Card
n SubDemand
sd) = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
lubCard Card
C_01 Card
n) SubDemand
sd
mkCalledOnceDmd :: SubDemand -> SubDemand
mkCalledOnceDmd :: SubDemand -> SubDemand
mkCalledOnceDmd SubDemand
sd = Card -> SubDemand -> SubDemand
mkCall Card
C_11 SubDemand
sd
mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand
mkCalledOnceDmds :: Int -> SubDemand -> SubDemand
mkCalledOnceDmds Int
arity SubDemand
sd = (SubDemand -> SubDemand) -> SubDemand -> [SubDemand]
forall a. (a -> a) -> a -> [a]
iterate SubDemand -> SubDemand
mkCalledOnceDmd SubDemand
sd [SubDemand] -> Int -> SubDemand
forall a. HasCallStack => [a] -> Int -> a
!! Int
arity
peelCallDmd :: SubDemand -> (Card, SubDemand)
peelCallDmd :: SubDemand -> (Card, SubDemand)
peelCallDmd SubDemand
sd = SubDemand -> Maybe (Card, SubDemand)
viewCall SubDemand
sd Maybe (Card, SubDemand) -> (Card, SubDemand) -> (Card, SubDemand)
forall a. Maybe a -> a -> a
`orElse` (Card
topCard, SubDemand
topSubDmd)
peelManyCalls :: Arity -> SubDemand -> (Card, SubDemand)
peelManyCalls :: Int -> SubDemand -> (Card, SubDemand)
peelManyCalls Int
k SubDemand
sd = Int -> Card -> SubDemand -> (Card, SubDemand)
forall {t}.
(Eq t, Num t) =>
t -> Card -> SubDemand -> (Card, SubDemand)
go Int
k Card
C_11 SubDemand
sd
where
go :: t -> Card -> SubDemand -> (Card, SubDemand)
go t
0 !Card
n !SubDemand
sd = (Card
n, SubDemand
sd)
go t
k !Card
n (SubDemand -> Maybe (Card, SubDemand)
viewCall -> Just (Card
m, SubDemand
sd)) = t -> Card -> SubDemand -> (Card, SubDemand)
go (t
kt -> t -> t
forall a. Num a => a -> a -> a
-t
1) (Card
n Card -> Card -> Card
`multCard` Card
m) SubDemand
sd
go t
_ Card
_ SubDemand
_ = (Card
topCard, SubDemand
topSubDmd)
{-# INLINE peelManyCalls #-}
mkWorkerDemand :: Int -> Demand
mkWorkerDemand :: Int -> Demand
mkWorkerDemand Int
n = Card
C_01 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Int -> SubDemand
forall {t}. (Eq t, Num t) => t -> SubDemand
go Int
n
where go :: t -> SubDemand
go t
0 = SubDemand
topSubDmd
go t
n = Card -> SubDemand -> SubDemand
Call Card
C_01 (SubDemand -> SubDemand) -> SubDemand -> SubDemand
forall a b. (a -> b) -> a -> b
$ t -> SubDemand
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1)
argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]]
argsOneShots :: DmdSig -> Int -> [[OneShotInfo]]
argsOneShots (DmdSig (DmdType DmdEnv
_ [Demand]
arg_ds)) Int
n_val_args
| Bool
unsaturated_call = []
| Bool
otherwise = [Demand] -> [[OneShotInfo]]
go [Demand]
arg_ds
where
unsaturated_call :: Bool
unsaturated_call = [Demand]
arg_ds [Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
n_val_args
go :: [Demand] -> [[OneShotInfo]]
go [] = []
go (Demand
arg_d : [Demand]
arg_ds) = Demand -> [OneShotInfo]
argOneShots Demand
arg_d [OneShotInfo] -> [[OneShotInfo]] -> [[OneShotInfo]]
forall {a}. [a] -> [[a]] -> [[a]]
`cons` [Demand] -> [[OneShotInfo]]
go [Demand]
arg_ds
cons :: [a] -> [[a]] -> [[a]]
cons [] [] = []
cons [a]
a [[a]]
as = [a]
a[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:[[a]]
as
argOneShots :: Demand
-> [OneShotInfo]
argOneShots :: Demand -> [OneShotInfo]
argOneShots Demand
AbsDmd = []
argOneShots Demand
BotDmd = []
argOneShots (Card
_ :* SubDemand
sd) = SubDemand -> [OneShotInfo]
go SubDemand
sd
where
go :: SubDemand -> [OneShotInfo]
go (Call Card
n SubDemand
sd)
| Card -> Bool
isUsedOnce Card
n = OneShotInfo
OneShotLam OneShotInfo -> [OneShotInfo] -> [OneShotInfo]
forall a. a -> [a] -> [a]
: SubDemand -> [OneShotInfo]
go SubDemand
sd
| Bool
otherwise = OneShotInfo
NoOneShotInfo OneShotInfo -> [OneShotInfo] -> [OneShotInfo]
forall a. a -> [a] -> [a]
: SubDemand -> [OneShotInfo]
go SubDemand
sd
go SubDemand
_ = []
saturatedByOneShots :: Int -> Demand -> Bool
saturatedByOneShots :: Int -> Demand -> Bool
saturatedByOneShots Int
_ Demand
AbsDmd = Bool
True
saturatedByOneShots Int
_ Demand
BotDmd = Bool
True
saturatedByOneShots Int
n (Card
_ :* SubDemand
sd) = Card -> Bool
isUsedOnce (Card -> Bool) -> Card -> Bool
forall a b. (a -> b) -> a -> b
$ (Card, SubDemand) -> Card
forall a b. (a, b) -> a
fst ((Card, SubDemand) -> Card) -> (Card, SubDemand) -> Card
forall a b. (a -> b) -> a -> b
$ Int -> SubDemand -> (Card, SubDemand)
peelManyCalls Int
n SubDemand
sd
data Divergence
= Diverges
| ExnOrDiv
| Dunno
deriving Divergence -> Divergence -> Bool
(Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Bool) -> Eq Divergence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Divergence -> Divergence -> Bool
== :: Divergence -> Divergence -> Bool
$c/= :: Divergence -> Divergence -> Bool
/= :: Divergence -> Divergence -> Bool
Eq
lubDivergence :: Divergence -> Divergence -> Divergence
lubDivergence :: Divergence -> Divergence -> Divergence
lubDivergence Divergence
Diverges Divergence
div = Divergence
div
lubDivergence Divergence
div Divergence
Diverges = Divergence
div
lubDivergence Divergence
ExnOrDiv Divergence
ExnOrDiv = Divergence
ExnOrDiv
lubDivergence Divergence
_ Divergence
_ = Divergence
Dunno
plusDivergence :: Divergence -> Divergence -> Divergence
plusDivergence :: Divergence -> Divergence -> Divergence
plusDivergence Divergence
Dunno Divergence
Dunno = Divergence
Dunno
plusDivergence Divergence
Diverges Divergence
_ = Divergence
Diverges
plusDivergence Divergence
_ Divergence
Diverges = Divergence
Diverges
plusDivergence Divergence
_ Divergence
_ = Divergence
ExnOrDiv
multDivergence :: Card -> Divergence -> Divergence
multDivergence :: Card -> Divergence -> Divergence
multDivergence Card
n Divergence
_ | Bool -> Bool
not (Card -> Bool
isStrict Card
n) = Divergence
Dunno
multDivergence Card
_ Divergence
d = Divergence
d
topDiv, exnDiv, botDiv :: Divergence
topDiv :: Divergence
topDiv = Divergence
Dunno
exnDiv :: Divergence
exnDiv = Divergence
ExnOrDiv
botDiv :: Divergence
botDiv = Divergence
Diverges
isDeadEndDiv :: Divergence -> Bool
isDeadEndDiv :: Divergence -> Bool
isDeadEndDiv Divergence
Diverges = Bool
True
isDeadEndDiv Divergence
ExnOrDiv = Bool
True
isDeadEndDiv Divergence
Dunno = Bool
False
defaultFvDmd :: Divergence -> Demand
defaultFvDmd :: Divergence -> Demand
defaultFvDmd Divergence
Dunno = Demand
absDmd
defaultFvDmd Divergence
ExnOrDiv = Demand
absDmd
defaultFvDmd Divergence
Diverges = Demand
botDmd
defaultArgDmd :: Divergence -> Demand
defaultArgDmd :: Divergence -> Demand
defaultArgDmd Divergence
Dunno = Demand
topDmd
defaultArgDmd Divergence
ExnOrDiv = Demand
absDmd
defaultArgDmd Divergence
Diverges = Demand
botDmd
data DmdEnv = DE { DmdEnv -> VarEnv Demand
de_fvs :: !(VarEnv Demand), DmdEnv -> Divergence
de_div :: !Divergence }
instance Eq DmdEnv where
DE VarEnv Demand
fv1 Divergence
div1 == :: DmdEnv -> DmdEnv -> Bool
== DE VarEnv Demand
fv2 Divergence
div2
= Divergence
div1 Divergence -> Divergence -> Bool
forall a. Eq a => a -> a -> Bool
== Divergence
div2 Bool -> Bool -> Bool
&& Divergence -> VarEnv Demand -> VarEnv Demand
forall {key}. Divergence -> UniqFM key Demand -> UniqFM key Demand
canonicalise Divergence
div1 VarEnv Demand
fv1 VarEnv Demand -> VarEnv Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Divergence -> VarEnv Demand -> VarEnv Demand
forall {key}. Divergence -> UniqFM key Demand -> UniqFM key Demand
canonicalise Divergence
div2 VarEnv Demand
fv2
where
canonicalise :: Divergence -> UniqFM key Demand -> UniqFM key Demand
canonicalise Divergence
div UniqFM key Demand
fv = (Demand -> Bool) -> UniqFM key Demand -> UniqFM key Demand
forall elt key. (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM (Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
/= Divergence -> Demand
defaultFvDmd Divergence
div) UniqFM key Demand
fv
mkEmptyDmdEnv :: Divergence -> DmdEnv
mkEmptyDmdEnv :: Divergence -> DmdEnv
mkEmptyDmdEnv Divergence
div = VarEnv Demand -> Divergence -> DmdEnv
DE VarEnv Demand
forall a. VarEnv a
emptyVarEnv Divergence
div
mkTermDmdEnv :: VarEnv Demand -> DmdEnv
mkTermDmdEnv :: VarEnv Demand -> DmdEnv
mkTermDmdEnv VarEnv Demand
fvs = VarEnv Demand -> Divergence -> DmdEnv
DE VarEnv Demand
fvs Divergence
topDiv
nopDmdEnv :: DmdEnv
nopDmdEnv :: DmdEnv
nopDmdEnv = Divergence -> DmdEnv
mkEmptyDmdEnv Divergence
topDiv
botDmdEnv :: DmdEnv
botDmdEnv :: DmdEnv
botDmdEnv = Divergence -> DmdEnv
mkEmptyDmdEnv Divergence
botDiv
exnDmdEnv :: DmdEnv
exnDmdEnv :: DmdEnv
exnDmdEnv = Divergence -> DmdEnv
mkEmptyDmdEnv Divergence
exnDiv
lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
lubDmdEnv (DE VarEnv Demand
fv1 Divergence
d1) (DE VarEnv Demand
fv2 Divergence
d2) = VarEnv Demand -> Divergence -> DmdEnv
DE VarEnv Demand
lub_fv Divergence
lub_div
where
lub_fv :: VarEnv Demand
lub_fv = (Demand -> Demand -> Demand)
-> VarEnv Demand
-> Demand
-> VarEnv Demand
-> Demand
-> VarEnv Demand
forall a.
(a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
plusVarEnv_CD Demand -> Demand -> Demand
lubDmd VarEnv Demand
fv1 (Divergence -> Demand
defaultFvDmd Divergence
d1) VarEnv Demand
fv2 (Divergence -> Demand
defaultFvDmd Divergence
d2)
lub_div :: Divergence
lub_div = Divergence -> Divergence -> Divergence
lubDivergence Divergence
d1 Divergence
d2
addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv
addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv
addVarDmdEnv env :: DmdEnv
env@(DE VarEnv Demand
fvs Divergence
div) Id
id Demand
dmd
= VarEnv Demand -> Divergence -> DmdEnv
DE (VarEnv Demand -> Id -> Demand -> VarEnv Demand
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Demand
fvs Id
id (Demand
dmd Demand -> Demand -> Demand
`plusDmd` DmdEnv -> Id -> Demand
lookupDmdEnv DmdEnv
env Id
id)) Divergence
div
plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
plusDmdEnv (DE VarEnv Demand
fv1 Divergence
d1) (DE VarEnv Demand
fv2 Divergence
d2)
| VarEnv Demand -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv Demand
fv2, Divergence -> Demand
defaultFvDmd Divergence
d2 Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Demand
absDmd
= VarEnv Demand -> Divergence -> DmdEnv
DE VarEnv Demand
fv1 (Divergence
d1 Divergence -> Divergence -> Divergence
`plusDivergence` Divergence
d2)
| VarEnv Demand -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarEnv Demand
fv1, Divergence -> Demand
defaultFvDmd Divergence
d1 Demand -> Demand -> Bool
forall a. Eq a => a -> a -> Bool
== Demand
absDmd
= VarEnv Demand -> Divergence -> DmdEnv
DE VarEnv Demand
fv2 (Divergence
d1 Divergence -> Divergence -> Divergence
`plusDivergence` Divergence
d2)
| Bool
otherwise
= VarEnv Demand -> Divergence -> DmdEnv
DE ((Demand -> Demand -> Demand)
-> VarEnv Demand
-> Demand
-> VarEnv Demand
-> Demand
-> VarEnv Demand
forall a.
(a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a
plusVarEnv_CD Demand -> Demand -> Demand
plusDmd VarEnv Demand
fv1 (Divergence -> Demand
defaultFvDmd Divergence
d1) VarEnv Demand
fv2 (Divergence -> Demand
defaultFvDmd Divergence
d2))
(Divergence
d1 Divergence -> Divergence -> Divergence
`plusDivergence` Divergence
d2)
plusDmdEnvs :: [DmdEnv] -> DmdEnv
plusDmdEnvs :: [DmdEnv] -> DmdEnv
plusDmdEnvs [] = DmdEnv
nopDmdEnv
plusDmdEnvs [DmdEnv]
pdas = (DmdEnv -> DmdEnv -> DmdEnv) -> [DmdEnv] -> DmdEnv
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' DmdEnv -> DmdEnv -> DmdEnv
plusDmdEnv [DmdEnv]
pdas
multDmdEnv :: Card -> DmdEnv -> DmdEnv
multDmdEnv :: Card -> DmdEnv -> DmdEnv
multDmdEnv Card
C_11 DmdEnv
env = DmdEnv
env
multDmdEnv Card
C_00 DmdEnv
_ = DmdEnv
nopDmdEnv
multDmdEnv Card
n (DE VarEnv Demand
fvs Divergence
div) = VarEnv Demand -> Divergence -> DmdEnv
DE ((Demand -> Demand) -> VarEnv Demand -> VarEnv Demand
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (Card -> Demand -> Demand
multDmd Card
n) VarEnv Demand
fvs) (Card -> Divergence -> Divergence
multDivergence Card
n Divergence
div)
reuseEnv :: DmdEnv -> DmdEnv
reuseEnv :: DmdEnv -> DmdEnv
reuseEnv = Card -> DmdEnv -> DmdEnv
multDmdEnv Card
C_1N
lookupDmdEnv :: DmdEnv -> Id -> Demand
lookupDmdEnv :: DmdEnv -> Id -> Demand
lookupDmdEnv (DE VarEnv Demand
fv Divergence
div) Id
id = VarEnv Demand -> Id -> Maybe Demand
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Demand
fv Id
id Maybe Demand -> Demand -> Demand
forall a. Maybe a -> a -> a
`orElse` Divergence -> Demand
defaultFvDmd Divergence
div
delDmdEnv :: DmdEnv -> Id -> DmdEnv
delDmdEnv :: DmdEnv -> Id -> DmdEnv
delDmdEnv (DE VarEnv Demand
fv Divergence
div) Id
id = VarEnv Demand -> Divergence -> DmdEnv
DE (VarEnv Demand
fv VarEnv Demand -> Id -> VarEnv Demand
forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
id) Divergence
div
data DmdType
= DmdType
{ DmdType -> DmdEnv
dt_env :: !DmdEnv
, DmdType -> [Demand]
dt_args :: ![Demand]
}
instance Eq DmdType where
DmdType DmdEnv
env1 [Demand]
ds1 == :: DmdType -> DmdType -> Bool
== DmdType DmdEnv
env2 [Demand]
ds2
= [Demand]
ds1 [Demand] -> [Demand] -> Bool
forall a. Eq a => a -> a -> Bool
== [Demand]
ds2
Bool -> Bool -> Bool
&& DmdEnv
env1 DmdEnv -> DmdEnv -> Bool
forall a. Eq a => a -> a -> Bool
== DmdEnv
env2
lubDmdType :: DmdType -> DmdType -> DmdType
lubDmdType :: DmdType -> DmdType -> DmdType
lubDmdType DmdType
d1 DmdType
d2 = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
lub_fv [Demand]
lub_ds
where
n :: Int
n = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (DmdType -> Int
dmdTypeDepth DmdType
d1) (DmdType -> Int
dmdTypeDepth DmdType
d2)
(DmdType DmdEnv
fv1 [Demand]
ds1) = Int -> DmdType -> DmdType
etaExpandDmdType Int
n DmdType
d1
(DmdType DmdEnv
fv2 [Demand]
ds2) = Int -> DmdType -> DmdType
etaExpandDmdType Int
n DmdType
d2
lub_ds :: [Demand]
lub_ds = String
-> (Demand -> Demand -> Demand) -> [Demand] -> [Demand] -> [Demand]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"lubDmdType" Demand -> Demand -> Demand
lubDmd [Demand]
ds1 [Demand]
ds2
lub_fv :: DmdEnv
lub_fv = DmdEnv -> DmdEnv -> DmdEnv
lubDmdEnv DmdEnv
fv1 DmdEnv
fv2
discardArgDmds :: DmdType -> DmdEnv
discardArgDmds :: DmdType -> DmdEnv
discardArgDmds (DmdType DmdEnv
fv [Demand]
_) = DmdEnv
fv
plusDmdType :: DmdType -> DmdEnv -> DmdType
plusDmdType :: DmdType -> DmdEnv -> DmdType
plusDmdType (DmdType DmdEnv
fv [Demand]
ds) DmdEnv
fv'
= DmdEnv -> [Demand] -> DmdType
DmdType (DmdEnv -> DmdEnv -> DmdEnv
plusDmdEnv DmdEnv
fv DmdEnv
fv') [Demand]
ds
botDmdType :: DmdType
botDmdType :: DmdType
botDmdType = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
botDmdEnv []
nopDmdType :: DmdType
nopDmdType :: DmdType
nopDmdType = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
nopDmdEnv []
exnDmdType :: DmdType
exnDmdType :: DmdType
exnDmdType = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
exnDmdEnv []
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth :: DmdType -> Int
dmdTypeDepth = [Demand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Demand] -> Int) -> (DmdType -> [Demand]) -> DmdType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdType -> [Demand]
dt_args
etaExpandDmdType :: Arity -> DmdType -> DmdType
etaExpandDmdType :: Int -> DmdType -> DmdType
etaExpandDmdType Int
n d :: DmdType
d@DmdType{dt_args :: DmdType -> [Demand]
dt_args = [Demand]
ds, dt_env :: DmdType -> DmdEnv
dt_env = DmdEnv
env}
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
depth = DmdType
d
| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
depth = DmdType
d{dt_args :: [Demand]
dt_args = [Demand]
inc_ds}
| Bool
otherwise = String -> SDoc -> DmdType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"etaExpandDmdType: arity decrease" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n SDoc -> SDoc -> SDoc
$$ DmdType -> SDoc
forall a. Outputable a => a -> SDoc
ppr DmdType
d)
where depth :: Int
depth = [Demand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
ds
inc_ds :: [Demand]
inc_ds = Int -> [Demand] -> [Demand]
forall a. Int -> [a] -> [a]
take Int
n ([Demand]
ds [Demand] -> [Demand] -> [Demand]
forall a. [a] -> [a] -> [a]
++ Demand -> [Demand]
forall a. a -> [a]
repeat (Divergence -> Demand
defaultArgDmd (DmdEnv -> Divergence
de_div DmdEnv
env)))
decreaseArityDmdType :: DmdType -> DmdType
decreaseArityDmdType :: DmdType -> DmdType
decreaseArityDmdType DmdType
_ = DmdType
nopDmdType
splitDmdTy :: DmdType -> (Demand, DmdType)
splitDmdTy :: DmdType -> (Demand, DmdType)
splitDmdTy ty :: DmdType
ty@DmdType{dt_args :: DmdType -> [Demand]
dt_args=Demand
dmd:[Demand]
args} = (Demand
dmd, DmdType
ty{dt_args :: [Demand]
dt_args=[Demand]
args})
splitDmdTy ty :: DmdType
ty@DmdType{dt_env :: DmdType -> DmdEnv
dt_env=DmdEnv
env} = (Divergence -> Demand
defaultArgDmd (DmdEnv -> Divergence
de_div DmdEnv
env), DmdType
ty)
multDmdType :: Card -> DmdType -> DmdType
multDmdType :: Card -> DmdType -> DmdType
multDmdType Card
n (DmdType DmdEnv
fv [Demand]
args)
=
DmdEnv -> [Demand] -> DmdType
DmdType (Card -> DmdEnv -> DmdEnv
multDmdEnv Card
n DmdEnv
fv)
((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map (Card -> Demand -> Demand
multDmd Card
n) [Demand]
args)
peelFV :: DmdType -> Var -> (DmdType, Demand)
peelFV :: DmdType -> Id -> (DmdType, Demand)
peelFV (DmdType DmdEnv
fv [Demand]
ds) Id
id =
(DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
fv' [Demand]
ds, Demand
dmd)
where
!fv' :: DmdEnv
fv' = DmdEnv
fv DmdEnv -> Id -> DmdEnv
`delDmdEnv` Id
id
!dmd :: Demand
dmd = DmdEnv -> Id -> Demand
lookupDmdEnv DmdEnv
fv Id
id
addDemand :: Demand -> DmdType -> DmdType
addDemand :: Demand -> DmdType -> DmdType
addDemand Demand
dmd (DmdType DmdEnv
fv [Demand]
ds) = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
fv (Demand
dmdDemand -> [Demand] -> [Demand]
forall a. a -> [a] -> [a]
:[Demand]
ds)
findIdDemand :: DmdType -> Var -> Demand
findIdDemand :: DmdType -> Id -> Demand
findIdDemand (DmdType DmdEnv
fv [Demand]
_) Id
id = DmdEnv -> Id -> Demand
lookupDmdEnv DmdEnv
fv Id
id
deferAfterPreciseException :: DmdType -> DmdType
deferAfterPreciseException :: DmdType -> DmdType
deferAfterPreciseException = DmdType -> DmdType -> DmdType
lubDmdType DmdType
exnDmdType
newtype DmdSig
= DmdSig DmdType
deriving DmdSig -> DmdSig -> Bool
(DmdSig -> DmdSig -> Bool)
-> (DmdSig -> DmdSig -> Bool) -> Eq DmdSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DmdSig -> DmdSig -> Bool
== :: DmdSig -> DmdSig -> Bool
$c/= :: DmdSig -> DmdSig -> Bool
/= :: DmdSig -> DmdSig -> Bool
Eq
mkDmdSigForArity :: Arity -> DmdType -> DmdSig
mkDmdSigForArity :: Int -> DmdType -> DmdSig
mkDmdSigForArity Int
arity dmd_ty :: DmdType
dmd_ty@(DmdType DmdEnv
fvs [Demand]
args)
| Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< DmdType -> Int
dmdTypeDepth DmdType
dmd_ty = DmdType -> DmdSig
DmdSig (DmdType -> DmdSig) -> DmdType -> DmdSig
forall a b. (a -> b) -> a -> b
$ DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
fvs (Int -> [Demand] -> [Demand]
forall a. Int -> [a] -> [a]
take Int
arity [Demand]
args)
| Bool
otherwise = DmdType -> DmdSig
DmdSig (Int -> DmdType -> DmdType
etaExpandDmdType Int
arity DmdType
dmd_ty)
mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig
mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig
mkClosedDmdSig [Demand]
ds Divergence
div = Int -> DmdType -> DmdSig
mkDmdSigForArity ([Demand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
ds) (DmdEnv -> [Demand] -> DmdType
DmdType (Divergence -> DmdEnv
mkEmptyDmdEnv Divergence
div) [Demand]
ds)
splitDmdSig :: DmdSig -> ([Demand], Divergence)
splitDmdSig :: DmdSig -> ([Demand], Divergence)
splitDmdSig (DmdSig (DmdType DmdEnv
env [Demand]
dmds)) = ([Demand]
dmds, DmdEnv -> Divergence
de_div DmdEnv
env)
dmdSigDmdEnv :: DmdSig -> DmdEnv
dmdSigDmdEnv :: DmdSig -> DmdEnv
dmdSigDmdEnv (DmdSig (DmdType DmdEnv
env [Demand]
_)) = DmdEnv
env
hasDemandEnvSig :: DmdSig -> Bool
hasDemandEnvSig :: DmdSig -> Bool
hasDemandEnvSig = Bool -> Bool
not (Bool -> Bool) -> (DmdSig -> Bool) -> DmdSig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarEnv Demand -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv (VarEnv Demand -> Bool)
-> (DmdSig -> VarEnv Demand) -> DmdSig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdEnv -> VarEnv Demand
de_fvs (DmdEnv -> VarEnv Demand)
-> (DmdSig -> DmdEnv) -> DmdSig -> VarEnv Demand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdSig -> DmdEnv
dmdSigDmdEnv
botSig :: DmdSig
botSig :: DmdSig
botSig = DmdType -> DmdSig
DmdSig DmdType
botDmdType
nopSig :: DmdSig
nopSig :: DmdSig
nopSig = DmdType -> DmdSig
DmdSig DmdType
nopDmdType
isNopSig :: DmdSig -> Bool
isNopSig :: DmdSig -> Bool
isNopSig (DmdSig DmdType
ty) = DmdType
ty DmdType -> DmdType -> Bool
forall a. Eq a => a -> a -> Bool
== DmdType
nopDmdType
isDeadEndSig :: DmdSig -> Bool
isDeadEndSig :: DmdSig -> Bool
isDeadEndSig (DmdSig (DmdType DmdEnv
env [Demand]
_)) = Divergence -> Bool
isDeadEndDiv (DmdEnv -> Divergence
de_div DmdEnv
env)
onlyBoxedArguments :: DmdSig -> Bool
onlyBoxedArguments :: DmdSig -> Bool
onlyBoxedArguments (DmdSig (DmdType DmdEnv
_ [Demand]
dmds)) = (Demand -> Bool) -> [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Demand -> Bool
demandIsBoxed [Demand]
dmds
where
demandIsBoxed :: Demand -> Bool
demandIsBoxed Demand
BotDmd = Bool
True
demandIsBoxed Demand
AbsDmd = Bool
True
demandIsBoxed (Card
_ :* SubDemand
sd) = SubDemand -> Bool
subDemandIsboxed SubDemand
sd
subDemandIsboxed :: SubDemand -> Bool
subDemandIsboxed (Poly Boxity
Unboxed Card
_) = Bool
False
subDemandIsboxed (Poly Boxity
_ Card
_) = Bool
True
subDemandIsboxed (Call Card
_ SubDemand
sd) = SubDemand -> Bool
subDemandIsboxed SubDemand
sd
subDemandIsboxed (Prod Boxity
Unboxed [Demand]
_) = Bool
False
subDemandIsboxed (Prod Boxity
_ [Demand]
ds) = (Demand -> Bool) -> [Demand] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Demand -> Bool
demandIsBoxed [Demand]
ds
isDeadEndAppSig :: DmdSig -> Int -> Bool
isDeadEndAppSig :: DmdSig -> Int -> Bool
isDeadEndAppSig (DmdSig (DmdType DmdEnv
env [Demand]
ds)) Int
n
= Divergence -> Bool
isDeadEndDiv (DmdEnv -> Divergence
de_div DmdEnv
env) Bool -> Bool -> Bool
&& Bool -> Bool
not ([Demand] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthExceeds [Demand]
ds Int
n)
trimBoxityDmdEnv :: DmdEnv -> DmdEnv
trimBoxityDmdEnv :: DmdEnv -> DmdEnv
trimBoxityDmdEnv (DE VarEnv Demand
fvs Divergence
div) = VarEnv Demand -> Divergence -> DmdEnv
DE ((Demand -> Demand) -> VarEnv Demand -> VarEnv Demand
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv Demand -> Demand
trimBoxity VarEnv Demand
fvs) Divergence
div
trimBoxityDmdType :: DmdType -> DmdType
trimBoxityDmdType :: DmdType -> DmdType
trimBoxityDmdType (DmdType DmdEnv
env [Demand]
ds) =
DmdEnv -> [Demand] -> DmdType
DmdType (DmdEnv -> DmdEnv
trimBoxityDmdEnv DmdEnv
env) ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map Demand -> Demand
trimBoxity [Demand]
ds)
trimBoxityDmdSig :: DmdSig -> DmdSig
trimBoxityDmdSig :: DmdSig -> DmdSig
trimBoxityDmdSig = (DmdType -> DmdType) -> DmdSig -> DmdSig
forall a b. Coercible a b => a -> b
coerce DmdType -> DmdType
trimBoxityDmdType
prependArgsDmdSig :: Int -> DmdSig -> DmdSig
prependArgsDmdSig :: Int -> DmdSig -> DmdSig
prependArgsDmdSig Int
new_args sig :: DmdSig
sig@(DmdSig dmd_ty :: DmdType
dmd_ty@(DmdType DmdEnv
env [Demand]
dmds))
| Int
new_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = DmdSig
sig
| DmdType
dmd_ty DmdType -> DmdType -> Bool
forall a. Eq a => a -> a -> Bool
== DmdType
nopDmdType = DmdSig
sig
| Bool
otherwise = DmdType -> DmdSig
DmdSig (DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
env [Demand]
dmds')
where
dmds' :: [Demand]
dmds' = Int -> Demand -> [Demand]
forall a. Int -> a -> [a]
replicate Int
new_args Demand
topDmd [Demand] -> [Demand] -> [Demand]
forall a. [a] -> [a] -> [a]
++ [Demand]
dmds
etaConvertDmdSig :: Arity -> DmdSig -> DmdSig
etaConvertDmdSig :: Int -> DmdSig -> DmdSig
etaConvertDmdSig Int
arity (DmdSig DmdType
dmd_ty)
| Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< DmdType -> Int
dmdTypeDepth DmdType
dmd_ty = DmdType -> DmdSig
DmdSig (DmdType -> DmdSig) -> DmdType -> DmdSig
forall a b. (a -> b) -> a -> b
$ DmdType -> DmdType
decreaseArityDmdType DmdType
dmd_ty
| Bool
otherwise = DmdType -> DmdSig
DmdSig (DmdType -> DmdSig) -> DmdType -> DmdSig
forall a b. (a -> b) -> a -> b
$ Int -> DmdType -> DmdType
etaExpandDmdType Int
arity DmdType
dmd_ty
type DmdTransformer = SubDemand -> DmdType
dmdTransformSig :: DmdSig -> DmdTransformer
dmdTransformSig :: DmdSig -> DmdTransformer
dmdTransformSig (DmdSig dmd_ty :: DmdType
dmd_ty@(DmdType DmdEnv
_ [Demand]
arg_ds)) SubDemand
sd
= Card -> DmdType -> DmdType
multDmdType ((Card, SubDemand) -> Card
forall a b. (a, b) -> a
fst ((Card, SubDemand) -> Card) -> (Card, SubDemand) -> Card
forall a b. (a -> b) -> a -> b
$ Int -> SubDemand -> (Card, SubDemand)
peelManyCalls ([Demand] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Demand]
arg_ds) SubDemand
sd) DmdType
dmd_ty
dmdTransformDataConSig :: [StrictnessMark] -> DmdTransformer
dmdTransformDataConSig :: [StrictnessMark] -> DmdTransformer
dmdTransformDataConSig [StrictnessMark]
str_marks SubDemand
sd = case Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd Int
arity SubDemand
body_sd of
Just (Boxity
_, [Demand]
dmds) -> Card -> [Demand] -> DmdType
mk_body_ty Card
n [Demand]
dmds
Maybe (Boxity, [Demand])
Nothing -> DmdType
nopDmdType
where
arity :: Int
arity = [StrictnessMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictnessMark]
str_marks
(Card
n, SubDemand
body_sd) = Int -> SubDemand -> (Card, SubDemand)
peelManyCalls Int
arity SubDemand
sd
mk_body_ty :: Card -> [Demand] -> DmdType
mk_body_ty Card
n [Demand]
dmds = DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
nopDmdEnv ((StrictnessMark -> Demand -> Demand)
-> [StrictnessMark] -> [Demand] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Card -> StrictnessMark -> Demand -> Demand
bump Card
n) [StrictnessMark]
str_marks [Demand]
dmds)
bump :: Card -> StrictnessMark -> Demand -> Demand
bump Card
n StrictnessMark
str Demand
dmd | StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str = Card -> Demand -> Demand
multDmd Card
n (Demand -> Demand -> Demand
plusDmd Demand
str_field_dmd Demand
dmd)
| Bool
otherwise = Card -> Demand -> Demand
multDmd Card
n Demand
dmd
str_field_dmd :: Demand
str_field_dmd = Card
C_01 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
seqSubDmd
dmdTransformDictSelSig :: DmdSig -> DmdTransformer
dmdTransformDictSelSig :: DmdSig -> DmdTransformer
dmdTransformDictSelSig (DmdSig (DmdType DmdEnv
_ [Card
_ :* SubDemand
prod])) SubDemand
call_sd
| (Card
n, SubDemand
sd') <- SubDemand -> (Card, SubDemand)
peelCallDmd SubDemand
call_sd
, Prod Boxity
_ [Demand]
sig_ds <- SubDemand
prod
= Card -> DmdType -> DmdType
multDmdType Card
n (DmdType -> DmdType) -> DmdType -> DmdType
forall a b. (a -> b) -> a -> b
$
DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
nopDmdEnv [Card
C_11 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* Boxity -> [Demand] -> SubDemand
mkProd Boxity
Unboxed ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map (SubDemand -> Demand -> Demand
enhance SubDemand
sd') [Demand]
sig_ds)]
| Bool
otherwise
= DmdType
nopDmdType
where
enhance :: SubDemand -> Demand -> Demand
enhance SubDemand
_ Demand
AbsDmd = Demand
AbsDmd
enhance SubDemand
_ Demand
BotDmd = Demand
BotDmd
enhance SubDemand
sd Demand
_dmd_var = Card
C_11 HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand
sd
dmdTransformDictSelSig DmdSig
sig SubDemand
sd = String -> SDoc -> DmdType
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dmdTransformDictSelSig: no args" (DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr DmdSig
sig SDoc -> SDoc -> SDoc
$$ SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
sd)
zapDmdEnv :: DmdEnv -> DmdEnv
zapDmdEnv :: DmdEnv -> DmdEnv
zapDmdEnv (DE VarEnv Demand
_ Divergence
div) = Divergence -> DmdEnv
mkEmptyDmdEnv Divergence
div
zapDmdEnvSig :: DmdSig -> DmdSig
zapDmdEnvSig :: DmdSig -> DmdSig
zapDmdEnvSig (DmdSig (DmdType DmdEnv
env [Demand]
ds)) = DmdType -> DmdSig
DmdSig (DmdEnv -> [Demand] -> DmdType
DmdType (DmdEnv -> DmdEnv
zapDmdEnv DmdEnv
env) [Demand]
ds)
zapUsageDemand :: Demand -> Demand
zapUsageDemand :: Demand -> Demand
zapUsageDemand = KillFlags -> Demand -> Demand
kill_usage (KillFlags -> Demand -> Demand) -> KillFlags -> Demand -> Demand
forall a b. (a -> b) -> a -> b
$ KillFlags
{ kf_abs :: Bool
kf_abs = Bool
True
, kf_used_once :: Bool
kf_used_once = Bool
True
, kf_called_once :: Bool
kf_called_once = Bool
True
}
zapUsedOnceDemand :: Demand -> Demand
zapUsedOnceDemand :: Demand -> Demand
zapUsedOnceDemand = KillFlags -> Demand -> Demand
kill_usage (KillFlags -> Demand -> Demand) -> KillFlags -> Demand -> Demand
forall a b. (a -> b) -> a -> b
$ KillFlags
{ kf_abs :: Bool
kf_abs = Bool
False
, kf_used_once :: Bool
kf_used_once = Bool
True
, kf_called_once :: Bool
kf_called_once = Bool
False
}
zapUsedOnceSig :: DmdSig -> DmdSig
zapUsedOnceSig :: DmdSig -> DmdSig
zapUsedOnceSig (DmdSig (DmdType DmdEnv
env [Demand]
ds))
= DmdType -> DmdSig
DmdSig (DmdEnv -> [Demand] -> DmdType
DmdType DmdEnv
env ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map Demand -> Demand
zapUsedOnceDemand [Demand]
ds))
data KillFlags = KillFlags
{ KillFlags -> Bool
kf_abs :: Bool
, KillFlags -> Bool
kf_used_once :: Bool
, KillFlags -> Bool
kf_called_once :: Bool
}
kill_usage_card :: KillFlags -> Card -> Card
kill_usage_card :: KillFlags -> Card -> Card
kill_usage_card KillFlags
kfs Card
C_00 | KillFlags -> Bool
kf_abs KillFlags
kfs = Card
C_0N
kill_usage_card KillFlags
kfs Card
C_10 | KillFlags -> Bool
kf_abs KillFlags
kfs = Card
C_1N
kill_usage_card KillFlags
kfs Card
C_01 | KillFlags -> Bool
kf_used_once KillFlags
kfs = Card
C_0N
kill_usage_card KillFlags
kfs Card
C_11 | KillFlags -> Bool
kf_used_once KillFlags
kfs = Card
C_1N
kill_usage_card KillFlags
_ Card
n = Card
n
kill_usage :: KillFlags -> Demand -> Demand
kill_usage :: KillFlags -> Demand -> Demand
kill_usage KillFlags
_ Demand
AbsDmd = Demand
AbsDmd
kill_usage KillFlags
_ Demand
BotDmd = Demand
BotDmd
kill_usage KillFlags
kfs (Card
n :* SubDemand
sd) = KillFlags -> Card -> Card
kill_usage_card KillFlags
kfs Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* KillFlags -> SubDemand -> SubDemand
kill_usage_sd KillFlags
kfs SubDemand
sd
kill_usage_sd :: KillFlags -> SubDemand -> SubDemand
kill_usage_sd :: KillFlags -> SubDemand -> SubDemand
kill_usage_sd KillFlags
kfs (Call Card
n SubDemand
sd)
| KillFlags -> Bool
kf_called_once KillFlags
kfs = Card -> SubDemand -> SubDemand
mkCall (Card -> Card -> Card
lubCard Card
C_1N Card
n) (KillFlags -> SubDemand -> SubDemand
kill_usage_sd KillFlags
kfs SubDemand
sd)
| Bool
otherwise = Card -> SubDemand -> SubDemand
mkCall Card
n (KillFlags -> SubDemand -> SubDemand
kill_usage_sd KillFlags
kfs SubDemand
sd)
kill_usage_sd KillFlags
kfs (Prod Boxity
b [Demand]
ds) = Boxity -> [Demand] -> SubDemand
mkProd Boxity
b ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map (KillFlags -> Demand -> Demand
kill_usage KillFlags
kfs) [Demand]
ds)
kill_usage_sd KillFlags
_ SubDemand
sd = SubDemand
sd
data TypeShape
= TsFun TypeShape
| TsProd [TypeShape]
| TsUnk
trimToType :: Demand -> TypeShape -> Demand
trimToType :: Demand -> TypeShape -> Demand
trimToType Demand
AbsDmd TypeShape
_ = Demand
AbsDmd
trimToType Demand
BotDmd TypeShape
_ = Demand
BotDmd
trimToType (Card
n :* SubDemand
sd) TypeShape
ts
= Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand -> TypeShape -> SubDemand
go SubDemand
sd TypeShape
ts
where
go :: SubDemand -> TypeShape -> SubDemand
go (Prod Boxity
b [Demand]
ds) (TsProd [TypeShape]
tss)
| [Demand] -> [TypeShape] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [Demand]
ds [TypeShape]
tss = Boxity -> [Demand] -> SubDemand
mkProd Boxity
b ((Demand -> TypeShape -> Demand)
-> [Demand] -> [TypeShape] -> [Demand]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Demand -> TypeShape -> Demand
trimToType [Demand]
ds [TypeShape]
tss)
go (Call Card
n SubDemand
sd) (TsFun TypeShape
ts) = Card -> SubDemand -> SubDemand
mkCall Card
n (SubDemand -> TypeShape -> SubDemand
go SubDemand
sd TypeShape
ts)
go sd :: SubDemand
sd@Poly{} TypeShape
_ = SubDemand
sd
go SubDemand
_ TypeShape
_ = SubDemand
topSubDmd
trimBoxity :: Demand -> Demand
trimBoxity :: Demand -> Demand
trimBoxity Demand
AbsDmd = Demand
AbsDmd
trimBoxity Demand
BotDmd = Demand
BotDmd
trimBoxity (Card
n :* SubDemand
sd) = Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:* SubDemand -> SubDemand
go SubDemand
sd
where
go :: SubDemand -> SubDemand
go (Poly Boxity
_ Card
n) = Boxity -> Card -> SubDemand
Poly Boxity
Boxed Card
n
go (Prod Boxity
_ [Demand]
ds) = Boxity -> [Demand] -> SubDemand
mkProd Boxity
Boxed ((Demand -> Demand) -> [Demand] -> [Demand]
forall a b. (a -> b) -> [a] -> [b]
map Demand -> Demand
trimBoxity [Demand]
ds)
go (Call Card
n SubDemand
sd) = Card -> SubDemand -> SubDemand
mkCall Card
n (SubDemand -> SubDemand) -> SubDemand -> SubDemand
forall a b. (a -> b) -> a -> b
$ SubDemand -> SubDemand
go SubDemand
sd
seqDemand :: Demand -> ()
seqDemand :: Demand -> ()
seqDemand Demand
AbsDmd = ()
seqDemand Demand
BotDmd = ()
seqDemand (Card
_ :* SubDemand
sd) = SubDemand -> ()
seqSubDemand SubDemand
sd
seqSubDemand :: SubDemand -> ()
seqSubDemand :: SubDemand -> ()
seqSubDemand (Prod Boxity
_ [Demand]
ds) = [Demand] -> ()
seqDemandList [Demand]
ds
seqSubDemand (Call Card
_ SubDemand
sd) = SubDemand -> ()
seqSubDemand SubDemand
sd
seqSubDemand (Poly Boxity
_ Card
_) = ()
seqDemandList :: [Demand] -> ()
seqDemandList :: [Demand] -> ()
seqDemandList = (Demand -> () -> ()) -> () -> [Demand] -> ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (() -> () -> ()
forall a b. a -> b -> b
seq (() -> () -> ()) -> (Demand -> ()) -> Demand -> () -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Demand -> ()
seqDemand) ()
seqDmdType :: DmdType -> ()
seqDmdType :: DmdType -> ()
seqDmdType (DmdType DmdEnv
env [Demand]
ds) =
DmdEnv -> ()
seqDmdEnv DmdEnv
env () -> () -> ()
forall a b. a -> b -> b
`seq` [Demand] -> ()
seqDemandList [Demand]
ds () -> () -> ()
forall a b. a -> b -> b
`seq` ()
seqDmdEnv :: DmdEnv -> ()
seqDmdEnv :: DmdEnv -> ()
seqDmdEnv (DE VarEnv Demand
fvs Divergence
_) = (Demand -> ()) -> VarEnv Demand -> ()
forall elt key. (elt -> ()) -> UniqFM key elt -> ()
seqEltsUFM Demand -> ()
seqDemand VarEnv Demand
fvs
seqDmdSig :: DmdSig -> ()
seqDmdSig :: DmdSig -> ()
seqDmdSig (DmdSig DmdType
ty) = DmdType -> ()
seqDmdType DmdType
ty
instance Show Card where
show :: Card -> String
show Card
C_00 = String
"C_00"
show Card
C_01 = String
"C_01"
show Card
C_0N = String
"C_0N"
show Card
C_10 = String
"C_10"
show Card
C_11 = String
"C_11"
show Card
C_1N = String
"C_1N"
instance Outputable Card where
ppr :: Card -> SDoc
ppr Card
C_00 = Char -> SDoc
char Char
'A'
ppr Card
C_01 = Char -> SDoc
char Char
'M'
ppr Card
C_0N = Char -> SDoc
char Char
'L'
ppr Card
C_11 = Char -> SDoc
char Char
'1'
ppr Card
C_1N = Char -> SDoc
char Char
'S'
ppr Card
C_10 = Char -> SDoc
char Char
'B'
instance Outputable Demand where
ppr :: Demand -> SDoc
ppr Demand
AbsDmd = Char -> SDoc
char Char
'A'
ppr Demand
BotDmd = Char -> SDoc
char Char
'B'
ppr (Card
C_0N :* Poly Boxity
Boxed Card
C_0N) = Char -> SDoc
char Char
'L'
ppr (Card
C_1N :* Poly Boxity
Boxed Card
C_1N) = Char -> SDoc
char Char
'S'
ppr (Card
n :* SubDemand
sd) = Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
n SDoc -> SDoc -> SDoc
<> SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
sd
instance Outputable SubDemand where
ppr :: SubDemand -> SDoc
ppr (Poly Boxity
b Card
sd) = Boxity -> SDoc
pp_boxity Boxity
b SDoc -> SDoc -> SDoc
<> Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
sd
ppr (Call Card
n SubDemand
sd) = Char -> SDoc
char Char
'C' SDoc -> SDoc -> SDoc
<> Card -> SDoc
forall a. Outputable a => a -> SDoc
ppr Card
n SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SubDemand -> SDoc
forall a. Outputable a => a -> SDoc
ppr SubDemand
sd)
ppr (Prod Boxity
b [Demand]
ds) = Boxity -> SDoc
pp_boxity Boxity
b SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'P' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([Demand] -> SDoc
forall {a}. Outputable a => [a] -> SDoc
fields [Demand]
ds)
where
fields :: [a] -> SDoc
fields [] = SDoc
empty
fields [a
x] = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x
fields (a
x:[a]
xs) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
',' SDoc -> SDoc -> SDoc
<> [a] -> SDoc
fields [a]
xs
pp_boxity :: Boxity -> SDoc
pp_boxity :: Boxity -> SDoc
pp_boxity Boxity
Unboxed = Char -> SDoc
char Char
'!'
pp_boxity Boxity
_ = SDoc
empty
instance Outputable Divergence where
ppr :: Divergence -> SDoc
ppr Divergence
Diverges = Char -> SDoc
char Char
'b'
ppr Divergence
ExnOrDiv = Char -> SDoc
char Char
'x'
ppr Divergence
Dunno = SDoc
empty
instance Outputable DmdEnv where
ppr :: DmdEnv -> SDoc
ppr (DE VarEnv Demand
fvs Divergence
div)
= Divergence -> SDoc
forall a. Outputable a => a -> SDoc
ppr Divergence
div SDoc -> SDoc -> SDoc
<> if [(Unique, Demand)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Unique, Demand)]
fv_elts then SDoc
empty
else SDoc -> SDoc
braces ([SDoc] -> SDoc
fsep (((Unique, Demand) -> SDoc) -> [(Unique, Demand)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unique, Demand) -> SDoc
forall {a} {a}. (Outputable a, Outputable a) => (a, a) -> SDoc
pp_elt [(Unique, Demand)]
fv_elts))
where
pp_elt :: (a, a) -> SDoc
pp_elt (a
uniq, a
dmd) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
uniq SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"->" SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
dmd
fv_elts :: [(Unique, Demand)]
fv_elts = VarEnv Demand -> [(Unique, Demand)]
forall key elt. UniqFM key elt -> [(Unique, elt)]
nonDetUFMToList VarEnv Demand
fvs
instance Outputable DmdType where
ppr :: DmdType -> SDoc
ppr (DmdType DmdEnv
fv [Demand]
ds)
= [SDoc] -> SDoc
hcat ((Demand -> SDoc) -> [Demand] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
angleBrackets (SDoc -> SDoc) -> (Demand -> SDoc) -> Demand -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Demand -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [Demand]
ds) SDoc -> SDoc -> SDoc
<> DmdEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr DmdEnv
fv
instance Outputable DmdSig where
ppr :: DmdSig -> SDoc
ppr (DmdSig DmdType
ty) = DmdType -> SDoc
forall a. Outputable a => a -> SDoc
ppr DmdType
ty
instance Outputable TypeShape where
ppr :: TypeShape -> SDoc
ppr TypeShape
TsUnk = String -> SDoc
text String
"TsUnk"
ppr (TsFun TypeShape
ts) = String -> SDoc
text String
"TsFun" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (TypeShape -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypeShape
ts)
ppr (TsProd [TypeShape]
tss) = SDoc -> SDoc
parens ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (TypeShape -> SDoc) -> [TypeShape] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TypeShape -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TypeShape]
tss)
instance Binary Card where
put_ :: BinHandle -> Card -> IO ()
put_ BinHandle
bh Card
C_00 = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
put_ BinHandle
bh Card
C_01 = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
put_ BinHandle
bh Card
C_0N = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
put_ BinHandle
bh Card
C_11 = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
3
put_ BinHandle
bh Card
C_1N = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
4
put_ BinHandle
bh Card
C_10 = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
5
get :: BinHandle -> IO Card
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> Card -> IO Card
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Card
C_00
Word8
1 -> Card -> IO Card
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Card
C_01
Word8
2 -> Card -> IO Card
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Card
C_0N
Word8
3 -> Card -> IO Card
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Card
C_11
Word8
4 -> Card -> IO Card
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Card
C_1N
Word8
5 -> Card -> IO Card
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Card
C_10
Word8
_ -> String -> SDoc -> IO Card
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Binary:Card" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h :: Int))
instance Binary Demand where
put_ :: BinHandle -> Demand -> IO ()
put_ BinHandle
bh (Card
n :* SubDemand
sd) = BinHandle -> Card -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Card
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> case Card
n of
Card
C_00 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Card
C_10 -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Card
_ -> BinHandle -> SubDemand -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SubDemand
sd
get :: BinHandle -> IO Demand
get BinHandle
bh = BinHandle -> IO Card
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO Card -> (Card -> IO Demand) -> IO Demand
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Card
n -> case Card
n of
Card
C_00 -> Demand -> IO Demand
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Demand
AbsDmd
Card
C_10 -> Demand -> IO Demand
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Demand
BotDmd
Card
_ -> (Card
n HasDebugCallStack => Card -> SubDemand -> Demand
Card -> SubDemand -> Demand
:*) (SubDemand -> Demand) -> IO SubDemand -> IO Demand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO SubDemand
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
instance Binary SubDemand where
put_ :: BinHandle -> SubDemand -> IO ()
put_ BinHandle
bh (Poly Boxity
b Card
sd) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Boxity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Boxity
b IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Card -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Card
sd
put_ BinHandle
bh (Call Card
n SubDemand
sd) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Card -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Card
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> SubDemand -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh SubDemand
sd
put_ BinHandle
bh (Prod Boxity
b [Demand]
ds) = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> Boxity -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Boxity
b IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> [Demand] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Demand]
ds
get :: BinHandle -> IO SubDemand
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> Boxity -> Card -> SubDemand
Poly (Boxity -> Card -> SubDemand)
-> IO Boxity -> IO (Card -> SubDemand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Boxity
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (Card -> SubDemand) -> IO Card -> IO SubDemand
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO Card
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Word8
1 -> Card -> SubDemand -> SubDemand
mkCall (Card -> SubDemand -> SubDemand)
-> IO Card -> IO (SubDemand -> SubDemand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Card
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO (SubDemand -> SubDemand) -> IO SubDemand -> IO SubDemand
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO SubDemand
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Word8
2 -> Boxity -> [Demand] -> SubDemand
Prod (Boxity -> [Demand] -> SubDemand)
-> IO Boxity -> IO ([Demand] -> SubDemand)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Boxity
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO ([Demand] -> SubDemand) -> IO [Demand] -> IO SubDemand
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO [Demand]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Word8
_ -> String -> SDoc -> IO SubDemand
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Binary:SubDemand" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h :: Int))
instance Binary Divergence where
put_ :: BinHandle -> Divergence -> IO ()
put_ BinHandle
bh Divergence
Dunno = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
put_ BinHandle
bh Divergence
ExnOrDiv = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
put_ BinHandle
bh Divergence
Diverges = BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
2
get :: BinHandle -> IO Divergence
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> Divergence -> IO Divergence
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Divergence
Dunno
Word8
1 -> Divergence -> IO Divergence
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Divergence
ExnOrDiv
Word8
2 -> Divergence -> IO Divergence
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Divergence
Diverges
Word8
_ -> String -> SDoc -> IO Divergence
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Binary:Divergence" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
h :: Int))
instance Binary DmdEnv where
put_ :: BinHandle -> DmdEnv -> IO ()
put_ BinHandle
bh (DE VarEnv Demand
_ Divergence
d) = BinHandle -> Divergence -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Divergence
d
get :: BinHandle -> IO DmdEnv
get BinHandle
bh = VarEnv Demand -> Divergence -> DmdEnv
DE VarEnv Demand
forall a. VarEnv a
emptyVarEnv (Divergence -> DmdEnv) -> IO Divergence -> IO DmdEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO Divergence
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
instance Binary DmdType where
put_ :: BinHandle -> DmdType -> IO ()
put_ BinHandle
bh (DmdType DmdEnv
fv [Demand]
ds) = BinHandle -> DmdEnv -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh DmdEnv
fv IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> BinHandle -> [Demand] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh [Demand]
ds
get :: BinHandle -> IO DmdType
get BinHandle
bh = DmdEnv -> [Demand] -> DmdType
DmdType (DmdEnv -> [Demand] -> DmdType)
-> IO DmdEnv -> IO ([Demand] -> DmdType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO DmdEnv
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh IO ([Demand] -> DmdType) -> IO [Demand] -> IO DmdType
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO [Demand]
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
instance Binary DmdSig where
put_ :: BinHandle -> DmdSig -> IO ()
put_ BinHandle
bh (DmdSig DmdType
aa) = BinHandle -> DmdType -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh DmdType
aa
get :: BinHandle -> IO DmdSig
get BinHandle
bh = DmdType -> DmdSig
DmdSig (DmdType -> DmdSig) -> IO DmdType -> IO DmdSig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO DmdType
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh