{-# LANGUAGE DataKinds #-}
{-# LANGUAGE CPP #-}
-- | Note that the allocation numbers are only reproducible on linux using the nix shell.
module Main where
import Html
import qualified Html.Attribute as A
import qualified Small as S
import qualified Medium as M
import qualified Big as B
import Weigh
import Control.DeepSeq
import Data.Proxy
import Data.Int
import System.IO.Temp
import GHC
import GHC.Paths (libdir)
import DynFlags
import Control.Monad
allocs :: Int64 -> Weight -> Maybe String
allocs n w
| n' > n = Just $ "More" ++ answer
| n' < n = Just $ "Less" ++ answer
| otherwise = Nothing
where n' = weightAllocatedBytes w
answer = " allocated bytes than expected: " ++ show (abs $ n' - n)
allocsError :: Int -> Int -> Int -> Weight -> Maybe String
allocsError i m n w
| n' > (m'+1) = Just $ "More" ++ answer
| n' < (m'-1) = Just $ "Less" ++ answer
| otherwise = Nothing
where n' = round (fromIntegral (weightAllocatedBytes w) / (10^i) :: Rational) :: Int
m' = n + m
answer = " allocated bytes than expected: " ++ pretty (abs $ m' - n')
pretty x = show x ++ " e" ++ show i
f :: NFData b => String -> (a -> b) -> a -> Int64 -> Weigh ()
f s g x n = validateFunc s g x (allocs n)
main :: IO ()
main = withSystemTempDirectory "compile" $ \tmp -> mainWith $ do
-- ghc version 822 843 861
f "()" renderByteString () $ ghc [ 96 ]
f "Int" renderByteString (123456789 :: Int) $ ghc [ 216 ]
f "Word" renderByteString (123456789 :: Word) $ ghc [ 216 ]
f "Char" renderByteString 'a' $ ghc [ 232 ]
f "Integer" renderByteString (123456789 :: Integer) $ ghc [ 248 ]
f "Proxy" renderByteString (Proxy :: Proxy "a") $ ghc [ 280 ]
f "oneElement Proxy" (renderByteString . S.oneElement) (Proxy :: Proxy "b") $ ghc [ 280 ]
f "oneElement ()" (renderByteString . S.oneElement) () $ ghc [ 280 ]
f "oneAttribute ()" (renderByteString . A.class_) () $ ghc [ 280 ]
f "oneAttribute Proxy" (renderByteString . A.class_) (Proxy :: Proxy "c") $ ghc [ 280 ]
f "listElement" (renderByteString . S.listElement) () $ ghc [ 392 ]
f "Double" renderByteString (123456789 :: Double) $ ghc [ 360 ]
f "oneElement" (renderByteString . S.oneElement) "" $ ghc [ 368 ]
f "nestedElement" (renderByteString . S.nestedElement) "" $ ghc [ 368 ]
f "listOfAttributes" (\x -> renderByteString [A.class_ x, A.class_ x]) () $ ghc [ 488, 0, -16 ]
f "Float" renderByteString (123456789 :: Float) $ ghc [ 400 ]
f "oneAttribute" (renderByteString . A.class_) "" $ ghc [ 408 ]
f "parallelElement" (renderByteString . S.parallelElement) "" $ ghc [ 520 ]
f "parallelAttribute" (\x -> renderByteString $ A.class_ x # A.id_ x) "" $ ghc [ 584 ]
f "elementWithAttribute" (\x -> renderByteString $ div_A (A.class_ x) x) "" $ ghc [ 584 ]
f "listOfListOf" (\x -> renderByteString $ div_ [i_ [span_ x]]) () $ ghc [ 896, 88, -8 ]
f "helloWorld" (renderByteString . M.helloWorld) () $ ghc [ 1248, 0, 16 ]
f "page" (renderByteString . M.page) () $ ghc [ 1256 ]
f "table" (renderByteString . M.table) (2,2) $ ghc [ 1920, -256, -8 ]
f "AttrShort" (renderByteString . M.attrShort) () $ ghc [ 3184, 48 ]
f "pageA" (renderByteString . M.pageA) () $ ghc [ 2536, -216 ]
f "AttrLong" (renderByteString . M.attrLong) () $ ghc [ 3184, 48, -192 ]
f "Big table" (renderByteString . M.table) (15,15) $ ghc [12904, 7064, -8 ]
f "Big page" (renderByteString . B.page) () $ ghc [25208, -248, -40 ]
let g x y z = validateAction x (compile tmp) y . allocsError 7 z $ ghc [ 104, 0, 2 ]
g "Compile Library" "Html" $ ghc [ 0 ]
g "Compile Small.hs" "Small" $ ghc [ 0 ]
g "Compile Medium.hs" "Medium" $ ghc [ 37, 0, 2 ]
g "Compile Big.hs" "Big" $ ghc [ 70, 0, 3 ]
g "Compile Alloc.hs" "bench/Alloc.hs" $ ghc [ 74, 2 ]
g "Compile Perf.hs" "bench/Perf.hs" $ ghc [ 179, 2 ]
g "Compile X0.hs" "bench/Compilation/X0.hs" $ ghc [ 4, -2 ]
g "Compile X1.hs" "bench/Compilation/X1.hs" $ ghc [ 3 ]
g "Compile X2.hs" "bench/Compilation/X2.hs" $ ghc [ 5 ]
g "Compile X4.hs" "bench/Compilation/X4.hs" $ ghc [ 7 ]
g "Compile X8.hs" "bench/Compilation/X8.hs" $ ghc [ 12 ]
g "Compile X16.hs" "bench/Compilation/X16.hs" $ ghc [ 23 ]
g "Compile X32.hs" "bench/Compilation/X32.hs" $ ghc [ 64, 0 ]
g "Compile X64.hs" "bench/Compilation/X64.hs" $ ghc [ 203, 2, -3 ]
g "Compile X128.hs" "bench/Compilation/X128.hs" $ ghc [ 711, 4, -5 ]
ghc :: Num a => [a] -> a
ghc [] = 0
ghc (x:xs) = sum $ x:[y | (y, v) <- zip xs supportedGhcs, v < __GLASGOW_HASKELL__]
where supportedGhcs = [802, 804] :: [Int]
compile :: String -> String -> IO ()
compile out m =
void . defaultErrorHandler defaultFatalMessager defaultFlushOut . runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
void $ setSessionDynFlags (dflags {optLevel = 2, importPaths = ["src", "bench"], hiDir = Just out, objectDir = Just out, outputFile = Just (out ++ "/out")})
target <- guessTarget m Nothing
setTargets [target]
load LoadAllTargets