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

module GHC.Driver.Config.StgToCmm
  ( initStgToCmmConfig
  ) where

import GHC.Prelude.Basic

import GHC.StgToCmm.Config

import GHC.Cmm.MachOp ( FMASign(..))
import GHC.Driver.Backend
import GHC.Driver.Session
import GHC.Platform
import GHC.Platform.Profile
import GHC.Utils.Error
import GHC.Unit.Module
import GHC.Utils.Outputable

initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod = StgToCmmConfig
  -- settings
  { stgToCmmProfile :: Profile
stgToCmmProfile       = Profile
profile
  , stgToCmmThisModule :: Module
stgToCmmThisModule    = Module
mod
  , stgToCmmTmpDir :: TempDir
stgToCmmTmpDir        = DynFlags -> TempDir
tmpDir          DynFlags
dflags
  , stgToCmmContext :: SDocContext
stgToCmmContext       = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultDumpStyle
  , stgToCmmEmitDebugInfo :: Bool
stgToCmmEmitDebugInfo = DynFlags -> Int
debugLevel      DynFlags
dflags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  , stgToCmmBinBlobThresh :: Maybe Word
stgToCmmBinBlobThresh = Maybe Word
b_blob
  , stgToCmmMaxInlAllocSize :: Int
stgToCmmMaxInlAllocSize = DynFlags -> Int
maxInlineAllocSize           DynFlags
dflags
  -- ticky options
  , stgToCmmDoTicky :: Bool
stgToCmmDoTicky       = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky                 DynFlags
dflags
  , stgToCmmTickyAllocd :: Bool
stgToCmmTickyAllocd   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky_Allocd          DynFlags
dflags
  , stgToCmmTickyLNE :: Bool
stgToCmmTickyLNE      = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky_LNE             DynFlags
dflags
  , stgToCmmTickyDynThunk :: Bool
stgToCmmTickyDynThunk = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky_Dyn_Thunk       DynFlags
dflags
  , stgToCmmTickyTag :: Bool
stgToCmmTickyTag      = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky_Tag             DynFlags
dflags
  -- flags
  , stgToCmmLoopification :: Bool
stgToCmmLoopification = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Loopification         DynFlags
dflags
  , stgToCmmAlignCheck :: Bool
stgToCmmAlignCheck    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AlignmentSanitisation DynFlags
dflags
  , stgToCmmOptHpc :: Bool
stgToCmmOptHpc        = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Hpc                   DynFlags
dflags
  , stgToCmmFastPAPCalls :: Bool
stgToCmmFastPAPCalls  = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FastPAPCalls          DynFlags
dflags
  , stgToCmmSCCProfiling :: Bool
stgToCmmSCCProfiling  = DynFlags -> Bool
sccProfilingEnabled            DynFlags
dflags
  , stgToCmmEagerBlackHole :: Bool
stgToCmmEagerBlackHole = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EagerBlackHoling     DynFlags
dflags
  , stgToCmmInfoTableMap :: Bool
stgToCmmInfoTableMap  = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap          DynFlags
dflags
  , stgToCmmInfoTableMapWithFallback :: Bool
stgToCmmInfoTableMapWithFallback = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMapWithFallback DynFlags
dflags
  , stgToCmmInfoTableMapWithStack :: Bool
stgToCmmInfoTableMapWithStack = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMapWithStack DynFlags
dflags
  , stgToCmmOmitYields :: Bool
stgToCmmOmitYields    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitYields            DynFlags
dflags
  , stgToCmmOmitIfPragmas :: Bool
stgToCmmOmitIfPragmas = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas  DynFlags
dflags
  , stgToCmmPIC :: Bool
stgToCmmPIC           = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PIC                   DynFlags
dflags
  , stgToCmmPIE :: Bool
stgToCmmPIE           = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PIE                   DynFlags
dflags
  , stgToCmmExtDynRefs :: Bool
stgToCmmExtDynRefs    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExternalDynamicRefs   DynFlags
dflags
  , stgToCmmDoBoundsCheck :: Bool
stgToCmmDoBoundsCheck = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoBoundsChecking      DynFlags
dflags
  , stgToCmmDoTagCheck :: Bool
stgToCmmDoTagCheck    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoTagInferenceChecks  DynFlags
dflags
  -- backend flags
  , stgToCmmAllowBigArith :: Bool
stgToCmmAllowBigArith             = Bool -> Bool
not Bool
ncg Bool -> Bool -> Bool
|| Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchWasm32
  , stgToCmmAllowQuotRemInstr :: Bool
stgToCmmAllowQuotRemInstr         = Bool
ncg  Bool -> Bool -> Bool
&& (Bool
x86ish Bool -> Bool -> Bool
|| Bool
ppc)
  , stgToCmmAllowQuotRem2 :: Bool
stgToCmmAllowQuotRem2             = (Bool
ncg Bool -> Bool -> Bool
&& (Bool
x86ish Bool -> Bool -> Bool
|| Bool
ppc)) Bool -> Bool -> Bool
|| Bool
llvm
  , stgToCmmAllowExtendedAddSubInstrs :: Bool
stgToCmmAllowExtendedAddSubInstrs = (Bool
ncg Bool -> Bool -> Bool
&& (Bool
x86ish Bool -> Bool -> Bool
|| Bool
ppc)) Bool -> Bool -> Bool
|| Bool
llvm
  , stgToCmmAllowFMAInstr :: FMASign -> Bool
stgToCmmAllowFMAInstr =
      if
        | Bool -> Bool
not (DynFlags -> Bool
isFmaEnabled DynFlags
dflags)
        Bool -> Bool -> Bool
|| Bool -> Bool
not (Bool
ncg Bool -> Bool -> Bool
|| Bool
llvm)
        -- If we're not using the native code generator or LLVM,
        -- fall back to the generic implementation.
        Bool -> Bool -> Bool
|| Platform -> Arch
platformArch Platform
platform Arch -> Arch -> Bool
forall a. Eq a => a -> a -> Bool
== Arch
ArchWasm32
        -- WASM doesn't support native FMA instructions (at the time of writing).
        -> Bool -> FMASign -> Bool
forall a b. a -> b -> a
const Bool
False

        -- FNMSub and FNMAdd have different semantics on PowerPC,
        -- so we avoid using them.
        | Bool
ppc
        -> \ case { FMASign
FMAdd -> Bool
True; FMASign
FMSub -> Bool
True; FMASign
_ -> Bool
False }

        | Bool
otherwise
        -> Bool -> FMASign -> Bool
forall a b. a -> b -> a
const Bool
True

  , stgToCmmAllowIntMul2Instr :: Bool
stgToCmmAllowIntMul2Instr         = (Bool
ncg Bool -> Bool -> Bool
&& Bool
x86ish) Bool -> Bool -> Bool
|| Bool
llvm
  -- SIMD flags
  , stgToCmmVecInstrsErr :: Maybe String
stgToCmmVecInstrsErr  = Maybe String
vec_err
  , stgToCmmAvx :: Bool
stgToCmmAvx           = DynFlags -> Bool
isAvxEnabled                   DynFlags
dflags
  , stgToCmmAvx2 :: Bool
stgToCmmAvx2          = DynFlags -> Bool
isAvx2Enabled                  DynFlags
dflags
  , stgToCmmAvx512f :: Bool
stgToCmmAvx512f       = DynFlags -> Bool
isAvx512fEnabled               DynFlags
dflags
  , stgToCmmTickyAP :: Bool
stgToCmmTickyAP       = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky_AP DynFlags
dflags
  } where profile :: Profile
