{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
) where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} DsExpr( dsLExpr )
import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches )
import GHC.Hs
import CoreSyn
import CoreOpt ( simpleOptExpr )
import OccurAnal ( occurAnalyseExpr )
import MkCore
import CoreUtils
import CoreArity ( etaExpand )
import CoreUnfold
import CoreFVs
import Digraph
import Predicate
import PrelNames
import TyCon
import TcEvidence
import TcType
import Type
import Coercion
import TysWiredIn ( typeNatKind, typeSymbolKind )
import Id
import MkId(proxyHashId)
import Name
import VarSet
import Rules
import VarEnv
import Var( EvVar )
import Outputable
import Module
import SrcLoc
import Maybes
import OrdList
import Bag
import BasicTypes
import DynFlags
import FastString
import Util
import UniqSet( nonDetEltsUniqSet )
import MonadUtils
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 (LHsBinds GhcTc -> Bool
forall a. Bag a -> Bool
isEmptyBag LHsBinds GhcTc
unlifted_binds) Bool -> Bool -> Bool
|| Bool -> Bool
not (LHsBinds GhcTc -> Bool
forall a. Bag a -> Bool
isEmptyBag LHsBinds GhcTc
bang_binds)
= do { (LHsBindLR GhcTc GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> LHsBinds GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (String -> LHsBindLR GhcTc GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a.
(HasSrcSpan a, Outputable (SrcSpanLess a)) =>
String -> a -> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err String
"bindings for unlifted types") LHsBinds GhcTc
unlifted_binds
; (LHsBindLR GhcTc GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ())
-> LHsBinds GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Bag a -> m ()
mapBagM_ (String -> LHsBindLR GhcTc GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a.
(HasSrcSpan a, Outputable (SrcSpanLess a)) =>
String -> a -> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err String
"strict bindings") LHsBinds 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
; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr 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 :: LHsBinds GhcTc
unlifted_binds = (LHsBindLR GhcTc GhcTc -> Bool) -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBind GhcTc -> Bool
isUnliftedHsBind (HsBind GhcTc -> Bool)
-> (LHsBindLR GhcTc GhcTc -> HsBind GhcTc)
-> LHsBindLR GhcTc GhcTc
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBindLR GhcTc GhcTc -> HsBind GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) LHsBinds GhcTc
binds
bang_binds :: LHsBinds GhcTc
bang_binds = (LHsBindLR GhcTc GhcTc -> Bool) -> LHsBinds GhcTc -> LHsBinds GhcTc
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag (HsBind GhcTc -> Bool
isBangedHsBind (HsBind GhcTc -> Bool)
-> (LHsBindLR GhcTc GhcTc -> HsBind GhcTc)
-> LHsBindLR GhcTc GhcTc
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBindLR GhcTc GhcTc -> HsBind GhcTc
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) LHsBinds GhcTc
binds
top_level_err :: String -> a -> IOEnv (Env DsGblEnv DsLclEnv) ()
top_level_err String
desc (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess a
bind)
= SrcSpan
-> IOEnv (Env DsGblEnv DsLclEnv) ()
-> IOEnv (Env DsGblEnv DsLclEnv) ()
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs SrcSpan
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 (SrcSpanLess a -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpanLess 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 <- (LHsBindLR GhcTc GhcTc -> DsM ([Id], [(Id, CoreExpr)]))
-> LHsBinds GhcTc
-> IOEnv (Env DsGblEnv DsLclEnv) (Bag ([Id], [(Id, CoreExpr)]))
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Bag a -> m (Bag b)
mapBagM LHsBindLR GhcTc GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBind 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 :: LHsBindLR GhcTc GhcTc -> DsM ([Id], [(Id, CoreExpr)])
dsLHsBind (LHsBindLR GhcTc GhcTc
-> Located (SrcSpanLess (LHsBindLR GhcTc GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsBindLR GhcTc GhcTc)
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 SrcSpan
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 SrcSpanLess (LHsBindLR GhcTc GhcTc)
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
, var_inline :: forall idL idR. HsBindLR idL idR -> Bool
var_inline = Bool
inline_regardless })
= do { CoreExpr
core_expr <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
expr
; let var' :: Id
var' | Bool
inline_regardless = Id
IdP GhcTc
var Id -> Unfolding -> Id
`setIdUnfolding` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
core_expr
| Bool
otherwise = Id
IdP GhcTc
var
; let core_bind :: (Id, CoreExpr)
core_bind@(Id
id,CoreExpr
_) = DynFlags -> Id -> Bool -> Int -> CoreExpr -> (Id, CoreExpr)
makeCorePair DynFlags
dflags Id
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 -> Located (IdP idL)
fun_id = (Located (IdP GhcTc) -> Located (SrcSpanLess (Located Id))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located Id)
fun)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches = MatchGroup GhcTc (LHsExpr GhcTc)
matches
, fun_co_fn :: forall idL idR. HsBindLR idL idR -> HsWrapper
fun_co_fn = HsWrapper
co_fn
, fun_tick :: forall idL idR. HsBindLR idL idR -> [Tickish Id]
fun_tick = [Tickish Id]
tick })
= do { ([Id]
args, CoreExpr
body) <- HsMatchContext Name
-> Maybe (LHsExpr GhcTc)
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
matchWrapper
(Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs (SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (Located Name) -> Located Name)
-> SrcSpanLess (Located Name) -> Located Name
forall a b. (a -> b) -> a -> b
$ Id -> Name
idName SrcSpanLess (Located Id)
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
co_fn
; let body' :: CoreExpr
body' = [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox [Tickish Id]
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 SrcSpanLess (Located Id)
Id
fun Bool
False Int
0 CoreExpr
rhs
force_var :: [Id]
force_var
| Extension -> DynFlags -> Bool
xopt Extension
LangExt.Strict DynFlags
dflags
, MatchGroup GhcTc (LHsExpr GhcTc) -> Int
forall (id :: Pass) body. MatchGroup (GhcPass id) body -> Int
matchGroupArity 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 = NPatBindTc _ ty
, pat_ticks :: forall idL idR. HsBindLR idL idR -> ([Tickish Id], [[Tickish Id]])
pat_ticks = ([Tickish Id]
rhs_tick, [[Tickish Id]]
var_ticks) })
= do { CoreExpr
body_expr <- GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
dsGuarded GRHSs GhcTc (LHsExpr GhcTc)
grhss Type
ty
; HsMatchContext Name
-> GRHSs GhcTc (LHsExpr GhcTc) -> IOEnv (Env DsGblEnv DsLclEnv) ()
checkGuardMatches HsMatchContext Name
forall id. HsMatchContext id
PatBindGuards GRHSs GhcTc (LHsExpr GhcTc)
grhss
; let body' :: CoreExpr
body' = [Tickish Id] -> CoreExpr -> CoreExpr
mkOptTickBox [Tickish Id]
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) <- [[Tickish Id]]
-> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])
mkSelectorBinds [[Tickish Id]]
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 <- Bool
-> (DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)]))
-> DsM ([Id], [(Id, CoreExpr)])
-> DsM ([Id], [(Id, CoreExpr)])
forall a. Bool -> (a -> a) -> a -> a
applyWhen (DynFlags -> Origin -> Bool
needToRunPmCheck DynFlags
dflags Origin
FromSource)
(Bag Id
-> DsM ([Id], [(Id, CoreExpr)]) -> DsM ([Id], [(Id, CoreExpr)])
forall a. Bag Id -> DsM a -> DsM a
addTyCsDs ([Id] -> Bag Id
forall a. [a] -> Bag a
listToBag [Id]
dicts))
(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"
dsHsBind DynFlags
_ (XHsBindsLR XXHsBindsLR GhcTc GhcTc
nec) = NoExtCon -> DsM ([Id], [(Id, CoreExpr)])
forall a. NoExtCon -> a
noExtCon XXHsBindsLR GhcTc GhcTc
NoExtCon
nec
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))) }
mk_bind (XABExport XXABExport GhcTc
nec) = NoExtCon -> IOEnv (Env DsGblEnv DsLclEnv) (Id, CoreExpr)
forall a. NoExtCon -> a
noExtCon XXABExport GhcTc
NoExtCon
nec
; [(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 -> DsM Id
newSysLocalDs (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 -> DsM Id
newSysLocalDs 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) }
mk_bind (XABExport XXABExport GhcTc
nec) = NoExtCon -> IOEnv (Env DsGblEnv DsLclEnv) [(Id, CoreExpr)]
forall a. NoExtCon -> a
noExtCon XXABExport GhcTc
NoExtCon
nec
; [[(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 -> DsM Id
newSysLocalDs
(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 = XABE GhcTc
NoExtField
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` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs, CoreExpr
rhs)
| Bool
otherwise
= case InlinePragma -> InlineSpec
inlinePragmaSpec InlinePragma
inline_prag of
InlineSpec
NoUserInline -> (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
inline_prag :: InlinePragma
inline_prag = Id -> InlinePragma
idInlinePragma Id
gbl_id
inlinable_unf :: Unfolding
inlinable_unf = DynFlags -> CoreExpr -> Unfolding
mkInlinableUnfolding DynFlags
dflags 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 -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity Int
real_arity 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` CoreExpr -> Unfolding
mkInlineUnfolding 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 (LTcSpecPrag -> Located (SrcSpanLess LTcSpecPrag)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (SpecPrag poly_id spec_co 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 { 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 (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 { 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 (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 { WarnReason -> SDoc -> IOEnv (Env DsGblEnv DsLclEnv) ()
warnDs WarnReason
NoReason 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]
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
spec_unf :: Unfolding
spec_unf = DynFlags
-> [Id] -> (CoreExpr -> CoreExpr) -> Int -> Unfolding -> Unfolding
specUnfolding DynFlags
dflags [Id]
spec_bndrs CoreExpr -> CoreExpr
core_app Int
arity_decrease Unfolding
fn_unf
spec_id :: Id
spec_id = Name -> Type -> Id
mkLocalId Name
spec_name Type
spec_ty
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
inl_prag
Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
spec_unf
arity_decrease :: Int
arity_decrease = (CoreExpr -> Bool) -> [CoreExpr] -> Int
forall a. (a -> Bool) -> [a] -> Int
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
args Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
spec_bndrs
; 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]
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
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 -> [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
lhs1 :: CoreExpr
lhs1 = CoreExpr -> CoreExpr
drop_dicts CoreExpr
orig_lhs
lhs2 :: CoreExpr
lhs2 = DynFlags -> CoreExpr -> CoreExpr
simpleOptExpr DynFlags
dflags 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 = [ Name -> Type -> Id
mkLocalId (Name -> Name
localiseName (Id -> Name
idName Id
d)) (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
_ [(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 Type
t1 SDoc
doc)
= do { Id
x <- Type -> DsM Id
newSysLocalDsNoLP 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) = 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) }
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 (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
k1, Type
k2) = 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
ev1 EvTerm
ev2)
| Just (Type
t1,Type
t2) <- Type -> Maybe (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
; 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
r1, Type
r2, Type
t1, Type
t2])
[ 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
; let proxy :: CoreExpr
proxy = CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
proxyHashId) [Type
ty_kind, 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
fun) [Type
ty]) [ CoreExpr
dict, CoreExpr
proxy ]) }
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
typeNatKind = Name
typeNatTypeRepName
| Type
ty_kind Type -> Type -> Bool
`eqType` Type
typeSymbolKind = Name
typeSymbolTypeRepName
| 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)