{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore (
deSugar, deSugarExpr
) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
import GHC.Driver.Config.HsToCore.Ticks
import GHC.Driver.Config.HsToCore.Usage
import GHC.Driver.Env
import GHC.Driver.Backend
import GHC.Driver.Plugins
import GHC.Hs
import GHC.HsToCore.Usage
import GHC.HsToCore.Monad
import GHC.HsToCore.Errors.Types
import GHC.HsToCore.Expr
import GHC.HsToCore.Binds
import GHC.HsToCore.Foreign.Decl
import GHC.HsToCore.Ticks
import GHC.HsToCore.Breakpoints
import GHC.HsToCore.Coverage
import GHC.HsToCore.Docs
import GHC.Tc.Types
import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceLoad )
import GHC.Tc.Module ( runTcInteractive )
import GHC.Core.Type
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon ( tyConDataCons )
import GHC.Core
import GHC.Core.FVs ( exprsSomeFreeVarsList, exprFreeVars )
import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
import GHC.Core.Utils
import GHC.Core.Unfold.Make
import GHC.Core.Coercion
import GHC.Core.DataCon ( dataConWrapId )
import GHC.Core.Make
import GHC.Core.Rules
import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
import GHC.Core.Ppr
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
import GHC.Data.OrdList
import GHC.Data.SizedSeq ( sizeSS )
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Logger
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.ForeignStubs
import GHC.Types.Avail
import GHC.Types.Basic
import GHC.Types.Var.Set
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.TypeEnv
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.Name.Ppr
import GHC.Types.HpcInfo
import GHC.Unit
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import Data.List (partition)
import Data.IORef
import Data.Traversable (for)
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
deSugar :: HscEnv
-> ModLocation
-> TcGblEnv
-> IO (Messages DsMessage, Maybe ModGuts)
deSugar HscEnv
hsc_env
ModLocation
mod_loc
tcg_env :: TcGblEnv
tcg_env@(TcGblEnv { tcg_mod :: TcGblEnv -> Module
tcg_mod = Module
id_mod,
tcg_semantic_mod :: TcGblEnv -> Module
tcg_semantic_mod = Module
mod,
tcg_src :: TcGblEnv -> HscSource
tcg_src = HscSource
hsc_src,
tcg_type_env :: TcGblEnv -> TypeEnv
tcg_type_env = TypeEnv
type_env,
tcg_imports :: TcGblEnv -> ImportAvails
tcg_imports = ImportAvails
imports,
tcg_exports :: TcGblEnv -> [AvailInfo]
tcg_exports = [AvailInfo]
exports,
tcg_keep :: TcGblEnv -> TcRef NameSet
tcg_keep = TcRef NameSet
keep_var,
tcg_th_splice_used :: TcGblEnv -> TcRef Bool
tcg_th_splice_used = TcRef Bool
tc_splice_used,
tcg_rdr_env :: TcGblEnv -> GlobalRdrEnv
tcg_rdr_env = GlobalRdrEnv
rdr_env,
tcg_fix_env :: TcGblEnv -> FixityEnv
tcg_fix_env = FixityEnv
fix_env,
tcg_inst_env :: TcGblEnv -> InstEnv
tcg_inst_env = InstEnv
inst_env,
tcg_fam_inst_env :: TcGblEnv -> FamInstEnv
tcg_fam_inst_env = FamInstEnv
fam_inst_env,
tcg_merged :: TcGblEnv -> [(Module, Fingerprint)]
tcg_merged = [(Module, Fingerprint)]
merged,
tcg_warns :: TcGblEnv -> Warnings GhcRn
tcg_warns = Warnings GhcRn
warns,
tcg_anns :: TcGblEnv -> [Annotation]
tcg_anns = [Annotation]
anns,
tcg_binds :: TcGblEnv -> LHsBinds GhcTc
tcg_binds = LHsBinds GhcTc
binds,
tcg_imp_specs :: TcGblEnv -> [LTcSpecPrag]
tcg_imp_specs = [LTcSpecPrag]
imp_specs,
tcg_dependent_files :: TcGblEnv -> TcRef [FilePath]
tcg_dependent_files = TcRef [FilePath]
dependent_files,
tcg_ev_binds :: TcGblEnv -> Bag EvBind
tcg_ev_binds = Bag EvBind
ev_binds,
tcg_th_foreign_files :: TcGblEnv -> TcRef [(ForeignSrcLang, FilePath)]
tcg_th_foreign_files = TcRef [(ForeignSrcLang, FilePath)]
th_foreign_files_var,
tcg_fords :: TcGblEnv -> [LForeignDecl GhcTc]
tcg_fords = [LForeignDecl GhcTc]
fords,
tcg_rules :: TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
rules,
tcg_patsyns :: TcGblEnv -> [PatSyn]
tcg_patsyns = [PatSyn]
patsyns,
tcg_tcs :: TcGblEnv -> [TyCon]
tcg_tcs = [TyCon]
tcs,
tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts = [ClsInst]
insts,
tcg_fam_insts :: TcGblEnv -> [FamInst]
tcg_fam_insts = [FamInst]
fam_insts,
tcg_hpc :: TcGblEnv -> Bool
tcg_hpc = Bool
other_hpc_info,
tcg_complete_matches :: TcGblEnv -> CompleteMatches
tcg_complete_matches = CompleteMatches
complete_matches,
tcg_self_boot :: TcGblEnv -> SelfBootInfo
tcg_self_boot = SelfBootInfo
self_boot
})
= do { let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
name_ppr_ctx :: NamePprCtx
name_ppr_ctx = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
; Logger
-> SDoc
-> ((Messages DsMessage, Maybe ModGuts) -> ())
-> IO (Messages DsMessage, Maybe ModGuts)
-> IO (Messages DsMessage, Maybe ModGuts)
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Desugar"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod))
(() -> (Messages DsMessage, Maybe ModGuts) -> ()
forall a b. a -> b -> a
const ()) (IO (Messages DsMessage, Maybe ModGuts)
-> IO (Messages DsMessage, Maybe ModGuts))
-> IO (Messages DsMessage, Maybe ModGuts)
-> IO (Messages DsMessage, Maybe ModGuts)
forall a b. (a -> b) -> a -> b
$
do {
; let export_set :: NameSet
export_set = [AvailInfo] -> NameSet
availsToNameSet [AvailInfo]
exports
bcknd :: Backend
bcknd = DynFlags -> Backend
backend DynFlags
dflags
; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds_cvr, Maybe (FilePath, SizedSeq Tick)
m_tickInfo)
<- if Bool -> Bool
not (HscSource -> Bool
isHsBootOrSig HscSource
hsc_src)
then Logger
-> TicksConfig
-> Module
-> ModLocation
-> NameSet
-> [TyCon]
-> LHsBinds GhcTc
-> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))
addTicksToBinds
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(DynFlags -> TicksConfig
initTicksConfig (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env))
Module
mod ModLocation
mod_loc
NameSet
export_set (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env) LHsBinds GhcTc
binds
else (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Maybe (FilePath, SizedSeq Tick))
-> IO
(Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)),
Maybe (FilePath, SizedSeq Tick))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds, Maybe (FilePath, SizedSeq Tick)
forall a. Maybe a
Nothing)
; Maybe ModBreaks
modBreaks <- Maybe (Interp, SizedSeq Tick)
-> ((Interp, SizedSeq Tick) -> IO ModBreaks)
-> IO (Maybe ModBreaks)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for
[ (Interp
i, SizedSeq Tick
s)
| Interp
i <- HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env
, (FilePath
_, SizedSeq Tick
s) <- Maybe (FilePath, SizedSeq Tick)
m_tickInfo
, Backend -> Bool
backendWantsBreakpointTicks (DynFlags -> Backend
backend DynFlags
dflags)
]
(((Interp, SizedSeq Tick) -> IO ModBreaks) -> IO (Maybe ModBreaks))
-> ((Interp, SizedSeq Tick) -> IO ModBreaks)
-> IO (Maybe ModBreaks)
forall a b. (a -> b) -> a -> b
$ \(Interp
interp, SizedSeq Tick
specs) -> Interp -> Module -> SizedSeq Tick -> IO ModBreaks
mkModBreaks Interp
interp Module
mod SizedSeq Tick
specs
; HpcInfo
ds_hpc_info <- case Maybe (FilePath, SizedSeq Tick)
m_tickInfo of
Just (FilePath
orig_file2, SizedSeq Tick
ticks)
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc (DynFlags -> Bool) -> DynFlags -> Bool
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
-> do
Int
hashNo <- if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc (DynFlags -> Bool) -> DynFlags -> Bool
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
then FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int
writeMixEntries (DynFlags -> FilePath
hpcDir DynFlags
dflags) Module
mod SizedSeq Tick
ticks FilePath
orig_file2
else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
HpcInfo -> IO HpcInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HpcInfo -> IO HpcInfo) -> HpcInfo -> IO HpcInfo
forall a b. (a -> b) -> a -> b
$ Int -> Int -> HpcInfo
HpcInfo (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ SizedSeq Tick -> Word
forall a. SizedSeq a -> Word
sizeSS SizedSeq Tick
ticks) Int
hashNo
Maybe (FilePath, SizedSeq Tick)
_ -> HpcInfo -> IO HpcInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HpcInfo -> IO HpcInfo) -> HpcInfo -> IO HpcInfo
forall a b. (a -> b) -> a -> b
$ Bool -> HpcInfo
emptyHpcInfo Bool
other_hpc_info
; (Messages DsMessage
msgs, Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
mb_res) <- HscEnv
-> TcGblEnv
-> DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> IO
(Messages DsMessage,
Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs))
forall a.
HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
initDs HscEnv
hsc_env TcGblEnv
tcg_env (DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> IO
(Messages DsMessage,
Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)))
-> DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> IO
(Messages DsMessage,
Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs))
forall a b. (a -> b) -> a -> b
$
do { [CoreBind]
ds_ev_binds <- Bag EvBind -> DsM [CoreBind]
dsEvBinds Bag EvBind
ev_binds
; OrdList Binding
core_prs <- LHsBinds GhcTc -> DsM (OrdList Binding)
dsTopLHsBinds LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds_cvr
; OrdList Binding
core_prs <- OrdList Binding -> DsM (OrdList Binding)
patchMagicDefns OrdList Binding
core_prs
; (OrdList Binding
spec_prs, [CoreRule]
spec_rules) <- [LTcSpecPrag] -> DsM (OrdList Binding, [CoreRule])
dsImpSpecs [LTcSpecPrag]
imp_specs
; (ForeignStubs
ds_fords, OrdList Binding
foreign_prs) <- [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns [LForeignDecl GhcTc]
fords
; [CoreRule]
ds_rules <- (GenLocated SrcSpanAnnA (RuleDecl GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule))
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> IOEnv (Env DsGblEnv DsLclEnv) [CoreRule]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM LRuleDecl GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
GenLocated SrcSpanAnnA (RuleDecl GhcTc)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
dsRule [LRuleDecl GhcTc]
[GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules
; let hpc_init :: CStub
hpc_init
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc DynFlags
dflags = Platform -> Module -> HpcInfo -> CStub
hpcInitCode (DynFlags -> Platform
targetPlatform (DynFlags -> Platform) -> DynFlags -> Platform
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) Module
mod HpcInfo
ds_hpc_info
| Bool
otherwise = CStub
forall a. Monoid a => a
mempty
; ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
-> DsM ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [CoreBind]
ds_ev_binds
, OrdList Binding
foreign_prs OrdList Binding -> OrdList Binding -> OrdList Binding
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Binding
core_prs OrdList Binding -> OrdList Binding -> OrdList Binding
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Binding
spec_prs
, [CoreRule]
spec_rules [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
ds_rules
, ForeignStubs
ds_fords ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
hpc_init) }
; case Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
mb_res of {
Maybe ([CoreBind], OrdList Binding, [CoreRule], ForeignStubs)
Nothing -> (Messages DsMessage, Maybe ModGuts)
-> IO (Messages DsMessage, Maybe ModGuts)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DsMessage
msgs, Maybe ModGuts
forall a. Maybe a
Nothing) ;
Just ([CoreBind]
ds_ev_binds, OrdList Binding
all_prs, [CoreRule]
all_rules, ForeignStubs
ds_fords) ->
do {
NameSet
keep_alive <- TcRef NameSet -> IO NameSet
forall a. IORef a -> IO a
readIORef TcRef NameSet
keep_var
; let ([CoreRule]
rules_for_locals, [CoreRule]
rules_for_imps) = (CoreRule -> Bool) -> [CoreRule] -> ([CoreRule], [CoreRule])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition CoreRule -> Bool
isLocalRule [CoreRule]
all_rules
final_prs :: [Binding]
final_prs = Backend
-> NameSet -> NameSet -> [CoreRule] -> [Binding] -> [Binding]
forall t.
Backend
-> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules Backend
bcknd NameSet
export_set NameSet
keep_alive
[CoreRule]
rules_for_locals (OrdList Binding -> [Binding]
forall a. OrdList a -> [a]
fromOL OrdList Binding
all_prs)
final_pgm :: [CoreBind]
final_pgm = [CoreBind] -> [Binding] -> [CoreBind]
combineEvBinds [CoreBind]
ds_ev_binds [Binding]
final_prs
; HscEnv
-> NamePprCtx -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
endPassHscEnvIO HscEnv
hsc_env NamePprCtx
name_ppr_ctx CoreToDo
CoreDesugar [CoreBind]
final_pgm [CoreRule]
rules_for_imps
; let simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
; let ([CoreBind]
ds_binds, [CoreRule]
ds_rules_for_imps, [CoreBind]
occ_anald_binds)
= SimpleOpts
-> Module
-> [CoreBind]
-> [CoreRule]
-> ([CoreBind], [CoreRule], [CoreBind])
simpleOptPgm SimpleOpts
simpl_opts Module
mod [CoreBind]
final_pgm [CoreRule]
rules_for_imps
; Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_occur_anal FilePath
"Occurrence analysis"
DumpFormat
FormatCore ([CoreBind] -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings [CoreBind]
occ_anald_binds SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [CoreRule] -> SDoc
pprRules [CoreRule]
ds_rules_for_imps )
; HscEnv
-> NamePprCtx -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
endPassHscEnvIO HscEnv
hsc_env NamePprCtx
name_ppr_ctx CoreToDo
CoreDesugarOpt [CoreBind]
ds_binds [CoreRule]
ds_rules_for_imps
; let used_names :: NameSet
used_names = TcGblEnv -> NameSet
mkUsedNames TcGblEnv
tcg_env
pluginModules :: [ModIface]
pluginModules = (LoadedPlugin -> ModIface) -> [LoadedPlugin] -> [ModIface]
forall a b. (a -> b) -> [a] -> [b]
map LoadedPlugin -> ModIface
lpModule (Plugins -> [LoadedPlugin]
loadedPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env))
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
; let deps :: Dependencies
deps = HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies
mkDependencies HomeUnit
home_unit
(TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env)
(TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env)
((ModIface -> Module) -> [ModIface] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module [ModIface]
pluginModules)
; Bool
used_th <- TcRef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef TcRef Bool
tc_splice_used
; [FilePath]
dep_files <- TcRef [FilePath] -> IO [FilePath]
forall a. IORef a -> IO a
readIORef TcRef [FilePath]
dependent_files
; SafeHaskellMode
safe_mode <- DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env
; ([Linkable]
needed_mods, PkgsLoaded
needed_pkgs) <- IORef ([Linkable], PkgsLoaded) -> IO ([Linkable], PkgsLoaded)
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef ([Linkable], PkgsLoaded)
tcg_th_needed_deps TcGblEnv
tcg_env)
; let uc :: UsageConfig
uc = HscEnv -> UsageConfig
initUsageConfig HscEnv
hsc_env
; let plugins :: Plugins
plugins = HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env
; let fc :: FinderCache
fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
; let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
; [Usage]
usages <- HscEnv -> IfG [Usage] -> IO [Usage]
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG [Usage] -> IO [Usage]) -> IfG [Usage] -> IO [Usage]
forall a b. (a -> b) -> a -> b
$
UsageConfig
-> Plugins
-> FinderCache
-> UnitEnv
-> Module
-> ImportedMods
-> NameSet
-> [FilePath]
-> [(Module, Fingerprint)]
-> [Linkable]
-> PkgsLoaded
-> IfG [Usage]
mkUsageInfo UsageConfig
uc Plugins
plugins FinderCache
fc UnitEnv
unit_env Module
mod (ImportAvails -> ImportedMods
imp_mods ImportAvails
imports) NameSet
used_names
[FilePath]
dep_files [(Module, Fingerprint)]
merged [Linkable]
needed_mods PkgsLoaded
needed_pkgs
; Bool -> IO ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Module
id_mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
mod)
; [(ForeignSrcLang, FilePath)]
foreign_files <- TcRef [(ForeignSrcLang, FilePath)]
-> IO [(ForeignSrcLang, FilePath)]
forall a. IORef a -> IO a
readIORef TcRef [(ForeignSrcLang, FilePath)]
th_foreign_files_var
; Maybe Docs
docs <- DynFlags -> TcGblEnv -> IO (Maybe Docs)
forall (m :: * -> *).
MonadIO m =>
DynFlags -> TcGblEnv -> m (Maybe Docs)
extractDocs DynFlags
dflags TcGblEnv
tcg_env
; let mod_guts :: ModGuts
mod_guts = ModGuts {
mg_module :: Module
mg_module = Module
mod,
mg_hsc_src :: HscSource
mg_hsc_src = HscSource
hsc_src,
mg_loc :: SrcSpan
mg_loc = ModLocation -> SrcSpan
mkFileSrcSpan ModLocation
mod_loc,
mg_exports :: [AvailInfo]
mg_exports = [AvailInfo]
exports,
mg_usages :: [Usage]
mg_usages = [Usage]
usages,
mg_deps :: Dependencies
mg_deps = Dependencies
deps,
mg_used_th :: Bool
mg_used_th = Bool
used_th,
mg_rdr_env :: GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env,
mg_fix_env :: FixityEnv
mg_fix_env = FixityEnv
fix_env,
mg_warns :: Warnings GhcRn
mg_warns = Warnings GhcRn
warns,
mg_anns :: [Annotation]
mg_anns = [Annotation]
anns,
mg_tcs :: [TyCon]
mg_tcs = [TyCon]
tcs,
mg_insts :: [ClsInst]
mg_insts = SafeHaskellMode -> [ClsInst] -> [ClsInst]
fixSafeInstances SafeHaskellMode
safe_mode [ClsInst]
insts,
mg_fam_insts :: [FamInst]
mg_fam_insts = [FamInst]
fam_insts,
mg_inst_env :: InstEnv
mg_inst_env = InstEnv
inst_env,
mg_fam_inst_env :: FamInstEnv
mg_fam_inst_env = FamInstEnv
fam_inst_env,
mg_boot_exports :: NameSet
mg_boot_exports = SelfBootInfo -> NameSet
bootExports SelfBootInfo
self_boot,
mg_patsyns :: [PatSyn]
mg_patsyns = [PatSyn]
patsyns,
mg_rules :: [CoreRule]
mg_rules = [CoreRule]
ds_rules_for_imps,
mg_binds :: [CoreBind]
mg_binds = [CoreBind]
ds_binds,
mg_foreign :: ForeignStubs
mg_foreign = ForeignStubs
ds_fords,
mg_foreign_files :: [(ForeignSrcLang, FilePath)]
mg_foreign_files = [(ForeignSrcLang, FilePath)]
foreign_files,
mg_hpc_info :: HpcInfo
mg_hpc_info = HpcInfo
ds_hpc_info,
mg_modBreaks :: Maybe ModBreaks
mg_modBreaks = Maybe ModBreaks
modBreaks,
mg_safe_haskell :: SafeHaskellMode
mg_safe_haskell = SafeHaskellMode
safe_mode,
mg_trust_pkg :: Bool
mg_trust_pkg = ImportAvails -> Bool
imp_trust_own_pkg ImportAvails
imports,
mg_complete_matches :: CompleteMatches
mg_complete_matches = CompleteMatches
complete_matches,
mg_docs :: Maybe Docs
mg_docs = Maybe Docs
docs
}
; (Messages DsMessage, Maybe ModGuts)
-> IO (Messages DsMessage, Maybe ModGuts)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DsMessage
msgs, ModGuts -> Maybe ModGuts
forall a. a -> Maybe a
Just ModGuts
mod_guts)
}}}}
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan :: ModLocation -> SrcSpan
mkFileSrcSpan ModLocation
mod_loc
= case ModLocation -> Maybe FilePath
ml_hs_file ModLocation
mod_loc of
Just FilePath
file_path -> FastString -> SrcSpan
mkGeneralSrcSpan (FilePath -> FastString
mkFastString FilePath
file_path)
Maybe FilePath
Nothing -> SrcSpan
interactiveSrcSpan
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList Binding, [CoreRule])
dsImpSpecs [LTcSpecPrag]
imp_specs
= do { [(OrdList Binding, CoreRule)]
spec_prs <- (LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList Binding, CoreRule)))
-> [LTcSpecPrag]
-> IOEnv (Env DsGblEnv DsLclEnv) [(OrdList Binding, CoreRule)]
forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM (Maybe CoreExpr
-> LTcSpecPrag
-> IOEnv
(Env DsGblEnv DsLclEnv) (Maybe (OrdList Binding, CoreRule))
dsSpec Maybe CoreExpr
forall a. Maybe a
Nothing) [LTcSpecPrag]
imp_specs
; let ([OrdList Binding]
spec_binds, [CoreRule]
spec_rules) = [(OrdList Binding, CoreRule)] -> ([OrdList Binding], [CoreRule])
forall a b. [(a, b)] -> ([a], [b])
unzip [(OrdList Binding, CoreRule)]
spec_prs
; (OrdList Binding, [CoreRule]) -> DsM (OrdList Binding, [CoreRule])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([OrdList Binding] -> OrdList Binding
forall a. [OrdList a] -> OrdList a
concatOL [OrdList Binding]
spec_binds, [CoreRule]
spec_rules) }
combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
combineEvBinds :: [CoreBind] -> [Binding] -> [CoreBind]
combineEvBinds [] [Binding]
val_prs
= [[Binding] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [Binding]
val_prs]
combineEvBinds (NonRec Id
b CoreExpr
r : [CoreBind]
bs) [Binding]
val_prs
| Id -> Bool
isId Id
b = [CoreBind] -> [Binding] -> [CoreBind]
combineEvBinds [CoreBind]
bs ((Id
b,CoreExpr
r)Binding -> [Binding] -> [Binding]
forall a. a -> [a] -> [a]
:[Binding]
val_prs)
| Bool
otherwise = Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r CoreBind -> [CoreBind] -> [CoreBind]
forall a. a -> [a] -> [a]
: [CoreBind] -> [Binding] -> [CoreBind]
combineEvBinds [CoreBind]
bs [Binding]
val_prs
combineEvBinds (Rec [Binding]
prs : [CoreBind]
bs) [Binding]
val_prs
= [CoreBind] -> [Binding] -> [CoreBind]
combineEvBinds [CoreBind]
bs ([Binding]
prs [Binding] -> [Binding] -> [Binding]
forall a. [a] -> [a] -> [a]
++ [Binding]
val_prs)
deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
deSugarExpr HscEnv
hsc_env LHsExpr GhcTc
tc_expr = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
Logger -> FilePath -> IO ()
showPass Logger
logger FilePath
"Desugar"
(Messages TcRnMessage
tc_msgs, Maybe (Messages DsMessage, Maybe CoreExpr)
mb_result) <- HscEnv
-> TcRn (Messages DsMessage, Maybe CoreExpr)
-> IO
(Messages TcRnMessage, Maybe (Messages DsMessage, Maybe CoreExpr))
forall a. HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
runTcInteractive HscEnv
hsc_env (TcRn (Messages DsMessage, Maybe CoreExpr)
-> IO
(Messages TcRnMessage, Maybe (Messages DsMessage, Maybe CoreExpr)))
-> TcRn (Messages DsMessage, Maybe CoreExpr)
-> IO
(Messages TcRnMessage, Maybe (Messages DsMessage, Maybe CoreExpr))
forall a b. (a -> b) -> a -> b
$
DsM CoreExpr -> TcRn (Messages DsMessage, Maybe CoreExpr)
forall a. DsM a -> TcM (Messages DsMessage, Maybe a)
initDsTc (DsM CoreExpr -> TcRn (Messages DsMessage, Maybe CoreExpr))
-> DsM CoreExpr -> TcRn (Messages DsMessage, Maybe CoreExpr)
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
tc_expr
Bool -> IO ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Messages TcRnMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages TcRnMessage
tc_msgs)
let (Messages DsMessage
ds_msgs, Maybe CoreExpr
mb_core_expr) = FilePath
-> Maybe (Messages DsMessage, Maybe CoreExpr)
-> (Messages DsMessage, Maybe CoreExpr)
forall a. HasCallStack => FilePath -> Maybe a -> a
expectJust FilePath
"deSugarExpr" Maybe (Messages DsMessage, Maybe CoreExpr)
mb_result
case Maybe CoreExpr
mb_core_expr of
Maybe CoreExpr
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just CoreExpr
expr -> Logger -> DumpFlag -> FilePath -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_ds FilePath
"Desugared"
DumpFormat
FormatCore (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
expr)
let final_res :: Maybe CoreExpr
final_res | Messages DsMessage -> Bool
forall e. Diagnostic e => Messages e -> Bool
errorsFound Messages DsMessage
ds_msgs = Maybe CoreExpr
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe CoreExpr
mb_core_expr
(Messages DsMessage, Maybe CoreExpr)
-> IO (Messages DsMessage, Maybe CoreExpr)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages DsMessage
ds_msgs, Maybe CoreExpr
final_res)
addExportFlagsAndRules
:: Backend -> NameSet -> NameSet -> [CoreRule]
-> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules :: forall t.
Backend
-> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)]
addExportFlagsAndRules Backend
bcknd NameSet
exports NameSet
keep_alive [CoreRule]
rules
= (Id -> Id) -> [(Id, t)] -> [(Id, t)]
forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst (RuleBase -> Id -> Id
addRulesToId RuleBase
rule_base (Id -> Id) -> (Id -> Id) -> Id -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Id
add_export_flag)
where
rule_base :: RuleBase
rule_base = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
emptyRuleBase [CoreRule]
rules
add_export_flag :: Id -> Id
add_export_flag Id
bndr
| Id -> Bool
dont_discard Id
bndr = Id -> Id
setIdExported Id
bndr
| Bool
otherwise = Id
bndr
dont_discard :: Id -> Bool
dont_discard :: Id -> Bool
dont_discard Id
bndr = Name -> Bool
is_exported Name
name
Bool -> Bool -> Bool
|| Name
name Name -> NameSet -> Bool
`elemNameSet` NameSet
keep_alive
where
name :: Name
name = Id -> Name
idName Id
bndr
is_exported :: Name -> Bool
is_exported :: Name -> Bool
is_exported | Backend -> Bool
backendWantsGlobalBindings Backend
bcknd = Name -> Bool
isExternalName
| Bool
otherwise = (Name -> NameSet -> Bool
`elemNameSet` NameSet
exports)
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule :: LRuleDecl GhcTc -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
dsRule (L SrcSpanAnnA
loc (HsRule { rd_name :: forall pass. RuleDecl pass -> XRec pass FastString
rd_name = XRec GhcTc FastString
name
, rd_act :: forall pass. RuleDecl pass -> Activation
rd_act = Activation
rule_act
, rd_tmvs :: forall pass. RuleDecl pass -> [LRuleBndr pass]
rd_tmvs = [LRuleBndr GhcTc]
vars
, rd_lhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_lhs = LHsExpr GhcTc
lhs
, rd_rhs :: forall pass. RuleDecl pass -> XRec pass (HsExpr pass)
rd_rhs = LHsExpr GhcTc
rhs }))
= SrcSpan
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule))
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
-> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a b. (a -> b) -> a -> b
$
do { let bndrs' :: [Id]
bndrs' = [Id
var | L SrcAnn NoEpAnns
_ (RuleBndr XCRuleBndr GhcTc
_ (L SrcSpanAnnN
_ Id
var)) <- [LRuleBndr GhcTc]
[GenLocated (SrcAnn NoEpAnns) (RuleBndr GhcTc)]
vars]
; CoreExpr
lhs' <- GeneralFlag -> DsM CoreExpr -> DsM CoreExpr
forall gbl lcl a.
GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetGOptM GeneralFlag
Opt_EnableRewriteRules (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
WarningFlag -> DsM CoreExpr -> DsM CoreExpr
forall gbl lcl a.
WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetWOptM WarningFlag
Opt_WarnIdentities (DsM CoreExpr -> DsM CoreExpr) -> DsM CoreExpr -> DsM CoreExpr
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
lhs
; CoreExpr
rhs' <- LHsExpr GhcTc -> DsM CoreExpr
dsLExpr LHsExpr GhcTc
rhs
; Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; ([Id]
bndrs'', CoreExpr
lhs'', CoreExpr
rhs'') <- [Id] -> CoreExpr -> CoreExpr -> DsM ([Id], CoreExpr, CoreExpr)
unfold_coerce [Id]
bndrs' CoreExpr
lhs' CoreExpr
rhs'
; DynFlags
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; case DynFlags
-> [Id]
-> CoreExpr
-> VarSet
-> Either DsMessage ([Id], Id, [CoreExpr])
decomposeRuleLhs DynFlags
dflags [Id]
bndrs'' CoreExpr
lhs'' (CoreExpr -> VarSet
exprFreeVars CoreExpr
rhs'') of {
Left DsMessage
msg -> do { DsMessage -> DsM ()
diagnosticDs DsMessage
msg; Maybe CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CoreRule
forall a. Maybe a
Nothing } ;
Right ([Id]
final_bndrs, Id
fn_id, [CoreExpr]
args) -> do
{ let is_local :: Bool
is_local = Id -> Bool
isLocalId Id
fn_id
fn_name :: Name
fn_name = Id -> Name
idName Id
fn_id
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
final_rhs :: CoreExpr
final_rhs = (() :: Constraint) => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
simpl_opts CoreExpr
rhs''
rule_name :: FastString
rule_name = GenLocated (SrcAnn NoEpAnns) FastString -> FastString
forall l e. GenLocated l e -> e
unLoc XRec GhcTc FastString
GenLocated (SrcAnn NoEpAnns) FastString
name
rule :: CoreRule
rule = Module
-> Bool
-> Bool
-> FastString
-> Activation
-> Name
-> [Id]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkRule Module
this_mod Bool
False Bool
is_local FastString
rule_name Activation
rule_act
Name
fn_name [Id]
final_bndrs [CoreExpr]
args CoreExpr
final_rhs
; CoreRule -> DsM ()
dsWarnOrphanRule CoreRule
rule
; Id -> CoreRule -> DsM ()
dsWarnRuleShadowing Id
fn_id CoreRule
rule
; Maybe CoreRule -> IOEnv (Env DsGblEnv DsLclEnv) (Maybe CoreRule)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreRule -> Maybe CoreRule
forall a. a -> Maybe a
Just CoreRule
rule)
} } }
dsWarnRuleShadowing :: Id -> CoreRule -> DsM ()
dsWarnRuleShadowing :: Id -> CoreRule -> DsM ()
dsWarnRuleShadowing Id
fn_id
(Rule { ru_name :: CoreRule -> FastString
ru_name = FastString
rule_name, ru_act :: CoreRule -> Activation
ru_act = Activation
rule_act, ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args})
= do { Bool -> Id -> DsM ()
check Bool
False Id
fn_id
; (Id -> DsM ()) -> [Id] -> DsM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Id -> DsM ()
check Bool
True) [Id]
arg_ids }
where
bndrs_set :: VarSet
bndrs_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
arg_ids :: [Id]
arg_ids = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Id -> VarSet -> Bool
`elemVarSet` VarSet
bndrs_set) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
(Id -> Bool) -> [CoreExpr] -> [Id]
exprsSomeFreeVarsList Id -> Bool
isId [CoreExpr]
args
check :: Bool -> Id -> DsM ()
check Bool
check_rules_too Id
lhs_id
| Id -> Bool
isLocalId Id
lhs_id Bool -> Bool -> Bool
|| Unfolding -> Bool
canUnfold (IdUnfoldingFun
idUnfolding Id
lhs_id)
, Id -> Activation
idInlineActivation Id
lhs_id Activation -> Activation -> Bool
`competesWith` Activation
rule_act
= DsMessage -> DsM ()
diagnosticDs (FastString -> Id -> Activation -> DsMessage
DsRuleMightInlineFirst FastString
rule_name Id
lhs_id Activation
rule_act)
| Bool
check_rules_too
, CoreRule
bad_rule : [CoreRule]
_ <- Id -> [CoreRule]
get_bad_rules Id
lhs_id
= DsMessage -> DsM ()
diagnosticDs (FastString -> FastString -> Id -> DsMessage
DsAnotherRuleMightFireFirst FastString
rule_name (CoreRule -> FastString
ruleName CoreRule
bad_rule) Id
lhs_id)
| Bool
otherwise
= () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
get_bad_rules :: Id -> [CoreRule]
get_bad_rules Id
lhs_id
= [ CoreRule
rule | CoreRule
rule <- Id -> [CoreRule]
idCoreRules Id
lhs_id
, CoreRule -> Activation
ruleActivation CoreRule
rule Activation -> Activation -> Bool
`competesWith` Activation
rule_act ]
dsWarnRuleShadowing Id
_ CoreRule
_ = () -> DsM ()
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Id], CoreExpr, CoreExpr)
unfold_coerce [Id]
bndrs CoreExpr
lhs CoreExpr
rhs = do
([Id]
bndrs', CoreExpr -> CoreExpr
wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
bndrs
([Id], CoreExpr, CoreExpr) -> DsM ([Id], CoreExpr, CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndrs', CoreExpr -> CoreExpr
wrap CoreExpr
lhs, CoreExpr -> CoreExpr
wrap CoreExpr
rhs)
where
go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [] = ([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], CoreExpr -> CoreExpr
forall a. a -> a
id)
go (Id
v:[Id]
vs)
| Just (TyCon
tc, [Type
k, Type
t1, Type
t2]) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe (Id -> Type
idType Id
v)
, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey = do
Unique
u <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
let ty' :: Type
ty' = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type
k, Type
k, Type
t1, Type
t2]
v' :: Id
v' = Name -> Type -> Id
mkLocalCoVar
((OccName -> OccName) -> Unique -> Name -> Name
mkDerivedInternalName OccName -> OccName
mkRepEqOcc Unique
u (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
v)) Type
ty'
box :: CoreExpr
box = Id -> CoreExpr
forall b. Id -> Expr b
Var (DataCon -> Id
dataConWrapId DataCon
coercibleDataCon) CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
`mkTyApps`
[Type
k, Type
t1, Type
t2] CoreExpr -> CoreExpr -> CoreExpr
forall b. Expr b -> Expr b -> Expr b
`App`
Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (Id -> Coercion
mkCoVarCo Id
v')
([Id]
bndrs, CoreExpr -> CoreExpr
wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
vs
([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
v'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrs, CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
v CoreExpr
box) (CoreExpr -> CoreExpr)
-> (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreExpr -> CoreExpr
wrap)
| Bool
otherwise = do
([Id]
bndrs,CoreExpr -> CoreExpr
wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
vs
([Id], CoreExpr -> CoreExpr) -> DsM ([Id], CoreExpr -> CoreExpr)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
vId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrs, CoreExpr -> CoreExpr
wrap)
patchMagicDefns :: OrdList (Id,CoreExpr)
-> DsM (OrdList (Id,CoreExpr))
patchMagicDefns :: OrdList Binding -> DsM (OrdList Binding)
patchMagicDefns OrdList Binding
pairs
= do { Module
this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; if Module
this_mod Module -> ModuleSet -> Bool
`elemModuleSet` ModuleSet
magicDefnModules
then (Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> OrdList Binding -> DsM (OrdList Binding)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> OrdList a -> f (OrdList b)
traverse Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
patchMagicDefn OrdList Binding
pairs
else OrdList Binding -> DsM (OrdList Binding)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Binding
pairs }
patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr)
patchMagicDefn :: Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
patchMagicDefn orig_pair :: Binding
orig_pair@(Id
orig_id, CoreExpr
orig_rhs)
| Just Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
mk_magic_pair <- NameEnv (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Name
-> Maybe (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
magicDefnsEnv (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
orig_id)
= do { magic_pair :: Binding
magic_pair@(Id
magic_id, CoreExpr
_) <- Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
mk_magic_pair Id
orig_id CoreExpr
orig_rhs
; Bool -> DsM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
magic_id Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Id -> Unique
forall a. Uniquable a => a -> Unique
getUnique Id
orig_id)
; Bool -> DsM ()
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (Id -> Type
varType Id
magic_id Type -> Type -> Bool
`eqType` Id -> Type
varType Id
orig_id)
; Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Binding
magic_pair }
| Bool
otherwise
= Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Binding
orig_pair
magicDefns :: [(Name, Id -> CoreExpr
-> DsM (Id, CoreExpr)
)]
magicDefns :: [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
magicDefns = [ (Name
unsafeCoercePrimName, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
mkUnsafeCoercePrimPair) ]
magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr))
magicDefnsEnv :: NameEnv (Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
magicDefnsEnv = [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
-> NameEnv
(Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
magicDefns
magicDefnModules :: ModuleSet
magicDefnModules :: ModuleSet
magicDefnModules = [Module] -> ModuleSet
mkModuleSet ([Module] -> ModuleSet) -> [Module] -> ModuleSet
forall a b. (a -> b) -> a -> b
$ ((Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Module)
-> [(Name,
Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
-> [Module]
forall a b. (a -> b) -> [a] -> [b]
map ((() :: Constraint) => Name -> Module
Name -> Module
nameModule (Name -> Module)
-> ((Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Name)
-> (Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
forall a. NamedThing a => a -> Name
getName (Name -> Name)
-> ((Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Name)
-> (Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)
-> Name
forall a b. (a, b) -> a
fst) [(Name, Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding)]
magicDefns
mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr)
mkUnsafeCoercePrimPair :: Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
mkUnsafeCoercePrimPair Id
_old_id CoreExpr
old_expr
= do { Id
unsafe_equality_proof_id <- Name -> DsM Id
dsLookupGlobalId Name
unsafeEqualityProofName
; TyCon
unsafe_equality_tc <- Name -> DsM TyCon
dsLookupTyCon Name
unsafeEqualityTyConName
; let [DataCon
unsafe_refl_data_con] = TyCon -> [DataCon]
tyConDataCons TyCon
unsafe_equality_tc
rhs :: CoreExpr
rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
, Id
openAlphaTyVar, Id
openBetaTyVar
, Id
x ] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
scrut1
(Type -> Type -> Id
mkWildValBinder Type
ManyTy Type
scrut1_ty)
(DataCon -> AltCon
DataAlt DataCon
unsafe_refl_data_con)
[Id
rr_cv] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr
mkSingleAltCase CoreExpr
scrut2
(Type -> Type -> Id
mkWildValBinder Type
ManyTy Type
scrut2_ty)
(DataCon -> AltCon
DataAlt DataCon
unsafe_refl_data_con)
[Id
ab_cv] (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Id -> CoreExpr
forall b. Id -> Expr b
Var Id
x (() :: Constraint) => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
x_co
[Id
x, Id
rr_cv, Id
ab_cv] = [Type] -> [Id]
mkTemplateLocals
[ Type
openAlphaTy
, Type
rr_cv_ty
, Type
ab_cv_ty
]
unsafe_equality :: Type -> Type -> Type -> (CoreExpr, Type, Type)
unsafe_equality Type
k Type
a Type
b
= ( CoreExpr -> [Type] -> CoreExpr
forall b. Expr b -> [Type] -> Expr b
mkTyApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
unsafe_equality_proof_id) [Type
k,Type
b,Type
a]
, TyCon -> [Type] -> Type
mkTyConApp TyCon
unsafe_equality_tc [Type
k,Type
b,Type
a]
, Type -> Type -> Type -> Type -> Type
mkHeteroPrimEqPred Type
k Type
k Type
a Type
b
)
(CoreExpr
scrut1, Type
scrut1_ty, Type
rr_cv_ty) = Type -> Type -> Type -> (CoreExpr, Type, Type)
unsafe_equality Type
runtimeRepTy
Type
runtimeRep1Ty
Type
runtimeRep2Ty
(CoreExpr
scrut2, Type
scrut2_ty, Type
ab_cv_ty) = Type -> Type -> Type -> (CoreExpr, Type, Type)
unsafe_equality (Type -> Type
mkTYPEapp Type
runtimeRep2Ty)
(Type
openAlphaTy Type -> Coercion -> Type
`mkCastTy` Coercion
alpha_co)
Type
openBetaTy
alpha_co :: Coercion
alpha_co = (() :: Constraint) => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Nominal TyCon
tYPETyCon [Id -> Coercion
mkCoVarCo Id
rr_cv]
x_co :: Coercion
x_co = Role -> Type -> MCoercionN -> Coercion
mkGReflCo Role
Representational Type
openAlphaTy (Coercion -> MCoercionN
MCo Coercion
alpha_co) Coercion -> Coercion -> Coercion
`mkTransCo`
(() :: Constraint) => Coercion -> Coercion
Coercion -> Coercion
mkSubCo (Id -> Coercion
mkCoVarCo Id
ab_cv)
info :: IdInfo
info = IdInfo
noCafIdInfo IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
alwaysInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` CoreExpr -> Unfolding
mkCompulsoryUnfolding CoreExpr
rhs
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
ty :: Type
ty = [Id] -> Type -> Type
mkSpecForAllTys [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
, Id
openAlphaTyVar, Id
openBetaTyVar ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
(() :: Constraint) => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
openAlphaTy Type
openBetaTy
arity :: Int
arity = Int
1
id :: Id
id = Name -> Type -> Id
mkExportedVanillaId Name
unsafeCoercePrimName Type
ty Id -> IdInfo -> Id
`setIdInfo` IdInfo
info
; Binding -> IOEnv (Env DsGblEnv DsLclEnv) Binding
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
id, CoreExpr
old_expr) }