Сравнение производительности языков на примере простейшего классификатора

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE BangPatterns, MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}
module Main where 

import Criterion
import Criterion.Main
import Control.DeepSeq
import GHC.Generics (Generic)
import qualified Data.ByteString.Char8 as BS
import qualified Data.Vector.Unboxed as V
import Data.ByteString.Read
import Data.Maybe

import qualified Data.Vector.Generic         as G
import qualified Data.Vector.Generic.Mutable as M
import Control.Monad 

data Measure = Measure {-# UNPACK #-} !Float {-# UNPACK #-} !Float
  deriving (Generic)

instance NFData Measure 

instance Num Measure where 
  (Measure x1 y1) + (Measure x2 y2) = Measure (x1+x2) (y1+y2)
  (Measure x1 y1) - (Measure x2 y2) = Measure (x1-x2) (y1-y2)
  (Measure x1 y1) * (Measure x2 y2) = Measure (x1*x2) (y1*y2)
  abs = undefined
  signum = undefined
  fromInteger i = Measure (fromIntegral i) (fromIntegral i)

instance Fractional Measure where 
  (Measure x1 y1) / (Measure x2 y2) = Measure (x1/x2) (y1/y2)
  fromRational = undefined

sqr :: Float -> Float 
sqr x = x*x

dist :: Measure -> Measure -> Float 
dist (Measure x1 y1) (Measure x2 y2) = sqrt $ sqr (x1 - x2) + sqr (y1 - y2)

data Class = Class !Measure !Int 
  deriving (Generic)

instance NFData Class 

instance Show Class where
  show (Class (Measure x y) i) = "[" ++ show x ++ ", " ++ show y ++ "]: " ++ show i 

newClass :: Measure -> Class 
newClass m = Class m 1 

append :: Class -> Measure -> Class
append (Class mean n) m = Class newMean (n+1)
  where newMean = ( mean * fromIntegral n + m ) / fromIntegral ( n + 1 )

merge :: Class -> Class -> Class 
merge (Class mean1 n1) (Class mean2 n2) = Class mean3 (n1+n2)
  where mean3 =  ( mean1 * fromIntegral n1 + mean2 * fromIntegral n2 ) / fromIntegral ( n1 + n2 );

classificate :: Float -> V.Vector Measure -> V.Vector Class
classificate nclsDist ms = V.foldl' go V.empty ms 
  where 
    go :: V.Vector Class -> Measure -> V.Vector Class
    go acc m 
      | V.null acc = V.singleton $ newClass m
      | otherwise = if minDist < nclsDist
        then newCls
        else (newClass m) `V.cons` newCls
      where 
        newCls = acc `V.unsafeUpd` [(nearClsI, nearCls `append` m)]
        (nearCls, nearClsI, minDist) = sortByDist acc m

    sortByDist :: V.Vector Class -> Measure -> (Class, Int, Float)
    sortByDist cs m = out $ V.ifoldl' checkDist (0, maxFloat) cs 
      where 
        maxFloat :: Float 
        maxFloat = 1/0

        out :: (Int, Float) -> (Class, Int, Float)
        out (i, d) = (V.unsafeIndex cs i, i, d)

        checkDist :: (Int, Float) -> Int -> Class -> (Int, Float)
        checkDist acc@(_, mdist) i (Class mean _) = if curDist < mdist 
          then (i, curDist)
          else acc
          where curDist = dist m mean

readMeasures :: BS.ByteString -> V.Vector Measure
readMeasures = V.fromList . catMaybes . fmap (go . BS.words) . BS.lines
  where go [a, b] = do
          (x, _) <- signed fractional a
          (y, _) <- signed fractional b 
          return $!! Measure x y
        go _ = Nothing
        
main :: IO ()
main = defaultMain [
    env (fmap readMeasures $ BS.readFile "data") $ \measures ->
      bench "classificate" $ nf (classificate 3) measures
  ]

-- | Алтернативная main функция для проверки правильности реализации
main2 :: IO ()
main2 = do 
  measures <- fmap readMeasures $ BS.readFile "data"
  print $ measures `deepseq` V.length measures
  let classes = classificate 3 measures
  print $ classes `deepseq` V.length classes 
  putStrLn $ unlines $ fmap show $ V.toList classes

-- | Далее идет boilerplate для реализации Unboxed векторов для кастомных типов

newtype instance V.MVector s Measure = MV_Measure (V.MVector s (Float,Float))
newtype instance V.Vector    Measure = V_Measure  (V.Vector    (Float,Float))

instance V.Unbox Measure

instance M.MVector V.MVector Measure where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength (MV_Measure v) = M.basicLength v
  basicUnsafeSlice i n (MV_Measure v) = MV_Measure $ M.basicUnsafeSlice i n v
  basicOverlaps (MV_Measure v1) (MV_Measure v2) = M.basicOverlaps v1 v2
  basicUnsafeNew n = MV_Measure `liftM` M.basicUnsafeNew n
  basicUnsafeReplicate n (Measure x y) = MV_Measure `liftM` M.basicUnsafeReplicate n (x,y)
  basicUnsafeRead (MV_Measure v) i = uncurry Measure `liftM` M.basicUnsafeRead v i
  basicUnsafeWrite (MV_Measure v) i (Measure x y) = M.basicUnsafeWrite v i (x,y)
  basicClear (MV_Measure v) = M.basicClear v
  basicSet (MV_Measure v) (Measure x y) = M.basicSet v (x,y)
  basicUnsafeCopy (MV_Measure v1) (MV_Measure v2) = M.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Measure v1) (MV_Measure v2) = M.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Measure v) n = MV_Measure `liftM` M.basicUnsafeGrow v n