profile  = DynFlags -> Profile
targetProfile DynFlags
dflags
          platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
          bk_end :: Backend
bk_end  = DynFlags -> Backend
backend DynFlags
dflags
          b_blob :: Maybe Word
b_blob  = if Bool -> Bool
not Bool
ncg then Maybe Word
forall a. Maybe a
Nothing else DynFlags -> Maybe Word
binBlobThreshold DynFlags
dflags
          (Bool
ncg, Bool
llvm) = case Backend -> PrimitiveImplementation
backendPrimitiveImplementation Backend
bk_end of
                          PrimitiveImplementation
GenericPrimitives -> (Bool
False, Bool
False)
                          PrimitiveImplementation
JSPrimitives      -> (Bool
False, Bool
False)
                          PrimitiveImplementation
NcgPrimitives     -> (Bool
True, Bool
False)
                          PrimitiveImplementation
LlvmPrimitives    -> (Bool
False, Bool
True)
          x86ish :: Bool
x86ish  = case Platform -> Arch
platformArch Platform
platform of
                      Arch
ArchX86    -> Bool
True
                      Arch
ArchX86_64 -> Bool
True
                      Arch
_          -> Bool
False
          ppc :: Bool
ppc     = case Platform -> Arch
platformArch Platform
platform of
                      Arch
ArchPPC      -> Bool
True
                      ArchPPC_64 PPC_64ABI
_ -> Bool
True
                      Arch
_            -> Bool
False
          vec_err :: Maybe String
vec_err = case Backend -> Validity' String
backendSimdValidity (DynFlags -> Backend
backend DynFlags
dflags) of
                      Validity' String
IsValid -> Maybe String
forall a. Maybe a
Nothing
                      NotValid String
msg -> String -> Maybe String
forall a. a -> Maybe a
Just String
msg