{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.SpecConstr(
        specConstrProgram,
        SpecConstrAnnotation(..)
    ) where
import GHC.Prelude
import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
                          , gopt, hasPprDebug )
import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.Unfold
import GHC.Core.FVs     ( exprsFreeVarsList )
import GHC.Core.Opt.Monad
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.DataCon
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.Rules
import GHC.Core.Type     hiding ( substTy )
import GHC.Core.TyCon   (TyCon, tyConUnique, tyConName )
import GHC.Core.Multiplicity
import GHC.Core.Ppr     ( pprParendExpr )
import GHC.Core.Make    ( mkImpossibleExpr )
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Types.Literal ( litIsLifted )
import GHC.Types.Id
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Basic
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Types.Unique.Supply
import GHC.Types.Unique.FM
import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )
import GHC.Data.Pair
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Monad
import GHC.Utils.Trace
import GHC.Builtin.Names ( specTyConKey )
import GHC.Exts( SpecConstrAnnotation(..) )
import GHC.Serialized   ( deserializeWithData )
import Control.Monad    ( zipWithM )
import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Ord( comparing )
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram :: ModGuts -> CoreM ModGuts
specConstrProgram ModGuts
guts
  = do
      DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      UniqSupply
us     <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
      (ModuleEnv SpecConstrAnnotation
_, NameEnv SpecConstrAnnotation
annos) <- ([Word8] -> SpecConstrAnnotation)
-> ModGuts
-> CoreM
     (ModuleEnv SpecConstrAnnotation, NameEnv SpecConstrAnnotation)
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)
getFirstAnnotations [Word8] -> SpecConstrAnnotation
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
      Module
this_mod <- CoreM Module
forall (m :: * -> *). HasModule m => m Module
getModule
      
      let binds' :: [CoreBind]
binds' = [CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse ([CoreBind] -> [CoreBind]) -> [CoreBind] -> [CoreBind]
forall a b. (a -> b) -> a -> b
$ ([CoreBind], UniqSupply) -> [CoreBind]
forall a b. (a, b) -> a
fst (([CoreBind], UniqSupply) -> [CoreBind])
-> ([CoreBind], UniqSupply) -> [CoreBind]
forall a b. (a -> b) -> a -> b
$ UniqSupply -> UniqSM [CoreBind] -> ([CoreBind], UniqSupply)
forall a. UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs UniqSupply
us (UniqSM [CoreBind] -> ([CoreBind], UniqSupply))
-> UniqSM [CoreBind] -> ([CoreBind], UniqSupply)
forall a b. (a -> b) -> a -> b
$ do
                    
                    (ScEnv
env, [CoreBind]
binds) <- ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv (DynFlags -> Module -> NameEnv SpecConstrAnnotation -> ScEnv
initScEnv DynFlags
dflags Module
this_mod NameEnv SpecConstrAnnotation
annos)
                                          (ModGuts -> [CoreBind]
mg_binds ModGuts
guts)
                        
                        
                        
                        
                    ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
env ScUsage
nullUsage ([CoreBind] -> [CoreBind]
forall a. [a] -> [a]
reverse [CoreBind]
binds)
      ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts
guts { mg_binds :: [CoreBind]
mg_binds = [CoreBind]
binds' })
  where
    
    goEnv :: ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv ScEnv
env []            = (ScEnv, [CoreBind]) -> UniqSM (ScEnv, [CoreBind])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env, [])
    goEnv ScEnv
env (CoreBind
bind:[CoreBind]
binds)  = do (ScEnv
env', CoreBind
bind')   <- ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv ScEnv
env CoreBind
bind
                                 (ScEnv
env'', [CoreBind]
binds') <- ScEnv -> [CoreBind] -> UniqSM (ScEnv, [CoreBind])
goEnv ScEnv
env' [CoreBind]
binds
                                 (ScEnv, [CoreBind]) -> UniqSM (ScEnv, [CoreBind])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env'', CoreBind
bind' CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
binds')
    
    go :: ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
_   ScUsage
_   []           = [CoreBind] -> UniqSM [CoreBind]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go ScEnv
env ScUsage
usg (CoreBind
bind:[CoreBind]
binds) = do (ScUsage
usg', CoreBind
bind') <- ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind ScEnv
env ScUsage
usg CoreBind
bind
                                 [CoreBind]
binds' <- ScEnv -> ScUsage -> [CoreBind] -> UniqSM [CoreBind]
go ScEnv
env ScUsage
usg' [CoreBind]
binds
                                 [CoreBind] -> UniqSM [CoreBind]
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind
bind' CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind]
binds')
data ScEnv = SCE { ScEnv -> DynFlags
sc_dflags    :: DynFlags,
                   ScEnv -> UnfoldingOpts
sc_uf_opts   :: !UnfoldingOpts, 
                   ScEnv -> Module
sc_module    :: !Module,
                   ScEnv -> Maybe Int
sc_size      :: Maybe Int,   
                                                
                   ScEnv -> Maybe Int
sc_count     :: Maybe Int,   
                                                
                                                
                   ScEnv -> Int
sc_recursive :: Int,         
                                                
                   ScEnv -> Bool
sc_keen     :: Bool,         
                                                
                                                
                                                
                   ScEnv -> Bool
sc_force     :: Bool,        
                                                
                   ScEnv -> Subst
sc_subst     :: Subst,       
                                                
                   ScEnv -> HowBoundEnv
sc_how_bound :: HowBoundEnv,
                        
                        
                   ScEnv -> ValueEnv
sc_vals      :: ValueEnv,
                        
                        
                        
                        
                        
                        
                   ScEnv -> NameEnv SpecConstrAnnotation
sc_annotations :: UniqFM Name SpecConstrAnnotation
             }
type HowBoundEnv = VarEnv HowBound      
type ValueEnv = IdEnv Value             
data Value    = ConVal AltCon [CoreArg] 
                                        
              | LambdaVal               
instance Outputable Value where
   ppr :: Value -> SDoc
ppr (ConVal AltCon
con [Expr Id]
args) = AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> [Expr Id] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [Expr Id]
args
   ppr Value
LambdaVal         = String -> SDoc
text String
"<Lambda>"
initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv
initScEnv :: DynFlags -> Module -> NameEnv SpecConstrAnnotation -> ScEnv
initScEnv DynFlags
dflags Module
this_mod NameEnv SpecConstrAnnotation
anns
  = SCE { sc_dflags :: DynFlags
sc_dflags      = DynFlags
dflags,
          sc_uf_opts :: UnfoldingOpts
sc_uf_opts     = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags,
          sc_module :: Module
sc_module      = Module
this_mod,
          sc_size :: Maybe Int
sc_size        = DynFlags -> Maybe Int
specConstrThreshold DynFlags
dflags,
          sc_count :: Maybe Int
sc_count       = DynFlags -> Maybe Int
specConstrCount     DynFlags
dflags,
          sc_recursive :: Int
sc_recursive   = DynFlags -> Int
specConstrRecursive DynFlags
dflags,
          sc_keen :: Bool
sc_keen        = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecConstrKeen DynFlags
dflags,
          sc_force :: Bool
sc_force       = Bool
False,
          sc_subst :: Subst
sc_subst       = Subst
emptySubst,
          sc_how_bound :: HowBoundEnv
sc_how_bound   = HowBoundEnv
forall a. VarEnv a
emptyVarEnv,
          sc_vals :: ValueEnv
sc_vals        = ValueEnv
forall a. VarEnv a
emptyVarEnv,
          sc_annotations :: NameEnv SpecConstrAnnotation
sc_annotations = NameEnv SpecConstrAnnotation
anns }
data HowBound = RecFun  
                        
              | RecArg  
                        
instance Outputable HowBound where
  ppr :: HowBound -> SDoc
ppr HowBound
RecFun = String -> SDoc
text String
"RecFun"
  ppr HowBound
RecArg = String -> SDoc
text String
"RecArg"
scForce :: ScEnv -> Bool -> ScEnv
scForce :: ScEnv -> Bool -> ScEnv
scForce ScEnv
env Bool
b = ScEnv
env { sc_force :: Bool
sc_force = Bool
b }
lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound :: ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
id = HowBoundEnv -> Id -> Maybe HowBound
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env) Id
id
scSubstId :: ScEnv -> Id -> CoreExpr
scSubstId :: ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
v = (() :: Constraint) => Subst -> Id -> Expr Id
Subst -> Id -> Expr Id
lookupIdSubst (ScEnv -> Subst
sc_subst ScEnv
env) Id
v
scSubstTy :: ScEnv -> Type -> Type
scSubstTy :: ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
ty = Subst -> Type -> Type
substTy (ScEnv -> Subst
sc_subst ScEnv
env) Type
ty
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo :: ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
co = HasCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
substCo (ScEnv -> Subst
sc_subst ScEnv
env) Coercion
co
zapScSubst :: ScEnv -> ScEnv
zapScSubst :: ScEnv -> ScEnv
zapScSubst ScEnv
env = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> Subst
zapSubstEnv (ScEnv -> Subst
sc_subst ScEnv
env) }
extendScInScope :: ScEnv -> [Var] -> ScEnv
        
extendScInScope :: ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars
  = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> [Id] -> Subst
extendSubstInScopeList (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
qvars }
        
extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
extendScSubst :: ScEnv -> Id -> Expr Id -> ScEnv
extendScSubst ScEnv
env Id
var Expr Id
expr = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> Id -> Expr Id -> Subst
extendSubst (ScEnv -> Subst
sc_subst ScEnv
env) Id
var Expr Id
expr }
extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
extendScSubstList :: ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList ScEnv
env [(Id, Expr Id)]
prs = ScEnv
env { sc_subst :: Subst
sc_subst = Subst -> [(Id, Expr Id)] -> Subst
extendSubstList (ScEnv -> Subst
sc_subst ScEnv
env) [(Id, Expr Id)]
prs }
extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
extendHowBound :: ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
env [Id]
bndrs HowBound
how_bound
  = ScEnv
