{-# LANGUAGE BangPatterns #-}
module GHC.Core.Unfold (
Unfolding, UnfoldingGuidance,
UnfoldingOpts (..), defaultUnfoldingOpts,
updateCreationThreshold, updateUseThreshold,
updateFunAppDiscount, updateDictDiscount,
updateVeryAggressive, updateCaseScaling,
updateCaseThreshold, updateReportPrefix,
ArgSummary(..),
couldBeSmallEnoughToInline, inlineBoringOk,
smallEnoughToInline,
callSiteInline, CallCtxt(..),
calcUnfoldingGuidance
) where
import GHC.Prelude
import GHC.Driver.Flags
import GHC.Core
import GHC.Core.Utils
import GHC.Types.Id
import GHC.Core.DataCon
import GHC.Types.Literal
import GHC.Builtin.PrimOps
import GHC.Types.Id.Info
import GHC.Types.RepType ( isZeroBitTy )
import GHC.Types.Basic ( Arity, RecFlag(..) )
import GHC.Core.Type
import GHC.Builtin.Names
import GHC.Data.Bag
import GHC.Utils.Logger
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.ForeignCall
import GHC.Types.Name
import GHC.Types.Tickish
import qualified Data.ByteString as BS
import Data.List (isPrefixOf)
data UnfoldingOpts = UnfoldingOpts
{ UnfoldingOpts -> Int
unfoldingCreationThreshold :: !Int
, UnfoldingOpts -> Int
unfoldingUseThreshold :: !Int
, UnfoldingOpts -> Int
unfoldingFunAppDiscount :: !Int
, UnfoldingOpts -> Int
unfoldingDictDiscount :: !Int
, UnfoldingOpts -> Bool
unfoldingVeryAggressive :: !Bool
, UnfoldingOpts -> Int
unfoldingCaseThreshold :: !Int
, UnfoldingOpts -> Int
unfoldingCaseScaling :: !Int
, UnfoldingOpts -> Maybe String
unfoldingReportPrefix :: !(Maybe String)
}
defaultUnfoldingOpts :: UnfoldingOpts
defaultUnfoldingOpts :: UnfoldingOpts
defaultUnfoldingOpts = UnfoldingOpts
{ unfoldingCreationThreshold :: Int
unfoldingCreationThreshold = Int
750
, unfoldingUseThreshold :: Int
unfoldingUseThreshold = Int
90
, unfoldingFunAppDiscount :: Int
unfoldingFunAppDiscount = Int
60
, unfoldingDictDiscount :: Int
unfoldingDictDiscount = Int
30
, unfoldingVeryAggressive :: Bool
unfoldingVeryAggressive = Bool
False
, unfoldingCaseThreshold :: Int
unfoldingCaseThreshold = Int
2
, unfoldingCaseScaling :: Int
unfoldingCaseScaling = Int
30
, unfoldingReportPrefix :: Maybe String
unfoldingReportPrefix = Maybe String
forall a. Maybe a
Nothing
}
updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
updateCreationThreshold Int
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingCreationThreshold = n }
updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
updateUseThreshold Int
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingUseThreshold = n }
updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
updateFunAppDiscount Int
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingFunAppDiscount = n }
updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts
updateDictDiscount Int
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingDictDiscount = n }
updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts
updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts
updateVeryAggressive Bool
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingVeryAggressive = n }
updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts
updateCaseThreshold Int
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingCaseThreshold = n }
updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts
updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts
updateCaseScaling Int
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingCaseScaling = n }
updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts
updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts
updateReportPrefix Maybe String
n UnfoldingOpts
opts = UnfoldingOpts
opts { unfoldingReportPrefix = n }
inlineBoringOk :: CoreExpr -> Bool
inlineBoringOk :: CoreExpr -> Bool
inlineBoringOk CoreExpr
e
= Int -> CoreExpr -> Bool
go Int
0 CoreExpr
e
where
go :: Int -> CoreExpr -> Bool
go :: Int -> CoreExpr -> Bool
go Int
credit (Lam Id
x CoreExpr
e) | Id -> Bool
isId Id
x = Int -> CoreExpr -> Bool
go (Int
creditInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) CoreExpr
e
| Bool
otherwise = Int -> CoreExpr -> Bool
go Int
credit CoreExpr
e
go Int
credit (App CoreExpr
f (Type {})) = Int -> CoreExpr -> Bool
go Int
credit CoreExpr
f
go Int
credit (App CoreExpr
f CoreExpr
a) | Int
credit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
, CoreExpr -> Bool
exprIsTrivial CoreExpr
a = Int -> CoreExpr -> Bool
go (Int
creditInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) CoreExpr
f
go Int
credit (Tick CoreTickish
_ CoreExpr
e) = Int -> CoreExpr -> Bool
go Int
credit CoreExpr
e
go Int
credit (Cast CoreExpr
e CoercionR
_) = Int -> CoreExpr -> Bool
go Int
credit CoreExpr
e
go Int
credit (Case CoreExpr
scrut Id
_ Type
_ [Alt AltCon
_ [Id]
_ CoreExpr
rhs])
| CoreExpr -> Bool
isUnsafeEqualityProof CoreExpr
scrut = Int -> CoreExpr -> Bool
go Int
credit CoreExpr
rhs
go Int
_ (Var {}) = Bool
boringCxtOk
go Int
_ CoreExpr
_ = Bool
boringCxtNotOk
calcUnfoldingGuidance
:: UnfoldingOpts
-> Bool
-> CoreExpr
-> UnfoldingGuidance
calcUnfoldingGuidance :: UnfoldingOpts -> Bool -> CoreExpr -> UnfoldingGuidance
calcUnfoldingGuidance UnfoldingOpts
opts Bool
is_top_bottoming (Tick CoreTickish
t CoreExpr
expr)
| Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t)
= UnfoldingOpts -> Bool -> CoreExpr -> UnfoldingGuidance
calcUnfoldingGuidance UnfoldingOpts
opts Bool
is_top_bottoming CoreExpr
expr
calcUnfoldingGuidance UnfoldingOpts
opts Bool
is_top_bottoming CoreExpr
expr
= case UnfoldingOpts -> Int -> [Id] -> CoreExpr -> ExprSize
sizeExpr UnfoldingOpts
opts Int
bOMB_OUT_SIZE [Id]
val_bndrs CoreExpr
body of
ExprSize
TooBig -> UnfoldingGuidance
UnfNever
SizeIs Int
size Bag (Id, Int)
cased_bndrs Int
scrut_discount
| CoreExpr -> Int -> Int -> Bool
uncondInline CoreExpr
expr Int
n_val_bndrs Int
size
-> UnfWhen { ug_unsat_ok :: Bool
ug_unsat_ok = Bool
unSaturatedOk
, ug_boring_ok :: Bool
ug_boring_ok = Bool
boringCxtOk
, ug_arity :: Int
ug_arity = Int
n_val_bndrs }
| Bool
is_top_bottoming
-> UnfoldingGuidance
UnfNever
| Bool
otherwise
-> UnfIfGoodArgs { ug_args :: [Int]
ug_args = (Id -> Int) -> [Id] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Bag (Id, Int) -> Id -> Int
mk_discount Bag (Id, Int)
cased_bndrs) [Id]
val_bndrs
, ug_size :: Int
ug_size = Int
size
, ug_res :: Int
ug_res = Int
scrut_discount }
where
([Id]
bndrs, CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
expr
bOMB_OUT_SIZE :: Int
bOMB_OUT_SIZE = UnfoldingOpts -> Int
unfoldingCreationThreshold UnfoldingOpts
opts
val_bndrs :: [Id]
val_bndrs = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isId [Id]
bndrs
n_val_bndrs :: Int
n_val_bndrs = [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
val_bndrs
mk_discount :: Bag (Id,Int) -> Id -> Int
mk_discount :: Bag (Id, Int) -> Id -> Int
mk_discount Bag (Id, Int)
cbs Id
bndr = (Int -> (Id, Int) -> Int) -> Int -> Bag (Id, Int) -> Int
forall b a. (b -> a -> b) -> b -> Bag a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> (Id, Int) -> Int
combine Int
0 Bag (Id, Int)
cbs
where
combine :: Int -> (Id, Int) -> Int
combine Int
acc (Id
bndr', Int
disc)
| Id
bndr Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
bndr' = Int
acc Int -> Int -> Int
`plus_disc` Int
disc
| Bool
otherwise = Int
acc
plus_disc :: Int -> Int -> Int
plus_disc :: Int -> Int -> Int
plus_disc | Type -> Bool
isFunTy (Id -> Type
idType Id
bndr) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max
| Bool
otherwise = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
uncondInline :: CoreExpr -> Arity -> Int -> Bool
uncondInline :: CoreExpr -> Int -> Int -> Bool
uncondInline CoreExpr
rhs Int
arity Int
size
| Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = CoreExpr -> Bool
exprIsTrivial CoreExpr
rhs
sizeExpr :: UnfoldingOpts
-> Int
-> [Id]
-> CoreExpr
-> ExprSize
sizeExpr :: UnfoldingOpts -> Int -> [Id] -> CoreExpr -> ExprSize
sizeExpr UnfoldingOpts
opts !Int
bOMB_OUT_SIZE [Id]
top_args CoreExpr
expr
= CoreExpr -> ExprSize
size_up CoreExpr
expr
where
size_up :: CoreExpr -> ExprSize
size_up (Cast CoreExpr
e CoercionR
_) = CoreExpr -> ExprSize
size_up CoreExpr
e
size_up (Tick CoreTickish
_ CoreExpr
e) = CoreExpr -> ExprSize
size_up CoreExpr
e
size_up (Type Type
_) = ExprSize
sizeZero
size_up (Coercion CoercionR
_) = ExprSize
sizeZero
size_up (Lit Literal
lit) = Int -> ExprSize
sizeN (Literal -> Int
litSize Literal
lit)
size_up (Var Id
f) | Id -> Bool
isZeroBitId Id
f = ExprSize
sizeZero
| Bool
otherwise = Id -> [CoreExpr] -> Int -> ExprSize
size_up_call Id
f [] Int
0
size_up (App CoreExpr
fun CoreExpr
arg)
| CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
arg = CoreExpr -> ExprSize
size_up CoreExpr
fun
| Bool
otherwise = CoreExpr -> ExprSize
size_up CoreExpr
arg ExprSize -> ExprSize -> ExprSize
`addSizeNSD`
CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app CoreExpr
fun [CoreExpr
arg] (if CoreExpr -> Bool
forall b. Expr b -> Bool
isZeroBitExpr CoreExpr
arg then Int
1 else Int
0)
size_up (Lam Id
b CoreExpr
e)
| Id -> Bool
isId Id
b Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isZeroBitId Id
b) = UnfoldingOpts -> ExprSize -> ExprSize
lamScrutDiscount UnfoldingOpts
opts (CoreExpr -> ExprSize
size_up CoreExpr
e ExprSize -> Int -> ExprSize
`addSizeN` Int
10)
| Bool
otherwise = CoreExpr -> ExprSize
size_up CoreExpr
e
size_up (Let (NonRec Id
binder CoreExpr
rhs) CoreExpr
body)
= (Id, CoreExpr) -> ExprSize
size_up_rhs (Id
binder, CoreExpr
rhs) ExprSize -> ExprSize -> ExprSize
`addSizeNSD`
CoreExpr -> ExprSize
size_up CoreExpr
body ExprSize -> Int -> ExprSize
`addSizeN`
Id -> Int
forall {a}. Num a => Id -> a
size_up_alloc Id
binder
size_up (Let (Rec [(Id, CoreExpr)]
pairs) CoreExpr
body)
= ((Id, CoreExpr) -> ExprSize -> ExprSize)
-> ExprSize -> [(Id, CoreExpr)] -> ExprSize
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ExprSize -> ExprSize -> ExprSize
addSizeNSD (ExprSize -> ExprSize -> ExprSize)
-> ((Id, CoreExpr) -> ExprSize)
-> (Id, CoreExpr)
-> ExprSize
-> ExprSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> ExprSize
size_up_rhs)
(CoreExpr -> ExprSize
size_up CoreExpr
body ExprSize -> Int -> ExprSize
`addSizeN` [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((Id, CoreExpr) -> Int) -> [(Id, CoreExpr)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Int
forall {a}. Num a => Id -> a
size_up_alloc (Id -> Int) -> ((Id, CoreExpr) -> Id) -> (Id, CoreExpr) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst) [(Id, CoreExpr)]
pairs))
[(Id, CoreExpr)]
pairs
size_up (Case CoreExpr
e Id
_ Type
_ [Alt Id]
alts)
| [Alt Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Alt Id]
alts
= CoreExpr -> ExprSize
size_up CoreExpr
e
size_up (Case CoreExpr
e Id
_ Type
_ [Alt Id]
alts)
| Just Id
v <- CoreExpr -> Maybe Id
is_top_arg CoreExpr
e
= let
alt_sizes :: [ExprSize]
alt_sizes = (Alt Id -> ExprSize) -> [Alt Id] -> [ExprSize]
forall a b. (a -> b) -> [a] -> [b]
map Alt Id -> ExprSize
size_up_alt [Alt Id]
alts
alts_size :: ExprSize -> ExprSize -> ExprSize
alts_size (SizeIs Int
tot Bag (Id, Int)
tot_disc Int
tot_scrut)
(SizeIs Int
max Bag (Id, Int)
_ Int
_)
= Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
tot ((Id, Int) -> Bag (Id, Int)
forall a. a -> Bag a
unitBag (Id
v, Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
max)
Bag (Id, Int) -> Bag (Id, Int) -> Bag (Id, Int)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (Id, Int)
tot_disc) Int
tot_scrut
alts_size ExprSize
tot_size ExprSize
_ = ExprSize
tot_size
in
ExprSize -> ExprSize -> ExprSize
alts_size ((ExprSize -> ExprSize -> ExprSize) -> [ExprSize] -> ExprSize
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ExprSize -> ExprSize -> ExprSize
addAltSize [ExprSize]
alt_sizes)
((ExprSize -> ExprSize -> ExprSize) -> [ExprSize] -> ExprSize
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ExprSize -> ExprSize -> ExprSize
maxSize [ExprSize]
alt_sizes)
where
is_top_arg :: CoreExpr -> Maybe Id
is_top_arg (Var Id
v) | Id
v Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
top_args = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
v
is_top_arg (Cast CoreExpr
e CoercionR
_) = CoreExpr -> Maybe Id
is_top_arg CoreExpr
e
is_top_arg CoreExpr
_ = Maybe Id
forall a. Maybe a
Nothing
size_up (Case CoreExpr
e Id
_ Type
_ [Alt Id]
alts) = CoreExpr -> ExprSize
size_up CoreExpr
e ExprSize -> ExprSize -> ExprSize
`addSizeNSD`
(Alt Id -> ExprSize -> ExprSize)
-> ExprSize -> [Alt Id] -> ExprSize
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ExprSize -> ExprSize -> ExprSize
addAltSize (ExprSize -> ExprSize -> ExprSize)
-> (Alt Id -> ExprSize) -> Alt Id -> ExprSize -> ExprSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alt Id -> ExprSize
size_up_alt) ExprSize
case_size [Alt Id]
alts
where
case_size :: ExprSize
case_size
| CoreExpr -> Bool
forall b. Expr b -> Bool
is_inline_scrut CoreExpr
e, [Alt Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthAtMost [Alt Id]
alts Int
1 = Int -> ExprSize
sizeN (-Int
10)
| Bool
otherwise = ExprSize
sizeZero
is_inline_scrut :: Expr b -> Bool
is_inline_scrut (Var Id
v) =
(() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
v)
is_inline_scrut Expr b
scrut
| (Var Id
f, [Expr b]
_) <- Expr b -> (Expr b, [Expr b])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr b
scrut
= case Id -> IdDetails
idDetails Id
f of
FCallId ForeignCall
fc -> Bool -> Bool
not (ForeignCall -> Bool
isSafeForeignCall ForeignCall
fc)
PrimOpId PrimOp
op Bool
_ -> Bool -> Bool
not (PrimOp -> Bool
primOpOutOfLine PrimOp
op)
IdDetails
_other -> Bool
False
| Bool
otherwise
= Bool
False
size_up_rhs :: (Id, CoreExpr) -> ExprSize
size_up_rhs (Id
bndr, CoreExpr
rhs)
| Just Int
join_arity <- Id -> Maybe Int
isJoinId_maybe Id
bndr
, ([Id]
_bndrs, CoreExpr
body) <- Int -> CoreExpr -> ([Id], CoreExpr)
forall b. Int -> Expr b -> ([b], Expr b)
collectNBinders Int
join_arity CoreExpr
rhs
= CoreExpr -> ExprSize
size_up CoreExpr
body
| Bool
otherwise
= CoreExpr -> ExprSize
size_up CoreExpr
rhs
size_up_app :: CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app (App CoreExpr
fun CoreExpr
arg) [CoreExpr]
args Int
voids
| CoreExpr -> Bool
forall b. Expr b -> Bool
isTyCoArg CoreExpr
arg = CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app CoreExpr
fun [CoreExpr]
args Int
voids
| CoreExpr -> Bool
forall b. Expr b -> Bool
isZeroBitExpr CoreExpr
arg = CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app CoreExpr
fun (CoreExpr
argCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args) (Int
voids Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = CoreExpr -> ExprSize
size_up CoreExpr
arg ExprSize -> ExprSize -> ExprSize
`addSizeNSD`
CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app CoreExpr
fun (CoreExpr
argCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args) Int
voids
size_up_app (Var Id
fun) [CoreExpr]
args Int
voids = Id -> [CoreExpr] -> Int -> ExprSize
size_up_call Id
fun [CoreExpr]
args Int
voids
size_up_app (Tick CoreTickish
_ CoreExpr
expr) [CoreExpr]
args Int
voids = CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app CoreExpr
expr [CoreExpr]
args Int
voids
size_up_app (Cast CoreExpr
expr CoercionR
_) [CoreExpr]
args Int
voids = CoreExpr -> [CoreExpr] -> Int -> ExprSize
size_up_app CoreExpr
expr [CoreExpr]
args Int
voids
size_up_app CoreExpr
other [CoreExpr]
args Int
voids = CoreExpr -> ExprSize
size_up CoreExpr
other ExprSize -> Int -> ExprSize
`addSizeN`
Int -> Int -> Int
callSize ([CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args) Int
voids
size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize
size_up_call Id
fun [CoreExpr]
val_args Int
voids
= case Id -> IdDetails
idDetails Id
fun of
FCallId ForeignCall
_ -> Int -> ExprSize
sizeN (Int -> Int -> Int
callSize ([CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
val_args) Int
voids)
DataConWorkId DataCon
dc -> DataCon -> Int -> ExprSize
conSize DataCon
dc ([CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
val_args)
PrimOpId PrimOp
op Bool
_ -> PrimOp -> Int -> ExprSize
primOpSize PrimOp
op ([CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
val_args)
ClassOpId Class
_ -> UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize
classOpSize UnfoldingOpts
opts [Id]
top_args [CoreExpr]
val_args
IdDetails
_ -> UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
funSize UnfoldingOpts
opts [Id]
top_args Id
fun ([CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
val_args) Int
voids
size_up_alt :: Alt Id -> ExprSize
size_up_alt (Alt AltCon
_con [Id]
_bndrs CoreExpr
rhs) = CoreExpr -> ExprSize
size_up CoreExpr
rhs ExprSize -> Int -> ExprSize
`addSizeN` Int
10
size_up_alloc :: Id -> a
size_up_alloc Id
bndr
| Id -> Bool
isTyVar Id
bndr
Bool -> Bool -> Bool
|| Id -> Bool
isJoinId Id
bndr
Bool -> Bool -> Bool
|| Bool -> Bool
not (Type -> Bool
isBoxedType (Id -> Type
idType Id
bndr))
= a
0
| Bool
otherwise
= a
10
addSizeN :: ExprSize -> Int -> ExprSize
addSizeN ExprSize
TooBig Int
_ = ExprSize
TooBig
addSizeN (SizeIs Int
n Bag (Id, Int)
xs Int
d) Int
m = Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
mkSizeIs Int
bOMB_OUT_SIZE (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m) Bag (Id, Int)
xs Int
d
addAltSize :: ExprSize -> ExprSize -> ExprSize
addAltSize ExprSize
TooBig ExprSize
_ = ExprSize
TooBig
addAltSize ExprSize
_ ExprSize
TooBig = ExprSize
TooBig
addAltSize (SizeIs Int
n1 Bag (Id, Int)
xs Int
d1) (SizeIs Int
n2 Bag (Id, Int)
ys Int
d2)
= Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
mkSizeIs Int
bOMB_OUT_SIZE (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2)
(Bag (Id, Int)
xs Bag (Id, Int) -> Bag (Id, Int) -> Bag (Id, Int)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (Id, Int)
ys)
(Int
d1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d2)
addSizeNSD :: ExprSize -> ExprSize -> ExprSize
addSizeNSD ExprSize
TooBig ExprSize
_ = ExprSize
TooBig
addSizeNSD ExprSize
_ ExprSize
TooBig = ExprSize
TooBig
addSizeNSD (SizeIs Int
n1 Bag (Id, Int)
xs Int
_) (SizeIs Int
n2 Bag (Id, Int)
ys Int
d2)
= Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
mkSizeIs Int
bOMB_OUT_SIZE (Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2)
(Bag (Id, Int)
xs Bag (Id, Int) -> Bag (Id, Int) -> Bag (Id, Int)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (Id, Int)
ys)
Int
d2
isZeroBitId :: Id -> Bool
isZeroBitId Id
id = Bool -> Bool
not (Id -> Bool
isJoinId Id
id) Bool -> Bool -> Bool
&& (() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Id -> Type
idType Id
id)
isZeroBitExpr :: Expr b -> Bool
isZeroBitExpr (Var Id
id) = Id -> Bool
isZeroBitId Id
id
isZeroBitExpr (Tick CoreTickish
_ Expr b
e) = Expr b -> Bool
isZeroBitExpr Expr b
e
isZeroBitExpr Expr b
_ = Bool
False
litSize :: Literal -> Int
litSize :: Literal -> Int
litSize (LitNumber LitNumType
LitNumBigNat Integer
_) = Int
100
litSize (LitString ByteString
str) = Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ((ByteString -> Int
BS.length ByteString
str Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4)
litSize Literal
_other = Int
0
classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize
classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize
classOpSize UnfoldingOpts
_ [Id]
_ []
= ExprSize
sizeZero
classOpSize UnfoldingOpts
opts [Id]
top_args (CoreExpr
arg1 : [CoreExpr]
other_args)
= Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
size Bag (Id, Int)
arg_discount Int
0
where
size :: Int
size = Int
20 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [CoreExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
other_args)
arg_discount :: Bag (Id, Int)
arg_discount = case CoreExpr
arg1 of
Var Id
dict | Id
dict Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
top_args
-> (Id, Int) -> Bag (Id, Int)
forall a. a -> Bag a
unitBag (Id
dict, UnfoldingOpts -> Int
unfoldingDictDiscount UnfoldingOpts
opts)
CoreExpr
_other -> Bag (Id, Int)
forall a. Bag a
emptyBag
callSize
:: Int
-> Int
-> Int
callSize :: Int -> Int -> Int
callSize Int
n_val_args Int
voids = Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
voids)
jumpSize
:: Int
-> Int
-> Int
jumpSize :: Int -> Int -> Int
jumpSize Int
n_val_args Int
voids = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
voids)
funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize
funSize UnfoldingOpts
opts [Id]
top_args Id
fun Int
n_val_args Int
voids
| Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
buildIdKey = ExprSize
buildSize
| Id
fun Id -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
augmentIdKey = ExprSize
augmentSize
| Bool
otherwise = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
size Bag (Id, Int)
arg_discount Int
res_discount
where
some_val_args :: Bool
some_val_args = Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
is_join :: Bool
is_join = Id -> Bool
isJoinId Id
fun
size :: Int
size | Bool
is_join = Int -> Int -> Int
jumpSize Int
n_val_args Int
voids
| Bool -> Bool
not Bool
some_val_args = Int
0
| Bool
otherwise = Int -> Int -> Int
callSize Int
n_val_args Int
voids
arg_discount :: Bag (Id, Int)
arg_discount | Bool
some_val_args Bool -> Bool -> Bool
&& Id
fun Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
top_args
= (Id, Int) -> Bag (Id, Int)
forall a. a -> Bag a
unitBag (Id
fun, UnfoldingOpts -> Int
unfoldingFunAppDiscount UnfoldingOpts
opts)
| Bool
otherwise = Bag (Id, Int)
forall a. Bag a
emptyBag
res_discount :: Int
res_discount | Id -> Int
idArity Id
fun Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n_val_args = UnfoldingOpts -> Int
unfoldingFunAppDiscount UnfoldingOpts
opts
| Bool
otherwise = Int
0
conSize :: DataCon -> Int -> ExprSize
conSize :: DataCon -> Int -> ExprSize
conSize DataCon
dc Int
n_val_args
| Int
n_val_args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
0 Bag (Id, Int)
forall a. Bag a
emptyBag Int
10
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
dc = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
0 Bag (Id, Int)
forall a. Bag a
emptyBag Int
10
| Bool
otherwise = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
10 Bag (Id, Int)
forall a. Bag a
emptyBag Int
10
primOpSize :: PrimOp -> Int -> ExprSize
primOpSize :: PrimOp -> Int -> ExprSize
primOpSize PrimOp
op Int
n_val_args
= if PrimOp -> Bool
primOpOutOfLine PrimOp
op
then Int -> ExprSize
sizeN (Int
op_size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_val_args)
else Int -> ExprSize
sizeN Int
op_size
where
op_size :: Int
op_size = PrimOp -> Int
primOpCodeSize PrimOp
op
buildSize :: ExprSize
buildSize :: ExprSize
buildSize = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
0 Bag (Id, Int)
forall a. Bag a
emptyBag Int
40
augmentSize :: ExprSize
augmentSize :: ExprSize
augmentSize = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
0 Bag (Id, Int)
forall a. Bag a
emptyBag Int
40
lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize
lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize
lamScrutDiscount UnfoldingOpts
opts (SizeIs Int
n Bag (Id, Int)
vs Int
_) = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
n Bag (Id, Int)
vs (UnfoldingOpts -> Int
unfoldingFunAppDiscount UnfoldingOpts
opts)
lamScrutDiscount UnfoldingOpts
_ ExprSize
TooBig = ExprSize
TooBig
data ExprSize
= TooBig
| SizeIs { ExprSize -> Int
_es_size_is :: {-# UNPACK #-} !Int
, ExprSize -> Bag (Id, Int)
_es_args :: !(Bag (Id,Int))
, ExprSize -> Int
_es_discount :: {-# UNPACK #-} !Int
}
instance Outputable ExprSize where
ppr :: ExprSize -> SDoc
ppr ExprSize
TooBig = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TooBig"
ppr (SizeIs Int
a Bag (Id, Int)
_ Int
c) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
a SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
c)
mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize
mkSizeIs Int
max Int
n Bag (Id, Int)
xs Int
d | (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max = ExprSize
TooBig
| Bool
otherwise = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
n Bag (Id, Int)
xs Int
d
maxSize :: ExprSize -> ExprSize -> ExprSize
maxSize :: ExprSize -> ExprSize -> ExprSize
maxSize ExprSize
TooBig ExprSize
_ = ExprSize
TooBig
maxSize ExprSize
_ ExprSize
TooBig = ExprSize
TooBig
maxSize s1 :: ExprSize
s1@(SizeIs Int
n1 Bag (Id, Int)
_ Int
_) s2 :: ExprSize
s2@(SizeIs Int
n2 Bag (Id, Int)
_ Int
_) | Int
n1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n2 = ExprSize
s1
| Bool
otherwise = ExprSize
s2
sizeZero :: ExprSize
sizeN :: Int -> ExprSize
sizeZero :: ExprSize
sizeZero = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
0 Bag (Id, Int)
forall a. Bag a
emptyBag Int
0
sizeN :: Int -> ExprSize
sizeN Int
n = Int -> Bag (Id, Int) -> Int -> ExprSize
SizeIs Int
n Bag (Id, Int)
forall a. Bag a
emptyBag Int
0
couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool
couldBeSmallEnoughToInline UnfoldingOpts
opts Int
threshold CoreExpr
rhs
= case UnfoldingOpts -> Int -> [Id] -> CoreExpr -> ExprSize
sizeExpr UnfoldingOpts
opts Int
threshold [] CoreExpr
body of
ExprSize
TooBig -> Bool
False
ExprSize
_ -> Bool
True
where
([Id]
_, CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
rhs
smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool
smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool
smallEnoughToInline UnfoldingOpts
opts (CoreUnfolding {uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance})
= case UnfoldingGuidance
guidance of
UnfIfGoodArgs {ug_size :: UnfoldingGuidance -> Int
ug_size = Int
size} -> Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= UnfoldingOpts -> Int
unfoldingUseThreshold UnfoldingOpts
opts
UnfWhen {} -> Bool
True
UnfoldingGuidance
UnfNever -> Bool
False
smallEnoughToInline UnfoldingOpts
_ Unfolding
_
= Bool
False
data ArgSummary = TrivArg
| NonTrivArg
| ValueArg
instance Outputable ArgSummary where
ppr :: ArgSummary -> SDoc
ppr ArgSummary
TrivArg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TrivArg"
ppr ArgSummary
NonTrivArg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NonTrivArg"
ppr ArgSummary
ValueArg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ValueArg"
nonTriv :: ArgSummary -> Bool
nonTriv :: ArgSummary -> Bool
nonTriv ArgSummary
TrivArg = Bool
False
nonTriv ArgSummary
_ = Bool
True
data CallCtxt
= BoringCtxt
| RhsCtxt RecFlag
| DiscArgCtxt
| RuleArgCtxt
| ValAppCtxt
| CaseCtxt
instance Outputable CallCtxt where
ppr :: CallCtxt -> SDoc
ppr CallCtxt
CaseCtxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CaseCtxt"
ppr CallCtxt
ValAppCtxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ValAppCtxt"
ppr CallCtxt
BoringCtxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"BoringCtxt"
ppr (RhsCtxt RecFlag
ir)= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RhsCtxt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (RecFlag -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecFlag
ir)
ppr CallCtxt
DiscArgCtxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DiscArgCtxt"
ppr CallCtxt
RuleArgCtxt = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"RuleArgCtxt"
callSiteInline :: Logger
-> UnfoldingOpts
-> Int
-> Id
-> Bool
-> Bool
-> [ArgSummary]
-> CallCtxt
-> Maybe CoreExpr
callSiteInline :: Logger
-> UnfoldingOpts
-> Int
-> Id
-> Bool
-> Bool
-> [ArgSummary]
-> CallCtxt
-> Maybe CoreExpr
callSiteInline Logger
logger UnfoldingOpts
opts !Int
case_depth Id
id Bool
active_unfolding Bool
lone_variable [ArgSummary]
arg_infos CallCtxt
cont_info
= case IdUnfoldingFun
idUnfolding Id
id of
CoreUnfolding { uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
unf_template
, uf_cache :: Unfolding -> UnfoldingCache
uf_cache = UnfoldingCache
unf_cache
, uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance }
| Bool
active_unfolding -> Logger
-> UnfoldingOpts
-> Int
-> Id
-> Bool
-> [ArgSummary]
-> CallCtxt
-> CoreExpr
-> UnfoldingCache
-> UnfoldingGuidance
-> Maybe CoreExpr
tryUnfolding Logger
logger UnfoldingOpts
opts Int
case_depth Id
id Bool
lone_variable
[ArgSummary]
arg_infos CallCtxt
cont_info CoreExpr
unf_template
UnfoldingCache
unf_cache UnfoldingGuidance
guidance
| Bool
otherwise -> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
"Inactive unfolding:" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id) Maybe CoreExpr
forall a. Maybe a
Nothing
Unfolding
NoUnfolding -> Maybe CoreExpr
forall a. Maybe a
Nothing
Unfolding
BootUnfolding -> Maybe CoreExpr
forall a. Maybe a
Nothing
OtherCon {} -> Maybe CoreExpr
forall a. Maybe a
Nothing
DFunUnfolding {} -> Maybe CoreExpr
forall a. Maybe a
Nothing
traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline :: forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
inline_id String
str SDoc
doc a
result
| Bool
enable = Logger -> String -> SDoc -> a -> a
forall a. Logger -> String -> SDoc -> a -> a
logTraceMsg Logger
logger String
str SDoc
doc a
result
| Bool
otherwise = a
result
where
enable :: Bool
enable
| Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_verbose_inlinings
= Bool
True
| Just String
prefix <- UnfoldingOpts -> Maybe String
unfoldingReportPrefix UnfoldingOpts
opts
= String
prefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` OccName -> String
occNameString (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
inline_id)
| Bool
otherwise
= Bool
False
{-# INLINE traceInline #-}
tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt
-> CoreExpr -> UnfoldingCache -> UnfoldingGuidance
-> Maybe CoreExpr
tryUnfolding :: Logger
-> UnfoldingOpts
-> Int
-> Id
-> Bool
-> [ArgSummary]
-> CallCtxt
-> CoreExpr
-> UnfoldingCache
-> UnfoldingGuidance
-> Maybe CoreExpr
tryUnfolding Logger
logger UnfoldingOpts
opts !Int
case_depth Id
id Bool
lone_variable [ArgSummary]
arg_infos
CallCtxt
cont_info CoreExpr
unf_template UnfoldingCache
unf_cache UnfoldingGuidance
guidance
= case UnfoldingGuidance
guidance of
UnfoldingGuidance
UnfNever -> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
str (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnfNever") Maybe CoreExpr
forall a. Maybe a
Nothing
UnfWhen { ug_arity :: UnfoldingGuidance -> Int
ug_arity = Int
uf_arity, ug_unsat_ok :: UnfoldingGuidance -> Bool
ug_unsat_ok = Bool
unsat_ok, ug_boring_ok :: UnfoldingGuidance -> Bool
ug_boring_ok = Bool
boring_ok }
| Bool
enough_args Bool -> Bool -> Bool
&& (Bool
boring_ok Bool -> Bool -> Bool
|| Bool
some_benefit Bool -> Bool -> Bool
|| UnfoldingOpts -> Bool
unfoldingVeryAggressive UnfoldingOpts
opts)
-> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
str (Bool -> SDoc -> Bool -> SDoc
mk_doc Bool
some_benefit SDoc
forall doc. IsOutput doc => doc
empty Bool
True) (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
unf_template)
| Bool
otherwise
-> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
str (Bool -> SDoc -> Bool -> SDoc
mk_doc Bool
some_benefit SDoc
forall doc. IsOutput doc => doc
empty Bool
False) Maybe CoreExpr
forall a. Maybe a
Nothing
where
some_benefit :: Bool
some_benefit = Int -> Bool
calc_some_benefit Int
uf_arity
enough_args :: Bool
enough_args = (Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
uf_arity) Bool -> Bool -> Bool
|| (Bool
unsat_ok Bool -> Bool -> Bool
&& Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)
UnfIfGoodArgs { ug_args :: UnfoldingGuidance -> [Int]
ug_args = [Int]
arg_discounts, ug_res :: UnfoldingGuidance -> Int
ug_res = Int
res_discount, ug_size :: UnfoldingGuidance -> Int
ug_size = Int
size }
| UnfoldingOpts -> Bool
unfoldingVeryAggressive UnfoldingOpts
opts
-> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
str (Bool -> SDoc -> Bool -> SDoc
mk_doc Bool
some_benefit SDoc
extra_doc Bool
True) (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
unf_template)
| Bool
is_wf Bool -> Bool -> Bool
&& Bool
some_benefit Bool -> Bool -> Bool
&& Bool
small_enough
-> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
str (Bool -> SDoc -> Bool -> SDoc
mk_doc Bool
some_benefit SDoc
extra_doc Bool
True) (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
unf_template)
| Bool
otherwise
-> Logger
-> UnfoldingOpts
-> Id
-> String
-> SDoc
-> Maybe CoreExpr
-> Maybe CoreExpr
forall a. Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a
traceInline Logger
logger UnfoldingOpts
opts Id
id String
str (Bool -> SDoc -> Bool -> SDoc
mk_doc Bool
some_benefit SDoc
extra_doc Bool
False) Maybe CoreExpr
forall a. Maybe a
Nothing
where
some_benefit :: Bool
some_benefit = Int -> Bool
calc_some_benefit ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
arg_discounts)
depth_treshold :: Int
depth_treshold = UnfoldingOpts -> Int
unfoldingCaseThreshold UnfoldingOpts
opts
depth_scaling :: Int
depth_scaling = UnfoldingOpts -> Int
unfoldingCaseScaling UnfoldingOpts
opts
depth_penalty :: Int
depth_penalty | Int
case_depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
depth_treshold = Int
0
| Bool
otherwise = (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
case_depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
depth_treshold)) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
depth_scaling
adjusted_size :: Int
adjusted_size = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
depth_penalty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
discount
small_enough :: Bool
small_enough = Int
adjusted_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= UnfoldingOpts -> Int
unfoldingUseThreshold UnfoldingOpts
opts
discount :: Int
discount = [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int
computeDiscount [Int]
arg_discounts Int
res_discount [ArgSummary]
arg_infos CallCtxt
cont_info
extra_doc :: SDoc
extra_doc = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case depth =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
case_depth
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"depth based penalty =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
depth_penalty
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"discounted size =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
adjusted_size ]
where
UnfoldingCache{ uf_is_work_free :: UnfoldingCache -> Bool
uf_is_work_free = Bool
is_wf, uf_expandable :: UnfoldingCache -> Bool
uf_expandable = Bool
is_exp } = UnfoldingCache
unf_cache
mk_doc :: Bool -> SDoc -> Bool -> SDoc
mk_doc Bool
some_benefit SDoc
extra_doc Bool
yes_or_no
= [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"arg infos" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ArgSummary] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ArgSummary]
arg_infos
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"interesting continuation" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CallCtxt -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallCtxt
cont_info
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"some_benefit" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
some_benefit
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is exp:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
is_exp
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is work-free:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
is_wf
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"guidance" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnfoldingGuidance -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnfoldingGuidance
guidance
, SDoc
extra_doc
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ANSWER =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> if Bool
yes_or_no then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"YES" else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NO"]
ctx :: SDocContext
ctx = LogFlags -> SDocContext
log_default_dump_context (Logger -> LogFlags
logFlags Logger
logger)
str :: String
str = String
"Considering inlining: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id)
n_val_args :: Int
n_val_args = [ArgSummary] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ArgSummary]
arg_infos
calc_some_benefit :: Arity -> Bool
calc_some_benefit :: Int -> Bool
calc_some_benefit Int
uf_arity
| Bool -> Bool
not Bool
saturated = Bool
interesting_args
| Bool
otherwise = Bool
interesting_args
Bool -> Bool -> Bool
|| Bool
interesting_call
where
saturated :: Bool
saturated = Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
uf_arity
over_saturated :: Bool
over_saturated = Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
uf_arity
interesting_args :: Bool
interesting_args = (ArgSummary -> Bool) -> [ArgSummary] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ArgSummary -> Bool
nonTriv [ArgSummary]
arg_infos
interesting_call :: Bool
interesting_call
| Bool
over_saturated
= Bool
True
| Bool
otherwise
= case CallCtxt
cont_info of
CallCtxt
CaseCtxt -> Bool -> Bool
not (Bool
lone_variable Bool -> Bool -> Bool
&& Bool
is_exp)
CallCtxt
ValAppCtxt -> Bool
True
CallCtxt
RuleArgCtxt -> Int
uf_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
CallCtxt
DiscArgCtxt -> Int
uf_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
RhsCtxt RecFlag
NonRecursive
-> Int
uf_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
CallCtxt
_other -> Bool
False
computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt
-> Int
computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt -> Int
computeDiscount [Int]
arg_discounts Int
res_discount [ArgSummary]
arg_infos CallCtxt
cont_info
= Int
10
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
actual_arg_discounts
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
total_arg_discount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
res_discount'
where
actual_arg_discounts :: [Int]
actual_arg_discounts = (Int -> ArgSummary -> Int) -> [Int] -> [ArgSummary] -> [Int]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> ArgSummary -> Int
forall {a}. Num a => a -> ArgSummary -> a
mk_arg_discount [Int]
arg_discounts [ArgSummary]
arg_infos
total_arg_discount :: Int
total_arg_discount = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
actual_arg_discounts
mk_arg_discount :: a -> ArgSummary -> a
mk_arg_discount a
_ ArgSummary
TrivArg = a
0
mk_arg_discount a
_ ArgSummary
NonTrivArg = a
10
mk_arg_discount a
discount ArgSummary
ValueArg = a
discount
res_discount' :: Int
res_discount'
| Ordering
LT <- [Int]
arg_discounts [Int] -> [ArgSummary] -> Ordering
forall a b. [a] -> [b] -> Ordering
`compareLength` [ArgSummary]
arg_infos
= Int
res_discount
| Bool
otherwise
= case CallCtxt
cont_info of
CallCtxt
BoringCtxt -> Int
0
CallCtxt
CaseCtxt -> Int
res_discount
CallCtxt
ValAppCtxt -> Int
res_discount
CallCtxt
_ -> Int
40 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
res_discount