From aeafc1692afa5952f3d06195916bb38463c1674c Mon Sep 17 00:00:00 2001 From: Justin Bedo Date: Sat, 1 Nov 2014 10:18:31 +1100 Subject: Benchmarking & optimisations --- LinProg.cabal | 18 ++++++++++++++++-- Math/LinProg/LP.hs | 9 +++++---- Math/LinProg/LPSolve.hs | 27 +++++++++++++++------------ Math/LinProg/LPSolve/FFI.hs | 13 ++++++++++++- Math/LinProg/LPSolve/bindings.c | 12 ++++++++++++ Math/LinProg/Types.hs | 22 ++++++++++++---------- bench.hs | 38 ++++++++++++++++++++++++++++++++++++++ default.nix | 4 ++++ 8 files changed, 114 insertions(+), 29 deletions(-) create mode 100644 Math/LinProg/LPSolve/bindings.c create mode 100644 bench.hs diff --git a/LinProg.cabal b/LinProg.cabal index 3751020..22b0f56 100644 --- a/LinProg.cabal +++ b/LinProg.cabal @@ -19,8 +19,22 @@ library exposed-modules: Math.LinProg.Types, Math.LinProg.LP, Math.LinProg.LPSolve other-modules: Math.LinProg.LPSolve.FFI extra-libraries: lpsolve55 - extensions: DeriveFunctor, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell, ScopedTypeVariables, ForeignFunctionInterface, ViewPatterns + other-extensions: DeriveFunctor, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell, ScopedTypeVariables, ForeignFunctionInterface, ViewPatterns build-depends: base >=4.7 && <4.8, recursion-schemes >=4.1 && <4.2, free >=4.9 && <4.10, containers >=0.5 && <0.6, lens >=4.4 && <4.5, mtl >=2.1 && <2.2, QuickCheck, unordered-containers, hashable -- hs-source-dirs: default-language: Haskell2010 - ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing + ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing + ghc-prof-options: -auto-all -caf-all + c-sources: Math/LinProg/LPSolve/bindings.c + +benchmark bench + type: exitcode-stdio-1.0 + main-is: bench.hs + extra-libraries: lpsolve55 + other-extensions: DeriveFunctor, FlexibleInstances, FlexibleContexts, UndecidableInstances, TemplateHaskell, ScopedTypeVariables, ForeignFunctionInterface, ViewPatterns + build-depends: base >=4.7 && <4.8, recursion-schemes >=4.1 && <4.2, free >=4.9 && <4.10, containers >=0.5 && <0.6, lens >=4.4 && <4.5, mtl >=2.1 && <2.2, QuickCheck, unordered-containers, hashable, criterion + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -rtsopts + ghc-prof-options: -auto-all -caf-all + c-sources: Math/LinProg/LPSolve/bindings.c diff --git a/Math/LinProg/LP.hs b/Math/LinProg/LP.hs index d1a1cf1..513bdad 100644 --- a/Math/LinProg/LP.hs +++ b/Math/LinProg/LP.hs @@ -24,11 +24,12 @@ module Math.LinProg.LP ( ,bins ) where -import Data.List -import Math.LinProg.Types import Control.Lens -import Data.Maybe import Control.Monad.Free +import Data.Hashable +import Data.List +import Data.Maybe +import Math.LinProg.Types type Equation t v = (LinExpr t v, t) -- LHS and RHS @@ -88,7 +89,7 @@ instance (Show t, Num t, Ord t) => Show (CompilerS t String) where render x = (if x >= 0 then "+" else "") ++ show x -findBounds :: (Eq v, Num t, Ord t, Eq t) => [Equation t v] -> ([(t, v, t)], [Equation t v]) +findBounds :: (Hashable v, Eq v, Num t, Ord t, Eq t) => [Equation t v] -> ([(t, v, t)], [Equation t v]) findBounds eqs = (mapMaybe bound singleTerms, eqs \\ filter (isBounded . head . vars . fst) singleTermEqs) where singleTermEqs = filter (\(ts, _) -> length (vars ts) == 1) eqs diff --git a/Math/LinProg/LPSolve.hs b/Math/LinProg/LPSolve.hs index 427c5d7..4e8385a 100644 --- a/Math/LinProg/LPSolve.hs +++ b/Math/LinProg/LPSolve.hs @@ -19,16 +19,18 @@ module Math.LinProg.LPSolve ( ) where import Control.Applicative -import Control.Monad -import Data.List +import Control.Arrow import Control.Lens -import Math.LinProg.LPSolve.FFI hiding (solve) -import qualified Math.LinProg.LPSolve.FFI as F +import Control.Monad +import Data.Hashable +import Data.List hiding (nub) import Math.LinProg.LP +import Math.LinProg.LPSolve.FFI hiding (solve) import Math.LinProg.Types +import Prelude hiding (EQ, nub) import qualified Data.HashMap.Strict as M -import Data.Hashable -import Prelude hiding (EQ) +import qualified Data.HashSet as S +import qualified Math.LinProg.LPSolve.FFI as F solve :: (Hashable v, Eq v, Ord v) => LinProg Double v () -> IO (Maybe ResultCode, [(v, Double)]) solve = solveWithTimeout 0 @@ -47,8 +49,7 @@ solveWithTimeout t (compile -> lp) = do let c = negate $ snd eq setConstrType m i EQ setRHS m i c - forM_ (varTerms (fst eq)) $ \(v, w) -> - setMat m i (varLUT M.! v) w + setRow' m i (fst eq) return () -- Leqs @@ -56,8 +57,7 @@ solveWithTimeout t (compile -> lp) = do let c = negate $ snd eq setConstrType m i LE setRHS m i c - forM_ (varTerms (fst eq)) $ \(v, w) -> - setMat m i (varLUT M.! v) w + setRow' m i (fst eq) return () -- Ints @@ -69,8 +69,7 @@ solveWithTimeout t (compile -> lp) = do setBin m (varLUT M.! v) -- Objective - forM_ (varTerms (lp ^. objective)) $ \(v, w) -> - void $ setMat m 0 (varLUT M.! v) w + setRow' m 0 (lp ^. objective) res <- F.solve m sol <- snd <$> getSol nvars m @@ -89,3 +88,7 @@ solveWithTimeout t (compile -> lp) = do r <- f m freeLP m return r + + nub = S.toList . S.fromList + + setRow' m i eq = setRow m i (map (first ((M.!) varLUT)) $ varTerms eq) diff --git a/Math/LinProg/LPSolve/FFI.hs b/Math/LinProg/LPSolve/FFI.hs index 64919b9..edf0a43 100644 --- a/Math/LinProg/LPSolve/FFI.hs +++ b/Math/LinProg/LPSolve/FFI.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface, ViewPatterns #-} module Math.LinProg.LPSolve.FFI ( ResultCode(..) ,ConstraintType(..) @@ -9,6 +9,7 @@ module Math.LinProg.LPSolve.FFI ( ,setBin ,makeLP ,freeLP + ,setRow ,setMat ,setRHS ,solve @@ -58,6 +59,7 @@ foreign import ccall "set_timeout" c_set_timeout :: LPRec -> CLong -> IO () foreign import ccall "set_int" c_set_int :: LPRec -> CInt -> CChar -> IO CChar foreign import ccall "set_binary" c_set_binary :: LPRec -> CInt -> CChar -> IO CChar foreign import ccall "print_debugdump" c_print_debugdump :: LPRec -> CString -> IO () +foreign import ccall "hs_set_row" c_hs_set_row :: LPRec -> CInt -> CInt -> Ptr CInt -> Ptr CDouble -> IO CChar debugDump :: LPRec -> FilePath -> IO () debugDump lp path = withCString path $ \str -> c_print_debugdump lp str @@ -82,6 +84,15 @@ freeLP m = with m $ \m' -> c_free_lp m' setMat :: LPRec -> Int -> Int -> Double -> IO Word8 setMat a b c d = fromIntegral <$> c_set_mat a (fromIntegral b) (fromIntegral c) (realToFrac d) +setRow :: LPRec -> Int -> [(Int, Double)] -> IO Word8 +setRow m row (unzip -> (cols, ws)) = fmap fromIntegral $ withArray (map fromIntegral cols) $ \c -> + withArray (map realToFrac ws) $ \w -> + c_hs_set_row m + (fromIntegral row) + (fromIntegral (length cols)) + c + w + setRHS :: LPRec -> Int -> Double -> IO Word8 setRHS a b c = fromIntegral <$> c_set_rh a (fromIntegral b) (realToFrac c) diff --git a/Math/LinProg/LPSolve/bindings.c b/Math/LinProg/LPSolve/bindings.c new file mode 100644 index 0000000..fbaf09f --- /dev/null +++ b/Math/LinProg/LPSolve/bindings.c @@ -0,0 +1,12 @@ +#include + +char +hs_set_row(void *model, int row, int n, int *cols, double *ws) +{ + int i; + + for(i = 0; i < n; i++) + set_mat(model, row, cols[i], ws[i]); + + return 0; +} diff --git a/Math/LinProg/Types.hs b/Math/LinProg/Types.hs index 4819dd3..d67e642 100644 --- a/Math/LinProg/Types.hs +++ b/Math/LinProg/Types.hs @@ -30,13 +30,14 @@ module Math.LinProg.Types ( ,int ) where -import Data.Functor.Foldable +import Control.Applicative import Control.Monad.Free +import Data.Functor.Foldable +import Data.Hashable +import Data.List import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S import Test.QuickCheck -import Control.Applicative -import Data.List -import Data.Hashable -- | Base AST for expressions. Expressions have factors or type t and -- variables referenced by ids of type v. @@ -92,13 +93,14 @@ getVar id x = cata getVar' x - consts x where getVar' (Negate a) = negate a -- | Gets all variables used in an equation. -vars :: Eq v => LinExpr t v -> [v] -vars = nub . cata vars' where - vars' (Var x) = [x] - vars' (Add a b) = a ++ b - vars' (Mul a b) = a ++ b +vars :: (Hashable v, Eq v) => LinExpr t v -> [v] +vars = S.toList . cata vars' where + vars' (Wvar _ x) = S.fromList [x] + vars' (Var x) = S.fromList [x] + vars' (Add a b) = S.union a b + vars' (Mul a b) = S.union a b vars' (Negate a) = a - vars' _ = [] + vars' _ = S.empty -- | Expands terms to Wvars but does not collect like terms rewrite :: (Eq t, Num t) => LinExpr t v -> LinExpr t v diff --git a/bench.hs b/bench.hs new file mode 100644 index 0000000..0f9e474 --- /dev/null +++ b/bench.hs @@ -0,0 +1,38 @@ +import Criterion.Main +import Math.LinProg.LP +import Math.LinProg.LPSolve +import Math.LinProg.Types + +benchLP :: Int -> IO (Maybe ResultCode, [(Int, Double)]) +benchLP n = + solve $ obj $ sum $ map var [1..n] + +benchEq :: Int -> [(Int, Double)] +benchEq n = varTerms $ sum $ map var [1..n] + +benchVars :: Int -> [Int] +benchVars n = vars $ sum $ map var [1..n] + +benchCompile :: Int -> CompilerS Double String +benchCompile n = compile $ obj $ sum $ map (var . show) [1..n] + +benchShow :: Int -> IO () +benchShow n = print (benchCompile n) + +main = defaultMain [ + bgroup "compile" [ bench "100" $ whnf benchCompile 100 + , bench "1000" $ whnf benchCompile 1000 + , bench "10000" $ whnf benchCompile 10000 ] + --,bgroup "compile-show" [ bench "100" $ whnfIO (benchShow 100) + -- , bench "1000" $ whnfIO (benchShow 1000) + -- , bench "10000" $ whnfIO (benchShow 10000) ] + ,bgroup "vars" [ bench "100" $ whnf benchVars 100 + , bench "1000" $ whnf benchVars 1000 + , bench "10000" $ whnf benchVars 10000 ] + ,bgroup "eq" [ bench "100" $ whnf benchEq 100 + , bench "1000" $ whnf benchEq 1000 + , bench "10000" $ whnf benchEq 10000 ] + ,bgroup "LP" [ bench "100" $ whnfIO (benchLP 100) + , bench "1000" $ whnfIO (benchLP 1000) + , bench "10000" $ whnfIO (benchLP 10000)] + ] diff --git a/default.nix b/default.nix index acadb7a..4a702fc 100644 --- a/default.nix +++ b/default.nix @@ -3,6 +3,8 @@ , haskellPackages ? (import {}).haskellPackages }: let inherit (haskellPackages) cabal + ghcCore + criterion unorderedContainers QuickCheck recursionSchemes @@ -17,6 +19,8 @@ in cabal.mkDerivation (self: { src = ./.; isLibrary = true; buildDepends = [ + ghcCore + criterion unorderedContainers QuickCheck recursionSchemes -- cgit v1.2.3