env { sc_how_bound :: HowBoundEnv
sc_how_bound = HowBoundEnv -> [(Id, HowBound)] -> HowBoundEnv
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env)
                            [(Id
bndr,HowBound
how_bound) | Id
bndr <- [Id]
bndrs] }
extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
extendBndrsWith :: HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
how_bound ScEnv
env [Id]
bndrs
  = (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst', sc_how_bound :: HowBoundEnv
sc_how_bound = HowBoundEnv
hb_env' }, [Id]
bndrs')
  where
    (Subst
subst', [Id]
bndrs') = Subst -> [Id] -> (Subst, [Id])
substBndrs (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
bndrs
    hb_env' :: HowBoundEnv
hb_env' = ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env HowBoundEnv -> [(Id, HowBound)] -> HowBoundEnv
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
`extendVarEnvList`
                    [(Id
bndr,HowBound
how_bound) | Id
bndr <- [Id]
bndrs']
extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
extendBndrWith :: HowBound -> ScEnv -> Id -> (ScEnv, Id)
extendBndrWith HowBound
how_bound ScEnv
env Id
bndr
  = (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst', sc_how_bound :: HowBoundEnv
sc_how_bound = HowBoundEnv
hb_env' }, Id
bndr')
  where
    (Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr (ScEnv -> Subst
sc_subst ScEnv
env) Id
bndr
    hb_env' :: HowBoundEnv
hb_env' = HowBoundEnv -> Id -> HowBound -> HowBoundEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (ScEnv -> HowBoundEnv
sc_how_bound ScEnv
env) Id
bndr' HowBound
how_bound
extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
extendRecBndrs :: ScEnv -> [Id] -> (ScEnv, [Id])
extendRecBndrs ScEnv
env [Id]
bndrs  = (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst' }, [Id]
bndrs')
                      where
                        (Subst
subst', [Id]
bndrs') = Subst -> [Id] -> (Subst, [Id])
substRecBndrs (ScEnv -> Subst
sc_subst ScEnv
env) [Id]
bndrs
extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
extendBndrs :: ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrs ScEnv
env [Id]
bndrs = (ScEnv -> Id -> (ScEnv, Id)) -> ScEnv -> [Id] -> (ScEnv, [Id])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env [Id]
bndrs
extendBndr :: ScEnv -> Var -> (ScEnv, Var)
extendBndr :: ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr  = (ScEnv
env { sc_subst :: Subst
sc_subst = Subst
subst' }, Id
bndr')
                     where
                       (Subst
subst', Id
bndr') = Subst -> Id -> (Subst, Id)
substBndr (ScEnv -> Subst
sc_subst ScEnv
env) Id
bndr
extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env Id
_  Maybe Value
Nothing   = ScEnv
env
extendValEnv ScEnv
env Id
id (Just Value
cv)
 | Value -> Bool
valueIsWorkFree Value
cv      
 = ScEnv
env { sc_vals :: ValueEnv
sc_vals = ValueEnv -> Id -> Value -> ValueEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (ScEnv -> ValueEnv
sc_vals ScEnv
env) Id
id Value
cv }
extendValEnv ScEnv
env Id
_ Maybe Value
_ = ScEnv
env
extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
extendCaseBndrs :: ScEnv -> Expr Id -> Id -> AltCon -> [Id] -> (ScEnv, [Id])
extendCaseBndrs ScEnv
env Expr Id
scrut Id
case_bndr AltCon
con [Id]
alt_bndrs
   = (ScEnv
env2, [Id]
alt_bndrs')
 where
   live_case_bndr :: Bool
live_case_bndr = Bool -> Bool
not (Id -> Bool
isDeadBinder Id
case_bndr)
   env1 :: ScEnv
env1 | Var Id
v <- (CoreTickish -> Bool) -> Expr Id -> Expr Id
forall b. (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> CoreTickish -> Bool
forall a b. a -> b -> a
const Bool
True) Expr Id
scrut
                         = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env Id
v Maybe Value
cval
        | Bool
otherwise      = ScEnv
env  
   env2 :: ScEnv
env2 | Bool
live_case_bndr = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env1 Id
case_bndr Maybe Value
cval
        | Bool
otherwise      = ScEnv
env1
   alt_bndrs' :: [Id]
alt_bndrs' | case Expr Id
scrut of { Var {} -> Bool
True; Expr Id
_ -> Bool
live_case_bndr }
              = (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
zap [Id]
alt_bndrs
              | Bool
otherwise
              = [Id]
alt_bndrs
   cval :: Maybe Value
cval = case AltCon
con of
                AltCon
DEFAULT    -> Maybe Value
forall a. Maybe a
Nothing
                LitAlt {}  -> Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal AltCon
con [])
                DataAlt {} -> Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal AltCon
con [Expr Id]
vanilla_args)
                      where
                        vanilla_args :: [Expr Id]
vanilla_args = (Type -> Expr Id) -> [Type] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Expr Id
forall b. Type -> Expr b
Type (HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs (Id -> Type
idType Id
case_bndr)) [Expr Id] -> [Expr Id] -> [Expr Id]
forall a. [a] -> [a] -> [a]
++
                                       [Id] -> [Expr Id]
forall b. [Id] -> [Expr b]
varsToCoreExprs [Id]
alt_bndrs
   zap :: Id -> Id
zap Id
v | Id -> Bool
isTyVar Id
v = Id
v                
         | Bool
otherwise = Id -> Id
zapIdOccInfo Id
v
decreaseSpecCount :: ScEnv -> Int -> ScEnv
decreaseSpecCount :: ScEnv -> Int -> ScEnv
decreaseSpecCount ScEnv
env Int
n_specs
  = ScEnv
env { sc_force :: Bool
sc_force = Bool
False   
        , sc_count :: Maybe Int
sc_count = case ScEnv -> Maybe Int
sc_count ScEnv
env of
                       Maybe Int
Nothing -> Maybe Int
forall a. Maybe a
Nothing
                       Just Int
n  -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` (Int
n_specs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) }
        
        
ignoreType    :: ScEnv -> Type   -> Bool
ignoreDataCon  :: ScEnv -> DataCon -> Bool
forceSpecBndr :: ScEnv -> Var    -> Bool
ignoreDataCon :: ScEnv -> DataCon -> Bool
ignoreDataCon ScEnv
env DataCon
dc = ScEnv -> TyCon -> Bool
ignoreTyCon ScEnv
env (DataCon -> TyCon
dataConTyCon DataCon
dc)
ignoreType :: ScEnv -> Type -> Bool
ignoreType ScEnv
env Type
ty
  = case Type -> Maybe TyCon
tyConAppTyCon_maybe Type
ty of
      Just TyCon
tycon -> ScEnv -> TyCon -> Bool
ignoreTyCon ScEnv
env TyCon
tycon
      Maybe TyCon
_          -> Bool
False
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon :: ScEnv -> TyCon -> Bool
ignoreTyCon ScEnv
env TyCon
tycon
  = NameEnv SpecConstrAnnotation -> Name -> Maybe SpecConstrAnnotation
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ScEnv -> NameEnv SpecConstrAnnotation
sc_annotations ScEnv
env) (TyCon -> Name
tyConName TyCon
tycon) Maybe SpecConstrAnnotation -> Maybe SpecConstrAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SpecConstrAnnotation -> Maybe SpecConstrAnnotation
forall a. a -> Maybe a
Just SpecConstrAnnotation
NoSpecConstr
forceSpecBndr :: ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env Id
var = ScEnv -> Type -> Bool
forceSpecFunTy ScEnv
env (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Id], Type) -> Type
forall a b. (a, b) -> b
snd (([Id], Type) -> Type) -> (Id -> ([Id], Type)) -> Id -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Id], Type)
splitForAllTyCoVars (Type -> ([Id], Type)) -> (Id -> Type) -> Id -> ([Id], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
varType (Id -> Bool) -> Id -> Bool
forall a b. (a -> b) -> a -> b
$ Id
var
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy :: ScEnv -> Type -> Bool
forceSpecFunTy ScEnv
env = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env) ([Type] -> Bool) -> (Type -> [Type]) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type])
-> (Type -> [Scaled Type]) -> Type -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Scaled Type], Type) -> [Scaled Type]
forall a b. (a, b) -> a
fst (([Scaled Type], Type) -> [Scaled Type])
-> (Type -> ([Scaled Type], Type)) -> Type -> [Scaled Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ([Scaled Type], Type)
splitFunTys
forceSpecArgTy :: ScEnv -> Type -> Bool
forceSpecArgTy :: ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env Type
ty
  | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env Type
ty'
forceSpecArgTy ScEnv
env Type
ty
  | Just (TyCon
tycon, [Type]
tys) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
  , TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
/= TyCon
funTyCon
      = TyCon -> Unique
tyConUnique TyCon
tycon Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
specTyConKey
        Bool -> Bool -> Bool
|| NameEnv SpecConstrAnnotation -> Name -> Maybe SpecConstrAnnotation
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (ScEnv -> NameEnv SpecConstrAnnotation
sc_annotations ScEnv
env) (TyCon -> Name
tyConName TyCon
tycon) Maybe SpecConstrAnnotation -> Maybe SpecConstrAnnotation -> Bool
forall a. Eq a => a -> a -> Bool
== SpecConstrAnnotation -> Maybe SpecConstrAnnotation
forall a. a -> Maybe a
Just SpecConstrAnnotation
ForceSpecConstr
        Bool -> Bool -> Bool
|| (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Type -> Bool
forceSpecArgTy ScEnv
env) [Type]
tys
forceSpecArgTy ScEnv
_ Type
_ = Bool
False
data ScUsage
   = SCU {
        ScUsage -> CallEnv
scu_calls :: CallEnv,           
                                        
                                        
        ScUsage -> IdEnv ArgOcc
scu_occs :: !(IdEnv ArgOcc)     
     }                                  
type CallEnv = IdEnv [Call]
data Call = Call Id [CoreArg] ValueEnv
        
        
        
        
        
        
instance Outputable ScUsage where
  ppr :: ScUsage -> SDoc
ppr (SCU { scu_calls :: ScUsage -> CallEnv
scu_calls = CallEnv
calls, scu_occs :: ScUsage -> IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
occs })
    = String -> SDoc
text String
"SCU" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"calls =" SDoc -> SDoc -> SDoc
<+> CallEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallEnv
calls
                                 , String -> SDoc
text String
"occs =" SDoc -> SDoc -> SDoc
<+> IdEnv ArgOcc -> SDoc
forall a. Outputable a => a -> SDoc
ppr IdEnv ArgOcc
occs ])
instance Outputable Call where
  ppr :: Call -> SDoc
ppr (Call Id
fn [Expr Id]
args ValueEnv
_) = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep ((Expr Id -> SDoc) -> [Expr Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Expr Id -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprParendExpr [Expr Id]
args)
nullUsage :: ScUsage
nullUsage :: ScUsage
nullUsage = SCU { scu_calls :: CallEnv
scu_calls = CallEnv
forall a. VarEnv a
emptyVarEnv, scu_occs :: IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
forall a. VarEnv a
emptyVarEnv }
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls :: CallEnv -> CallEnv -> CallEnv
combineCalls = ([Call] -> [Call] -> [Call]) -> CallEnv -> CallEnv -> CallEnv
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C [Call] -> [Call] -> [Call]
forall a. [a] -> [a] -> [a]
(++)
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage :: ScUsage -> ScUsage -> ScUsage
combineUsage ScUsage
u1 ScUsage
u2 = SCU { scu_calls :: CallEnv
scu_calls = CallEnv -> CallEnv -> CallEnv
combineCalls (ScUsage -> CallEnv
scu_calls ScUsage
u1) (ScUsage -> CallEnv
scu_calls ScUsage
u2),
                           scu_occs :: IdEnv ArgOcc
scu_occs  = (ArgOcc -> ArgOcc -> ArgOcc)
-> IdEnv ArgOcc -> IdEnv ArgOcc -> IdEnv ArgOcc
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C ArgOcc -> ArgOcc -> ArgOcc
combineOcc (ScUsage -> IdEnv ArgOcc
scu_occs ScUsage
u1) (ScUsage -> IdEnv ArgOcc
scu_occs ScUsage
u2) }
combineUsages :: [ScUsage] -> ScUsage
combineUsages :: [ScUsage] -> ScUsage
combineUsages [] = ScUsage
nullUsage
combineUsages [ScUsage]
us = (ScUsage -> ScUsage -> ScUsage) -> [ScUsage] -> ScUsage
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ScUsage -> ScUsage -> ScUsage
combineUsage [ScUsage]
us
lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
lookupOccs :: ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs (SCU { scu_calls :: ScUsage -> CallEnv
scu_calls = CallEnv
sc_calls, scu_occs :: ScUsage -> IdEnv ArgOcc
scu_occs = IdEnv ArgOcc
sc_occs }) [Id]
bndrs
  = (SCU {scu_calls :: CallEnv
scu_calls = CallEnv
sc_calls, scu_occs :: IdEnv ArgOcc
scu_occs = IdEnv ArgOcc -> [Id] -> IdEnv ArgOcc
forall a. VarEnv a -> [Id] -> VarEnv a
delVarEnvList IdEnv ArgOcc
sc_occs [Id]
bndrs},
     [IdEnv ArgOcc -> Id -> Maybe ArgOcc
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv ArgOcc
sc_occs Id
b Maybe ArgOcc -> ArgOcc -> ArgOcc
forall a. Maybe a -> a -> a
`orElse` ArgOcc
NoOcc | Id
b <- [Id]
bndrs])
data ArgOcc = NoOcc     
            | UnkOcc    
            | ScrutOcc  
                 (DataConEnv [ArgOcc])   
instance Outputable ArgOcc where
  ppr :: ArgOcc -> SDoc
ppr (ScrutOcc DataConEnv [ArgOcc]
xs) = String -> SDoc
text String
"scrut-occ" SDoc -> SDoc -> SDoc
<> DataConEnv [ArgOcc] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataConEnv [ArgOcc]
xs
  ppr ArgOcc
UnkOcc        = String -> SDoc
text String
"unk-occ"
  ppr ArgOcc
NoOcc         = String -> SDoc
text String
"no-occ"
evalScrutOcc :: ArgOcc
evalScrutOcc :: ArgOcc
evalScrutOcc = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
forall key elt. UniqFM key elt
emptyUFM
combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
combineOcc ArgOcc
NoOcc         ArgOcc
occ           = ArgOcc
occ
combineOcc ArgOcc
occ           ArgOcc
NoOcc         = ArgOcc
occ
combineOcc (ScrutOcc DataConEnv [ArgOcc]
xs) (ScrutOcc DataConEnv [ArgOcc]
ys) = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc (([ArgOcc] -> [ArgOcc] -> [ArgOcc])
-> DataConEnv [ArgOcc]
-> DataConEnv [ArgOcc]
-> DataConEnv [ArgOcc]
forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs DataConEnv [ArgOcc]
xs DataConEnv [ArgOcc]
ys)
combineOcc ArgOcc
UnkOcc        (ScrutOcc DataConEnv [ArgOcc]
ys) = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
ys
combineOcc (ScrutOcc DataConEnv [ArgOcc]
xs) ArgOcc
UnkOcc        = DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
xs
combineOcc ArgOcc
UnkOcc        ArgOcc
UnkOcc        = ArgOcc
UnkOcc
combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
combineOccs [ArgOcc]
xs [ArgOcc]
ys = String
-> (ArgOcc -> ArgOcc -> ArgOcc) -> [ArgOcc] -> [ArgOcc] -> [ArgOcc]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"combineOccs" ArgOcc -> ArgOcc -> ArgOcc
combineOcc [ArgOcc]
xs [ArgOcc]
ys
setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
setScrutOcc :: ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg (Cast Expr Id
e Coercion
_) ArgOcc
occ      = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg Expr Id
e ArgOcc
occ
setScrutOcc ScEnv
env ScUsage
usg (Tick CoreTickish
_ Expr Id
e) ArgOcc
occ      = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
usg Expr Id
e ArgOcc
occ
setScrutOcc ScEnv
env ScUsage
usg (Var Id
v)    ArgOcc
occ
  | Just HowBound
RecArg <- ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
v = ScUsage
usg { scu_occs :: IdEnv ArgOcc
scu_occs = IdEnv ArgOcc -> Id -> ArgOcc -> IdEnv ArgOcc
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv (ScUsage -> IdEnv ArgOcc
scu_occs ScUsage
usg) Id
v ArgOcc
occ }
  | Bool
otherwise                           = ScUsage
usg
setScrutOcc ScEnv
_env ScUsage
usg Expr Id
_other ArgOcc
_occ        
  = ScUsage
usg
scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
        
        
scExpr :: ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
e = ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr' ScEnv
env Expr Id
e
scExpr' :: ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr' ScEnv
env (Var Id
v)      = case ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
v of
                            Var Id
v' -> (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
v' [], Id -> Expr Id
forall b. Id -> Expr b
Var Id
v')
                            Expr Id
e'     -> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) Expr Id
e'
scExpr' ScEnv
env (Type Type
t)     = (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Type -> Expr Id
forall b. Type -> Expr b
Type (ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
t))
scExpr' ScEnv
env (Coercion Coercion
c) = (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Coercion -> Expr Id
forall b. Coercion -> Expr b
Coercion (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
c))
scExpr' ScEnv
_   e :: Expr Id
e@(Lit {})   = (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, Expr Id
e)
scExpr' ScEnv
env (Tick CoreTickish
t Expr Id
e)   = do (ScUsage
usg, Expr Id
e') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
e
                              (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, CoreTickish -> Expr Id -> Expr Id
forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t Expr Id
e')
scExpr' ScEnv
env (Cast Expr Id
e Coercion
co)  = do (ScUsage
usg, Expr Id
e') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
e
                              (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, Expr Id -> Coercion -> Expr Id
mkCast Expr Id
e' (ScEnv -> Coercion -> Coercion
scSubstCo ScEnv
env Coercion
co))
                              
                              
scExpr' ScEnv
env e :: Expr Id
e@(App Expr Id
_ Expr Id
_)  = ScEnv -> (Expr Id, [Expr Id]) -> UniqSM (ScUsage, Expr Id)
scApp ScEnv
env (Expr Id -> (Expr Id, [Expr Id])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr Id
e)
scExpr' ScEnv
env (Lam Id
b Expr Id
e)    = do let (ScEnv
env', Id
b') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
b
                              (ScUsage
usg, Expr Id
e') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env' Expr Id
e
                              (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg, Id -> Expr Id -> Expr Id
forall b. b -> Expr b -> Expr b
Lam Id
b' Expr Id
e')
scExpr' ScEnv
env (Case Expr Id
scrut Id
b Type
ty [Alt Id]
alts)
  = do  { (ScUsage
scrut_usg, Expr Id
scrut') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
scrut
        ; case ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
scrut' of
                Just (ConVal AltCon
con [Expr Id]
args) -> AltCon -> [Expr Id] -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_con_app AltCon
con [Expr Id]
args Expr Id
scrut'
                Maybe Value
_other                 -> ScUsage -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_vanilla ScUsage
scrut_usg Expr Id
scrut'
        }
  where
    sc_con_app :: AltCon -> [Expr Id] -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_con_app AltCon
con [Expr Id]
args Expr Id
scrut'  
     = do { let Alt AltCon
_ [Id]
bs Expr Id
rhs = AltCon -> [Alt Id] -> Maybe (Alt Id)
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
findAlt AltCon
con [Alt Id]
alts
                                  Maybe (Alt Id) -> Alt Id -> Alt Id
forall a. Maybe a -> a -> a
`orElse` AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (Type -> Expr Id
mkImpossibleExpr Type
ty)
                alt_env' :: ScEnv
alt_env'     = ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList ScEnv
env ((Id
b,Expr Id
scrut') (Id, Expr Id) -> [(Id, Expr Id)] -> [(Id, Expr Id)]
forall a. a -> [a] -> [a]
: [Id]
bs [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` AltCon -> [Expr Id] -> [Expr Id]
trimConArgs AltCon
con [Expr Id]
args)
          ; ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
alt_env' Expr Id
rhs }
    sc_vanilla :: ScUsage -> Expr Id -> UniqSM (ScUsage, Expr Id)
sc_vanilla ScUsage
scrut_usg Expr Id
scrut' 
     = do { let (ScEnv
alt_env,Id
b') = HowBound -> ScEnv -> Id -> (ScEnv, Id)
extendBndrWith HowBound
RecArg ScEnv
env Id
b
                        
          ; ([ScUsage]
alt_usgs, [ArgOcc]
alt_occs, [Alt Id]
alts')
                <- (Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id))
-> [Alt Id] -> UniqSM ([ScUsage], [ArgOcc], [Alt Id])
forall (m :: * -> *) a b c d.
Monad m =>
(a -> m (b, c, d)) -> [a] -> m ([b], [c], [d])
mapAndUnzip3M (ScEnv
-> Expr Id -> Id -> Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id)
sc_alt ScEnv
alt_env Expr Id
scrut' Id
b') [Alt Id]
alts
          ; let scrut_occ :: ArgOcc
scrut_occ  = (ArgOcc -> ArgOcc -> ArgOcc) -> ArgOcc -> [ArgOcc] -> ArgOcc
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ArgOcc -> ArgOcc -> ArgOcc
combineOcc ArgOcc
NoOcc [ArgOcc]
alt_occs
                scrut_usg' :: ScUsage
scrut_usg' = ScEnv -> ScUsage -> Expr Id -> ArgOcc -> ScUsage
setScrutOcc ScEnv
env ScUsage
scrut_usg Expr Id
scrut' ArgOcc
scrut_occ
                
                
                
          ; (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ScUsage -> ScUsage -> ScUsage) -> ScUsage -> [ScUsage] -> ScUsage
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ScUsage -> ScUsage -> ScUsage
combineUsage ScUsage
scrut_usg' [ScUsage]
alt_usgs,
                    Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr Id
scrut' Id
b' (ScEnv -> Type -> Type
scSubstTy ScEnv
env Type
ty) [Alt Id]
alts') }
    sc_alt :: ScEnv
-> Expr Id -> Id -> Alt Id -> UniqSM (ScUsage, ArgOcc, Alt Id)
sc_alt ScEnv
env Expr Id
scrut' Id
b' (Alt AltCon
con [Id]
bs Expr Id
rhs)
     = do { let (ScEnv
env1, [Id]
bs1) = HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
RecArg ScEnv
env [Id]
bs
                (ScEnv
env2, [Id]
bs2) = ScEnv -> Expr Id -> Id -> AltCon -> [Id] -> (ScEnv, [Id])
extendCaseBndrs ScEnv
env1 Expr Id
scrut' Id
b' AltCon
con [Id]
bs1
          ; (ScUsage
usg, Expr Id
rhs') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env2 Expr Id
rhs
          ; let (ScUsage
usg', ArgOcc
b_occ:[ArgOcc]
arg_occs) = ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs ScUsage
usg (Id
b'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bs2)
                scrut_occ :: ArgOcc
scrut_occ = case AltCon
con of
                               DataAlt DataCon
dc -> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc (DataCon -> [ArgOcc] -> DataConEnv [ArgOcc]
forall key elt. Uniquable key => key -> elt -> UniqFM key elt
unitUFM DataCon
dc [ArgOcc]
arg_occs)
                               AltCon
_          -> DataConEnv [ArgOcc] -> ArgOcc
ScrutOcc DataConEnv [ArgOcc]
forall key elt. UniqFM key elt
emptyUFM
          ; (ScUsage, ArgOcc, Alt Id) -> UniqSM (ScUsage, ArgOcc, Alt Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg', ArgOcc
b_occ ArgOcc -> ArgOcc -> ArgOcc
`combineOcc` ArgOcc
scrut_occ, AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs2 Expr Id
rhs') }
scExpr' ScEnv
env (Let (NonRec Id
bndr Expr Id
rhs) Expr Id
body)
  | Id -> Bool
isTyVar Id
bndr        
  = ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr' (ScEnv -> Id -> Expr Id -> ScEnv
extendScSubst ScEnv
env Id
bndr Expr Id
rhs) Expr Id
body
  | Bool
otherwise
  = do  { let (ScEnv
body_env, Id
bndr') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr
        ; RhsInfo
rhs_info  <- ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
env (Id
bndr',Expr Id
rhs)
        ; let body_env2 :: ScEnv
body_env2 = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
body_env [Id
bndr'] HowBound
RecFun
                           
              rhs' :: Expr Id
rhs'      = RhsInfo -> Expr Id
ri_new_rhs RhsInfo
rhs_info
              body_env3 :: ScEnv
body_env3 = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
body_env2 Id
bndr' (ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
rhs')
        ; (ScUsage
body_usg, Expr Id
body') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
body_env3 Expr Id
body
          
          
        ; (ScUsage
spec_usg, SpecInfo
specs) <- ScEnv -> ScUsage -> RhsInfo -> UniqSM (ScUsage, SpecInfo)
specNonRec ScEnv
env ScUsage
body_usg RhsInfo
rhs_info
        
        ; let spec_bnds :: Expr Id
spec_bnds = [CoreBind] -> Expr Id -> Expr Id
forall b. [Bind b] -> Expr b -> Expr b
mkLets [Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
b Expr Id
r | (Id
b,Expr Id
r) <- RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds RhsInfo
rhs_info SpecInfo
specs] Expr Id
body'
        
        ; (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usg { scu_calls :: CallEnv
scu_calls = ScUsage -> CallEnv
scu_calls ScUsage
body_usg CallEnv -> Id -> CallEnv
forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
bndr' }
                    ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usg,  
                  Expr Id
spec_bnds
                  )
        }
scExpr' ScEnv
env (Let (Rec [(Id, Expr Id)]
prs) Expr Id
body)
  = do  { let ([Id]
bndrs,[Expr Id]
rhss)      = [(Id, Expr Id)] -> ([Id], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
              (ScEnv
rhs_env1,[Id]
bndrs') = ScEnv -> [Id] -> (ScEnv, [Id])
extendRecBndrs ScEnv
env [Id]
bndrs
              rhs_env2 :: ScEnv
rhs_env2          = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
rhs_env1 [Id]
bndrs' HowBound
RecFun
              force_spec :: Bool
force_spec        = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env) [Id]
bndrs'
                
        ; [RhsInfo]
rhs_infos <- ((Id, Expr Id) -> UniqSM RhsInfo)
-> [(Id, Expr Id)] -> UniqSM [RhsInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
rhs_env2) ([Id]
bndrs' [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
rhss)
        ; (ScUsage
body_usg, Expr Id
body')     <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
rhs_env2 Expr Id
body
        
        ; (ScUsage
spec_usg, [SpecInfo]
specs) <- TopLevelFlag
-> ScEnv -> ScUsage -> [RhsInfo] -> UniqSM (ScUsage, [SpecInfo])
specRec TopLevelFlag
NotTopLevel (ScEnv -> Bool -> ScEnv
scForce ScEnv
rhs_env2 Bool
force_spec)
                                       ScUsage
body_usg [RhsInfo]
rhs_infos
                
                
                
        ; let all_usg :: ScUsage
all_usg = ScUsage
spec_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
body_usg  
              bind' :: CoreBind
bind'   = [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([[(Id, Expr Id)]] -> [(Id, Expr Id)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String
-> (RhsInfo -> SpecInfo -> [(Id, Expr Id)])
-> [RhsInfo]
-> [SpecInfo]
-> [[(Id, Expr Id)]]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"scExpr'" RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))
                        
                        
        ; (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
all_usg { scu_calls :: CallEnv
scu_calls = ScUsage -> CallEnv
scu_calls ScUsage
all_usg CallEnv -> [Id] -> CallEnv
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs' },
                  CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' Expr Id
body') }
scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
scApp :: ScEnv -> (Expr Id, [Expr Id]) -> UniqSM (ScUsage, Expr Id)
scApp ScEnv
env (Var Id
fn, [Expr Id]
args)        
  = Bool -> UniqSM (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([Expr Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Id]
args)) (UniqSM (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id))
-> UniqSM (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a b. (a -> b) -> a -> b
$
    do  { [(ScUsage, Expr Id)]
args_w_usgs <- (Expr Id -> UniqSM (ScUsage, Expr Id))
-> [Expr Id] -> UniqSM [(ScUsage, Expr Id)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env) [Expr Id]
args
        ; let ([ScUsage]
arg_usgs, [Expr Id]
args') = [(ScUsage, Expr Id)] -> ([ScUsage], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(ScUsage, Expr Id)]
args_w_usgs
              arg_usg :: ScUsage
arg_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs
        ; case ScEnv -> Id -> Expr Id
scSubstId ScEnv
env Id
fn of
            fn' :: Expr Id
fn'@(Lam {}) -> ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr (ScEnv -> ScEnv
zapScSubst ScEnv
env) (Expr Id -> [Expr Id] -> Expr Id
doBeta Expr Id
fn' [Expr Id]
args')
                        
            Var Id
fn' -> (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
fn' [Expr Id]
args',
                               Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> Expr Id
forall b. Id -> Expr b
Var Id
fn') [Expr Id]
args')
            Expr Id
other_fn' -> (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
arg_usg, Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
other_fn' [Expr Id]
args') }
                
                
                
  where
    doBeta :: OutExpr -> [OutExpr] -> OutExpr
    
    doBeta :: Expr Id -> [Expr Id] -> Expr Id
doBeta (Lam Id
bndr Expr Id
body) (Expr Id
arg : [Expr Id]
args) = CoreBind -> Expr Id -> Expr Id
forall b. Bind b -> Expr b -> Expr b
Let (Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr Expr Id
arg) (Expr Id -> [Expr Id] -> Expr Id
doBeta Expr Id
body [Expr Id]
args)
    doBeta Expr Id
fn              [Expr Id]
args         = Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
fn [Expr Id]
args
scApp ScEnv
env (Expr Id
other_fn, [Expr Id]
args)
  = do  { (ScUsage
fn_usg,   Expr Id
fn')   <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
other_fn
        ; ([ScUsage]
arg_usgs, [Expr Id]
args') <- (Expr Id -> UniqSM (ScUsage, Expr Id))
-> [Expr Id] -> UniqSM ([ScUsage], [Expr Id])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env) [Expr Id]
args
        ; (ScUsage, Expr Id) -> UniqSM (ScUsage, Expr Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ScUsage] -> ScUsage
combineUsages [ScUsage]
arg_usgs ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
fn_usg, Expr Id -> [Expr Id] -> Expr Id
forall b. Expr b -> [Expr b] -> Expr b
mkApps Expr Id
fn' [Expr Id]
args') }
mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
mkVarUsage :: ScEnv -> Id -> [Expr Id] -> ScUsage
mkVarUsage ScEnv
env Id
fn [Expr Id]
args
  = case ScEnv -> Id -> Maybe HowBound
lookupHowBound ScEnv
env Id
fn of
        Just HowBound
RecFun -> SCU { scu_calls :: CallEnv
scu_calls = Id -> [Call] -> CallEnv
forall a. Id -> a -> VarEnv a
unitVarEnv Id
fn [Id -> [Expr Id] -> ValueEnv -> Call
Call Id
fn [Expr Id]
args (ScEnv -> ValueEnv
sc_vals ScEnv
env)]
                           , scu_occs :: IdEnv ArgOcc
scu_occs  = IdEnv ArgOcc
forall a. VarEnv a
emptyVarEnv }
        Just HowBound
RecArg -> SCU { scu_calls :: CallEnv
scu_calls = CallEnv
forall a. VarEnv a
emptyVarEnv
                           , scu_occs :: IdEnv ArgOcc
scu_occs  = Id -> ArgOcc -> IdEnv ArgOcc
forall a. Id -> a -> VarEnv a
unitVarEnv Id
fn ArgOcc
arg_occ }
        Maybe HowBound
Nothing     -> ScUsage
nullUsage
  where
    
    arg_occ :: ArgOcc
arg_occ | [Expr Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expr Id]
args = ArgOcc
UnkOcc
            | Bool
otherwise = ArgOcc
evalScrutOcc
scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
scTopBindEnv ScEnv
env (Rec [(Id, Expr Id)]
prs)
  = do  { let (ScEnv
rhs_env1,[Id]
bndrs') = ScEnv -> [Id] -> (ScEnv, [Id])
extendRecBndrs ScEnv
env [Id]
bndrs
              rhs_env2 :: ScEnv
rhs_env2          = ScEnv -> [Id] -> HowBound -> ScEnv
extendHowBound ScEnv
rhs_env1 [Id]
bndrs HowBound
RecFun
              prs' :: [(Id, Expr Id)]
prs'              = [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs' [Expr Id]
rhss
        ; (ScEnv, CoreBind) -> UniqSM (ScEnv, CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
rhs_env2, [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, Expr Id)]
prs') }
  where
    ([Id]
bndrs,[Expr Id]
rhss) = [(Id, Expr Id)] -> ([Id], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
scTopBindEnv ScEnv
env (NonRec Id
bndr Expr Id
rhs)
  = do  { let (ScEnv
env1, Id
bndr') = ScEnv -> Id -> (ScEnv, Id)
extendBndr ScEnv
env Id
bndr
              env2 :: ScEnv
env2          = ScEnv -> Id -> Maybe Value -> ScEnv
extendValEnv ScEnv
env1 Id
bndr' (ValueEnv -> Expr Id -> Maybe Value
isValue (ScEnv -> ValueEnv
sc_vals ScEnv
env) Expr Id
rhs)
        ; (ScEnv, CoreBind) -> UniqSM (ScEnv, CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScEnv
env2, Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' Expr Id
rhs) }
scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
scTopBind ScEnv
env ScUsage
body_usage (Rec [(Id, Expr Id)]
prs)
  | Just Int
threshold <- ScEnv -> Maybe Int
sc_size ScEnv
env
  , Bool -> Bool
not Bool
force_spec
  , Bool -> Bool
not ((Expr Id -> Bool) -> [Expr Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UnfoldingOpts -> Int -> Expr Id -> Bool
couldBeSmallEnoughToInline (ScEnv -> UnfoldingOpts
sc_uf_opts ScEnv
env) Int
threshold) [Expr Id]
rhss)
                
  = 
    do  { ([ScUsage]
rhs_usgs, [Expr Id]
rhss')   <- (Expr Id -> UniqSM (ScUsage, Expr Id))
-> [Expr Id] -> UniqSM ([ScUsage], [Expr Id])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env) [Expr Id]
rhss
        ; (ScUsage, CoreBind) -> UniqSM (ScUsage, CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usage ScUsage -> ScUsage -> ScUsage
`combineUsage` [ScUsage] -> ScUsage
combineUsages [ScUsage]
rhs_usgs, [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id]
bndrs [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
rhss')) }
  | Bool
otherwise   
  = do  { [RhsInfo]
rhs_infos <- ((Id, Expr Id) -> UniqSM RhsInfo)
-> [(Id, Expr Id)] -> UniqSM [RhsInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
env) [(Id, Expr Id)]
prs
        ; (ScUsage
spec_usage, [SpecInfo]
specs) <- TopLevelFlag
-> ScEnv -> ScUsage -> [RhsInfo] -> UniqSM (ScUsage, [SpecInfo])
specRec TopLevelFlag
TopLevel (ScEnv -> Bool -> ScEnv
scForce ScEnv
env Bool
force_spec)
                                         ScUsage
body_usage [RhsInfo]
rhs_infos
        ; (ScUsage, CoreBind) -> UniqSM (ScUsage, CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
body_usage ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
spec_usage,
                  [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([[(Id, Expr Id)]] -> [(Id, Expr Id)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((RhsInfo -> SpecInfo -> [(Id, Expr Id)])
-> [RhsInfo] -> [SpecInfo] -> [[(Id, Expr Id)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds [RhsInfo]
rhs_infos [SpecInfo]
specs))) }
  where
    ([Id]
bndrs,[Expr Id]
rhss) = [(Id, Expr Id)] -> ([Id], [Expr Id])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, Expr Id)]
prs
    force_spec :: Bool
force_spec   = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ScEnv -> Id -> Bool
forceSpecBndr ScEnv
env) [Id]
bndrs
      
scTopBind ScEnv
env ScUsage
usage (NonRec Id
bndr Expr Id
rhs)   
  = do  { (ScUsage
rhs_usg', Expr Id
rhs') <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
env Expr Id
rhs
        ; (ScUsage, CoreBind) -> UniqSM (ScUsage, CoreBind)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usage ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
rhs_usg', Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr Expr Id
rhs') }
scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
scRecRhs :: ScEnv -> (Id, Expr Id) -> UniqSM RhsInfo
scRecRhs ScEnv
env (Id
bndr,Expr Id
rhs)
  = do  { let ([Id]
arg_bndrs,Expr Id
body)       = Expr Id -> ([Id], Expr Id)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr Id
rhs
              (ScEnv
body_env, [Id]
arg_bndrs') = HowBound -> ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrsWith HowBound
RecArg ScEnv
env [Id]
arg_bndrs
        ; (ScUsage
body_usg, Expr Id
body')         <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
body_env Expr Id
body
        ; let (ScUsage
rhs_usg, [ArgOcc]
arg_occs)    = ScUsage -> [Id] -> (ScUsage, [ArgOcc])
lookupOccs ScUsage
body_usg [Id]
arg_bndrs'
        ; RhsInfo -> UniqSM RhsInfo
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RI { ri_rhs_usg :: ScUsage
ri_rhs_usg = ScUsage
rhs_usg
                     , ri_fn :: Id
ri_fn = Id
bndr, ri_new_rhs :: Expr Id
ri_new_rhs = [Id] -> Expr Id -> Expr Id
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
arg_bndrs' Expr Id
body'
                     , ri_lam_bndrs :: [Id]
ri_lam_bndrs = [Id]
arg_bndrs, ri_lam_body :: Expr Id
ri_lam_body = Expr Id
body
                     , ri_arg_occs :: [ArgOcc]
ri_arg_occs = [ArgOcc]
arg_occs }) }
                
                
                
                
ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id, Expr Id)]
ruleInfoBinds (RI { ri_fn :: RhsInfo -> Id
ri_fn = Id
fn, ri_new_rhs :: RhsInfo -> Expr Id
ri_new_rhs = Expr Id
new_rhs })
              (SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
specs })
  = [(Id
id,Expr Id
rhs) | OS { os_id :: OneSpec -> Id
os_id = Id
id, os_rhs :: OneSpec -> Expr Id
os_rhs = Expr Id
rhs } <- [OneSpec]
specs] [(Id, Expr Id)] -> [(Id, Expr Id)] -> [(Id, Expr Id)]
forall a. [a] -> [a] -> [a]
++
              
    [(Id
fn Id -> [CoreRule] -> Id
`addIdSpecialisations` [CoreRule]
rules, Expr Id
new_rhs)]
              
  where
    rules :: [CoreRule]
rules = [CoreRule
r | OS { os_rule :: OneSpec -> CoreRule
os_rule = CoreRule
r } <- [OneSpec]
specs]
data RhsInfo
  = RI { RhsInfo -> Id
ri_fn :: OutId                 
       , RhsInfo -> Expr Id
ri_new_rhs :: OutExpr          
       , RhsInfo -> ScUsage
ri_rhs_usg :: ScUsage          
       , RhsInfo -> [Id]
ri_lam_bndrs :: [InVar]       
       , RhsInfo -> Expr Id
ri_lam_body  :: InExpr        
       , RhsInfo -> [ArgOcc]
ri_arg_occs  :: [ArgOcc]      
    }
data SpecInfo       
  = SI { SpecInfo -> [OneSpec]
si_specs :: [OneSpec]          
       , SpecInfo -> Int
si_n_specs :: Int              
       , SpecInfo -> Maybe ScUsage
si_mb_unspec :: Maybe ScUsage  
       }                                
                                        
                                        
                                        
                                        
                                        
                                        
                                        
        
data OneSpec =
  OS { OneSpec -> CallPat
os_pat  :: CallPat    
     , OneSpec -> CoreRule
os_rule :: CoreRule   
     , OneSpec -> Id
os_id   :: OutId      
     , OneSpec -> Expr Id
os_rhs  :: OutExpr }  
noSpecInfo :: SpecInfo
noSpecInfo :: SpecInfo
noSpecInfo = SI { si_specs :: [OneSpec]
si_specs = [], si_n_specs :: Int
si_n_specs = Int
0, si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
forall a. Maybe a
Nothing }
specNonRec :: ScEnv
           -> ScUsage         
           -> RhsInfo         
           -> UniqSM (ScUsage, SpecInfo)       
                                               
specNonRec :: ScEnv -> ScUsage -> RhsInfo -> UniqSM (ScUsage, SpecInfo)
specNonRec ScEnv
env ScUsage
body_usg RhsInfo
rhs_info
  = ScEnv
-> CallEnv -> RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo)
specialise ScEnv
env (ScUsage -> CallEnv
scu_calls ScUsage
body_usg) RhsInfo
rhs_info
               (SpecInfo
noSpecInfo { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = ScUsage -> Maybe ScUsage
forall a. a -> Maybe a
Just (RhsInfo -> ScUsage
ri_rhs_usg RhsInfo
rhs_info) })
specRec :: TopLevelFlag -> ScEnv
        -> ScUsage                         
        -> [RhsInfo]                       
        -> UniqSM (ScUsage, [SpecInfo])    
                                           
specRec :: TopLevelFlag
-> ScEnv -> ScUsage -> [RhsInfo] -> UniqSM (ScUsage, [SpecInfo])
specRec TopLevelFlag
top_lvl ScEnv
env ScUsage
body_usg [RhsInfo]
rhs_infos
  = Int
-> CallEnv -> ScUsage -> [SpecInfo] -> UniqSM (ScUsage, [SpecInfo])
go Int
1 CallEnv
seed_calls ScUsage
nullUsage [SpecInfo]
init_spec_infos
  where
    (CallEnv
seed_calls, [SpecInfo]
init_spec_infos)    
       | TopLevelFlag -> Bool
isTopLevel TopLevelFlag
top_lvl
       , (RhsInfo -> Bool) -> [RhsInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> Bool
isExportedId (Id -> Bool) -> (RhsInfo -> Id) -> RhsInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RhsInfo -> Id
ri_fn) [RhsInfo]
rhs_infos   
       = (CallEnv
all_calls,     [SpecInfo
noSpecInfo | RhsInfo
_ <- [RhsInfo]
rhs_infos])
       | Bool
otherwise                              
       = (CallEnv
calls_in_body, [SpecInfo
noSpecInfo { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = ScUsage -> Maybe ScUsage
forall a. a -> Maybe a
Just (RhsInfo -> ScUsage
ri_rhs_usg RhsInfo
ri) }
                         | RhsInfo
ri <- [RhsInfo]
rhs_infos])
    calls_in_body :: CallEnv
calls_in_body = ScUsage -> CallEnv
scu_calls ScUsage
body_usg
    calls_in_rhss :: CallEnv
calls_in_rhss = (RhsInfo -> CallEnv -> CallEnv) -> CallEnv -> [RhsInfo] -> CallEnv
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CallEnv -> CallEnv -> CallEnv
combineCalls (CallEnv -> CallEnv -> CallEnv)
-> (RhsInfo -> CallEnv) -> RhsInfo -> CallEnv -> CallEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScUsage -> CallEnv
scu_calls (ScUsage -> CallEnv) -> (RhsInfo -> ScUsage) -> RhsInfo -> CallEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RhsInfo -> ScUsage
ri_rhs_usg) CallEnv
forall a. VarEnv a
emptyVarEnv [RhsInfo]
rhs_infos
    all_calls :: CallEnv
all_calls = CallEnv
calls_in_rhss CallEnv -> CallEnv -> CallEnv
`combineCalls` CallEnv
calls_in_body
    
    go :: Int   
                
       -> CallEnv   
                    
       -> ScUsage      
       -> [SpecInfo]   
       -> UniqSM (ScUsage, [SpecInfo])
    go :: Int
-> CallEnv -> ScUsage -> [SpecInfo] -> UniqSM (ScUsage, [SpecInfo])
go Int
n_iter CallEnv
seed_calls ScUsage
usg_so_far [SpecInfo]
spec_infos
      | CallEnv -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv CallEnv
seed_calls
      = 
        
        
        (ScUsage, [SpecInfo]) -> UniqSM (ScUsage, [SpecInfo])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos)
      
      
      | Int
n_iter Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ScEnv -> Int
sc_recursive ScEnv
env  
      , ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (ScEnv -> Maybe Int
sc_count ScEnv
env)
           
           
      , (SpecInfo -> Bool) -> [SpecInfo] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
the_limit) (Int -> Bool) -> (SpecInfo -> Int) -> SpecInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecInfo -> Int
si_n_specs) [SpecInfo]
spec_infos
      = 
        (ScUsage, [SpecInfo]) -> UniqSM (ScUsage, [SpecInfo])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
usg_so_far, [SpecInfo]
spec_infos)
      | Bool
otherwise
      = 
        
        
        
        do  { [(ScUsage, SpecInfo)]
specs_w_usg <- (RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo))
-> [RhsInfo] -> [SpecInfo] -> UniqSM [(ScUsage, SpecInfo)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (ScEnv
-> CallEnv -> RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo)
specialise ScEnv
env CallEnv
seed_calls) [RhsInfo]
rhs_infos [SpecInfo]
spec_infos
            ; let ([ScUsage]
extra_usg_s, [SpecInfo]
new_spec_infos) = [(ScUsage, SpecInfo)] -> ([ScUsage], [SpecInfo])
forall a b. [(a, b)] -> ([a], [b])
unzip [(ScUsage, SpecInfo)]
specs_w_usg
                  extra_usg :: ScUsage
extra_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
extra_usg_s
                  all_usg :: ScUsage
all_usg   = ScUsage
usg_so_far ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
extra_usg
            ; Int
-> CallEnv -> ScUsage -> [SpecInfo] -> UniqSM (ScUsage, [SpecInfo])
go (Int
n_iter Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (ScUsage -> CallEnv
scu_calls ScUsage
extra_usg) ScUsage
all_usg [SpecInfo]
new_spec_infos }
    
    the_limit :: Int
the_limit = case ScEnv -> Maybe Int
sc_count ScEnv
env of
                  Maybe Int
Nothing  -> Int
10    
                  Just Int
max -> Int
max
specialise
   :: ScEnv
   -> CallEnv                     
   -> RhsInfo
   -> SpecInfo                    
   -> UniqSM (ScUsage, SpecInfo)  
specialise :: ScEnv
-> CallEnv -> RhsInfo -> SpecInfo -> UniqSM (ScUsage, SpecInfo)
specialise ScEnv
env CallEnv
bind_calls (RI { ri_fn :: RhsInfo -> Id
ri_fn = Id
fn, ri_lam_bndrs :: RhsInfo -> [Id]
ri_lam_bndrs = [Id]
arg_bndrs
                              , ri_lam_body :: RhsInfo -> Expr Id
ri_lam_body = Expr Id
body, ri_arg_occs :: RhsInfo -> [ArgOcc]
ri_arg_occs = [ArgOcc]
arg_occs })
               spec_info :: SpecInfo
spec_info@(SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
specs, si_n_specs :: SpecInfo -> Int
si_n_specs = Int
spec_count
                             , si_mb_unspec :: SpecInfo -> Maybe ScUsage
si_mb_unspec = Maybe ScUsage
mb_unspec })
  | Id -> Bool
isDeadEndId Id
fn  
                    
  = 
    (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info)
  | Bool -> Bool
not (Activation -> Bool
isNeverActive (Id -> Activation
idInlineActivation Id
fn))
      
      
      
      
      
      
      
  , Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
arg_bndrs)                         
  , Just [Call]
all_calls <- CallEnv -> Id -> Maybe [Call]
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv CallEnv
bind_calls Id
fn 
  = 
    do  { (Bool
boring_call, [CallPat]
new_pats) <- ScEnv
-> Id -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
callsToNewPats ScEnv
env Id
fn SpecInfo
spec_info [ArgOcc]
arg_occs [Call]
all_calls
        ; let n_pats :: Int
n_pats = [CallPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CallPat]
new_pats
        ; let spec_env :: ScEnv
spec_env = ScEnv -> Int -> ScEnv
decreaseSpecCount ScEnv
env Int
n_pats
        ; ([ScUsage]
spec_usgs, [OneSpec]
new_specs) <- ((CallPat, Int) -> UniqSM (ScUsage, OneSpec))
-> [(CallPat, Int)] -> UniqSM ([ScUsage], [OneSpec])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM (ScEnv
-> Id
-> [Id]
-> Expr Id
-> (CallPat, Int)
-> UniqSM (ScUsage, OneSpec)
spec_one ScEnv
spec_env Id
fn [Id]
arg_bndrs Expr Id
body)
                                                 ([CallPat]
new_pats [CallPat] -> [Int] -> [(CallPat, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
spec_count..])
                
        ; let spec_usg :: ScUsage
spec_usg = [ScUsage] -> ScUsage
combineUsages [ScUsage]
spec_usgs
              
              
              
              
              (ScUsage
new_usg, Maybe ScUsage
mb_unspec')
                  = case Maybe ScUsage
mb_unspec of
                      Just ScUsage
rhs_usg | Bool
boring_call -> (ScUsage
spec_usg ScUsage -> ScUsage -> ScUsage
`combineUsage` ScUsage
rhs_usg, Maybe ScUsage
forall a. Maybe a
Nothing)
                      Maybe ScUsage
_                          -> (ScUsage
spec_usg,                      Maybe ScUsage
mb_unspec)
          ; (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
new_usg, SI { si_specs :: [OneSpec]
si_specs = [OneSpec]
new_specs [OneSpec] -> [OneSpec] -> [OneSpec]
forall a. [a] -> [a] -> [a]
++ [OneSpec]
specs
                                , si_n_specs :: Int
si_n_specs = Int
spec_count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n_pats
                                , si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
mb_unspec' }) }
  | Bool
otherwise  
               
  = 
    case Maybe ScUsage
mb_unspec of    
      Just ScUsage
rhs_usg -> (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
rhs_usg, SpecInfo
spec_info { si_mb_unspec :: Maybe ScUsage
si_mb_unspec = Maybe ScUsage
forall a. Maybe a
Nothing })
                         
      Maybe ScUsage
Nothing      -> (ScUsage, SpecInfo) -> UniqSM (ScUsage, SpecInfo)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
nullUsage, SpecInfo
spec_info)
spec_one :: ScEnv
         -> OutId       
         -> [InVar]     
         -> InExpr      
         -> (CallPat, Int)
         -> UniqSM (ScUsage, OneSpec)   
spec_one :: ScEnv
-> Id
-> [Id]
-> Expr Id
-> (CallPat, Int)
-> UniqSM (ScUsage, OneSpec)
spec_one ScEnv
env Id
fn [Id]
arg_bndrs Expr Id
body (CallPat
call_pat, Int
rule_number)
  | CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qvars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
pats, cp_strict_args :: CallPat -> [Id]
cp_strict_args = [Id]
cbv_args } <- CallPat
call_pat
  = do  { Unique
spec_uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
        ; let env1 :: ScEnv
env1 = ScEnv -> [(Id, Expr Id)] -> ScEnv
extendScSubstList (ScEnv -> [Id] -> ScEnv
extendScInScope ScEnv
env [Id]
qvars)
                                       ([Id]
arg_bndrs [Id] -> [Expr Id] -> [(Id, Expr Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Id]
pats)
              (ScEnv
body_env, [Id]
extra_bndrs) = ScEnv -> [Id] -> (ScEnv, [Id])
extendBndrs ScEnv
env1 ([Expr Id] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
dropList [Expr Id]
pats [Id]
arg_bndrs)
              
              
              
              
              
              
              fn_name :: Name
fn_name  = Id -> Name
idName Id
fn
              fn_loc :: SrcSpan
fn_loc   = Name -> SrcSpan
nameSrcSpan Name
fn_name
              fn_occ :: OccName
fn_occ   = Name -> OccName
nameOccName Name
fn_name
              spec_occ :: OccName
spec_occ = OccName -> OccName
mkSpecOcc OccName
fn_occ
              
              
              
              
              rule_name :: FastString
rule_name  = String -> FastString
mkFastString (String
"SC:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
fn_occ String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rule_number)
              spec_name :: Name
spec_name  = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
spec_uniq OccName
spec_occ SrcSpan
fn_loc
        
        
        ; (ScUsage
spec_usg, Expr Id
spec_body) <- ScEnv -> Expr Id -> UniqSM (ScUsage, Expr Id)
scExpr ScEnv
body_env Expr Id
body
                
        ; let spec_body_ty :: Type
spec_body_ty = (() :: Constraint) => Expr Id -> Type
Expr Id -> Type
exprType Expr Id
spec_body
              ([Id]
spec_lam_args, [Id]
spec_call_args, DmdSig
spec_sig)
                  = Id -> [Id] -> CallPat -> [Id] -> ([Id], [Id], DmdSig)
calcSpecInfo Id
fn [Id]
arg_bndrs CallPat
call_pat [Id]
extra_bndrs
              spec_arity :: Int
spec_arity = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
spec_lam_args
              spec_join_arity :: Maybe Int
spec_join_arity | Id -> Bool
isJoinId Id
fn = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
spec_call_args)
                              | Bool
otherwise   = Maybe Int
forall a. Maybe a
Nothing
              spec_id :: Id
spec_id    = Id -> Id
asWorkerLikeId (Id -> Id) -> Id -> Id
forall a b. (a -> b) -> a -> b
$
                           (() :: Constraint) => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
spec_name Type
Many
                                     ([Id] -> Type -> Type
mkLamTypes [Id]
spec_lam_args Type
spec_body_ty)
                             
                             Id -> DmdSig -> Id
`setIdDmdSig`    DmdSig
spec_sig
                             Id -> CprSig -> Id
`setIdCprSig`    CprSig
topCprSig
                             Id -> Int -> Id
`setIdArity`     Int
spec_arity
                             Id -> Maybe Int -> Id
`asJoinId_maybe` Maybe Int
spec_join_arity
        
              spec_rhs :: Expr Id
spec_rhs = [Id] -> Expr Id -> Expr Id
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
spec_lam_args ([Id] -> Type -> Expr Id -> Expr Id
mkSeqs [Id]
cbv_args Type
spec_body_ty Expr Id
spec_body)
              rule_rhs :: Expr Id
rule_rhs = Expr Id -> [Id] -> Expr Id
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> Expr Id
forall b. Id -> Expr b
Var Id
spec_id) [Id]
spec_call_args
              inline_act :: Activation
inline_act = Id -> Activation
idInlineActivation Id
fn
              this_mod :: Module
this_mod   = ScEnv -> Module
sc_module ScEnv
env
              rule :: CoreRule
rule       = Module
-> Bool
-> Bool
-> FastString
-> Activation
-> Name
-> [Id]
-> [Expr Id]
-> Expr Id
-> CoreRule
mkRule Module
this_mod Bool
True  Bool
True 
                                  FastString
rule_name Activation
inline_act Name
fn_name [Id]
qvars [Expr Id]
pats Expr Id
rule_rhs
                           
        
        
        
        
        
        
        
        
        
        
        
        
        
        
        
        ; (ScUsage, OneSpec) -> UniqSM (ScUsage, OneSpec)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScUsage
spec_usg, OS { os_pat :: CallPat
os_pat = CallPat
call_pat, os_rule :: CoreRule
os_rule = CoreRule
rule
                               , os_id :: Id
os_id = Id
spec_id
                               , os_rhs :: Expr Id
os_rhs = Expr Id
spec_rhs }) }
mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr
mkSeqs :: [Id] -> Type -> Expr Id -> Expr Id
mkSeqs [Id]
seqees Type
res_ty Expr Id
rhs =
  (Id -> Expr Id -> Expr Id) -> Expr Id -> [Id] -> Expr Id
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> Expr Id -> Expr Id
addEval Expr Id
rhs [Id]
seqees
    where
      addEval :: Var -> CoreExpr -> CoreExpr
      addEval :: Id -> Expr Id -> Expr Id
addEval Id
arg_id Expr Id
rhs
        
        | Id -> Bool
shouldStrictifyIdForCbv Id
arg_id
        = Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Id -> Expr Id
forall b. Id -> Expr b
Var Id
arg_id) Id
arg_id Type
res_ty ([AltCon -> [Id] -> Expr Id -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] Expr Id
rhs])
        | Bool
otherwise
        = Expr Id
rhs
calcSpecInfo :: Id           
             -> [InVar]      
             -> CallPat      
             -> [Var]        
             -> ( [Var]           
                                  
                , [Var]           
                , DmdSig )        
calcSpecInfo :: Id -> [Id] -> CallPat -> [Id] -> ([Id], [Id], DmdSig)
calcSpecInfo Id
fn [Id]
arg_bndrs (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qvars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
pats }) [Id]
extra_bndrs
  = ( [Id]
spec_lam_bndrs_w_dmds
    , [Id]
spec_call_args
    , DmdSig -> DmdSig
zapDmdEnvSig (DmdType -> DmdSig
DmdSig (DmdType
dt{dt_args :: [Demand]
dt_args = [Demand]
spec_fn_dmds})) )
  where
    DmdSig dt :: DmdType
dt@DmdType{dt_args :: DmdType -> [Demand]
dt_args=[Demand]
fn_dmds} = Id -> DmdSig
idDmdSig Id
fn
    spec_fn_dmds :: [Demand]
spec_fn_dmds = [Id -> Demand
idDemandInfo Id
b | Id
b <- [Id]
spec_lam_bndrs_w_dmds, Id -> Bool
isId Id
b]
    val_pats :: [Expr Id]
val_pats   = (Expr Id -> Bool) -> [Expr Id] -> [Expr Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Expr Id -> Bool
forall b. Expr b -> Bool
isTypeArg [Expr Id]
pats
                 
                 
    arg_dmd_env :: VarEnv Demand
arg_dmd_env = VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go VarEnv Demand
forall a. VarEnv a
emptyVarEnv [Demand]
fn_dmds [Expr Id]
val_pats
    qvar_dmds :: [Demand]
qvar_dmds  = [ VarEnv Demand -> Id -> Maybe Demand
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Demand
arg_dmd_env Id
qv Maybe Demand -> Demand -> Demand
forall a. Maybe a -> a -> a
`orElse` Demand
topDmd | Id
qv <- [Id]
qvars, Id -> Bool
isId Id
qv ]
    extra_dmds :: [Demand]
extra_dmds = [Expr Id] -> [Demand] -> [Demand]
forall b a. [b] -> [a] -> [a]
dropList [Expr Id]
val_pats [Demand]
fn_dmds
    
    
    qvars_w_dmds :: [Id]
qvars_w_dmds          = [Id] -> [Demand] -> [Id]
set_dmds [Id]
qvars       [Demand]
qvar_dmds
    extras_w_dmds :: [Id]
extras_w_dmds         = [Id] -> [Demand] -> [Id]
set_dmds [Id]
extra_bndrs [Demand]
extra_dmds
    spec_lam_bndrs_w_dmds :: [Id]
spec_lam_bndrs_w_dmds = [Id]
final_qvars_w_dmds [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
extras_w_dmds
    ([Id]
final_qvars_w_dmds, [Id]
spec_call_args)
       | Id -> [Id] -> [Id] -> Bool
needsVoidWorkerArg Id
fn [Id]
arg_bndrs ([Id]
qvars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
extra_bndrs)
         
         
         
       = ( [Id]
qvars_w_dmds [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidArgId], [Id]
qvars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id
voidPrimId] )
       | Bool
otherwise
       = ( [Id]
qvars_w_dmds,                [Id]
qvars )
    set_dmds :: [Var] -> [Demand] -> [Var]
    set_dmds :: [Id] -> [Demand] -> [Id]
set_dmds [] [Demand]
_   = []
    set_dmds [Id]
vs  [] = [Id]
vs  
    set_dmds (Id
v:[Id]
vs) ds :: [Demand]
ds@(Demand
d:[Demand]
ds') | Id -> Bool
isTyVar Id
v = Id
v                   Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id] -> [Demand] -> [Id]
set_dmds [Id]
vs [Demand]
ds
                               | Bool
otherwise = Id -> Demand -> Id
setIdDemandInfo Id
v Demand
d Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id] -> [Demand] -> [Id]
set_dmds [Id]
vs [Demand]
ds'
    go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand
    
    go :: VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go VarEnv Demand
env (Demand
d:[Demand]
ds) (Expr Id
pat : [Expr Id]
pats)     = VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go (VarEnv Demand -> Demand -> Expr Id -> VarEnv Demand
go_one VarEnv Demand
env Demand
d Expr Id
pat) [Demand]
ds [Expr Id]
pats
    go VarEnv Demand
env [Demand]
_      [Expr Id]
_                = VarEnv Demand
env
    go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand
    go_one :: VarEnv Demand -> Demand -> Expr Id -> VarEnv Demand
go_one VarEnv Demand
env Demand
d          (Var Id
v) = (Demand -> Demand -> Demand)
-> VarEnv Demand -> Id -> Demand -> VarEnv Demand
forall a. (a -> a -> a) -> VarEnv a -> Id -> a -> VarEnv a
extendVarEnv_C Demand -> Demand -> Demand
plusDmd VarEnv Demand
env Id
v Demand
d
    go_one VarEnv Demand
env (Card
_n :* SubDemand
cd) Expr Id
e 
      | (Var Id
_, [Expr Id]
args) <- Expr Id -> (Expr Id, [Expr Id])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs Expr Id
e
      , Just (Boxity
_b, [Demand]
ds) <- Int -> SubDemand -> Maybe (Boxity, [Demand])
viewProd ([Expr Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Id]
args) SubDemand
cd 
      = VarEnv Demand -> [Demand] -> [Expr Id] -> VarEnv Demand
go VarEnv Demand
env [Demand]
ds [Expr Id]
args
    go_one VarEnv Demand
env Demand
_  Expr Id
_ = VarEnv Demand
env
data CallPat = CP { CallPat -> [Id]
cp_qvars :: [Var]           
                  , CallPat -> [Expr Id]
cp_args  :: [CoreExpr]      
                  , CallPat -> [Id]
cp_strict_args :: [Var] }   
     
instance Outputable CallPat where
  ppr :: CallPat -> SDoc
ppr (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qvars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
args, cp_strict_args :: CallPat -> [Id]
cp_strict_args =  [Id]
strict })
    = String -> SDoc
text String
"CP" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"cp_qvars =" SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
qvars SDoc -> SDoc -> SDoc
<> SDoc
comma
                               , String -> SDoc
text String
"cp_args =" SDoc -> SDoc -> SDoc
<+> [Expr Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Id]
args
                               , String -> SDoc
text String
"cp_strict_args = " SDoc -> SDoc -> SDoc
<> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
strict ])
callsToNewPats :: ScEnv -> Id
               -> SpecInfo
               -> [ArgOcc] -> [Call]
               -> UniqSM (Bool, [CallPat])
        
        
        
callsToNewPats :: ScEnv
-> Id -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])
callsToNewPats ScEnv
env Id
fn spec_info :: SpecInfo
spec_info@(SI { si_specs :: SpecInfo -> [OneSpec]
si_specs = [OneSpec]
done_specs }) [ArgOcc]
bndr_occs [Call]
calls
  = do  { [Maybe CallPat]
mb_pats <- (Call -> UniqSM (Maybe CallPat))
-> [Call] -> UniqSM [Maybe CallPat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPats ScEnv
env [ArgOcc]
bndr_occs) [Call]
calls
        ; let have_boring_call :: Bool
have_boring_call = (Maybe CallPat -> Bool) -> [Maybe CallPat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Maybe CallPat -> Bool
forall a. Maybe a -> Bool
isNothing [Maybe CallPat]
mb_pats
              good_pats :: [CallPat]
              good_pats :: [CallPat]
good_pats = [Maybe CallPat] -> [CallPat]
forall a. [Maybe a] -> [a]
catMaybes [Maybe CallPat]
mb_pats
              
              new_pats :: [CallPat]
new_pats = (CallPat -> Bool) -> [CallPat] -> [CallPat]
forall a. (a -> Bool) -> [a] -> [a]
filterOut CallPat -> Bool
is_done [CallPat]
good_pats
              is_done :: CallPat -> Bool
is_done CallPat
p = (OneSpec -> Bool) -> [OneSpec] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CallPat -> CallPat -> Bool
samePat CallPat
p (CallPat -> Bool) -> (OneSpec -> CallPat) -> OneSpec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneSpec -> CallPat
os_pat) [OneSpec]
done_specs
              
              non_dups :: [CallPat]
non_dups = (CallPat -> CallPat -> Bool) -> [CallPat] -> [CallPat]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy CallPat -> CallPat -> Bool
samePat [CallPat]
new_pats
              
              small_pats :: [CallPat]
small_pats = (CallPat -> Bool) -> [CallPat] -> [CallPat]
forall a. (a -> Bool) -> [a] -> [a]
filterOut CallPat -> Bool
too_big [CallPat]
non_dups
              max_args :: Int
max_args = DynFlags -> Int
maxWorkerArgs (ScEnv -> DynFlags
sc_dflags ScEnv
env)
              too_big :: CallPat -> Bool
too_big (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
vars, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
args })
                = Bool -> Bool
not (Int -> Int -> [Id] -> Bool
isWorkerSmallEnough Int
max_args ([Expr Id] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr Id]
args) [Id]
vars)
                  
                  
                  
                
              (Bool
pats_were_discarded, [CallPat]
trimmed_pats) = ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
trim_pats ScEnv
env Id
fn SpecInfo
spec_info [CallPat]
small_pats
        ; (Bool, [CallPat]) -> UniqSM (Bool, [CallPat])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
have_boring_call Bool -> Bool -> Bool
|| Bool
pats_were_discarded, [CallPat]
trimmed_pats) }
          
          
          
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
trim_pats ScEnv
env Id
fn (SI { si_n_specs :: SpecInfo -> Int
si_n_specs = Int
done_spec_count }) [CallPat]
pats
  | ScEnv -> Bool
sc_force ScEnv
env
    Bool -> Bool -> Bool
|| Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Int
mb_scc
    Bool -> Bool -> Bool
|| Int
n_remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n_pats
  = 
    (Bool
False, [CallPat]
pats)          
  | Bool
otherwise
  = (Bool, [CallPat]) -> (Bool, [CallPat])
emit_trace ((Bool, [CallPat]) -> (Bool, [CallPat]))
-> (Bool, [CallPat]) -> (Bool, [CallPat])
forall a b. (a -> b) -> a -> b
$  
    (Bool
True, Int -> [CallPat] -> [CallPat]
forall a. Int -> [a] -> [a]
take Int
n_remaining [CallPat]
sorted_pats)
  where
    n_pats :: Int
n_pats         = [CallPat] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CallPat]
pats
    spec_count' :: Int
spec_count'    = Int
n_pats Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
done_spec_count
    n_remaining :: Int
n_remaining    = Int
max_specs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
done_spec_count
    mb_scc :: Maybe Int
mb_scc         = ScEnv -> Maybe Int
sc_count ScEnv
env
    Just Int
max_specs = Maybe Int
mb_scc
    sorted_pats :: [CallPat]
sorted_pats = ((CallPat, Int) -> CallPat) -> [(CallPat, Int)] -> [CallPat]
forall a b. (a -> b) -> [a] -> [b]
map (CallPat, Int) -> CallPat
forall a b. (a, b) -> a
fst ([(CallPat, Int)] -> [CallPat]) -> [(CallPat, Int)] -> [CallPat]
forall a b. (a -> b) -> a -> b
$
                  ((CallPat, Int) -> (CallPat, Int) -> Ordering)
-> [(CallPat, Int)] -> [(CallPat, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((CallPat, Int) -> Int)
-> (CallPat, Int) -> (CallPat, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (CallPat, Int) -> Int
forall a b. (a, b) -> b
snd) ([(CallPat, Int)] -> [(CallPat, Int)])
-> [(CallPat, Int)] -> [(CallPat, Int)]
forall a b. (a -> b) -> a -> b
$
                  [(CallPat
pat, CallPat -> Int
pat_cons CallPat
pat) | CallPat
pat <- [CallPat]
pats]
     
     
     
    pat_cons :: CallPat -> Int
    
    
    pat_cons :: CallPat -> Int
pat_cons (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
qs, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
ps })
       = (Expr Id -> Int -> Int) -> Int -> [Expr Id] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> (Expr Id -> Int) -> Expr Id -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Id -> Int
n_cons) Int
0 [Expr Id]
ps
       where
          q_set :: CoVarSet
q_set = [Id] -> CoVarSet
mkVarSet [Id]
qs
          n_cons :: Expr Id -> Int
n_cons (Var Id
v) | Id
v Id -> CoVarSet -> Bool
`elemVarSet` CoVarSet
q_set = Int
0
                         | Bool
otherwise            = Int
1
          n_cons (Cast Expr Id
e Coercion
_)  = Expr Id -> Int
n_cons Expr Id
e
          n_cons (App Expr Id
e1 Expr Id
e2) = Expr Id -> Int
n_cons Expr Id
e1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Expr Id -> Int
n_cons Expr Id
e2
          n_cons (Lit {})    = Int
1
          n_cons Expr Id
_           = Int
0
    emit_trace :: (Bool, [CallPat]) -> (Bool, [CallPat])
emit_trace (Bool, [CallPat])
result
       | Bool
debugIsOn Bool -> Bool -> Bool
|| DynFlags -> Bool
hasPprDebug (ScEnv -> DynFlags
sc_dflags ScEnv
env)
         
       = String -> SDoc -> (Bool, [CallPat]) -> (Bool, [CallPat])
forall a. String -> SDoc -> a -> a
pprTrace String
"SpecConstr" SDoc
msg (Bool, [CallPat])
result
       | Bool
otherwise
       = (Bool, [CallPat])
result
    msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Function" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn)
                     , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"has" SDoc -> SDoc -> SDoc
<+>
                               Int -> SDoc -> SDoc
speakNOf Int
spec_count' (String -> SDoc
text String
"call pattern") SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
                               String -> SDoc
text String
"but the limit is" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
max_specs) ]
               , String -> SDoc
text String
"Use -fspec-constr-count=n to set the bound"
               , String -> SDoc
text String
"done_spec_count =" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
done_spec_count
               , String -> SDoc
text String
"Keeping " SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n_remaining SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", out of" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
n_pats
               , String -> SDoc
text String
"Discarding:" SDoc -> SDoc -> SDoc
<+> [CallPat] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> [CallPat] -> [CallPat]
forall a. Int -> [a] -> [a]
drop Int
n_remaining [CallPat]
sorted_pats) ]
callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
        
        
        
        
callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
callToPats ScEnv
env [ArgOcc]
bndr_occs call :: Call
call@(Call Id
fn [Expr Id]
args ValueEnv
con_env)
  = do  { let in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
substInScope (ScEnv -> Subst
sc_subst ScEnv
env)
        ; [(Bool, Expr Id, [Id])]
arg_tripples <- (Expr Id
 -> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id]))
-> [Expr Id]
-> [ArgOcc]
-> [StrictnessMark]
-> UniqSM [(Bool, Expr Id, [Id])]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M (ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
con_env) [Expr Id]
args [ArgOcc]
bndr_occs ((Expr Id -> StrictnessMark) -> [Expr Id] -> [StrictnessMark]
forall a b. (a -> b) -> [a] -> [b]
map (StrictnessMark -> Expr Id -> StrictnessMark
forall a b. a -> b -> a
const StrictnessMark
NotMarkedStrict) [Expr Id]
args)
                   
                   
          
          
        ; let arg_tripples' :: [(Bool, Expr Id, [Id])]
arg_tripples' | Id -> Bool
isJoinId Id
fn = [(Bool, Expr Id, [Id])]
arg_tripples
                            | Bool
otherwise   = ((Bool, Expr Id, [Id]) -> Bool)
-> [(Bool, Expr Id, [Id])] -> [(Bool, Expr Id, [Id])]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (Bool, Expr Id, [Id]) -> Bool
forall {b} {c}. (Bool, b, c) -> Bool
is_boring [(Bool, Expr Id, [Id])]
arg_tripples
              is_boring :: (Bool, b, c) -> Bool
is_boring (Bool
interesting, b
_,c
_) = Bool -> Bool
not Bool
interesting
              ([Bool]
interesting_s, [Expr Id]
pats, [[Id]]
cbv_ids) = [(Bool, Expr Id, [Id])] -> ([Bool], [Expr Id], [[Id]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Bool, Expr Id, [Id])]
arg_tripples'
              interesting :: Bool
interesting           = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
interesting_s
        ; let pat_fvs :: [Id]
pat_fvs = [Expr Id] -> [Id]
exprsFreeVarsList [Expr Id]
pats
                
                
                
                
                
                
              in_scope_vars :: CoVarSet
in_scope_vars = InScopeSet -> CoVarSet
getInScopeVars InScopeSet
in_scope
              is_in_scope :: Id -> Bool
is_in_scope Id
v = Id
v Id -> CoVarSet -> Bool
`elemVarSet` CoVarSet
in_scope_vars
              qvars :: [Id]
qvars         = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Id -> Bool
is_in_scope [Id]
pat_fvs
                
                
                
                
              ([Id]
ktvs, [Id]
ids)   = (Id -> Bool) -> [Id] -> ([Id], [Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
qvars
              qvars' :: [Id]
qvars'        = [Id] -> [Id]
scopedSort [Id]
ktvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ (Id -> Id) -> [Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Id
sanitise [Id]
ids
                
                
                
              sanitise :: Id -> Id
sanitise Id
id   = (Type -> Type) -> Id -> Id
updateIdTypeAndMult Type -> Type
expandTypeSynonyms Id
id
                
              
              bad_covars :: CoVarSet
              bad_covars :: CoVarSet
bad_covars = (Expr Id -> CoVarSet) -> [Expr Id] -> CoVarSet
forall a. (a -> CoVarSet) -> [a] -> CoVarSet
mapUnionVarSet Expr Id -> CoVarSet
get_bad_covars [Expr Id]
pats
              get_bad_covars :: CoreArg -> CoVarSet
              get_bad_covars :: Expr Id -> CoVarSet
get_bad_covars (Type Type
ty) = (Id -> Bool) -> CoVarSet -> CoVarSet
filterVarSet Id -> Bool
bad_covar (Type -> CoVarSet
tyCoVarsOfType Type
ty)
              get_bad_covars Expr Id
_         = CoVarSet
emptyVarSet
              bad_covar :: Id -> Bool
bad_covar Id
v = Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
is_in_scope Id
v)
        ; 
          Bool
-> String
-> SDoc
-> UniqSM (Maybe CallPat)
-> UniqSM (Maybe CallPat)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (CoVarSet -> Bool
isEmptyVarSet CoVarSet
bad_covars))
              String
"SpecConstr: bad covars"
              (CoVarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoVarSet
bad_covars SDoc -> SDoc -> SDoc
$$ Call -> SDoc
forall a. Outputable a => a -> SDoc
ppr Call
call) (UniqSM (Maybe CallPat) -> UniqSM (Maybe CallPat))
-> UniqSM (Maybe CallPat) -> UniqSM (Maybe CallPat)
forall a b. (a -> b) -> a -> b
$
          if Bool
interesting Bool -> Bool -> Bool
&& CoVarSet -> Bool
isEmptyVarSet CoVarSet
bad_covars
          then do
              
              
              
              
              
              
              
              
              Maybe CallPat -> UniqSM (Maybe CallPat)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CallPat -> Maybe CallPat
forall a. a -> Maybe a
Just (CP { cp_qvars :: [Id]
cp_qvars = [Id]
qvars', cp_args :: [Expr Id]
cp_args = [Expr Id]
pats, cp_strict_args :: [Id]
cp_strict_args = [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Id]]
cbv_ids }))
          else Maybe CallPat -> UniqSM (Maybe CallPat)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CallPat
forall a. Maybe a
Nothing }
    
    
    
    
    
argToPat :: ScEnv
         -> InScopeSet                  
         -> ValueEnv                    
         -> CoreArg                     
         -> ArgOcc
         -> StrictnessMark              
                                        
         -> UniqSM (Bool, CoreArg, [Id])
argToPat :: ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
  = do
    
    !(Bool, Expr Id, [Id])
res <- ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
    
    (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, Expr Id, [Id])
res
argToPat1 :: ScEnv
  -> InScopeSet
  -> ValueEnv
  -> Expr CoreBndr
  -> ArgOcc
  -> StrictnessMark
  -> UniqSM (Bool, Expr CoreBndr, [Id])
argToPat1 :: ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat1 ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env arg :: Expr Id
arg@(Type {}) ArgOcc
_arg_occ StrictnessMark
_arg_str
  = (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Expr Id
arg, [])
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Tick CoreTickish
_ Expr Id
arg) ArgOcc
arg_occ StrictnessMark
arg_str
  = ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
        
        
        
        
        
        
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Let CoreBind
_ Expr Id
arg) ArgOcc
arg_occ StrictnessMark
arg_str
  = ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
        
        
        
        
        
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Cast Expr Id
arg Coercion
co) ArgOcc
arg_occ StrictnessMark
arg_str
  | Bool -> Bool
not (ScEnv -> Type -> Bool
ignoreType ScEnv
env Type
ty2)
  = do  { (Bool
interesting, Expr Id
arg', [Id]
strict_args) <- ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
arg_str
        ; if Bool -> Bool
not Bool
interesting then
                Type -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id])
