{-# LANGUAGE CPP #-}

-- | Ways
--
-- The central concept of a "way" is that all objects in a given
-- program must be compiled in the same "way". Certain options change
-- parameters of the virtual machine, eg. profiling adds an extra word
-- to the object header, so profiling objects cannot be linked with
-- non-profiling objects.
--
-- After parsing the command-line options, we determine which "way" we
-- are building - this might be a combination way, eg. profiling+threaded.
--
-- There are two kinds of ways:
--    - RTS only: only affect the runtime system (RTS) and don't affect code
--    generation (e.g. threaded, debug)
--    - Full ways: affect code generation and the RTS (e.g. profiling, dynamic
--    linking)
--
-- We then find the "build-tag" associated with this way, and this
-- becomes the suffix used to find .hi files and libraries used in
-- this compilation.
module GHC.Platform.Ways
   ( Way(..)
   , Ways
   , hasWay
   , hasNotWay
   , addWay
   , removeWay
   , allowed_combination
   , wayGeneralFlags
   , wayUnsetGeneralFlags
   , wayOptc
   , wayOptl
   , wayOptP
   , wayDesc
   , wayRTSOnly
   , wayTag
   , waysTag
   , waysBuildTag
   , fullWays
   , rtsWays
   -- * Host GHC ways
   , hostWays
   , hostFullWays
   , hostIsProfiled
   , hostIsDynamic
   , hostIsThreaded
   , hostIsDebugged
   , hostIsTracing
   )
where

import GHC.Prelude
import GHC.Platform
import GHC.Driver.Flags

import qualified Data.Set as Set
import Data.Set (Set)
import Data.List (intersperse)

-- | A way
--
-- Don't change the constructor order as it us used by `waysTag` to create a
-- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal).
data Way
  = WayCustom String -- ^ for GHC API clients building custom variants
  | WayThreaded      -- ^ (RTS only) Multithreaded runtime system
  | WayDebug         -- ^ Debugging, enable trace messages and extra checks
  | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports
  | WayDyn           -- ^ Dynamic linking
  deriving (Eq, Ord, Show, Read)

type Ways = Set Way

-- | Test if a way is enabled
hasWay :: Ways -> Way -> Bool
hasWay ws w = Set.member w ws

-- | Test if a way is not enabled
hasNotWay :: Ways -> Way -> Bool
hasNotWay ws w = Set.notMember w ws

-- | Add a way
addWay :: Way -> Ways -> Ways
addWay = Set.insert

-- | Remove a way
removeWay :: Way -> Ways -> Ways
removeWay = Set.delete

-- | Check if a combination of ways is allowed
allowed_combination :: Ways -> Bool
allowed_combination ways = not disallowed
  where
   disallowed = or [ hasWay ways x && hasWay ways y
                   | (x,y) <- couples
                   ]
   -- List of disallowed couples of ways
   couples = [] -- we don't have any disallowed combination of ways nowadays

-- | Unique tag associated to a list of ways
waysTag :: Ways -> String
waysTag = concat . intersperse "_" . map wayTag . Set.toAscList

-- | Unique build-tag associated to a list of ways
--
-- RTS only ways are filtered out because they have no impact on the build.
waysBuildTag :: Ways -> String
waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws)


-- | Unique build-tag associated to a way
wayTag :: Way -> String
wayTag (WayCustom xs) = xs
wayTag WayThreaded    = "thr"
wayTag WayDebug       = "debug"
wayTag WayDyn         = "dyn"
wayTag WayProf        = "p"

-- | Return true for ways that only impact the RTS, not the generated code
wayRTSOnly :: Way -> Bool
wayRTSOnly (WayCustom {}) = False
wayRTSOnly WayDyn         = False
wayRTSOnly WayProf        = False
wayRTSOnly WayThreaded    = True
wayRTSOnly WayDebug       = True

-- | Filter ways that have an impact on compilation
fullWays :: Ways -> Ways
fullWays ws = Set.filter (not . wayRTSOnly) ws

