diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ + +MIT License + +Copyright (c) 2018 Preferred Networks, Inc. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +# menoh-haskell + +Haskell binding for [Menoh](https://github.com/pfnet-research/menoh/) DNN inference library. + +# Requirements + +- [Menoh](https://github.com/pfnet-research/menoh/) +- [The Haskell Tool Stack](https://www.haskellstack.org/) + +# Build + +Execute below commands in root directory. + +``` +sh retrieve_data.sh +stack build +``` + +# Running VGG16 example + +Execute below command in root directory. + +``` +cd menoh +stack exec vgg16_example +``` + +Result is below + +``` +vgg16 example +fc6_out: -19.079105 -37.94045 -16.185831 25.51685 4.432623 ... +top 5 categories are: +8 0.958079 n01514859 hen +7 0.039541963 n01514668 cock +86 0.0018722217 n01807496 partridge +82 0.00027406064 n01797886 ruffed grouse, partridge, Bonasa umbellus +97 0.00003177848 n01847000 drake +``` + +Please give `--help` option for details + +``` +stack exec vgg16_example --help +``` + +# Installation + +``` +stack install +``` + +# Licence + +Note: `retrieve_data.sh` downloads `data/VGG16.onnx`. `data/VGG16.onnx` is generated by onnx-chainer from pre-trained model which is uploaded +at http://www.robots.ox.ac.uk/%7Evgg/software/very_deep/caffe/VGG_ILSVRC_16_layers.caffemodel + +That pre-trained model is released under Creative Commons Attribution License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/mnist_example.hs b/app/mnist_example.hs new file mode 100644 --- /dev/null +++ b/app/mnist_example.hs @@ -0,0 +1,153 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Main (main) where + +import qualified Codec.Picture as Picture +import Control.Applicative +import Control.Monad +import Data.Monoid +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Version +import Options.Applicative +import Menoh +import System.FilePath +import Text.Printf + +import Paths_menoh (getDataDir) + +main :: IO () +main = do + putStrLn "mnist example" + dataDir <- getDataDir + opt <- execParser (parserInfo (dataDir "data")) + + let input_dir = optInputPath opt + image_filenames = + [ "0.png" + , "1.png" + , "2.png" + , "3.png" + , "4.png" + , "5.png" + , "6.png" + , "7.png" + , "8.png" + , "9.png" + ] + batch_size = length image_filenames + channel_num = 1 + height = 28 + width = 28 + category_num = 10 + input_dims, output_dims :: Dims + input_dims = [batch_size, channel_num, height, width] + output_dims = [batch_size, category_num] + + images <- liftM VS.concat $ forM image_filenames $ \fname -> do + ret <- Picture.readImage $ input_dir fname + case ret of + Left e -> error e + Right img -> return $ convert width height img + + -- Aliases to onnx's node input and output tensor name + let mnist_in_name = "139900320569040" + mnist_out_name = "139898462888656" + + -- Load ONNX model data + model_data <- makeModelDataFromONNX (optModelPath opt) + + -- Specify inputs and outputs + vpt <- makeVariableProfileTable + [(mnist_in_name, DTypeFloat, input_dims)] + [(mnist_out_name, DTypeFloat)] + model_data + optimizeModelData model_data vpt + + -- Construct computation primitive list and memories + model <- makeModel vpt model_data "mkldnn" + + -- Copy input image data to model's input array + writeBufferFromStorableVector model mnist_in_name images + + -- Run inference + run model + + -- Get output + (v :: V.Vector Float) <- readBufferToVector model mnist_out_name + forM_ (zip [0..] image_filenames) $ \(i,fname) -> do + let scores = V.slice (i * category_num) category_num v + j = V.maxIndex scores + s = scores V.! j + printf "%s = %d : %f\n" fname j s + +-- ------------------------------------------------------------------------- + +data Options + = Options + { optInputPath :: FilePath + , optModelPath :: FilePath + } + +optionsParser :: FilePath -> Parser Options +optionsParser dataDir = Options + <$> inputPathOption + <*> modelPathOption + where + inputPathOption = strOption + $ long "input" + <> short 'i' + <> metavar "DIR" + <> help "input image path" + <> value dataDir + <> showDefault + modelPathOption = strOption + $ long "model" + <> short 'm' + <> metavar "PATH" + <> help "onnx model path" + <> value (dataDir "mnist.onnx") + <> showDefault + +parserInfo :: FilePath -> ParserInfo Options +parserInfo dir = info (helper <*> versionOption <*> optionsParser dir) + $ fullDesc + <> header "mnist_example - an example program of Menoh haskell binding" + where + versionOption :: Parser (a -> a) + versionOption = infoOption (showVersion version) + $ hidden + <> long "version" + <> help "Show version" + +-- ------------------------------------------------------------------------- + +convert :: Int -> Int -> Picture.DynamicImage -> VS.Vector Float +convert w h = reorderToNCHW . resize (w,h) . crop . Picture.convertRGB8 + +crop :: Picture.Pixel a => Picture.Image a -> Picture.Image a +crop img = Picture.generateImage (\x y -> Picture.pixelAt img (base_x + x) (base_y + y)) shortEdge shortEdge + where + shortEdge = min (Picture.imageWidth img) (Picture.imageHeight img) + base_x = (Picture.imageWidth img - shortEdge) `div` 2 + base_y = (Picture.imageHeight img - shortEdge) `div` 2 + +-- TODO: Should we do some kind of interpolation? +resize :: Picture.Pixel a => (Int,Int) -> Picture.Image a -> Picture.Image a +resize (w,h) img = Picture.generateImage (\x y -> Picture.pixelAt img (x * orig_w `div` w) (y * orig_h `div` h)) w h + where + orig_w = Picture.imageWidth img + orig_h = Picture.imageHeight img + +reorderToNCHW :: Picture.Image Picture.PixelRGB8 -> VS.Vector Float +reorderToNCHW img = VS.generate (Picture.imageHeight img * Picture.imageWidth img) f + where + f i = + case Picture.pixelAt img x y of + Picture.PixelRGB8 r g b -> + (fromIntegral r + fromIntegral g + fromIntegral b) / 3 + where + (y,x) = i `divMod` Picture.imageWidth img + +-- ------------------------------------------------------------------------- diff --git a/app/vgg16_example.hs b/app/vgg16_example.hs new file mode 100644 --- /dev/null +++ b/app/vgg16_example.hs @@ -0,0 +1,164 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Main (main) where + +import qualified Codec.Picture as Picture +import Control.Applicative +import Control.Monad +import Data.List +import Data.Monoid +import Data.Ord +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Version +import Options.Applicative +import Menoh +import Text.Printf + +main :: IO () +main = do + putStrLn "vgg16 example" + opt <- execParser parserInfo + + let batch_size = 1 + channel_num = 3 + height = 224 + width = 224 + category_num = 1000 + input_dims, output_dims :: Dims + input_dims = [batch_size, channel_num, height, width] + output_dims = [batch_size, category_num] + + ret <- Picture.readImage (optInputImagePath opt) + let image_data = + case ret of + Left e -> error e + Right img -> convert width height img + + -- Aliases to onnx's node input and output tensor name + let conv1_1_in_name = "140326425860192" + fc6_out_name = "140326200777584" + softmax_out_name = "140326200803680" + + -- Load ONNX model data + model_data <- makeModelDataFromONNX (optModelPath opt) + + -- Specify inputs and outputs + vpt <- makeVariableProfileTable + [(conv1_1_in_name, DTypeFloat, input_dims)] + [(fc6_out_name, DTypeFloat), (softmax_out_name, DTypeFloat)] + model_data + optimizeModelData model_data vpt + + -- Construct computation primitive list and memories + model <- makeModel vpt model_data "mkldnn" + + -- Copy input image data to model's input array + writeBufferFromStorableVector model conv1_1_in_name image_data + + -- Run inference + run model + + -- Get output + (fc6_out :: V.Vector Float) <- readBufferToVector model fc6_out_name + putStr "fc6_out: " + forM_ [0..4] $ \i -> do + putStr $ show $ fc6_out V.! i + putStr " " + putStrLn "..." + + (softmax_out :: V.Vector Float) <- readBufferToVector model softmax_out_name + + categories <- liftM lines $ readFile (optSynsetWordsPath opt) + let k = 5 + scores <- forM [0 .. V.length softmax_out - 1] $ \i -> do + return (i, softmax_out V.! i) + printf "top %d categories are:\n" k + forM_ (take k $ sortBy (flip (comparing snd)) scores) $ \(i,p) -> do + printf "%d %f %s\n" i p (categories !! i) + +-- ------------------------------------------------------------------------- + +data Options + = Options + { optInputImagePath :: FilePath + , optModelPath :: FilePath + , optSynsetWordsPath :: FilePath + } + +optionsParser :: Parser Options +optionsParser = Options + <$> inputImageOption + <*> modelPathOption + <*> synsetWordsPathOption + where + inputImageOption = strOption + $ long "input-image" + <> short 'i' + <> metavar "PATH" + <> help "input image path" + <> value "data/Light_sussex_hen.jpg" + <> showDefault + modelPathOption = strOption + $ long "model" + <> short 'm' + <> metavar "PATH" + <> help "onnx model path" + <> value "data/VGG16.onnx" + <> showDefault + synsetWordsPathOption = strOption + $ long "synset-words" + <> short 's' + <> metavar "PATH" + <> help "synset words path" + <> value "data/synset_words.txt" + <> showDefault + +parserInfo :: ParserInfo Options +parserInfo = info (helper <*> versionOption <*> optionsParser) + $ fullDesc + <> header "vgg16_example - an example program of Menoh haskell binding" + where + versionOption :: Parser (a -> a) + versionOption = infoOption (showVersion version) + $ hidden + <> long "version" + <> help "Show version" + +-- ------------------------------------------------------------------------- + +convert :: Int -> Int -> Picture.DynamicImage -> VS.Vector Float +convert w h = reorderToNCHW . resize (w,h) . crop . Picture.convertRGB8 + +crop :: Picture.Pixel a => Picture.Image a -> Picture.Image a +crop img = Picture.generateImage (\x y -> Picture.pixelAt img (base_x + x) (base_y + y)) shortEdge shortEdge + where + shortEdge = min (Picture.imageWidth img) (Picture.imageHeight img) + base_x = (Picture.imageWidth img - shortEdge) `div` 2 + base_y = (Picture.imageHeight img - shortEdge) `div` 2 + +-- TODO: Should we do some kind of interpolation? +resize :: Picture.Pixel a => (Int,Int) -> Picture.Image a -> Picture.Image a +resize (w,h) img = Picture.generateImage (\x y -> Picture.pixelAt img (x * orig_w `div` w) (y * orig_h `div` h)) w h + where + orig_w = Picture.imageWidth img + orig_h = Picture.imageHeight img + +-- Note that VGG16.onnx assumes BGR image +reorderToNCHW :: Picture.Image Picture.PixelRGB8 -> VS.Vector Float +reorderToNCHW img = VS.generate (3 * Picture.imageHeight img * Picture.imageWidth img) f + where + f i = + case Picture.pixelAt img x y of + Picture.PixelRGB8 r g b -> + case ch of + 0 -> fromIntegral b + 1 -> fromIntegral g + 2 -> fromIntegral r + _ -> undefined + where + (ch,m) = i `divMod` (Picture.imageWidth img * Picture.imageHeight img) + (y,x) = m `divMod` Picture.imageWidth img + +-- ------------------------------------------------------------------------- diff --git a/data/0.png b/data/0.png new file mode 100644 Binary files /dev/null and b/data/0.png differ diff --git a/data/1.png b/data/1.png new file mode 100644 Binary files /dev/null and b/data/1.png differ diff --git a/data/2.png b/data/2.png new file mode 100644 Binary files /dev/null and b/data/2.png differ diff --git a/data/3.png b/data/3.png new file mode 100644 Binary files /dev/null and b/data/3.png differ diff --git a/data/4.png b/data/4.png new file mode 100644 Binary files /dev/null and b/data/4.png differ diff --git a/data/5.png b/data/5.png new file mode 100644 Binary files /dev/null and b/data/5.png differ diff --git a/data/6.png b/data/6.png new file mode 100644 Binary files /dev/null and b/data/6.png differ diff --git a/data/7.png b/data/7.png new file mode 100644 Binary files /dev/null and b/data/7.png differ diff --git a/data/8.png b/data/8.png new file mode 100644 Binary files /dev/null and b/data/8.png differ diff --git a/data/9.png b/data/9.png new file mode 100644 Binary files /dev/null and b/data/9.png differ diff --git a/data/mnist.onnx b/data/mnist.onnx new file mode 100644 # file too large to diff: data/mnist.onnx diff --git a/menoh.cabal b/menoh.cabal new file mode 100644 --- /dev/null +++ b/menoh.cabal @@ -0,0 +1,71 @@ +name: menoh +version: 0.1.0 +license: MIT +license-file: LICENSE +author: Masahiro Sakai +maintainer: Masahiro Sakai +copyright: Copyright 2018 Preferred Networks, Inc. +category: Machine Learning, Deep Learning +synopsis: Haskell binding for Menoh DNN inference library +description: Menoh is a MKL-DNN based DNN inference library for ONNX models. See https://github.com/pfnet-research/menoh/ for details. +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + README.md + retrieve_data.sh +data-files: + data/*.png + data/mnist.onnx + +source-repository head + type: git + location: https://github.com/pfnet-research/menoh-haskell/ + +library + hs-source-dirs: src + exposed-modules: + Menoh + Menoh.Base + other-modules: + Paths_menoh + other-extensions: + CPP + , FlexibleContexts + , ForeignFunctionInterface + , ScopedTypeVariables + build-depends: + base >=4.7 && <5 + , aeson >=0.8 && <1.3 + , bytestring >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , monad-control >=1.0 && <1.1 + , transformers >=0.3 && <0.6 + , vector >=0.10 && <0.13 + pkgconfig-depends: + menoh >=0.5.1 + default-language: Haskell2010 + +executable vgg16_example + hs-source-dirs: app + main-is: vgg16_example.hs + build-depends: + base + -- convertRGB8 requires JuicyPixels >=3.2.7 + , JuicyPixels >=3.2.7 && <3.3 + , optparse-applicative >=0.11 && <0.15 + , menoh + , vector + default-language: Haskell2010 + +executable mnist_example + hs-source-dirs: app + other-modules: Paths_menoh + main-is: mnist_example.hs + build-depends: + base + , filepath >=1.3 && <1.5 + , JuicyPixels + , optparse-applicative + , menoh + , vector + default-language: Haskell2010 diff --git a/retrieve_data.sh b/retrieve_data.sh new file mode 100644 --- /dev/null +++ b/retrieve_data.sh @@ -0,0 +1,3 @@ +wget https://www.dropbox.com/s/bjfn9kehukpbmcm/VGG16.onnx?dl=1 -O ./data/VGG16.onnx +wget https://raw.githubusercontent.com/HoldenCaulfieldRye/caffe/master/data/ilsvrc12/synset_words.txt -O ./data/synset_words.txt +wget https://upload.wikimedia.org/wikipedia/commons/5/54/Light_sussex_hen.jpg -O ./data/Light_sussex_hen.jpg diff --git a/src/Menoh.hs b/src/Menoh.hs new file mode 100644 --- /dev/null +++ b/src/Menoh.hs @@ -0,0 +1,558 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Menoh +-- Copyright : Copyright (c) 2018 Preferred Networks, Inc. +-- License : MIT (see the file LICENSE) +-- +-- Maintainer : Masahiro Sakai +-- Stability : experimental +-- Portability : non-portable +-- +-- Haskell binding for /Menoh/ DNN inference library. +-- +-- = Basic usage +-- +-- 1. Load computation graph from ONNX file using 'makeModelDataFromONNX'. +-- +-- 2. Specify input variable type/dimentions (in particular batch size) and +-- which output variables you want to retrieve. These information is +-- represented as 'VariableProfileTable'. +-- Simple way to construct 'VariableProfileTable' is to use 'makeVariableProfileTable'. +-- +-- 3. Optimize 'ModelData' with respect to your 'VariableProfileTable' by using +-- 'optimizeModelData'. +-- +-- 4. Construct a 'Model' using 'makeModel' or 'makeModelWithConfig'. +-- If you want to use custom buffers instead of internally allocated ones, +-- You need to use more low level 'ModelBuilder'. +-- +-- 5. Load input data. This can be done conveniently using 'writeBufferFromVector' +-- or 'writeBufferFromStorableVector'. There are also more low-level API such as +-- 'unsafeGetBuffer' and 'withBuffer'. +-- +-- 6. Run inference using 'run'. +-- +-- 7. Retrieve the result data. This can be done conveniently using 'readBufferToVector' +-- or 'readBufferToStorableVector'. +-- +----------------------------------------------------------------------------- +module Menoh + ( + -- * Basic data types + Dims + , DType (..) + , HasDType (..) + , Error (..) + + -- * ModelData type + , ModelData (..) + , makeModelDataFromONNX + , optimizeModelData + + -- * Model type + , Model (..) + , makeModel + , makeModelWithConfig + , run + , getDType + , getDims + , unsafeGetBuffer + , withBuffer + , writeBufferFromVector + , writeBufferFromStorableVector + , readBufferToVector + , readBufferToStorableVector + + -- * Misc + , version + , bindingVersion + + -- * Low-level API + -- ** VariableProfileTable + , VariableProfileTable (..) + , makeVariableProfileTable + , vptGetDType + , vptGetDims + + -- ** Builder for 'VariableProfileTable' + , VariableProfileTableBuilder (..) + , makeVariableProfileTableBuilder + , addInputProfileDims2 + , addInputProfileDims4 + , addOutputProfile + , buildVariableProfileTable + + -- ** Builder for 'Model' + , ModelBuilder (..) + , makeModelBuilder + , attachExternalBuffer + , buildModel + , buildModelWithConfig + ) where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp) +import Control.Monad.IO.Class +import Control.Exception +import qualified Data.Aeson as J +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.Proxy +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import qualified Data.Vector.Generic as VG +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Version +import Foreign +import Foreign.C + +import qualified Menoh.Base as Base +import qualified Paths_menoh + +#include "MachDeps.h" + +-- ------------------------------------------------------------------------ + +-- | Functions in this module can throw this exception type. +data Error + = ErrorStdError String + | ErrorUnknownError String + | ErrorInvalidFilename String + | ErrorONNXParseError String + | ErrorInvalidDType String + | ErrorInvalidAttributeType String + | ErrorUnsupportedOperatorAttribute String + | ErrorDimensionMismatch String + | ErrorVariableNotFound String + | ErrorIndexOutOfRange String + | ErrorJSONParseError String + | ErrorInvalidBackendName String + | ErrorUnsupportedOperator String + | ErrorFailedToConfigureOperator String + | ErrorBackendError String + | ErrorSameNamedVariableAlreadyExist String + deriving (Eq, Ord, Show, Read) + +instance Exception Error + +runMenoh :: IO Base.MenohErrorCode -> IO () +runMenoh m = runInBoundThread' $ do + e <- m + if e == Base.menohErrorCodeSuccess then + return () + else do + s <- peekCString =<< Base.menoh_get_last_error_message + case IntMap.lookup (fromIntegral e) table of + Just ex -> throwIO $ ex s + Nothing -> throwIO $ ErrorUnknownError $ s ++ "(error code: " ++ show (fromIntegral e :: Int) ++ ")" + where + table :: IntMap (String -> Error) + table = IntMap.fromList $ map (\(k,v) -> (fromIntegral k, v)) $ + [ (Base.menohErrorCodeStdError , ErrorStdError) + , (Base.menohErrorCodeUnknownError , ErrorUnknownError) + , (Base.menohErrorCodeInvalidFilename , ErrorInvalidFilename) + , (Base.menohErrorCodeOnnxParseError , ErrorONNXParseError) + , (Base.menohErrorCodeInvalidDtype , ErrorInvalidDType) + , (Base.menohErrorCodeInvalidAttributeType , ErrorInvalidAttributeType) + , (Base.menohErrorCodeUnsupportedOperatorAttribute , ErrorUnsupportedOperatorAttribute) + , (Base.menohErrorCodeDimensionMismatch , ErrorDimensionMismatch) + , (Base.menohErrorCodeVariableNotFound , ErrorVariableNotFound) + , (Base.menohErrorCodeIndexOutOfRange , ErrorIndexOutOfRange) + , (Base.menohErrorCodeJsonParseError , ErrorJSONParseError) + , (Base.menohErrorCodeInvalidBackendName , ErrorInvalidBackendName) + , (Base.menohErrorCodeUnsupportedOperator , ErrorUnsupportedOperator) + , (Base.menohErrorCodeFailedToConfigureOperator , ErrorFailedToConfigureOperator) + , (Base.menohErrorCodeBackendError , ErrorBackendError) + , (Base.menohErrorCodeSameNamedVariableAlreadyExist , ErrorSameNamedVariableAlreadyExist) + ] + +runInBoundThread' :: IO a -> IO a +runInBoundThread' action + | rtsSupportsBoundThreads = runInBoundThread action + | otherwise = action + +-- ------------------------------------------------------------------------ + +-- | Data type of array elements +data DType + = DTypeFloat -- ^ single precision floating point number + | DTypeUnknown !Base.MenohDType -- ^ types that this binding is unware of + deriving (Eq, Ord, Show, Read) + +instance Enum DType where + toEnum x + | x == fromIntegral Base.menohDtypeFloat = DTypeFloat + | otherwise = DTypeUnknown (fromIntegral x) + + fromEnum DTypeFloat = fromIntegral Base.menohDtypeFloat + fromEnum (DTypeUnknown i) = fromIntegral i + +-- | Haskell types that have associated 'DType' type code. +class Storable a => HasDType a where + dtypeOf :: Proxy a -> DType + +instance HasDType CFloat where + dtypeOf _ = DTypeFloat + +#if SIZEOF_HSFLOAT == SIZEOF_FLOAT + +instance HasDType Float where + dtypeOf _ = DTypeFloat + +#endif + +-- ------------------------------------------------------------------------ + +-- | Dimensions of array +type Dims = [Int] + +-- ------------------------------------------------------------------------ + +-- | @ModelData@ contains model parameters and computation graph structure. +newtype ModelData = ModelData (ForeignPtr Base.MenohModelData) + +-- | Load onnx file and make 'ModelData'. +makeModelDataFromONNX :: MonadIO m => FilePath -> m ModelData +makeModelDataFromONNX fpath = liftIO $ withCString fpath $ \fpath' -> alloca $ \ret -> do + runMenoh $ Base.menoh_make_model_data_from_onnx fpath' ret + liftM ModelData $ newForeignPtr Base.menoh_delete_model_data_funptr =<< peek ret + +-- | Optimize function for 'ModelData'. +-- +-- This function modify given 'ModelData'. +optimizeModelData :: MonadIO m => ModelData -> VariableProfileTable -> m () +optimizeModelData (ModelData m) (VariableProfileTable vpt) = liftIO $ + withForeignPtr m $ \m' -> withForeignPtr vpt $ \vpt' -> + runMenoh $ Base.menoh_model_data_optimize m' vpt' + +-- ------------------------------------------------------------------------ + +-- | Builder for creation of 'VariableProfileTable'. +newtype VariableProfileTableBuilder + = VariableProfileTableBuilder (ForeignPtr Base.MenohVariableProfileTableBuilder) + +-- | Factory function for 'VariableProfileTableBuilder'. +makeVariableProfileTableBuilder :: MonadIO m => m VariableProfileTableBuilder +makeVariableProfileTableBuilder = liftIO $ alloca $ \p -> do + runMenoh $ Base.menoh_make_variable_profile_table_builder p + liftM VariableProfileTableBuilder $ newForeignPtr Base.menoh_delete_variable_profile_table_builder_funptr =<< peek p + +addInputProfileDims :: MonadIO m => VariableProfileTableBuilder -> String -> DType -> Dims -> m () +addInputProfileDims vpt name dtype dims = + case dims of + [num, size] -> addInputProfileDims2 vpt name dtype (num, size) + [num, channel, height, width] -> addInputProfileDims4 vpt name dtype (num, channel, height, width) + _ -> liftIO $ throwIO $ ErrorDimensionMismatch $ "Menoh.addInputProfileDims: cannot handle dims of length " ++ show (length dims) + +-- | Add 2D input profile. +-- +-- Input profile contains name, dtype and dims @(num, size)@. +-- This 2D input is conventional batched 1D inputs. +addInputProfileDims2 + :: MonadIO m + => VariableProfileTableBuilder + -> String + -> DType + -> (Int, Int) -- ^ (num, size) + -> m () +addInputProfileDims2 (VariableProfileTableBuilder vpt) name dtype (num, size) = liftIO $ + withForeignPtr vpt $ \vpt' -> withCString name $ \name' -> + runMenoh $ Base.menoh_variable_profile_table_builder_add_input_profile_dims_2 + vpt' name' (fromIntegral (fromEnum dtype)) + (fromIntegral num) (fromIntegral size) + +-- | Add 4D input profile +-- +-- Input profile contains name, dtype and dims @(num, channel, height, width)@. +-- This 4D input is conventional batched image inputs. Image input is +-- 3D (channel, height, width). +addInputProfileDims4 + :: MonadIO m + => VariableProfileTableBuilder + -> String + -> DType + -> (Int, Int, Int, Int) -- ^ (num, channel, height, width) + -> m () +addInputProfileDims4 (VariableProfileTableBuilder vpt) name dtype (num, channel, height, width) = liftIO $ + withForeignPtr vpt $ \vpt' -> withCString name $ \name' -> + runMenoh $ Base.menoh_variable_profile_table_builder_add_input_profile_dims_4 + vpt' name' (fromIntegral (fromEnum dtype)) + (fromIntegral num) (fromIntegral channel) (fromIntegral height) (fromIntegral width) + +-- | Add output profile +-- +-- Output profile contains name and dtype. Its 'Dims' are calculated automatically, +-- so that you don't need to specify explicitly. +addOutputProfile :: MonadIO m => VariableProfileTableBuilder -> String -> DType -> m () +addOutputProfile (VariableProfileTableBuilder vpt) name dtype = liftIO $ + withForeignPtr vpt $ \vpt' -> withCString name $ \name' -> + runMenoh $ Base.menoh_variable_profile_table_builder_add_output_profile + vpt' name' (fromIntegral (fromEnum dtype)) + +-- | Factory function for 'VariableProfileTable' +buildVariableProfileTable + :: MonadIO m + => VariableProfileTableBuilder + -> ModelData + -> m VariableProfileTable +buildVariableProfileTable (VariableProfileTableBuilder b) (ModelData m) = liftIO $ + withForeignPtr b $ \b' -> withForeignPtr m $ \m' -> alloca $ \ret -> do + runMenoh $ Base.menoh_build_variable_profile_table b' m' ret + liftM VariableProfileTable $ newForeignPtr Base.menoh_delete_variable_profile_table_funptr =<< peek ret + +-- ------------------------------------------------------------------------ + +-- | @VariableProfileTable@ contains information of dtype and dims of variables. +-- +-- Users can access to dtype and dims via 'vptGetDType' and 'vptGetDims'. +newtype VariableProfileTable + = VariableProfileTable (ForeignPtr Base.MenohVariableProfileTable) + +-- | Convenient function for constructing 'VariableProfileTable'. +-- +-- If you need finer control, you can use 'VariableProfileTableBuidler'. +makeVariableProfileTable + :: MonadIO m + => [(String, DType, Dims)] -- ^ input names with dtypes and dims + -> [(String, DType)] -- ^ required output name list with dtypes + -> ModelData -- ^ model data + -> m VariableProfileTable +makeVariableProfileTable input_name_and_dims_pair_list required_output_name_list model_data = liftIO $ do + b <- makeVariableProfileTableBuilder + forM_ input_name_and_dims_pair_list $ \(name,dtype,dims) -> do + addInputProfileDims b name dtype dims + forM_ required_output_name_list $ \(name,dtype) -> do + addOutputProfile b name dtype + buildVariableProfileTable b model_data + +-- | Accessor function for 'VariableProfileTable' +-- +-- Select variable name and get its 'DType'. +vptGetDType :: MonadIO m => VariableProfileTable -> String -> m DType +vptGetDType (VariableProfileTable vpt) name = liftIO $ + withForeignPtr vpt $ \vpt' -> withCString name $ \name' -> alloca $ \ret -> do + runMenoh $ Base.menoh_variable_profile_table_get_dims_size vpt' name' ret + (toEnum . fromIntegral) <$> peek ret + +-- | Accessor function for 'VariableProfileTable' +-- +-- Select variable name and get its 'Dims'. +vptGetDims :: MonadIO m => VariableProfileTable -> String -> m Dims +vptGetDims (VariableProfileTable vpt) name = liftIO $ + withForeignPtr vpt $ \vpt' -> withCString name $ \name' -> alloca $ \ret -> do + runMenoh $ Base.menoh_variable_profile_table_get_dims_size vpt' name' ret + size <- peek ret + forM [0..size-1] $ \i -> do + runMenoh $ Base.menoh_variable_profile_table_get_dims_at vpt' name' (fromIntegral i) ret + fromIntegral <$> peek ret + +-- ------------------------------------------------------------------------ + +-- | Helper for creating of 'Model'. +newtype ModelBuilder = ModelBuilder (ForeignPtr Base.MenohModelBuilder) + +-- | Factory function for 'ModelBuilder' +makeModelBuilder :: MonadIO m => VariableProfileTable -> m ModelBuilder +makeModelBuilder (VariableProfileTable vpt) = liftIO $ + withForeignPtr vpt $ \vpt' -> alloca $ \ret -> do + runMenoh $ Base.menoh_make_model_builder vpt' ret + liftM ModelBuilder $ newForeignPtr Base.menoh_delete_model_builder_funptr =<< peek ret + +-- | Attach a buffer which allocated by users. +-- +-- Users can attach a external buffer which they allocated to target variable. +-- +-- Variables attached no external buffer are attached internal buffers allocated +-- automatically. +-- +-- Users can get that internal buffer handle by calling 'unsafeGetBuffer' etc. later. +attachExternalBuffer :: MonadIO m => ModelBuilder -> String -> Ptr a -> m () +attachExternalBuffer (ModelBuilder m) name buf = liftIO $ + withForeignPtr m $ \m' -> withCString name $ \name' -> + runMenoh $ Base.menoh_model_builder_attach_external_buffer m' name' buf + +-- | Factory function for 'Model'. +buildModel + :: MonadIO m + => ModelBuilder + -> ModelData + -> String -- ^ backend name + -> m Model +buildModel builder m backend = liftIO $ + withCString "" $ + buildModelWithConfigString builder m backend + +-- | Similar to 'buildModel', but backend specific configuration can be supplied as JSON. +buildModelWithConfig + :: (MonadIO m, J.ToJSON a) + => ModelBuilder + -> ModelData + -> String -- ^ backend name + -> a -- ^ backend config + -> m Model +buildModelWithConfig builder m backend backend_config = liftIO $ + BS.useAsCString (BL.toStrict (J.encode backend_config)) $ + buildModelWithConfigString builder m backend + +buildModelWithConfigString + :: MonadIO m + => ModelBuilder + -> ModelData + -> String -- ^ backend name + -> CString -- ^ backend config + -> m Model +buildModelWithConfigString (ModelBuilder builder) (ModelData m) backend backend_config = liftIO $ + withForeignPtr builder $ \builder' -> withForeignPtr m $ \m' -> withCString backend $ \backend' -> alloca $ \ret -> do + runMenoh $ Base.menoh_build_model builder' m' backend' backend_config ret + liftM Model $ newForeignPtr Base.menoh_delete_model_funptr =<< peek ret + +-- ------------------------------------------------------------------------ + +-- | ONNX model with input/output buffers +newtype Model = Model (ForeignPtr Base.MenohModel) + +-- | Run model inference. +-- +-- This function can't be called asynchronously. +run :: MonadIO m => Model -> m () +run (Model model) = liftIO $ withForeignPtr model $ \model' -> do + runMenoh $ Base.menoh_model_run model' + +-- | Get 'DType' of target variable. +getDType :: MonadIO m => Model -> String -> m DType +getDType (Model m) name = liftIO $ do + withForeignPtr m $ \m' -> withCString name $ \name' -> alloca $ \ret -> do + runMenoh $ Base.menoh_model_get_variable_dtype m' name' ret + liftM (toEnum . fromIntegral) $ peek ret + +-- | Get 'Dims' of target variable. +getDims :: MonadIO m => Model -> String -> m Dims +getDims (Model m) name = liftIO $ do + withForeignPtr m $ \m' -> withCString name $ \name' -> alloca $ \ret -> do + runMenoh $ Base.menoh_model_get_variable_dims_size m' name' ret + size <- peek ret + forM [0..size-1] $ \i -> do + runMenoh $ Base.menoh_model_get_variable_dims_at m' name' (fromIntegral i) ret + fromIntegral <$> peek ret + +-- | Get a buffer handle attached to target variable. +-- +-- Users can get a buffer handle attached to target variable. +-- If that buffer is allocated by users and attached to the variable by calling +-- 'attachExternalBuffer', returned buffer handle is same to it. +-- +-- This function is unsafe because it does not prevent the model to be GC'ed and +-- the returned pointer become dangling pointer. +-- +-- See also 'withBuffer'. +unsafeGetBuffer :: MonadIO m => Model -> String -> m (Ptr a) +unsafeGetBuffer (Model m) name = liftIO $ do + withForeignPtr m $ \m' -> withCString name $ \name' -> alloca $ \ret -> do + runMenoh $ Base.menoh_model_get_variable_buffer_handle m' name' ret + peek ret + +-- | This function takes a function which is applied to the buffer associated to specified variable. +-- The resulting action is then executed. The buffer is kept alive at least during the whole action, +-- even if it is not used directly inside. +-- Note that it is not safe to return the pointer from the action and use it after the action completes. +-- +-- See also 'unsafeGetBuffer'. +withBuffer :: forall m r a. (MonadIO m, MonadBaseControl IO m) => Model -> String -> (Ptr a -> m r) -> m r +withBuffer (Model m) name f = + liftBaseOp (withForeignPtr m) $ \m' -> + (liftBaseOp (withCString name) :: (CString -> m r) -> m r) $ \name' -> + liftBaseOp alloca $ \ret -> do + p <- liftIO $ do + runMenoh $ Base.menoh_model_get_variable_buffer_handle m' name' ret + peek ret + f p + +checkDType :: String -> DType -> DType -> IO () +checkDType name dtype1 dtype2 + | dtype1 /= dtype2 = throwIO $ ErrorInvalidDType $ name ++ ": dtype mismatch" + | otherwise = return () + +checkDTypeAndSize :: String -> (DType,Int) -> (DType,Int) -> IO () +checkDTypeAndSize name (dtype1,n1) (dtype2,n2) + | dtype1 /= dtype2 = throwIO $ ErrorInvalidDType $ name ++ ": dtype mismatch" + | n1 /= n2 = throwIO $ ErrorDimensionMismatch $ name ++ ": dimension mismatch" + | otherwise = return () + +-- | Copy whole elements of 'VG.Vector' into a model's buffer +writeBufferFromVector :: forall v a m. (VG.Vector v a, HasDType a, MonadIO m) => Model -> String -> v a -> m () +writeBufferFromVector model name vec = liftIO $ withBuffer model name $ \p -> do + dtype <- getDType model name + dims <- getDims model name + let n = product dims + checkDTypeAndSize "Menoh.writeBufferFromVector" (dtype, n) (dtypeOf (Proxy :: Proxy a), VG.length vec) + forM_ [0..n-1] $ \i -> do + pokeElemOff p i (vec VG.! i) + +-- | Copy whole elements of @'VS.Vector' a@ into a model's buffer +writeBufferFromStorableVector :: forall a m. (HasDType a, MonadIO m) => Model -> String -> VS.Vector a -> m () +writeBufferFromStorableVector model name vec = liftIO $ withBuffer model name $ \p -> do + dtype <- getDType model name + dims <- getDims model name + let n = product dims + checkDTypeAndSize "Menoh.writeBufferFromStorableVector" (dtype, n) (dtypeOf (Proxy :: Proxy a), VG.length vec) + VS.unsafeWith vec $ \src -> do + copyArray p src n + +-- | Read whole elements of 'Array' and return as a 'VG.Vector'. +readBufferToVector :: forall v a m. (VG.Vector v a, HasDType a, MonadIO m) => Model -> String -> m (v a) +readBufferToVector model name = liftIO $ withBuffer model name $ \p -> do + dtype <- getDType model name + dims <- getDims model name + checkDType "Menoh.readBufferToVector" dtype (dtypeOf (Proxy :: Proxy a)) + let n = product dims + VG.generateM n $ peekElemOff p + +-- | Read whole eleemnts of 'Array' and return as a @'VS.Vector' 'Float'@. +readBufferToStorableVector :: forall a m. (HasDType a, MonadIO m) => Model -> String -> m (VS.Vector a) +readBufferToStorableVector model name = liftIO $ withBuffer model name $ \p -> do + dtype <- getDType model name + dims <- getDims model name + checkDType "Menoh.readBufferToStorableVector" dtype (dtypeOf (Proxy :: Proxy a)) + let n = product dims + vec <- VSM.new n + VSM.unsafeWith vec $ \dst -> copyArray dst p n + VS.unsafeFreeze vec + +-- | Convenient methods for constructing a 'Model'. +makeModel + :: MonadIO m + => VariableProfileTable -- ^ variable profile table + -> ModelData -- ^ model data + -> String -- ^ backend name + -> m Model +makeModel vpt model_data backend_name = liftIO $ do + b <- makeModelBuilder vpt + buildModel b model_data backend_name + +-- | Similar to 'makeModel' but backend-specific configuration can be supplied. +makeModelWithConfig + :: (MonadIO m, J.ToJSON a) + => VariableProfileTable -- ^ variable profile table + -> ModelData -- ^ model data + -> String -- ^ backend name + -> a -- ^ backend config + -> m Model +makeModelWithConfig vpt model_data backend_name backend_config = liftIO $ do + b <- makeModelBuilder vpt + buildModelWithConfig b model_data backend_name backend_config + +-- ------------------------------------------------------------------------ + +-- | Menoh version which was supplied on compilation time via CPP macro. +version :: Version +version = makeVersion [Base.menoh_major_version, Base.menoh_minor_version, Base.menoh_patch_version] + +-- | Version of this Haskell binding. (Not the version of /Menoh/ itself) +bindingVersion :: Version +bindingVersion = Paths_menoh.version diff --git a/src/Menoh/Base.hsc b/src/Menoh/Base.hsc new file mode 100644 --- /dev/null +++ b/src/Menoh/Base.hsc @@ -0,0 +1,138 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Menoh.Base where + +import Data.Int +import Foreign +import Foreign.C + +#include +#include + +type MenohDType = #type menoh_dtype + +type MenohErrorCode = #type menoh_error_code + +#enum MenohDType,,menoh_dtype_float + +#enum MenohErrorCode,, \ + menoh_error_code_success, \ + menoh_error_code_std_error, \ + menoh_error_code_unknown_error, \ + menoh_error_code_invalid_filename, \ + menoh_error_code_onnx_parse_error, \ + menoh_error_code_invalid_dtype, \ + menoh_error_code_invalid_attribute_type, \ + menoh_error_code_unsupported_operator_attribute, \ + menoh_error_code_dimension_mismatch, \ + menoh_error_code_variable_not_found, \ + menoh_error_code_index_out_of_range, \ + menoh_error_code_json_parse_error, \ + menoh_error_code_invalid_backend_name, \ + menoh_error_code_unsupported_operator, \ + menoh_error_code_failed_to_configure_operator, \ + menoh_error_code_backend_error, \ + menoh_error_code_same_named_variable_already_exist + +foreign import ccall unsafe menoh_get_last_error_message + :: IO CString + +data MenohModelData +type MenohModelDataHandle = Ptr MenohModelData + +foreign import ccall safe menoh_make_model_data_from_onnx + :: CString -> Ptr MenohModelDataHandle -> IO MenohErrorCode + +foreign import ccall "&menoh_delete_model_data" menoh_delete_model_data_funptr + :: FunPtr (MenohModelDataHandle -> IO ()) + +data MenohVariableProfileTableBuilder +type MenohVariableProfileTableBuilderHandle = Ptr MenohVariableProfileTableBuilder + +foreign import ccall unsafe menoh_make_variable_profile_table_builder + :: Ptr MenohVariableProfileTableBuilderHandle -> IO MenohErrorCode + +foreign import ccall "&menoh_delete_variable_profile_table_builder" + menoh_delete_variable_profile_table_builder_funptr + :: FunPtr (MenohVariableProfileTableBuilderHandle -> IO ()) + +foreign import ccall unsafe menoh_variable_profile_table_builder_add_input_profile_dims_2 + :: MenohVariableProfileTableBuilderHandle -> CString -> MenohDType -> Int32 -> Int32 -> IO MenohErrorCode + +foreign import ccall unsafe menoh_variable_profile_table_builder_add_input_profile_dims_4 + :: MenohVariableProfileTableBuilderHandle -> CString -> MenohDType -> Int32 -> Int32 -> Int32 -> Int32 -> IO MenohErrorCode + +foreign import ccall unsafe menoh_variable_profile_table_builder_add_output_profile + :: MenohVariableProfileTableBuilderHandle -> CString -> MenohDType -> IO MenohErrorCode + +data MenohVariableProfileTable +type MenohVariableProfileTableHandle = Ptr MenohVariableProfileTable + +foreign import ccall safe menoh_build_variable_profile_table + :: MenohVariableProfileTableBuilderHandle -> MenohModelDataHandle + -> Ptr MenohVariableProfileTableHandle -> IO MenohErrorCode + +foreign import ccall "&menoh_delete_variable_profile_table" + menoh_delete_variable_profile_table_funptr + :: FunPtr (MenohVariableProfileTableHandle -> IO ()) + +foreign import ccall unsafe menoh_variable_profile_table_get_dtype + :: MenohVariableProfileTableHandle -> CString -> Ptr MenohDType -> IO MenohErrorCode + +foreign import ccall unsafe menoh_variable_profile_table_get_dims_size + :: MenohVariableProfileTableHandle -> CString -> Ptr Int32 -> IO MenohErrorCode + +foreign import ccall unsafe menoh_variable_profile_table_get_dims_at + :: MenohVariableProfileTableHandle -> CString -> Int32 -> Ptr Int32 -> IO MenohErrorCode + +foreign import ccall safe menoh_model_data_optimize + :: MenohModelDataHandle -> MenohVariableProfileTableHandle -> IO MenohErrorCode + +data MenohModelBuilder +type MenohModelBuilderHandle = Ptr MenohModelBuilder + +foreign import ccall unsafe menoh_make_model_builder + :: MenohVariableProfileTableHandle -> Ptr MenohModelBuilderHandle -> IO MenohErrorCode + +foreign import ccall "&menoh_delete_model_builder" menoh_delete_model_builder_funptr + :: FunPtr (MenohModelBuilderHandle -> IO ()) + +foreign import ccall unsafe menoh_model_builder_attach_external_buffer + :: MenohModelBuilderHandle -> CString -> Ptr a -> IO MenohErrorCode + +data MenohModel +type MenohModelHandle = Ptr MenohModel + +foreign import ccall safe menoh_build_model + :: MenohModelBuilderHandle -> MenohModelDataHandle -> CString -> CString + -> Ptr MenohModelHandle -> IO MenohErrorCode + +foreign import ccall "&menoh_delete_model" menoh_delete_model_funptr + :: FunPtr (MenohModelHandle -> IO ()) + +foreign import ccall unsafe menoh_model_get_variable_buffer_handle + :: MenohModelHandle -> CString -> Ptr (Ptr a) -> IO MenohErrorCode + +foreign import ccall unsafe menoh_model_get_variable_dtype + :: MenohModelHandle -> CString -> Ptr MenohDType -> IO MenohErrorCode + +foreign import ccall unsafe menoh_model_get_variable_dims_size + :: MenohModelHandle -> CString -> Ptr Int32 -> IO MenohErrorCode + +foreign import ccall unsafe menoh_model_get_variable_dims_at + :: MenohModelHandle -> CString -> Int32 -> Ptr Int32 -> IO MenohErrorCode + +foreign import ccall safe menoh_model_run + :: MenohModelHandle -> IO MenohErrorCode + +menoh_major_version :: Int +menoh_major_version = #const MENOH_MAJOR_VERSION + +menoh_minor_version :: Int +menoh_minor_version = #const MENOH_MINOR_VERSION + +menoh_patch_version :: Int +menoh_patch_version = #const MENOH_PATCH_VERSION + +menoh_version_string :: String +menoh_version_string = #const_str MENOH_VERSION_STRING