{-# LANGUAGE CPP                      #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell          #-}
{-# LANGUAGE TypeOperators            #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-unused-imports     #-}
{-# OPTIONS_GHC -fno-warn-unused-top-binds   #-}
{-# OPTIONS_GHC -fobject-code                #-} -- SEE: [linking to .c files]
-- |
-- Module      : Data.Array.Accelerate.Debug.Flags
-- Copyright   : [2008..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Option parsing for debug flags
--

module Data.Array.Accelerate.Debug.Flags (

  Value,
  unfolding_use_threshold,
  max_simplifier_iterations,
  getValue,
  setValue,

  Flag(..),
  seq_sharing, acc_sharing, exp_sharing, array_fusion, simplify, inplace, flush_cache, force_recomp,
  fast_math, fast_permute_const, debug, verbose, dump_phases, dump_sharing, dump_fusion,
  dump_simpl_stats, dump_simpl_iterations, dump_vectorisation, dump_dot,
  dump_simpl_dot, dump_gc, dump_gc_stats, dump_cc, dump_ld, dump_asm, dump_exec,
  dump_sched,

  getFlag,
  setFlag, setFlags,
  clearFlag, clearFlags,

  when,
  unless,

  __cmd_line_flags,

) where


import Control.Monad.IO.Class                                       ( MonadIO, liftIO )
import Data.Bits
import Data.Int
import Data.Word
import Foreign.Ptr
import Foreign.Storable
import Language.Haskell.TH.Syntax
import System.Directory
import System.FilePath
import qualified Control.Monad                                      as M

newtype Flag  = Flag  Int
newtype Value = Value (Ptr Word32)    -- see flags.c

-- We aren't using a "real" enum so that we can make use of the unused top
-- bits for other configuration options, not controlled by the command line
-- flags.
--
instance Enum Flag where
  toEnum :: Int -> Flag
toEnum            = Int -> Flag
Flag
  fromEnum :: Flag -> Int
fromEnum (Flag Int
x) = Int
x

-- SEE: [layout of command line options bitfield]
instance Show Flag where
  show :: Flag -> String
show (Flag Int
x) =
    case Int
x of
      Int
0  -> String
"seq-sharing"
      Int
1  -> String
"acc-sharing"
      Int
2  -> String
"exp-sharing"
      Int
3  -> String
"fusion"
      Int
4  -> String
"simplify"
      Int
5  -> String
"inplace"
      Int
6  -> String
"fast-math"
      Int
7  -> String
"fast-permute-const"
      Int
8  -> String
"flush_cache"
      Int
9  -> String
"force-recomp"
      Int
10 -> String
"debug"
      Int
11 -> String
"verbose"
      Int
12 -> String
"dump-phases"
      Int
13 -> String
"dump-sharing"
      Int
14 -> String
"dump-fusion"
      Int
15 -> String
"dump-simpl_stats"
      Int
16 -> String
"dump-simpl_iterations"
      Int
17 -> String
"dump-vectorisation"
      Int
18 -> String
"dump-dot"
      Int
19 -> String
"dump-simpl_dot"
      Int
20 -> String
"dump-gc"
      Int
21 -> String
"dump-gc_stats"
      Int
22 -> String
"dump-cc"
      Int
23 -> String
"dump-ld"
      Int
24 -> String
"dump-asm"
      Int
25 -> String
"dump-exec"
      Int
26 -> String
"dump-sched"
      Int
_  -> Int -> String
forall a. Show a => a -> String
show Int
x

-- | Conditional execution of a monadic debugging expression.
--
-- This does nothing unless the program is compiled in debug mode.
--
{-# INLINEABLE when #-}
when :: MonadIO m => Flag -> m () -> m ()
#if ACCELERATE_DEBUG
when f action = do
  yes <- liftIO $ getFlag f
  M.when yes action
#else
when :: Flag -> m () -> m ()
when Flag
_ m ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif


-- | The opposite of 'when'.
--
-- This does nothing unless the program is compiled in debug mode.
--
{-# INLINEABLE unless #-}
unless :: MonadIO m => Flag -> m () -> m ()
#ifdef ACCELERATE_DEBUG
unless f action = do
  yes <- liftIO $ getFlag f
  M.unless yes action
#else
unless :: Flag -> m () -> m ()
unless Flag
_ m ()
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif


setValue   :: Value -> Word32 -> IO ()
setValue :: Value -> Word32 -> IO ()
setValue (Value Ptr Word32
f) Word32
v = Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
f Word32
v

getValue   :: Value -> IO Word32
getValue :: Value -> IO Word32
getValue (Value Ptr Word32
f) = Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
f

getFlag    :: Flag -> IO Bool
getFlag :: Flag -> IO Bool
getFlag (Flag Int
i) = do
  Word32
flags  <- Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
__cmd_line_flags
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$! Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
flags Int
i

setFlag    :: Flag -> IO ()
setFlag :: Flag -> IO ()
setFlag (Flag Int
i) = do
  Word32
flags <- Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
__cmd_line_flags
  Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
__cmd_line_flags (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
setBit Word32
flags Int
i)

clearFlag  :: Flag -> IO ()
clearFlag :: Flag -> IO ()
clearFlag (Flag Int
i) = do
  Word32
flags <- Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek Ptr Word32
__cmd_line_flags
  Ptr Word32 -> Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word32
__cmd_line_flags (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
clearBit Word32
flags Int
i)

setFlags   :: [Flag] -> IO ()
setFlags :: [Flag] -> IO ()
setFlags = (Flag -> IO ()) -> [Flag] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Flag -> IO ()
setFlag

clearFlags :: [Flag] -> IO ()
clearFlags :: [Flag] -> IO ()
clearFlags = (Flag -> IO ()) -> [Flag] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Flag -> IO ()
clearFlag

-- notEnabled :: a
-- notEnabled = error $ unlines [ "Data.Array.Accelerate: Debugging options are disabled."
--                              , "Reinstall package 'accelerate' with '-fdebug' to enable them." ]

-- Import the underlying flag variables. These are defined in the file
-- cbits/flags.h as a bitfield and initialised at program initialisation.
--
-- SEE: [layout of command line options bitfield]
-- SEE: [linking to .c files]
--
foreign import ccall "&__cmd_line_flags" __cmd_line_flags :: Ptr Word32

-- These @-f<blah>=INT@ values are used by the compiler
--
foreign import ccall "&__unfolding_use_threshold"   unfolding_use_threshold   :: Value  -- the magic cut-off figure for inlining
foreign import ccall "&__max_simplifier_iterations" max_simplifier_iterations :: Value  -- maximum number of scalar simplification passes

-- These @-f<blah>@ flags can be reversed with @-fno-<blah>@
--
seq_sharing :: Flag
seq_sharing           = Int -> Flag
Flag  Int
0 -- recover sharing of sequence expressions
acc_sharing :: Flag
acc_sharing           = Int -> Flag
Flag  Int
1 -- recover sharing of array computations
exp_sharing :: Flag
exp_sharing           = Int -> Flag
Flag  Int
2 -- recover sharing of scalar expressions
array_fusion :: Flag
array_fusion          = Int -> Flag
Flag  Int
3 -- fuse array expressions
simplify :: Flag
simplify              = Int -> Flag
Flag  Int
4 -- simplify scalar expressions
inplace :: Flag
inplace               = Int -> Flag
Flag  Int
5 -- allow (safe) in-place array updates
fast_math :: Flag
fast_math             = Int -> Flag
Flag  Int
6 -- use faster, less precise math library operations
fast_permute_const :: Flag
fast_permute_const    = Int -> Flag
Flag  Int
7 -- allow non-atomic permute const for product types
flush_cache :: Flag
flush_cache           = Int -> Flag
Flag  Int
8 -- delete persistent compilation cache(s)
force_recomp :: Flag
force_recomp          = Int -> Flag
Flag  Int
9 -- force recompilation of array programs

-- These debugging flags are disable by default and are enabled with @-d<blah>@
--
debug :: Flag
debug                 = Int -> Flag
Flag Int
10 -- compile code with debugging symbols (-g)
verbose :: Flag
verbose               = Int -> Flag
Flag Int
11 -- be very chatty
dump_phases :: Flag
dump_phases           = Int -> Flag
Flag Int
12 -- print information about each phase of the compiler
dump_sharing :: Flag
dump_sharing          = Int -> Flag
Flag Int
13 -- sharing recovery phase
dump_fusion :: Flag
dump_fusion           = Int -> Flag
Flag Int
14 -- array fusion phase
dump_simpl_stats :: Flag
dump_simpl_stats      = Int -> Flag
Flag Int
15 -- statistics form fusion/simplification
dump_simpl_iterations :: Flag
dump_simpl_iterations = Int -> Flag
Flag Int
16 -- output from each simplifier iteration
dump_vectorisation :: Flag
dump_vectorisation    = Int -> Flag
Flag Int
17 -- output from the vectoriser
dump_dot :: Flag
dump_dot              = Int -> Flag
Flag Int
18 -- generate dot output of the program
dump_simpl_dot :: Flag
dump_simpl_dot        = Int -> Flag
Flag Int
19 -- generate simplified dot output
dump_gc :: Flag
dump_gc               = Int -> Flag
Flag Int
20 -- trace garbage collector
dump_gc_stats :: Flag
dump_gc_stats         = Int -> Flag
Flag Int
21 -- print final GC statistics
dump_cc :: Flag
dump_cc               = Int -> Flag
Flag Int
22 -- trace code generation & compilation
dump_ld :: Flag
dump_ld               = Int -> Flag
Flag Int
23 -- trace runtime linker
dump_asm :: Flag
dump_asm              = Int -> Flag
Flag Int
24 -- trace assembler
dump_exec :: Flag
dump_exec             = Int -> Flag
Flag Int
25 -- trace execution
dump_sched :: Flag
dump_sched            = Int -> Flag
Flag Int
26 -- trace scheduler


-- Note: [linking to .c files]
--
-- We use Template Haskell to tell GHC which .c files need to be compiled
-- for a particular module, rather than relying on Cabal as is traditional.
-- Using Cabal:
--
--  * loading Accelerate into GHCi only works _after_ compiling the entire
--    package (which defeats the purpose), presumably because the .c files
--    are compiled last. This would often lead to errors such "can not find
--    symbol __cmd_line_flags" etc.
--
--  * Cabal would refuse to re-compile .c files when changing command
--    line flags, see: https://github.com/haskell/cabal/issues/4937
--
--  * Linking problems also prevented us from using Template Haskell in
--    some locations, because GHC was unable to load the project into the
--    interpreter to run the splices.
--
-- Note that for this fix to work in GHCi we also require modules using it
-- to be loaded as object code.
--
runQ $ do
  addForeignFilePath LangC "cbits/flags.c"
  return []