{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.HsToCore.Binds
( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
, dsHsWrapper, dsHsWrappers
, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
, dsWarnOrphanRule
)
where
import GHC.Prelude
import GHC.Driver.DynFlags
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.Pmc.Utils( tracePm )
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.InstEnv ( CanonicalEvidence(..) )
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.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 qualified Data.Set as S
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Monad
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (EvVar, CoreExpr))
dsTopLHsBinds LHsBinds GhcTc
binds
| Bool -> Bool
not ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
unlifted_binds) Bool -> Bool -> Bool
|| Bool -> Bool
not ([GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bang_binds)
= do { (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BindsType
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall {a}.
HasLoc a =>
BindsType
-> GenLocated a (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err BindsType
UnliftedTypeBinds) [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
unlifted_binds
; (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BindsType
-> GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall {a}.
HasLoc a =>
BindsType
-> GenLocated a (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err BindsType
StrictBinds) [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 { (force_vars, prs) <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; when debugIsOn $
do { xstrict <- xoptM LangExt.Strict
; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }
; return (toOL prs) }
where
unlifted_binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
unlifted_binds = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. (a -> Bool) -> [a] -> [a]
filter (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
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds
bang_binds :: [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
bang_binds = (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> Bool)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
forall a. (a -> Bool) -> [a] -> [a]
filter (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
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds
top_level_err :: BindsType
-> GenLocated a (HsBindLR GhcTc GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err BindsType
bindsType (L a
loc HsBindLR GhcTc GhcTc
bind)
= SrcSpan
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (a -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA 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 { ds_bs <- (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [([EvVar], [(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 LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)
-> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBind LHsBinds GhcTc
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds
; return (foldr (\([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'))
([], []) 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 dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
putSrcSpanDs (locA loc) $ dsHsBind dflags 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 { core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr
force_var = if Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
then [EvVar
id]
else []
; return (force_var, [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)
})
= HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
co_fn (((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
core_wrap ->
do { (args, body) <- HsMatchContextRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([EvVar], CoreExpr)
matchWrapper (GenLocated SrcSpanAnnN Name
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (EvVar -> Name
idName EvVar
fun)) AnnFunRhs
forall a. NoAnn a => a
noAnn) Maybe [LHsExpr GhcTc]
Maybe [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; let body' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
body
rhs = CoreExpr -> CoreExpr
core_wrap ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
args CoreExpr
body')
core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
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
= []
;
return (force_var, [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 { rhss_nablas <- HsMatchContextRn
-> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)
pmcGRHSs HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
forall fn. HsMatchContext fn
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; body_expr <- dsGuarded grhss ty rhss_nablas
; let body' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
rhs_tick CoreExpr
body_expr
pat' = DynFlags -> LPat GhcTc -> LPat GhcTc
decideBangHood DynFlags
dflags LPat GhcTc
pat
; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body'
; let force_var' = if LPat GhcTc -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isBangedLPat LPat GhcTc
pat'
then [EvVar
force_var]
else []
; return (force_var', 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 }))
= 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
$
[TcEvBinds]
-> ([CoreBind] -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds_s [TcEvBinds]
ev_binds (([CoreBind] -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> ([CoreBind] -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$ \[CoreBind]
ds_ev_binds -> do
do { ds_binds <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds
(isSingleton binds) 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
-> Bool
-> DsM ([Id], [(Id,CoreExpr)])
dsAbsBinds :: DynFlags
-> [EvVar]
-> [EvVar]
-> [ABExport]
-> [CoreBind]
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bool
-> 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
is_singleton 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 { HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
wrap (((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> ((CoreExpr -> CoreExpr) -> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
core_wrap -> do
{ 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)
; (spec_binds, rules) <- CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs TcSpecPrags
prags
; let global_id' = EvVar -> [CoreRule] -> EvVar
addIdSpecialisations EvVar
global_id [CoreRule]
rules
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
; return (force_vars', fromOL spec_binds ++ [main_bind]) } }
| [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 wrap_first_bind :: (b -> b) -> [(a, b)] -> [(a, b)]
wrap_first_bind b -> b
f ((a
main, b
main_rhs):[(a, b)]
other_binds) =
((a
main, b -> b
f b
main_rhs)(a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
:[(a, b)]
other_binds)
wrap_first_bind b -> b
_ [] = String -> [(a, b)]
forall a. HasCallStack => String -> a
panic String
"dsAbsBinds received an empty binding list"
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 { HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM (EvVar, CoreExpr))
-> DsM (EvVar, CoreExpr)
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
wrap (((CoreExpr -> CoreExpr) -> DsM (EvVar, CoreExpr))
-> DsM (EvVar, CoreExpr))
-> ((CoreExpr -> CoreExpr) -> DsM (EvVar, CoreExpr))
-> DsM (EvVar, CoreExpr)
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
core_wrap -> do
{ (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)) } }
; 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
; let bind_prs' = ((EvVar, CoreExpr) -> (EvVar, CoreExpr))
-> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (EvVar, CoreExpr) -> (EvVar, CoreExpr)
mk_aux_bind [(EvVar, CoreExpr)]
bind_prs
final_prs | Bool
is_singleton = (CoreExpr -> CoreExpr)
-> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall {b} {a}. (b -> b) -> [(a, b)] -> [(a, b)]
wrap_first_bind ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_ev_binds) [(EvVar, CoreExpr)]
bind_prs'
| Bool
otherwise = [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)]
bind_prs'
; return (force_vars, final_prs ++ 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))
-> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (EvVar, CoreExpr) -> (EvVar, CoreExpr)
mk_aux_bind [(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 = HasDebugCallStack => 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
; poly_tup_id <- Type -> DsM EvVar
newSysLocalMDs (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
poly_tup_rhs)
; (exported_force_vars, extra_exports) <- get_exports force_vars
; let 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 { tup_id <- Type -> DsM EvVar
newSysLocalMDs Type
tup_ty
; dsHsWrapper wrap $ \CoreExpr -> CoreExpr
core_wrap -> do
{ 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
; (spec_binds, rules) <- CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs_for_spec TcSpecPrags
spec_prags
; let global' = (EvVar
global EvVar -> InlinePragma -> EvVar
`setInlinePragma` InlinePragma
defaultInlinePragma)
EvVar -> [CoreRule] -> EvVar
`addIdSpecialisations` [CoreRule]
rules
; return (fromOL spec_binds ++ [(global', rhs)]) } }
; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
; return ( exported_force_vars
, (poly_tup_id, poly_tup_rhs) :
concat export_binds_s) }
where
mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr)
mk_aux_bind :: (EvVar, CoreExpr) -> (EvVar, CoreExpr)
mk_aux_bind (EvVar
lcl_id, CoreExpr
rhs) = 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
in
DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
lcl_w_inline Bool
False Arity
0 CoreExpr
rhs
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 export <- EvVar -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
mk_export EvVar
lcl
let glbl = ABExport -> EvVar
abe_poly ABExport
export
return (glbl:glbls, export:exports))
([],[]) [EvVar]
lcls
mk_export :: EvVar -> IOEnv (Env DsGblEnv DsLclEnv) ABExport
mk_export EvVar
local =
do global <- Type -> DsM EvVar
newSysLocalMDs
(HasDebugCallStack => 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))))
return (ABE { abe_poly = global
, abe_mono = local
, abe_wrap = WpHole
, abe_prags = 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 { 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 (spec_binds_s, rules) = unzip pairs
; return (concatOL spec_binds_s, 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 { uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let poly_name = EvVar -> Name
idName EvVar
poly_id
spec_occ = OccName -> OccName
mkSpecOcc (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
poly_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)
(spec_bndrs, spec_app) = collectHsWrapBinders spec_co
; dsHsWrapper spec_app $ \CoreExpr -> CoreExpr
core_app -> do
{ 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 (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
ds_lhs)
;
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case decomposeRuleLhs dflags spec_bndrs ds_lhs (mkVarSet 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
{ this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let fn_unf = EvVar -> Unfolding
realIdUnfolding EvVar
poly_id
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
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 = HasDebugCallStack => 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 = 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 = [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
spec_bndrs (CoreExpr -> CoreExpr
core_app CoreExpr
poly_rhs)
; dsWarnOrphanRule rule
; tracePm "dsSpec" (vcat
[ text "fun:" <+> ppr poly_id
, text "spec_co:" <+> ppr spec_co
, text "spec_bndrs:" <+> ppr spec_bndrs
, text "ds_lhs:" <+> ppr ds_lhs
, text "args:" <+> ppr rule_lhs_args ])
; return (Just (unitOL (spec_id, spec_rhs), 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 (CoreRule -> Bool
ruleIsOrphan 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 =
[ HasDebugCallStack => Name -> Type -> Type -> EvVar
Name -> Type -> Type -> EvVar
mkLocalIdOrCoVar (Name -> Name
localiseName (EvVar -> Name
idName EvVar
d)) Type
ManyTy (EvVar -> Type
idType EvVar
d)
| EvVar
d <- [EvVar]
extra_vars, EvVar -> Bool
isEvVar 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 = HasDebugCallStack => 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
dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
dsHsWrappers :: forall a. [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
dsHsWrappers (HsWrapper
wp:[HsWrapper]
wps) [CoreExpr -> CoreExpr] -> DsM a
k = HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
wp (((CoreExpr -> CoreExpr) -> DsM a) -> DsM a)
-> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
wrap -> [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
forall a. [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
dsHsWrappers [HsWrapper]
wps (([CoreExpr -> CoreExpr] -> DsM a) -> DsM a)
-> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
forall a b. (a -> b) -> a -> b
$ \[CoreExpr -> CoreExpr]
wraps -> [CoreExpr -> CoreExpr] -> DsM a
k (CoreExpr -> CoreExpr
wrap(CoreExpr -> CoreExpr)
-> [CoreExpr -> CoreExpr] -> [CoreExpr -> CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr -> CoreExpr]
wraps)
dsHsWrappers [] [CoreExpr -> CoreExpr] -> DsM a
k = [CoreExpr -> CoreExpr] -> DsM a
k []
dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper :: forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper HsWrapper
hs_wrap (CoreExpr -> CoreExpr) -> DsM a
thing_inside
= HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
ds_hs_wrapper HsWrapper
hs_wrap (((CoreExpr -> CoreExpr) -> DsM a) -> DsM a)
-> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
forall a b. (a -> b) -> a -> b
$ \ CoreExpr -> CoreExpr
core_wrap ->
Origin -> Bag EvVar -> DsM a -> DsM a
forall a. Origin -> Bag EvVar -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag EvVar
hsWrapDictBinders HsWrapper
hs_wrap) (DsM a -> DsM a) -> DsM a -> DsM a
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> CoreExpr) -> DsM a
thing_inside CoreExpr -> CoreExpr
core_wrap
ds_hs_wrapper :: HsWrapper
-> ((CoreExpr -> CoreExpr) -> DsM a)
-> DsM a
ds_hs_wrapper :: forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
ds_hs_wrapper HsWrapper
wrap = HsWrapper
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) a)
-> IOEnv (Env DsGblEnv DsLclEnv) a
forall a. HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
go HsWrapper
wrap
where
go :: HsWrapper
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
go HsWrapper
WpHole (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e -> CoreExpr
e
go (WpTyApp Type
ty) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
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)
go (WpEvLam EvVar
ev) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
ev
go (WpTyLam EvVar
tv) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
tv
go (WpCast TcCoercionR
co) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = Bool
-> IOEnv (Env DsGblEnv DsLclEnv) b
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a. HasCallStack => Bool -> a -> a
assert (TcCoercionR -> Role
coercionRole TcCoercionR
co Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Representational) (IOEnv (Env DsGblEnv DsLclEnv) b
-> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ \CoreExpr
e -> CoreExpr -> TcCoercionR -> CoreExpr
mkCastDs CoreExpr
e TcCoercionR
co
go (WpEvApp EvTerm
tm) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = do { core_tm <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
tm
; k $ \CoreExpr
e -> CoreExpr
e CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr
core_tm }
go (WpLet TcEvBinds
ev_binds) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = TcEvBinds
-> ([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds TcEvBinds
ev_binds (([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b)
-> ([CoreBind] -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ \[CoreBind]
bs ->
(CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k ([CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
bs)
go (WpCompose HsWrapper
c1 HsWrapper
c2) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k = HsWrapper
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
go HsWrapper
c1 (((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b)
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
w1 ->
HsWrapper
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
go HsWrapper
c2 (((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b)
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
w2 ->
(CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k (CoreExpr -> CoreExpr
w1 (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
w2)
go (WpFun HsWrapper
c1 HsWrapper
c2 Scaled Type
st) (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k =
do { x <- Scaled Type -> DsM EvVar
newSysLocalDs Scaled Type
st
; go c1 $ \CoreExpr -> CoreExpr
w1 ->
HsWrapper
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
go HsWrapper
c2 (((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b)
-> ((CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b)
-> IOEnv (Env DsGblEnv DsLclEnv) b
forall a b. (a -> b) -> a -> b
$ \CoreExpr -> CoreExpr
w2 ->
let app :: CoreExpr -> CoreExpr -> CoreExpr
app CoreExpr
f CoreExpr
a = SDoc -> CoreExpr -> CoreExpr -> CoreExpr
mkCoreApp (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)
in (CoreExpr -> CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) b
k (\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)))) }
dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds_s :: forall a. [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds_s [] [CoreBind] -> DsM a
k = [CoreBind] -> DsM a
k []
dsTcEvBinds_s (TcEvBinds
b:[TcEvBinds]
rest) [CoreBind] -> DsM a
k = Bool -> DsM a -> DsM a
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 a -> DsM a) -> DsM a -> DsM a
forall a b. (a -> b) -> a -> b
$
TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds TcEvBinds
b [CoreBind] -> DsM a
k
dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds :: forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds (TcEvBinds {}) = String -> ([CoreBind] -> DsM a) -> DsM a
forall a. HasCallStack => String -> a
panic String
"dsEvBinds"
dsTcEvBinds (EvBinds Bag EvBind
bs) = Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
forall a. Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
dsEvBinds Bag EvBind
bs
dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
dsEvBinds :: forall a. Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
dsEvBinds Bag EvBind
ev_binds [CoreBind] -> DsM a
thing_inside
= do { ds_binds <- (EvBind
-> IOEnv
(Env DsGblEnv DsLclEnv) (EvVar, CanonicalEvidence, CoreExpr))
-> Bag EvBind
-> IOEnv
(Env DsGblEnv DsLclEnv) (Bag (EvVar, CanonicalEvidence, CoreExpr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM EvBind
-> IOEnv
(Env DsGblEnv DsLclEnv) (EvVar, CanonicalEvidence, CoreExpr)
dsEvBind Bag EvBind
ev_binds
; let comps = Bag (EvVar, CanonicalEvidence, CoreExpr)
-> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
sort_ev_binds Bag (EvVar, CanonicalEvidence, CoreExpr)
ds_binds
; go comps thing_inside }
where
go ::[SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a
go :: forall a.
[SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
-> ([CoreBind] -> DsM a) -> DsM a
go (SCC (Node EvVar (CanonicalEvidence, CoreExpr))
comp:[SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
comps) [CoreBind] -> DsM a
thing_inside
= do { unspecables <- DsM (Set EvVar)
getUnspecables
; let (core_bind, new_unspecables) = ds_component unspecables comp
; addUnspecables new_unspecables $ go comps $ \ [CoreBind]
core_binds ->
[CoreBind] -> DsM a
thing_inside (CoreBind
core_bindCoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
:[CoreBind]
core_binds) }
go [] [CoreBind] -> DsM a
thing_inside = [CoreBind] -> DsM a
thing_inside []
ds_component :: Set a
-> SCC (Node a (CanonicalEvidence, Expr a)) -> (Bind a, Set a)
ds_component Set a
unspecables (AcyclicSCC Node a (CanonicalEvidence, Expr a)
node) = (a -> Expr a -> Bind a
forall b. b -> Expr b -> Bind b
NonRec a
v Expr a
rhs, Set a
new_unspecables)
where
((a
v, Expr a
rhs), (CanonicalEvidence
this_canonical, [a]
deps)) = Node a (CanonicalEvidence, Expr a)
-> ((a, Expr a), (CanonicalEvidence, [a]))
forall {a} {a} {b}. Node a (a, b) -> ((a, b), (a, [a]))
unpack_node Node a (CanonicalEvidence, Expr a)
node
transitively_unspecable :: Bool
transitively_unspecable = CanonicalEvidence -> Bool
is_unspecable CanonicalEvidence
this_canonical Bool -> Bool -> Bool
|| (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any a -> Bool
is_unspecable_dep [a]
deps
is_unspecable_dep :: a -> Bool
is_unspecable_dep a
dep = a
dep a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
unspecables
new_unspecables :: Set a
new_unspecables
| Bool
transitively_unspecable = a -> Set a
forall a. a -> Set a
S.singleton a
v
| Bool
otherwise = Set a
forall a. Monoid a => a
mempty
ds_component Set a
unspecables (CyclicSCC [Node a (CanonicalEvidence, Expr a)]
nodes) = ([(a, Expr a)] -> Bind a
forall b. [(b, Expr b)] -> Bind b
Rec [(a, Expr a)]
pairs, Set a
new_unspecables)
where
([(a, Expr a)]
pairs, [(CanonicalEvidence, [a])]
direct_canonicity) = [((a, Expr a), (CanonicalEvidence, [a]))]
-> ([(a, Expr a)], [(CanonicalEvidence, [a])])
forall a b. [(a, b)] -> ([a], [b])
unzip ([((a, Expr a), (CanonicalEvidence, [a]))]
-> ([(a, Expr a)], [(CanonicalEvidence, [a])]))
-> [((a, Expr a), (CanonicalEvidence, [a]))]
-> ([(a, Expr a)], [(CanonicalEvidence, [a])])
forall a b. (a -> b) -> a -> b
$ (Node a (CanonicalEvidence, Expr a)
-> ((a, Expr a), (CanonicalEvidence, [a])))
-> [Node a (CanonicalEvidence, Expr a)]
-> [((a, Expr a), (CanonicalEvidence, [a]))]
forall a b. (a -> b) -> [a] -> [b]
map Node a (CanonicalEvidence, Expr a)
-> ((a, Expr a), (CanonicalEvidence, [a]))
forall {a} {a} {b}. Node a (a, b) -> ((a, b), (a, [a]))
unpack_node [Node a (CanonicalEvidence, Expr a)]
nodes
is_unspecable_remote :: a -> Bool
is_unspecable_remote a
dep = a
dep a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
unspecables
transitively_unspecable :: Bool
transitively_unspecable = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ CanonicalEvidence -> Bool
is_unspecable CanonicalEvidence
this_canonical Bool -> Bool -> Bool
|| (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any a -> Bool
is_unspecable_remote [a]
deps
| (CanonicalEvidence
this_canonical, [a]
deps) <- [(CanonicalEvidence, [a])]
direct_canonicity ]
new_unspecables :: Set a
new_unspecables
| Bool
transitively_unspecable = [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [ a
v | (a
v, Expr a
_) <- [(a, Expr a)]
pairs]
| Bool
otherwise = Set a
forall a. Monoid a => a
mempty
unpack_node :: Node a (a, b) -> ((a, b), (a, [a]))
unpack_node DigraphNode { node_key :: forall key payload. Node key payload -> key
node_key = a
v, node_payload :: forall key payload. Node key payload -> payload
node_payload = (a
canonical, b
rhs), node_dependencies :: forall key payload. Node key payload -> [key]
node_dependencies = [a]
deps }
= ((a
v, b
rhs), (a
canonical, [a]
deps))
is_unspecable :: CanonicalEvidence -> Bool
is_unspecable :: CanonicalEvidence -> Bool
is_unspecable CanonicalEvidence
EvNonCanonical = Bool
True
is_unspecable CanonicalEvidence
EvCanonical = Bool
False
sort_ev_binds :: Bag (Id, CanonicalEvidence, CoreExpr) -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
sort_ev_binds :: Bag (EvVar, CanonicalEvidence, CoreExpr)
-> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
sort_ev_binds Bag (EvVar, CanonicalEvidence, CoreExpr)
ds_binds = [Node EvVar (CanonicalEvidence, CoreExpr)]
-> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR [Node EvVar (CanonicalEvidence, CoreExpr)]
edges
where
edges :: [ Node EvVar (CanonicalEvidence, CoreExpr) ]
edges :: [Node EvVar (CanonicalEvidence, CoreExpr)]
edges = ((EvVar, CanonicalEvidence, CoreExpr)
-> [Node EvVar (CanonicalEvidence, CoreExpr)]
-> [Node EvVar (CanonicalEvidence, CoreExpr)])
-> [Node EvVar (CanonicalEvidence, CoreExpr)]
-> Bag (EvVar, CanonicalEvidence, CoreExpr)
-> [Node EvVar (CanonicalEvidence, 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 (CanonicalEvidence, CoreExpr)
-> [Node EvVar (CanonicalEvidence, CoreExpr)]
-> [Node EvVar (CanonicalEvidence, CoreExpr)])
-> ((EvVar, CanonicalEvidence, CoreExpr)
-> Node EvVar (CanonicalEvidence, CoreExpr))
-> (EvVar, CanonicalEvidence, CoreExpr)
-> [Node EvVar (CanonicalEvidence, CoreExpr)]
-> [Node EvVar (CanonicalEvidence, CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvVar, CanonicalEvidence, CoreExpr)
-> Node EvVar (CanonicalEvidence, CoreExpr)
mk_node) [] Bag (EvVar, CanonicalEvidence, CoreExpr)
ds_binds
mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr)
mk_node :: (EvVar, CanonicalEvidence, CoreExpr)
-> Node EvVar (CanonicalEvidence, CoreExpr)
mk_node (EvVar
var, CanonicalEvidence
canonical, CoreExpr
rhs)
= DigraphNode { node_payload :: (CanonicalEvidence, CoreExpr)
node_payload = (CanonicalEvidence
canonical, CoreExpr
rhs)
, 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) }
dsEvBind :: EvBind -> DsM (Id, CanonicalEvidence, CoreExpr)
dsEvBind :: EvBind
-> IOEnv
(Env DsGblEnv DsLclEnv) (EvVar, CanonicalEvidence, CoreExpr)
dsEvBind (EvBind { eb_lhs :: EvBind -> EvVar
eb_lhs = EvVar
v, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
r, eb_info :: EvBind -> EvBindInfo
eb_info = EvBindInfo
info }) = do
e <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
r
let canonical = case EvBindInfo
info of
EvBindGiven{} -> CanonicalEvidence
EvCanonical
EvBindWanted{ ebi_canonical :: EvBindInfo -> CanonicalEvidence
ebi_canonical = CanonicalEvidence
canonical } -> CanonicalEvidence
canonical
return (v, canonical, e)
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 { TcEvBinds -> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a. TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds TcEvBinds
ev_binds (([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr)
-> ([CoreBind] -> DsM CoreExpr) -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ \[CoreBind]
ds_ev_binds -> do
{ 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 { tyCl <- Name -> DsM TyCon
dsLookupTyCon Name
typeableClassName
; let kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty
typeable_data_con = TyCon -> DataCon
tyConSingleDataCon TyCon
tyCl
; rep_expr <- ds_ev_typeable ty ev
; return $ mkConApp typeable_data_con [Type kind, Type ty, 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 { mkTrCon <- Name -> DsM EvVar
dsLookupGlobalId Name
mkTrConName
; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
; tc_rep <- tyConRep tc
; let ks = HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs Type
ty
toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
toSomeTypeRep Type
t EvTerm
ev = do
rep <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev Type
t
return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev
; let
kind_args = Type -> [CoreExpr] -> CoreExpr
mkListExpr (TyCon -> Type
mkTyConTy TyCon
someTypeRepTyCon) [CoreExpr]
kind_arg_reps
; let 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 (HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty)
, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
ty
, CoreExpr
tc_rep
, CoreExpr
kind_args ]
; return 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 { e1 <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev1 Type
t1
; e2 <- getRep ev2 t2
; mkTrApp <- dsLookupGlobalId mkTrAppName
; let (_, k1, k2) = splitFunTy (typeKind t1)
; let 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 ]
; return 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 { e1 <- EvTerm -> Type -> DsM CoreExpr
getRep EvTerm
ev1 Type
t1
; e2 <- getRep ev2 t2
; em <- getRep evm m
; mkTrFun <- dsLookupGlobalId mkTrFunName
; let r1 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
t1
r2 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
t2
; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])
[ em, e1, e2 ]
}
ds_ev_typeable Type
ty (EvTypeableTyLit EvTerm
ev)
=
do { fun <- Name -> DsM EvVar
dsLookupGlobalId Name
tr_fun
; dict <- dsEvTerm ev
; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }
where
ty_kind :: Type
ty_kind = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty
tr_fun :: Name
tr_fun | Type
ty_kind HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
naturalTy = Name
typeNatTypeRepName
| Type
ty_kind HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
typeSymbolKind = Name
typeSymbolTypeRepName
| Type
ty_kind HasCallStack => Type -> Type -> Bool
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 { typeable_expr <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
ev
; typeRepId <- dsLookupGlobalId typeRepIdName
; let ty_args = [HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty, Type
ty]
; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ 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 { tc_rep_id <- Name -> DsM EvVar
dsLookupGlobalId Name
tc_rep_nm
; return (Var 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)