{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998


The Desugarer: turning HsSyn into Core.
-}

module GHC.HsToCore (
    -- * Desugaring operations
    deSugar, deSugarExpr
    ) where

import GHC.Prelude

import GHC.Driver.DynFlags
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.Types.Origin ( Position(..) )
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.Id.Make ( mkRepPolyIdConcreteTyVars )
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)

{-
************************************************************************
*                                                                      *
*              The main function: deSugar
*                                                                      *
************************************************************************
-}

-- | Main entry point to the desugarer.
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
-- Can modify PCS by faulting in more declarations

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
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> 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 { -- Desugar the program
        ; let export_set :: NameSet
export_set = [AvailInfo] -> NameSet
availsToNameSet [AvailInfo]
exports
              bcknd :: Backend
bcknd      = DynFlags -> Backend
backend DynFlags
dflags

        ; (binds_cvr, 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)
        ; modBreaks <- for
           [ (i, s)
           | i <- hsc_interp hsc_env
           , (_, s) <- m_tickInfo
           , breakpointsAllowed dflags
           ]
           $ \(Interp
interp, SizedSeq Tick
specs) -> Interp -> Module -> SizedSeq Tick -> IO ModBreaks
mkModBreaks Interp
interp Module
mod SizedSeq Tick
specs

        ; ds_hpc_info <- case 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
              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 -- dummy hash when none are written
              pure $ HpcInfo (fromIntegral $ sizeSS ticks) 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

        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
                       do { dsEvBinds ev_binds $ \ [CoreBind]
ds_ev_binds -> do
                          { core_prs <- LHsBinds GhcTc -> DsM (OrdList Binding)
dsTopLHsBinds LHsBinds GhcTc
Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc))
binds_cvr
                          ; core_prs <- patchMagicDefns core_prs
                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
                          ; (ds_fords, foreign_prs) <- dsForeigns fords
                          ; ds_rules <- mapMaybeM dsRule rules
                          ; let 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
                          ; return ( ds_ev_binds
                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
                                   , spec_rules ++ ds_rules
                                   , ds_fords `appendStubC` hpc_init) } }

        ; case 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 {       -- Add export flags to bindings
          keep_alive <- TcRef NameSet -> IO NameSet
forall a. IORef a -> IO a
readIORef TcRef NameSet
keep_var
        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
              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] -> [Binding] -> [CoreBind]
combineEvBinds [CoreBind]
ds_ev_binds [Binding]
final_prs
        -- Notice that we put the whole lot in a big Rec, even the foreign binds
        -- When compiling PrelFloat, which defines data Float = F# Float#
        -- we want F# to be in scope in the foreign marshalling code!
        -- You might think it doesn't matter, but the simplifier brings all top-level
        -- things into the in-scope set before simplifying; so we get no unfolding for F#!

        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps
        ; let simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
        ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
                = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
                         -- The simpleOptPgm gets rid of type
                         -- bindings plus any stupid dead code
        ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
            FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )

        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps

        ; let used_names = TcGblEnv -> NameSet
mkUsedNames TcGblEnv
tcg_env
              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 = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        ; let 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)

        ; used_th <- readIORef tc_splice_used
        ; dep_files <- readIORef dependent_files
        ; safe_mode <- finalSafeMode dflags tcg_env
        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env)

        ; let uc = HscEnv -> UsageConfig
initUsageConfig HscEnv
hsc_env
        ; let plugins = HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env
        ; let fc = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
        ; let unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
        ; usages <- initIfaceLoad hsc_env $
                      mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names
                        dep_files merged needed_mods needed_pkgs
        -- id_mod /= mod when we are processing an hsig, but hsigs
        -- never desugared and compiled (there's no code!)
        -- Consequently, this should hold for any ModGuts that make
        -- past desugaring. See Note [Identity versus semantic module].
        ; massert (id_mod == mod)

        ; foreign_files <- readIORef th_foreign_files_var

        ; docs <- extractDocs dflags tcg_env

        ; let 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
              }
        ; return (msgs, Just 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   -- Presumably

dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList Binding, [CoreRule])
dsImpSpecs [LTcSpecPrag]
imp_specs
 = do { 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 (spec_binds, spec_rules) = unzip spec_prs
      ; return (concatOL spec_binds, spec_rules) }

combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
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)