wildCardPat Type
ty2 StrictnessMark
arg_str
          else do
        { 
          Unique
uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
        ; let co_name :: Name
co_name = Unique -> FastString -> Name
mkSysTvName Unique
uniq (String -> FastString
fsLit String
"sg")
              co_var :: Id
co_var  = Name -> Type -> Id
mkCoVar Name
co_name (Role -> Type -> Type -> Type
mkCoercionType Role
Representational Type
ty1 Type
ty2)
        ; (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
interesting, Expr Id -> Coercion -> Expr Id
forall b. Expr b -> Coercion -> Expr b
Cast Expr Id
arg' (Id -> Coercion
mkCoVarCo Id
co_var), [Id]
strict_args) } }
  where
    Pair Type
ty1 Type
ty2 = Coercion -> Pair Type
coercionKind Coercion
co
  
  
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env Expr Id
arg ArgOcc
arg_occ StrictnessMark
_arg_str
  | Just (ConVal (DataAlt DataCon
dc) [Expr Id]
args) <- ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
val_env Expr Id
arg
  , Bool -> Bool
not (ScEnv -> DataCon -> Bool
ignoreDataCon ScEnv
env DataCon
dc)        
  , Just [ArgOcc]
arg_occs <- DataCon -> Maybe [ArgOcc]
mb_scrut DataCon
dc
  = do { let ([Expr Id]
ty_args, [Expr Id]
rest_args) = [Id] -> [Expr Id] -> ([Expr Id], [Expr Id])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList (DataCon -> [Id]
dataConUnivTyVars DataCon
dc) [Expr Id]
args
             con_str, matched_str :: [StrictnessMark]
             
             
             con_str :: [StrictnessMark]
con_str = DataCon -> [StrictnessMark]
dataConRepStrictness DataCon
dc
             matched_str :: [StrictnessMark]
matched_str = [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
con_str [Expr Id]
rest_args
      
      
      
      
      
       ; [(Bool, Expr Id, [Id])]
prs <- (Expr Id
 -> ArgOcc -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id]))
