{-# LANGUAGE CPP #-}
{-# 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
#include "HsVersions.h"
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.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 (EvVar, CoreExpr))
dsTopLHsBinds LHsBinds GhcTc
binds
| Bool -> Bool
not (Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
unlifted_binds) Bool -> Bool -> Bool
|| Bool -> Bool
not (Bag (GenLocated SrcSpanAnnA (HsBind GhcTc)) -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
bang_binds)
= do { (GenLocated SrcSpanAnnA (HsBind GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (String
-> GenLocated SrcSpanAnnA (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 SrcSpanAnnA (HsBind GhcTc))
unlifted_binds
; (GenLocated SrcSpanAnnA (HsBind GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (String
-> GenLocated SrcSpanAnnA (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 SrcSpanAnnA (HsBind GhcTc))
bang_binds
; OrdList (EvVar, CoreExpr) -> DsM (OrdList (EvVar, CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList (EvVar, CoreExpr)
forall a. OrdList a
nilOL }
| Bool
otherwise
= do { ([EvVar]
force_vars, [(EvVar, CoreExpr)]
prs) <- LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; Bool
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugIsOn (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
do { Bool
xstrict <- Extension -> TcRnIf DsGblEnv DsLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.Strict
; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
; OrdList (EvVar, CoreExpr) -> DsM (OrdList (EvVar, CoreExpr))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(EvVar, CoreExpr)] -> OrdList (EvVar, CoreExpr)
forall a. [a] -> OrdList a
toOL [(EvVar, CoreExpr)]
prs) }
where
unlifted_binds :: Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
unlifted_binds = (GenLocated SrcSpanAnnA (HsBind GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc)
-> GenLocated SrcSpanAnnA (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
LHsBinds GhcTc
binds
bang_binds :: Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
bang_binds = (GenLocated SrcSpanAnnA (HsBind GhcTc) -> Bool)
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBind GhcTc -> Bool
isBangedHsBind (HsBind GhcTc -> Bool)
-> (GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc)
-> GenLocated SrcSpanAnnA (HsBind GhcTc)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (HsBind GhcTc) -> HsBind GhcTc
forall l e. GenLocated l e -> e
unLoc) Bag (GenLocated SrcSpanAnnA (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 -> Arity -> 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:")
Arity
2 (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
bind))
dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds :: LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
= do { Bag ([EvVar], [(EvVar, CoreExpr)])
ds_bs <- (GenLocated SrcSpanAnnA (HsBind GhcTc)
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
-> IOEnv
(Env DsGblEnv DsLclEnv) (Bag ([EvVar], [(EvVar, CoreExpr)]))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM GenLocated SrcSpanAnnA (HsBind GhcTc)
-> DsM ([EvVar], [(EvVar, CoreExpr)])
LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBind Bag (GenLocated SrcSpanAnnA (HsBind GhcTc))
LHsBinds GhcTc
binds
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ((([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)]))
-> (([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)]))
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bag ([EvVar], [(EvVar, CoreExpr)])
-> ([EvVar], [(EvVar, CoreExpr)])
forall r a. (r -> r -> r) -> (a -> r) -> r -> Bag a -> r
foldBag (\([EvVar]
a, [(EvVar, CoreExpr)]
a') ([EvVar]
b, [(EvVar, CoreExpr)]
b') -> ([EvVar]
a [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
b, [(EvVar, CoreExpr)]
a' [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(EvVar, CoreExpr)]
b'))
([EvVar], [(EvVar, CoreExpr)]) -> ([EvVar], [(EvVar, CoreExpr)])
forall a. a -> a
id ([], []) Bag ([EvVar], [(EvVar, CoreExpr)])
ds_bs) }
dsLHsBind :: LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsLHsBind :: LHsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBind (L SrcSpanAnnA
loc HsBind GhcTc
bind) = do DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
SrcSpan
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$ DynFlags -> HsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsHsBind DynFlags
dflags HsBind GhcTc
bind
dsHsBind :: DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsHsBind :: DynFlags -> HsBind GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsHsBind DynFlags
dflags (VarBind { var_id :: forall idL idR. HsBindLR idL idR -> IdP idL
var_id = IdP GhcTc
var
, var_rhs :: forall idL idR. HsBindLR idL idR -> LHsExpr idR
var_rhs = LHsExpr GhcTc
expr })
= do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; let core_bind :: (EvVar, CoreExpr)
core_bind@(EvVar
id,CoreExpr
_) = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
IdP GhcTc
var Bool
False Arity
0 CoreExpr
core_expr
force_var :: [EvVar]
force_var = if Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
then [EvVar
id]
else []
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_var, [(EvVar, CoreExpr)
core_bind]) }
dsHsBind DynFlags
dflags b :: HsBind 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 = XFunBind GhcTc GhcTc
co_fn
, fun_tick :: forall idL idR. HsBindLR idL idR -> [CoreTickish]
fun_tick = [CoreTickish]
tick })
= do { ([EvVar]
args, CoreExpr
body) <- Origin
-> Bag EvVar -> DsM ([EvVar], CoreExpr) -> DsM ([EvVar], CoreExpr)
forall a. Origin -> Bag EvVar -> DsM a -> DsM a
addTyCs Origin
FromSource (HsWrapper -> Bag EvVar
hsWrapDictBinders XFunBind GhcTc GhcTc
HsWrapper
co_fn) (DsM ([EvVar], CoreExpr) -> DsM ([EvVar], CoreExpr))
-> DsM ([EvVar], CoreExpr) -> DsM ([EvVar], CoreExpr)
forall a b. (a -> b) -> a -> b
$
HsMatchContext GhcRn
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([EvVar], CoreExpr)
matchWrapper
(LIdP 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 (EvVar -> Name
idName EvVar
fun)))
Maybe (LHsExpr GhcTc)
forall a. Maybe a
Nothing MatchGroup GhcTc (LHsExpr GhcTc)
matches
; CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper XFunBind GhcTc GhcTc
HsWrapper
co_fn
; let body' :: CoreExpr
body' = [CoreTickish] -> CoreExpr -> CoreExpr
mkOptTickBox [CoreTickish]
tick CoreExpr
body
rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
core_wrap ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
args CoreExpr
body')
core_binds :: (EvVar, CoreExpr)
core_binds@(EvVar
id,CoreExpr
_) = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
fun Bool
False Arity
0 CoreExpr
rhs
force_var :: [EvVar]
force_var
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
, MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc)) -> Arity
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Arity
matchGroupArity MatchGroup GhcTc (GenLocated SrcSpanAnnA (HsExpr GhcTc))
MatchGroup GhcTc (LHsExpr GhcTc)
matches Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
= [EvVar
id]
| HsBind GhcTc -> Bool
isBangedHsBind HsBind GhcTc
b
= [EvVar
id]
| Bool
otherwise
= []
;
([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_var, [(EvVar, CoreExpr)
core_binds]) }
dsHsBind DynFlags
dflags (PatBind { pat_lhs :: forall idL idR. HsBindLR idL idR -> LPat idL
pat_lhs = LPat GhcTc
pat, pat_rhs :: forall idL idR. HsBindLR idL idR -> GRHSs idR (LHsExpr idR)
pat_rhs = GRHSs GhcTc (LHsExpr GhcTc)
grhss
, pat_ext :: forall idL idR. HsBindLR idL idR -> XPatBind idL idR
pat_ext = 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
; (EvVar
force_var,[(EvVar, CoreExpr)]
sel_binds) <- [[CoreTickish]]
-> LPat GhcTc -> CoreExpr -> DsM (EvVar, [(EvVar, CoreExpr)])
mkSelectorBinds [[CoreTickish]]
var_ticks LPat GhcTc
pat CoreExpr
body'
; let force_var' :: [EvVar]
force_var' = if LPat GhcTc -> Bool
forall (p :: Pass). LPat (GhcPass p) -> Bool
isBangedLPat LPat GhcTc
pat'
then [EvVar
force_var]
else []
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_var', [(EvVar, CoreExpr)]
sel_binds) }
dsHsBind DynFlags
dflags (AbsBinds { abs_tvs :: forall idL idR. HsBindLR idL idR -> [EvVar]
abs_tvs = [EvVar]
tyvars, abs_ev_vars :: forall idL idR. HsBindLR idL idR -> [EvVar]
abs_ev_vars = [EvVar]
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 { ([EvVar], [(EvVar, CoreExpr)])
ds_binds <- Origin
-> Bag EvVar
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a. Origin -> Bag EvVar -> DsM a -> DsM a
addTyCs Origin
FromSource ([EvVar] -> Bag EvVar
forall a. [a] -> Bag a
listToBag [EvVar]
dicts) (DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)]))
-> DsM ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall a b. (a -> b) -> a -> b
$
LHsBinds GhcTc -> DsM ([EvVar], [(EvVar, CoreExpr)])
dsLHsBinds LHsBinds GhcTc
binds
; [CoreBind]
ds_ev_binds <- [TcEvBinds] -> DsM [CoreBind]
dsTcEvBinds_s [TcEvBinds]
ev_binds
; DynFlags
-> [EvVar]
-> [EvVar]
-> [ABExport GhcTc]
-> [CoreBind]
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bool
-> DsM ([EvVar], [(EvVar, CoreExpr)])
dsAbsBinds DynFlags
dflags [EvVar]
tyvars [EvVar]
dicts [ABExport GhcTc]
exports [CoreBind]
ds_ev_binds ([EvVar], [(EvVar, CoreExpr)])
ds_binds Bool
has_sig }
dsHsBind DynFlags
_ (PatSynBind{}) = String -> DsM ([EvVar], [(EvVar, 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
-> [EvVar]
-> [EvVar]
-> [ABExport GhcTc]
-> [CoreBind]
-> ([EvVar], [(EvVar, CoreExpr)])
-> Bool
-> DsM ([EvVar], [(EvVar, CoreExpr)])
dsAbsBinds DynFlags
dflags [EvVar]
tyvars [EvVar]
dicts [ABExport GhcTc]
exports
[CoreBind]
ds_ev_binds ([EvVar]
force_vars, [(EvVar, 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 [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
IdP GhcTc
local_id -> [EvVar] -> Maybe [EvVar]
forall a. a -> Maybe a
Just [EvVar
IdP GhcTc
global_id]
[EvVar]
_ -> Maybe [EvVar]
forall a. Maybe a
Nothing
= do { CoreExpr -> CoreExpr
core_wrap <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
wrap
; let rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
core_wrap (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
tyvars (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
dicts (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
body
body :: CoreExpr
body | Bool
has_sig
, [(EvVar
_, CoreExpr
lrhs)] <- [(EvVar, CoreExpr)]
bind_prs
= CoreExpr
lrhs
| Bool
otherwise
= [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
forall b. [(b, Expr b)] -> Expr b -> Expr b
mkLetRec [(EvVar, CoreExpr)]
bind_prs (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
IdP GhcTc
local_id)
; (OrdList (EvVar, CoreExpr)
spec_binds, [CoreRule]
rules) <- CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs TcSpecPrags
prags
; let global_id' :: EvVar
global_id' = EvVar -> [CoreRule] -> EvVar
addIdSpecialisations EvVar
IdP GhcTc
global_id [CoreRule]
rules
main_bind :: (EvVar, CoreExpr)
main_bind = DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
global_id'
(TcSpecPrags -> Bool
isDefaultMethod TcSpecPrags
prags)
([EvVar] -> Arity
dictArity [EvVar]
dicts) CoreExpr
rhs
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_vars', (EvVar, CoreExpr)
main_bind (EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
: OrdList (EvVar, CoreExpr) -> [(EvVar, CoreExpr)]
forall a. OrdList a -> [a]
fromOL OrdList (EvVar, CoreExpr)
spec_binds) }
| [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
tyvars, [EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
dicts
= do { let mk_bind :: ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, 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
; (EvVar, CoreExpr)
-> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags EvVar
IdP GhcTc
global
(TcSpecPrags -> Bool
isDefaultMethod TcSpecPrags
prags)
Arity
0 (CoreExpr -> CoreExpr
core_wrap (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
IdP GhcTc
local))) }
; [(EvVar, CoreExpr)]
main_binds <- (ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr))
-> [ABExport GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, 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) (EvVar, CoreExpr)
mk_bind [ABExport GhcTc]
exports
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvVar]
force_vars, [CoreBind] -> [(EvVar, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds [CoreBind]
ds_ev_binds [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(EvVar, CoreExpr)]
bind_prs [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(EvVar, CoreExpr)]
main_binds) }
| Bool
otherwise
= do { let core_bind :: CoreBind
core_bind = [(EvVar, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [ DynFlags -> EvVar -> Bool -> Arity -> CoreExpr -> (EvVar, CoreExpr)
makeCorePair DynFlags
dflags (EvVar -> EvVar
add_inline EvVar
lcl_id) Bool
False Arity
0 CoreExpr
rhs
| (EvVar
lcl_id, CoreExpr
rhs) <- [(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 GhcTc -> EvVar) -> [ABExport GhcTc] -> [EvVar]
forall a b. (a -> b) -> [a] -> [b]
map ABExport GhcTc -> EvVar
forall p. ABExport p -> IdP p
abe_mono [ABExport GhcTc]
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 = 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
core_bind (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr
tup_expr
; EvVar
poly_tup_id <- Type -> Type -> DsM EvVar
newSysLocalDs Type
Many (CoreExpr -> Type
exprType CoreExpr
poly_tup_rhs)
; ([EvVar]
exported_force_vars, [ABExport GhcTc]
extra_exports) <- [EvVar] -> DsM ([EvVar], [ABExport GhcTc])
get_exports [EvVar]
force_vars
; let mk_bind :: ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, 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 { EvVar
tup_id <- Type -> Type -> DsM EvVar
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
$ [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
mkTupleSelector [EvVar]
all_locals EvVar
IdP GhcTc
local EvVar
tup_id (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [EvVar] -> CoreExpr
forall b. Expr b -> [EvVar] -> Expr b
mkVarApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
poly_tup_id) ([EvVar]
tyvars [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
dicts)
rhs_for_spec :: CoreExpr
rhs_for_spec = CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (EvVar -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec EvVar
poly_tup_id CoreExpr
poly_tup_rhs) CoreExpr
rhs
; (OrdList (EvVar, CoreExpr)
spec_binds, [CoreRule]
rules) <- CoreExpr
-> TcSpecPrags -> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
dsSpecs CoreExpr
rhs_for_spec TcSpecPrags
spec_prags
; let global' :: EvVar
global' = (EvVar
IdP GhcTc
global EvVar -> InlinePragma -> EvVar
`setInlinePragma` InlinePragma
defaultInlinePragma)
EvVar -> [CoreRule] -> EvVar
`addIdSpecialisations` [CoreRule]
rules
; [(EvVar, CoreExpr)]
-> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((EvVar
global', CoreExpr
rhs) (EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
: OrdList (EvVar, CoreExpr) -> [(EvVar, CoreExpr)]
forall a. OrdList a -> [a]
fromOL OrdList (EvVar, CoreExpr)
spec_binds) }
; [[(EvVar, CoreExpr)]]
export_binds_s <- (ABExport GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) [(EvVar, CoreExpr)])
-> [ABExport GhcTc]
-> IOEnv (Env DsGblEnv DsLclEnv) [[(EvVar, 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) [(EvVar, CoreExpr)]
mk_bind ([ABExport GhcTc]
exports [ABExport GhcTc] -> [ABExport GhcTc] -> [ABExport GhcTc]
forall a. [a] -> [a] -> [a]
++ [ABExport GhcTc]
extra_exports)
; ([EvVar], [(EvVar, CoreExpr)])
-> DsM ([EvVar], [(EvVar, CoreExpr)])
forall (m :: * -> *) a. Monad m => a -> m a
return ( [EvVar]
exported_force_vars
, (EvVar
poly_tup_id, CoreExpr
poly_tup_rhs) (EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
:
[[(EvVar, CoreExpr)]] -> [(EvVar, CoreExpr)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(EvVar, CoreExpr)]]
export_binds_s) }
where
inline_env :: IdEnv Id
inline_env :: IdEnv EvVar
inline_env
= [(EvVar, EvVar)] -> IdEnv EvVar
forall a. [(EvVar, a)] -> VarEnv a
mkVarEnv [ (EvVar
IdP GhcTc
lcl_id, EvVar -> InlinePragma -> EvVar
setInlinePragma EvVar
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 = EvVar -> InlinePragma
idInlinePragma EvVar
IdP GhcTc
gbl_id ]
add_inline :: Id -> Id
add_inline :: EvVar -> EvVar
add_inline EvVar
lcl_id = IdEnv EvVar -> EvVar -> Maybe EvVar
forall a. VarEnv a -> EvVar -> Maybe a
lookupVarEnv IdEnv EvVar
inline_env EvVar
lcl_id
Maybe EvVar -> EvVar -> EvVar
forall a. Maybe a -> a -> a
`orElse` EvVar
lcl_id
global_env :: IdEnv Id
global_env :: IdEnv EvVar
global_env =
[(EvVar, EvVar)] -> IdEnv EvVar
forall a. [(EvVar, a)] -> VarEnv a
mkVarEnv [ (EvVar
IdP GhcTc
local, EvVar
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 EvVar -> [EvVar]
get_new_force_vars t EvVar
lcls =
(EvVar -> [EvVar] -> [EvVar]) -> [EvVar] -> t EvVar -> [EvVar]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\EvVar
lcl [EvVar]
acc -> case IdEnv EvVar -> EvVar -> Maybe EvVar
forall a. VarEnv a -> EvVar -> Maybe a
lookupVarEnv IdEnv 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 GhcTc])
get_exports :: [EvVar] -> DsM ([EvVar], [ABExport GhcTc])
get_exports [EvVar]
lcls =
(([EvVar], [ABExport GhcTc])
-> EvVar -> DsM ([EvVar], [ABExport GhcTc]))
-> ([EvVar], [ABExport GhcTc])
-> [EvVar]
-> DsM ([EvVar], [ABExport GhcTc])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\([EvVar]
glbls, [ABExport GhcTc]
exports) EvVar
lcl ->
case IdEnv EvVar -> EvVar -> Maybe EvVar
forall a. VarEnv a -> EvVar -> Maybe a
lookupVarEnv IdEnv EvVar
global_env EvVar
lcl of
Just EvVar
glbl -> ([EvVar], [ABExport GhcTc]) -> DsM ([EvVar], [ABExport GhcTc])
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar
glblEvVar -> [EvVar] -> [EvVar]
forall a. a -> [a] -> [a]
:[EvVar]
glbls, [ABExport GhcTc]
exports)
Maybe EvVar
Nothing -> do ABExport GhcTc
export <- EvVar -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
mk_export EvVar
lcl
let glbl :: IdP GhcTc
glbl = ABExport GhcTc -> IdP GhcTc
forall p. ABExport p -> IdP p
abe_poly ABExport GhcTc
export
([EvVar], [ABExport GhcTc]) -> DsM ([EvVar], [ABExport GhcTc])
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar
IdP GhcTc
glblEvVar -> [EvVar] -> [EvVar]
forall a. a -> [a] -> [a]
:[EvVar]
glbls, ABExport GhcTc
exportABExport GhcTc -> [ABExport GhcTc] -> [ABExport GhcTc]
forall a. a -> [a] -> [a]
:[ABExport GhcTc]
exports))
([],[]) [EvVar]
lcls
mk_export :: EvVar -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
mk_export EvVar
local =
do EvVar
global <- Type -> Type -> DsM EvVar
newSysLocalDs Type
Many
(CoreExpr -> Type
exprType ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
tyvars ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
dicts (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
local))))
ABExport GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (ABExport GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (ABE { abe_ext :: XABE GhcTc
abe_ext = NoExtField
XABE GhcTc
noExtField
, abe_poly :: IdP GhcTc
abe_poly = EvVar
IdP GhcTc
global
, abe_mono :: IdP GhcTc
abe_mono = EvVar
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 -> 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)
InlineSpec
NoInline -> (EvVar
gbl_id, CoreExpr
rhs)
InlineSpec
Inlinable -> (EvVar
gbl_id EvVar -> Unfolding -> EvVar
`setIdUnfolding` Unfolding
inlinable_unf, CoreExpr
rhs)
InlineSpec
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 -> CoreExpr -> Unfolding
mkInlinableUnfolding SimpleOpts
simpl_opts 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` Arity -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Arity
real_arity SimpleOpts
simpl_opts 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 -> CoreExpr -> Unfolding
mkInlineUnfolding SimpleOpts
simpl_opts 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 (m :: * -> *) a. Monad m => a -> m a
return (OrdList (EvVar, CoreExpr)
forall a. OrdList a
nilOL, [])
dsSpecs CoreExpr
poly_rhs (SpecPrags [LTcSpecPrag]
sps)
= do { [(OrdList (EvVar, CoreExpr), CoreRule)]
pairs <- (LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> [LTcSpecPrag]
-> IOEnv
(Env DsGblEnv DsLclEnv) [(OrdList (EvVar, CoreExpr), CoreRule)]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Maybe CoreExpr
-> LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
dsSpec (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
poly_rhs)) [LTcSpecPrag]
sps
; let ([OrdList (EvVar, CoreExpr)]
spec_binds_s, [CoreRule]
rules) = [(OrdList (EvVar, CoreExpr), CoreRule)]
-> ([OrdList (EvVar, CoreExpr)], [CoreRule])
forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList (EvVar, CoreExpr), CoreRule)]
pairs
; (OrdList (EvVar, CoreExpr), [CoreRule])
-> DsM (OrdList (EvVar, CoreExpr), [CoreRule])
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList (EvVar, CoreExpr)] -> OrdList (EvVar, CoreExpr)
forall a. [OrdList a] -> OrdList a
concatOL [OrdList (EvVar, CoreExpr)]
spec_binds_s, [CoreRule]
rules) }
dsSpec :: Maybe CoreExpr
-> Located TcSpecPrag
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec :: Maybe CoreExpr
-> LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
dsSpec Maybe CoreExpr
mb_poly_rhs (L SrcSpan
loc (SpecPrag EvVar
poly_id HsWrapper
spec_co InlinePragma
spec_inl))
| Maybe Class -> Bool
forall a. Maybe a -> Bool
isJust (EvVar -> Maybe Class
isClassOpId_maybe EvVar
poly_id)
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs WarnReason
NoReason (String -> SDoc
text String
"Ignoring useless SPECIALISE pragma for class method selector"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
poly_id))
; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
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 { WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs WarnReason
NoReason (String -> SDoc
text String
"Ignoring useless SPECIALISE pragma for NOINLINE function:"
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
poly_id))
; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. Maybe a
Nothing }
| Bool
otherwise
= SrcSpan
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
loc (IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule)))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall a b. (a -> b) -> a -> b
$
do { Unique
uniq <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let poly_name :: Name
poly_name = EvVar -> Name
idName EvVar
poly_id
spec_occ :: OccName
spec_occ = OccName -> OccName
mkSpecOcc (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
poly_name)
spec_name :: Name
spec_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
spec_occ (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
poly_name)
([EvVar]
spec_bndrs, HsWrapper
spec_app) = HsWrapper -> ([EvVar], HsWrapper)
collectHsWrapBinders HsWrapper
spec_co
; CoreExpr -> CoreExpr
core_app <- HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
spec_app
; let ds_lhs :: CoreExpr
ds_lhs = CoreExpr -> CoreExpr
core_app (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
poly_id)
spec_ty :: Type
spec_ty = [EvVar] -> Type -> Type
mkLamTypes [EvVar]
spec_bndrs (CoreExpr -> Type
exprType CoreExpr
ds_lhs)
;
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case DynFlags
-> [EvVar] -> CoreExpr -> Either SDoc ([EvVar], EvVar, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [EvVar]
spec_bndrs CoreExpr
ds_lhs of {
Left SDoc
msg -> do { WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs WarnReason
NoReason SDoc
msg; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. Maybe a
Nothing } ;
Right ([EvVar]
rule_bndrs, EvVar
_fn, [CoreExpr]
rule_lhs_args) -> do
{ Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let fn_unf :: Unfolding
fn_unf = EvVar -> Unfolding
realIdUnfolding EvVar
poly_id
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
spec_unf :: Unfolding
spec_unf = SimpleOpts
-> [EvVar]
-> (CoreExpr -> CoreExpr)
-> [CoreExpr]
-> Unfolding
-> Unfolding
specUnfolding SimpleOpts
simpl_opts [EvVar]
spec_bndrs CoreExpr -> CoreExpr
core_app [CoreExpr]
rule_lhs_args Unfolding
fn_unf
spec_id :: EvVar
spec_id = HasDebugCallStack => Name -> Type -> Type -> EvVar
Name -> Type -> Type -> EvVar
mkLocalId Name
spec_name Type
Many Type
spec_ty
EvVar -> InlinePragma -> EvVar
`setInlinePragma` InlinePragma
inl_prag
EvVar -> Unfolding -> EvVar
`setIdUnfolding` Unfolding
spec_unf
; CoreRule
rule <- Module
-> Bool
-> RuleName
-> Activation
-> Name
-> [EvVar]
-> [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
[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)
; let spec_rhs :: CoreExpr
spec_rhs = [EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [EvVar]
spec_bndrs (CoreExpr -> CoreExpr
core_app CoreExpr
poly_rhs)
; Maybe (OrdList (EvVar, CoreExpr), CoreRule)
-> IOEnv
(Env DsGblEnv DsLclEnv)
(Maybe (OrdList (EvVar, CoreExpr), CoreRule))
forall (m :: * -> *) a. Monad m => a -> m a
return ((OrdList (EvVar, CoreExpr), CoreRule)
-> Maybe (OrdList (EvVar, CoreExpr), CoreRule)
forall a. a -> Maybe a
Just ((EvVar, CoreExpr) -> OrdList (EvVar, CoreExpr)
forall a. a -> OrdList a
unitOL (EvVar
spec_id, CoreExpr
spec_rhs), CoreRule
rule))
} } }
where
is_local_id :: Bool
is_local_id = Maybe CoreExpr -> Bool
forall a. Maybe a -> Bool
isJust Maybe CoreExpr
mb_poly_rhs
poly_rhs :: CoreExpr
poly_rhs | Just CoreExpr
rhs <- Maybe CoreExpr
mb_poly_rhs
= CoreExpr
rhs
| Just CoreExpr
unfolding <- Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (EvVar -> Unfolding
realIdUnfolding EvVar
poly_id)
= CoreExpr
unfolding
| Bool
otherwise = String -> SDoc -> CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"dsImpSpecs" (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
poly_id)
id_inl :: InlinePragma
id_inl = EvVar -> InlinePragma
idInlinePragma EvVar
poly_id
inl_prag :: InlinePragma
inl_prag | Bool -> Bool
not (InlinePragma -> Bool
isDefaultInlinePragma InlinePragma
spec_inl) = InlinePragma
spec_inl
| Bool -> Bool
not Bool
is_local_id
, OccInfo -> Bool
isStrongLoopBreaker (EvVar -> OccInfo
idOccInfo EvVar
poly_id) = InlinePragma
neverInlinePragma
| Bool
otherwise = InlinePragma
id_inl
spec_prag_act :: Activation
spec_prag_act = InlinePragma -> Activation
inlinePragmaActivation InlinePragma
spec_inl
no_act_spec :: Bool
no_act_spec = case InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
spec_inl of
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
-> [EvVar]
-> [CoreExpr]
-> CoreExpr
-> DsM CoreRule
dsMkUserRule Module
this_mod Bool
is_local RuleName
name Activation
act Name
fn [EvVar]
bndrs [CoreExpr]
args CoreExpr
rhs = do
let rule :: CoreRule
rule = Module
-> Bool
-> Bool
-> RuleName
-> Activation
-> Name
-> [EvVar]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkRule Module
this_mod Bool
False Bool
is_local RuleName
name Activation
act Name
fn [EvVar]
bndrs [CoreExpr]
args CoreExpr
rhs
DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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) Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnOrphans DynFlags
dflags) (IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ())
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a b. (a -> b) -> a -> b
$
WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs (WarningFlag -> WarnReason
Reason 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
-> [EvVar] -> CoreExpr -> Either SDoc ([EvVar], EvVar, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [EvVar]
orig_bndrs CoreExpr
orig_lhs
| Bool -> Bool
not ([EvVar] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EvVar]
unbound)
= SDoc -> Either SDoc ([EvVar], EvVar, [CoreExpr])
forall a b. a -> Either a b
Left ([SDoc] -> SDoc
vcat ((EvVar -> SDoc) -> [EvVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map EvVar -> SDoc
dead_msg [EvVar]
unbound))
| Var EvVar
funId <- CoreExpr
fun2
, Just DataCon
con <- EvVar -> Maybe DataCon
isDataConId_maybe EvVar
funId
= SDoc -> Either SDoc ([EvVar], EvVar, [CoreExpr])
forall a b. a -> Either a b
Left (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
constructor_msg DataCon
con)
| Just (EvVar
fn_id, [CoreExpr]
args) <- CoreExpr -> [CoreExpr] -> Maybe (EvVar, [CoreExpr])
decompose CoreExpr
fun2 [CoreExpr]
args2
, let extra_bndrs :: [EvVar]
extra_bndrs = EvVar -> [CoreExpr] -> [EvVar]
mk_extra_bndrs EvVar
fn_id [CoreExpr]
args
=
([EvVar], EvVar, [CoreExpr])
-> Either SDoc ([EvVar], EvVar, [CoreExpr])
forall a b. b -> Either a b
Right ([EvVar]
orig_bndrs [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
extra_bndrs, EvVar
fn_id, [CoreExpr]
args)
| Bool
otherwise
= SDoc -> Either SDoc ([EvVar], EvVar, [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 :: [EvVar]
unbound = (EvVar -> Bool) -> [EvVar] -> [EvVar]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (EvVar -> VarSet -> Bool
`elemVarSet` VarSet
lhs_fvs) [EvVar]
orig_bndrs
orig_bndr_set :: VarSet
orig_bndr_set = [EvVar] -> VarSet
mkVarSet [EvVar]
orig_bndrs
mk_extra_bndrs :: EvVar -> [CoreExpr] -> [EvVar]
mk_extra_bndrs EvVar
fn_id [CoreExpr]
args
= [EvVar] -> [EvVar]
scopedSort [EvVar]
unbound_tvs [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
unbound_dicts
where
unbound_tvs :: [EvVar]
unbound_tvs = [ EvVar
v | EvVar
v <- [EvVar]
unbound_vars, EvVar -> Bool
isTyVar EvVar
v ]
unbound_dicts :: [EvVar]
unbound_dicts = [ HasDebugCallStack => Name -> Type -> Type -> EvVar
Name -> Type -> Type -> EvVar
mkLocalId (Name -> Name
localiseName (EvVar -> Name
idName EvVar
d)) Type
Many (EvVar -> Type
idType EvVar
d)
| EvVar
d <- [EvVar]
unbound_vars, EvVar -> Bool
isDictId EvVar
d ]
unbound_vars :: [EvVar]
unbound_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) ]
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
bad_shape_msg :: SDoc
bad_shape_msg = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"RULE left-hand side too complicated to desugar")
Arity
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 :: EvVar -> SDoc
dead_msg EvVar
bndr = SDoc -> Arity -> SDoc -> SDoc
hang ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"Forall'd" SDoc -> SDoc -> SDoc
<+> EvVar -> SDoc
pp_bndr EvVar
bndr
, String -> SDoc
text String
"is not bound in RULE lhs"])
Arity
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Orig bndrs:" SDoc -> SDoc -> SDoc
<+> [EvVar] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvVar]
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 :: EvVar -> SDoc
pp_bndr EvVar
bndr
| EvVar -> Bool
isTyVar EvVar
bndr = String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
bndr)
| EvVar -> Bool
isEvVar EvVar
bndr = String -> SDoc
text String
"constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (EvVar -> Type
varType EvVar
bndr))
| Bool
otherwise = String -> SDoc
text String
"variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (EvVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvVar
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 -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed [(EvVar, CoreExpr)]
bnds CoreExpr
body
where
needed :: VarSet
needed = VarSet
orig_bndr_set VarSet -> VarSet -> VarSet
`minusVarSet` CoreExpr -> VarSet
exprFreeVars CoreExpr
body
([(EvVar, CoreExpr)]
bnds, CoreExpr
body) = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
e)
split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
split_lets :: CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets (Let (NonRec EvVar
d CoreExpr
r) CoreExpr
body)
| EvVar -> Bool
isDictId EvVar
d
= ((EvVar
d,CoreExpr
r)(EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
:[(EvVar, CoreExpr)]
bs, CoreExpr
body')
where ([(EvVar, CoreExpr)]
bs, CoreExpr
body') = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets CoreExpr
body
split_lets (Case CoreExpr
r EvVar
d Type
_ [Alt AltCon
DEFAULT [EvVar]
_ CoreExpr
body])
| EvVar -> Bool
isCoVar EvVar
d
= ((EvVar
d,CoreExpr
r)(EvVar, CoreExpr) -> [(EvVar, CoreExpr)] -> [(EvVar, CoreExpr)]
forall a. a -> [a] -> [a]
:[(EvVar, CoreExpr)]
bs, CoreExpr
body')
where ([(EvVar, CoreExpr)]
bs, CoreExpr
body') = CoreExpr -> ([(EvVar, CoreExpr)], CoreExpr)
split_lets CoreExpr
body
split_lets CoreExpr
e = ([], CoreExpr
e)
wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets :: VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
_ [] CoreExpr
body = CoreExpr
body
wrap_lets VarSet
needed ((EvVar
d, CoreExpr
r) : [(EvVar, CoreExpr)]
bs) CoreExpr
body
| VarSet
rhs_fvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
needed = CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (EvVar -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec EvVar
d CoreExpr
r) (VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed' [(EvVar, CoreExpr)]
bs CoreExpr
body)
| Bool
otherwise = VarSet -> [(EvVar, CoreExpr)] -> CoreExpr -> CoreExpr
wrap_lets VarSet
needed [(EvVar, CoreExpr)]
bs CoreExpr
body
where
rhs_fvs :: VarSet
rhs_fvs = CoreExpr -> VarSet
exprFreeVars CoreExpr
r
needed' :: VarSet
needed' = (VarSet
needed VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
rhs_fvs) VarSet -> EvVar -> VarSet
`extendVarSet` EvVar
d
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
dsHsWrapper HsWrapper
WpHole = (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall (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 EvVar
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
$ EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
ev
dsHsWrapper (WpTyLam EvVar
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
$ EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
tv
dsHsWrapper (WpLet TcEvBinds
ev_binds) = do { [CoreBind]
bs <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
ev_binds
; (CoreExpr -> CoreExpr) -> DsM (CoreExpr -> CoreExpr)
forall (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 { EvVar
x <- Type -> Type -> DsM EvVar
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 (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
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 -> (EvVar -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam EvVar
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) = ASSERT(coercionRole co == Representational)
(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) = ASSERT( null rest )
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 (EvVar, CoreExpr)
ds_bs <- (EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr))
-> Bag EvBind
-> IOEnv (Env DsGblEnv DsLclEnv) (Bag (EvVar, CoreExpr))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
dsEvBind Bag EvBind
bs
; [CoreBind] -> DsM [CoreBind]
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (EvVar, CoreExpr) -> [CoreBind]
mk_ev_binds Bag (EvVar, CoreExpr)
ds_bs) }
mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
mk_ev_binds :: Bag (EvVar, CoreExpr) -> [CoreBind]
mk_ev_binds Bag (EvVar, CoreExpr)
ds_binds
= (SCC (EvVar, CoreExpr) -> CoreBind)
-> [SCC (EvVar, CoreExpr)] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map SCC (EvVar, CoreExpr) -> CoreBind
forall {b}. SCC (b, Expr b) -> Bind b
ds_scc ([Node EvVar (EvVar, CoreExpr)] -> [SCC (EvVar, CoreExpr)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node EvVar (EvVar, CoreExpr)]
edges)
where
edges :: [ Node EvVar (EvVar,CoreExpr) ]
edges :: [Node EvVar (EvVar, CoreExpr)]
edges = ((EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
-> [Node EvVar (EvVar, CoreExpr)])
-> [Node EvVar (EvVar, CoreExpr)]
-> Bag (EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (Node EvVar (EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
-> [Node EvVar (EvVar, CoreExpr)])
-> ((EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr))
-> (EvVar, CoreExpr)
-> [Node EvVar (EvVar, CoreExpr)]
-> [Node EvVar (EvVar, CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr)
mk_node) [] Bag (EvVar, CoreExpr)
ds_binds
mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
mk_node :: (EvVar, CoreExpr) -> Node EvVar (EvVar, CoreExpr)
mk_node b :: (EvVar, CoreExpr)
b@(EvVar
var, CoreExpr
rhs)
= DigraphNode { node_payload :: (EvVar, CoreExpr)
node_payload = (EvVar, CoreExpr)
b
, node_key :: EvVar
node_key = EvVar
var
, node_dependencies :: [EvVar]
node_dependencies = VarSet -> [EvVar]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (VarSet -> [EvVar]) -> VarSet -> [EvVar]
forall a b. (a -> b) -> a -> b
$
CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs VarSet -> VarSet -> VarSet
`unionVarSet`
Type -> VarSet
coVarsOfType (EvVar -> Type
varType EvVar
var) }
ds_scc :: SCC (b, Expr b) -> Bind b
ds_scc (AcyclicSCC (b
v,Expr b
r)) = b -> Expr b -> Bind b
forall b. b -> Expr b -> Bind b
NonRec b
v Expr b
r
ds_scc (CyclicSCC [(b, Expr b)]
prs) = [(b, Expr b)] -> Bind b
forall b. [(b, Expr b)] -> Bind b
Rec [(b, Expr b)]
prs
dsEvBind :: EvBind -> DsM (Id, CoreExpr)
dsEvBind :: EvBind -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
dsEvBind (EvBind { eb_lhs :: EvBind -> EvVar
eb_lhs = EvVar
v, eb_rhs :: EvBind -> EvTerm
eb_rhs = EvTerm
r}) = (CoreExpr -> (EvVar, CoreExpr))
-> DsM CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) (EvVar, CoreExpr)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) EvVar
v) (EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
r)
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm :: EvTerm -> DsM CoreExpr
dsEvTerm (EvExpr CoreExpr
e) = CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
dsEvTerm (EvTypeable Type
ty EvTypeable
ev) = Type -> EvTypeable -> DsM CoreExpr
dsEvTypeable Type
ty EvTypeable
ev
dsEvTerm (EvFun { et_tvs :: EvTerm -> [EvVar]
et_tvs = [EvVar]
tvs, et_given :: EvTerm -> [EvVar]
et_given = [EvVar]
given
, et_binds :: EvTerm -> TcEvBinds
et_binds = TcEvBinds
ev_binds, et_body :: EvTerm -> EvVar
et_body = EvVar
wanted_id })
= do { [CoreBind]
ds_ev_binds <- TcEvBinds -> DsM [CoreBind]
dsTcEvBinds TcEvBinds
ev_binds
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> DsM CoreExpr) -> CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$ ([EvVar] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([EvVar]
tvs [EvVar] -> [EvVar] -> [EvVar]
forall a. [a] -> [a] -> [a]
++ [EvVar]
given) (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
[CoreBind] -> CoreExpr -> CoreExpr
mkCoreLets [CoreBind]
ds_ev_binds (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
wanted_id) }
dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
dsEvTypeable Type
ty EvTypeable
ev
= do { TyCon
tyCl <- Name -> DsM TyCon
dsLookupTyCon Name
typeableClassName
; let kind :: Type
kind = 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 { EvVar
mkTrCon <- Name -> DsM EvVar
dsLookupGlobalId Name
mkTrConName
; TyCon
someTypeRepTyCon <- Name -> DsM TyCon
dsLookupTyCon Name
someTypeRepTyConName
; DataCon
someTypeRepDataCon <- Name -> DsM DataCon
dsLookupDataCon Name
someTypeRepDataConName
; CoreExpr
tc_rep <- TyCon -> DsM CoreExpr
tyConRep TyCon
tc
; let ks :: [Type]
ks = 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 (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 ]
; 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
; EvVar
mkTrApp <- Name -> DsM EvVar
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 (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
mkTrApp) [ Type
k1, Type
k2, Type
t1, Type
t2 ])
[ CoreExpr
e1, CoreExpr
e2 ]
; CoreExpr -> DsM CoreExpr
forall (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
; EvVar
mkTrFun <- Name -> DsM EvVar
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 (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
mkTrFun) [Type
m, Type
r1, Type
r2, Type
t1, Type
t2])
[ CoreExpr
em, CoreExpr
e1, CoreExpr
e2 ]
}
ds_ev_typeable Type
ty (EvTypeableTyLit EvTerm
ev)
=
do { EvVar
fun <- Name -> DsM EvVar
dsLookupGlobalId Name
tr_fun
; CoreExpr
dict <- EvTerm -> DsM CoreExpr
dsEvTerm EvTerm
ev
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
fun) [Type
ty]) [ CoreExpr
dict ]) }
where
ty_kind :: Type
ty_kind = 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
; EvVar
typeRepId <- Name -> DsM EvVar
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 (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
typeRepId) [Type]
ty_args) [ CoreExpr
typeable_expr ]) }
tyConRep :: TyCon -> DsM CoreExpr
tyConRep :: TyCon -> DsM CoreExpr
tyConRep TyCon
tc
| Just Name
tc_rep_nm <- TyCon -> Maybe Name
tyConRepName_maybe TyCon
tc
= do { EvVar
tc_rep_id <- Name -> DsM EvVar
dsLookupGlobalId Name
tc_rep_nm
; CoreExpr -> DsM CoreExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (EvVar -> CoreExpr
forall b. EvVar -> Expr b
Var EvVar
tc_rep_id) }
| Bool
otherwise
= String -> SDoc -> DsM CoreExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tyConRep" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)