-- | 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
   , wayOptcxx
   , 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 is 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 (Way -> Way -> Bool
(Way -> Way -> Bool) -> (Way -> Way -> Bool) -> Eq Way
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Way -> Way -> Bool
== :: Way -> Way -> Bool
$c/= :: Way -> Way -> Bool
/= :: Way -> Way -> Bool
Eq, Eq Way
Eq Way =>
(Way -> Way -> Ordering)
-> (Way -> Way -> Bool)
-> (Way -> Way -> Bool)
-> (Way -> Way -> Bool)
-> (Way -> Way -> Bool)
-> (Way -> Way -> Way)
-> (Way -> Way -> Way)
-> Ord Way
Way -> Way -> Bool
Way -> Way -> Ordering
Way -> Way -> Way
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Way -> Way -> Ordering
compare :: Way -> Way -> Ordering
$c< :: Way -> Way -> Bool
< :: Way -> Way -> Bool
$c<= :: Way -> Way -> Bool
<= :: Way -> Way -> Bool
$c> :: Way -> Way -> Bool
> :: Way -> Way -> Bool
$c>= :: Way -> Way -> Bool
>= :: Way -> Way -> Bool
$cmax :: Way -> Way -> Way
max :: Way -> Way -> Way
$cmin :: Way -> Way -> Way
min :: Way -> Way -> Way
Ord, Int -> Way -> ShowS
[Way] -> ShowS
Way -> String
(Int -> Way -> ShowS)
-> (Way -> String) -> ([Way] -> ShowS) -> Show Way
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Way -> ShowS
showsPrec :: Int -> Way -> ShowS
$cshow :: Way -> String
show :: Way -> String
$cshowList :: [Way] -> ShowS
showList :: [Way] -> ShowS
Show, ReadPrec [Way]
ReadPrec Way
Int -> ReadS Way
ReadS [Way]
(Int -> ReadS Way)
-> ReadS [Way] -> ReadPrec Way -> ReadPrec [Way] -> Read Way
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Way
readsPrec :: Int -> ReadS Way
$creadList :: ReadS [Way]
readList :: ReadS [Way]
$creadPrec :: ReadPrec Way
readPrec :: ReadPrec Way
$creadListPrec :: ReadPrec [Way]
readListPrec :: ReadPrec [Way]
Read)

type Ways = Set Way

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

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

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

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

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

-- | Unique tag associated to a list of ways
waysTag :: Ways -> String
waysTag :: Ways -> String
waysTag = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (Ways -> [String]) -> Ways -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"_" ([String] -> [String]) -> (Ways -> [String]) -> Ways -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Way -> String) -> [Way] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Way -> String
wayTag ([Way] -> [String]) -> (Ways -> [Way]) -> Ways -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ways -> [Way]
forall a. Set a -> [a]
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 :: Ways -> String
waysBuildTag Ways
ws = Ways -> String
waysTag ((Way -> Bool) -> Ways -> Ways
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Way -> Bool) -> Way -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> Bool
wayRTSOnly) Ways
ws)


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

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

-- | Filter ways that have an impact on compilation
fullWays :: Ways -> Ways
fullWays :: Ways -> Ways
fullWays Ways
ws = (Way -> Bool) -> Ways -> Ways
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Way -> Bool) -> Way -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> Bool
wayRTSOnly) Ways
ws

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

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

-- | Turn these flags on when enabling this way
wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
wayGeneralFlags :: Platform -> Way -> [GeneralFlag]
wayGeneralFlags Platform
_ (WayCustom {}) = []
wayGeneralFlags Platform
_ Way
WayThreaded = []
wayGeneralFlags Platform
_ Way
WayDebug    = []
wayGeneralFlags Platform
_ Way
WayDyn      = [GeneralFlag
Opt_PIC, GeneralFlag
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 Platform
_ Way
WayProf     = []

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

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

wayOptcxx :: Platform -> Way -> [String]
wayOptcxx :: Platform -> Way -> [String]
wayOptcxx = Platform -> Way -> [String]
wayOptc -- Use the same flags as C

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

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


-- | Consult the RTS to find whether it has been built with profiling enabled.
hostIsProfiled :: Bool
hostIsProfiled :: Bool
hostIsProfiled = Int
rtsIsProfiled_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
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 :: Bool
hostIsDynamic = Int
rtsIsDynamic_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int


-- | Consult the RTS to find whether it is threaded.
hostIsThreaded :: Bool
hostIsThreaded :: Bool
hostIsThreaded = Int
rtsIsThreaded_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int

-- | Consult the RTS to find whether it is debugged.
hostIsDebugged :: Bool
hostIsDebugged :: Bool
hostIsDebugged = Int
rtsIsDebugged_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int

-- | Consult the RTS to find whether it is tracing.
hostIsTracing :: Bool
hostIsTracing :: Bool
hostIsTracing = Int
rtsIsTracing_ Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0

foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int




-- | Host ways.
hostWays :: Ways
hostWays :: Ways
hostWays = [Ways] -> Ways
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
   [ if Bool
hostIsDynamic  then Way -> Ways
forall a. a -> Set a
Set.singleton Way
WayDyn      else Ways
forall a. Set a
Set.empty
   , if Bool
hostIsProfiled then Way -> Ways
forall a. a -> Set a
Set.singleton Way
WayProf     else Ways
forall a. Set a
Set.empty
   , if Bool
hostIsThreaded then Way -> Ways
forall a. a -> Set a
Set.singleton Way
WayThreaded else Ways
forall a. Set a
Set.empty
   , if Bool
hostIsDebugged then Way -> Ways
forall a. a -> Set a
Set.singleton Way
WayDebug    else Ways
forall a. Set a
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 :: Ways
hostFullWays = Ways -> Ways
fullWays Ways
hostWays