-> [Expr Id]
-> [ArgOcc]
-> [StrictnessMark]
-> UniqSM [(Bool, Expr Id, [Id])]
forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M (ScEnv
-> InScopeSet
-> ValueEnv
-> Expr Id
-> ArgOcc
-> StrictnessMark
-> UniqSM (Bool, Expr Id, [Id])
argToPat ScEnv
env InScopeSet
in_scope ValueEnv
val_env) [Expr Id]
rest_args [ArgOcc]
arg_occs [StrictnessMark]
matched_str
       ; let args' :: [Expr Id]
args' = ((Bool, Expr Id, [Id]) -> Expr Id)
-> [(Bool, Expr Id, [Id])] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Expr Id, [Id]) -> Expr Id
forall a b c. (a, b, c) -> b
sndOf3 [(Bool, Expr Id, [Id])]
prs :: [CoreArg]
       ; Bool -> SDoc -> UniqSM () -> UniqSM ()
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([StrictnessMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictnessMark]
con_str Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Expr Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Expr Id -> Bool) -> [Expr Id] -> [Expr Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Expr Id -> Bool
isRuntimeArg [Expr Id]
rest_args))
            ( [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
con_str SDoc -> SDoc -> SDoc
$$ [Expr Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Id]
rest_args SDoc -> SDoc -> SDoc
$$
              Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([StrictnessMark] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StrictnessMark]
con_str) SDoc -> SDoc -> SDoc
$$ Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Expr Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Id]
rest_args)
            ) (UniqSM () -> UniqSM ()) -> UniqSM () -> UniqSM ()
