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