ReducerSmoke.hs (5314B)
1 {-# LANGUAGE BangPatterns #-} 2 {-# OPTIONS_GHC -fno-full-laziness -fno-cse #-} 3 -- Harness-only anti-sharing flags; production Runtime.Tree compiles normally. 4 -- This deliberately uses the real, uninstrumented Haskell reducer. 5 module Main where 6 7 import Control.Exception (evaluate) 8 import Control.Monad (foldM, unless) 9 import qualified Data.ByteString as BS 10 import qualified Data.Vector as V 11 import GHC.Clock (getMonotonicTimeNSec) 12 import Runtime 13 import Wire 14 import TreeObservation (forceTreeShared) 15 import System.Environment (getArgs) 16 import System.Exit (die) 17 import System.Mem (performGC) 18 import System.Posix.Resource 19 import Text.Printf (printf) 20 21 now :: IO Double 22 now = (/ 1e9) . fromIntegral <$> getMonotonicTimeNSec 23 24 -- Forcing this box allocates the application thunk but does NOT demand its 25 -- result. OPAQUE prevents specialization of known constant/identity functions. 26 data Suspended = Suspended T 27 {-# OPAQUE suspend #-} 28 suspend :: T -> T -> Suspended 29 suspend f x = Suspended (apply f x) 30 31 -- Inputs are finite canonical byte lists. Force their complete construction 32 -- before measuring application, without running a codec to validate them. 33 forceInput :: T -> () 34 forceInput Leaf = () 35 forceInput (Stem x) = forceInput x 36 forceInput (Fork x y) = forceInput x `seq` forceInput y 37 38 load :: FilePath -> IO T 39 load path = do 40 bytes <- BS.readFile path 41 bundle <- either die pure (decodeBundle bytes) 42 either die pure (verifyBundle bundle) 43 index <- case bundleRoots bundle of 44 first:_ -> pure first 45 [] -> die "bundle has no roots" 46 let root = reconstructBundleTerms (bundleNodes bundle) V.! fromIntegral index 47 forceTreeShared root 48 pure root 49 50 rss :: String -> IO Integer 51 rss key = do 52 contents <- readFile "/proc/self/status" 53 case [read value | line <- lines contents, (label:value:_) <- [words line], label == key ++ ":"] of 54 [value] -> evaluate value 55 _ -> die ("cannot read " ++ key) 56 57 -- Each invocation creates fresh input graphs/thunks. Round-dependent bytes 58 -- match the C runner and prevent accidentally benchmarking a cached result. 59 {-# NOINLINE iteration #-} 60 iteration :: String -> Int -> Int -> T -> IO (Double, Double, Double) 61 iteration kind n roundNo worker = do 62 let input = BS.pack [fromIntegral (97 + (j + roundNo) `mod` 26) | j <- [0..n-1]] 63 second = BS.pack [fromIntegral (65 + (j + roundNo) `mod` 26) | j <- [0..n-1]] 64 strings = kind == "id" || kind == "append" 65 if strings then evaluate (BS.length input + BS.length second) >> pure () else pure () 66 begin <- now 67 Suspended term <- if strings then do 68 let arg = ofBytes input 69 evaluate (forceInput arg) 70 first <- evaluate (suspend worker arg) 71 if kind == "append" then do 72 let arg2 = ofBytes second 73 evaluate (forceInput arg2) 74 case first of Suspended f -> evaluate (suspend f arg2) 75 else pure first 76 else foldM (\(Suspended previous) _ -> 77 if kind == "distribution" then evaluate (suspend worker previous) 78 else evaluate (suspend (Fork Leaf previous) Leaf)) (Suspended Leaf) [1..n] 79 built <- now 80 result <- evaluate term 81 reduced <- now 82 valid <- evaluate $ if strings then case toBytes result of 83 Left _ -> False 84 Right bytes -> BS.length bytes == n * (if kind == "append" then 2 else 1) 85 && BS.take n bytes == input 86 && (kind /= "append" || BS.drop n bytes == second) 87 else case result of Leaf -> True; _ -> False 88 unless valid (die "incorrect complete result") 89 observed <- now 90 pure (built-begin, reduced-built, observed-reduced) 91 92 main :: IO () 93 main = do 94 args <- getArgs 95 (kind,n,rounds,path) <- case args of 96 [k,n',r,p] | k `elem` ["id", "append", "deep", "distribution"] -> pure (k, read n', read r, p) 97 _ -> die "usage: haskell-reducer-smoke id|append|deep|distribution n rounds fixture" 98 unless (n > 0 && rounds > 0) (die "positive sizes required") 99 setResourceLimit ResourceCPUTime (ResourceLimits (ResourceLimit 60) (ResourceLimit 60)) 100 setResourceLimit ResourceStackSize (ResourceLimits (ResourceLimit (8*1024*1024)) (ResourceLimit (8*1024*1024))) 101 setResourceLimit ResourceCoreFileSize (ResourceLimits (ResourceLimit 0) (ResourceLimit 0)) 102 -- A bottom function must remain undemanded during application construction. 103 _ <- evaluate (suspend (error "suspend demanded function during construction") Leaf) 104 start <- now 105 worker <- if kind `elem` ["id", "append"] then load path else pure $ 106 if kind == "distribution" then Fork (Stem (Stem Leaf)) (Stem Leaf) else Leaf 107 initialized <- now 108 (buildS,reduceS,observeS,gcS,mid) <- foldM (\(!b,!r,!o,!g,!mid) roundNo -> do 109 (b',r',o') <- iteration kind n roundNo worker 110 if (roundNo+1) `mod` 16 == 0 || roundNo+1 == rounds || roundNo+1 == rounds `div` 2 then do 111 before <- now 112 performGC 113 after <- now 114 mid' <- if roundNo+1 == rounds `div` 2 then rss "VmRSS" else pure mid 115 pure (b+b', r+r', o+o', g+after-before, mid') 116 else pure (b+b', r+r', o+o', g, mid)) (0,0,0,0,-1) [0..rounds-1] 117 peak <- rss "VmHWM" 118 end <- rss "VmRSS" 119 printf "{\"host_mode\":\"GHC-O2-N1\",\"kind\":\"%s\",\"n\":%d,\"rounds\":%d,\"init_s\":%.9f,\"build_s\":%.9f,\"reduce_s\":%.9f,\"observe_s\":%.9f,\"gc_s\":%.9f,\"peak_rss_kib\":%d,\"mid_rss_kib\":%d,\"end_rss_kib\":%d}\n" 120 kind n rounds (initialized-start) buildS reduceS observeS gcS peak mid end