forall a b. (a -> b) -> a -> b
$ () -> UniqSM ()
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       ; (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, DataCon -> [Expr Id] -> Expr Id
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
dc ([Expr Id]
ty_args [Expr Id] -> [Expr Id] -> [Expr Id]
forall a. [a] -> [a] -> [a]
++ [Expr Id]
args'), [[Id]] -> [Id]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((Bool, Expr Id, [Id]) -> [Id])
-> [(Bool, Expr Id, [Id])] -> [[Id]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Expr Id, [Id]) -> [Id]
forall a b c. (a, b, c) -> c
thdOf3 [(Bool, Expr Id, [Id])]
prs)) }
  where
    mb_scrut :: DataCon -> Maybe [ArgOcc]
mb_scrut DataCon
dc = case ArgOcc
arg_occ of
                ScrutOcc DataConEnv [ArgOcc]
bs | Just [ArgOcc]
occs <- DataConEnv [ArgOcc] -> DataCon -> Maybe [ArgOcc]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM DataConEnv [ArgOcc]
bs DataCon
dc
                            -> [ArgOcc] -> Maybe [ArgOcc]
forall a. a -> Maybe a
Just ([ArgOcc]
occs)  
                ArgOcc
_other      | ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| ScEnv -> Bool
sc_keen ScEnv
env
                            -> [ArgOcc] -> Maybe [ArgOcc]