{-
Note [Top-level evidence]
~~~~~~~~~~~~~~~~~~~~~~~~~
Top-level evidence bindings may be mutually recursive with the top-level value
bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
because the occurrence analyser doesn't take account of type/coercion variables
when computing dependencies.

So we pull out the type/coercion variables (which are in dependency order),
and Rec the rest.
-}

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"

    -- Do desugaring
    (tc_msgs, 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

    massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here

      -- mb_result is Nothing only when a failure happens in the type-checker,
      -- but mb_core_expr is Nothing when a failure happens in the desugarer
    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result

    case 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)

      -- callers (i.e. ioMsgMaybe) expect that no expression is returned if
      -- there are errors
    let 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

    return (ds_msgs, final_res)

{-
************************************************************************
*                                                                      *
*              Add rules and export flags to binders
*                                                                      *
************************************************************************
-}

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)
        -- addRulesToId: see Note [Attach rules to local ids]
        -- NB: the binder might have some existing rules,
        -- arising from specialisation pragmas

  where

    ---------- Rules --------
    rule_base :: RuleBase
rule_base = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
emptyRuleBase [CoreRule]
rules

    ---------- Export flag --------
    -- See Note [Adding export flags]
    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

        -- In interactive mode, we don't want to discard any top-level
        -- entities at all (eg. do not inline them away during
        -- simplification), and retain them all in the TypeEnv so they are
        -- available from the command line.
        --
        -- isExternalName separates the user-defined top-level names from those
        -- introduced by the type checker.
    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)

{-
Note [Adding export flags]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Set the no-discard flag if either
        a) the Id is exported
        b) it's mentioned in the RHS of an orphan rule
        c) it's in the keep-alive set

It means that the binding won't be discarded EVEN if the binding
ends up being trivial (v = w) -- the simplifier would usually just
substitute w for v throughout, but we don't apply the substitution to
the rules (maybe we should?), so this substitution would make the rule
bogus.

You might wonder why exported Ids aren't already marked as such;
it's just because the type checker is rather busy already and
I didn't want to pass in yet another mapping.

Note [Attach rules to local ids]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Find the rules for locally-defined Ids; then we can attach them
to the binders in the top-level bindings

Reason
  - It makes the rules easier to look up
  - It means that rewrite rules and specialisations for
    locally defined Ids are handled uniformly
  - It keeps alive things that are referred to only from a rule
    (the occurrence analyser knows about rules attached to Ids)
  - It makes sure that, when we apply a rule, the free vars
    of the RHS are more likely to be in scope
  - The imported rules are carried in the in-scope set
    which is extended on each iteration by the new wave of
    local binders; any rules which aren't on the binding will
    thereby get dropped


