packed-data 0.1.0.1 → 0.1.0.2
raw patch · 48 files changed
+1839/−1526 lines, 48 filesdep +processdep +scientificdep −Chartdep −Chart-diagramsdep −timedep ~bytestringdep ~deepseqdep ~mtlnew-component:exe:examplesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: process, scientific
Dependencies removed: Chart, Chart-diagrams, time
Dependency ranges changed: bytestring, deepseq, mtl
API changes (from Hackage documentation)
+ Data.Packed.TH.Utils: getBranchTyList :: Con -> [PackingFlag] -> Q [Type]
+ Data.Packed.TH.Utils: getBranchesTyList :: Name -> [PackingFlag] -> Q [[Type]]
+ Data.Packed.TH.Utils: getConFieldsIdxAndNeedsFS :: Con -> [PackingFlag] -> [(Type, Int, Bool)]
+ Data.Packed.TH.Utils: getNameAndBangTypesFromCon :: Con -> (Name, [BangType])
+ Data.Packed.TH.Utils: getParentTypeFromConstructorType :: Type -> Type
+ Data.Packed.TH.Utils: resolveAppliedType :: Name -> Q (Type, [Name])
+ Data.Packed.TH.Utils: sanitizeConName :: Name -> String
+ Data.Packed.TH.Utils: type Tag = Word8
+ Data.Packed.TH.Utils: typeIsFieldSize :: Type -> Bool
- Data.Packed.TH: genConWrite :: [PackingFlag] -> Name -> Tag -> [BangType] -> Q [Dec]
+ Data.Packed.TH: genConWrite :: [PackingFlag] -> Con -> Tag -> Q [Dec]
- Data.Packed.TH: genStart :: [PackingFlag] -> Name -> Tag -> [Type] -> Q [Dec]
+ Data.Packed.TH: genStart :: [PackingFlag] -> Con -> Tag -> Q [Dec]
Files
- README.md +2/−3
- app/Main.hs +0/−47
- benchmark/AST.hs +0/−97
- benchmark/Build.hs +0/−46
- benchmark/CIReport.hs +0/−40
- benchmark/Increment.hs +0/−109
- benchmark/List.hs +0/−144
- benchmark/Main.hs +0/−70
- benchmark/OutputData.hs +0/−115
- benchmark/Pack.hs +0/−45
- benchmark/Plot.hs +0/−43
- benchmark/Sum.hs +0/−134
- benchmark/Traversals.hs +0/−225
- benchmark/Utils.hs +0/−41
- benchmark/benchmark.c +0/−199
- benchmark/report/Criterion.hs +78/−0
- benchmark/report/Go.hs +68/−0
- benchmark/report/Main.hs +66/−0
- benchmark/report/Types.hs +46/−0
- benchmark/tree/AST.hs +97/−0
- benchmark/tree/Build.hs +46/−0
- benchmark/tree/CIReport.hs +40/−0
- benchmark/tree/Increment.hs +113/−0
- benchmark/tree/List.hs +144/−0
- benchmark/tree/Main.hs +65/−0
- benchmark/tree/OutputData.hs +115/−0
- benchmark/tree/Pack.hs +45/−0
- benchmark/tree/Sum.hs +134/−0
- benchmark/tree/Traversals.hs +225/−0
- benchmark/tree/Utils.hs +41/−0
- benchmark/tree/benchmark.c +213/−0
- examples/Increment.hs +29/−0
- examples/Main.hs +4/−0
- examples/Pack.hs +22/−0
- examples/Traversal.hs +34/−0
- examples/Tree.hs +3/−0
- examples/Unpack.hs +15/−0
- packed-data.cabal +46/−15
- src/Data/Packed/Packed.hs +14/−3
- src/Data/Packed/TH/Case.hs +7/−17
- src/Data/Packed/TH/Read.hs +14/−19
- src/Data/Packed/TH/RepackCon.hs +12/−22
- src/Data/Packed/TH/Skip.hs +10/−22
- src/Data/Packed/TH/Start.hs +9/−23
- src/Data/Packed/TH/Transform.hs +22/−19
- src/Data/Packed/TH/Utils.hs +43/−0
- src/Data/Packed/TH/Write.hs +2/−7
- src/Data/Packed/TH/WriteCon.hs +15/−21
README.md view
@@ -1,7 +1,7 @@ # `packed-data` for Haskell -[](https://hackage.haskell.org/package/packed-data-0.1.0.0/docs/Data-Packed.html)+[](https://hackage.haskell.org/package/packed-data-0.1.0.1/docs/Data-Packed.html) Build, traverse and deserialise packed data in Haskell. @@ -55,7 +55,7 @@ Take a look at the `benchmark` directory for more examples. -Documentation is available on [Hackage](https://hackage.haskell.org/package/packed-data-0.1.0.0/docs/Data-Packed.html)+Documentation is available on [Hackage](https://hackage.haskell.org/package/packed-data-0.1.0.1/docs/Data-Packed.html) ## Benchmark @@ -69,4 +69,3 @@ stach bench --ba '--csv bench.csv sums' ``` -Note: Graphs of the benchmark results will be generated in the `graph/` directory when saving the report as CSV.
− app/Main.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Main (main) where--import Control.DeepSeq-import Data.Fixed-import Data.Int-import Data.Packed-import qualified Data.Packed.Reader as R-import Data.Time.Clock-import Text.Printf--data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)--$(mkPacked ''Tree1 [])--sumPacked :: PackedReader '[Tree1 Int64] r Int64-sumPacked =- caseTree1- ( R.do- !n <- reader- R.return n- )- ( R.do- !left <- sumPacked- !right <- sumPacked- let !res = left + right- R.return res- )--buildNativeTree :: Int64 -> Tree1 Int64-buildNativeTree 0 = Leaf1 1-buildNativeTree n = Node1 subTree subTree- where- subTree = buildNativeTree (n - 1)--main :: IO ()-main = do- let packed = pack $! buildNativeTree 15- _ <- fromPacked packed `deepseq` return ()- startTime <- getCurrentTime- (!s, !_) <- R.runReader sumPacked packed- endTime <- s `seq` getCurrentTime- printf- "Sum: %d. Total execution time: %ss.\n"- s- (showFixed True $ nominalDiffTimeToSeconds $ diffUTCTime endTime startTime)
− benchmark/AST.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE TemplateHaskell #-}--module AST (benchmark) where--import Criterion.Main-import Data.ByteString.Internal-import Data.Packed-import qualified Data.Packed.Reader as R-import Data.Void-import Foreign-import Foreign.C-import Foreign.ForeignPtr.Unsafe-import Utils-import Prelude hiding (sum)--foreign import capi unsafe "benchmark.h eval" c_eval :: Ptr Void -> IO CLong--foreign import capi unsafe "benchmark.h build_ast" c_build_ast :: CInt -> IO (Ptr Void)--foreign import capi unsafe "benchmark.h free_ast" c_free_ast :: Ptr Void -> IO ()--data AST = Value Int32 | Add AST AST | Sub AST AST | Mul AST AST--$(mkPacked ''AST [])--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "ast"- $ fmap buildAndEvaluateASTWithDepth depths--buildAndEvaluateASTWithDepth :: Int -> Benchmark-buildAndEvaluateASTWithDepth n =- bgroup- (depthGroupName n)- [ envWithCleanup (c_build_ast $ fromIntegral n) c_free_ast $ bench cTestName . nfAppIO c_eval- , bench nativeTestName $ nf eval nativeAST- , bench packedTestName $ nfAppIO (runReader evalPacked) packedAST- , bench packedWithUnpackTestName $ whnf (eval . fst . unpack) packedAST- , bench nonMonadicPackedTestName $ nfAppIO evalPackedNonMonadic packedAST- ]- where- !packedAST = pack nativeAST- !nativeAST = buildNativeAST n--eval :: AST -> Int32-eval (Value n) = n-eval (Add a b) = eval a + eval b-eval (Sub a b) = eval a - eval b-eval (Mul a b) = eval a * eval b--evalPacked :: PackedReader '[AST] r Int32-evalPacked =- caseAST- reader- (opLambda (+))- (opLambda (-))- (opLambda (*))- where- {-# INLINE opLambda #-}- opLambda ::- (Int32 -> Int32 -> Int32) ->- PackedReader '[AST, AST] r Int32- opLambda f = R.do- left <- evalPacked- right <- evalPacked- R.return (f left right)--evalPackedNonMonadic :: Packed (AST ': r) -> IO Int-evalPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Int, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- let !nextPtr = ptr `plusPtr` 1- case tag of- 0 -> do- !n <- peek nextPtr :: IO Int32- return (fromIntegral n, plusPtr nextPtr (sizeOf n))- 1 -> opLambda (+) nextPtr- 2 -> opLambda (-) nextPtr- 3 -> opLambda (*) nextPtr- _ -> undefined- {-# INLINE opLambda #-}- opLambda :: (Int -> Int -> Int) -> Ptr Int32 -> IO (Int, Ptr Word8)- opLambda f ptr = do- (!left, !r) <- go $ castPtr ptr- (!right, !r1) <- go r- let !res = left `f` right- return (res, r1)--buildNativeAST :: Int -> AST-buildNativeAST 0 = Value 1-buildNativeAST n = Add (buildNativeAST (n - 1)) (buildNativeAST (n - 1))
− benchmark/Build.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-orphans #-}--module Build (benchmark) where--import Control.DeepSeq-import Criterion.Main-import Data.Packed-import Data.Packed.Needs-import qualified Data.Packed.Needs as N-import Utils-import Prelude hiding (sum)--data Tree1 a = Leaf1 a | Node1 !(Tree1 a) !(Tree1 a)--$(mkPacked ''Tree1 [])--instance NFData (Tree1 a) where- rnf (Leaf1 a) = a `seq` ()- rnf (Node1 l r) = l `seq` r `seq` ()--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "build"- $ fmap buildTreeWithDepth depths--buildTreeWithDepth :: Int -> Benchmark-buildTreeWithDepth n =- bgroup- (depthGroupName n)- [ bench nativeTestName $ nf buildNativeTree n- , bench packedTestName $ nf (\p -> finish (buildPackedTree p)) n- ]--buildNativeTree :: Int -> Tree1 Int-buildNativeTree 0 = Leaf1 1-buildNativeTree n = Node1 subTree subTree- where- subTree = buildNativeTree (n - 1)--buildPackedTree :: Int -> Needs '[] '[Tree1 Int]-buildPackedTree 0 = withEmptyNeeds (writeConLeaf1 (1 :: Int))-buildPackedTree n = withEmptyNeeds (startNode1 N.>> applyNeeds subTree N.>> applyNeeds subTree)- where- !subTree = buildPackedTree (n - 1)
− benchmark/CIReport.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module CIReport (generateCIReport) where--import Data.Aeson-import GHC.Generics-import OutputData (BenchmarkResult (BenchmarkResult), BenchmarkValue (meanExecutionTime), mode, readBenchmarkResults)-import Text.Printf-import Utils (nativeTestName)--data ReportEntry = ReportEntry- { name :: String- , unit :: String- , value :: Double- }- deriving (Generic, Show)--instance ToJSON ReportEntry--generateCIReport :: FilePath -> IO ()-generateCIReport csvPath = do- let reportPath = "benchmark-report.json"- benRes <- readBenchmarkResults csvPath- let reportEntries = concatMap toReportEntries benRes- encodeFile reportPath reportEntries--toReportEntries :: BenchmarkResult -> [ReportEntry]-toReportEntries (BenchmarkResult benName values) =- concatMap- ( \(depth, depthValues) ->- ( \depthVal ->- ReportEntry- { name = printf "%s/%d (%s)" benName depth (show $ mode depthVal)- , unit = "seconds"- , value = meanExecutionTime depthVal- }- )- <$> filter (\v -> show (mode v) /= nativeTestName) depthValues- )- values
− benchmark/Increment.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CApiFFI #-}-{-# LANGUAGE DeriveGeneric #-}--module Increment (benchmark) where--import Control.DeepSeq-import Control.Monad-import Criterion.Main-import Data.List (intercalate)-import Data.Packed-import Data.Packed.Needs (applyNeeds)-import qualified Data.Packed.Needs as N-import qualified Data.Packed.Reader as R-import Data.Void-import Foreign-import Foreign.C-import GHC.Generics (Generic, Generic1)-import Utils-import Prelude hiding (concat)--foreign import capi unsafe "benchmark.h increment" c_increment :: Ptr Void -> IO ()--foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)--foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()-data Tree1 a = Leaf1 !a | Node1 !(Tree1 a) !(Tree1 a) deriving (Generic, Generic1)--instance (NFData a) => NFData (Tree1 a)-instance NFData1 Tree1--$(mkPacked ''Tree1 [])--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "increment"- $ fmap computeTreeSumWithDepth depths--computeTreeSumWithDepth :: Int -> Benchmark-computeTreeSumWithDepth n =- bgroup- (depthGroupName n)- [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $- bench cTestName . nfAppIO c_increment- , bench nativeTestName $- nf increment nativeTree- , bench (intercalate "-" [packedTestName, "needsbuilder"]) $- nfAppIO incrementPackedRunner packedTree- , bench (intercalate "-" ["unpack", "repack"]) $- nf (pack . increment . fst . unpack) packedTree- , bench (intercalate "-" [packedTestName, "rebuild-repack"]) $- nfAppIO repackingIncrementPackedRunner packedTree- ]- where- !packedTree = pack nativeTree- !nativeTree = buildNativeTree n--increment :: Tree1 Int -> Tree1 Int-increment (Leaf1 n) = let !res = n + 1 in Leaf1 res-increment (Node1 t1 t2) = Node1 res1 res2- where- !res1 = increment t1- !res2 = increment t2---- Produces an needsbuilder for a tree alread incremented, and finishes it-incrementPackedRunner :: Packed '[Tree1 Int] -> IO (Packed '[Tree1 Int])-incrementPackedRunner packed = do- (!needs, _) <- runReader incrementPacked packed- return $ finish needs--incrementPacked :: PackedReader '[Tree1 Int] r (Needs '[] '[Tree1 Int])-incrementPacked =- transformTree1- ( R.do- n <- reader- R.return (write (n + 1))- )- ( R.do- left <- incrementPacked- right <- incrementPacked- R.return (applyNeeds left N.>> applyNeeds right)- )--buildNativeTree :: Int -> Tree1 Int-buildNativeTree 0 = Leaf1 1-buildNativeTree n = Node1 subTree subTree- where- !subTree = buildNativeTree (n - 1)---- Produces an unpacked tree alread incremented, and packs it-repackingIncrementPackedRunner :: Packed '[Tree1 Int] -> IO (Packed '[Tree1 Int])-repackingIncrementPackedRunner packed = do- (!tree, _) <- runReader repackingIncrementPacked packed- let !repacked = pack tree- return repacked--repackingIncrementPacked :: PackedReader '[Tree1 Int] r (Tree1 Int)-repackingIncrementPacked =- caseTree1- ( R.do- n <- reader- R.return (Leaf1 (n + 1))- )- ( R.do- !left <- repackingIncrementPacked- !right <- repackingIncrementPacked- R.return (Node1 left right)- )
− benchmark/List.hs
@@ -1,144 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TemplateHaskell #-}--module List (benchmark) where--import Control.DeepSeq-import Criterion.Main-import qualified Data.ByteString.Internal as BS-import Data.Packed-import Data.Packed.Needs (Needs (Needs))-import qualified Data.Packed.Needs as N-import qualified Data.Packed.Reader as R-import Foreign-import Utils-import Prelude hiding (sum)--data Tree1 a = Leaf1 | Node1 (Tree1 a) a (Tree1 a)--instance NFData (Tree1 a) where- rnf Leaf1 = ()- rnf (Node1 l n r) = n `seq` l `seq` r `seq` ()--$(mkPacked ''Tree1 [InsertFieldSize])--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "list"- []---- bgroup--- "from-list"--- $ fmap buildTreeFromListWithLength depths--- , bgroup--- "to-list"--- $ fmap treeToListWithLength depths---- buildTreeFromListWithLength :: Int -> Benchmark--- buildTreeFromListWithLength n =--- bgroup--- (depthGroupName n)--- [ bench nativeTestName $ nf buildTreeFromList list--- , bench packedTestName $ nfAppIO buildPackedTreeFromList list--- ]--- where--- list = buildUnorderedList n---- treeToListWithLength :: Int -> Benchmark--- treeToListWithLength n =--- bgroup--- (depthGroupName n)--- [ bench nativeTestName $ nf treeToList (buildTreeFromList list)--- , env (buildPackedTreeFromList list) $--- bench packedTestName--- . nfAppIO--- (runReader packedTreeToList)--- ]--- where--- list = buildUnorderedList n--buildTreeFromList :: [Int] -> Tree1 Int-buildTreeFromList = foldl (flip insertInTree) Leaf1- where- insertInTree n Leaf1 = Node1 Leaf1 n Leaf1- insertInTree n (Node1 l n' r) =- if n > n'- then Node1 l n' (insertInTree n r)- else Node1 (insertInTree n l) n' r--treeToList :: Tree1 Int -> [Int]-treeToList t = go t []- where- go Leaf1 r = r- go (Node1 l n r) list = go l (n : go r list)--packedTreeToList :: PackedReader '[Tree1 Int] '[] [Int]-packedTreeToList = go []- where- go :: [Int] -> PackedReader '[Tree1 Int] r [Int]- go l =- caseTree1- (R.return l)- ( R.do- packedLeft <- isolate- n <- readerWithFieldSize- packedRight <- isolate- rightList <- R.lift (go l) packedRight- R.lift (go $ n : rightList) packedLeft- )------- buildPackedTreeFromList :: [Int] -> IO (Packed '[Tree1 Int])--- buildPackedTreeFromList l =--- finish--- =<< withEmptyNeeds--- =<< foldl--- ( \builder i -> R.do--- n <- insertInPackedTree i--- R.return (builder N.>> n)--- )--- (write Leaf1)--- l--- where--- packedToNeeds :: Packed a -> Needs '[] a--- packedToNeeds p = let (BS.BS fptr l) = fromPacked p in Needs fptr l l--- insertInPackedTree ::--- Int ->--- PackedReader '[Tree1 Int] '[] (N.NeedsBuilder '[] '[Tree1 Int] '[] '[Tree1 Int])--- insertInPackedTree n =--- caseTree1--- ( mkPackedReader--- ( \p l -> do--- let n =--- ( N.do--- startNode1--- writeWithFieldSize Leaf1--- writeWithFieldSize 0--- writeWithFieldSize Leaf1--- )--- return (n, p, l)--- )--- )--- ( R.do--- !left <- isolate--- !n' <- readerWithFieldSize--- !right <- isolate--- let !needLeft = packedToNeeds left--- let !needRight = packedToNeeds right--- needsN' <- mkPackedReader (\p l -> (,p,l) <$> withEmptyNeeds (write n'))--- if n > n'--- then R.do--- right' <- R.lift (insertInPackedTree n) right--- R.return (repackNode1 needLeft needsN' right')--- else R.do--- left' <- R.lift (insertInPackedTree n) left--- R.return (repackNode1 left' needsN' needRight)--- )----buildUnorderedList :: Int -> [Int]-buildUnorderedList n = intercalate [(n `div` 2) .. n] [0 .. (n `div` 2) - 1]- where- intercalate a [] = a- intercalate [] b = b- intercalate (a : b) (c : d) = a : c : intercalate b d
− benchmark/Main.hs
@@ -1,70 +0,0 @@-module Main (main) where--import qualified AST-import qualified Build-import CIReport-import Control.Monad (when)-import Criterion.Main-import Criterion.Main.Options (Mode (..), describe)-import Criterion.Types (Config (..))-import Data.Maybe (isJust, isNothing)-import qualified Increment-import qualified List-import Options.Applicative (execParser)-import qualified Pack-import Plot-import qualified Sum-import System.Directory-import qualified Traversals--main :: IO ()-main = do- mode <- execParser (describe defaultConfig)- when (isNothing (csvPath mode) && modeExportOtherThanCsv mode) $ do- putStrLn "Warning: Graphs will not be generated."- putStrLn "Warning: Report for CI will not be generated."- putStrLn "Warning: Use the CSV export function to generate graphs and CI report."- -- Criterion seems to append the result to the file if it already exists- -- Therefore, it adds a new header. Cassava does not like this.- _ <- case csvPath mode of- Just p -> do- exists <- doesFileExist p- when exists (removeFile p)- _ -> return ()- runMode mode benchmarks- case csvPath mode of- Nothing -> return ()- Just exportPath -> do- putStrLn "Generating graph..."- generateGraphs exportPath- putStrLn "Generation finished."- putStrLn "Generating CI report..."- generateCIReport exportPath- putStrLn "Generation CI report."- where- depths = [1, 5, 10, 15, 20]- benchmarks =- [ Traversals.benchmark depths- , Pack.benchmark depths- , Increment.benchmark depths- , Sum.benchmark depths- , AST.benchmark depths- , Build.benchmark depths- , List.benchmark depths- ]- csvPath (RunIters cfg _ _ _) = csvPathFromCfg cfg- csvPath (Run cfg _ _) = csvPathFromCfg cfg- csvPath _ = Nothing- csvPathFromCfg = csvFile- modeExportOtherThanCsv (RunIters cfg _ _ _) = cfgExportOtherThanCsv cfg- modeExportOtherThanCsv (Run cfg _ _) = cfgExportOtherThanCsv cfg- modeExportOtherThanCsv _ = False- cfgExportOtherThanCsv cfg =- any- isJust- $ ($ cfg)- <$> [ junitFile- , jsonFile- , reportFile- , rawDataFile- ]
− benchmark/OutputData.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}--module OutputData (- RawCSVEntry (..),- BenchmarkMode (..),- BenchmarkResult (..),- BenchmarkValue (..),- readBenchmarkResults,- genFail,-) where--import qualified Data.ByteString.Lazy as BS-import Data.Char (isDigit)-import Data.Csv-import qualified Data.List.Safe as Safe-import Data.List.Split (splitOn)-import Data.Vector (toList)-import System.Exit-import Text.Read--data RawCSVEntry = RawCSVEntry- { _name :: String- , _mean :: Double- }-instance FromNamedRecord RawCSVEntry where- parseNamedRecord m = RawCSVEntry <$> m .: "Name" <*> m .: "Mean"--newtype BenchmarkMode = BenchmarkMode String deriving (Eq)--instance Show BenchmarkMode where- show (BenchmarkMode s) = s--instance Read BenchmarkMode where- readsPrec _ s = [(BenchmarkMode s, "")]---- | Processed data-data BenchmarkResult = BenchmarkResult- { name :: String- -- ^ Example: Build- , values :: [(Int, [BenchmarkValue])]- -- ^ Maps benchmark values with the depths of the related tree.- }- deriving (Show)--data BenchmarkValue = BenchmarkValue- { mode :: BenchmarkMode- , meanExecutionTime :: Double- }- deriving (Show)--readBenchmarkResults :: FilePath -> IO [BenchmarkResult]-readBenchmarkResults csvPath = do- rawFile <- BS.readFile csvPath- rawCSVEntries <-- either- genFail- (return . toList . snd)- (decodeByName rawFile)- processedCSVEntries <-- either- genFail- return- (processCSVEntries rawCSVEntries)- return processedCSVEntries--processCSVEntries :: [RawCSVEntry] -> Either String [BenchmarkResult]-processCSVEntries rawEntries = do- entries <-- mapM- (maybe (Left "Error when processing entry") Right . processCSVEntry)- rawEntries- return $ foldr mergeBenchmarkEntries [] entries--processCSVEntry :: RawCSVEntry -> Maybe BenchmarkResult-processCSVEntry (RawCSVEntry rawname mean) = do- let splitEntryName = splitOn "/" rawname- benchName <- splitEntryName Safe.!! (length splitEntryName - 3 :: Int)- benchMode <- readMaybe =<< Safe.last splitEntryName- depth <- do- rawDepth <- splitEntryName Safe.!! (length splitEntryName - 2)- readMaybe $ takeWhile isDigit rawDepth- let benchValue =- BenchmarkValue- { mode = benchMode- , meanExecutionTime = mean- }- return $- BenchmarkResult- { name = benchName- , values = [(depth, [benchValue])]- }--mergeBenchmarkEntries :: BenchmarkResult -> [BenchmarkResult] -> [BenchmarkResult]-mergeBenchmarkEntries benRes [] = [benRes]-mergeBenchmarkEntries benRes (mergedRes : mergedRest) =- let benValue = head $ snd $ head (values benRes)- depth = fst $ head (values benRes)- in if name benRes == name mergedRes- then mergedRes{values = mergeBenchmarkValues depth benValue (values mergedRes)} : mergedRest- else mergedRes : mergeBenchmarkEntries benRes mergedRest- where- mergeBenchmarkValues :: Int -> BenchmarkValue -> [(Int, [BenchmarkValue])] -> [(Int, [BenchmarkValue])]- mergeBenchmarkValues depth val [] = [(depth, [val])]- mergeBenchmarkValues valDepth val ((depth, vals) : b) =- if valDepth == depth- then (depth, val : vals) : b- else (depth, vals) : mergeBenchmarkValues valDepth val b---- | Prints error message, and exits-genFail :: (Show a) => a -> IO b-genFail msg = do- putStrLn "An error occured while generating graphs:"- print msg- exitFailure
− benchmark/Pack.hs
@@ -1,45 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--module Pack (benchmark) where--import Control.DeepSeq-import Criterion.Main-import Data.Packed-import Utils-import Prelude hiding (sum)--data Tree1 a = Leaf1 a | Node1 !(Tree1 a) !(Tree1 a)-data Tree2 a = Leaf2 a | Node2 !(Tree2 a) !(Tree2 a)--$(mkPacked ''Tree1 [])-$(mkPacked ''Tree2 [])--instance NFData (Tree1 a) where- rnf (Leaf1 a) = a `seq` ()- rnf (Node1 l r) = l `seq` r `seq` ()--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "pack"- $ fmap buildTreeWithDepth depths--buildTreeWithDepth :: Int -> Benchmark-buildTreeWithDepth n =- bgroup- (depthGroupName n)- [ bench packedTestName $ nf Data.Packed.pack (buildNativeTree n)- , bench packedWithFieldSizeTestName $ nf Data.Packed.pack (buildNativeTree2 n)- ]--buildNativeTree :: Int -> Tree1 Int-buildNativeTree 0 = Leaf1 1-buildNativeTree n = Node1 subTree subTree- where- subTree = buildNativeTree (n - 1)--buildNativeTree2 :: Int -> Tree2 Int-buildNativeTree2 0 = Leaf2 1-buildNativeTree2 n = Node2 subTree subTree- where- subTree = buildNativeTree2 (n - 1)
− benchmark/Plot.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}--module Plot (generateGraphs) where--import Control.Monad-import Data.List (nub)-import Graphics.Rendering.Chart.Backend.Diagrams-import Graphics.Rendering.Chart.Easy-import OutputData-import System.Directory (createDirectory, doesDirectoryExist)-import Text.Printf---- | Generates and saves graphs using CSV exported by Criterion-generateGraphs :: FilePath -> IO ()-generateGraphs csvPath = do- let outDir = "graphs"- processedCSVEntries <- readBenchmarkResults csvPath- outdirExists <- doesDirectoryExist outDir- unless outdirExists $ createDirectory outDir- forM_ processedCSVEntries (generateGraph outDir)--generateGraph :: FilePath -> BenchmarkResult -> IO ()-generateGraph outDir benRes = do- -- TODO: Make this work in windows- let outFile = printf "%s/%s.svg" outDir (name benRes)- toFile def outFile $ do- layout_title .= name benRes- layout_x_axis . laxis_title .= "Depth of tree"- layout_y_axis . laxis_title .= "Execution Time"- forM_ benchTypes $ \m ->- plot- ( line- (show m)- [ [ (depth, meanExecutionTime val)- | (depth, vals) <- values benRes- , val <- vals- , mode val == m- ]- ]- )- where- benchTypes = nub $ mode <$> concatMap snd (values benRes)
− benchmark/Sum.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CApiFFI #-}--module Sum (benchmark) where--import Criterion.Main-import Data.ByteString.Internal-import Data.Packed-import qualified Data.Packed.Reader as R-import Data.Void (Void)-import Foreign-import Foreign.C-import Foreign.ForeignPtr.Unsafe-import GHC.IO-import Utils-import Prelude hiding (sum)--foreign import capi unsafe "benchmark.h sum" c_sum :: Ptr Void -> IO CLong--foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)--foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()--data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)-data Tree2 a = Leaf2 a | Node2 (Tree2 a) (Tree2 a)--$(mkPacked ''Tree1 [])-$(mkPacked ''Tree2 [InsertFieldSize])--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "sum"- $ fmap computeTreeSumWithDepth depths--computeTreeSumWithDepth :: Int -> Benchmark-computeTreeSumWithDepth n =- bgroup- (depthGroupName n)- [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $ bench cTestName . nfAppIO c_sum- , bench nativeTestName $ nf sum nativeTree- , bench packedTestName $ whnfAppIO (R.runReader sumPacked) packedTree- , bench packedWithUnpackTestName $ whnf (sum . fst . unpack) packedTree- , bench packedWithFieldSizeTestName $ whnfAppIO (R.runReader sumPacked2) packedTree2- , bench nonMonadicPackedTestName $ nfAppIO sumPackedNonMonadic packedTree- , bench nonMonadicPackedWithSizeTestName $ nfAppIO sumPackedNonMonadic2 packedTree2- ]- where- !packedTree = pack nativeTree- !packedTree2 = pack (buildNativeTree2 n)- !nativeTree = buildNativeTree n--sum :: Tree1 Int -> Int-sum (Leaf1 n) = n-sum (Node1 t1 t2) = sum t1 + sum t2--sumPacked :: PackedReader '[Tree1 Int] r Int-sumPacked =- caseTree1- ( R.do- !n <- reader- R.return n- )- ( R.do- !left <- sumPacked- !right <- sumPacked- let !res = left + right- R.return res- )--sumPacked2 :: PackedReader '[Tree2 Int] r Int-sumPacked2 =- caseTree2- ( R.do- !n <- readerWithFieldSize- R.return n- )- ( R.do- !left <- skip R.>> sumPacked2- !right <- skip R.>> sumPacked2- let !res = left + right- R.return res- )-sumPackedNonMonadic :: Packed (Tree1 Int ': r) -> IO Int-sumPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Int, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- let !nextPtr = ptr `plusPtr` 1- case tag of- 0 -> do- !n <- peek nextPtr- let !nextPtr1 = ptr `plusPtr` 9- return (n, nextPtr1)- 1 -> do- (!left, !r) <- go (castPtr nextPtr)- (!right, !r1) <- go r- let !res = left + right- return (res, r1)- _ -> undefined--sumPackedNonMonadic2 :: Packed (Tree2 Int ': r) -> IO Int-sumPackedNonMonadic2 packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- sizeOfFieldSize = sizeOf (1 :: Int32)- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Int, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- let !nextPtr = ptr `plusPtr` 1- case tag of- 0 -> do- !n <- peek (nextPtr `plusPtr` sizeOfFieldSize)- let !nextPtr1 = ptr `plusPtr` 9 `plusPtr` sizeOfFieldSize- return (n, nextPtr1)- 1 -> do- (!left, !r) <- go (castPtr $ nextPtr `plusPtr` sizeOfFieldSize)- (!right, !r1) <- go (r `plusPtr` sizeOfFieldSize)- let !res = left + right- return (res, r1)- _ -> undefined-buildNativeTree :: Int -> Tree1 Int-buildNativeTree 0 = Leaf1 1-buildNativeTree n = Node1 subTree subTree- where- subTree = buildNativeTree (n - 1)--buildNativeTree2 :: Int -> Tree2 Int-buildNativeTree2 0 = Leaf2 1-buildNativeTree2 n = Node2 subTree subTree- where- subTree = buildNativeTree2 (n - 1)
− benchmark/Traversals.hs
@@ -1,225 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CApiFFI #-}--module Traversals (benchmark) where--import Criterion.Main-import Data.ByteString.Internal-import Data.Packed-import qualified Data.Packed.Reader as R-import Data.Void-import Foreign-import Foreign.C-import Foreign.ForeignPtr.Unsafe-import Utils--foreign import capi unsafe "benchmark.h get_right_most" c_get_right_most :: Ptr Void -> IO CLong--foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)--foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()--data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)-data Tree2 a = Leaf2 a | Node2 (Tree2 a) (Tree2 a)--$(mkPacked ''Tree1 [])-$(mkPacked ''Tree2 [InsertFieldSize])--benchmark :: [Int] -> Benchmark-benchmark depths =- bgroup- "traversals"- [ bgroup- "right-most-node"- $ fmap compareGettingRightMostNode depths- , bgroup- "contains"- $ fmap compareContainsValue depths- ]--compareGettingRightMostNode :: Int -> Benchmark-compareGettingRightMostNode n =- bgroup- (depthGroupName n)- [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $ bench cTestName . nfAppIO c_get_right_most- , bench nativeTestName $ nf getRightMostNodeNative nativeTree- , bench packedTestName $ nfAppIO (runReader getRightMostNodePacked) packedTree- , bench packedWithUnpackTestName $ whnf (getRightMostNodeNative . fst . unpack) packedTree- , bench nonMonadicPackedTestName $ nfAppIO getRightMostNodePackedNonMonadic packedTree- , bench packedWithFieldSizeTestName $- nfAppIO (runReader getRightMostNodePacked2) packedTreeWithSize- , bench nonMonadicPackedWithSizeTestName $ nfAppIO getRightMostNodePacked2NonMonadic packedTreeWithSize- ]- where- packedTree = pack nativeTree- packedTreeWithSize = pack (tree1ToTree2 nativeTree)- tree1ToTree2 (Leaf1 l) = Leaf2 l- tree1ToTree2 (Node1 a b) = Node2 (tree1ToTree2 a) (tree1ToTree2 b)- nativeTree = buildNativeTree n--getRightMostNodeNative :: Tree1 Int -> Int-getRightMostNodeNative (Leaf1 n) = n-getRightMostNodeNative (Node1 _ r) = getRightMostNodeNative r--getRightMostNodePacked :: PackedReader '[Tree1 Int] r Int-getRightMostNodePacked =- caseTree1- reader- (skip R.>> getRightMostNodePacked)--getRightMostNodePackedNonMonadic :: Packed (Tree1 Int ': r) -> IO Int-getRightMostNodePackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Int, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- case tag of- 0 -> do- !n <- peek (plusPtr ptr 1)- return (n, plusPtr ptr 9)- 1 -> do- (!_, !r) <- go (plusPtr ptr 1)- (!right, !r1) <- go r- return (right, r1)- _ -> undefined--getRightMostNodePacked2 :: PackedReader '[Tree2 Int] '[] Int-getRightMostNodePacked2 =- caseTree2- readerWithFieldSize- ( R.do- skipWithFieldSize- skip R.>> getRightMostNodePacked2- )--getRightMostNodePacked2NonMonadic :: Packed (Tree2 Int ': r) -> IO Int-getRightMostNodePacked2NonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- sizeOfFieldSize = sizeOf (1 :: Int32)- sizeOfInt = sizeOf (1 :: Int)- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Int, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- let nextPtr = ptr `plusPtr` 1- case tag of- 0 -> do- !n <- peek (plusPtr nextPtr sizeOfFieldSize)- let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + sizeOfInt)- return (n, nextPtr1)- 1 -> do- !fieldSize <- peek (castPtr nextPtr :: Ptr Int32)- let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + fromIntegral fieldSize) `plusPtr` sizeOfFieldSize- (!right, !r1) <- go nextPtr1- return (right, r1)- _ -> undefined--buildNativeTree :: Int -> Tree1 Int-buildNativeTree 0 = Leaf1 0-buildNativeTree n = Node1 subTree subTree- where- subTree = buildNativeTree (n - 1)---- Contains--compareContainsValue :: Int -> Benchmark-compareContainsValue n =- bgroup- (depthGroupName n)- [ bench nativeTestName $ nf (containsNative value) nativeTree- , bench packedTestName $ nfAppIO (runReader (containsPacked value)) packedTree- , bench nonMonadicPackedTestName $ nfAppIO (containsNonMonadic value) packedTree- , bench packedWithFieldSizeTestName $- nfAppIO (runReader (containsPacked2 value)) packedTreeWithSize- , bench nonMonadicPackedWithSizeTestName $ nfAppIO (containsNonMonadic2 value) packedTreeWithSize- ]- where- packedTree = pack nativeTree- packedTreeWithSize = pack (tree1ToTree2 nativeTree)- tree1ToTree2 (Leaf1 l) = Leaf2 l- tree1ToTree2 (Node1 a b) = Node2 (tree1ToTree2 a) (tree1ToTree2 b)- nativeTree = buildNativeTreeContains n value- value = 500--containsNative :: Int -> Tree1 Int -> Bool-containsNative value (Leaf1 n) = n == value-containsNative value (Node1 s1 s2) = containsNative value s1 || containsNative value s2--containsPacked :: Int -> PackedReader '[Tree1 Int] r Bool-containsPacked n =- caseTree1- ( R.do- i <- reader- R.return (i == n)- )- ( R.do- s1 <- containsPacked n- if s1 then skip R.>> R.return s1 else containsPacked n- )--containsPacked2 :: Int -> PackedReader '[Tree2 Int] r Bool-containsPacked2 n =- caseTree2- ( R.do- i <- readerWithFieldSize- R.return (i == n)- )- ( R.do- s1 <- skip R.>> containsPacked2 n- if s1 then skipWithFieldSize R.>> R.return s1 else skip R.>> containsPacked2 n- )--containsNonMonadic :: Int -> Packed (Tree1 Int ': r) -> IO Bool-containsNonMonadic n packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Bool, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- case tag of- 0 -> do- !i <- peek (plusPtr ptr 1)- return (i == n, plusPtr ptr 9)- 1 -> do- (!b, !r) <- go (plusPtr ptr 1)- if b- then do- (!_, !r1) <- go r- return (True, r1)- else do- (!right, !r1) <- go r- return (right, r1)- _ -> undefined--containsNonMonadic2 :: Int -> Packed (Tree2 Int ': r) -> IO Bool-containsNonMonadic2 n packed = fst <$> go (unsafeForeignPtrToPtr fptr)- where- sizeOfFieldSize = sizeOf (1 :: Int32)- sizeOfInt = sizeOf (1 :: Int)- (BS fptr _) = fromPacked packed- go :: Ptr Word8 -> IO (Bool, Ptr Word8)- go ptr = do- tag <- peek ptr :: IO Word8- let nextPtr = ptr `plusPtr` 1- case tag of- 0 -> do- !i <- peek (plusPtr nextPtr sizeOfFieldSize)- let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + sizeOfInt)- return (i == n, nextPtr1)- 1 -> do- let subTree1Ptr = nextPtr `plusPtr` sizeOfFieldSize- (!b, !nextPtr1) <- go subTree1Ptr- if b- then do- !fieldSize <- peek (castPtr nextPtr1 :: Ptr Int32)- return (True, castPtr $ nextPtr1 `plusPtr` (sizeOfFieldSize + fromIntegral fieldSize))- else go (nextPtr1 `plusPtr` sizeOfFieldSize)- _ -> undefined--buildNativeTreeContains :: Int -> Int -> Tree1 Int-buildNativeTreeContains 0 _ = Leaf1 0-buildNativeTreeContains 1 n = Node1 (Leaf1 n) (buildNativeTreeContains 0 n)-buildNativeTreeContains depth n = Node1 subTree subTree- where- subTree = buildNativeTreeContains (depth - 1) n
− benchmark/Utils.hs
@@ -1,41 +0,0 @@-module Utils (- toRight,- cTestName,- nativeTestName,- packedTestName,- packedWithUnpackTestName,- nonMonadicPackedTestName,- packedWithFieldSizeTestName,- nonMonadicPackedWithSizeTestName,- depthGroupName,-) where--import Text.Printf--toRight :: Either b a -> a-toRight (Right a) = a-toRight _ = error "unexpected left"--cTestName :: String-cTestName = "c"--nativeTestName :: String-nativeTestName = "native"--packedTestName :: String-packedTestName = "packed"--packedWithUnpackTestName :: String-packedWithUnpackTestName = "packed-unpacked"--nonMonadicPackedTestName :: String-nonMonadicPackedTestName = "non-monadic-" ++ packedTestName--packedWithFieldSizeTestName :: String-packedWithFieldSizeTestName = "packed-with-size"--nonMonadicPackedWithSizeTestName :: String-nonMonadicPackedWithSizeTestName = "non-monadic-" ++ packedWithFieldSizeTestName--depthGroupName :: Int -> String-depthGroupName = printf "%02d-depth"
− benchmark/benchmark.c
@@ -1,199 +0,0 @@--#include "benchmark.h"-#include <assert.h>-#include <math.h>-#include <stdio.h>-#include <stdlib.h>-#include <string.h>-#include <time.h>--// static long get_nanos(void) {-// struct timespec ts;-// timespec_get(&ts, TIME_UTC);-// return (long)ts.tv_sec * 1000000000L + ts.tv_nsec;-// }--//// AST--long eval(struct AST *t) {- long left;- long right;- switch (t->tag) {- case VAL:- return t->value;- case ADD:- left = eval(t->left);- right = eval(t->right);- return left + right;- case SUB:- left = eval(t->left);- right = eval(t->right);- return left - right;- case MUL:- left = eval(t->left);- right = eval(t->right);- return left * right;- case DIV:- left = eval(t->left);- right = eval(t->right);- return left / right;- }-}--struct AST *build_ast(int size) {- struct AST *t = malloc(sizeof(struct AST));-- if (size <= 0) {- t->tag = VAL;- t->value = 1;- } else {- t->tag = ADD;- t->left = build_ast(size - 1);- t->right = build_ast(size - 1);- }-- return t;-}--void free_ast(struct AST *t) {-- if (t->tag != VAL) {- free_ast(t->left);- free_ast(t->right);- }- free(t);-}--/// Tree-long sum(struct Tree *t) {- if (t->tag == LEAF) {- return t->value;- } else {- return sum(t->left) + sum(t->right);- }-}--long get_right_most(struct Tree *t) {- if (t->tag == LEAF) {- return t->value;- } else {- return get_right_most(t->right);- }-}--void increment(struct Tree *t) {- if (t->tag == LEAF) {- t->value++;- } else {- increment(t->left);- increment(t->right);- }-}--struct Tree *build_tree(int size) {- struct Tree *t = malloc(sizeof(struct Tree));-- if (size <= 0) {- t->tag = LEAF;- t->value = 1;- } else {- t->tag = NODE;- t->left = build_tree(size - 1);- t->right = build_tree(size - 1);- }-- return t;-}--void free_tree(struct Tree *t) {-- if (t->tag == NODE) {- free_tree(t->left);- free_tree(t->right);- }- free(t);-}--////////--// void time_sum(int size, struct Tree *tree) {-// long begin = get_nanos();-//-// long res = sum(tree);-//-// long time_spent = (get_nanos() - begin);-//-// assert(res == pow(2, size));-// free_tree(tree);-// // todo free tree-// printf("Size: %d\n", size);-// printf("Execution time %ldns\n", time_spent);-// }-//-// void time_traversal(int size, struct Tree *tree) {-// long begin = get_nanos();-//-// long res = get_right_most(tree);-//-// long time_spent = (get_nanos() - begin);-//-// free_tree(tree);-// printf("Size: %d\n", size);-// printf("Execution time %ldns\n", time_spent);-// }--// void time_eval(int size, struct AST *tree) {-// long begin = get_nanos();-//-// long res = eval(tree);-//-// long time_spent = (get_nanos() - begin);-//-// free_ast(tree);-// printf("Size: %d\n", size);-// printf("Execution time %ldns\n", time_spent);-// }-//-// int main(int argc, char **argv) {-// // TODO Check "sum", "right-most"-// if (argc < 2) {-// printf("Expected at least one argument\n");-// return 1;-// }-// if (strcmp(argv[1], "sum") == 0) {-// printf("right-most\n");-// if (argc == 3) {-//-// int tree_size = atoi(argv[2]);-// time_sum(tree_size, build_tree(tree_size));-// return 0;-// }-// for (int tree_size = 0; tree_size <= 20; tree_size++) {-//-// time_sum(tree_size, build_tree(tree_size));-// }-// } else if (strcmp(argv[1], "right-most") == 0) {-// printf("right-most\n");-// if (argc == 3) {-// int tree_size = atoi(argv[2]);-// time_traversal(tree_size, build_tree(tree_size));-// return 0;-// }-// for (int tree_size = 0; tree_size <= 20; tree_size++) {-//-// time_traversal(tree_size, build_tree(tree_size));-// }-//-// } else if (strcmp(argv[1], "ast") == 0) {-// printf("ast\n");-// if (argc == 3) {-// int tree_size = atoi(argv[2]);-// time_eval(tree_size, build_ast(tree_size));-// return 0;-// }-// for (int tree_size = 0; tree_size <= 20; tree_size++) {-//-// time_eval(tree_size, build_ast(tree_size));-// }-// }-// }
+ benchmark/report/Criterion.hs view
@@ -0,0 +1,78 @@+module Criterion where++import Data.Char (isDigit)+import Data.List (isInfixOf, isPrefixOf, isSuffixOf)+import Data.Scientific+import Debug.Trace (trace)+import System.Directory (removeFile)+import System.Process+import Text.Read (readMaybe)+import Types++runCriterionBenchmarks :: BenchSuite -> IO BenchmarkResults+runCriterionBenchmarks s = do+ (_, _, _, h) <- createProcess (shell criterionCmd)+ _ <- waitForProcess h+ csv <- readFile reportPath+ res <- parseCSV s csv+ removeFile reportPath+ return res+ where+ reportPath = "report.csv"+ criterionTestSuiteName = suiteToCriterionBenchName s+ criterionCmd =+ "cabal bench tree-bench --benchmark-options='--csv "+ ++ reportPath+ ++ " "+ ++ criterionTestSuiteName+ ++ "'"++suiteToCriterionBenchName :: BenchSuite -> String+suiteToCriterionBenchName = \case+ AST -> "ast"+ Sum -> "sum"+ RightMost -> "traversals/right-most"+ Incr -> "increment"++parseCSV :: BenchSuite -> String -> IO BenchmarkResults+parseCSV s csv = do+ let cleanCSV = drop 1 $ lines csv+ res <- parseCSVForCase cleanCSV s `mapM` cases+ return $ filter (not . null . values) res++parseCSVForCase :: [String] -> BenchSuite -> (String, String, Maybe String) -> IO BenchmarkResult+parseCSVForCase csvLines s (caseId, lang, subtitle) = do+ let caseLines = filter (('/' : caseId ++ ",") `isInfixOf`) csvLines+ caseValues <- parseCSVLineForCase `mapM` caseLines+ return $ BenchmarkResult s lang subtitle caseValues++parseCSVLineForCase :: (MonadFail m) => String -> m (Int, Double)+parseCSVLineForCase line =+ let res = do+ treeSize <- readMaybe rawTreeSize+ time <- readMaybe rawTime :: Maybe Scientific+ return (treeSize, toRealFloat time)+ in trace (show res) $ maybe (fail "Parsing error") return res+ where+ rawTime =+ takeWhile (/= ',') $+ drop 1 $+ dropWhile (/= ',') line+ rawTreeSize =+ takeWhile isDigit $+ dropWhile (not . isDigit) line++cases :: [(String, String, Maybe String)]+cases =+ [ ("c-inplace", "C", Just "Inplace")+ , ("c-new-tree", "C", Just "Produces new tree")+ , ("native", "Haskell", Nothing)+ , ("packed", "packed-data", Just "W/o Indirections")+ , ("packed-with-size", "packed-data", Just "W/ Indirections")+ , ("packed-unpacked", "packed-data", Just "Unpacking, then traverse")+ , ("non-monadic-packed", "packed-data", Just "Non-monadic, w/o Indirections")+ , ("non-monadic-packed-with-size", "packed-data", Just "Non-monadic, w/ Indirections")+ , ("packed-needsbuilder", "packed-data", Just "Using NeedsBuilder")+ , ("unpack-repack", "packed-data", Just "Unpacking, increment and repack")+ , ("packed-rebuild-repack", "packed-data", Just "Deserialise and increment, and repack")+ ]
+ benchmark/report/Go.hs view
@@ -0,0 +1,68 @@+module Go where++import Control.Monad (unless)+import Data.Char (isDigit, isSpace)+import Data.List (groupBy, isPrefixOf)+import System.Directory (doesFileExist)+import System.IO hiding (stdout)+import System.Process+import Text.Read (readMaybe)+import Types+import Prelude++goTestPath :: String+goTestPath = "benchmark/report/go/benchmarks_test.go"++runGoBenchmarks :: BenchSuite -> IO [BenchmarkResult]+runGoBenchmarks s = do+ goIsFound <- doesFileExist goTestPath+ unless goIsFound $+ fail ("Could not find the Golang benchmark in " ++ goTestPath)+ (_, Just hout, _, _) <-+ createProcess (shell golangCmd){std_out = CreatePipe}+ hGetContents hout >>= parseOutput s+ where+ golangTestSuiteName = suiteToGolangBenchName s+ golangCmd = "go test " ++ goTestPath ++ " -bench " ++ golangTestSuiteName++suiteToGolangBenchName :: BenchSuite -> String+suiteToGolangBenchName = \case+ AST -> "BenchmarkAST"+ Sum -> "BenchmarkSum"+ RightMost -> "BenchmarkGetRightMost"+ Incr -> "BenchmarkIncrement"++parseOutput :: (MonadFail m) => BenchSuite -> String -> m [BenchmarkResult]+parseOutput s stdout = do+ parsedLines <- parseOutputLine `mapM` l+ let groups = groupBy (\(sa, _, _) (sb, _, _) -> sa == sb) parsedLines+ return $ groupToBenchRes <$> groups+ where+ groupToBenchRes group =+ let+ (label, _, _) = head group+ n = if label == "BenchmarkIncrementInplace" then "Inplace" else "Produces new tree"+ v = (\(_, size, time) -> (size, time)) <$> group+ in+ BenchmarkResult{suite = s, values = v, language = "Golang", name = Just n}+ suiteName = suiteToGolangBenchName s+ l = filter (suiteName `isPrefixOf`) $ lines stdout++parseOutputLine :: (MonadFail m) => String -> m (String, Int, Double)+parseOutputLine bs =+ let res = do+ let suiteName = takeWhile (/= '_') bs+ treeSize <- readMaybe rawTreeSize+ time <- readMaybe rawTime+ return (suiteName, treeSize, time * 10 ^^ (-9))+ in maybe (fail "Parsing error") return res+ where+ -- BenchmarkSum_5-10 -> 5+ rawTreeSize = takeWhile (/= '-') (drop 1 $ dropWhile (/= '_') bs)+ -- BenchmarkEval_5-10 11866071 101.7 ns/op -> 101.7+ rawTime =+ takeWhile (\c -> c == '.' || isDigit c) $+ dropWhile isSpace $+ dropWhile isDigit $+ dropWhile isSpace $+ dropWhile (not . isSpace) bs
+ benchmark/report/Main.hs view
@@ -0,0 +1,66 @@+module Main (main) where++import Control.Monad+import Criterion+import qualified Data.ByteString.Lazy as BS+import Data.Char+import Data.Csv+import Data.List (intercalate, sortBy)+import Go+import System.Directory+import System.Environment (getArgs)+import Types++main :: IO ()+main = do+ s <- getSuite+ isInStackProject <- doesFileExist "package.yaml"+ unless isInStackProject $+ fail "Please run this at the root of the packed-data project"+ goRes <- runGoBenchmarks s+ criterionRes <- runCriterionBenchmarks s+ let benchRes = goRes ++ criterionRes+ reportFileName = toLower <$> show s ++ "-report.csv"+ BS.writeFile reportFileName $+ encodeDefaultOrderedByName $+ orderBenchResults benchRes++orderBenchResults :: [BenchmarkResult] -> [BenchmarkResult]+orderBenchResults benchs = fst <$> sortBy (\(_, ia) (_, ib) -> ia `compare` ib) benchWithIndex+ where+ benchWithIndex = (\b -> (b, curry benchIndex (language b) (name b))) <$> benchs+ benchIndex :: (String, Maybe String) -> Int+ benchIndex = \case+ ("C", Just "Inplace") -> 0+ ("C", Just "Produces new tree") -> 1+ ("C", _) -> 0+ ("Haskell", _) -> 2+ ("packed-data", Just "W/o Indirections") -> 3+ ("packed-data", Just "W/ Indirections") -> 4+ ("packed-data", Just "Non-monadic, w/o Indirections") -> 9+ ("packed-data", Just "Non-monadic, w/ Indirections") -> 10+ ("packed-data", Just "Unpacking, then traverse") -> 5+ ("packed-data", Just "Using NeedsBuilder") -> 6+ ("packed-data", Just "Unpacking, increment and repack") -> 7+ ("packed-data", Just "Deserialise and increment, and repack") -> 8+ ("Golang", Just "Inplace") -> 11+ ("Golang", Just "Produces new tree") -> 12+ ("Golang", _) -> 11+ c -> error $ show c++getSuite :: IO BenchSuite+getSuite = do+ args <- getArgs+ case args of+ [s] -> parseSuite s+ _ -> fail "Expected exactly one argument"+ where+ parseSuite "sum" = return Sum+ parseSuite "ast" = return AST+ parseSuite "right-most" = return RightMost+ parseSuite "increment" = return Incr+ parseSuite _ =+ fail $+ "Expected one of ["+ ++ intercalate ", " ["ast", "sum", "right-most", "increment"]+ ++ "]"
+ benchmark/report/Types.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Types where++import Data.Csv hiding (lookup)+import Data.Maybe (fromJust)+import Numeric (showFFloat)++data BenchSuite = AST | Incr | Sum | RightMost deriving (Show)++type BenchmarkResults = [BenchmarkResult]++data BenchmarkResult = BenchmarkResult+ { suite :: BenchSuite+ , language :: String+ , name :: Maybe String+ , values :: [(Int, Double)]+ -- ^ Maps tree size to execution time, in s+ }+ deriving (Show)++instance ToNamedRecord BenchmarkResult where+ toNamedRecord (BenchmarkResult _ l n v) =+ namedRecord+ [ "Language" .= l+ , "Name" .= n+ , "1" .= get 1+ , "5" .= get 5+ , "10" .= get 10+ , "15" .= get 15+ , "20" .= get 20+ ]+ where+ get i = formatDuration (fromJust $ lookup i v)++formatDuration :: Double -> String+formatDuration d+ | d < (10 :: Double) ^^ (-6 :: Int) = showVal (d * 10 ^ (9 :: Int)) " ns"+ | d < (10 :: Double) ^^ (-3 :: Int) = showVal (d * 10 ^ (6 :: Int)) " us"+ | d < 1 = showVal (d * 10 ^ (3 :: Int)) " ms"+ | otherwise = showVal d " s"+ where+ showVal = showFFloat (Just 2)++instance DefaultOrdered BenchmarkResult where+ headerOrder _ = header ["Language", "Name", "1", "5", "10", "15", "20"]
+ benchmark/tree/AST.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE TemplateHaskell #-}++module AST (benchmark) where++import Criterion.Main+import Data.ByteString.Internal+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Void+import Foreign+import Foreign.C+import Foreign.ForeignPtr.Unsafe+import Utils+import Prelude hiding (sum)++foreign import capi unsafe "benchmark.h eval" c_eval :: Ptr Void -> IO CLong++foreign import capi unsafe "benchmark.h build_ast" c_build_ast :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_ast" c_free_ast :: Ptr Void -> IO ()++data AST = Value Int32 | Add AST AST | Sub AST AST | Mul AST AST++$(mkPacked ''AST [])++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "ast"+ $ fmap buildAndEvaluateASTWithDepth depths++buildAndEvaluateASTWithDepth :: Int -> Benchmark+buildAndEvaluateASTWithDepth n =+ bgroup+ (depthGroupName n)+ [ envWithCleanup (c_build_ast $ fromIntegral n) c_free_ast $ bench cTestName . nfAppIO c_eval+ , bench nativeTestName $ nf eval nativeAST+ , bench packedTestName $ nfAppIO (runReader evalPacked) packedAST+ , bench packedWithUnpackTestName $ whnf (eval . fst . unpack) packedAST+ , bench nonMonadicPackedTestName $ nfAppIO evalPackedNonMonadic packedAST+ ]+ where+ !packedAST = pack nativeAST+ !nativeAST = buildNativeAST n++eval :: AST -> Int32+eval (Value n) = n+eval (Add a b) = eval a + eval b+eval (Sub a b) = eval a - eval b+eval (Mul a b) = eval a * eval b++evalPacked :: PackedReader '[AST] r Int32+evalPacked =+ caseAST+ reader+ (opLambda (+))+ (opLambda (-))+ (opLambda (*))+ where+ {-# INLINE opLambda #-}+ opLambda ::+ (Int32 -> Int32 -> Int32) ->+ PackedReader '[AST, AST] r Int32+ opLambda f = R.do+ left <- evalPacked+ right <- evalPacked+ R.return (f left right)++evalPackedNonMonadic :: Packed (AST ': r) -> IO Int32+evalPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Int32, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ let !nextPtr = ptr `plusPtr` 1+ case tag of+ 0 -> do+ !n <- peek nextPtr :: IO Int32+ return (n, plusPtr nextPtr (sizeOf n))+ 1 -> opLambda (+) nextPtr+ 2 -> opLambda (-) nextPtr+ 3 -> opLambda (*) nextPtr+ _ -> undefined+ {-# INLINE opLambda #-}+ opLambda :: (Int32 -> Int32 -> Int32) -> Ptr Int32 -> IO (Int32, Ptr Word8)+ opLambda f ptr = do+ (!left, !r) <- go $ castPtr ptr+ (!right, !r1) <- go r+ let !res = left `f` right+ return (res, r1)++buildNativeAST :: Int -> AST+buildNativeAST 0 = Value 1+buildNativeAST n = Add (buildNativeAST (n - 1)) (buildNativeAST (n - 1))
+ benchmark/tree/Build.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Build (benchmark) where++import Control.DeepSeq+import Criterion.Main+import Data.Packed+import Data.Packed.Needs+import qualified Data.Packed.Needs as N+import GHC.Generics (Generic, Generic1)+import Utils+import Prelude hiding (sum)++data Tree1 a = Leaf1 !a | Node1 !(Tree1 a) !(Tree1 a) deriving (Generic, Generic1)++$(mkPacked ''Tree1 [])++instance (NFData a) => NFData (Tree1 a)++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "build"+ $ fmap buildTreeWithDepth depths++buildTreeWithDepth :: Int -> Benchmark+buildTreeWithDepth n =+ bgroup+ (depthGroupName n)+ [ bench nativeTestName $ nf buildNativeTree n+ , bench packedTestName $ nf (\p -> finish (buildPackedTree p)) n+ ]++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+ where+ !subTree = buildNativeTree (n - 1)++buildPackedTree :: Int -> Needs '[] '[Tree1 Int]+buildPackedTree 0 = withEmptyNeeds (writeConLeaf1 (1 :: Int))+buildPackedTree n = withEmptyNeeds (startNode1 N.>> applyNeeds subTree N.>> applyNeeds subTree)+ where+ !subTree = buildPackedTree (n - 1)
+ benchmark/tree/CIReport.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}++module CIReport (generateCIReport) where++import Data.Aeson+import GHC.Generics+import OutputData (BenchmarkResult (BenchmarkResult), BenchmarkValue (meanExecutionTime), mode, readBenchmarkResults)+import Text.Printf+import Utils (nativeTestName)++data ReportEntry = ReportEntry+ { name :: String+ , unit :: String+ , value :: Double+ }+ deriving (Generic, Show)++instance ToJSON ReportEntry++generateCIReport :: FilePath -> IO ()+generateCIReport csvPath = do+ let reportPath = "benchmark-report.json"+ benRes <- readBenchmarkResults csvPath+ let reportEntries = concatMap toReportEntries benRes+ encodeFile reportPath reportEntries++toReportEntries :: BenchmarkResult -> [ReportEntry]+toReportEntries (BenchmarkResult benName values) =+ concatMap+ ( \(depth, depthValues) ->+ ( \depthVal ->+ ReportEntry+ { name = printf "%s/%d (%s)" benName depth (show $ mode depthVal)+ , unit = "seconds"+ , value = meanExecutionTime depthVal+ }+ )+ <$> filter (\v -> show (mode v) /= nativeTestName) depthValues+ )+ values
+ benchmark/tree/Increment.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}+{-# LANGUAGE DeriveGeneric #-}++module Increment (benchmark) where++import Control.DeepSeq+import Control.Monad+import Criterion.Main+import Data.List (intercalate)+import Data.Packed+import Data.Packed.Needs (applyNeeds)+import qualified Data.Packed.Needs as N+import qualified Data.Packed.Reader as R+import Data.Void+import Foreign+import Foreign.C+import GHC.Generics (Generic, Generic1)+import Utils+import Prelude hiding (concat)++foreign import capi unsafe "benchmark.h increment_inplace" c_increment_inplace :: Ptr Void -> IO ()++foreign import capi unsafe "benchmark.h increment" c_increment :: Ptr Void -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()+data Tree1 a = Leaf1 !a | Node1 !(Tree1 a) !(Tree1 a) deriving (Generic, Generic1)++instance (NFData a) => NFData (Tree1 a)+instance NFData1 Tree1++$(mkPacked ''Tree1 [])++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "increment"+ $ fmap computeTreeSumWithDepth depths++computeTreeSumWithDepth :: Int -> Benchmark+computeTreeSumWithDepth n =+ bgroup+ (depthGroupName n)+ [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $+ bench (cTestName ++ "-inplace") . nfAppIO c_increment_inplace+ , envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $+ bench (cTestName ++ "-new-tree") . nfAppIO c_increment+ , bench nativeTestName $+ nf increment nativeTree+ , bench (intercalate "-" [packedTestName, "needsbuilder"]) $+ nfAppIO incrementPackedRunner packedTree+ , bench (intercalate "-" ["unpack", "repack"]) $+ nf (pack . increment . fst . unpack) packedTree+ , bench (intercalate "-" [packedTestName, "rebuild-repack"]) $+ nfAppIO repackingIncrementPackedRunner packedTree+ ]+ where+ !packedTree = pack nativeTree+ !nativeTree = buildNativeTree n++increment :: Tree1 Int -> Tree1 Int+increment (Leaf1 n) = let !res = n + 1 in Leaf1 res+increment (Node1 t1 t2) = Node1 res1 res2+ where+ !res1 = increment t1+ !res2 = increment t2++-- Produces an needsbuilder for a tree alread incremented, and finishes it+incrementPackedRunner :: Packed '[Tree1 Int] -> IO (Packed '[Tree1 Int])+incrementPackedRunner packed = do+ (!needs, _) <- runReader incrementPacked packed+ return $ finish needs++incrementPacked :: PackedReader '[Tree1 Int] r (Needs '[] '[Tree1 Int])+incrementPacked =+ transformTree1+ ( R.do+ n <- reader+ R.return (write (n + 1))+ )+ ( R.do+ left <- incrementPacked+ right <- incrementPacked+ R.return (applyNeeds left N.>> applyNeeds right)+ )++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+ where+ !subTree = buildNativeTree (n - 1)++-- Produces an unpacked tree alread incremented, and packs it+repackingIncrementPackedRunner :: Packed '[Tree1 Int] -> IO (Packed '[Tree1 Int])+repackingIncrementPackedRunner packed = do+ (!tree, _) <- runReader repackingIncrementPacked packed+ let !repacked = pack tree+ return repacked++repackingIncrementPacked :: PackedReader '[Tree1 Int] r (Tree1 Int)+repackingIncrementPacked =+ caseTree1+ ( R.do+ n <- reader+ R.return (Leaf1 (n + 1))+ )+ ( R.do+ !left <- repackingIncrementPacked+ !right <- repackingIncrementPacked+ R.return (Node1 left right)+ )
+ benchmark/tree/List.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}++module List (benchmark) where++import Control.DeepSeq+import Criterion.Main+import qualified Data.ByteString.Internal as BS+import Data.Packed+import Data.Packed.Needs (Needs (Needs))+import qualified Data.Packed.Needs as N+import qualified Data.Packed.Reader as R+import Foreign+import Utils+import Prelude hiding (sum)++data Tree1 a = Leaf1 | Node1 (Tree1 a) a (Tree1 a)++instance NFData (Tree1 a) where+ rnf Leaf1 = ()+ rnf (Node1 l n r) = n `seq` l `seq` r `seq` ()++$(mkPacked ''Tree1 [InsertFieldSize])++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "list"+ []++-- bgroup+-- "from-list"+-- $ fmap buildTreeFromListWithLength depths+-- , bgroup+-- "to-list"+-- $ fmap treeToListWithLength depths++-- buildTreeFromListWithLength :: Int -> Benchmark+-- buildTreeFromListWithLength n =+-- bgroup+-- (depthGroupName n)+-- [ bench nativeTestName $ nf buildTreeFromList list+-- , bench packedTestName $ nfAppIO buildPackedTreeFromList list+-- ]+-- where+-- list = buildUnorderedList n++-- treeToListWithLength :: Int -> Benchmark+-- treeToListWithLength n =+-- bgroup+-- (depthGroupName n)+-- [ bench nativeTestName $ nf treeToList (buildTreeFromList list)+-- , env (buildPackedTreeFromList list) $+-- bench packedTestName+-- . nfAppIO+-- (runReader packedTreeToList)+-- ]+-- where+-- list = buildUnorderedList n++buildTreeFromList :: [Int] -> Tree1 Int+buildTreeFromList = foldl (flip insertInTree) Leaf1+ where+ insertInTree n Leaf1 = Node1 Leaf1 n Leaf1+ insertInTree n (Node1 l n' r) =+ if n > n'+ then Node1 l n' (insertInTree n r)+ else Node1 (insertInTree n l) n' r++treeToList :: Tree1 Int -> [Int]+treeToList t = go t []+ where+ go Leaf1 r = r+ go (Node1 l n r) list = go l (n : go r list)++packedTreeToList :: PackedReader '[Tree1 Int] '[] [Int]+packedTreeToList = go []+ where+ go :: [Int] -> PackedReader '[Tree1 Int] r [Int]+ go l =+ caseTree1+ (R.return l)+ ( R.do+ packedLeft <- isolate+ n <- readerWithFieldSize+ packedRight <- isolate+ rightList <- R.lift (go l) packedRight+ R.lift (go $ n : rightList) packedLeft+ )++--+-- buildPackedTreeFromList :: [Int] -> IO (Packed '[Tree1 Int])+-- buildPackedTreeFromList l =+-- finish+-- =<< withEmptyNeeds+-- =<< foldl+-- ( \builder i -> R.do+-- n <- insertInPackedTree i+-- R.return (builder N.>> n)+-- )+-- (write Leaf1)+-- l+-- where+-- packedToNeeds :: Packed a -> Needs '[] a+-- packedToNeeds p = let (BS.BS fptr l) = fromPacked p in Needs fptr l l+-- insertInPackedTree ::+-- Int ->+-- PackedReader '[Tree1 Int] '[] (N.NeedsBuilder '[] '[Tree1 Int] '[] '[Tree1 Int])+-- insertInPackedTree n =+-- caseTree1+-- ( mkPackedReader+-- ( \p l -> do+-- let n =+-- ( N.do+-- startNode1+-- writeWithFieldSize Leaf1+-- writeWithFieldSize 0+-- writeWithFieldSize Leaf1+-- )+-- return (n, p, l)+-- )+-- )+-- ( R.do+-- !left <- isolate+-- !n' <- readerWithFieldSize+-- !right <- isolate+-- let !needLeft = packedToNeeds left+-- let !needRight = packedToNeeds right+-- needsN' <- mkPackedReader (\p l -> (,p,l) <$> withEmptyNeeds (write n'))+-- if n > n'+-- then R.do+-- right' <- R.lift (insertInPackedTree n) right+-- R.return (repackNode1 needLeft needsN' right')+-- else R.do+-- left' <- R.lift (insertInPackedTree n) left+-- R.return (repackNode1 left' needsN' needRight)+-- )+--+buildUnorderedList :: Int -> [Int]+buildUnorderedList n = intercalate [(n `div` 2) .. n] [0 .. (n `div` 2) - 1]+ where+ intercalate a [] = a+ intercalate [] b = b+ intercalate (a : b) (c : d) = a : c : intercalate b d
+ benchmark/tree/Main.hs view
@@ -0,0 +1,65 @@+module Main (main) where++import qualified AST+import qualified Build+import CIReport+import Control.Monad (when)+import Criterion.Main+import Criterion.Main.Options (Mode (..), describe)+import Criterion.Types (Config (..))+import Data.Maybe (isJust, isNothing)+import qualified Increment+import qualified List+import Options.Applicative (execParser)+import qualified Pack+import qualified Sum+import System.Directory+import qualified Traversals++main :: IO ()+main = do+ mode <- execParser (describe defaultConfig)+ when (isNothing (csvPath mode) && modeExportOtherThanCsv mode) $ do+ putStrLn "Warning: Report for CI will not be generated."+ putStrLn "Warning: Use the CSV export function to generate graphs and CI report."+ -- Criterion seems to append the result to the file if it already exists+ -- Therefore, it adds a new header. Cassava does not like this.+ _ <- case csvPath mode of+ Just p -> do+ exists <- doesFileExist p+ when exists (removeFile p)+ _ -> return ()+ runMode mode benchmarks+ case csvPath mode of+ Nothing -> return ()+ Just exportPath -> do+ putStrLn "Generating CI report..."+ generateCIReport exportPath+ putStrLn "Generation CI report."+ where+ depths = [1, 5, 10, 15, 20]+ benchmarks =+ [ Traversals.benchmark depths+ , Pack.benchmark depths+ , Increment.benchmark depths+ , Sum.benchmark depths+ , AST.benchmark depths+ , Build.benchmark depths+ , List.benchmark depths+ ]+ csvPath (RunIters cfg _ _ _) = csvPathFromCfg cfg+ csvPath (Run cfg _ _) = csvPathFromCfg cfg+ csvPath _ = Nothing+ csvPathFromCfg = csvFile+ modeExportOtherThanCsv (RunIters cfg _ _ _) = cfgExportOtherThanCsv cfg+ modeExportOtherThanCsv (Run cfg _ _) = cfgExportOtherThanCsv cfg+ modeExportOtherThanCsv _ = False+ cfgExportOtherThanCsv cfg =+ any+ isJust+ $ ($ cfg)+ <$> [ junitFile+ , jsonFile+ , reportFile+ , rawDataFile+ ]
+ benchmark/tree/OutputData.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-x-partial -Wno-unrecognised-warning-flags #-}++module OutputData (+ RawCSVEntry (..),+ BenchmarkMode (..),+ BenchmarkResult (..),+ BenchmarkValue (..),+ readBenchmarkResults,+ genFail,+) where++import qualified Data.ByteString.Lazy as BS+import Data.Char (isDigit)+import Data.Csv+import qualified Data.List.Safe as Safe+import Data.List.Split (splitOn)+import Data.Vector (toList)+import System.Exit+import Text.Read++data RawCSVEntry = RawCSVEntry+ { _name :: String+ , _mean :: Double+ }+instance FromNamedRecord RawCSVEntry where+ parseNamedRecord m = RawCSVEntry <$> m .: "Name" <*> m .: "Mean"++newtype BenchmarkMode = BenchmarkMode String deriving (Eq)++instance Show BenchmarkMode where+ show (BenchmarkMode s) = s++instance Read BenchmarkMode where+ readsPrec _ s = [(BenchmarkMode s, "")]++-- | Processed data+data BenchmarkResult = BenchmarkResult+ { name :: String+ -- ^ Example: Build+ , values :: [(Int, [BenchmarkValue])]+ -- ^ Maps benchmark values with the depths of the related tree.+ }+ deriving (Show)++data BenchmarkValue = BenchmarkValue+ { mode :: BenchmarkMode+ , meanExecutionTime :: Double+ }+ deriving (Show)++readBenchmarkResults :: FilePath -> IO [BenchmarkResult]+readBenchmarkResults csvPath = do+ rawFile <- BS.readFile csvPath+ rawCSVEntries <-+ either+ genFail+ (return . toList . snd)+ (decodeByName rawFile)+ processedCSVEntries <-+ either+ genFail+ return+ (processCSVEntries rawCSVEntries)+ return processedCSVEntries++processCSVEntries :: [RawCSVEntry] -> Either String [BenchmarkResult]+processCSVEntries rawEntries = do+ entries <-+ mapM+ (maybe (Left "Error when processing entry") Right . processCSVEntry)+ rawEntries+ return $ foldr mergeBenchmarkEntries [] entries++processCSVEntry :: RawCSVEntry -> Maybe BenchmarkResult+processCSVEntry (RawCSVEntry rawname mean) = do+ let splitEntryName = splitOn "/" rawname+ benchName <- splitEntryName Safe.!! (length splitEntryName - 3 :: Int)+ benchMode <- readMaybe =<< Safe.last splitEntryName+ depth <- do+ rawDepth <- splitEntryName Safe.!! (length splitEntryName - 2)+ readMaybe $ takeWhile isDigit rawDepth+ let benchValue =+ BenchmarkValue+ { mode = benchMode+ , meanExecutionTime = mean+ }+ return $+ BenchmarkResult+ { name = benchName+ , values = [(depth, [benchValue])]+ }++mergeBenchmarkEntries :: BenchmarkResult -> [BenchmarkResult] -> [BenchmarkResult]+mergeBenchmarkEntries benRes [] = [benRes]+mergeBenchmarkEntries benRes (mergedRes : mergedRest) =+ let benValue = head $ snd $ head (values benRes)+ depth = fst $ head (values benRes)+ in if name benRes == name mergedRes+ then mergedRes{values = mergeBenchmarkValues depth benValue (values mergedRes)} : mergedRest+ else mergedRes : mergeBenchmarkEntries benRes mergedRest+ where+ mergeBenchmarkValues :: Int -> BenchmarkValue -> [(Int, [BenchmarkValue])] -> [(Int, [BenchmarkValue])]+ mergeBenchmarkValues depth val [] = [(depth, [val])]+ mergeBenchmarkValues valDepth val ((depth, vals) : b) =+ if valDepth == depth+ then (depth, val : vals) : b+ else (depth, vals) : mergeBenchmarkValues valDepth val b++-- | Prints error message, and exits+genFail :: (Show a) => a -> IO b+genFail msg = do+ putStrLn "An error occured while generating graphs:"+ print msg+ exitFailure
+ benchmark/tree/Pack.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Pack (benchmark) where++import Control.DeepSeq+import Criterion.Main+import Data.Packed+import Utils+import Prelude hiding (sum)++data Tree1 a = Leaf1 a | Node1 !(Tree1 a) !(Tree1 a)+data Tree2 a = Leaf2 a | Node2 !(Tree2 a) !(Tree2 a)++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [])++instance NFData (Tree1 a) where+ rnf (Leaf1 a) = a `seq` ()+ rnf (Node1 l r) = l `seq` r `seq` ()++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "pack"+ $ fmap buildTreeWithDepth depths++buildTreeWithDepth :: Int -> Benchmark+buildTreeWithDepth n =+ bgroup+ (depthGroupName n)+ [ bench packedTestName $ nf Data.Packed.pack (buildNativeTree n)+ , bench packedWithFieldSizeTestName $ nf Data.Packed.pack (buildNativeTree2 n)+ ]++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+ where+ subTree = buildNativeTree (n - 1)++buildNativeTree2 :: Int -> Tree2 Int+buildNativeTree2 0 = Leaf2 1+buildNativeTree2 n = Node2 subTree subTree+ where+ subTree = buildNativeTree2 (n - 1)
+ benchmark/tree/Sum.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}++module Sum (benchmark) where++import Criterion.Main+import Data.ByteString.Internal+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Void (Void)+import Foreign+import Foreign.C+import Foreign.ForeignPtr.Unsafe+import GHC.IO+import Utils+import Prelude hiding (sum)++foreign import capi unsafe "benchmark.h sum" c_sum :: Ptr Void -> IO CLong++foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()++data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)+data Tree2 a = Leaf2 a | Node2 (Tree2 a) (Tree2 a)++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [InsertFieldSize])++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "sum"+ $ fmap computeTreeSumWithDepth depths++computeTreeSumWithDepth :: Int -> Benchmark+computeTreeSumWithDepth n =+ bgroup+ (depthGroupName n)+ [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $ bench cTestName . nfAppIO c_sum+ , bench nativeTestName $ nf sum nativeTree+ , bench packedTestName $ whnfAppIO (R.runReader sumPacked) packedTree+ , bench packedWithUnpackTestName $ whnf (sum . fst . unpack) packedTree+ , bench packedWithFieldSizeTestName $ whnfAppIO (R.runReader sumPacked2) packedTree2+ , bench nonMonadicPackedTestName $ nfAppIO sumPackedNonMonadic packedTree+ , bench nonMonadicPackedWithSizeTestName $ nfAppIO sumPackedNonMonadic2 packedTree2+ ]+ where+ !packedTree = pack nativeTree+ !packedTree2 = pack (buildNativeTree2 n)+ !nativeTree = buildNativeTree n++sum :: Tree1 Int -> Int+sum (Leaf1 n) = n+sum (Node1 t1 t2) = sum t1 + sum t2++sumPacked :: PackedReader '[Tree1 Int] r Int+sumPacked =+ caseTree1+ ( R.do+ !n <- reader+ R.return n+ )+ ( R.do+ !left <- sumPacked+ !right <- sumPacked+ let !res = left + right+ R.return res+ )++sumPacked2 :: PackedReader '[Tree2 Int] r Int+sumPacked2 =+ caseTree2+ ( R.do+ !n <- readerWithFieldSize+ R.return n+ )+ ( R.do+ !left <- skip R.>> sumPacked2+ !right <- skip R.>> sumPacked2+ let !res = left + right+ R.return res+ )+sumPackedNonMonadic :: Packed (Tree1 Int ': r) -> IO Int+sumPackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Int, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ let !nextPtr = ptr `plusPtr` 1+ case tag of+ 0 -> do+ !n <- peek nextPtr+ let !nextPtr1 = ptr `plusPtr` 9+ return (n, nextPtr1)+ 1 -> do+ (!left, !r) <- go (castPtr nextPtr)+ (!right, !r1) <- go r+ let !res = left + right+ return (res, r1)+ _ -> undefined++sumPackedNonMonadic2 :: Packed (Tree2 Int ': r) -> IO Int+sumPackedNonMonadic2 packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ sizeOfFieldSize = sizeOf (1 :: Int32)+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Int, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ let !nextPtr = ptr `plusPtr` 1+ case tag of+ 0 -> do+ !n <- peek (nextPtr `plusPtr` sizeOfFieldSize)+ let !nextPtr1 = ptr `plusPtr` 9 `plusPtr` sizeOfFieldSize+ return (n, nextPtr1)+ 1 -> do+ (!left, !r) <- go (castPtr $ nextPtr `plusPtr` sizeOfFieldSize)+ (!right, !r1) <- go (r `plusPtr` sizeOfFieldSize)+ let !res = left + right+ return (res, r1)+ _ -> undefined+buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 1+buildNativeTree n = Node1 subTree subTree+ where+ subTree = buildNativeTree (n - 1)++buildNativeTree2 :: Int -> Tree2 Int+buildNativeTree2 0 = Leaf2 1+buildNativeTree2 n = Node2 subTree subTree+ where+ subTree = buildNativeTree2 (n - 1)
+ benchmark/tree/Traversals.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CApiFFI #-}++module Traversals (benchmark) where++import Criterion.Main+import Data.ByteString.Internal+import Data.Packed+import qualified Data.Packed.Reader as R+import Data.Void+import Foreign+import Foreign.C+import Foreign.ForeignPtr.Unsafe+import Utils++foreign import capi unsafe "benchmark.h get_right_most" c_get_right_most :: Ptr Void -> IO CLong++foreign import capi unsafe "benchmark.h build_tree" c_build_tree :: CInt -> IO (Ptr Void)++foreign import capi unsafe "benchmark.h free_tree" c_free_tree :: Ptr Void -> IO ()++data Tree1 a = Leaf1 a | Node1 (Tree1 a) (Tree1 a)+data Tree2 a = Leaf2 a | Node2 (Tree2 a) (Tree2 a)++$(mkPacked ''Tree1 [])+$(mkPacked ''Tree2 [InsertFieldSize])++benchmark :: [Int] -> Benchmark+benchmark depths =+ bgroup+ "traversals"+ [ bgroup+ "right-most-node"+ $ fmap compareGettingRightMostNode depths+ , bgroup+ "contains"+ $ fmap compareContainsValue depths+ ]++compareGettingRightMostNode :: Int -> Benchmark+compareGettingRightMostNode n =+ bgroup+ (depthGroupName n)+ [ envWithCleanup (c_build_tree (fromIntegral n)) c_free_tree $ bench cTestName . nfAppIO c_get_right_most+ , bench nativeTestName $ nf getRightMostNodeNative nativeTree+ , bench packedTestName $ nfAppIO (runReader getRightMostNodePacked) packedTree+ , bench packedWithUnpackTestName $ whnf (getRightMostNodeNative . fst . unpack) packedTree+ , bench nonMonadicPackedTestName $ nfAppIO getRightMostNodePackedNonMonadic packedTree+ , bench packedWithFieldSizeTestName $+ nfAppIO (runReader getRightMostNodePacked2) packedTreeWithSize+ , bench nonMonadicPackedWithSizeTestName $ nfAppIO getRightMostNodePacked2NonMonadic packedTreeWithSize+ ]+ where+ packedTree = pack nativeTree+ packedTreeWithSize = pack (tree1ToTree2 nativeTree)+ tree1ToTree2 (Leaf1 l) = Leaf2 l+ tree1ToTree2 (Node1 a b) = Node2 (tree1ToTree2 a) (tree1ToTree2 b)+ nativeTree = buildNativeTree n++getRightMostNodeNative :: Tree1 Int -> Int+getRightMostNodeNative (Leaf1 n) = n+getRightMostNodeNative (Node1 _ r) = getRightMostNodeNative r++getRightMostNodePacked :: PackedReader '[Tree1 Int] r Int+getRightMostNodePacked =+ caseTree1+ reader+ (skip R.>> getRightMostNodePacked)++getRightMostNodePackedNonMonadic :: Packed (Tree1 Int ': r) -> IO Int+getRightMostNodePackedNonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Int, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ case tag of+ 0 -> do+ !n <- peek (plusPtr ptr 1)+ return (n, plusPtr ptr 9)+ 1 -> do+ (!_, !r) <- go (plusPtr ptr 1)+ (!right, !r1) <- go r+ return (right, r1)+ _ -> undefined++getRightMostNodePacked2 :: PackedReader '[Tree2 Int] '[] Int+getRightMostNodePacked2 =+ caseTree2+ readerWithFieldSize+ ( R.do+ skipWithFieldSize+ skip R.>> getRightMostNodePacked2+ )++getRightMostNodePacked2NonMonadic :: Packed (Tree2 Int ': r) -> IO Int+getRightMostNodePacked2NonMonadic packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ sizeOfFieldSize = sizeOf (1 :: Int32)+ sizeOfInt = sizeOf (1 :: Int)+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Int, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ let nextPtr = ptr `plusPtr` 1+ case tag of+ 0 -> do+ !n <- peek (plusPtr nextPtr sizeOfFieldSize)+ let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + sizeOfInt)+ return (n, nextPtr1)+ 1 -> do+ !fieldSize <- peek (castPtr nextPtr :: Ptr Int32)+ let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + fromIntegral fieldSize) `plusPtr` sizeOfFieldSize+ (!right, !r1) <- go nextPtr1+ return (right, r1)+ _ -> undefined++buildNativeTree :: Int -> Tree1 Int+buildNativeTree 0 = Leaf1 0+buildNativeTree n = Node1 subTree subTree+ where+ subTree = buildNativeTree (n - 1)++-- Contains++compareContainsValue :: Int -> Benchmark+compareContainsValue n =+ bgroup+ (depthGroupName n)+ [ bench nativeTestName $ nf (containsNative value) nativeTree+ , bench packedTestName $ nfAppIO (runReader (containsPacked value)) packedTree+ , bench nonMonadicPackedTestName $ nfAppIO (containsNonMonadic value) packedTree+ , bench packedWithFieldSizeTestName $+ nfAppIO (runReader (containsPacked2 value)) packedTreeWithSize+ , bench nonMonadicPackedWithSizeTestName $ nfAppIO (containsNonMonadic2 value) packedTreeWithSize+ ]+ where+ packedTree = pack nativeTree+ packedTreeWithSize = pack (tree1ToTree2 nativeTree)+ tree1ToTree2 (Leaf1 l) = Leaf2 l+ tree1ToTree2 (Node1 a b) = Node2 (tree1ToTree2 a) (tree1ToTree2 b)+ nativeTree = buildNativeTreeContains n value+ value = 500++containsNative :: Int -> Tree1 Int -> Bool+containsNative value (Leaf1 n) = n == value+containsNative value (Node1 s1 s2) = containsNative value s1 || containsNative value s2++containsPacked :: Int -> PackedReader '[Tree1 Int] r Bool+containsPacked n =+ caseTree1+ ( R.do+ i <- reader+ R.return (i == n)+ )+ ( R.do+ s1 <- containsPacked n+ if s1 then skip R.>> R.return s1 else containsPacked n+ )++containsPacked2 :: Int -> PackedReader '[Tree2 Int] r Bool+containsPacked2 n =+ caseTree2+ ( R.do+ i <- readerWithFieldSize+ R.return (i == n)+ )+ ( R.do+ s1 <- skip R.>> containsPacked2 n+ if s1 then skipWithFieldSize R.>> R.return s1 else skip R.>> containsPacked2 n+ )++containsNonMonadic :: Int -> Packed (Tree1 Int ': r) -> IO Bool+containsNonMonadic n packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Bool, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ case tag of+ 0 -> do+ !i <- peek (plusPtr ptr 1)+ return (i == n, plusPtr ptr 9)+ 1 -> do+ (!b, !r) <- go (plusPtr ptr 1)+ if b+ then do+ (!_, !r1) <- go r+ return (True, r1)+ else do+ (!right, !r1) <- go r+ return (right, r1)+ _ -> undefined++containsNonMonadic2 :: Int -> Packed (Tree2 Int ': r) -> IO Bool+containsNonMonadic2 n packed = fst <$> go (unsafeForeignPtrToPtr fptr)+ where+ sizeOfFieldSize = sizeOf (1 :: Int32)+ sizeOfInt = sizeOf (1 :: Int)+ (BS fptr _) = fromPacked packed+ go :: Ptr Word8 -> IO (Bool, Ptr Word8)+ go ptr = do+ tag <- peek ptr :: IO Word8+ let nextPtr = ptr `plusPtr` 1+ case tag of+ 0 -> do+ !i <- peek (plusPtr nextPtr sizeOfFieldSize)+ let nextPtr1 = nextPtr `plusPtr` (sizeOfFieldSize + sizeOfInt)+ return (i == n, nextPtr1)+ 1 -> do+ let subTree1Ptr = nextPtr `plusPtr` sizeOfFieldSize+ (!b, !nextPtr1) <- go subTree1Ptr+ if b+ then do+ !fieldSize <- peek (castPtr nextPtr1 :: Ptr Int32)+ return (True, castPtr $ nextPtr1 `plusPtr` (sizeOfFieldSize + fromIntegral fieldSize))+ else go (nextPtr1 `plusPtr` sizeOfFieldSize)+ _ -> undefined++buildNativeTreeContains :: Int -> Int -> Tree1 Int+buildNativeTreeContains 0 _ = Leaf1 0+buildNativeTreeContains 1 n = Node1 (Leaf1 n) (buildNativeTreeContains 0 n)+buildNativeTreeContains depth n = Node1 subTree subTree+ where+ subTree = buildNativeTreeContains (depth - 1) n
+ benchmark/tree/Utils.hs view
@@ -0,0 +1,41 @@+module Utils (+ toRight,+ cTestName,+ nativeTestName,+ packedTestName,+ packedWithUnpackTestName,+ nonMonadicPackedTestName,+ packedWithFieldSizeTestName,+ nonMonadicPackedWithSizeTestName,+ depthGroupName,+) where++import Text.Printf++toRight :: Either b a -> a+toRight (Right a) = a+toRight _ = error "unexpected left"++cTestName :: String+cTestName = "c"++nativeTestName :: String+nativeTestName = "native"++packedTestName :: String+packedTestName = "packed"++packedWithUnpackTestName :: String+packedWithUnpackTestName = "packed-unpacked"++nonMonadicPackedTestName :: String+nonMonadicPackedTestName = "non-monadic-" ++ packedTestName++packedWithFieldSizeTestName :: String+packedWithFieldSizeTestName = "packed-with-size"++nonMonadicPackedWithSizeTestName :: String+nonMonadicPackedWithSizeTestName = "non-monadic-" ++ packedWithFieldSizeTestName++depthGroupName :: Int -> String+depthGroupName = printf "%02d-depth"
+ benchmark/tree/benchmark.c view
@@ -0,0 +1,213 @@++#include "benchmark.h"+#include <assert.h>+#include <math.h>+#include <stddef.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <time.h>++// static long get_nanos(void) {+// struct timespec ts;+// timespec_get(&ts, TIME_UTC);+// return (long)ts.tv_sec * 1000000000L + ts.tv_nsec;+// }++//// AST++long eval(struct AST *t) {+ long left;+ long right;+ switch (t->tag) {+ case VAL:+ return t->value;+ case ADD:+ left = eval(t->left);+ right = eval(t->right);+ return left + right;+ case SUB:+ left = eval(t->left);+ right = eval(t->right);+ return left - right;+ case MUL:+ left = eval(t->left);+ right = eval(t->right);+ return left * right;+ case DIV:+ left = eval(t->left);+ right = eval(t->right);+ return left / right;+ }+}++struct AST *build_ast(int size) {+ struct AST *t = malloc(sizeof(struct AST));++ if (size <= 0) {+ t->tag = VAL;+ t->value = 1;+ } else {+ t->tag = ADD;+ t->left = build_ast(size - 1);+ t->right = build_ast(size - 1);+ }++ return t;+}++void free_ast(struct AST *t) {++ if (t->tag != VAL) {+ free_ast(t->left);+ free_ast(t->right);+ }+ free(t);+}++/// Tree+long sum(struct Tree *t) {+ if (t->tag == LEAF) {+ return t->value;+ } else {+ return sum(t->left) + sum(t->right);+ }+}++long get_right_most(struct Tree *t) {+ if (t->tag == LEAF) {+ return t->value;+ } else {+ return get_right_most(t->right);+ }+}++struct Tree *increment(struct Tree *t) {+ struct Tree *res = malloc(sizeof(struct Tree));+ if (t->tag == LEAF) {+ res->left = NULL;+ res->right = NULL;+ res->value = t->value + 1;+ } else {+ res->left = increment(t->left);+ res->right = increment(t->right);+ }+ return res;+}++void increment_inplace(struct Tree *t) {+ if (t->tag == LEAF) {+ t->value++;+ } else {+ increment(t->left);+ increment(t->right);+ }+}++struct Tree *build_tree(int size) {+ struct Tree *t = malloc(sizeof(struct Tree));++ if (size <= 0) {+ t->tag = LEAF;+ t->value = 1;+ } else {+ t->tag = NODE;+ t->left = build_tree(size - 1);+ t->right = build_tree(size - 1);+ }++ return t;+}++void free_tree(struct Tree *t) {++ if (t->tag == NODE) {+ free_tree(t->left);+ free_tree(t->right);+ }+ free(t);+}++////////++// void time_sum(int size, struct Tree *tree) {+// long begin = get_nanos();+//+// long res = sum(tree);+//+// long time_spent = (get_nanos() - begin);+//+// assert(res == pow(2, size));+// free_tree(tree);+// // todo free tree+// printf("Size: %d\n", size);+// printf("Execution time %ldns\n", time_spent);+// }+//+// void time_traversal(int size, struct Tree *tree) {+// long begin = get_nanos();+//+// long res = get_right_most(tree);+//+// long time_spent = (get_nanos() - begin);+//+// free_tree(tree);+// printf("Size: %d\n", size);+// printf("Execution time %ldns\n", time_spent);+// }++// void time_eval(int size, struct AST *tree) {+// long begin = get_nanos();+//+// long res = eval(tree);+//+// long time_spent = (get_nanos() - begin);+//+// free_ast(tree);+// printf("Size: %d\n", size);+// printf("Execution time %ldns\n", time_spent);+// }+//+// int main(int argc, char **argv) {+// // TODO Check "sum", "right-most"+// if (argc < 2) {+// printf("Expected at least one argument\n");+// return 1;+// }+// if (strcmp(argv[1], "sum") == 0) {+// printf("right-most\n");+// if (argc == 3) {+//+// int tree_size = atoi(argv[2]);+// time_sum(tree_size, build_tree(tree_size));+// return 0;+// }+// for (int tree_size = 0; tree_size <= 20; tree_size++) {+//+// time_sum(tree_size, build_tree(tree_size));+// }+// } else if (strcmp(argv[1], "right-most") == 0) {+// printf("right-most\n");+// if (argc == 3) {+// int tree_size = atoi(argv[2]);+// time_traversal(tree_size, build_tree(tree_size));+// return 0;+// }+// for (int tree_size = 0; tree_size <= 20; tree_size++) {+//+// time_traversal(tree_size, build_tree(tree_size));+// }+//+// } else if (strcmp(argv[1], "ast") == 0) {+// printf("ast\n");+// if (argc == 3) {+// int tree_size = atoi(argv[2]);+// time_eval(tree_size, build_ast(tree_size));+// return 0;+// }+// for (int tree_size = 0; tree_size <= 20; tree_size++) {+//+// time_eval(tree_size, build_ast(tree_size));+// }+// }+// }
+ examples/Increment.hs view
@@ -0,0 +1,29 @@+-- | Showcase how to 'mutate' packed data+module Increment (incrementRunner) where++import Data.Packed+import Data.Packed.Needs+import qualified Data.Packed.Needs as N+import qualified Data.Packed.Reader as R+import Tree++$(mkPacked ''Tree [])++incrementRunner :: Packed '[Tree Int] -> IO (Packed '[Tree Int])+incrementRunner p = do+ (incremented, _) <- runReader incrementPacked p+ return $ finish incremented++-- The workhouse of the incrementation+incrementPacked :: PackedReader '[Tree Int] r (Needs '[] '[Tree Int])+incrementPacked =+ transformTree+ ( R.do+ n <- reader+ R.return (write (n + 1))+ )+ ( R.do+ left <- incrementPacked+ right <- incrementPacked+ R.return (applyNeeds left N.>> applyNeeds right)+ )
+ examples/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = return ()
+ examples/Pack.hs view
@@ -0,0 +1,22 @@+-- | Showcase how to 'mutate' packed data+module Pack () where++import Data.Packed+import qualified Data.Packed.Needs as N+import Tree++$(mkPacked ''Tree [])++myTree :: Tree Int+myTree = Node (Leaf 1) (Leaf 2)++packedTree :: Packed '[Tree Int]+packedTree = pack myTree++buildTree :: Packed '[Tree Int]+buildTree =+ finish $+ withEmptyNeeds $ N.do+ startNode+ startLeaf N.>> write (1 :: Int)+ startLeaf N.>> write 2
+ examples/Traversal.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE BangPatterns #-}++module Traversal () where++import Data.Packed+import qualified Data.Packed.Reader as R+import Tree++$(mkPacked ''Tree [])++myTree :: Tree Int+myTree = Node (Leaf 1) (Leaf 2)++packedTree :: Packed '[Tree Int]+packedTree = pack myTree++sumPacked :: PackedReader '[Tree Int] r Int+sumPacked =+ caseTree+ ( R.do+ !n <- reader+ R.return n+ )+ ( R.do+ !left <- sumPacked+ !right <- sumPacked+ let !res = left + right+ R.return res+ )++runSum :: IO Int+runSum = do+ (res, _) <- runReader sumPacked packedTree+ return res
+ examples/Tree.hs view
@@ -0,0 +1,3 @@+module Tree where++data Tree a = Leaf a | Node (Tree a) (Tree a)
+ examples/Unpack.hs view
@@ -0,0 +1,15 @@+module Unpack () where++import Data.Packed+import Tree++$(mkPacked ''Tree [])++myTree :: Tree Int+myTree = Node (Leaf 1) (Leaf 2)++packedTree :: Packed '[Tree Int]+packedTree = pack myTree++unpackedTree :: Tree Int+unpackedTree = fst $ unpack packedTree
packed-data.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: packed-data-version: 0.1.0.1+version: 0.1.0.2 description: Build, traverse and deserialise packed data in Haskell category: Data homepage: https://github.com/Arthi-chaud/packed-haskell#readme@@ -37,6 +37,7 @@ Data.Packed.Needs Data.Packed.Instances Data.Packed.TH+ Data.Packed.TH.Utils Data.Packed.Skippable other-modules: Data.Packed.FieldSize@@ -53,7 +54,6 @@ Data.Packed.TH.Start Data.Packed.TH.Transform Data.Packed.TH.Unpackable- Data.Packed.TH.Utils Data.Packed.TH.Write Data.Packed.TH.WriteCon Data.Packed.Unpackable@@ -85,14 +85,19 @@ , template-haskell >=2.18.0.0 && <=2.24.0.0 default-language: Haskell2010 -executable packed-exe+executable examples main-is: Main.hs other-modules:+ Increment+ Pack+ Traversal+ Tree+ Unpack Paths_packed_data autogen-modules: Paths_packed_data hs-source-dirs:- app+ examples default-extensions: DataKinds TypeOperators@@ -103,13 +108,10 @@ TemplateHaskellQuotes TupleSections QualifiedDo- ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wno-unused-top-binds build-depends: base >=4.7 && <5- , deepseq- , mtl , packed-data- , time default-language: Haskell2010 test-suite packed-test@@ -203,10 +205,42 @@ , packed-data default-language: Haskell2010 -benchmark packed-bench+benchmark report type: exitcode-stdio-1.0 main-is: Main.hs other-modules:+ Criterion+ Go+ Types+ Paths_packed_data+ autogen-modules:+ Paths_packed_data+ hs-source-dirs:+ benchmark/report+ default-extensions:+ DataKinds+ TypeOperators+ KindSignatures+ GADTs+ LambdaCase+ TemplateHaskell+ TemplateHaskellQuotes+ TupleSections+ QualifiedDo+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-T -O2 -Wno-unused-top-binds -Wno-orphans -Wno-redundant-constraints+ build-depends:+ base >=4.7 && <5+ , bytestring+ , cassava+ , directory+ , process+ , scientific+ default-language: Haskell2010++benchmark tree-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules: AST Build CIReport@@ -214,7 +248,6 @@ List OutputData Pack- Plot Sum Traversals Utils@@ -222,7 +255,7 @@ autogen-modules: Paths_packed_data hs-source-dirs:- benchmark+ benchmark/tree default-extensions: DataKinds TypeOperators@@ -238,11 +271,9 @@ include-dirs: benchmark c-sources:- benchmark/benchmark.c+ benchmark/tree/benchmark.c build-depends:- Chart- , Chart-diagrams- , aeson+ aeson , base >=4.7 && <5 , bytestring , cassava
src/Data/Packed/Packed.hs view
@@ -1,12 +1,20 @@-module Data.Packed.Packed (Packed (..), unsafeToPacked, unsafeToPacked', fromPacked, unsafeCastPacked, duplicate) where+module Data.Packed.Packed (+ Packed (..),+ unsafeToPacked,+ unsafeToPacked',+ fromPacked,+ unsafeCastPacked,+ duplicate,+ getPtr,+) where import Control.DeepSeq import Data.ByteString (copy) import Data.ByteString.Internal import Data.Kind (Type)-import Foreign (Ptr)+import Foreign.Ptr import GHC.Exts (Ptr (Ptr))-import GHC.ForeignPtr (ForeignPtr (ForeignPtr), ForeignPtrContents (FinalPtr))+import GHC.ForeignPtr -- | A buffer that contains one or more packed (i.e. serialised) values. -- The order of the values in the buffer is defined by the 'l' type list@@ -39,3 +47,6 @@ unsafeToPacked' :: Ptr a -> Int -> Packed b unsafeToPacked' (Ptr addr) l = Packed (BS (ForeignPtr addr FinalPtr) l)++getPtr :: Packed a -> Ptr b+getPtr p = let BS fptr _ = fromPacked p in castPtr $ unsafeForeignPtrToPtr fptr
src/Data/Packed/TH/Case.hs view
@@ -2,11 +2,9 @@ module Data.Packed.TH.Case (caseFName, genCase) where -import Data.Packed.FieldSize import Data.Packed.Reader hiding (return) import Data.Packed.TH.Flag-import Data.Packed.TH.Utils (Tag, getNameAndBangTypesFromCon, resolveAppliedType, sanitizeConName)-import Data.Packed.Utils ((:++:))+import Data.Packed.TH.Utils (Tag, getBranchesTyList, getNameAndBangTypesFromCon, resolveAppliedType, sanitizeConName) import Language.Haskell.TH caseFName :: Name -> Name@@ -89,27 +87,19 @@ genCaseSignature :: [PackingFlag] -> Name -> Q Dec genCaseSignature flags tyName = do (sourceType, _) <- resolveAppliedType tyName- (TyConI (DataD _ _ _ _ cs _)) <- reify tyName bVar <- newName "b" rVar <- newName "r"+ branchesTypes <- getBranchesTyList tyName flags let bType = varT bVar rType = varT rVar- lambdaTypes = (\c -> buildLambdaType c bType rType) <$> cs+ lambdaTypes = (\branchTypes -> buildLambdaType branchTypes bType rType) <$> branchesTypes outType = [t|PackedReader '[$(return sourceType)] $rType $bType|] signature <- foldr (\lambda out -> [t|$lambda -> $out|]) outType lambdaTypes return $ SigD (caseFName tyName) signature where -- From a constructor (say Leaf a), build type PackedReader '[a] r b- buildLambdaType con returnType restType = do- let constructorTypeNames = snd <$> snd (getNameAndBangTypesFromCon con)- packedContentType =- foldr- ( \(i, x) xs ->- if (InsertFieldSize `elem` flags) && (SkipLastFieldSize `notElem` flags || (SkipLastFieldSize `elem` flags && i /= 1))- then [t|'[FieldSize, $(return x)] :++: $xs|]- else [t|$(return x) ': $xs|]- )- [t|'[]|]- $ zip (reverse [0 .. length constructorTypeNames]) constructorTypeNames- [t|PackedReader ($packedContentType) $restType $returnType|]+ buildLambdaType :: [Type] -> Q Type -> Q Type -> Q Type+ buildLambdaType branchType returnType restType = do+ let branchTypeList = foldr (\a rest -> [t|$(return a) ': $rest|]) [t|'[]|] branchType+ [t|PackedReader $branchTypeList $restType $returnType|]
src/Data/Packed/TH/Read.hs view
@@ -56,39 +56,34 @@ genReadLambdas :: [PackingFlag] -> Name -> Q [Exp] genReadLambdas flags tyName = do (TyConI (DataD _ _ _ _ cs _)) <- reify tyName- mapM- ( \con ->- let (conName, bt) = getNameAndBangTypesFromCon con- in genReadLambda flags conName (snd <$> bt)- )- cs+ genReadLambda flags `mapM` cs -- generates a single lambda to use with caseTree for our unpack method-genReadLambda :: [PackingFlag] -> Name -> [Type] -> Q Exp-genReadLambda flags conName conParameterTypes = do+genReadLambda :: [PackingFlag] -> Con -> Q Exp+genReadLambda flags con = do let appliedConstructor = foldl (\rest arg -> AppE rest $ VarE arg) (ConE conName) $ (\i -> mkName $ "arg" ++ show i)- <$> [0 .. (length conParameterTypes - 1)]+ <$> [0 .. (length conParamTypes - 1)] buildBindingExpression appliedConstructor where- hasSizeFlag = InsertFieldSize `elem` flags- skipLastFieldSizeFlag = SkipLastFieldSize `elem` flags+ (conName, conParamTypes) = getNameAndBangTypesFromCon con buildBindingExpression :: Exp -> Q Exp buildBindingExpression appliedConstructor = foldr- ( \(argIndex, hasSize) ret ->- let- skipAndUnpack = [|skip R.>> $unpackExpr|]- unpackExpr = [|reader R.>>= \($(varP $ mkName $ "arg" ++ show argIndex)) -> $ret|]- in- if hasSize then skipAndUnpack else unpackExpr+ ( \(_, idx, needsFS) ret ->+ let skipExpr = [|skip R.>> $readerExpr|]+ readerExpr = [|reader R.>>= \($(varP $ mkName $ "arg" ++ show idx)) -> $ret|]+ in if needsFS+ then skipExpr+ else readerExpr ) [|R.return ($(parensE (return appliedConstructor)))|]- $ (\i -> (i, hasSizeFlag && (not skipLastFieldSizeFlag || (skipLastFieldSizeFlag && i /= length conParameterTypes - 1))))- <$> [0 .. (length conParameterTypes - 1)]+ (getConFieldsIdxAndNeedsFS con flags)++-- genReadLambda flags conName conParameterTypes = do -- For a type 'Tree', generates the following function signature -- readTree :: ('Unpackable' a) => 'Data.Packed.PackedReader' '[Tree a] r (Tree a)
src/Data/Packed/TH/RepackCon.hs view
@@ -24,39 +24,29 @@ genConstructorRepackers :: [PackingFlag] -> Name -> Q [Dec] genConstructorRepackers flags tyName = do (TyConI (DataD _ _ _ _ cs _)) <- reify tyName- packers <-- mapM- ( \con ->- let (conName, bt) = getNameAndBangTypesFromCon con- in genConstructorRepacker flags conName (snd <$> bt)- )- cs+ packers <- genConstructorRepacker flags `mapM` cs return $ concat packers repackConFName :: Name -> Name repackConFName conName = mkName $ "repack" ++ sanitizeConName conName -genConstructorRepacker :: [PackingFlag] -> Name -> [Type] -> Q [Dec]-genConstructorRepacker flags conName argTypes = do- let argCount = length argTypes- needsFieldSize i =- (InsertFieldSize `elem` flags)- && ( (SkipLastFieldSize `notElem` flags)- || i < argCount - 1- )- varNames <- mapM (\_ -> newName "t") argTypes+genConstructorRepacker :: [PackingFlag] -> Con -> Q [Dec]+genConstructorRepacker flags con = do+ let conName = fst $ getNameAndBangTypesFromCon con+ fieldTypes = getConFieldsIdxAndNeedsFS con flags+ varNames <- mapM (\_ -> newName "t") fieldTypes writeExp <- let concated = foldl- ( \rest (i, p) ->- if needsFieldSize i- then [|($rest) N.>> applyNeedsWithFieldSize $(varE p)|]- else [|($rest) N.>> applyNeeds $(varE p)|]+ ( \rest ((_, _, needsFieldSize), varName) ->+ if needsFieldSize+ then [|($rest) N.>> applyNeedsWithFieldSize $(varE varName)|]+ else [|($rest) N.>> applyNeeds $(varE varName)|] ) [|$(varE $ startFName conName)|]- (zip [0 ..] varNames)+ (zip fieldTypes varNames) in [|withEmptyNeeds $concated|]- signature <- genConstructorPackerSig flags conName argTypes+ signature <- genConstructorPackerSig flags conName ((\(t, _, _) -> t) <$> fieldTypes) return [ signature , FunD (repackConFName conName) [Clause (VarP <$> varNames) (NormalB writeExp) []]
src/Data/Packed/TH/Skip.hs view
@@ -41,31 +41,19 @@ -- Generates all the lambda functions we will need, to skip using caseTree genSkipLambdas :: [PackingFlag] -> Name -> Q [Exp] genSkipLambdas flags tyName = do- (TyConI (DataD _ _ _ _ cs _)) <- reify tyName- mapM- ( \con ->- let (_, bt) = getNameAndBangTypesFromCon con- in genSkipLambda flags (snd <$> bt)- )- cs+ branchTypes <- getBranchesTyList tyName flags+ genSkipLambda `mapM` branchTypes -- generates a single lambda to use with caseTree for our skip method-genSkipLambda :: [PackingFlag] -> [Type] -> Q Exp-genSkipLambda flags conParameterTypes =- foldr- ( \hasSize ret ->- let- skipFSAndSkipField = [|skipWithFieldSize R.>> $ret|]- skipField = [|skip R.>> $ret|]- in- if hasSize then skipFSAndSkipField else skipField- )- [|R.return ()|]- $ (\i -> hasSizeFlag && (not skipLastFieldSizeFlag || (skipLastFieldSizeFlag && i /= length conParameterTypes - 1)))- <$> [0 .. (length conParameterTypes - 1)]+genSkipLambda :: [Type] -> Q Exp+genSkipLambda types = go types [|R.return ()|] where- hasSizeFlag = InsertFieldSize `elem` flags- skipLastFieldSizeFlag = SkipLastFieldSize `elem` flags+ go [] end = end+ go [_] end = [|skip R.>> $end|]+ go (t1 : t2 : ts) end =+ if typeIsFieldSize t1+ then [|skipWithFieldSize R.>> $(go ts end)|]+ else [|skip R.>> $(go (t2 : ts) end)|] -- Generates the following function signature for a data type 'Tree' -- skipTree :: ('Data.Packed.Skippable' a) => 'Data.Packed.PackedReader' '[Tree a] r ()
src/Data/Packed/TH/Start.hs view
@@ -1,6 +1,5 @@ module Data.Packed.TH.Start (startFName, genStart) where -import Data.Packed.FieldSize import Data.Packed.Needs import Data.Packed.Packable (write) import Data.Packed.TH.Flag (PackingFlag (..))@@ -27,35 +26,22 @@ -- @ genStart :: [PackingFlag] ->- -- | The name of the data constructor to generate the function for- Name ->+ -- | Constructor to generate the function for+ Con -> -- | The 'Tag' (byte) to write for this constructor Tag ->- -- | The list of 'Type's of the data constructor's arguments- [Type] -> Q [Dec]-genStart flags conName tag paramTypeList = do- let fName = startFName conName- constructorParamTypes = return <$> paramTypeList+genStart flags con tag = do+ branchType <- getBranchTyList con flags+ let (conName, _) = getNameAndBangTypesFromCon con+ fName = startFName conName (DataConI _ conType _) <- reify conName sig <- let r = varT $ mkName "r" t = varT $ mkName "t"- insertFieldSizes = InsertFieldSize `elem` flags- skipLastFieldSize = SkipLastFieldSize `elem` flags- -- From the list of the constructor's parameters, generate the correct type for 'Data.Packed.Needs'- -- For Leaf a, we will obtain Needs (a ': r)- -- For node, if size flag is enabled, we will get Needs (FieldSize ': Tree a ': FieldSize ': Tree a ': r)- destNeedsTypeParams =- foldr- ( \(i, x) xs ->- if insertFieldSizes && (not skipLastFieldSize || (skipLastFieldSize && i /= 1))- then [t|FieldSize ': $x ': $xs|]- else [t|$x ': $xs|]- )- r- $ zip (reverse [0 .. length constructorParamTypes]) constructorParamTypes- in [t|NeedsBuilder ($(return $ getParentTypeFromConstructorType conType) ': $r) $t $destNeedsTypeParams $t|]+ destNeedsTypeParams = foldr (\field rest -> [t|$(return field) ': $rest|]) r branchType+ parentType = getParentTypeFromConstructorType conType+ in [t|NeedsBuilder ($(return parentType) ': $r) $t $destNeedsTypeParams $t|] expr <- [|mkNeedsBuilder (\n -> runBuilder (write (tag :: Word8)) (unsafeCastNeeds n))|] return [ SigD fName sig
src/Data/Packed/TH/Transform.hs view
@@ -2,7 +2,7 @@ import Data.Maybe (catMaybes) import Data.Packed.FieldSize (FieldSize)-import Data.Packed.Needs (withEmptyNeeds, (:++:))+import Data.Packed.Needs (withEmptyNeeds) import qualified Data.Packed.Needs as N import Data.Packed.Reader (PackedReader) import qualified Data.Packed.Reader as R@@ -80,21 +80,24 @@ return $ SigD (transformFName tyName) signature where -- From a constructor (say Leaf a), build type PackedTransformer a r- buildLambdaType con ty restType = case snd <$> snd (getNameAndBangTypesFromCon con) of- [] -> Nothing- constructorTypeNames -> return $ do- packedContentType <-- foldr- ( \(i, x) xs ->- if (InsertFieldSize `elem` flags) && (SkipLastFieldSize `notElem` flags || (SkipLastFieldSize `elem` flags && i /= 1))- then [t|'[FieldSize, $(return x)] :++: $xs|]- else [t|$(return x) ': $xs|]- )- [t|'[]|]- $ zip (reverse [0 .. length constructorTypeNames]) constructorTypeNames- [t|- PackedReader- $(return packedContentType)- $restType- (N.NeedsBuilder $(return packedContentType) '[$(return ty)] '[] '[$(return ty)])- |]+ buildLambdaType con ty restType =+ if null fieldType+ then Nothing+ else return $ do+ packedContentType <-+ foldr+ ( \(fieldTy, _, needsFS) tys ->+ if needsFS+ then [t|FieldSize ': $(return fieldTy) ': $tys|]+ else [t|$(return fieldTy) ': $tys|]+ )+ [t|'[]|]+ fieldType+ [t|+ PackedReader+ $(return packedContentType)+ $restType+ (N.NeedsBuilder $(return packedContentType) '[$(return ty)] '[] '[$(return ty)])+ |]+ where+ fieldType = getConFieldsIdxAndNeedsFS con flags
src/Data/Packed/TH/Utils.hs view
@@ -4,9 +4,17 @@ resolveAppliedType, getNameAndBangTypesFromCon, sanitizeConName,+ getBranchesTyList,+ getBranchTyList,+ typeIsFieldSize,+ getConFieldsIdxAndNeedsFS, ) where +import Control.Monad import Data.Char+import Data.Functor+import Data.Packed.FieldSize (FieldSize)+import Data.Packed.TH.Flag import Data.Word (Word8) import Language.Haskell.TH @@ -49,3 +57,38 @@ sanitizeConName conName = strName $ nameBase conName where strName s = (\c -> if isAlphaNum c then [c] else show $ ord c) =<< s++-- | for a given type, and the packing flags, gives back the list of types for each branch+--+-- @+-- getBranchesTyList ''Tree ['InsertFieldSize']+--+-- > [[FieldSize, Int], [FieldSize, Tree a, FieldSize, Tree a]]+-- @+getBranchesTyList :: Name -> [PackingFlag] -> Q [[Type]]+getBranchesTyList tyName flags = do+ (TyConI (DataD _ _ _ _ cs _)) <- reify tyName+ forM cs (`getBranchTyList` flags)++getBranchTyList :: Con -> [PackingFlag] -> Q [Type]+getBranchTyList con flags = do+ fields <- forM (getConFieldsIdxAndNeedsFS con flags) $ \(fieldTy, _, needsFS) ->+ if needsFS+ then [t|FieldSize|] <&> (: [fieldTy])+ else return [fieldTy]+ return $ concat fields++getConFieldsIdxAndNeedsFS :: Con -> [PackingFlag] -> [(Type, Int, Bool)]+getConFieldsIdxAndNeedsFS con flags =+ consValueTypesWithIndex <&> \(valIdx, valTy) ->+ if (InsertFieldSize `elem` flags)+ && (SkipLastFieldSize `notElem` flags || (SkipLastFieldSize `elem` flags && valIdx /= consValueCount - 1))+ then (valTy, valIdx, True)+ else (valTy, valIdx, False)+ where+ consValueTypes = snd <$> snd (getNameAndBangTypesFromCon con)+ consValueCount = length consValueTypes+ consValueTypesWithIndex = zip [0 .. length consValueTypes] consValueTypes++typeIsFieldSize :: Type -> Bool+typeIsFieldSize = (== ConT ''FieldSize)
src/Data/Packed/TH/Write.hs view
@@ -1,5 +1,6 @@ module Data.Packed.TH.Write (genWrite, writeFName) where +import Control.Monad import Data.Packed.Needs import Data.Packed.Packable import Data.Packed.TH.Flag (PackingFlag)@@ -45,13 +46,7 @@ cs -- For each of the data constructor of the type, we generate the corresponding `writeConXXX` -- We define the Tag using the index of the data constructor- conWriter <-- mapM- ( \(index, constructor) ->- let (conName, types) = getNameAndBangTypesFromCon constructor- in genConWrite flags conName index types- )- $ zip [0 ..] cs+ conWriter <- forM (zip [0 ..] cs) (\(index, con) -> genConWrite flags con index) signature <- genWriteSignature tyName return $ concat conWriter ++ [signature, FunD (writeFName tyName) clauses]
src/Data/Packed/TH/WriteCon.hs view
@@ -31,44 +31,38 @@ genConWrite :: [PackingFlag] -> -- | The name of the data constructor to generate the function for- Name ->+ Con -> -- | A unique (to the data type) 'Tag' to identify the packed data constructor. -- -- For example, for a 'Tree' data type, -- we would typically use '0' for the 'Leaf' constructor and '1' for the 'Node' constructor Tag ->- [BangType] -> Q [Dec]-genConWrite flags conName conIndex bangTypes = do- (DataConI _ conType _) <- reify conName- let r = VarT $ mkName "r"+genConWrite flags con tag = do+ let (conName, _) = getNameAndBangTypesFromCon con+ r = VarT $ mkName "r" t = VarT $ mkName "t" fName = conWriteFName conName- paramTypeList = snd <$> bangTypes- parentType = getParentTypeFromConstructorType conType- signature <- genConWriteSignature conName paramTypeList parentType r t+ paramTypes = getConFieldsIdxAndNeedsFS con flags+ parentType <- do+ DataConI _ conTy _ <- reify conName+ return $ getParentTypeFromConstructorType conTy+ signature <- genConWriteSignature conName ((\(ty, _, _) -> ty) <$> paramTypes) parentType r t -- for each parameter type, we create a name- varNameAndType <- mapM (\ty -> (,ty) <$> newName "t") paramTypeList- -- we either call `encode` for every type parameter, and fold+ fieldTypeAndName <- mapM (\ty -> (ty,) <$> newName "t") paramTypes body <- foldl- ( \rest (paramName, needsSizeTag) ->+ ( \rest ((_, _, needsFS), paramName) -> -- We insert the size before- if needsSizeTag+ if needsFS then [|$rest N.>> writeWithFieldSize $(varE paramName)|] else [|$rest N.>> write $(varE paramName)|] ) [|$(varE $ startFName conName)|]- ( if InsertFieldSize `elem` flags- then case reverse varNameAndType of- -- Here, 'a' is the last field. We insert a FieldSize iff SkipLastFieldSize is not set- (a : b) -> reverse $ (fst a, SkipLastFieldSize `notElem` flags) : ((,True) . fst <$> b)- x -> reverse $ (,True) . fst <$> x- else (,False) . fst <$> varNameAndType- )+ fieldTypeAndName -- The pattern (lhs of '=' in a function implementation) will be something like '\a needs' for constructor 'Leaf a'- let patt = VarP . fst <$> varNameAndType- start <- genStart flags conName conIndex (snd <$> bangTypes)+ let patt = VarP . snd <$> fieldTypeAndName+ start <- genStart flags con tag return $ start ++ [ signature