forall a. a -> Maybe a
Just (ArgOcc -> [ArgOcc]
forall a. a -> [a]
repeat ArgOcc
UnkOcc)
                            | Bool
otherwise
                            -> Maybe [ArgOcc]
forall a. Maybe a
Nothing
    match_vals :: [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
bangs (Expr Id
arg:[Expr Id]
args)
      | Expr Id -> Bool
forall b. Expr b -> Bool
isTypeArg Expr Id
arg
      = StrictnessMark
NotMarkedStrict StrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
: [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
bangs [Expr Id]
args
      | (StrictnessMark
b:[StrictnessMark]
bs) <- [StrictnessMark]
bangs
      = StrictnessMark
b StrictnessMark -> [StrictnessMark] -> [StrictnessMark]
forall a. a -> [a] -> [a]
: [StrictnessMark] -> [Expr Id] -> [StrictnessMark]
match_vals [StrictnessMark]
bs [Expr Id]
args
    match_vals [] [] = []
    match_vals [StrictnessMark]
as [Expr Id]
bs =
        String -> SDoc -> [StrictnessMark]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"spec-constr:argToPat - Bangs don't match value arguments"
            (String -> SDoc
text String
"arg:" SDoc -> SDoc -> SDoc
<> Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
arg SDoc -> SDoc -> SDoc
$$
             String -> SDoc
text String
"remaining args:" SDoc -> SDoc -> SDoc
<> [StrictnessMark] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StrictnessMark]
as SDoc -> SDoc -> SDoc
$$
             String -> SDoc
text String
"remaining bangs:" SDoc -> SDoc -> SDoc
<> [Expr Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Id]
bs)
  
  
  
  
  
  
  
argToPat1 ScEnv
env InScopeSet
in_scope ValueEnv
val_env (Var Id
v) ArgOcc
arg_occ StrictnessMark
arg_str
  | ScEnv -> Bool
sc_force ScEnv
env Bool -> Bool -> Bool
|| case ArgOcc
arg_occ of { ScrutOcc {} -> Bool
True
                                    ; ArgOcc
UnkOcc      -> Bool
False
                                    ; ArgOcc
NoOcc       -> Bool
False } 
  , Bool
is_value                                                 
       
       
       
  , Bool -> Bool
not (ScEnv -> Type -> Bool
ignoreType ScEnv
env (Id -> Type
varType Id
v))
  
  = (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Id -> Expr Id
forall b. Id -> Expr b
Var Id
v, if StrictnessMark -> Bool
isMarkedStrict StrictnessMark
arg_str then [Id
v] else [Id]
forall a. Monoid a => a
mempty)
  where
    is_value :: Bool
is_value
        | Id -> Bool
isLocalId Id
v = Id
v Id -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
in_scope
                        Bool -> Bool -> Bool
&& Maybe Value -> Bool
forall a. Maybe a -> Bool
isJust (ValueEnv -> Id -> Maybe Value
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ValueEnv
val_env Id
v)
                
        | Bool
otherwise   = Unfolding -> Bool
isValueUnfolding (Id -> Unfolding
idUnfolding Id
v)
                
  
  
  
  
        
        
        
        
        
  
  
argToPat1 ScEnv
_env InScopeSet
_in_scope ValueEnv
_val_env Expr Id
arg ArgOcc
_arg_occ StrictnessMark
arg_str
  = Type -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id])