************************************************************************
*                                                                      *
*              Desugaring rewrite rules
*                                                                      *
************************************************************************
-}

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. HasLoc a => 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 EpAnnCO
_ (RuleBndr XCRuleBndr GhcTc
_ (L SrcSpanAnnN
_ Id
var)) <- [LRuleBndr GhcTc]
[GenLocated EpAnnCO (RuleBndr GhcTc)]
vars]

        ; 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   -- Note [Desugaring RULE left hand sides]

        ; rhs' <- dsLExpr rhs
        ; this_mod <- getModule

        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'

        -- Substitute the dict bindings eagerly,
        -- and take the body apart into a (f args) form
        ; dflags <- getDynFlags
        ; case decomposeRuleLhs dflags bndrs'' lhs'' (exprFreeVars 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
                -- NB: isLocalId is False of implicit Ids.  This is good because
                -- we don't want to attach rules to the bindings of implicit Ids,
                -- because they don't show up in the bindings until just before code gen
              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 = HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
SimpleOpts -> CoreExpr -> CoreExpr
simpleOptExpr SimpleOpts
simpl_opts CoreExpr
rhs''    -- De-crap it
              rule_name :: FastString
rule_name = GenLocated EpAnnCO FastString -> FastString
forall l e. GenLocated l e -> e
unLoc XRec GhcTc FastString
GenLocated EpAnnCO 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 ()
-- See Note [Rules and inlining/other rules]
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    -- We often have multiple rules for the same Id in a
                              -- module. Maybe we should check that they don't overlap
                              -- but currently we don't
       ; (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)
                       -- If imported with no unfolding, no worries
      , 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 () -- Not expecting built-in rules here

-- See Note [Desugaring coerce as cast]
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
    (bndrs', wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
bndrs
    return (bndrs', wrap lhs, wrap 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]) <- HasDebugCallStack => 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
            u <- TcRnIf DsGblEnv DsLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique

            let ty' = TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type
k, Type
k, Type
t1, Type
t2]
                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 = 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')

            (bndrs, wrap) <- go vs
            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
        | Bool
otherwise = do
            (bndrs,wrap) <- [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
go [Id]
vs
            return (v:bndrs, wrap)

{- Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the LHS of a RULE we do *not* want to desugar
    [x]   to    build (\cn. x `c` n)
We want to leave explicit lists simply as chains
of cons's. We can achieve that slightly indirectly by
switching off EnableRewriteRules.  See GHC.HsToCore.Expr.dsExplicitList.

That keeps the desugaring of list comprehensions simple too.

Nor do we want to warn of conversion identities on the LHS;
the rule is precisely to optimise them:
  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}

Note [Desugaring coerce as cast]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want the user to express a rule saying roughly “mapping a coercion over a
list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
be written in Haskell. So we use `coerce` for that (#2110). The user writes
    map coerce = coerce
as a RULE, and this optimizes any kind of mapped' casts away, including `map
MkNewtype`.

For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
`let c = MkCoercible co in ...`. This is later simplified to the desired form
by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.

Note [Rules and inlining/other rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you have
  f x = ...
  g x = ...
  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
then there's a good chance that in a potential rule redex
    ...f (g e)...
then 'f' or 'g' will inline before the rule can fire.  Solution: add an
INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.

Note that this applies to all the free variables on the LHS, both the
main function and things in its arguments.

We also check if there are Ids on the LHS that have competing RULES.
In the above example, suppose we had
  {-# RULES "rule-for-g" forally. g [y] = ... #-}
Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
active; or perhaps after "rule-for-g" has become inactive. This is checked
by 'competesWith'

Class methods have a built-in RULE to select the method from the dictionary,
so you can't change the phase on this.  That makes id very dubious to
match on class methods in RULE lhs's.   See #10595.   I'm not happy
about this. For example in Control.Arrow we have

{-# RULES "compose/arr"   forall f g .
                          (arr f) . (arr g) = arr (f . g) #-}

and similar, which will elicit exactly these warnings, and risk never
firing.  But it's not clear what to do instead.  We could make the
class method rules inactive in phase 2, but that would delay when
subsequent transformations could fire.
-}

{-
************************************************************************
*                                                                      *
*              Magic definitions
*                                                                      *
************************************************************************

Note [Patching magic definitions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We sometimes need to have access to defined Ids in pure contexts. Usually, we
simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids
in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make.

However, it is sometimes *much* easier to define entities in Haskell,
even if we need pure access; note that wiring-in an Id requires all
entities used in its definition *also* to be wired in, transitively
and recursively.  This can be a huge pain.  The little trick
documented here allows us to have the best of both worlds.

Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the
details.

The trick is to

* Define the known-key Id in a library module, with a stub definition,
     unsafeCoerce# :: ..a suitable type signature..
     unsafeCoerce# = error "urk"

* Magically over-write its RHS here in the desugarer, in
  patchMagicDefns.  This update can be done with full access to the
  DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in
  all the entities used internally, a potentially big win.

  This step should not change the Name or type of the Id.

Because an Id stores its unfolding directly (as opposed to in the second
component of a (Id, CoreExpr) pair), the patchMagicDefns function returns
a new Id to use.

Here are the moving parts:

- patchMagicDefns checks whether we're in a module with magic definitions;
  if so, patch the magic definitions. If not, skip.

- patchMagicDefn just looks up in an environment to find a magic defn and
  patches it in.

- magicDefns holds the magic definitions.

- magicDefnsEnv allows for quick access to magicDefns.

- magicDefnModules, built also from magicDefns, contains the modules that
  need careful attention.

Note [Wiring in unsafeCoerce#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want (Haskell)

  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                          (a :: TYPE r1) (b :: TYPE r2).
                   a -> b
  unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of
    UnsafeRefl -> case unsafeEqualityProof @a @b of
      UnsafeRefl -> x

or (Core)

  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                          (a :: TYPE r1) (b :: TYPE r2).
                   a -> b
  unsafeCoerce# = \ @r1 @r2 @a @b (x :: a).
    case unsafeEqualityProof @RuntimeRep @r1 @r2 of
      UnsafeRefl (co1 :: r1 ~# r2) ->
        case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of
          UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) ->
            (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)

It looks like we can write this in Haskell directly, but we can't:
the representation polymorphism checks defeat us. Note that `x` is a
representation-polymorphic variable. So we must wire it in with a
compulsory unfolding, like other representation-polymorphic primops.

The challenge is that UnsafeEquality is a GADT, and wiring in a GADT
is *hard*: it has a worker separate from its wrapper, with all manner
of complications. (Simon and Richard tried to do this. We nearly wept.)

The solution is documented in Note [Patching magic definitions]. We now
simply look up the UnsafeEquality GADT in the environment, leaving us
only to wire in unsafeCoerce# directly.

Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
-}


-- Postcondition: the returned Ids are in one-to-one correspondence as the
-- input Ids; each returned Id has the same type as the passed-in Id.
-- See Note [Patching magic definitions]
patchMagicDefns :: OrdList (Id,CoreExpr)
                -> DsM (OrdList (Id,CoreExpr))
patchMagicDefns :: OrdList Binding -> DsM (OrdList Binding)
patchMagicDefns OrdList Binding
pairs
  -- optimization: check whether we're in a magic module before looking
  -- at all the ids
  = do { this_mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
       ; if this_mod `elemModuleSet` magicDefnModules
         then traverse patchMagicDefn pairs
         else return 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@(magic_id, _) <- Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
mk_magic_pair Id
orig_id CoreExpr
orig_rhs

       -- Patching should not change the Name or the type of the Id
       ; massert (getUnique magic_id == getUnique orig_id)
       ; massert (varType magic_id `eqType` varType orig_id)

       ; return 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     -- old Id and RHS
                      -> DsM (Id, CoreExpr) -- new Id and RHS
               )]
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 (HasDebugCallStack => 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)
-- See Note [Wiring in unsafeCoerce#] for the defn we are creating here
mkUnsafeCoercePrimPair :: Id -> CoreExpr -> IOEnv (Env DsGblEnv DsLclEnv) Binding
mkUnsafeCoercePrimPair Id
_old_id CoreExpr
old_expr
  = do { unsafe_equality_proof_id <- Name -> DsM Id
dsLookupGlobalId Name
unsafeEqualityProofName
       ; unsafe_equality_tc       <- dsLookupTyCon unsafeEqualityTyConName

       ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc

             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 HasDebugCallStack => CoreExpr -> Coercion -> CoreExpr
CoreExpr -> Coercion -> CoreExpr
`mkCast` Coercion
x_co

             [x, rr_cv, ab_cv] = mkTemplateLocals
               [ openAlphaTy -- x :: a
               , rr_cv_ty    -- rr_cv :: r1 ~# r2
               , ab_cv_ty    -- ab_cv :: (alpha |> alpha_co ~# beta)
               ]

             -- Returns (scrutinee, scrutinee type, type of covar in AltCon)
             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
mkNomPrimEqPred Type
k Type
a Type
b
                 )
             -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to
             -- carefully swap the arguments above

             (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy
                                                             runtimeRep1Ty
                                                             runtimeRep2Ty
             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)
                                                             (openAlphaTy `mkCastTy` alpha_co)
                                                             openBetaTy

             -- alpha_co :: TYPE r1 ~# TYPE r2
             -- alpha_co = TYPE rr_cv
             alpha_co = HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion
Role -> TyCon -> [Coercion] -> Coercion
mkTyConAppCo Role
Nominal TyCon
tYPETyCon [Id -> Coercion
mkCoVarCo Id
rr_cv]

             -- x_co :: alpha ~R# beta
             x_co = Role -> Type -> MCoercionN -> Coercion
mkGReflCo Role
Representational Type
openAlphaTy (Coercion -> MCoercionN
MCo Coercion
alpha_co) Coercion -> Coercion -> Coercion
`mkTransCo`
                    HasDebugCallStack => Coercion -> Coercion
Coercion -> Coercion
mkSubCo (Id -> Coercion
mkCoVarCo Id
ab_cv)


             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 = [Id] -> Type -> Type
mkSpecForAllTys [ Id
runtimeRep1TyVar, Id
runtimeRep2TyVar
                                  , Id
openAlphaTyVar, Id
openBetaTyVar ] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                  HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
openAlphaTy Type
openBetaTy

             arity = Int
1

             concs = [((Type, Position 'Neg), Id)] -> Name -> ConcreteTyVars
mkRepPolyIdConcreteTyVars
                     [((Id -> Type
mkTyVarTy Id
openAlphaTyVar, Int -> Position (FlipPolarity 'Neg) -> Position 'Neg
forall (p :: Polarity).
Int -> Position (FlipPolarity p) -> Position p
Argument Int
1 Position (FlipPolarity 'Neg)
Position 'Pos
Top), Id
runtimeRep1TyVar)]
                     Name
unsafeCoercePrimName

             id   = IdDetails -> Name -> Type -> Id
mkExportedLocalId (ConcreteTyVars -> IdDetails
RepPolyId ConcreteTyVars
concs) Name
unsafeCoercePrimName Type
ty Id -> IdInfo -> Id
`setIdInfo` IdInfo
info
       ; return (id, old_expr) }