{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}

module GHC.Driver.Config.Tidy
  ( initTidyOpts
  , initStaticPtrOpts
  )
where

import GHC.Prelude

import GHC.Iface.Tidy
import GHC.Iface.Tidy.StaticPtrTable

import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Backend

import GHC.Core.Make (getMkStringIds)
import GHC.Data.Maybe
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Builtin.Names
import GHC.Tc.Utils.Env (lookupGlobal_maybe)
import GHC.Types.TyThing
import GHC.Platform.Ways

import qualified GHC.LanguageExtensions as LangExt

initTidyOpts :: HscEnv -> IO TidyOpts
initTidyOpts :: HscEnv -> IO TidyOpts
initTidyOpts HscEnv
hsc_env = do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  Maybe StaticPtrOpts
static_ptr_opts <- if Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers DynFlags
dflags)
    then Maybe StaticPtrOpts -> IO (Maybe StaticPtrOpts)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe StaticPtrOpts
forall a. Maybe a
Nothing
    else StaticPtrOpts -> Maybe StaticPtrOpts
forall a. a -> Maybe a
Just (StaticPtrOpts -> Maybe StaticPtrOpts)
-> IO StaticPtrOpts -> IO (Maybe StaticPtrOpts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO StaticPtrOpts
initStaticPtrOpts HscEnv
hsc_env
  TidyOpts -> IO TidyOpts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TidyOpts -> IO TidyOpts) -> TidyOpts -> IO TidyOpts
forall a b. (a -> b) -> a -> b
$ TidyOpts
    { opt_name_cache :: NameCache
opt_name_cache        = HscEnv -> NameCache
hsc_NC HscEnv
hsc_env
    , opt_collect_ccs :: Bool
opt_collect_ccs       = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayProf
    , opt_unfolding_opts :: UnfoldingOpts
opt_unfolding_opts    = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
    , opt_expose_unfoldings :: UnfoldingExposure
opt_expose_unfoldings = if | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags -> UnfoldingExposure
ExposeNone
                                 | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExposeAllUnfoldings DynFlags
dflags  -> UnfoldingExposure
ExposeAll
                                 | Bool
otherwise                            -> UnfoldingExposure
ExposeSome
    , opt_expose_rules :: Bool
opt_expose_rules      = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags)
    , opt_trim_ids :: Bool
opt_trim_ids          = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags
    , opt_static_ptr_opts :: Maybe StaticPtrOpts
opt_static_ptr_opts   = Maybe StaticPtrOpts
static_ptr_opts
    }

initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
initStaticPtrOpts HscEnv
hsc_env = do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

  let lookupM :: Name -> IO TyThing
lookupM Name
n = HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
n IO (MaybeErr SDoc TyThing)
-> (MaybeErr SDoc TyThing -> IO TyThing) -> IO TyThing
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Succeeded TyThing
r -> TyThing -> IO TyThing
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyThing
r
        Failed SDoc
err  -> String -> SDoc -> IO TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initStaticPtrOpts: couldn't find" ((SDoc, Name) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SDoc
err,Name
n))

  MkStringIds
mk_string <- (Name -> IO Id) -> IO MkStringIds
forall (m :: * -> *).
Applicative m =>
(Name -> m Id) -> m MkStringIds
getMkStringIds ((TyThing -> Id) -> IO TyThing -> IO Id
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() :: Constraint) => TyThing -> Id
TyThing -> Id
tyThingId (IO TyThing -> IO Id) -> (Name -> IO TyThing) -> Name -> IO Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IO TyThing
lookupM)
  DataCon
static_ptr_info_datacon <- (() :: Constraint) => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (TyThing -> DataCon) -> IO TyThing -> IO DataCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO TyThing
lookupM Name
staticPtrInfoDataConName
  DataCon
static_ptr_datacon      <- (() :: Constraint) => TyThing -> DataCon
TyThing -> DataCon
tyThingDataCon (TyThing -> DataCon) -> IO TyThing -> IO DataCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> IO TyThing
lookupM Name
staticPtrDataConName

  StaticPtrOpts -> IO StaticPtrOpts
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StaticPtrOpts -> IO StaticPtrOpts)
-> StaticPtrOpts -> IO StaticPtrOpts
forall a b. (a -> b) -> a -> b
$ StaticPtrOpts
    { opt_platform :: Platform
opt_platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

      -- If we are compiling for the interpreter we will insert any necessary
      -- SPT entries dynamically, otherwise we add a C stub to do so
    , opt_gen_cstub :: Bool
opt_gen_cstub = case DynFlags -> Backend
backend DynFlags
dflags of
                        Backend
Interpreter -> Bool
False
                        Backend
_           -> Bool
True

    , opt_mk_string :: MkStringIds
opt_mk_string = MkStringIds
mk_string
    , opt_static_ptr_info_datacon :: DataCon
opt_static_ptr_info_datacon = DataCon
static_ptr_info_datacon
    , opt_static_ptr_datacon :: DataCon
opt_static_ptr_datacon      = DataCon
static_ptr_datacon
    }