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