content: {-# LANGUAGE GADTs #-}
  module Main where
  
  import Control.Exception
  import System.Process
  import System.FilePath
  import System.Directory
  import System.Exit
  import System.IO
  import Control.Monad
  import Data.List
  import Numeric
  import Text.Printf
  
  main :: IO ()
  main = return ()
  
  nCycles = 10
  buildScript = "." </> "build.sh"
  
  -- programs = ["Bush"]
  programs = ["Allocate", "BinTree", "Bush", "BushTail", "Imbalanced",
              "MemBench", "PowerSet"]
  
  data Style = Baseline | TailCopy | TailCompact
  
  instance Show Style where
    show Baseline = "\\textbf{Baseline}"
    show TailCopy = "\\textbf{Tail-copy}"
    show TailCompact = "\\textbf{Tail-compact}"
  
  styles = [Baseline, TailCopy, TailCompact]
  
  type Millisecond = Int
  type Bytes = Int
  type MutTime = Millisecond
  type GCTime = Millisecond
  
  type Collections = Int
  type Copied = Bytes
  type Allocated = Bytes
  type MaxHeap = Bytes
  type PageFaults = Int
  type Cycles = Int
  type Instructions = Int
  type Branches = Int
  type BranchMisses = Int
  type LLCLoads = Int
  type LLCMisses = Int
  
  data Stat a where
    Runtime :: Stat (MutTime,GCTime)
    GCStats :: Stat (Collections, Copied, Allocated, MaxHeap)
    Perf :: Stat (PageFaults, Cycles, Instructions, Branches, BranchMisses, LLCLoads, LLCMisses)
  
  instance Show (Stat a) where
    show Runtime = "Runtime"
    show GCStats = "GCStats"
    show Perf = "Perf"
  
  getStats :: IO ()
  getStats = do
    -- sanityCheck
  
    ------------------------------------
    -- Runtime
    putStr (replicate (length programs * length styles * nCycles) '-')
    putStr "\r"
    runtimes <- forM programs $ \prog ->
      forM styles $ \style ->
        unzip <$> replicateM nCycles (getStat prog style Runtime)
    let (muttimes, gctimes) = unzip (map unzip runtimes)
    let (mutTabbed, mutAggr) = tabulate showMilli muttimes
        (gcTabbed, gcAggr) = tabulate showMilli gctimes
  
    putStr $ ppTable "Mutator times:" mutTabbed
    putStr $ ppAggregates mutAggr
  
    putStr $ ppTable "GC times:" gcTabbed
    putStr $ ppAggregates gcAggr
  
    ------------------------------------
    -- GCStats
    -- putStr (replicate (length programs * length styles) '-')
    -- putStr "\r"
    -- runtimes <- forM programs $ \prog ->
    --   forM styles $ \style ->
    --     unzip4 <$> replicateM 1 (getStat prog style GCStats)
    -- let (collections, copied, allocated, maxheap) = unzip4 (map unzip4 runtimes)
    -- let (colTabbed, colAggr) = tabulate show collections
    --     (copiedTabbed, copiedAggr) = tabulate showBytes copied
    --     (allocTabbed, allocAggr) = tabulate showBytes allocated
    --     (heapTabbed, heapAggr) = tabulate showBytes maxheap
    --
    -- putStr $ ppTable "Collections:" colTabbed
    -- putStr $ ppAggregates colAggr
    -- putStr $ ppTable "Copied:" copiedTabbed
    -- putStr $ ppAggregates copiedAggr
    -- putStr $ ppTable "Allocated:" allocTabbed
    -- putStr $ ppAggregates allocAggr
    -- putStr $ ppTable "Heap size:" heapTabbed
    -- putStr $ ppAggregates heapAggr
  
    ------------------------------------
    -- Perf
    -- putStr (replicate (length programs * length styles * nCycles) '-')
    -- putStr "\r"
    -- runtimes <- forM programs $ \prog ->
    --   forM styles $ \style ->
    --     unzip7 <$> replicateM nCycles (getStat prog style Perf)
    -- let (pageFaults, cycles, instructions, branches, branchMisses, llcLoads, llcMisses) =
    --       unzip7 (map unzip7 runtimes)
    -- let (pageTabbed, pageAggr) = tabulate showCount pageFaults
    --     (cyclesTabbed, cyclesAggr) = tabulate showCount cycles
    --     (instructionsTabbed, instructionsAggr) = tabulate showCount instructions
    --     (branchesTabbed, branchesAggr) = tabulate showCount branches
    --     (branchMissesTabbed, branchMissesAggr) = tabulate showCount branchMisses
    --     (llcLoadsTabbed, llcLoadsAggr) = tabulate showCount llcLoads
    --     (llcMissesTabbed, llcMissesAggr) = tabulate showCount llcMisses
    --
    -- putStr $ ppTable "Page faults:" pageTabbed
    -- putStr $ ppAggregates pageAggr
    -- putStr $ ppTable "Cycles:" cyclesTabbed
    -- putStr $ ppAggregates cyclesAggr
    -- putStr $ ppTable "Instructions:" instructionsTabbed
    -- putStr $ ppAggregates instructionsAggr
    -- putStr $ ppTable "Branches:" branchesTabbed
    -- putStr $ ppAggregates branchesAggr
    -- putStr $ ppTable "Branch Misses:" branchMissesTabbed
    -- putStr $ ppAggregates branchMissesAggr
    -- putStr $ ppTable "LLC Loads:" llcLoadsTabbed
    -- putStr $ ppAggregates llcLoadsAggr
    -- putStr $ ppTable "LLC Load Misses:" llcMissesTabbed
    -- putStr $ ppAggregates llcMissesAggr
  
    return ()
  
  getStat :: String -> Style -> Stat a -> IO a
  getStat prog style stat = do
    putStr "*\b"
    -- build prog
    hasProg <- doesFileExist dstFile
    unless hasProg $
      mustSucceed "build" =<< waitForProcess =<< spawnProcess buildScript [srcFile]
    case stat of
      Runtime -> do
        -- run: ./prog +RTS -s (args from style)
        (_stdout,_stdin,_stderr,p) <- runInteractiveProcess dstFile (["+RTS", "-s"] ++ styleArgs) Nothing Nothing
        hClose _stdout
        output <- hGetContents _stderr
        evaluate (length output)
        -- putStrLn output
        hClose _stderr
        mustSucceed (show (prog,style,stat)) =<< waitForProcess p
        putStr "."
        -- collect stderr
        -- look for Realtime and "GC Realtime"
        case map words $ lines output of
          [["Realtime:",mutTime]
           ,_
           ,["GC", "Realtime:",gcTime]
           ,_] -> do
            return (readSeconds mutTime, readSeconds gcTime)
          _ -> do
            hPutStrLn stderr $ "Invalid output:\n" ++ output
            exitWith (ExitFailure 1)
      GCStats -> do
        -- run: ./prog +RTS --gc-stats --machine-readable (args from style)
        (_stdout,_stdin,_stderr,p) <- runInteractiveProcess dstFile (["+RTS", "--gc-stats", "--machine-readable"] ++ styleArgs) Nothing Nothing
        hClose _stdout
        output <- hGetContents _stderr
        evaluate (length output)
        mustSucceed prog =<< waitForProcess p
        putStr "."
        case map words $ lines output of
          [  "Collections:", collections] :
            ["Copied:", copied, "b"] :
            ["Allocated:", allocated, "b"] :
            ["Max", "heap:", maxheap, "b"] :
            _ -> return (read collections, read copied, read allocated, read maxheap)
          _   -> do
            hPutStrLn stderr $ "Invalid output:\n" ++ output
            exitWith (ExitFailure 1)
      Perf -> do
        (_stdout,_stdin,_stderr,p) <- runInteractiveProcess "perf" (perfArgs ++ [dstFile, "+RTS"] ++ styleArgs) Nothing Nothing
        hClose _stdout
        output <- hGetContents _stderr
        evaluate (length output)
        mustSucceed "perf" =<< waitForProcess p
        putStr "."
        case map words $ lines output of
          [ (pageFaults : "page-faults" : _),
            (cycles : "cycles" : _),
            (instructions : "instructions" : _),
            ( branches : "branches" : _),
            ( branchMisses : "branch-misses" : _),
            ( llcLoads: "LLC-loads" : _),
            ( llcLoadMisses : "LLC-load-misses" : _)
            ] ->
            return (read pageFaults, read cycles, read instructions, read branches
                    , read branchMisses, read llcLoads, read llcLoadMisses)
          _ -> do
            hPutStrLn stderr $ "Invalid output:\n" ++ output
            exitWith (ExitFailure 1)
    where
      srcFile = "examples" </> prog <.> "hs"
      dstFile = "." </> prog
      perfArgs = ["stat","--event=page-faults,cycles,instructions,branches,branch-misses,LLC-loads,LLC-load-misses","--field-separator", " "]
      styleArgs =
        case style of
          Baseline -> []
          TailCopy -> ["--tail-copy"]
          TailCompact -> ["--tail-copy", "--tail-compact"]
  
  readSeconds :: String -> Millisecond
  readSeconds inp =
    case reads inp of
      [(float,"s")] -> round (float*1000)
      _             -> error $ "bad parse: " ++ inp
  
  {-
  \hline
  \multicolumn{4}{|c|}{Mutator runtime}\\
  \hline
  Name & Baseline & Tail-copy & Tail-compact \\
  
  \hline
  Allocate &                1.6s (±0.4\%)  &          +0.1\% (±2.9\%) &          +4.5\% (±0.9\%) \\
  BinTree  &                1.8s (±+0.8\%) &          -0.5\% (±1.5\%) &          -2.8\% (±1.0\%) \\
  Bush       &              2.4s (±0.4\%) &           -0.3\% (±0.3\%) &          -0.4\% (±0.2\%) \\
  BushTail   &              3.6s (±0.3\%) &           -0.1\% (±0.2\%) &          -0.2\% (±0.3\%) \\
  Imbalanced &              1.7s (±0.4\%) &           -0.7\% (±0.9\%) &          -0.4\% (±0.1\%) \\
  MemBench   &              1.7s (±0.7\%) &           -0.3\% (±0.2\%) &          -0.5\% (±0.2\%) \\
  PowerSet   &              1.1s (±0.5\%) &           -0.5\% (±0.5\%) &          -0.6\% (±0.3\%) \\
  \hline
  -}
  ppTable :: String -> [[String]] -> String
  ppTable caption table = unlines $
    ["","","", "\\hline","\\multicolumn{4}{|c|}{"++caption++"}\\\\","\\hline"] ++
    [intercalate "&" ("\\textbf{Name}":map show styles) ++ "\\\\" ] ++
    [ intercalate "&" (map (pad 15) (prog : progValues)) ++ "\\\\"
    | (prog, progValues) <- zip programs table ] ++
    ["\\hline"]
  
  pad :: Int -> String -> String
  pad n str = str ++ replicate (n-length str) ' '
  
  {-
  \hline
  \multicolumn{2}{|l|}{Min} &  -0.7\% &                   -2.8\% \\
  \multicolumn{2}{|l|}{Max} &   +0.1\% &                   +4.5\% \\
  \multicolumn{2}{|l|}{Mean} &   -0.3\% &                   -0.1\% \\
  \hline
  -}
  ppAggregates :: [[String]] -> String
  ppAggregates aggr = unlines $
    [ "\\hline" ] ++
    [ intercalate "&" (("\\multicolumn{2}{|l|}{"++key++"}"):row) ++ "\\\\"
    | (key:row) <- aggr ] ++
    [ "\\hline" ]
    -- replicate (4*25) '-' ++ "\n" ++ unlines (map ppRow table)
  
  ppRow :: [String] -> String
  ppRow = concatMap (printf "%-25s")
  
  -- Compute values compared against baseline.
  -- Compute min, max, and mean
  tabulate :: (Int -> String) -> [[[Int]]] -> ([[String]], [[String]])
  tabulate ppFn input = (map row input, transpose $ ["Min", "Max", "Mean"] : map column relColumns)
    where
      relColumns = transpose
        [ [ fromIntegral (median cell-baseMed) / fromIntegral baseMed
          | let baseMed = median baseline
          , cell <- rest ]
        | (baseline:rest) <- input ]
      column cs = map showPercent [minimum cs,maximum cs,sum cs / (fromIntegral $ length cs)]
      row (baseline:rest) = showPrimary baseline : map (showRelative (median baseline)) rest
      showRelative baseMed lst = diff -- ++ (" (±" ++ dev ++ ")")
        where
          diff = showPercent' (fromIntegral (med-baseMed) / fromIntegral baseMed)
          med = median lst
          dev = showPercent (deviation lst med)
      showPrimary lst = ppFn med -- ++ " (±" ++ dev ++ ")"
        where
          med = median lst
          dev = showPercent (deviation lst med)
  
  showPercent' f =
    (if f<0 then "" else "+") ++ showFFloat (Just 1) (f*100) "\\%"
  
  showPercent f = showFFloat (Just 1) (f*100) "\\%"
  
  
  showMilli :: Millisecond -> String
  showMilli usec = showFFloat (Just 1) (fromIntegral usec / 1000) "s"
  
  showBytes :: Bytes -> String
  showBytes bs
    | bs < 1024^1 = shows bs " b"
    | bs < 1024^2 = unit 1 " kb"
    | bs < 1024^3 = unit 2 " mb"
    | otherwise   = unit 3 " gb"
    where
      unit n label = showFFloat (Just 1) (fromIntegral bs / (1024^n)) label
  
  showCount :: Bytes -> String
  showCount bs
    | bs < 1000^1 = shows bs ""
    | bs < 1000^2 = unit 1 " thousand"
    | bs < 1000^3 = unit 2 " million"
    | otherwise   = unit 3 " billion"
    where
      unit n label = showFFloat (Just 1) (fromIntegral bs / (1000^n)) label
  
  median :: [Int] -> Int
  median lst'
    | odd len = lst !! (len `div` 2)
    | otherwise = (lst !! (len `div` 2) + lst !! (len `div` 2 - 1)) `div` 2
    where
      lst = sort lst'
      len = length lst'
  
  geomean :: [Int] -> Int
  geomean lst = round $ fromIntegral (product lst) ** (recip $ fromIntegral $ length lst)
  
  deviation :: [Int] -> Int -> Double
  deviation lst target = maximum
    [ (fromIntegral (abs (e-target)) / fromIntegral target)
    | e <- lst ]
  
  sanityCheck :: IO ()
  sanityCheck = do
    (code, _, _) <- readProcessWithExitCode "perf" ["stat", "true"] ""
    mustSucceed "perf" code
    hasBuild <- doesFileExist buildScript
    unless hasBuild $ do
      hPutStrLn stderr $ "Missing "++buildScript++" script"
  
  mustSucceed _ ExitSuccess = return ()
  mustSucceed cmd code = do
    hPutStrLn stderr $ "Command failed: " ++ cmd
    exitWith code
  