-- | Filter RTS-only ways (ways that don't have an impact on compilation)
rtsWays :: Ways -> Ways
rtsWays ws = Set.filter wayRTSOnly ws

wayDesc :: Way -> String
wayDesc (WayCustom xs) = xs
wayDesc WayThreaded    = "Threaded"
wayDesc WayDebug       = "Debug"
wayDesc WayDyn         = "Dynamic"
wayDesc WayProf        = "Profiling"

-- | Turn these flags on when enabling this way
wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
wayGeneralFlags _ (WayCustom {}) = []
wayGeneralFlags _ WayThreaded = []
wayGeneralFlags _ WayDebug    = []
wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]
    -- We could get away without adding -fPIC when compiling the
    -- modules of a program that is to be linked with -dynamic; the
    -- program itself does not need to be position-independent, only
    -- the libraries need to be.  HOWEVER, GHCi links objects into a
    -- .so before loading the .so using the system linker.  Since only
    -- PIC objects can be linked into a .so, we have to compile even
    -- modules of the main program with -fPIC when using -dynamic.
wayGeneralFlags _ WayProf     = []

-- | Turn these flags off when enabling this way
wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]
wayUnsetGeneralFlags _ (WayCustom {}) = []
wayUnsetGeneralFlags _ WayThreaded = []
wayUnsetGeneralFlags _ WayDebug    = []
wayUnsetGeneralFlags _ WayDyn      = [Opt_SplitSections]
   -- There's no point splitting when we're going to be dynamically linking.
   -- Plus it breaks compilation on OSX x86.
wayUnsetGeneralFlags _ WayProf     = []

-- | Pass these options to the C compiler when enabling this way
wayOptc :: Platform -> Way -> [String]
wayOptc _ (WayCustom {}) = []
wayOptc platform WayThreaded = case platformOS platform of
                               OSOpenBSD -> ["-pthread"]
                               OSNetBSD  -> ["-pthread"]
                               _         -> []
wayOptc _ WayDebug      = []
wayOptc _ WayDyn        = []
wayOptc _ WayProf       = ["-DPROFILING"]

-- | Pass these options to linker when enabling this way
wayOptl :: Platform -> Way -> [String]
wayOptl _ (WayCustom {}) = []
wayOptl platform WayThreaded =
   case platformOS platform of
   -- N.B. FreeBSD cc throws a warning if we pass -pthread without
   -- actually using any pthread symbols.
   OSFreeBSD  -> ["-pthread", "-Wno-unused-command-line-argument"]
   OSOpenBSD  -> ["-pthread"]
   OSNetBSD   -> ["-pthread"]
   _          -> []
wayOptl _ WayDebug      = []
wayOptl _ WayDyn        = []
wayOptl _ WayProf       = []

-- | Pass these options to the preprocessor when enabling this way
wayOptP :: Platform -> Way -> [String]
wayOptP _ (WayCustom {}) = []
wayOptP _ WayThreaded = []
wayOptP _ WayDebug    = []
wayOptP _ WayDyn      = []
wayOptP _ WayProf     = ["-DPROFILING"]


-- | Consult the RTS to find whether it has been built with profiling enabled.
hostIsProfiled :: Bool
hostIsProfiled = rtsIsProfiled_ /= 0

foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled_ :: Int

-- | Consult the RTS to find whether GHC itself has been built with
-- dynamic linking.  This can't be statically known at compile-time,
-- because we build both the static and dynamic versions together with
-- -dynamic-too.
hostIsDynamic :: Bool
hostIsDynamic = rtsIsDynamic_ /= 0

foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int

-- we need this until the bootstrap GHC is always recent enough
#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)

-- | Consult the RTS to find whether it is threaded.
hostIsThreaded :: Bool
hostIsThreaded = rtsIsThreaded_ /= 0

foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int

-- | Consult the RTS to find whether it is debugged.
hostIsDebugged :: Bool
hostIsDebugged = rtsIsDebugged_ /= 0

foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int

-- | Consult the RTS to find whether it is tracing.
hostIsTracing :: Bool
hostIsTracing = rtsIsTracing_ /= 0

foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int


#else

hostIsThreaded :: Bool
hostIsThreaded = False

hostIsDebugged :: Bool
hostIsDebugged = False

hostIsTracing :: Bool
hostIsTracing = False

#endif


-- | Host ways.
hostWays :: Ways
hostWays = Set.unions
   [ if hostIsDynamic  then Set.singleton WayDyn      else Set.empty
   , if hostIsProfiled then Set.singleton WayProf     else Set.empty
   , if hostIsThreaded then Set.singleton WayThreaded else Set.empty
   , if hostIsDebugged then Set.singleton WayDebug    else Set.empty
   ]

-- | Host "full" ways (i.e. ways that have an impact on the compilation,
-- not RTS only ways).
--
-- These ways must be used when compiling codes targeting the internal
-- interpreter.
hostFullWays :: Ways
hostFullWays = fullWays hostWays