intensional-datatys-0.2.0.0: profile/Profile.hs

module Main where

import Control.Monad
import Control.Monad.IO.Class
import DynFlags
import EnumSet
import GHC
import Intensional
import Plugins
import System.Directory
import System.Environment
import System.FilePath.Posix
import System.IO
import System.Timeout
import CmdLineParser

data Mode
  = Profile
  | BenchmarkInit
  | Benchmark
  deriving (Eq)

compileWithPlugin :: Mode -> IO ()
compileWithPlugin m = do
  args <- words <$> readFile "profile/self-args"
  runGhc (Just "/opt/ghc/8.8.3/lib/ghc-8.8.3") $ do
    df1 <- getSessionDynFlags
    (df2, leftover, ws) <-
      parseDynamicFlags
        df1
          { -- ghcLink = NoLink,
            -- optLevel = 0,
            -- enableTimeStats = m == Profile,
            -- generalFlags = fromList (Opt_ForceRecomp : [Opt_SccProfilingOn | m == Profile]),
            -- profAuto = if m == Profile then NoProfAuto else ProfAutoAll,
            staticPlugins =
              [ StaticPlugin
                  ( PluginWithArgs
                      plugin
                      ( "suppress-output"
                          : case m of
                            Profile -> []
                            Benchmark -> ["benchmark"]
                            BenchmarkInit -> ["benchmark'"]
                      )
                  )
              ]
          }
        (map noLoc args)
    liftIO $ mapM_ (print . warnReason) ws
    setSessionDynFlags df2
    mapM ((`guessTarget` Nothing) . unLoc) leftover >>= setTargets
    void $ load LoadAllTargets

main :: IO ()
main = do
  args <- getArgs
  case args of
    ["-p", file] -> do
      -- requires +RTS -pj -l-au
      compileWithPlugin Profile
      renameFile "profile.prof" ("profile/" ++ takeBaseName file ++ ".prof")
      removeFile "profile.eventlog"
    ["-b"] -> benchmark
      -- listDirectory "test/XMonad" >>= benchmark . fmap ("test/XMonad/" ++)
    -- ("-b" : files) -> benchmark -- Run benchmarks on particular files
    _ -> putStrLn "Invalid command line argument!"
  where
    benchmark :: IO ()
    benchmark = do
      -- appendFile "benchmarks" ("Running: " ++ file ++ "\n")
      b <- timeout 10000000 (compileWithPlugin BenchmarkInit)
      case b of
        Nothing -> return ()
        Just _ -> loop 9
    loop 0 = return ()
    loop n = do
      b <- timeout 10000000 (compileWithPlugin Benchmark)
      case b of
        Nothing -> return ()
        Just _ -> loop (n - 1)