{-# OPTIONS_GHC -Wno-missing-signatures #-}
-- |
-- Repeatable timing harness for the nesting-depth blowup described in
-- @docs/tasks/parser-exponential-time-on-nesting.md@.
--
-- Run with @cabal run nesting-bench@. Prints a table of parse times so the
-- before\/after effect of a fix is measurable rather than asserted.
--
-- Each case is given a wall-clock budget; a case that exceeds it is reported
-- as a timeout instead of hanging the run.
module Main where
import Control.Concurrent.MVar
import qualified Data.Text as Text
import PostgresqlSyntax (AExpr, parse)
import Prelude
import System.Clock
-- * Inputs
-- | Case 1: @((((a + b))))@ with @n@ layers of redundant parentheses.
nestedParens :: Int -> Text
nestedParens n =
Text.replicate n "(" <> "a + b" <> Text.replicate n ")"
-- | Case 2: the user-reported shape — a sum of @COALESCE@ terms, split into
-- two parenthesised groups subtracted from one another, wrapped in a few
-- redundant parentheses.
coalesceSum :: Int -> Int -> Text
coalesceSum terms wrap =
Text.replicate wrap "("
<> group 0
<> " - "
<> group terms
<> Text.replicate wrap ")"
where
group off =
"(" <> Text.intercalate " + " [term (off + i) | i <- [1 .. terms]] <> ")"
term i =
"coalesce(c" <> Text.pack (show i) <> ", 0)"
-- * Timing
-- | Run an action under a wall-clock budget. 'Nothing' on timeout.
withTimeout :: Int -> IO a -> IO (Maybe a)
withTimeout micros action = do
slot <- newEmptyMVar
_ <- forkIO (action >>= \x -> putMVar slot (Just x))
_ <- forkIO (threadDelay micros >> putMVar slot Nothing)
takeMVar slot
-- | Parse and fully force the result, returning elapsed seconds.
time :: Text -> IO Double
time input = do
start <- getTime Monotonic
_ <- evaluate (force (either (const "err") (const "ok") (parse @AExpr mempty input) :: String))
end <- getTime Monotonic
pure (fromIntegral (toNanoSecs (diffTimeSpec end start)) / 1e9)
budgetSeconds :: Double
budgetSeconds = 10
measure :: String -> Text -> IO ()
measure label input = do
result <- withTimeout (round (budgetSeconds * 1e6)) (time input)
putStrLn $ case result of
Nothing -> pad label <> " TIMEOUT (>" <> show (round budgetSeconds :: Int) <> "s), " <> show (Text.length input) <> " chars"
Just seconds -> pad label <> " " <> show seconds <> "s, " <> show (Text.length input) <> " chars"
where
pad s = s <> replicate (max 0 (28 - length s)) ' '
main :: IO ()
main = do
putStrLn "Case 1: ((((a + b)))) at increasing nesting depth"
mapM_ (\n -> measure (" depth " <> show n) (nestedParens n)) [1, 2, 4, 6, 8, 10, 12, 14, 16, 20, 30, 50, 100, 500]
putStrLn ""
putStrLn "Case 2: sum-of-COALESCE, two groups, 6 redundant wraps"
mapM_ (\t -> measure (" " <> show (2 * t) <> " terms") (coalesceSum t 6)) [4, 8, 12, 16, 20, 24]