{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.HsToCore.Binds
( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
, dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
, dsWarnOrphanRule
)
where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Config
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Module
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
import GHC.HsToCore.Monad
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
import GHC.Hs
import GHC.Core
import GHC.Core.SimpleOpt ( simpleOptExpr )
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Core.Make
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( etaExpand )
import GHC.Core.Unfold.Make
import GHC.Core.FVs
import GHC.Core.Predicate
import GHC.Core.TyCon
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.Multiplicity
import GHC.Core.Rules
import GHC.Core.TyCo.Compare( eqType )
import GHC.Builtin.Names
import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
import GHC.Tc.Types.Evidence
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Var( EvVar )
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.Graph.Directed
import GHC.Data.Bag
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (EvVar, CoreExpr))
dsTopLHsBinds LHsBinds GhcTc
binds
| Bool -> Bool
not (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
unlifted_binds) Bool -> Bool -> Bool
|| Bool -> Bool
not (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bang_binds)
= do { (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (BindsType
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall {a}.
BindsType
-> GenLocated (SrcSpanAnn' a) (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err BindsType
UnliftedTypeBinds) Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
unlifted_binds
; (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (BindsType
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall {a}.
BindsType
-> GenLocated (SrcSpanAnn' a) (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err BindsType
StrictBinds) Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bang_binds
; OrdList (EvVar, CoreExpr) -> DsM (OrdList (EvVar, CoreExpr))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList (EvVar, CoreExpr)
forall a. OrdList a
nilOL }
| Bool
otherwise
= do { ([EvVar]
force_vars, [(EvVar, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
do { Bool
xstrict <- Extension -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.Strict
; Bool -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr ([EvVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
force_vars Bool -> Bool -> Bool
|| Bool
xstrict) (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [EvVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
force_vars) }
; OrdList (EvVar, CoreExpr) -> DsM (OrdList (EvVar, CoreExpr))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(EvVar, CoreExpr)] -> OrdList (EvVar, CoreExpr)
forall a. [a] -> OrdList a
toOL [(EvVar, CoreExpr)]
prs) }
where
unlifted_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
unlifted_binds = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBindLR GhcTc GhcTc -> Bool
isUnliftedHsBind (HsBindLR GhcTc GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds
bang_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
bang_binds = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBindLR GhcTc GhcTc -> Bool
isBangedHsBind (HsBindLR GhcTc GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc)
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> HsBindLR GhcTc GhcTc
forall l e. GenLocated l e -> e
unLoc) LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds
top_level_err :: BindsType
-> GenLocated (SrcSpanAnn' a) (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err BindsType
bindsType (L SrcSpanAnn' a
loc HsBindLR GhcTc GhcTc
bind)
= SrcSpan
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (BindsType -> HsBindLR GhcTc GhcTc -> DsMessage
DsTopLevelBindsNotAllowed BindsType
bindsType HsBindLR GhcTc GhcTc
bind)
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds :: LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
= do { Bag ([EvVar], [(EvVar, CoreExpr)])
ds_bs <- (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Bag ([EvVar], [(EvVar, CoreExpr)]))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBind LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)]))
-> (([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)]))
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bag ([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)])
forall r a. (r -> r -> r) -> (a -> r) -> r -> Bag a -> r
foldBag (\([EvVar]
a, [(EvVar, CoreExpr)]
a') ([EvVar]
b, [(EvVar, CoreExpr)]
b') -> ([EvVar]
a [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
b, [(EvVar, CoreExpr)]
a' [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(EvVar, CoreExpr)]
b'))
([EvVar], [(EvVar, CoreExpr)]) -> ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> a
id ([], []) Bag ([EvVar], [(EvVar, CoreExpr)])
ds_bs) }
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsLHsBind :: LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBind (L SrcSpanAnnA
loc HsBindLR GhcTc GhcTc
bind) = do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
SrcSpan
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$ DynFlags
-> HsBindLR GhcTc GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsHsBind DynFlags
dflags HsBindLR GhcTc GhcTc
bind
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsHsBind :: DynFlags
-> HsBindLR GhcTc GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsHsBind DynFlags
dflags (VarBind { var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP GhcTc
var
, var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
expr })
= do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; let core_bind :: (EvVar, CoreExpr)
core_bind@(EvVar
id,CoreExpr
_) = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags IdP GhcTc
EvVar
var Bool
False Arity
0 CoreExpr
core_expr
force_var :: [EvVar]
force_var = if Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
then [EvVar
id]
else []
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_var, [(EvVar, CoreExpr)
core_bind]) }
dsHsBind DynFlags
dflags b :: HsBindLR GhcTc GhcTc
b@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L SrcSpanAnnN
loc EvVar
fun
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
matches
, fun_ext :: forall idL idR. HsBindLR idL idR -> XFunBind idL idR
fun_ext = (HsWrapper
co_fn, [CoreTickish]
tick)
})
= do { ([EvVar]
args, CoreExpr
body) <- Origin
-> Bag EvVar -> DsM ([EvVar], CoreExpr) -> DsM ([EvVar], CoreExpr)
forall a. Origin -> Bag EvVar -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag EvVar
hsWrapDictBinders HsWrapper
co_fn) (DsM ([EvVar], CoreExpr) -> DsM ([EvVar], CoreExpr))
-> DsM ([EvVar], CoreExpr) -> DsM ([EvVar], CoreExpr)
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([EvVar], CoreExpr)
matchWrapper (LIdP (NoGhcTc GhcRn) -> HsMatchContext GhcRn
forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (EvVar -> Name
idName EvVar
fun))) Maybe [LHsExpr GhcTc]
Maybe [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
co_fn
; let body' :: CoreExpr
body' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
body
rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
core_wrap ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
args CoreExpr
body')
core_binds :: (EvVar, CoreExpr)
core_binds@(EvVar
id,CoreExpr
_) = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
fun Bool
False Arity
0 CoreExpr
rhs
force_var :: [EvVar]
force_var
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcTc (LHsExpr GhcTc)
MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
matches Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
= [EvVar
id]
| HsBindLR GhcTc GhcTc -> Bool
isBangedHsBind HsBindLR GhcTc GhcTc
b
= [EvVar
id]
| Bool
otherwise
= []
;
([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_var, [(EvVar, CoreExpr)
core_binds]) }
dsHsBind DynFlags
dflags (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
grhss
, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = (Type
ty, ([CoreTickish]
rhs_tick, [[CoreTickish]]
var_ticks))
})
= do { NonEmpty Nablas
rhss_nablas <- HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContext GhcRn
forall p. HsMatchContext p
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; CoreExpr
body_expr <- GRHSs GhcTc (LHsExpr GhcTc)
-> Type -> NonEmpty Nablas -> DsM CoreExpr
dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
ty NonEmpty Nablas
rhss_nablas
; let body' :: CoreExpr
body' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
rhs_tick CoreExpr
body_expr
pat' :: LPat GhcTc
pat' = DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
pat
; (EvVar
force_var,[(EvVar, CoreExpr)]
sel_binds) <- [[CoreTickish]]
-> LPat GhcTc -> CoreExpr -> DsM (EvVar, [(EvVar, CoreExpr)])
mkSelectorBinds [[CoreTickish]]
var_ticks LPat GhcTc
pat CoreExpr
body'
; let force_var' :: [EvVar]
force_var' = if LPat GhcTc -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isBangedLPat LPat GhcTc
pat'
then [EvVar
force_var]
else []
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_var', [(EvVar, CoreExpr)]
sel_binds) }
dsHsBind
DynFlags
dflags
(XHsBindsLR (AbsBinds { abs_tvs :: AbsBinds -> [EvVar]
abs_tvs = [EvVar]
tyvars, abs_ev_vars :: AbsBinds -> [EvVar]
abs_ev_vars = [EvVar]
dicts
, abs_exports :: AbsBinds -> [ABExport]
abs_exports = [ABExport]
exports
, abs_ev_binds :: AbsBinds -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
, abs_binds :: AbsBinds -> LHsBinds GhcTc
abs_binds = LHsBinds GhcTc
binds, abs_sig :: AbsBinds -> Bool
abs_sig = Bool
has_sig }))
= do { ([EvVar], [(EvVar, CoreExpr)])
ds_binds <- Origin
-> Bag EvVar
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. Origin -> Bag EvVar -> DsM a -> DsM a
addTyCs Origin
FromSource ([EvVar] -> Bag EvVar
forall a. [a] -> Bag a
listToBag [EvVar]
dicts) (DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$
LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; [CoreBind]
ds_ev_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
; DynFlags
-> [EvVar]
-> [EvVar]
-> [ABExport]
-> [CoreBind]
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bool
-> DsM ([EvVar], [(EvVar, CoreExpr)])
dsAbsBinds DynFlags
dflags [EvVar]
tyvars [EvVar]
dicts [ABExport]
exports [CoreBind]
ds_ev_binds ([EvVar], [(EvVar, CoreExpr)])
ds_binds Bool
has_sig }
dsHsBind DynFlags
_ (PatSynBind{}) = String -> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. HasCallStack => String -> a
panic String
"dsHsBind: PatSynBind"
dsAbsBinds :: DynFlags
-> [TyVar] -> [EvVar] -> [ABExport]
-> [CoreBind]
-> ([Id], [(Id,CoreExpr)])
-> Bool
-> DsM ([Id], [(Id,CoreExpr)])
dsAbsBinds :: DynFlags
-> [EvVar]
-> [EvVar]
-> [ABExport]
-> [CoreBind]
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bool
-> DsM ([EvVar], [(EvVar, CoreExpr)])
dsAbsBinds DynFlags
dflags [EvVar]
tyvars [EvVar]
dicts [ABExport]
exports
[CoreBind]
ds_ev_binds ([EvVar]
force_vars, [(EvVar, CoreExpr)]
bind_prs) Bool
has_sig
| [ABExport
export] <- [ABExport]
exports
, ABE { abe_poly :: ABExport -> EvVar
abe_poly = EvVar
global_id, abe_mono :: ABExport -> EvVar
abe_mono = EvVar
local_id
, abe_wrap :: ABExport -> HsWrapper
abe_wrap = HsWrapper
wrap, abe_prags :: ABExport -> TcSpecPrags
abe_prags = TcSpecPrags
prags } <- ABExport
export
, Just [EvVar]
force_vars' <- case [EvVar]
force_vars of
[] -> [EvVar] -> Maybe [EvVar]
forall a. a -> Maybe a
Just []
[EvVar
v] | EvVar
v EvVar -> EvVar -> Bool
forall a. Eq a => a -> a -> Bool
== EvVar
local_id -> [EvVar] -> Maybe [EvVar]
forall a. a -> Maybe a
Just [EvVar
global_id]
[EvVar]
_ -> Maybe [EvVar]
forall a. Maybe a
Nothing
= do { CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; let rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
core_wrap (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
body
body :: CoreExpr
body | Bool
has_sig
, [(EvVar
_, CoreExpr
lrhs)] <- [(EvVar, CoreExpr)]
bind_prs
= CoreExpr
lrhs
| Bool
otherwise
= [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
forall b. [(b, Expr b)] -> Expr b -> Expr b
mkLetRec [(EvVar, CoreExpr)]
bind_prs (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
local_id)
; (OrdList (EvVar, CoreExpr)
spec_binds, [CoreRule]
rules) <- CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs TcSpecPrags
prags
; let global_id' :: EvVar
global_id' = EvVar -> [CoreRule] -> EvVar
addIdSpecialisations EvVar
global_id [CoreRule]
rules
main_bind :: (EvVar, CoreExpr)
main_bind = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
global_id'
(TcSpecPrags -> Bool
isDefaultMethod TcSpecPrags
prags)
([EvVar] -> Arity
dictArity [EvVar]
dicts) CoreExpr
rhs
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_vars', (EvVar, CoreExpr)
main_bind (EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
: OrdList (EvVar, CoreExpr) -> [(EvVar, CoreExpr)]
forall a. OrdList a -> [a]
fromOL OrdList (EvVar, CoreExpr)
spec_binds) }
| [EvVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
tyvars, [EvVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
dicts
= do { let mk_main :: ABExport -> DsM (Id, CoreExpr)
mk_main :: ABExport -> DsM (EvVar, CoreExpr)
mk_main (ABE { abe_poly :: ABExport -> EvVar
abe_poly = EvVar
gbl_id, abe_mono :: ABExport -> EvVar
abe_mono = EvVar
lcl_id
, abe_wrap :: ABExport -> HsWrapper
abe_wrap = HsWrapper
wrap })
= do { CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; (EvVar, CoreExpr) -> DsM (EvVar, CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( EvVar
gbl_id EvVar -> InlinePragma -> EvVar
`setInlinePragma` InlinePragma
defaultInlinePragma
, CoreExpr -> CoreExpr
core_wrap (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
lcl_id)) }
; [(EvVar, CoreExpr)]
main_prs <- (ABExport -> DsM (EvVar, CoreExpr))
-> [ABExport] -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
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 ABExport -> DsM (EvVar, CoreExpr)
mk_main [ABExport]
exports
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_vars, [CoreBind] -> [(EvVar, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [CoreBind]
ds_ev_binds
[(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
mk_aux_binds [(EvVar, CoreExpr)]
bind_prs [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(EvVar, CoreExpr)]
main_prs ) }
| Bool
otherwise
= do { let aux_binds :: CoreBind
aux_binds = [(EvVar, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
mk_aux_binds [(EvVar, CoreExpr)]
bind_prs)
new_force_vars :: [EvVar]
new_force_vars = [EvVar] -> [EvVar]
forall {t :: * -> *}. Foldable t => t EvVar -> [EvVar]
get_new_force_vars [EvVar]
force_vars
locals :: [EvVar]
locals = (ABExport -> EvVar) -> [ABExport] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map ABExport -> EvVar
abe_mono [ABExport]
exports
all_locals :: [EvVar]
all_locals = [EvVar]
locals [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
new_force_vars
tup_expr :: CoreExpr
tup_expr = [EvVar] -> CoreExpr
mkBigCoreVarTup [EvVar]
all_locals
tup_ty :: Type
tup_ty = (() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
tup_expr
; let poly_tup_rhs :: CoreExpr
poly_tup_rhs = [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
mkLet CoreBind
aux_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
tup_expr
; EvVar
poly_tup_id <- Type -> Type -> DsM EvVar
newSysLocalDs Type
ManyTy ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
poly_tup_rhs)
; ([EvVar]
exported_force_vars, [ABExport]
extra_exports) <- [EvVar] -> DsM ([EvVar], [ABExport])
get_exports [EvVar]
force_vars
; let mk_bind :: ABExport -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
mk_bind (ABE { abe_wrap :: ABExport -> HsWrapper
abe_wrap = HsWrapper
wrap
, abe_poly :: ABExport -> EvVar
abe_poly = EvVar
global
, abe_mono :: ABExport -> EvVar
abe_mono = EvVar
local, abe_prags :: ABExport -> TcSpecPrags
abe_prags = TcSpecPrags
spec_prags })
= do { EvVar
tup_id <- Type -> Type -> DsM EvVar
newSysLocalDs Type
ManyTy Type
tup_ty
; CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; let rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
core_wrap (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[EvVar] -> EvVar -> EvVar -> CoreExpr -> CoreExpr
mkBigTupleSelector [EvVar]
all_locals EvVar
local EvVar
tup_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [EvVar] -> CoreExpr
forall b. Expr b -> [EvVar] -> Expr b
mkVarApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
poly_tup_id) ([EvVar]
tyvars [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
dicts)
rhs_for_spec :: CoreExpr
rhs_for_spec = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (EvVar -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec EvVar
poly_tup_id CoreExpr
poly_tup_rhs) CoreExpr
rhs
; (OrdList (EvVar, CoreExpr)
spec_binds, [CoreRule]
rules) <- CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs_for_spec TcSpecPrags
spec_prags
; let global' :: EvVar
global' = (EvVar
global EvVar -> InlinePragma -> EvVar
`setInlinePragma` InlinePragma
defaultInlinePragma)
EvVar -> [CoreRule] -> EvVar
`addIdSpecialisations` [CoreRule]
rules
; [(EvVar, CoreExpr)]
-> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((EvVar
global', CoreExpr
rhs) (EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
: OrdList (EvVar, CoreExpr) -> [(EvVar, CoreExpr)]
forall a. OrdList a -> [a]
fromOL OrdList (EvVar, CoreExpr)
spec_binds) }
; [[(EvVar, CoreExpr)]]
export_binds_s <- (ABExport -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)])
-> [ABExport]
-> IOEnv (Env DsGblEnv DsLclEnv) [[(EvVar, CoreExpr)]]
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 ABExport -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
mk_bind ([ABExport]
exports [ABExport] -> [ABExport] -> [ABExport]
forall a. [a] -> [a] -> [a]
++ [ABExport]
extra_exports)
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [EvVar]
exported_force_vars
, (EvVar
poly_tup_id, CoreExpr
poly_tup_rhs) (EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
:
[[(EvVar, CoreExpr)]] -> [(EvVar, CoreExpr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(EvVar, CoreExpr)]]
export_binds_s) }
where
mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
mk_aux_binds :: [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
mk_aux_binds [(EvVar, CoreExpr)]
bind_prs = [ DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
lcl_w_inline Bool
False Arity
0 CoreExpr
rhs
| (EvVar
lcl_id, CoreExpr
rhs) <- [(EvVar, CoreExpr)]
bind_prs
, let lcl_w_inline :: EvVar
lcl_w_inline = VarEnv EvVar -> EvVar -> Maybe EvVar
forall a. VarEnv a -> EvVar -> Maybe a
lookupVarEnv VarEnv EvVar
inline_env EvVar
lcl_id
Maybe EvVar -> EvVar -> EvVar
forall a. Maybe a -> a -> a
`orElse` EvVar
lcl_id ]
inline_env :: IdEnv Id
inline_env :: VarEnv EvVar
inline_env
= [(EvVar, EvVar)] -> VarEnv EvVar
forall a. [(EvVar, a)] -> VarEnv a
mkVarEnv [ (EvVar
lcl_id, EvVar -> InlinePragma -> EvVar
setInlinePragma EvVar
lcl_id InlinePragma
prag)
| ABE { abe_mono :: ABExport -> EvVar
abe_mono = EvVar
lcl_id, abe_poly :: ABExport -> EvVar
abe_poly = EvVar
gbl_id } <- [ABExport]
exports
, let prag :: InlinePragma
prag = EvVar -> InlinePragma
idInlinePragma EvVar
gbl_id ]
global_env :: IdEnv Id
global_env :: VarEnv EvVar
global_env =
[(EvVar, EvVar)] -> VarEnv EvVar
forall a. [(EvVar, a)] -> VarEnv a
mkVarEnv [ (EvVar
local, EvVar
global)
| ABE { abe_mono :: ABExport -> EvVar
abe_mono = EvVar
local, abe_poly :: ABExport -> EvVar
abe_poly = EvVar
global } <- [ABExport]
exports
]
get_new_force_vars :: t EvVar -> [EvVar]
get_new_force_vars t EvVar
lcls =
(EvVar -> [EvVar] -> [EvVar]) -> [EvVar] -> t EvVar -> [EvVar]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\EvVar
lcl [EvVar]
acc -> case VarEnv EvVar -> EvVar -> Maybe EvVar
forall a. VarEnv a -> EvVar -> Maybe a
lookupVarEnv VarEnv EvVar
global_env EvVar
lcl of
Just EvVar
_ -> [EvVar]
acc
Maybe EvVar
Nothing -> EvVar
lclEvVar -> [EvVar] -> [EvVar]
forall a. a -> [a] -> [a]
:[EvVar]
acc)
[] t EvVar
lcls
get_exports :: [Id] -> DsM ([Id], [ABExport])
get_exports :: [EvVar] -> DsM ([EvVar], [ABExport])
get_exports [EvVar]
lcls =
(([EvVar], [ABExport]) -> EvVar -> DsM ([EvVar], [ABExport]))
-> ([EvVar], [ABExport]) -> [EvVar] -> DsM ([EvVar], [ABExport])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\([EvVar]
glbls, [ABExport]
exports) EvVar
lcl ->
case VarEnv EvVar -> EvVar -> Maybe EvVar
forall a. VarEnv a -> EvVar -> Maybe a
lookupVarEnv VarEnv EvVar
global_env EvVar
lcl of
Just EvVar
glbl -> ([EvVar], [ABExport]) -> DsM ([EvVar], [ABExport])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar
glblEvVar -> [EvVar] -> [EvVar]
forall a. a -> [a] -> [a]
:[EvVar]
glbls, [ABExport]
exports)
Maybe EvVar
Nothing -> do ABExport
export <- EvVar -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
mk_export EvVar
lcl
let glbl :: EvVar
glbl = ABExport -> EvVar
abe_poly ABExport
export
([EvVar], [ABExport]) -> DsM ([EvVar], [ABExport])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar
glblEvVar -> [EvVar] -> [EvVar]
forall a. a -> [a] -> [a]
:[EvVar]
glbls, ABExport
exportABExport -> [ABExport] -> [ABExport]
forall a. a -> [a] -> [a]
:[ABExport]
exports))
([],[]) [EvVar]
lcls
mk_export :: EvVar -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
mk_export EvVar
local =
do EvVar
global <- Type -> Type -> DsM EvVar
newSysLocalDs Type
ManyTy
((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
tyvars ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
dicts (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
local))))
ABExport -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE { abe_poly :: EvVar
abe_poly = EvVar
global
, abe_mono :: EvVar
abe_mono = EvVar
local
, abe_wrap :: HsWrapper
abe_wrap = HsWrapper
WpHole
, abe_prags :: TcSpecPrags
abe_prags = [LTcSpecPrag] -> TcSpecPrags
SpecPrags [] })
makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
-> (Id, CoreExpr)
makeCorePair :: DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
gbl_id Bool
is_default_method Arity
dict_arity CoreExpr
rhs
| Bool
is_default_method
= (EvVar
gbl_id EvVar -> Unfolding -> EvVar
`setIdUnfolding` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding' SimpleOpts
simpl_opts CoreExpr
rhs, CoreExpr
rhs)
| Bool
otherwise
= case InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
inline_prag of
InlineSpec
NoUserInlinePrag -> (EvVar
gbl_id, CoreExpr
rhs)
NoInline {} -> (EvVar
gbl_id, CoreExpr
rhs)
Opaque {} -> (EvVar
gbl_id, CoreExpr
rhs)
Inlinable {} -> (EvVar
gbl_id EvVar -> Unfolding -> EvVar
`setIdUnfolding` Unfolding
inlinable_unf, CoreExpr
rhs)
Inline {} -> (EvVar, CoreExpr)
inline_pair
where
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
inline_prag :: InlinePragma
inline_prag = EvVar -> InlinePragma
idInlinePragma EvVar
gbl_id
inlinable_unf :: Unfolding
inlinable_unf = SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
mkInlinableUnfolding SimpleOpts
simpl_opts UnfoldingSource
StableUserSrc CoreExpr
rhs
inline_pair :: (EvVar, CoreExpr)
inline_pair
| Just Arity
arity <- InlinePragma -> Maybe Arity
inlinePragmaSat InlinePragma
inline_prag
, let real_arity :: Arity
real_arity = Arity
dict_arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
arity
= ( EvVar
gbl_id EvVar -> Unfolding -> EvVar
`setIdUnfolding` SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
simpl_opts UnfoldingSource
StableUserSrc Arity
real_arity CoreExpr
rhs
, Arity -> CoreExpr -> CoreExpr
etaExpand Arity
real_arity CoreExpr
rhs)
| Bool
otherwise
= String -> SDoc -> (EvVar, CoreExpr) -> (EvVar, CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace String
"makeCorePair: arity missing" (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
gbl_id) ((EvVar, CoreExpr) -> (EvVar, CoreExpr))
-> (EvVar, CoreExpr) -> (EvVar, CoreExpr)
forall a b. (a -> b) -> a -> b
$
(EvVar
gbl_id EvVar -> Unfolding -> EvVar
`setIdUnfolding` SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
mkInlineUnfoldingNoArity SimpleOpts
simpl_opts UnfoldingSource
StableUserSrc CoreExpr
rhs, CoreExpr
rhs)
dictArity :: [Var] -> Arity
dictArity :: [EvVar] -> Arity
dictArity [EvVar]
dicts = (EvVar -> Bool) -> [EvVar] -> Arity
forall a. (a -> Bool) -> [a] -> Arity
count EvVar -> Bool
isId [EvVar]
dicts
dsSpecs :: CoreExpr
-> TcSpecPrags
-> DsM ( OrdList (Id,CoreExpr)
, [CoreRule] )
dsSpecs :: CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
_ TcSpecPrags
IsDefaultMethod = (OrdList (EvVar, CoreExpr), [CoreRule])
-> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList (EvVar, CoreExpr)
forall a. OrdList a
nilOL, [])
dsSpecs CoreExpr
poly_rhs (SpecPrags [LTcSpecPrag]
sps)
= do { [(OrdList (EvVar, CoreExpr), CoreRule)]
pairs <- (LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> [LTcSpecPrag]
-> IOEnv
(Env DsGblEnv DsLclEnv) [(OrdList (EvVar, CoreExpr), CoreRule)]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Maybe CoreExpr
-> LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
dsSpec (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
poly_rhs)) [LTcSpecPrag]
sps
; let ([OrdList (EvVar, CoreExpr)]
spec_binds_s, [CoreRule]
rules) = [(OrdList (EvVar, CoreExpr), CoreRule)]
-> ([OrdList (EvVar, CoreExpr)], [CoreRule])
forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList (EvVar, CoreExpr), CoreRule)]
pairs
; (OrdList (EvVar, CoreExpr), [CoreRule])
-> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList (EvVar, CoreExpr)] -> OrdList (EvVar, CoreExpr)
forall a. [OrdList a] -> OrdList a
concatOL [OrdList (EvVar, CoreExpr)]
spec_binds_s, [CoreRule]
rules) }
dsSpec :: Maybe CoreExpr
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec :: Maybe CoreExpr
-> LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
dsSpec Maybe CoreExpr
mb_poly_rhs (L SrcSpan
loc (SpecPrag EvVar
poly_id HsWrapper
spec_co InlinePragma
spec_inl))
| Maybe Class -> Bool
forall a. Maybe a -> Bool
isJust (EvVar -> Maybe Class
isClassOpId_maybe EvVar
poly_id)
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (EvVar -> DsMessage
DsUselessSpecialiseForClassMethodSelector EvVar
poly_id)
; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. Maybe a
Nothing }
| Bool
no_act_spec Bool -> Bool -> Bool
&& Activation -> Bool
isNeverActive Activation
rule_act
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (EvVar -> DsMessage
DsUselessSpecialiseForNoInlineFunction EvVar
poly_id)
; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. Maybe a
Nothing }
| Bool
otherwise
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { Unique
uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let poly_name :: Name
poly_name = EvVar -> Name
idName EvVar
poly_id
spec_occ :: OccName
spec_occ = OccName -> OccName
mkSpecOcc (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
poly_name)
spec_name :: Name
spec_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
spec_occ (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
poly_name)
([EvVar]
spec_bndrs, HsWrapper
spec_app) = HsWrapper -> ([EvVar], HsWrapper)
collectHsWrapBinders HsWrapper
spec_co
; CoreExpr -> CoreExpr
core_app <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
spec_app
; let ds_lhs :: CoreExpr
ds_lhs = CoreExpr -> CoreExpr
core_app (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
poly_id)
spec_ty :: Type
spec_ty = [EvVar] -> Type -> Type
mkLamTypes [EvVar]
spec_bndrs ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
ds_lhs)
;
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case DynFlags
-> [EvVar]
-> CoreExpr
-> VarSet
-> Either DsMessage ([EvVar], EvVar, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [EvVar]
spec_bndrs CoreExpr
ds_lhs ([EvVar] -> VarSet
mkVarSet [EvVar]
spec_bndrs) of {
Left DsMessage
msg -> do { DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs DsMessage
msg; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. Maybe a
Nothing } ;
Right ([EvVar]
rule_bndrs, EvVar
_fn, [CoreExpr]
rule_lhs_args) -> do
{ Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let fn_unf :: Unfolding
fn_unf = EvVar -> Unfolding
realIdUnfolding EvVar
poly_id
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
spec_unf :: Unfolding
spec_unf = SimpleOpts
-> [EvVar]
-> (CoreExpr -> CoreExpr)
-> [CoreExpr]
-> Unfolding
-> Unfolding
specUnfolding SimpleOpts
simpl_opts [EvVar]
spec_bndrs CoreExpr -> CoreExpr
core_app [CoreExpr]
rule_lhs_args Unfolding
fn_unf
spec_id :: EvVar
spec_id = (() :: Constraint) => Name -> Type -> Type -> EvVar
Name -> Type -> Type -> EvVar
mkLocalId Name
spec_name Type
ManyTy Type
spec_ty
EvVar -> InlinePragma -> EvVar
`setInlinePragma` InlinePragma
inl_prag
EvVar -> Unfolding -> EvVar
`setIdUnfolding` Unfolding
spec_unf
rule :: CoreRule
rule = DynFlags
-> Module
-> Bool
-> Activation
-> SDoc
-> EvVar
-> [EvVar]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkSpecRule DynFlags
dflags Module
this_mod Bool
False Activation
rule_act (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"USPEC")
EvVar
poly_id [EvVar]
rule_bndrs [CoreExpr]
rule_lhs_args
(CoreExpr -> [EvVar] -> CoreExpr
forall b. Expr b -> [EvVar] -> Expr b
mkVarApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
spec_id) [EvVar]
spec_bndrs)
spec_rhs :: CoreExpr
spec_rhs = [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
spec_bndrs (CoreExpr -> CoreExpr
core_app CoreExpr
poly_rhs)
; CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsWarnOrphanRule CoreRule
rule
; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList (EvVar, CoreExpr), CoreRule)
-> Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. a -> Maybe a
Just ((EvVar, CoreExpr) -> OrdList (EvVar, CoreExpr)
forall a. a -> OrdList a
unitOL (EvVar
spec_id, CoreExpr
spec_rhs), CoreRule
rule))
} } }
where
is_local_id :: Bool
is_local_id = Maybe CoreExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe CoreExpr
mb_poly_rhs
poly_rhs :: CoreExpr
poly_rhs | Just CoreExpr
rhs <- Maybe CoreExpr
mb_poly_rhs
= CoreExpr
rhs
| Just CoreExpr
unfolding <- Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (EvVar -> Unfolding
realIdUnfolding EvVar
poly_id)
= CoreExpr
unfolding
| Bool
otherwise = String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsImpSpecs" (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
poly_id)
id_inl :: InlinePragma
id_inl = EvVar -> InlinePragma
idInlinePragma EvVar
poly_id
inl_prag :: InlinePragma
inl_prag | Bool -> Bool
not (InlinePragma -> Bool
isDefaultInlinePragma InlinePragma
spec_inl) = InlinePragma
spec_inl
| Bool -> Bool
not Bool
is_local_id
, OccInfo -> Bool
isStrongLoopBreaker (EvVar -> OccInfo
idOccInfo EvVar
poly_id) = InlinePragma
neverInlinePragma
| Bool
otherwise = InlinePragma
id_inl
spec_prag_act :: Activation
spec_prag_act = InlinePragma -> Activation
inlinePragmaActivation InlinePragma
spec_inl
no_act_spec :: Bool
no_act_spec = case InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
spec_inl of
NoInline SourceText
_ -> Activation -> Bool
isNeverActive Activation
spec_prag_act
Opaque SourceText
_ -> Activation -> Bool
isNeverActive Activation
spec_prag_act
InlineSpec
_ -> Activation -> Bool
isAlwaysActive Activation
spec_prag_act
rule_act :: Activation
rule_act | Bool
no_act_spec = InlinePragma -> Activation
inlinePragmaActivation InlinePragma
id_inl
| Bool
otherwise = Activation
spec_prag_act
dsWarnOrphanRule :: CoreRule -> DsM ()
dsWarnOrphanRule :: CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsWarnOrphanRule CoreRule
rule
= Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsOrphan -> Bool
isOrphan (CoreRule -> IsOrphan
ru_orphan CoreRule
rule)) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (CoreRule -> DsMessage
DsOrphanRule CoreRule
rule)
decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
-> VarSet
-> Either DsMessage ([Var], Id, [CoreExpr])
decomposeRuleLhs :: DynFlags
-> [EvVar]
-> CoreExpr
-> VarSet
-> Either DsMessage ([EvVar], EvVar, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [EvVar]
orig_bndrs CoreExpr
orig_lhs VarSet
rhs_fvs
| Var EvVar
funId <- CoreExpr
fun2
, Just DataCon
con <- EvVar -> Maybe DataCon
isDataConId_maybe EvVar
funId
= DsMessage -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
forall a b. a -> Either a b
Left (DataCon -> DsMessage
DsRuleIgnoredDueToConstructor DataCon
con)
| Bool
otherwise = case CoreExpr -> [CoreExpr] -> Maybe (EvVar, [CoreExpr])
decompose CoreExpr
fun2 [CoreExpr]
args2 of
Maybe (EvVar, [CoreExpr])
Nothing ->
DsMessage -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
forall a b. a -> Either a b
Left (CoreExpr -> CoreExpr -> DsMessage
DsRuleLhsTooComplicated CoreExpr
orig_lhs CoreExpr
lhs2)
Just (EvVar
fn_id, [CoreExpr]
args)
| Bool -> Bool
not ([EvVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
unbound) ->
DsMessage -> Either DsMessage ([EvVar], EvVar, [CoreExpr])
forall a b. a -> Either a b
Left ([EvVar] -> [EvVar] -> CoreExpr -> CoreExpr -> DsMessage
DsRuleBindersNotBound [EvVar]
unbound [EvVar]
orig_bndrs CoreExpr
orig_lhs CoreExpr
lhs2)
| Bool
otherwise ->
([EvVar], EvVar, [CoreExpr])
-> Either DsMessage ([EvVar], EvVar, [CoreExpr])
forall a b. b -> Either a b
Right ([EvVar]
trimmed_bndrs [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
extra_bndrs, EvVar
fn_id, [CoreExpr]
args)
where
lhs_fvs :: VarSet
lhs_fvs = [CoreExpr] -> VarSet
exprsFreeVars [CoreExpr]
args
all_fvs :: VarSet
all_fvs = VarSet
lhs_fvs VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
rhs_fvs
trimmed_bndrs :: [EvVar]
trimmed_bndrs = (EvVar -> Bool) -> [EvVar] -> [EvVar]
forall a. (a -> Bool) -> [a] -> [a]
filter (EvVar -> VarSet -> Bool
`elemVarSet` VarSet
all_fvs) [EvVar]
orig_bndrs
unbound :: [EvVar]
unbound = (EvVar -> Bool) -> [EvVar] -> [EvVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (EvVar -> VarSet -> Bool
`elemVarSet` VarSet
lhs_fvs) [EvVar]
trimmed_bndrs
extra_bndrs :: [EvVar]
extra_bndrs = [EvVar] -> [EvVar]
scopedSort [EvVar]
extra_tvs [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
extra_dicts
where
extra_tvs :: [EvVar]
extra_tvs = [ EvVar
v | EvVar
v <- [EvVar]
extra_vars, EvVar -> Bool
isTyVar EvVar
v ]
extra_dicts :: [EvVar]
extra_dicts =
[ (() :: Constraint) => Name -> Type -> Type -> EvVar
Name -> Type -> Type -> EvVar
mkLocalId (Name -> Name
localiseName (EvVar -> Name
idName EvVar
d)) Type
ManyTy (EvVar -> Type
idType EvVar
d)
| EvVar
d <- [EvVar]
extra_vars, EvVar -> Bool
isDictId EvVar
d ]
extra_vars :: [EvVar]
extra_vars =
[ EvVar
v
| EvVar
v <- [CoreExpr] -> [EvVar]
exprsFreeVarsList [CoreExpr]
args
, Bool -> Bool
not (EvVar
v EvVar -> VarSet -> Bool
`elemVarSet` VarSet
orig_bndr_set)
, Bool -> Bool
not (EvVar
v EvVar -> EvVar -> Bool
forall a. Eq a => a -> a -> Bool
== EvVar
fn_id) ]
where
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
orig_bndr_set :: VarSet
orig_bndr_set = [EvVar] -> VarSet
mkVarSet [EvVar]
orig_bndrs
lhs1 :: CoreExpr
lhs1 = CoreExpr -> CoreExpr
drop_dicts CoreExpr
orig_lhs
lhs2 :: CoreExpr
lhs2 = (() :: Constraint) => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
simpl_opts CoreExpr
lhs1
(CoreExpr
fun2,[CoreExpr]
args2) = CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs CoreExpr
lhs2
decompose :: CoreExpr -> [CoreExpr] -> Maybe (EvVar, [CoreExpr])
decompose (Var EvVar
fn_id) [CoreExpr]
args
| Bool -> Bool
not (EvVar
fn_id EvVar -> VarSet -> Bool
`elemVarSet` VarSet
orig_bndr_set)
= (EvVar, [CoreExpr]) -> Maybe (EvVar, [CoreExpr])
forall a. a -> Maybe a
Just (EvVar
fn_id, [CoreExpr]
args)
decompose CoreExpr
_ [CoreExpr]
_ = Maybe (EvVar, [CoreExpr])
forall a. Maybe a
Nothing
drop_dicts :: CoreExpr -> CoreExpr
drop_dicts :: CoreExpr -> CoreExpr
drop_dicts CoreExpr
e
= VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed [(EvVar, CoreExpr)]
bnds CoreExpr
body
where
needed :: VarSet
needed = VarSet
orig_bndr_set VarSet -> VarSet -> VarSet
`minusVarSet` CoreExpr -> VarSet
exprFreeVars CoreExpr
body
([(EvVar, CoreExpr)]
bnds, CoreExpr
body) = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
e)
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets :: CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets (Let (NonRec EvVar
d CoreExpr
r) CoreExpr
body)
| EvVar -> Bool
isDictId EvVar
d
= ((EvVar
d,CoreExpr
r)(EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
:[(EvVar, CoreExpr)]
bs, CoreExpr
body')
where ([(EvVar, CoreExpr)]
bs, CoreExpr
body') = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets CoreExpr
body
split_lets (Case CoreExpr
r EvVar
d Type
_ [Alt AltCon
DEFAULT [EvVar]
_ CoreExpr
body])
| EvVar -> Bool
isCoVar EvVar
d
= ((EvVar
d,CoreExpr
r)(EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
:[(EvVar, CoreExpr)]
bs, CoreExpr
body')
where ([(EvVar, CoreExpr)]
bs, CoreExpr
body') = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets CoreExpr
body
split_lets CoreExpr
e = ([], CoreExpr
e)
wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets :: VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
_ [] CoreExpr
body = CoreExpr
body
wrap_lets VarSet
needed ((EvVar
d, CoreExpr
r) : [(EvVar, CoreExpr)]
bs) CoreExpr
body
| VarSet
rhs_fvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
needed = CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (EvVar -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec EvVar
d CoreExpr
r) (VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed' [(EvVar, CoreExpr)]
bs CoreExpr
body)
| Bool
otherwise = VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed [(EvVar, CoreExpr)]
bs CoreExpr
body
where
rhs_fvs :: VarSet
rhs_fvs = CoreExpr -> VarSet
exprFreeVars CoreExpr
r
needed' :: VarSet
needed' = (VarSet
needed VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
rhs_fvs) VarSet -> EvVar -> VarSet
`extendVarSet` EvVar
d
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
WpHole = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e -> CoreExpr
e
dsHsWrapper (WpTyApp Type
ty) = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e (Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty)
dsHsWrapper (WpEvLam EvVar
ev) = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
ev
dsHsWrapper (WpTyLam EvVar
tv) = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
tv
dsHsWrapper (WpLet TcEvBinds
ev_binds) = do { [CoreBind]
bs <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
ev_binds
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
bs) }
dsHsWrapper (WpCompose HsWrapper
c1 HsWrapper
c2) = do { CoreExpr -> CoreExpr
w1 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
c1
; CoreExpr -> CoreExpr
w2 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
c2
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr
w1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
w2) }
dsHsWrapper (WpFun HsWrapper
c1 HsWrapper
c2 (Scaled Type
w Type
t1))
= do { EvVar
x <- Type -> Type -> DsM EvVar
newSysLocalDs Type
w Type
t1
; CoreExpr -> CoreExpr
w1 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
c1
; CoreExpr -> CoreExpr
w2 <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
c2
; let app :: CoreExpr -> CoreExpr -> CoreExpr
app CoreExpr
f CoreExpr
a = SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreAppDs (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dsHsWrapper") CoreExpr
f CoreExpr
a
arg :: CoreExpr
arg = CoreExpr -> CoreExpr
w1 (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
x)
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (\CoreExpr
e -> (EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
x (CoreExpr -> CoreExpr
w2 (CoreExpr -> CoreExpr -> CoreExpr
app CoreExpr
e CoreExpr
arg)))) }
dsHsWrapper (WpCast TcCoercionR
co) = Bool -> DsM (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. HasCallStack => Bool -> a -> a
assert (TcCoercionR -> Role
coercionRole TcCoercionR
co Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational) (DsM (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> DsM (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e -> CoreExpr -> TcCoercionR -> CoreExpr
mkCastDs CoreExpr
e TcCoercionR
co
dsHsWrapper (WpEvApp EvTerm
tm) = do { CoreExpr
core_tm <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
tm
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (\CoreExpr
e -> CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e CoreExpr
core_tm) }
dsHsWrapper (WpMultCoercion TcCoercionR
co) = do { Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (TcCoercionR -> Bool
isReflexiveCo TcCoercionR
co)) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
DsMessage -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs DsMessage
DsMultiplicityCoercionsNotSupported
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr))
-> (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e -> CoreExpr
e }
dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [] = [CoreBind] -> DsM [CoreBind]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
dsTcEvBinds_s (TcEvBinds
b:[TcEvBinds]
rest) = Bool -> DsM [CoreBind] -> DsM [CoreBind]
forall a. HasCallStack => Bool -> a -> a
assert ([TcEvBinds] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcEvBinds]
rest) (DsM [CoreBind] -> DsM [CoreBind])
-> DsM [CoreBind] -> DsM [CoreBind]
forall a b. (a -> b) -> a -> b
$
TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
b
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
dsTcEvBinds (TcEvBinds {}) = String -> DsM [CoreBind]
forall a. HasCallStack => String -> a
panic String
"dsEvBinds"
dsTcEvBinds (EvBinds Bag EvBind
bs) = Bag EvBind -> DsM [CoreBind]
dsEvBinds Bag EvBind
bs
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds :: Bag EvBind -> DsM [CoreBind]
dsEvBinds Bag EvBind
bs
= do { Bag (EvVar, CoreExpr)
ds_bs <- (EvBind -> DsM (EvVar, CoreExpr))
-> Bag EvBind
-> IOEnv (Env DsGblEnv DsLclEnv) (Bag (EvVar, CoreExpr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM EvBind -> DsM (EvVar, CoreExpr)
dsEvBind Bag EvBind
bs
; [CoreBind] -> DsM [CoreBind]
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (EvVar, CoreExpr) -> [CoreBind]
mk_ev_binds Bag (EvVar, CoreExpr)
ds_bs) }
mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
mk_ev_binds :: Bag (EvVar, CoreExpr) -> [CoreBind]
mk_ev_binds Bag (EvVar, CoreExpr)
ds_binds
= (SCC (EvVar, CoreExpr) -> CoreBind)
-> [SCC (EvVar, CoreExpr)] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map SCC (EvVar, CoreExpr) -> CoreBind
forall {b}. SCC (b, Expr b) -> Bind b
ds_scc ([Node EvVar (EvVar, CoreExpr)] -> [SCC (EvVar, CoreExpr)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node EvVar (EvVar, CoreExpr)]
edges)
where
edges :: [ Node EvVar (EvVar,CoreExpr) ]
edges :: [Node EvVar (EvVar, CoreExpr)]
edges = ((EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
-> [Node EvVar (EvVar, CoreExpr)])
-> [Node EvVar (EvVar, CoreExpr)]
-> Bag (EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Node EvVar (EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
-> [Node EvVar (EvVar, CoreExpr)])
-> ((EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr))
-> (EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
-> [Node EvVar (EvVar, CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr)
mk_node) [] Bag (EvVar, CoreExpr)
ds_binds
mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
mk_node :: (EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr)
mk_node b :: (EvVar, CoreExpr)
b@(EvVar
var, CoreExpr
rhs)
= DigraphNode { node_payload :: (EvVar, CoreExpr)
node_payload = (EvVar, CoreExpr)
b
, node_key :: EvVar
node_key = EvVar
var
, node_dependencies :: [EvVar]
node_dependencies = VarSet -> [EvVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (VarSet -> [EvVar]) -> VarSet -> [EvVar]
forall a b. (a -> b) -> a -> b
$
CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs VarSet -> VarSet -> VarSet
`unionVarSet`
Type -> VarSet
coVarsOfType (EvVar -> Type
varType EvVar
var) }
ds_scc :: SCC (b, Expr b) -> Bind b
ds_scc (AcyclicSCC (b
v,Expr b
r)) = b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
v Expr b
r
ds_scc (CyclicSCC [(b, Expr b)]
prs) = [(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec [(b, Expr b)]
prs
dsEvBind :: EvBind -> DsM (Id, CoreExpr)
dsEvBind :: EvBind -> DsM (EvVar, CoreExpr)
dsEvBind (EvBind { eb_lhs :: EvBind -> EvVar
eb_lhs = EvVar
v, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
r}) = (CoreExpr -> (EvVar, CoreExpr))
-> DsM CoreExpr -> DsM (EvVar, CoreExpr)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) EvVar
v) (EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
r)
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvExpr CoreExpr
e) = CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
dsEvTerm (EvTypeable Type
ty EvTypeable
ev) = Type -> EvTypeable -> DsM CoreExpr
dsEvTypeable Type
ty EvTypeable
ev
dsEvTerm (EvFun { et_tvs :: EvTerm -> [EvVar]
et_tvs = [EvVar]
tvs, et_given :: EvTerm -> [EvVar]
et_given = [EvVar]
given
, et_binds :: EvTerm -> TcEvBinds
et_binds = TcEvBinds
ev_binds, et_body :: EvTerm -> EvVar
et_body = EvVar
wanted_id })
= do { [CoreBind]
ds_ev_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
ev_binds
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([EvVar]
tvs [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
given) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
wanted_id) }
dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
dsEvTypeable Type
ty EvTypeable
ev
= do { TyCon
tyCl <- Name -> DsM TyCon
dsLookupTyCon Name
typeableClassName
; let kind :: Type
kind = (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty
typeable_data_con :: DataCon
typeable_data_con = TyCon -> DataCon
tyConSingleDataCon TyCon
tyCl
; CoreExpr
rep_expr <- Type -> EvTypeable -> DsM CoreExpr
ds_ev_typeable Type
ty EvTypeable
ev
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [CoreExpr] -> CoreExpr
forall b. DataCon -> [Arg b] -> Arg b
mkConApp DataCon
typeable_data_con [Type -> CoreExpr
forall b. Type -> Expr b
Type Type
kind, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty, CoreExpr
rep_expr] }
type TypeRepExpr = CoreExpr
ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
ds_ev_typeable Type
ty (EvTypeableTyCon TyCon
tc [EvTerm]
kind_ev)
= do { EvVar
mkTrCon <- Name -> DsM EvVar
dsLookupGlobalId Name
mkTrConName
; TyCon
someTypeRepTyCon <- Name -> DsM TyCon
dsLookupTyCon Name
someTypeRepTyConName
; DataCon
someTypeRepDataCon <- Name -> DsM DataCon
dsLookupDataCon Name
someTypeRepDataConName
; CoreExpr
tc_rep <- TyCon -> DsM CoreExpr
tyConRep TyCon
tc
; let ks :: [Type]
ks = HasCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
ty
toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
toSomeTypeRep Type
t EvTerm
ev = do
CoreExpr
rep <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev Type
t
CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ DataCon -> [CoreExpr] -> CoreExpr
mkCoreConApps DataCon
someTypeRepDataCon [Type -> CoreExpr
forall b. Type -> Expr b
Type ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
t), Type -> CoreExpr
forall b. Type -> Expr b
Type Type
t, CoreExpr
rep]
; [CoreExpr]
kind_arg_reps <- [DsM CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([DsM CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr])
-> [DsM CoreExpr] -> IOEnv (Env DsGblEnv DsLclEnv) [CoreExpr]
forall a b. (a -> b) -> a -> b
$ (Type -> EvTerm -> DsM CoreExpr)
-> [Type] -> [EvTerm] -> [DsM CoreExpr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> EvTerm -> DsM CoreExpr
toSomeTypeRep [Type]
ks [EvTerm]
kind_ev
; let
kind_args :: CoreExpr
kind_args = Type -> [CoreExpr] -> CoreExpr
mkListExpr (TyCon -> Type
mkTyConTy TyCon
someTypeRepTyCon) [CoreExpr]
kind_arg_reps
; let expr :: CoreExpr
expr = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
mkTrCon) [ Type -> CoreExpr
forall b. Type -> Expr b
Type ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty)
, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty
, CoreExpr
tc_rep
, CoreExpr
kind_args ]
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
}
ds_ev_typeable Type
ty (EvTypeableTyApp EvTerm
ev1 EvTerm
ev2)
| Just (Type
t1,Type
t2) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty
= do { CoreExpr
e1 <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev1 Type
t1
; CoreExpr
e2 <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev2 Type
t2
; EvVar
mkTrApp <- Name -> DsM EvVar
dsLookupGlobalId Name
mkTrAppName
; let (Type
_, Type
k1, Type
k2) = Type -> (Type, Type, Type)
splitFunTy ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
t1)
; let expr :: CoreExpr
expr = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
mkTrApp) [ Type
k1, Type
k2, Type
t1, Type
t2 ])
[ CoreExpr
e1, CoreExpr
e2 ]
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
}
ds_ev_typeable Type
ty (EvTypeableTrFun EvTerm
evm EvTerm
ev1 EvTerm
ev2)
| Just (FunTyFlag
_af,Type
m,Type
t1,Type
t2) <- Type -> Maybe (FunTyFlag, Type, Type, Type)
splitFunTy_maybe Type
ty
= do { CoreExpr
e1 <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev1 Type
t1
; CoreExpr
e2 <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev2 Type
t2
; CoreExpr
em <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
evm Type
m
; EvVar
mkTrFun <- Name -> DsM EvVar
dsLookupGlobalId Name
mkTrFunName
; let r1 :: Type
r1 = (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
t1
r2 :: Type
r2 = (() :: Constraint) => Type -> Type
Type -> Type
getRuntimeRep Type
t2
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
mkTrFun) [Type
m, Type
r1, Type
r2, Type
t1, Type
t2])
[ CoreExpr
em, CoreExpr
e1, CoreExpr
e2 ]
}
ds_ev_typeable Type
ty (EvTypeableTyLit EvTerm
ev)
=
do { EvVar
fun <- Name -> DsM EvVar
dsLookupGlobalId Name
tr_fun
; CoreExpr
dict <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
ev
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
fun) [Type
ty]) [ CoreExpr
dict ]) }
where
ty_kind :: Type
ty_kind = (() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty
tr_fun :: Name
tr_fun | Type
ty_kind Type -> Type -> Bool
`eqType` Type
naturalTy = Name
typeNatTypeRepName
| Type
ty_kind Type -> Type -> Bool
`eqType` Type
typeSymbolKind = Name
typeSymbolTypeRepName
| Type
ty_kind Type -> Type -> Bool
`eqType` Type
charTy = Name
typeCharTypeRepName
| Bool
otherwise = String -> Name
forall a. HasCallStack => String -> a
panic String
"dsEvTypeable: unknown type lit kind"
ds_ev_typeable Type
ty EvTypeable
ev
= String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsEvTypeable" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ EvTypeable -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvTypeable
ev)
getRep :: EvTerm
-> Type
-> DsM TypeRepExpr
getRep :: EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev Type
ty
= do { CoreExpr
typeable_expr <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
ev
; EvVar
typeRepId <- Name -> DsM EvVar
dsLookupGlobalId Name
typeRepIdName
; let ty_args :: [Type]
ty_args = [(() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty, Type
ty]
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
typeRepId) [Type]
ty_args) [ CoreExpr
typeable_expr ]) }
tyConRep :: TyCon -> DsM CoreExpr
tyConRep :: TyCon -> DsM CoreExpr
tyConRep TyCon
tc
| Just Name
tc_rep_nm <- TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc
= do { EvVar
tc_rep_id <- Name -> DsM EvVar
dsLookupGlobalId Name
tc_rep_nm
; CoreExpr -> DsM CoreExpr
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
tc_rep_id) }
| Bool
otherwise
= String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyConRep" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)