instance G.Vector V.Vector Measure where
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE elemseq #-}
  basicUnsafeFreeze (MV_Measure v) = V_Measure `liftM` G.basicUnsafeFreeze v
  basicUnsafeThaw (V_Measure v) = MV_Measure `liftM` G.basicUnsafeThaw v
  basicLength (V_Measure v) = G.basicLength v
  basicUnsafeSlice i n (V_Measure v) = V_Measure $ G.basicUnsafeSlice i n v
  basicUnsafeIndexM (V_Measure v) i
                = uncurry Measure `liftM` G.basicUnsafeIndexM v i
  basicUnsafeCopy (MV_Measure mv) (V_Measure v)
                = G.basicUnsafeCopy mv v
  elemseq _ (Measure x y) z = G.elemseq (undefined :: V.Vector Float) x
                       $ G.elemseq (undefined :: V.Vector Float) y z



newtype instance V.MVector s Class = MV_Class (V.MVector s (Float, Float, Int))
newtype instance V.Vector    Class = V_Class  (V.Vector    (Float, Float, Int))

instance V.Unbox Class

instance M.MVector V.MVector Class where
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicOverlaps #-}
  {-# INLINE basicUnsafeNew #-}
  {-# INLINE basicUnsafeReplicate #-}
  {-# INLINE basicUnsafeRead #-}
  {-# INLINE basicUnsafeWrite #-}
  {-# INLINE basicClear #-}
  {-# INLINE basicSet #-}
  {-# INLINE basicUnsafeCopy #-}
  {-# INLINE basicUnsafeGrow #-}
  basicLength (MV_Class v) = M.basicLength v
  basicUnsafeSlice i n (MV_Class v) = MV_Class $ M.basicUnsafeSlice i n v
  basicOverlaps (MV_Class v1) (MV_Class v2) = M.basicOverlaps v1 v2
  basicUnsafeNew n = MV_Class `liftM` M.basicUnsafeNew n
  basicUnsafeReplicate n (Class (Measure x y) ni) = MV_Class `liftM` M.basicUnsafeReplicate n (x,y,ni)
  basicUnsafeRead (MV_Class v) i = (\(x,y,ni)->Class (Measure x y) ni) `liftM` M.basicUnsafeRead v i
  basicUnsafeWrite (MV_Class v) i (Class (Measure x y) ni) = M.basicUnsafeWrite v i (x,y, ni)
  basicClear (MV_Class v) = M.basicClear v
  basicSet (MV_Class v) (Class (Measure x y) ni) = M.basicSet v (x,y,ni)
  basicUnsafeCopy (MV_Class v1) (MV_Class v2) = M.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Class v1) (MV_Class v2) = M.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Class v) n = MV_Class `liftM` M.basicUnsafeGrow v n

instance G.Vector V.Vector Class where
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicUnsafeThaw #-}
  {-# INLINE basicLength #-}
  {-# INLINE basicUnsafeSlice #-}
  {-# INLINE basicUnsafeIndexM #-}
  {-# INLINE elemseq #-}
  basicUnsafeFreeze (MV_Class v) = V_Class `liftM` G.basicUnsafeFreeze v
  basicUnsafeThaw (V_Class v) = MV_Class `liftM` G.basicUnsafeThaw v
  basicLength (V_Class v) = G.basicLength v
  basicUnsafeSlice i n (V_Class v) = V_Class $ G.basicUnsafeSlice i n v
  basicUnsafeIndexM (V_Class v) i
                = (\(x,y,ni)->Class (Measure x y) ni) `liftM` G.basicUnsafeIndexM v i
  basicUnsafeCopy (MV_Class mv) (V_Class v)
                = G.basicUnsafeCopy mv v
  elemseq _ (Class (Measure x y) ni) z = G.elemseq (undefined :: V.Vector Float) x
                       $ G.elemseq (undefined :: V.Vector Float) y 
                       $ G.elemseq (undefined :: V.Vector Int) ni z 

name:                cls-bench
version:             0.1.0.0
license:             BSD3
license-file:        LICENSE
author:              Anton Gushcha
maintainer:          ncrashed@gmail.com
build-type:          Simple
cabal-version:       >=1.10

executable cls-bench
  main-is:             Main.hs
  build-depends:       base >= 4.7, criterion >= 1.1, deepseq, bytestring >= 0.10, bytestring-read >= 0.3, vector
  default-language:    Haskell2010
  ghc-options:         -O2 -threaded