{-# LANGUAGE CPP #-}
module SAT ( doStaticArgs ) where
import GhcPrelude
import Var
import CoreSyn
import CoreUtils
import Type
import Coercion
import Id
import Name
import VarEnv
import UniqSupply
import Util
import UniqFM
import VarSet
import Unique
import UniqSet
import Outputable
import Data.List (mapAccumL)
import FastString
#include "HsVersions.h"
doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
doStaticArgs UniqSupply
us CoreProgram
binds = (UniqSupply, CoreProgram) -> CoreProgram
forall a b. (a, b) -> b
snd ((UniqSupply, CoreProgram) -> CoreProgram)
-> (UniqSupply, CoreProgram) -> CoreProgram
forall a b. (a -> b) -> a -> b
$ (UniqSupply -> CoreBind -> (UniqSupply, CoreBind))
-> UniqSupply -> CoreProgram -> (UniqSupply, CoreProgram)
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL UniqSupply -> CoreBind -> (UniqSupply, CoreBind)
sat_bind_threaded_us UniqSupply
us CoreProgram
binds
where
sat_bind_threaded_us :: UniqSupply -> CoreBind -> (UniqSupply, CoreBind)
sat_bind_threaded_us UniqSupply
us CoreBind
bind =
let (UniqSupply
us1, UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply UniqSupply
us
in (UniqSupply
us1, (CoreBind, IdSATInfo) -> CoreBind
forall a b. (a, b) -> a
fst ((CoreBind, IdSATInfo) -> CoreBind)
-> (CoreBind, IdSATInfo) -> CoreBind
forall a b. (a -> b) -> a -> b
$ UniqSupply -> SatM (CoreBind, IdSATInfo) -> (CoreBind, IdSATInfo)
forall a. UniqSupply -> SatM a -> a
runSAT UniqSupply
us2 (CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
satBind CoreBind
bind IdSet
forall a. UniqSet a
emptyUniqSet))
satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
satBind (NonRec CoreBndr
binder Expr CoreBndr
expr) IdSet
interesting_ids = do
(Expr CoreBndr
expr', IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
expr IdSet
interesting_ids
(CoreBind, IdSATInfo) -> SatM (CoreBind, IdSATInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
binder Expr CoreBndr
expr', Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Maybe IdAppInfo
expr_app IdSATInfo
sat_info_expr)
satBind (Rec [(CoreBndr
binder, Expr CoreBndr
rhs)]) IdSet
interesting_ids = do
let interesting_ids' :: IdSet
interesting_ids' = IdSet
interesting_ids IdSet -> CoreBndr -> IdSet
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`addOneToUniqSet` CoreBndr
binder
([CoreBndr]
rhs_binders, Expr CoreBndr
rhs_body) = Expr CoreBndr -> ([CoreBndr], Expr CoreBndr)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr CoreBndr
rhs
(Expr CoreBndr
rhs_body', IdSATInfo
sat_info_rhs_body) <- Expr CoreBndr -> IdSet -> SatM (Expr CoreBndr, IdSATInfo)
satTopLevelExpr Expr CoreBndr
rhs_body IdSet
interesting_ids'
let sat_info_rhs_from_args :: IdSATInfo
sat_info_rhs_from_args = CoreBndr -> SATInfo -> IdSATInfo
forall a. CoreBndr -> a -> VarEnv a
unitVarEnv CoreBndr
binder ([CoreBndr] -> SATInfo
bindersToSATInfo [CoreBndr]
rhs_binders)
sat_info_rhs' :: IdSATInfo
sat_info_rhs' = IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo IdSATInfo
sat_info_rhs_from_args IdSATInfo
sat_info_rhs_body
shadowing :: Bool
shadowing = CoreBndr
binder CoreBndr -> IdSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` IdSet
interesting_ids
sat_info_rhs'' :: IdSATInfo
sat_info_rhs'' = if Bool
shadowing
then IdSATInfo
sat_info_rhs' IdSATInfo -> CoreBndr -> IdSATInfo
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
`delFromUFM` CoreBndr
binder
else IdSATInfo
sat_info_rhs'
CoreBind
bind' <- CoreBndr
-> Maybe SATInfo -> [CoreBndr] -> Expr CoreBndr -> SatM CoreBind
saTransformMaybe CoreBndr
binder (IdSATInfo -> CoreBndr -> Maybe SATInfo
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM IdSATInfo
sat_info_rhs' CoreBndr
binder)
[CoreBndr]
rhs_binders Expr CoreBndr
rhs_body'
(CoreBind, IdSATInfo) -> SatM (CoreBind, IdSATInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind
bind', IdSATInfo
sat_info_rhs'')
satBind (Rec [(CoreBndr, Expr CoreBndr)]
pairs) IdSet
interesting_ids = do
let ([CoreBndr]
binders, [Expr CoreBndr]
rhss) = [(CoreBndr, Expr CoreBndr)] -> ([CoreBndr], [Expr CoreBndr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CoreBndr, Expr CoreBndr)]
pairs
[(Expr CoreBndr, IdSATInfo)]
rhss_SATed <- (Expr CoreBndr -> SatM (Expr CoreBndr, IdSATInfo))
-> [Expr CoreBndr] -> UniqSM [(Expr CoreBndr, IdSATInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Expr CoreBndr
e -> Expr CoreBndr -> IdSet -> SatM (Expr CoreBndr, IdSATInfo)
satTopLevelExpr Expr CoreBndr
e IdSet
interesting_ids) [Expr CoreBndr]
rhss
let ([Expr CoreBndr]
rhss', [IdSATInfo]
sat_info_rhss') = [(Expr CoreBndr, IdSATInfo)] -> ([Expr CoreBndr], [IdSATInfo])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Expr CoreBndr, IdSATInfo)]
rhss_SATed
(CoreBind, IdSATInfo) -> SatM (CoreBind, IdSATInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec (String
-> [CoreBndr] -> [Expr CoreBndr] -> [(CoreBndr, Expr CoreBndr)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"satBind" [CoreBndr]
binders [Expr CoreBndr]
rhss'), [IdSATInfo] -> IdSATInfo
mergeIdSATInfos [IdSATInfo]
sat_info_rhss')
data App = VarApp Id | TypeApp Type | CoApp Coercion
data Staticness a = Static a | NotStatic
type IdAppInfo = (Id, SATInfo)
type SATInfo = [Staticness App]
type IdSATInfo = IdEnv SATInfo
emptyIdSATInfo :: IdSATInfo
emptyIdSATInfo :: IdSATInfo
emptyIdSATInfo = IdSATInfo
forall elt. UniqFM elt
emptyUFM
pprSATInfo :: SATInfo -> SDoc
pprSATInfo :: SATInfo -> SDoc
pprSATInfo SATInfo
staticness = [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Staticness App -> SDoc) -> SATInfo -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Staticness App -> SDoc
pprStaticness SATInfo
staticness
pprStaticness :: Staticness App -> SDoc
pprStaticness :: Staticness App -> SDoc
pprStaticness (Static (VarApp CoreBndr
_)) = String -> SDoc
text String
"SV"
pprStaticness (Static (TypeApp Type
_)) = String -> SDoc
text String
"ST"
pprStaticness (Static (CoApp Coercion
_)) = String -> SDoc
text String
"SC"
pprStaticness Staticness App
NotStatic = String -> SDoc
text String
"NS"
mergeSATInfo :: SATInfo -> SATInfo -> SATInfo
mergeSATInfo :: SATInfo -> SATInfo -> SATInfo
mergeSATInfo SATInfo
l SATInfo
r = (Staticness App -> Staticness App -> Staticness App)
-> SATInfo -> SATInfo -> SATInfo
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Staticness App -> Staticness App -> Staticness App
mergeSA SATInfo
l SATInfo
r
where
mergeSA :: Staticness App -> Staticness App -> Staticness App
mergeSA Staticness App
NotStatic Staticness App
_ = Staticness App
forall a. Staticness a
NotStatic
mergeSA Staticness App
_ Staticness App
NotStatic = Staticness App
forall a. Staticness a
NotStatic
mergeSA (Static (VarApp CoreBndr
v)) (Static (VarApp CoreBndr
v'))
| CoreBndr
v CoreBndr -> CoreBndr -> Bool
forall a. Eq a => a -> a -> Bool
== CoreBndr
v' = App -> Staticness App
forall a. a -> Staticness a
Static (CoreBndr -> App
VarApp CoreBndr
v)
| Bool
otherwise = Staticness App
forall a. Staticness a
NotStatic
mergeSA (Static (TypeApp Type
t)) (Static (TypeApp Type
t'))
| Type
t Type -> Type -> Bool
`eqType` Type
t' = App -> Staticness App
forall a. a -> Staticness a
Static (Type -> App
TypeApp Type
t)
| Bool
otherwise = Staticness App
forall a. Staticness a
NotStatic
mergeSA (Static (CoApp Coercion
c)) (Static (CoApp Coercion
c'))
| Coercion
c Coercion -> Coercion -> Bool
`eqCoercion` Coercion
c' = App -> Staticness App
forall a. a -> Staticness a
Static (Coercion -> App
CoApp Coercion
c)
| Bool
otherwise = Staticness App
forall a. Staticness a
NotStatic
mergeSA Staticness App
_ Staticness App
_ = String -> SDoc -> Staticness App
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mergeSATInfo" (SDoc -> Staticness App) -> SDoc -> Staticness App
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Left:"
SDoc -> SDoc -> SDoc
<> SATInfo -> SDoc
pprSATInfo SATInfo
l SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", "
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"Right:"
SDoc -> SDoc -> SDoc
<> SATInfo -> SDoc
pprSATInfo SATInfo
r
mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo = (SATInfo -> SATInfo -> SATInfo)
-> IdSATInfo -> IdSATInfo -> IdSATInfo
forall elt.
(elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt
plusUFM_C SATInfo -> SATInfo -> SATInfo
mergeSATInfo
mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo
mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo
mergeIdSATInfos = (IdSATInfo -> IdSATInfo -> IdSATInfo)
-> IdSATInfo -> [IdSATInfo] -> IdSATInfo
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo IdSATInfo
emptyIdSATInfo
bindersToSATInfo :: [Id] -> SATInfo
bindersToSATInfo :: [CoreBndr] -> SATInfo
bindersToSATInfo [CoreBndr]
vs = (CoreBndr -> Staticness App) -> [CoreBndr] -> SATInfo
forall a b. (a -> b) -> [a] -> [b]
map (App -> Staticness App
forall a. a -> Staticness a
Static (App -> Staticness App)
-> (CoreBndr -> App) -> CoreBndr -> Staticness App
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> App
binderToApp) [CoreBndr]
vs
where binderToApp :: CoreBndr -> App
binderToApp CoreBndr
v | CoreBndr -> Bool
isId CoreBndr
v = CoreBndr -> App
VarApp CoreBndr
v
| CoreBndr -> Bool
isTyVar CoreBndr
v = Type -> App
TypeApp (Type -> App) -> Type -> App
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Type
mkTyVarTy CoreBndr
v
| Bool
otherwise = Coercion -> App
CoApp (Coercion -> App) -> Coercion -> App
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Coercion
mkCoVarCo CoreBndr
v
finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Maybe IdAppInfo
Nothing IdSATInfo
id_sat_info = IdSATInfo
id_sat_info
finalizeApp (Just (CoreBndr
v, SATInfo
sat_info')) IdSATInfo
id_sat_info =
let sat_info'' :: SATInfo
sat_info'' = case IdSATInfo -> CoreBndr -> Maybe SATInfo
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM IdSATInfo
id_sat_info CoreBndr
v of
Maybe SATInfo
Nothing -> SATInfo
sat_info'
Just SATInfo
sat_info -> SATInfo -> SATInfo -> SATInfo
mergeSATInfo SATInfo
sat_info SATInfo
sat_info'
in IdSATInfo -> CoreBndr -> SATInfo -> IdSATInfo
forall a. VarEnv a -> CoreBndr -> a -> VarEnv a
extendVarEnv IdSATInfo
id_sat_info CoreBndr
v SATInfo
sat_info''
satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
satTopLevelExpr :: Expr CoreBndr -> IdSet -> SatM (Expr CoreBndr, IdSATInfo)
satTopLevelExpr Expr CoreBndr
expr IdSet
interesting_ids = do
(Expr CoreBndr
expr', IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
expr IdSet
interesting_ids
(Expr CoreBndr, IdSATInfo) -> SatM (Expr CoreBndr, IdSATInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
expr', Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Maybe IdAppInfo
expr_app IdSATInfo
sat_info_expr)
satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
satExpr :: Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr var :: Expr CoreBndr
var@(Var CoreBndr
v) IdSet
interesting_ids = do
let app_info :: Maybe (CoreBndr, [a])
app_info = if CoreBndr
v CoreBndr -> IdSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` IdSet
interesting_ids
then (CoreBndr, [a]) -> Maybe (CoreBndr, [a])
forall a. a -> Maybe a
Just (CoreBndr
v, [])
else Maybe (CoreBndr, [a])
forall a. Maybe a
Nothing
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
var, IdSATInfo
emptyIdSATInfo, Maybe IdAppInfo
forall a. Maybe (CoreBndr, [a])
app_info)
satExpr lit :: Expr CoreBndr
lit@(Lit Literal
_) IdSet
_ = do
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
lit, IdSATInfo
emptyIdSATInfo, Maybe IdAppInfo
forall a. Maybe a
Nothing)
satExpr (Lam CoreBndr
binders Expr CoreBndr
body) IdSet
interesting_ids = do
(Expr CoreBndr
body', IdSATInfo
sat_info, Maybe IdAppInfo
this_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
body IdSet
interesting_ids
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. b -> Expr b -> Expr b
Lam CoreBndr
binders Expr CoreBndr
body', Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Maybe IdAppInfo
this_app IdSATInfo
sat_info, Maybe IdAppInfo
forall a. Maybe a
Nothing)
satExpr (App Expr CoreBndr
fn Expr CoreBndr
arg) IdSet
interesting_ids = do
(Expr CoreBndr
fn', IdSATInfo
sat_info_fn, Maybe IdAppInfo
fn_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
fn IdSet
interesting_ids
let satRemainder :: Maybe IdAppInfo -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainder = Expr CoreBndr
-> IdSATInfo
-> Maybe IdAppInfo
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
boring Expr CoreBndr
fn' IdSATInfo
sat_info_fn
case Maybe IdAppInfo
fn_app of
Maybe IdAppInfo
Nothing -> Maybe IdAppInfo -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainder Maybe IdAppInfo
forall a. Maybe a
Nothing
Just (CoreBndr
fn_id, SATInfo
fn_app_info) ->
let satRemainderWithStaticness :: Staticness App -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainderWithStaticness Staticness App
arg_staticness = Maybe IdAppInfo -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainder (Maybe IdAppInfo
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo))
-> Maybe IdAppInfo
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall a b. (a -> b) -> a -> b
$ IdAppInfo -> Maybe IdAppInfo
forall a. a -> Maybe a
Just (CoreBndr
fn_id, SATInfo
fn_app_info SATInfo -> SATInfo -> SATInfo
forall a. [a] -> [a] -> [a]
++ [Staticness App
arg_staticness])
in case Expr CoreBndr
arg of
Type Type
t -> Staticness App -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainderWithStaticness (Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo))
-> Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall a b. (a -> b) -> a -> b
$ App -> Staticness App
forall a. a -> Staticness a
Static (Type -> App
TypeApp Type
t)
Coercion Coercion
c -> Staticness App -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainderWithStaticness (Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo))
-> Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall a b. (a -> b) -> a -> b
$ App -> Staticness App
forall a. a -> Staticness a
Static (Coercion -> App
CoApp Coercion
c)
Var CoreBndr
v -> Staticness App -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainderWithStaticness (Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo))
-> Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall a b. (a -> b) -> a -> b
$ App -> Staticness App
forall a. a -> Staticness a
Static (CoreBndr -> App
VarApp CoreBndr
v)
Expr CoreBndr
_ -> Staticness App -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satRemainderWithStaticness (Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo))
-> Staticness App
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall a b. (a -> b) -> a -> b
$ Staticness App
forall a. Staticness a
NotStatic
where
boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
boring :: Expr CoreBndr
-> IdSATInfo
-> Maybe IdAppInfo
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
boring Expr CoreBndr
fn' IdSATInfo
sat_info_fn Maybe IdAppInfo
app_info =
do (Expr CoreBndr
arg', IdSATInfo
sat_info_arg, Maybe IdAppInfo
arg_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
arg IdSet
interesting_ids
let sat_info_arg' :: IdSATInfo
sat_info_arg' = Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Maybe IdAppInfo
arg_app IdSATInfo
sat_info_arg
sat_info :: IdSATInfo
sat_info = IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo IdSATInfo
sat_info_fn IdSATInfo
sat_info_arg'
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Expr b -> Expr b -> Expr b
App Expr CoreBndr
fn' Expr CoreBndr
arg', IdSATInfo
sat_info, Maybe IdAppInfo
app_info)
satExpr (Case Expr CoreBndr
expr CoreBndr
bndr Type
ty [Alt CoreBndr]
alts) IdSet
interesting_ids = do
(Expr CoreBndr
expr', IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
expr IdSet
interesting_ids
let sat_info_expr' :: IdSATInfo
sat_info_expr' = Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
finalizeApp Maybe IdAppInfo
expr_app IdSATInfo
sat_info_expr
[(Alt CoreBndr, IdSATInfo)]
zipped_alts' <- (Alt CoreBndr -> UniqSM (Alt CoreBndr, IdSATInfo))
-> [Alt CoreBndr] -> UniqSM [(Alt CoreBndr, IdSATInfo)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt CoreBndr -> UniqSM (Alt CoreBndr, IdSATInfo)
forall a b.
(a, b, Expr CoreBndr) -> UniqSM ((a, b, Expr CoreBndr), IdSATInfo)
satAlt [Alt CoreBndr]
alts
let ([Alt CoreBndr]
alts', [IdSATInfo]
sat_infos_alts) = [(Alt CoreBndr, IdSATInfo)] -> ([Alt CoreBndr], [IdSATInfo])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Alt CoreBndr, IdSATInfo)]
zipped_alts'
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
-> CoreBndr -> Type -> [Alt CoreBndr] -> Expr CoreBndr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr CoreBndr
expr' CoreBndr
bndr Type
ty [Alt CoreBndr]
alts', IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo IdSATInfo
sat_info_expr' ([IdSATInfo] -> IdSATInfo
mergeIdSATInfos [IdSATInfo]
sat_infos_alts), Maybe IdAppInfo
forall a. Maybe a
Nothing)
where
satAlt :: (a, b, Expr CoreBndr) -> UniqSM ((a, b, Expr CoreBndr), IdSATInfo)
satAlt (a
con, b
bndrs, Expr CoreBndr
expr) = do
(Expr CoreBndr
expr', IdSATInfo
sat_info_expr) <- Expr CoreBndr -> IdSet -> SatM (Expr CoreBndr, IdSATInfo)
satTopLevelExpr Expr CoreBndr
expr IdSet
interesting_ids
((a, b, Expr CoreBndr), IdSATInfo)
-> UniqSM ((a, b, Expr CoreBndr), IdSATInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
con, b
bndrs, Expr CoreBndr
expr'), IdSATInfo
sat_info_expr)
satExpr (Let CoreBind
bind Expr CoreBndr
body) IdSet
interesting_ids = do
(Expr CoreBndr
body', IdSATInfo
sat_info_body, Maybe IdAppInfo
body_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
body IdSet
interesting_ids
(CoreBind
bind', IdSATInfo
sat_info_bind) <- CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
satBind CoreBind
bind IdSet
interesting_ids
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' Expr CoreBndr
body', IdSATInfo -> IdSATInfo -> IdSATInfo
mergeIdSATInfo IdSATInfo
sat_info_body IdSATInfo
sat_info_bind, Maybe IdAppInfo
body_app)
satExpr (Tick Tickish CoreBndr
tickish Expr CoreBndr
expr) IdSet
interesting_ids = do
(Expr CoreBndr
expr', IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
expr IdSet
interesting_ids
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish CoreBndr -> Expr CoreBndr -> Expr CoreBndr
forall b. Tickish CoreBndr -> Expr b -> Expr b
Tick Tickish CoreBndr
tickish Expr CoreBndr
expr', IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app)
satExpr ty :: Expr CoreBndr
ty@(Type Type
_) IdSet
_ = do
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
ty, IdSATInfo
emptyIdSATInfo, Maybe IdAppInfo
forall a. Maybe a
Nothing)
satExpr co :: Expr CoreBndr
co@(Coercion Coercion
_) IdSet
_ = do
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr
co, IdSATInfo
emptyIdSATInfo, Maybe IdAppInfo
forall a. Maybe a
Nothing)
satExpr (Cast Expr CoreBndr
expr Coercion
coercion) IdSet
interesting_ids = do
(Expr CoreBndr
expr', IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app) <- Expr CoreBndr
-> IdSet -> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
satExpr Expr CoreBndr
expr IdSet
interesting_ids
(Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
-> SatM (Expr CoreBndr, IdSATInfo, Maybe IdAppInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr CoreBndr -> Coercion -> Expr CoreBndr
forall b. Expr b -> Coercion -> Expr b
Cast Expr CoreBndr
expr' Coercion
coercion, IdSATInfo
sat_info_expr, Maybe IdAppInfo
expr_app)
type SatM result = UniqSM result
runSAT :: UniqSupply -> SatM a -> a
runSAT :: UniqSupply -> SatM a -> a
runSAT = UniqSupply -> SatM a -> a
forall a. UniqSupply -> SatM a -> a
initUs_
newUnique :: SatM Unique
newUnique :: SatM Unique
newUnique = SatM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
saTransformMaybe :: CoreBndr
-> Maybe SATInfo -> [CoreBndr] -> Expr CoreBndr -> SatM CoreBind
saTransformMaybe CoreBndr
binder Maybe SATInfo
maybe_arg_staticness [CoreBndr]
rhs_binders Expr CoreBndr
rhs_body
| Just SATInfo
arg_staticness <- Maybe SATInfo
maybe_arg_staticness
, SATInfo -> Bool
should_transform SATInfo
arg_staticness
= CoreBndr -> SATInfo -> [CoreBndr] -> Expr CoreBndr -> SatM CoreBind
saTransform CoreBndr
binder SATInfo
arg_staticness [CoreBndr]
rhs_binders Expr CoreBndr
rhs_body
| Bool
otherwise
= CoreBind -> SatM CoreBind
forall (m :: * -> *) a. Monad m => a -> m a
return ([(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr
binder, [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
rhs_binders Expr CoreBndr
rhs_body)])
where
should_transform :: SATInfo -> Bool
should_transform SATInfo
staticness = Int
n_static_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
where
n_static_args :: Int
n_static_args = (Staticness App -> Bool) -> SATInfo -> Int
forall a. (a -> Bool) -> [a] -> Int
count Staticness App -> Bool
isStaticValue SATInfo
staticness
saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
saTransform :: CoreBndr -> SATInfo -> [CoreBndr] -> Expr CoreBndr -> SatM CoreBind
saTransform CoreBndr
binder SATInfo
arg_staticness [CoreBndr]
rhs_binders Expr CoreBndr
rhs_body
= do { [CoreBndr]
shadow_lam_bndrs <- ((CoreBndr, Staticness App) -> UniqSM CoreBndr)
-> [(CoreBndr, Staticness App)] -> UniqSM [CoreBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (CoreBndr, Staticness App) -> UniqSM CoreBndr
forall a. (CoreBndr, Staticness a) -> UniqSM CoreBndr
clone [(CoreBndr, Staticness App)]
binders_w_staticness
; Unique
uniq <- SatM Unique
newUnique
; CoreBind -> SatM CoreBind
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
binder (Unique -> [CoreBndr] -> Expr CoreBndr
mk_new_rhs Unique
uniq [CoreBndr]
shadow_lam_bndrs)) }
where
binders_w_staticness :: [(CoreBndr, Staticness App)]
binders_w_staticness = [CoreBndr]
rhs_binders [CoreBndr] -> SATInfo -> [(CoreBndr, Staticness App)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (SATInfo
arg_staticness SATInfo -> SATInfo -> SATInfo
forall a. [a] -> [a] -> [a]
++ Staticness App -> SATInfo
forall a. a -> [a]
repeat Staticness App
forall a. Staticness a
NotStatic)
non_static_args :: [Var]
non_static_args :: [CoreBndr]
non_static_args = [CoreBndr
v | (CoreBndr
v, Staticness App
NotStatic) <- [(CoreBndr, Staticness App)]
binders_w_staticness]
clone :: (CoreBndr, Staticness a) -> UniqSM CoreBndr
clone (CoreBndr
bndr, Staticness a
NotStatic) = CoreBndr -> UniqSM CoreBndr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBndr
bndr
clone (CoreBndr
bndr, Staticness a
_ ) = do { Unique
uniq <- SatM Unique
newUnique
; CoreBndr -> UniqSM CoreBndr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBndr -> Unique -> CoreBndr
setVarUnique CoreBndr
bndr Unique
uniq) }
mk_new_rhs :: Unique -> [CoreBndr] -> Expr CoreBndr
mk_new_rhs Unique
uniq [CoreBndr]
shadow_lam_bndrs
= [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
rhs_binders (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let ([(CoreBndr, Expr CoreBndr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(CoreBndr
rec_body_bndr, Expr CoreBndr
rec_body)])
Expr CoreBndr
local_body
where
local_body :: Expr CoreBndr
local_body = Expr CoreBndr -> [CoreBndr] -> Expr CoreBndr
forall b. Expr b -> [CoreBndr] -> Expr b
mkVarApps (CoreBndr -> Expr CoreBndr
forall b. CoreBndr -> Expr b
Var CoreBndr
rec_body_bndr) [CoreBndr]
non_static_args
rec_body :: Expr CoreBndr
rec_body = [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
non_static_args (Expr CoreBndr -> Expr CoreBndr) -> Expr CoreBndr -> Expr CoreBndr
forall a b. (a -> b) -> a -> b
$
CoreBind -> Expr CoreBndr -> Expr CoreBndr
forall b. Bind b -> Expr b -> Expr b
Let (CoreBndr -> Expr CoreBndr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec CoreBndr
shadow_bndr Expr CoreBndr
shadow_rhs) Expr CoreBndr
rhs_body
shadow_rhs :: Expr CoreBndr
shadow_rhs = [CoreBndr] -> Expr CoreBndr -> Expr CoreBndr
forall b. [b] -> Expr b -> Expr b
mkLams [CoreBndr]
shadow_lam_bndrs Expr CoreBndr
local_body
rec_body_bndr :: CoreBndr
rec_body_bndr = FastString -> Unique -> Type -> CoreBndr
mkSysLocal (String -> FastString
fsLit String
"sat_worker") Unique
uniq (Expr CoreBndr -> Type
exprType Expr CoreBndr
rec_body)
shadow_bndr :: CoreBndr
shadow_bndr = FastString -> Unique -> Type -> CoreBndr
mkSysLocal (OccName -> FastString
occNameFS (CoreBndr -> OccName
forall a. NamedThing a => a -> OccName
getOccName CoreBndr
binder))
(CoreBndr -> Unique
idUnique CoreBndr
binder)
(Expr CoreBndr -> Type
exprType Expr CoreBndr
shadow_rhs)
isStaticValue :: Staticness App -> Bool
isStaticValue :: Staticness App -> Bool
isStaticValue (Static (VarApp CoreBndr
_)) = Bool
True
isStaticValue Staticness App
_ = Bool
False