tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

Probe.hs (3144B)

      1 {-# LANGUAGE BangPatterns #-}
      2 {-# OPTIONS_GHC -fno-full-laziness -fno-cse #-}
      3 -- Only the harness disables sharing optimizations, not the production runtime.
      4 module Main where
      5 import Runtime.Tree
      6 import Runtime.Value
      7 import qualified Data.ByteString as BS
      8 import Control.Exception (evaluate)
      9 import Control.Monad (foldM, unless)
     10 import GHC.Clock (getMonotonicTimeNSec)
     11 import System.Environment (getArgs)
     12 import System.Exit (die)
     13 import Text.Printf (printf)
     14 
     15 now :: IO Double
     16 now = (/1e9) . fromIntegral <$> getMonotonicTimeNSec
     17 
     18 data Suspended = Suspended T
     19 {-# OPAQUE suspend #-}
     20 suspend :: T -> T -> Suspended
     21 suspend f x = Suspended (apply f x)
     22 
     23 force :: T -> ()
     24 force Leaf = ()
     25 force (Stem x) = force x
     26 force (Fork x y) = force x `seq` force y
     27 
     28 check :: IO ()
     29 check = do
     30   let a = Stem (Stem Leaf); b = Fork Leaf (Stem Leaf)
     31       identity = Fork (Stem (Stem Leaf)) (Stem Leaf)
     32       cases = [ (apply Leaf a, Stem a), (apply (Stem a) b, Fork a b)
     33               , (apply (Fork Leaf a) (error "discard forced"), a)
     34               , (apply identity b, b)
     35               , (apply (Fork (Fork a b) Leaf) Leaf, a)
     36               , (apply (Fork (Fork a b) Leaf) (Stem Leaf), apply b Leaf)
     37               , (apply (Fork (Fork a b) identity) (Fork a b), apply (apply identity a) b)]
     38   mapM_ (\(actual, expected) -> unless (actual == expected) (die "reduction mismatch")) cases
     39   _ <- evaluate (suspend (error "construction forced function") Leaf)
     40   unless (toBytes (Fork (ofNumber 256) Leaf) == Left "Byte value out of range: 256")
     41     (die "invalid byte accepted")
     42   putStrLn "checks passed"
     43 
     44 iteration :: String -> Int -> Int -> IO (Double, Double, Double)
     45 iteration kind n roundNo = do
     46   let bytes = BS.pack [fromIntegral (97 + (j+roundNo) `mod` 26) | j <- [0..n-1]]
     47   _ <- evaluate (BS.length bytes)
     48   start <- now
     49   Suspended term <- if kind == "codec" then do
     50       let input = ofBytes bytes
     51       _ <- evaluate (force input)
     52       evaluate (suspend (Fork (Stem (Stem Leaf)) (Stem Leaf)) input)
     53     else foldM (\(Suspended previous) _ -> evaluate $
     54       if kind == "deep" then suspend (Fork Leaf previous) Leaf
     55       else suspend (Fork (Stem (Stem Leaf)) (Stem Leaf)) previous)
     56       (Suspended Leaf) [1..n]
     57   built <- now
     58   result <- evaluate term
     59   reduced <- now
     60   valid <- evaluate $ if kind == "codec" then toBytes result == Right bytes
     61                      else case result of Leaf -> True; _ -> False
     62   unless valid (die "incorrect complete result")
     63   observed <- now
     64   pure (built-start, reduced-built, observed-reduced)
     65 
     66 main :: IO ()
     67 main = do
     68   args <- getArgs
     69   case args of
     70     ["check"] -> check
     71     [kind, size, count] | kind `elem` ["codec", "deep", "distribution"] -> do
     72       let n = read size; rounds = read count
     73       unless (n > 0 && rounds > 0) (die "positive sizes required")
     74       (!b,!r,!o) <- foldM (\(!b,!r,!o) i -> do
     75         (b',r',o') <- iteration kind n i
     76         pure (b+b',r+r',o+o')) (0,0,0) [0..rounds-1]
     77       printf "{\"kind\":\"%s\",\"n\":%d,\"rounds\":%d,\"build_s\":%.9f,\"reduce_s\":%.9f,\"observe_s\":%.9f}\n" kind n rounds b r o
     78     _ -> die "usage: probe check | codec|deep|distribution SIZE ROUNDS"