1{-# LANGUAGE GADTs #-}
2{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6module Main where
7
8import System.CPUTime.Rdtsc
9import System.IO
10import System.IO.Unsafe
11import Data.IORef
12import Data.Word
13import Control.Monad
14import Control.Monad.State.Strict
15import Control.Monad.Fail (MonadFail)
16import Control.Monad.Free
17import Control.Monad.Free.TH
18import qualified Control.Monad.Free.Church as Church
19import Control.Monad.IO.Class
20import Control.Monad.Trans.Maybe
21import Control.Category ((>>>))
22import qualified Data.Foldable as F
23import Text.Read.Compat (readMaybe)
24import Text.Printf
25
26-- | A data type representing basic commands for our performance-testing eDSL.
27data PerfF next where
28  Output    :: String -> next -> PerfF next
29  Input     :: (Show a, Read a) => (a -> next) -> PerfF next
30
31-- | Unfortunately this Functor instance cannot yet be derived
32-- automatically by GHC.
33instance Functor PerfF where
34  fmap f (Output s x) = Output s (f x)
35  fmap f (Input g) = Input (f . g)
36
37makeFreeCon 'Output
38makeFreeCon 'Input
39
40type PerfCnt = Word64
41
42-- | Unsafe state variable: base CPU cycles
43{-# NOINLINE g_base_counter #-}
44g_base_counter :: IORef PerfCnt
45g_base_counter = unsafePerformIO $ do
46  rdtsc >>= newIORef
47
48-- | Prints number of CPU cycles since last call
49g_print_time_since_prev_call :: (MonadIO m) => m ()
50g_print_time_since_prev_call = liftIO $ do
51  cb <- readIORef g_base_counter
52  c <- rdtsc
53  writeIORef g_base_counter c
54  putStr $ printf "\r%-10s" (show $ c - cb)
55
56-- | Free-based interpreter
57runPerfFree :: (MonadIO m) => [String] -> Free PerfF () -> m ()
58runPerfFree [] _ = return ()
59runPerfFree (s:ss) x = case x of
60  Free (Output o next) -> do
61    runPerfFree (s:ss) next
62  Free (Input next) -> do
63    g_print_time_since_prev_call
64    runPerfFree ss (next (read s))
65  Pure a -> do
66    return a
67
68-- | Church-based interpreter
69runPerfF :: (MonadFail m, MonadIO m) => [String] -> Church.F PerfF () -> m ()
70runPerfF [] _ = return ()
71runPerfF ss0 f =
72  fst `liftM` do
73  flip runStateT ss0 $ Church.iterM go f where
74    go (Output o next) = do
75      next
76    go (Input next) = do
77      g_print_time_since_prev_call
78      (s:ss) <- get
79      put ss
80      next (read s)
81
82-- | Test input is the same for all cases
83test_input = [show i | i<-([1..9999] ++ [0])]
84
85-- | Tail-recursive program
86test_tail :: (MonadFree PerfF m) => m ()
87test_tail = do
88  output "Enter something"
89  (n :: Int) <- input
90  output $ "Just entered: " ++ (show n)
91  when (n > 0) $ do
92    test_tail
93
94run_tail_free,run_tail_f :: IO ()
95run_tail_free = runPerfFree test_input test_tail
96run_tail_f = runPerfF test_input test_tail
97
98
99-- | Deep-recursive program
100test_loop :: (MonadFree PerfF m) => m ()
101test_loop = do
102  output "Enter something"
103  (n :: Int) <- input
104  when (n > 0) $ do
105    test_loop
106  output $ "Just entered: " ++ (show n)
107
108run_loop_free,run_loop_f :: IO ()
109run_loop_free = runPerfFree test_input test_loop
110run_loop_f = runPerfF test_input test_loop
111
112main :: IO ()
113main = do
114  putStr $ unlines [
115      "Running two kinds of FreeMonad programs against two kinds of interpreters.",
116      "Counters represent approx. number of CPU ticks per program iteration" ]
117  putStrLn ">> (1/4) Tail-recursive program/Free interpreter"
118  run_tail_free
119  putStrLn "\n>> (2/4) Tail-recursive program/Church interpreter"
120  run_tail_f
121  putStrLn "\n>> (3/4) Deep-recursive program/Free interpreter (a slower one)"
122  run_loop_free
123  putStrLn "\n>> (4/4) Deep-recursive program/Church interpreter"
124  run_loop_f
125  putStrLn "\n"
126
127