git.iko.soy/project-m36
on 52182bc help sign in
project-m36/src/bin/benchmark/Basic.hs
106 lines 4.8 kB history raw
1import ProjectM36.Base
2import Criterion.Main
3import qualified ProjectM36.Attribute as A
4import ProjectM36.Relation
5import ProjectM36.Persist
6import ProjectM36.RelationalExpression
7import ProjectM36.Error
8import ProjectM36.Transaction.Persist
9import qualified Data.Text as T
10import qualified Data.Vector as V
11import Control.Monad.Trans.Reader
12import qualified ProjectM36.DatabaseContext as DBC
13import qualified Data.Set as S
14import Data.Monoid
15import System.IO.Temp
16import System.FilePath
17import System.Directory
19{-
20* create a relation
21* restrict a relation
22* project a relation
23* join two relations
24-}
26validate :: Either RelationalError a -> a
27validate (Left err) = error (show err)
28validate (Right x) = x
30createRelation :: Int -> Int -> Either RelationalError Relation
31createRelation attributeCount tupleCount = do
32 let attrs = A.attributesFromList $ map (\c-> Attribute (T.pack $ "a" ++ show c) IntAtomType) [0 .. attributeCount-1]
33 tuple tupleX = RelationTuple attrs (V.generate attributeCount (\_ -> IntAtom (fromIntegral tupleX)))
34 tuples = map tuple [0 .. tupleCount]
35 mkRelationDeferVerify attrs (RelationTupleSet tuples)
37createRelation' :: Int -> Int -> Relation
38createRelation' x y = validate (createRelation x y)
40restrictRelationToOneTuple :: Int -> Relation -> Relation
41restrictRelationToOneTuple match rel = validate (runReader (evalRelationalExpr restriction) exprState)
42 where
43 exprState = mkRelationalExprState DBC.empty
44 restriction = Restrict predicateMatch (ExistingRelation rel)
45 predicateMatch = AttributeEqualityPredicate "a0" (NakedAtomExpr (IntAtom match))
47restrictRelationToHalfRelation :: Int -> Relation -> Relation
48restrictRelationToHalfRelation cutoff rel = validate (runReader (evalRelationalExpr restriction) exprState)
49 where
50 exprState = mkRelationalExprState DBC.basicDatabaseContext
51 restriction = Restrict predicateMatch (ExistingRelation rel)
52 predicateMatch = AtomExprPredicate (FunctionAtomExpr "lte" [AttributeAtomExpr "a0", NakedAtomExpr (IntAtom cutoff)] ())
54projectRelationToAttributes :: AttributeNames -> Relation -> Relation
55projectRelationToAttributes attrNames rel = validate (runReader (evalRelationalExpr projection) exprState)
56 where
57 exprState = mkRelationalExprState DBC.empty
58 projection = Project attrNames (ExistingRelation rel)
60unionRelations :: Relation -> Relation -> Relation
61unionRelations relA relB = validate (relA `union` relB)
63joinRelations :: Relation -> Relation -> Relation
64joinRelations relA relB = validate (join relA relB)
66groupRelation :: AttributeNames -> Relation -> Relation
67groupRelation attrNames rel = validate (runReader (evalRelationalExpr (Group attrNames "x" (ExistingRelation rel))) exprState)
68 where
69 exprState = mkRelationalExprState DBC.empty
71bigRelAttrNames :: Int -> Int -> AttributeNames
72bigRelAttrNames start end = AttributeNames (S.fromList (map (\i -> "a" <> T.pack (show i)) [start .. end]))
74main :: IO ()
75main = do
76 tmpDir <- getCanonicalTemporaryDirectory
77 createDirectoryIfMissing False (tmpDir </> "relvars")
78 defaultMain [createRel, restrictRel, projectRel, unionRel, joinRel, groupRel, writeRel tmpDir]
79 where
80 createRel = bgroup "create" $ map (\tupCount -> bench ("relation 10x" ++ show tupCount) (nf (createRelation' 10) tupCount)) [100, 1000, 10000]
81 bigrel10000 = createRelation' 10 10000
82 bigrel1000 = createRelation' 10 1000
83 bigrel100 = createRelation' 10 100
85 restrictRel = bgroup "restrict" [restrictOneTupleRel, restrictHalfTuplesRel]
86 restrictOneTupleRel = bench "restrict relation 10x10000 to 10x1" (nf (restrictRelationToOneTuple 5000) bigrel10000)
87 restrictHalfTuplesRel = bench "restrict relation 10x10000 to 10x5000" (nf (restrictRelationToHalfRelation 5000) bigrel10000)
89 projectRel = bgroup "project" [projectOneAttr, projectHalfAttrs]
90 projectOneAttr = bench "project 10x1000 to 1x1000" (nf (projectRelationToAttributes (bigRelAttrNames 0 0)) bigrel1000)
91 projectHalfAttrs = bench "project 10x1000 to 5x1000" (nf (projectRelationToAttributes (bigRelAttrNames 0 4)) bigrel1000)
93 unionRel = bgroup "union" [unionIdenticalRelations1000, unionIdenticalRelations10000]
94 unionIdenticalRelations1000 = bench "union identical 10x1000" (nf (unionRelations bigrel1000) bigrel1000)
95 unionIdenticalRelations10000 = bench "union identical 10x10000" (nf (unionRelations bigrel10000) bigrel10000)
97 joinRel = bgroup "join" [joinIdenticalRelations100]
98 joinIdenticalRelations100 = bench "join identical 10x100" (nf (joinRelations bigrel100) bigrel100)
100 groupRel = bgroup "group" [group100]
101 group100 = bench "group 10x100" (nf (groupRelation (bigRelAttrNames 1 9)) bigrel100)
103 writeRel tmpDir = bgroup "write" [writeRel10000 tmpDir]
104 writeRel10000 tmpDir = bench "write 10x1000" $ nfIO (writeRelVar FsyncDiskSync tmpDir ("x", bigrel10000))