{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Binds
( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
, dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
)
where
import GHC.Prelude
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
import GHC.HsToCore.Monad
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.Data.Graph.Directed
import GHC.Core.Predicate
import GHC.Builtin.Names
import GHC.Core.TyCon
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Coercion
import GHC.Core.Multiplicity
import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Core.Rules
import GHC.Types.Var.Env
import GHC.Types.Var( EvVar )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Constants (debugIsOn)
import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Data.Maybe
import GHC.Data.OrdList
import GHC.Data.Bag
import GHC.Types.Basic
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Config
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
import GHC.Utils.Monad
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id, CoreExpr))
dsTopLHsBinds LHsBinds GhcTc
binds
| Bool -> Bool
not (Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
unlifted_binds) Bool -> Bool -> Bool
|| Bool -> Bool
not (Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
bang_binds)
= do { (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (String
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a a.
Outputable a =>
String
-> GenLocated (SrcSpanAnn' a) a -> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err String
"bindings for unlifted types") Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
unlifted_binds
; (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (String
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a a.
Outputable a =>
String
-> GenLocated (SrcSpanAnn' a) a -> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err String
"strict bindings") Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
bang_binds
; OrdList (Id, CoreExpr) -> DsM (OrdList (Id, CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList (Id, CoreExpr)
forall a. OrdList a
nilOL }
| Bool
otherwise
= do { ([Id]
force_vars, [(Id, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([Id], [(Id, 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 ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
force_vars Bool -> Bool -> Bool
|| Bool
xstrict) (Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
LHsBinds GhcTc
binds SDoc -> SDoc -> SDoc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
force_vars) }
; OrdList (Id, CoreExpr) -> DsM (OrdList (Id, CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id, CoreExpr)] -> OrdList (Id, CoreExpr)
forall a. [a] -> OrdList a
toOL [(Id, CoreExpr)]
prs) }
where
unlifted_binds :: Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
unlifted_binds = (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> Bool)
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> HsBind GhcTc)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
LHsBinds GhcTc
binds
bang_binds :: Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
bang_binds = (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> Bool)
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBind GhcTc -> Bool
isBangedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> HsBind GhcTc)
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
LHsBinds GhcTc
binds
top_level_err :: String
-> GenLocated (SrcSpanAnn' a) a -> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err String
desc (L SrcSpanAnn' a
loc a
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
$
SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
errDs (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Top-level" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
desc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"aren't allowed:")
Int
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
bind))
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
= do { Bag ([Id], [(Id, CoreExpr)])
ds_bs <- (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> DsM ([Id], [(Id, CoreExpr)]))
-> Bag
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) (Bag ([Id], [(Id, CoreExpr)]))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc)
-> DsM ([Id], [(Id, CoreExpr)])
LHsBind GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBind Bag (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBind GhcTc))
LHsBinds GhcTc
binds
; ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((([Id], [(Id, CoreExpr)])
-> ([Id], [(Id, CoreExpr)]) -> ([Id], [(Id, CoreExpr)]))
-> (([Id], [(Id, CoreExpr)]) -> ([Id], [(Id, CoreExpr)]))
-> ([Id], [(Id, CoreExpr)])
-> Bag ([Id], [(Id, CoreExpr)])
-> ([Id], [(Id, CoreExpr)])
forall r a. (r -> r -> r) -> (a -> r) -> r -> Bag a -> r
foldBag (\([Id]
a, [(Id, CoreExpr)]
a') ([Id]
b, [(Id, CoreExpr)]
b') -> ([Id]
a [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
b, [(Id, CoreExpr)]
a' [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
b'))
([Id], [(Id, CoreExpr)]) -> ([Id], [(Id, CoreExpr)])
forall a. a -> a
id ([], []) Bag ([Id], [(Id, CoreExpr)])
ds_bs) }
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsLHsBind :: LHsBind GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBind (L loc bind) = do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
SrcSpan
-> DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
loc) (DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)]))
-> DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall a b. (a -> b) -> a -> b
$ DynFlags -> HsBind GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsHsBind DynFlags
dflags HsBind GhcTc
bind
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsHsBind :: DynFlags -> HsBind GhcTc -> DsM ([Id], [(Id, 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 :: (Id, CoreExpr)
core_bind@(Id
id,CoreExpr
_) = DynFlags -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags Id
IdP GhcTc
var Bool
False Int
0 CoreExpr
core_expr
force_var :: [Id]
force_var = if Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
then [Id
id]
else []
; ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
force_var, [(Id, CoreExpr)
core_bind]) }
dsHsBind DynFlags
dflags b :: HsBind GhcTc
b@(FunBind { fun_id :: forall idL idR. HsBindLR idL idR -> LIdP idL
fun_id = L loc 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 = XFunBind GhcTc GhcTc
co_fn
, fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick = [CoreTickish]
tick })
= do { ([Id]
args, CoreExpr
body) <- Origin -> Bag Id -> DsM ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag Id
hsWrapDictBinders HsWrapper
XFunBind GhcTc GhcTc
co_fn) (DsM ([Id], CoreExpr) -> DsM ([Id], CoreExpr))
-> DsM ([Id], CoreExpr) -> DsM ([Id], CoreExpr)
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper
(LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnnN -> Name -> GenLocated SrcSpanAnnN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
loc (Id -> Name
idName Id
fun)))
Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
XFunBind GhcTc GhcTc
co_fn
; let body' :: CoreExpr
body' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
body
rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
core_wrap ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
args CoreExpr
body')
core_binds :: (Id, CoreExpr)
core_binds@(Id
id,CoreExpr
_) = DynFlags -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags Id
fun Bool
False Int
0 CoreExpr
rhs
force_var :: [Id]
force_var
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
, MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
-> Int
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Int
matchGroupArity MatchGroup
GhcTc (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
matches Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
= [Id
id]
| HsBind GhcTc -> Bool
isBangedHsBind HsBind GhcTc
b
= [Id
id]
| Bool
otherwise
= []
;
([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
force_var, [(Id, 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 = XPatBind GhcTc GhcTc
ty
, pat_ticks :: forall idL idR.
HsBindLR idL idR -> ([CoreTickish], [[CoreTickish]])
pat_ticks = ([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
XPatBind GhcTc GhcTc
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
; (Id
force_var,[(Id, CoreExpr)]
sel_binds) <- [[CoreTickish]]
-> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])
mkSelectorBinds [[CoreTickish]]
var_ticks LPat GhcTc
pat CoreExpr
body'
; let force_var' :: [Id]
force_var' = if LPat GhcTc -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isBangedLPat LPat GhcTc
pat'
then [Id
force_var]
else []
; ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
force_var', [(Id, CoreExpr)]
sel_binds) }
dsHsBind DynFlags
dflags (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [Id]
abs_tvs = [Id]
tyvars, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [Id]
abs_ev_vars = [Id]
dicts
, abs_exports :: forall idL idR. HsBindLR idL idR -> [ABExport idL]
abs_exports = [ABExport GhcTc]
exports
, abs_ev_binds :: forall idL idR. HsBindLR idL idR -> [TcEvBinds]
abs_ev_binds = [TcEvBinds]
ev_binds
, abs_binds :: forall idL idR. HsBindLR idL idR -> LHsBinds idL
abs_binds = LHsBinds GhcTc
binds, abs_sig :: forall idL idR. HsBindLR idL idR -> Bool
abs_sig = Bool
has_sig })
= do { ([Id], [(Id, CoreExpr)])
ds_binds <- Origin
-> Bag Id
-> DsM ([Id], [(Id, CoreExpr)])
-> DsM ([Id], [(Id, CoreExpr)])
forall a. Origin -> Bag Id -> DsM a -> DsM a
addTyCs Origin
FromSource ([Id] -> Bag Id
forall a. [a] -> Bag a
listToBag [Id]
dicts) (DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)]))
-> DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall a b. (a -> b) -> a -> b
$
LHsBinds GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; [CoreBind]
ds_ev_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
; DynFlags
-> [Id]
-> [Id]
-> [ABExport GhcTc]
-> [CoreBind]
-> ([Id], [(Id, CoreExpr)])
-> Bool
-> DsM ([Id], [(Id, CoreExpr)])
dsAbsBinds DynFlags
dflags [Id]
tyvars [Id]
dicts [ABExport GhcTc]
exports [CoreBind]
ds_ev_binds ([Id], [(Id, CoreExpr)])
ds_binds Bool
has_sig }
dsHsBind DynFlags
_ (PatSynBind{}) = String -> DsM ([Id], [(Id, CoreExpr)])
forall a. String -> a
panic String
"dsHsBind: PatSynBind"
dsAbsBinds :: DynFlags
-> [TyVar] -> [EvVar] -> [ABExport GhcTc]
-> [CoreBind]
-> ([Id], [(Id,CoreExpr)])
-> Bool
-> DsM ([Id], [(Id,CoreExpr)])
dsAbsBinds :: DynFlags
-> [Id]
-> [Id]
-> [ABExport GhcTc]
-> [CoreBind]
-> ([Id], [(Id, CoreExpr)])
-> Bool
-> DsM ([Id], [(Id, CoreExpr)])
dsAbsBinds DynFlags
dflags [Id]
tyvars [Id]
dicts [ABExport GhcTc]
exports
[CoreBind]
ds_ev_binds ([Id]
force_vars, [(Id, CoreExpr)]
bind_prs) Bool
has_sig
| [ABExport GhcTc
export] <- [ABExport GhcTc]
exports
, ABE { abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
global_id, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
local_id
, abe_wrap :: forall p. ABExport p -> HsWrapper
abe_wrap = HsWrapper
wrap, abe_prags :: forall p. ABExport p -> TcSpecPrags
abe_prags = TcSpecPrags
prags } <- ABExport GhcTc
export
, Just [Id]
force_vars' <- case [Id]
force_vars of
[] -> [Id] -> Maybe [Id]
forall a. a -> Maybe a
Just []
[Id
v] | Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
IdP GhcTc
local_id -> [Id] -> Maybe [Id]
forall a. a -> Maybe a
Just [Id
IdP GhcTc
global_id]
[Id]
_ -> Maybe [Id]
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
$
[Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
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
, [(Id
_, CoreExpr
lrhs)] <- [(Id, CoreExpr)]
bind_prs
= CoreExpr
lrhs
| Bool
otherwise
= [(Id, CoreExpr)] -> CoreExpr -> CoreExpr
forall b. [(b, Expr b)] -> Expr b -> Expr b
mkLetRec [(Id, CoreExpr)]
bind_prs (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
IdP GhcTc
local_id)
; (OrdList (Id, CoreExpr)
spec_binds, [CoreRule]
rules) <- CoreExpr -> TcSpecPrags -> DsM (OrdList (Id, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs TcSpecPrags
prags
; let global_id' :: Id
global_id' = Id -> [CoreRule] -> Id
addIdSpecialisations Id
IdP GhcTc
global_id [CoreRule]
rules
main_bind :: (Id, CoreExpr)
main_bind = DynFlags -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags Id
global_id'
(TcSpecPrags -> Bool
isDefaultMethod TcSpecPrags
prags)
([Id] -> Int
dictArity [Id]
dicts) CoreExpr
rhs
; ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
force_vars', (Id, CoreExpr)
main_bind (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: OrdList (Id, CoreExpr) -> [(Id, CoreExpr)]
forall a. OrdList a -> [a]
fromOL OrdList (Id, CoreExpr)
spec_binds) }
| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tyvars, [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
dicts
= do { let mk_bind :: ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
mk_bind (ABE { abe_wrap :: forall p. ABExport p -> HsWrapper
abe_wrap = HsWrapper
wrap
, abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
global
, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
local
, abe_prags :: forall p. ABExport p -> TcSpecPrags
abe_prags = TcSpecPrags
prags })
= do { CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; (Id, CoreExpr) -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags Id
IdP GhcTc
global
(TcSpecPrags -> Bool
isDefaultMethod TcSpecPrags
prags)
Int
0 (CoreExpr -> CoreExpr
core_wrap (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
IdP GhcTc
local))) }
; [(Id, CoreExpr)]
main_binds <- (ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr))
-> [ABExport GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
mk_bind [ABExport GhcTc]
exports
; ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
force_vars, [CoreBind] -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [CoreBind]
ds_ev_binds [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
bind_prs [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
main_binds) }
| Bool
otherwise
= do { let core_bind :: CoreBind
core_bind = [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [ DynFlags -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags (Id -> Id
add_inline Id
lcl_id) Bool
False Int
0 CoreExpr
rhs
| (Id
lcl_id, CoreExpr
rhs) <- [(Id, CoreExpr)]
bind_prs ]
new_force_vars :: [Id]
new_force_vars = [Id] -> [Id]
forall (t :: * -> *). Foldable t => t Id -> [Id]
get_new_force_vars [Id]
force_vars
locals :: [Id]
locals = (ABExport GhcTc -> Id) -> [ABExport GhcTc] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map ABExport GhcTc -> Id
forall p. ABExport p -> IdP p
abe_mono [ABExport GhcTc]
exports
all_locals :: [Id]
all_locals = [Id]
locals [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
new_force_vars
tup_expr :: CoreExpr
tup_expr = [Id] -> CoreExpr
mkBigCoreVarTup [Id]
all_locals
tup_ty :: Type
tup_ty = CoreExpr -> Type
exprType CoreExpr
tup_expr
; let poly_tup_rhs :: CoreExpr
poly_tup_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
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
core_bind (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
tup_expr
; Id
poly_tup_id <- Type -> Type -> DsM Id
newSysLocalDs Type
Many (CoreExpr -> Type
exprType CoreExpr
poly_tup_rhs)
; ([Id]
exported_force_vars, [ABExport GhcTc]
extra_exports) <- [Id] -> DsM ([Id], [ABExport GhcTc])
get_exports [Id]
force_vars
; let mk_bind :: ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
mk_bind (ABE { abe_wrap :: forall p. ABExport p -> HsWrapper
abe_wrap = HsWrapper
wrap
, abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
global
, abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
local, abe_prags :: forall p. ABExport p -> TcSpecPrags
abe_prags = TcSpecPrags
spec_prags })
= do { Id
tup_id <- Type -> Type -> DsM Id
newSysLocalDs Type
Many 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
$ [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[Id] -> Id -> Id -> CoreExpr -> CoreExpr
mkTupleSelector [Id]
all_locals Id
IdP GhcTc
local Id
tup_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
poly_tup_id) ([Id]
tyvars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
dicts)
rhs_for_spec :: CoreExpr
rhs_for_spec = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
poly_tup_id CoreExpr
poly_tup_rhs) CoreExpr
rhs
; (OrdList (Id, CoreExpr)
spec_binds, [CoreRule]
rules) <- CoreExpr -> TcSpecPrags -> DsM (OrdList (Id, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs_for_spec TcSpecPrags
spec_prags
; let global' :: Id
global' = (Id
IdP GhcTc
global Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
defaultInlinePragma)
Id -> [CoreRule] -> Id
`addIdSpecialisations` [CoreRule]
rules
; [(Id, CoreExpr)] -> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Id
global', CoreExpr
rhs) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: OrdList (Id, CoreExpr) -> [(Id, CoreExpr)]
forall a. OrdList a -> [a]
fromOL OrdList (Id, CoreExpr)
spec_binds) }
; [[(Id, CoreExpr)]]
export_binds_s <- (ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)])
-> [ABExport GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [[(Id, CoreExpr)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
mk_bind ([ABExport GhcTc]
exports [ABExport GhcTc] -> [ABExport GhcTc] -> [ABExport GhcTc]
forall a. [a] -> [a] -> [a]
++ [ABExport GhcTc]
extra_exports)
; ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Id]
exported_force_vars
, (Id
poly_tup_id, CoreExpr
poly_tup_rhs) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
:
[[(Id, CoreExpr)]] -> [(Id, CoreExpr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Id, CoreExpr)]]
export_binds_s) }
where
inline_env :: IdEnv Id
inline_env :: IdEnv Id
inline_env
= [(Id, Id)] -> IdEnv Id
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [ (Id
IdP GhcTc
lcl_id, Id -> InlinePragma -> Id
setInlinePragma Id
IdP GhcTc
lcl_id InlinePragma
prag)
| ABE { abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
lcl_id, abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
gbl_id } <- [ABExport GhcTc]
exports
, let prag :: InlinePragma
prag = Id -> InlinePragma
idInlinePragma Id
IdP GhcTc
gbl_id ]
add_inline :: Id -> Id
add_inline :: Id -> Id
add_inline Id
lcl_id = IdEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv Id
inline_env Id
lcl_id
Maybe Id -> Id -> Id
forall a. Maybe a -> a -> a
`orElse` Id
lcl_id
global_env :: IdEnv Id
global_env :: IdEnv Id
global_env =
[(Id, Id)] -> IdEnv Id
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [ (Id
IdP GhcTc
local, Id
IdP GhcTc
global)
| ABE { abe_mono :: forall p. ABExport p -> IdP p
abe_mono = IdP GhcTc
local, abe_poly :: forall p. ABExport p -> IdP p
abe_poly = IdP GhcTc
global } <- [ABExport GhcTc]
exports
]
get_new_force_vars :: t Id -> [Id]
get_new_force_vars t Id
lcls =
(Id -> [Id] -> [Id]) -> [Id] -> t Id -> [Id]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Id
lcl [Id]
acc -> case IdEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv Id
global_env Id
lcl of
Just Id
_ -> [Id]
acc
Maybe Id
Nothing -> Id
lclId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
acc)
[] t Id
lcls
get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
get_exports [Id]
lcls =
(([Id], [ABExport GhcTc]) -> Id -> DsM ([Id], [ABExport GhcTc]))
-> ([Id], [ABExport GhcTc]) -> [Id] -> DsM ([Id], [ABExport GhcTc])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\([Id]
glbls, [ABExport GhcTc]
exports) Id
lcl ->
case IdEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdEnv Id
global_env Id
lcl of
Just Id
glbl -> ([Id], [ABExport GhcTc]) -> DsM ([Id], [ABExport GhcTc])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
glblId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
glbls, [ABExport GhcTc]
exports)
Maybe Id
Nothing -> do ABExport GhcTc
export <- Id -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
mk_export Id
lcl
let glbl :: IdP GhcTc
glbl = ABExport GhcTc -> IdP GhcTc
forall p. ABExport p -> IdP p
abe_poly ABExport GhcTc
export
([Id], [ABExport GhcTc]) -> DsM ([Id], [ABExport GhcTc])
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
IdP GhcTc
glblId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
glbls, ABExport GhcTc
exportABExport GhcTc -> [ABExport GhcTc] -> [ABExport GhcTc]
forall a. a -> [a] -> [a]
:[ABExport GhcTc]
exports))
([],[]) [Id]
lcls
mk_export :: Id -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
mk_export Id
local =
do Id
global <- Type -> Type -> DsM Id
newSysLocalDs Type
Many
(CoreExpr -> Type
exprType ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tyvars ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
dicts (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
local))))
ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE :: forall p.
XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p
ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_poly :: IdP GhcTc
abe_poly = Id
IdP GhcTc
global
, abe_mono :: IdP GhcTc
abe_mono = Id
IdP GhcTc
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 -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags Id
gbl_id Bool
is_default_method Int
dict_arity CoreExpr
rhs
| Bool
is_default_method
= (Id
gbl_id Id -> Unfolding -> Id
`setIdUnfolding` SimpleOpts -> CoreExpr -> Unfolding
mkCompulsoryUnfolding SimpleOpts
simpl_opts CoreExpr
rhs, CoreExpr
rhs)
| Bool
otherwise
= case InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
inline_prag of
InlineSpec
NoUserInlinePrag -> (Id
gbl_id, CoreExpr
rhs)
InlineSpec
NoInline -> (Id
gbl_id, CoreExpr
rhs)
InlineSpec
Inlinable -> (Id
gbl_id Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
inlinable_unf, CoreExpr
rhs)
InlineSpec
Inline -> (Id, CoreExpr)
inline_pair
where
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
inline_prag :: InlinePragma
inline_prag = Id -> InlinePragma
idInlinePragma Id
gbl_id
inlinable_unf :: Unfolding
inlinable_unf = SimpleOpts -> CoreExpr -> Unfolding
mkInlinableUnfolding SimpleOpts
simpl_opts CoreExpr
rhs
inline_pair :: (Id, CoreExpr)
inline_pair
| Just Int
arity <- InlinePragma -> Maybe Int
inlinePragmaSat InlinePragma
inline_prag
, let real_arity :: Int
real_arity = Int
dict_arity Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
arity
= ( Id
gbl_id Id -> Unfolding -> Id
`setIdUnfolding` Int -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Int
real_arity SimpleOpts
simpl_opts CoreExpr
rhs
, Int -> CoreExpr -> CoreExpr
etaExpand Int
real_arity CoreExpr
rhs)
| Bool
otherwise
= String -> SDoc -> (Id, CoreExpr) -> (Id, CoreExpr)
forall a. String -> SDoc -> a -> a
pprTrace String
"makeCorePair: arity missing" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
gbl_id) ((Id, CoreExpr) -> (Id, CoreExpr))
-> (Id, CoreExpr) -> (Id, CoreExpr)
forall a b. (a -> b) -> a -> b
$
(Id
gbl_id Id -> Unfolding -> Id
`setIdUnfolding` SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfolding SimpleOpts
simpl_opts CoreExpr
rhs, CoreExpr
rhs)
dictArity :: [Var] -> Arity
dictArity :: [Id] -> Int
dictArity [Id]
dicts = (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
dicts
dsSpecs :: CoreExpr
-> TcSpecPrags
-> DsM ( OrdList (Id,CoreExpr)
, [CoreRule] )
dsSpecs :: CoreExpr -> TcSpecPrags -> DsM (OrdList (Id, CoreExpr), [CoreRule])
dsSpecs CoreExpr
_ TcSpecPrags
IsDefaultMethod = (OrdList (Id, CoreExpr), [CoreRule])
-> DsM (OrdList (Id, CoreExpr), [CoreRule])
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList (Id, CoreExpr)
forall a. OrdList a
nilOL, [])
dsSpecs CoreExpr
poly_rhs (SpecPrags [LTcSpecPrag]
sps)
= do { [(OrdList (Id, CoreExpr), CoreRule)]
pairs <- (LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule)))
-> [LTcSpecPrag]
-> IOEnv
(Env DsGblEnv DsLclEnv) [(OrdList (Id, 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 (Id, CoreExpr), CoreRule))
dsSpec (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
poly_rhs)) [LTcSpecPrag]
sps
; let ([OrdList (Id, CoreExpr)]
spec_binds_s, [CoreRule]
rules) = [(OrdList (Id, CoreExpr), CoreRule)]
-> ([OrdList (Id, CoreExpr)], [CoreRule])
forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList (Id, CoreExpr), CoreRule)]
pairs
; (OrdList (Id, CoreExpr), [CoreRule])
-> DsM (OrdList (Id, CoreExpr), [CoreRule])
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList (Id, CoreExpr)] -> OrdList (Id, CoreExpr)
forall a. [OrdList a] -> OrdList a
concatOL [OrdList (Id, 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 (Id, CoreExpr), CoreRule))
dsSpec Maybe CoreExpr
mb_poly_rhs (L SrcSpan
loc (SpecPrag Id
poly_id HsWrapper
spec_co InlinePragma
spec_inl))
| Maybe Class -> Bool
forall a. Maybe a -> Bool
isJust (Id -> Maybe Class
isClassOpId_maybe Id
poly_id)
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { DiagnosticReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs DiagnosticReason
WarningWithoutFlag (String -> SDoc
text String
"Ignoring useless SPECIALISE pragma for class method selector"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id))
; Maybe (OrdList (Id, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (Id, 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 (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { DiagnosticReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs DiagnosticReason
WarningWithoutFlag (String -> SDoc
text String
"Ignoring useless SPECIALISE pragma for NOINLINE function:"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id))
; Maybe (OrdList (Id, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (Id, CoreExpr), CoreRule)
forall a. Maybe a
Nothing }
| Bool
otherwise
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, 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 = Id -> Name
idName Id
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)
([Id]
spec_bndrs, HsWrapper
spec_app) = HsWrapper -> ([Id], 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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
poly_id)
spec_ty :: Type
spec_ty = [Id] -> Type -> Type
mkLamTypes [Id]
spec_bndrs (CoreExpr -> Type
exprType CoreExpr
ds_lhs)
;
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case DynFlags -> [Id] -> CoreExpr -> Either SDoc ([Id], Id, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [Id]
spec_bndrs CoreExpr
ds_lhs of {
Left SDoc
msg -> do { DiagnosticReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs DiagnosticReason
WarningWithoutFlag SDoc
msg; Maybe (OrdList (Id, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (Id, CoreExpr), CoreRule)
forall a. Maybe a
Nothing } ;
Right ([Id]
rule_bndrs, Id
_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 = Id -> Unfolding
realIdUnfolding Id
poly_id
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
spec_unf :: Unfolding
spec_unf = SimpleOpts
-> [Id]
-> (CoreExpr -> CoreExpr)
-> [CoreExpr]
-> Unfolding
-> Unfolding
specUnfolding SimpleOpts
simpl_opts [Id]
spec_bndrs CoreExpr -> CoreExpr
core_app [CoreExpr]
rule_lhs_args Unfolding
fn_unf
spec_id :: Id
spec_id = HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId Name
spec_name Type
Many Type
spec_ty
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
inl_prag
Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
spec_unf
; CoreRule
rule <- Module
-> Bool
-> RuleName
-> Activation
-> Name
-> [Id]
-> [CoreExpr]
-> CoreExpr
-> DsM CoreRule
dsMkUserRule Module
this_mod Bool
is_local_id
(String -> RuleName
mkFastString (String
"SPEC " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> Name -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags Name
poly_name))
Activation
rule_act Name
poly_name
[Id]
rule_bndrs [CoreExpr]
rule_lhs_args
(CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
spec_id) [Id]
spec_bndrs)
; let spec_rhs :: CoreExpr
spec_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
spec_bndrs (CoreExpr -> CoreExpr
core_app CoreExpr
poly_rhs)
; Maybe (OrdList (Id, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList (Id, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList (Id, CoreExpr), CoreRule)
-> Maybe (OrdList (Id, CoreExpr), CoreRule)
forall a. a -> Maybe a
Just ((Id, CoreExpr) -> OrdList (Id, CoreExpr)
forall a. a -> OrdList a
unitOL (Id
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 (Id -> Unfolding
realIdUnfolding Id
poly_id)
= CoreExpr
unfolding
| Bool
otherwise = String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsImpSpecs" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id)
id_inl :: InlinePragma
id_inl = Id -> InlinePragma
idInlinePragma Id
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 (Id -> OccInfo
idOccInfo Id
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
InlineSpec
NoInline -> 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
dsMkUserRule :: Module -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
dsMkUserRule :: Module
-> Bool
-> RuleName
-> Activation
-> Name
-> [Id]
-> [CoreExpr]
-> CoreExpr
-> DsM CoreRule
dsMkUserRule Module
this_mod Bool
is_local RuleName
name Activation
act Name
fn [Id]
bndrs [CoreExpr]
args CoreExpr
rhs = do
let rule :: CoreRule
rule = Module
-> Bool
-> Bool
-> RuleName
-> Activation
-> Name
-> [Id]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkRule Module
this_mod Bool
False Bool
is_local RuleName
name Activation
act Name
fn [Id]
bndrs [CoreExpr]
args CoreExpr
rhs
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
$
DiagnosticReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
diagnosticDs (WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnOrphans) (CoreRule -> SDoc
ruleOrphWarn CoreRule
rule)
CoreRule -> DsM CoreRule
forall (m :: * -> *) a. Monad m => a -> m a
return CoreRule
rule
ruleOrphWarn :: CoreRule -> SDoc
ruleOrphWarn :: CoreRule -> SDoc
ruleOrphWarn CoreRule
rule = String -> SDoc
text String
"Orphan rule:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
rule
decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
-> Either SDoc ([Var], Id, [CoreExpr])
decomposeRuleLhs :: DynFlags -> [Id] -> CoreExpr -> Either SDoc ([Id], Id, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [Id]
orig_bndrs CoreExpr
orig_lhs
| Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
unbound)
= SDoc -> Either SDoc ([Id], Id, [CoreExpr])
forall a b. a -> Either a b
Left ([SDoc] -> SDoc
vcat ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
dead_msg [Id]
unbound))
| Var Id
funId <- CoreExpr
fun2
, Just DataCon
con <- Id -> Maybe DataCon
isDataConId_maybe Id
funId
= SDoc -> Either SDoc ([Id], Id, [CoreExpr])
forall a b. a -> Either a b
Left (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
constructor_msg DataCon
con)
| Just (Id
fn_id, [CoreExpr]
args) <- CoreExpr -> [CoreExpr] -> Maybe (Id, [CoreExpr])
decompose CoreExpr
fun2 [CoreExpr]
args2
, let extra_bndrs :: [Id]
extra_bndrs = Id -> [CoreExpr] -> [Id]
mk_extra_bndrs Id
fn_id [CoreExpr]
args
=
([Id], Id, [CoreExpr]) -> Either SDoc ([Id], Id, [CoreExpr])
forall a b. b -> Either a b
Right ([Id]
orig_bndrs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
extra_bndrs, Id
fn_id, [CoreExpr]
args)
| Bool
otherwise
= SDoc -> Either SDoc ([Id], Id, [CoreExpr])
forall a b. a -> Either a b
Left SDoc
bad_shape_msg
where
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
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
lhs_fvs :: VarSet
lhs_fvs = CoreExpr -> VarSet
exprFreeVars CoreExpr
lhs2
unbound :: [Id]
unbound = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Id -> VarSet -> Bool
`elemVarSet` VarSet
lhs_fvs) [Id]
orig_bndrs
orig_bndr_set :: VarSet
orig_bndr_set = [Id] -> VarSet
mkVarSet [Id]
orig_bndrs
mk_extra_bndrs :: Id -> [CoreExpr] -> [Id]
mk_extra_bndrs Id
fn_id [CoreExpr]
args
= [Id] -> [Id]
scopedSort [Id]
unbound_tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
unbound_dicts
where
unbound_tvs :: [Id]
unbound_tvs = [ Id
v | Id
v <- [Id]
unbound_vars, Id -> Bool
isTyVar Id
v ]
unbound_dicts :: [Id]
unbound_dicts = [ HasDebugCallStack => Name -> Type -> Type -> Id
Name -> Type -> Type -> Id
mkLocalId (Name -> Name
localiseName (Id -> Name
idName Id
d)) Type
Many (Id -> Type
idType Id
d)
| Id
d <- [Id]
unbound_vars, Id -> Bool
isDictId Id
d ]
unbound_vars :: [Id]
unbound_vars = [ Id
v | Id
v <- [CoreExpr] -> [Id]
exprsFreeVarsList [CoreExpr]
args
, Bool -> Bool
not (Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
orig_bndr_set)
, Bool -> Bool
not (Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
fn_id) ]
decompose :: CoreExpr -> [CoreExpr] -> Maybe (Id, [CoreExpr])
decompose (Var Id
fn_id) [CoreExpr]
args
| Bool -> Bool
not (Id
fn_id Id -> VarSet -> Bool
`elemVarSet` VarSet
orig_bndr_set)
= (Id, [CoreExpr]) -> Maybe (Id, [CoreExpr])
forall a. a -> Maybe a
Just (Id
fn_id, [CoreExpr]
args)
decompose CoreExpr
_ [CoreExpr]
_ = Maybe (Id, [CoreExpr])
forall a. Maybe a
Nothing
bad_shape_msg :: SDoc
bad_shape_msg = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"RULE left-hand side too complicated to desugar")
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Optimised lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2
, String -> SDoc
text String
"Orig lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs])
dead_msg :: Id -> SDoc
dead_msg Id
bndr = SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"Forall'd" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
pp_bndr Id
bndr
, String -> SDoc
text String
"is not bound in RULE lhs"])
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Orig bndrs:" SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
orig_bndrs
, String -> SDoc
text String
"Orig lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs
, String -> SDoc
text String
"optimised lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2 ])
pp_bndr :: Id -> SDoc
pp_bndr Id
bndr
| Id -> Bool
isTyVar Id
bndr = String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr)
| Id -> Bool
isEvVar Id
bndr = String -> SDoc
text String
"constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
varType Id
bndr))
| Bool
otherwise = String -> SDoc
text String
"variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr)
constructor_msg :: a -> SDoc
constructor_msg a
con = [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"A constructor," SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
con SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
", appears as outermost match in RULE lhs."
, String -> SDoc
text String
"This rule will be ignored." ]
drop_dicts :: CoreExpr -> CoreExpr
drop_dicts :: CoreExpr -> CoreExpr
drop_dicts CoreExpr
e
= VarSet -> [(Id, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed [(Id, CoreExpr)]
bnds CoreExpr
body
where
needed :: VarSet
needed = VarSet
orig_bndr_set VarSet -> VarSet -> VarSet
`minusVarSet` CoreExpr -> VarSet
exprFreeVars CoreExpr
body
([(Id, CoreExpr)]
bnds, CoreExpr
body) = CoreExpr -> ([(Id, CoreExpr)], CoreExpr)
split_lets (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
e)
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets :: CoreExpr -> ([(Id, CoreExpr)], CoreExpr)
split_lets (Let (NonRec Id
d CoreExpr
r) CoreExpr
body)
| Id -> Bool
isDictId Id
d
= ((Id
d,CoreExpr
r)(Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
:[(Id, CoreExpr)]
bs, CoreExpr
body')
where ([(Id, CoreExpr)]
bs, CoreExpr
body') = CoreExpr -> ([(Id, CoreExpr)], CoreExpr)
split_lets CoreExpr
body
split_lets (Case CoreExpr
r Id
d Type
_ [Alt AltCon
DEFAULT [Id]
_ CoreExpr
body])
| Id -> Bool
isCoVar Id
d
= ((Id
d,CoreExpr
r)(Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
:[(Id, CoreExpr)]
bs, CoreExpr
body')
where ([(Id, CoreExpr)]
bs, CoreExpr
body') = CoreExpr -> ([(Id, CoreExpr)], CoreExpr)
split_lets CoreExpr
body
split_lets CoreExpr
e = ([], CoreExpr
e)
wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets :: VarSet -> [(Id, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
_ [] CoreExpr
body = CoreExpr
body
wrap_lets VarSet
needed ((Id
d, CoreExpr
r) : [(Id, CoreExpr)]
bs) CoreExpr
body
| VarSet
rhs_fvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
needed = CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
d CoreExpr
r) (VarSet -> [(Id, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed' [(Id, CoreExpr)]
bs CoreExpr
body)
| Bool
otherwise = VarSet -> [(Id, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed [(Id, 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 -> Id -> VarSet
`extendVarSet` Id
d
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
WpHole = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
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 (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 Id
ev) = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
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
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
ev
dsHsWrapper (WpTyLam Id
tv) = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
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
$ Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
tv
dsHsWrapper (WpLet TcEvBinds
ev_binds) = do { [CoreBind]
bs <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
ev_binds
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
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 (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) SDoc
doc)
= do { Id
x <- Type -> Type -> DsM Id
newSysLocalDsNoLP 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
text String
"dsHsWrapper") CoreExpr
f CoreExpr
a
arg :: CoreExpr
arg = CoreExpr -> CoreExpr
w1 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x)
; (()
_, Bool
ok) <- IOEnv (Env DsGblEnv DsLclEnv) () -> DsM ((), Bool)
forall a. DsM a -> DsM (a, Bool)
askNoErrsDs (IOEnv (Env DsGblEnv DsLclEnv) () -> DsM ((), Bool))
-> IOEnv (Env DsGblEnv DsLclEnv) () -> DsM ((), Bool)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
dsNoLevPolyExpr CoreExpr
arg SDoc
doc
; if Bool
ok
then (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (\CoreExpr
e -> (Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x (CoreExpr -> CoreExpr
w2 (CoreExpr -> CoreExpr -> CoreExpr
app CoreExpr
e CoreExpr
arg))))
else (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr -> CoreExpr
forall a. a -> a
id }
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 (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 (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
$
SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
errDs (String -> SDoc
text String
"Multiplicity coercions are currently not supported")
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
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 (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 (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. 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 (Id, CoreExpr)
ds_bs <- (EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr))
-> Bag EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (Bag (Id, CoreExpr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
dsEvBind Bag EvBind
bs
; [CoreBind] -> DsM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (Id, CoreExpr) -> [CoreBind]
mk_ev_binds Bag (Id, CoreExpr)
ds_bs) }
mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
mk_ev_binds :: Bag (Id, CoreExpr) -> [CoreBind]
mk_ev_binds Bag (Id, CoreExpr)
ds_binds
= (SCC (Id, CoreExpr) -> CoreBind)
-> [SCC (Id, CoreExpr)] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map SCC (Id, CoreExpr) -> CoreBind
forall b. SCC (b, Expr b) -> Bind b
ds_scc ([Node Id (Id, CoreExpr)] -> [SCC (Id, CoreExpr)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Id (Id, CoreExpr)]
edges)
where
edges :: [ Node EvVar (EvVar,CoreExpr) ]
edges :: [Node Id (Id, CoreExpr)]
edges = ((Id, CoreExpr)
-> [Node Id (Id, CoreExpr)] -> [Node Id (Id, CoreExpr)])
-> [Node Id (Id, CoreExpr)]
-> Bag (Id, CoreExpr)
-> [Node Id (Id, CoreExpr)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Node Id (Id, CoreExpr)
-> [Node Id (Id, CoreExpr)] -> [Node Id (Id, CoreExpr)])
-> ((Id, CoreExpr) -> Node Id (Id, CoreExpr))
-> (Id, CoreExpr)
-> [Node Id (Id, CoreExpr)]
-> [Node Id (Id, CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id, CoreExpr) -> Node Id (Id, CoreExpr)
mk_node) [] Bag (Id, CoreExpr)
ds_binds
mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
mk_node :: (Id, CoreExpr) -> Node Id (Id, CoreExpr)
mk_node b :: (Id, CoreExpr)
b@(Id
var, CoreExpr
rhs)
= DigraphNode :: forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode { node_payload :: (Id, CoreExpr)
node_payload = (Id, CoreExpr)
b
, node_key :: Id
node_key = Id
var
, node_dependencies :: [Id]
node_dependencies = VarSet -> [Id]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (VarSet -> [Id]) -> VarSet -> [Id]
forall a b. (a -> b) -> a -> b
$
CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs VarSet -> VarSet -> VarSet
`unionVarSet`
Type -> VarSet
coVarsOfType (Id -> Type
varType Id
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 -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
dsEvBind (EvBind { eb_lhs :: EvBind -> Id
eb_lhs = Id
v, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
r}) = (CoreExpr -> (Id, CoreExpr))
-> DsM CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) Id
v) (EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
r)
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvExpr CoreExpr
e) = CoreExpr -> DsM CoreExpr
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 -> [Id]
et_tvs = [Id]
tvs, et_given :: EvTerm -> [Id]
et_given = [Id]
given
, et_binds :: EvTerm -> TcEvBinds
et_binds = TcEvBinds
ev_binds, et_body :: EvTerm -> Id
et_body = Id
wanted_id })
= do { [CoreBind]
ds_ev_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
ev_binds
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
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
$
Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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 = HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty
Just DataCon
typeable_data_con
= TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tyCl
; CoreExpr
rep_expr <- Type -> EvTypeable -> DsM CoreExpr
ds_ev_typeable Type
ty EvTypeable
ev
; CoreExpr -> DsM CoreExpr
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 { Id
mkTrCon <- Name -> DsM Id
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 = 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 (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 (HasDebugCallStack => 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)
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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 ]
; CoreExpr -> DsM CoreExpr
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
; Id
mkTrApp <- Name -> DsM Id
dsLookupGlobalId Name
mkTrAppName
; let (Type
_, Type
k1, Type
k2) = Type -> (Type, Type, Type)
splitFunTy (HasDebugCallStack => 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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
mkTrApp) [ Type
k1, Type
k2, Type
t1, Type
t2 ])
[ CoreExpr
e1, CoreExpr
e2 ]
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
expr
}
ds_ev_typeable Type
ty (EvTypeableTrFun EvTerm
evm EvTerm
ev1 EvTerm
ev2)
| Just (Type
m,Type
t1,Type
t2) <- Type -> Maybe (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
; Id
mkTrFun <- Name -> DsM Id
dsLookupGlobalId Name
mkTrFunName
; let r1 :: Type
r1 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
t1
r2 :: Type
r2 = HasDebugCallStack => Type -> Type
Type -> Type
getRuntimeRep Type
t2
; CoreExpr -> DsM CoreExpr
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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 { Id
fun <- Name -> DsM Id
dsLookupGlobalId Name
tr_fun
; CoreExpr
dict <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
ev
; CoreExpr -> DsM CoreExpr
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fun) [Type
ty]) [ CoreExpr
dict ]) }
where
ty_kind :: Type
ty_kind = HasDebugCallStack => 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. 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
$$ 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
; Id
typeRepId <- Name -> DsM Id
dsLookupGlobalId Name
typeRepIdName
; let ty_args :: [Type]
ty_args = [HasDebugCallStack => Type -> Type
Type -> Type
typeKind Type
ty, Type
ty]
; CoreExpr -> DsM CoreExpr
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 (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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 { Id
tc_rep_id <- Name -> DsM Id
dsLookupGlobalId Name
tc_rep_nm
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
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)