wildCardPat ((() :: Constraint) => Expr Id -> Type
Expr Id -> Type
exprType Expr Id
arg) StrictnessMark
arg_str
wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])
wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, Expr Id, [Id])
wildCardPat Type
ty StrictnessMark
str
  = do { Id
id <- FastString -> Type -> Type -> UniqSM Id
forall (m :: * -> *).
MonadUnique m =>
FastString -> Type -> Type -> m Id
mkSysLocalOrCoVarM (String -> FastString
fsLit String
"sc") Type
Many Type
ty
       
       ; (Bool, Expr Id, [Id]) -> UniqSM (Bool, Expr Id, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Id -> Expr Id
forall b. Id -> Expr b
varToCoreExpr Id
id, if StrictnessMark -> Bool
isMarkedStrict StrictnessMark
str then [Id
id] else []) }
isValue :: ValueEnv -> CoreExpr -> Maybe Value
isValue :: ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
_env (Lit Literal
lit)
  | Literal -> Bool
litIsLifted Literal
lit = Maybe Value
forall a. Maybe a
Nothing
  | Bool
otherwise       = Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal (Literal -> AltCon
LitAlt Literal
lit) [])
isValue ValueEnv
env (Var Id
v)
  | Just Value
cval <- ValueEnv -> Id -> Maybe Value
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ValueEnv
env Id
v
  = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
cval  
               
               
  | Bool -> Bool
not (Id -> Bool
isLocalId Id
v) Bool -> Bool -> Bool
&& Unfolding -> Bool
isCheapUnfolding Unfolding
unf
  = ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env (Unfolding -> Expr Id
unfoldingTemplate Unfolding
unf)
  where
    unf :: Unfolding
unf = Id -> Unfolding
idUnfolding Id
v
        
        
isValue ValueEnv
env (Lam Id
b Expr Id
e)
  | Id -> Bool
isTyVar Id
b = case ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env Expr Id
e of
                  Just Value
_  -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal
                  Maybe Value
Nothing -> Maybe Value
forall a. Maybe a
Nothing
  | Bool
otherwise = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal
isValue ValueEnv
env (Tick CoreTickish
t Expr Id
e)
  | Bool -> Bool
not (CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode CoreTickish
t)
  = ValueEnv -> Expr Id -> Maybe Value
isValue ValueEnv
env Expr Id
e
isValue ValueEnv
_env Expr Id
expr       
  | (Var Id
fun, [Expr Id]
args, [CoreTickish]
_) <- (CoreTickish -> Bool)
-> Expr Id -> (Expr Id, [Expr Id], [CoreTickish])
forall b.
(CoreTickish -> Bool)
-> Expr b -> (Expr b, [Expr b], [CoreTickish])
collectArgsTicks (Bool -> Bool
not (Bool -> Bool) -> (CoreTickish -> Bool) -> CoreTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode) Expr Id
expr
  = case Id -> Maybe DataCon
isDataConWorkId_maybe Id
fun of
        Just DataCon
con | [Expr Id]
args [Expr Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtLeast` DataCon -> Int
dataConRepArity DataCon
con
                
                
                -> Value -> Maybe Value
forall a. a -> Maybe a
Just (AltCon -> [Expr Id] -> Value
ConVal (DataCon -> AltCon
DataAlt DataCon
con) [Expr Id]
args)
        Maybe DataCon
_other | [Expr Id] -> Int
forall b. [Arg b] -> Int
valArgCount [Expr Id]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Id -> Int
idArity Id
fun
                
               -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
LambdaVal        
        Maybe DataCon
_other -> Maybe Value
forall a. Maybe a
Nothing
isValue ValueEnv
_env Expr Id
_expr = Maybe Value
forall a. Maybe a
Nothing
valueIsWorkFree :: Value -> Bool
valueIsWorkFree :: Value -> Bool
valueIsWorkFree Value
LambdaVal       = Bool
True
valueIsWorkFree (ConVal AltCon
_ [Expr Id]
args) = (Expr Id -> Bool) -> [Expr Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Expr Id -> Bool
exprIsWorkFree [Expr Id]
args
samePat :: CallPat -> CallPat -> Bool
samePat :: CallPat -> CallPat -> Bool
samePat (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
vs1, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
as1 })
        (CP { cp_qvars :: CallPat -> [Id]
cp_qvars = [Id]
vs2, cp_args :: CallPat -> [Expr Id]
cp_args = [Expr Id]
as2 })
  = (Expr Id -> Expr Id -> Bool) -> [Expr Id] -> [Expr Id] -> Bool
forall a b. (a -> b -> Bool) -> [a] -> [b] -> Bool
all2 Expr Id -> Expr Id -> Bool
same [Expr Id]
as1 [Expr Id]
as2
  where
    
    same :: Expr Id -> Expr Id -> Bool
same (Var Id
v1) (Var Id
v2)
        | Id
v1 Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs1 = Id
v2 Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs2
        | Id
v2 Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
vs2 = Bool
False
        | Bool
otherwise     = Id
v1 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
v2
    same (Lit Literal
l1)    (Lit Literal
l2)    = Literal
l1Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
==Literal
l2
    same (App Expr Id
f1 Expr Id
a1) (App Expr Id
f2 Expr Id
a2) = Expr Id -> Expr Id -> Bool
same Expr Id
f1 Expr Id
f2 Bool -> Bool -> Bool
&& Expr Id -> Expr Id -> Bool
same Expr Id
a1 Expr Id
a2
    same (Type {}) (Type {}) = Bool
True     
    same (Coercion {}) (Coercion {}) = Bool
True
    same (Tick CoreTickish
_ Expr Id
e1) Expr Id
e2 = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2  
    same (Cast Expr Id
e1 Coercion
_) Expr Id
e2 = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
    same Expr Id
e1 (Tick CoreTickish
_ Expr Id
e2) = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
    same Expr Id
e1 (Cast Expr Id
e2 Coercion
_) = Expr Id -> Expr Id -> Bool
same Expr Id
e1 Expr Id
e2
    same Expr Id
e1 Expr Id
e2 = Bool -> String -> SDoc -> Bool -> Bool
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Expr Id -> Bool
forall b. Expr b -> Bool
bad Expr Id
e1 Bool -> Bool -> Bool
|| Expr Id -> Bool
forall b. Expr b -> Bool
bad Expr Id
e2) String
"samePat" (Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
e1 SDoc -> SDoc -> SDoc
$$ Expr Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Id
e2) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
                 Bool
False  
    bad :: Expr b -> Bool
bad (Case {}) = Bool
True
    bad (Let {})  = Bool
True
    bad (Lam {})  = Bool
True
    bad Expr b
_other    = Bool
False