diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,31 @@ import Distribution.Simple -main = defaultMain +import Distribution.Simple.Setup +import Distribution.Types.LocalBuildInfo +import Distribution.Types.GenericPackageDescription +import Distribution.Types.HookedBuildInfo + +import Data.List (find) + +main :: IO () +main = defaultMainWithHooks $ + simpleUserHooks { confHook = confWithExtraFlags + } + +-- | Patch the `-lmxnet` arguments during the build stage for TH phase. +confWithExtraFlags :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo +confWithExtraFlags desc_info flags = + defaultConfHook desc_info newFlags + where + newFlags = flags { configProgramArgs = defaultOtherArgs ++ [ ("ghc", defaultGhcArgs ++ ["-lmxnet"]) + , ("haddock", defaultHaddockArgs ++ ["--optghc=-lmxnet"]) + ] + } + defaultProgramArgs = configProgramArgs flags + defaultOtherArgs = filter (\(prog, _) -> prog /= "ghc" && prog /= "haddock") defaultProgramArgs + defaultGhcArgs = case find (\(prog, _) -> prog == "ghc") defaultProgramArgs of + Nothing -> [] + Just (_, opts) -> opts + defaultHaddockArgs = case find (\(prog, _) -> prog == "haddock") defaultProgramArgs of + Nothing -> [] + Just (_, opts) -> opts + defaultConfHook = confHook simpleUserHooks diff --git a/mxnet.cabal b/mxnet.cabal --- a/mxnet.cabal +++ b/mxnet.cabal @@ -1,5 +1,5 @@ name: mxnet -version: 0.1.0.1 +version: 0.2.0.0 synopsis: MXNet interface in Haskell. description: MXNet interface in Haskell via CFFI. homepage: http://github.com/sighingnow/mxnet-haskell#readme @@ -9,22 +9,49 @@ maintainer: sighingnow@gmail.com copyright: Copyright: (c) 2016-2017 Tao He category: Machine Learning -build-type: Simple +build-type: Custom cabal-version: >= 1.10 Library exposed-modules: MXNet.Core.Base - MXNet.Core.NDArray - MXNet.Core.Predict.Base + MXNet.Core.Base.DType + MXNet.Core.Base.HMap + MXNet.Core.Base.Executor + MXNet.Core.Base.NDArray + MXNet.Core.Base.Symbol + MXNet.Core.Base.Internal + MXNet.Core.Types.Internal + MXNet.Core.Predict.Internal + MXNet.Core.NNVM.Internal + MXNet.Core.Base.Internal.TH.NDArray + MXNet.Core.Base.Internal.TH.Symbol other-modules: - MXNet.Core.Internal.Types.Raw + MXNet.Core.Types.Internal.Raw MXNet.Core.Base.Internal.Raw MXNet.Core.Predict.Internal.Raw + MXNet.Core.NNVM.Internal.Raw + MXNet.Core.Base.Internal.TH hs-source-dirs: src build-tools: c2hs ghc-options: -Wall default-language: Haskell2010 build-depends: base >= 4.7 && < 5.0 , c2hs-extra >= 0.1 + , pretty >= 1.1 + , template-haskell >= 2.10.0.0 + , unordered-containers >= 0.2.7.0 + , vector >= 0.10.0.0 extra-libraries: mxnet + +Test-Suite mxnet-test + type: exitcode-stdio-1.0 + main-is: mxnet-test.hs + hs-source-dirs: tests + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5.0 + , mxnet + , vector >= 0.10.0.0 + , tasty >= 0.11.0.3 + , tasty-hunit >= 0.9.2 diff --git a/src/MXNet/Core/Base.hs b/src/MXNet/Core/Base.hs --- a/src/MXNet/Core/Base.hs +++ b/src/MXNet/Core/Base.hs @@ -7,148 +7,56 @@ -- -- Interfaces in core module of MXNet. -- -module MXNet.Core.Base ( - -- * Data type definitions - -- ** Type alias - MXUInt - , MXFloat - -- ** Handlers and Creators - , NDArrayHandle - , FunctionHandle - , AtomicSymbolCreator - , SymbolHandle - , AtomicSymbolHandle - , ExecutorHandle - , DataIterCreator - , DataIterHandle - , KVStoreHandle - , RecordIOHandle - , RtcHandle - -- ** Callback types - , ExecutorMonitorCallback - , CustomOpPropCreator - , MXKVStoreUpdater - , MXKVStoreServerController - -- * Error handling. - , mxGetLastError - -- * Global State setups - , mxRandomSeed - , mxNotifyShutdown - , mxSetProfilerConfig - , mxSetProfilerState - , mxDumpProfile - -- * NDArray creation and deletion - , mxNDArrayCreateNone - , mxNDArrayCreate - , mxNDArrayCreateEx - , mxNDArrayLoadFromRawBytes - , mxNDArraySaveRawBytes - , mxNDArraySave - , mxNDArrayLoad - , mxNDArraySyncCopyFromCPU - , mxNDArraySyncCopyToCPU - , mxNDArrayWaitToRead - , mxNDArrayWaitToWrite - , mxNDArrayWaitAll - , mxNDArrayFree - , mxNDArraySlice - , mxNDArrayAt - , mxNDArrayReshape - , mxNDArrayGetShape - , mxNDArrayGetData - , mxNDArrayGetDType - , mxNDArrayGetContext - -- * Functions on NDArray - , mxListFunctions - , mxGetFunction - , mxFuncGetInfo - , mxFuncDescribe - , mxFuncInvoke - , mxFuncInvokeEx - , mxImperativeInvoke - -- * Symbolic configuration generation - , mxSymbolListAtomicSymbolCreators - , mxSymbolGetAtomicSymbolName - , mxSymbolGetAtomicSymbolInfo - , mxSymbolCreateAtomicSymbol - , mxSymbolCreateVariable - , mxSymbolCreateGroup - , mxSymbolCreateFromFile - , mxSymbolCreateFromJSON - , mxSymbolSaveToFile - , mxSymbolSaveToJSON - , mxSymbolFree - , mxSymbolCopy - , mxSymbolPrint - , mxSymbolGetName - , mxSymbolGetAttr - , mxSymbolSetAttr - , mxSymbolListAttr - , mxSymbolListAttrShallow - , mxSymbolListArguments - , mxSymbolListOutputs - , mxSymbolGetInternals - , mxSymbolGetOutput - , mxSymbolListAuxiliaryStates - , mxSymbolCompose - , mxSymbolGrad - , mxSymbolInferShape - , mxSymbolInferShapePartial - , mxSymbolInferType - -- * Executor interface - , mxExecutorFree - , mxExecutorPrint - , mxExecutorForward - , mxExecutorBackward - , mxExecutorOutputs - , mxExecutorBind - , mxExecutorBindX - , mxExecutorBindEX - , mxExecutorSetMonitorCallback - -- * IO Interface - , mxListDataIters - , mxDataIterCreateIter - , mxDataIterGetIterInfo - , mxDataIterFree - , mxDataIterNext - , mxDataIterBeforeFirst - , mxDataIterGetData - , mxDataIterGetIndex - , mxDataIterGetPadNum - , mxDataIterGetLabel - -- * Basic KVStore interface - , mxInitPSEnv - , mxKVStoreCreate - , mxKVStoreFree - , mxKVStoreInit - , mxKVStorePush - , mxKVStorePull - , mxKVStoreSetUpdater - , mxKVStoreGetType - -- * Advanced KVStore for multi-machines - , mxKVStoreGetRank - , mxKVStoreGetGroupSize - , mxKVStoreIsWorkerNode - , mxKVStoreIsServerNode - , mxKVStoreIsSchedulerNode - , mxKVStoreBarrier - , mxKVStoreSetBarrierBeforeExit - , mxKVStoreRunServer - , mxKVStoreSendCommmandToServers - , mxKVStoreGetNumDeadNode - , mxRecordIOWriterCreate - , mxRecordIOWriterFree - , mxRecordIOWriterWriteRecord - , mxRecordIOWriterTell - , mxRecordIOReaderCreate - , mxRecordIOReaderFree - , mxRecordIOReaderReadRecord - , mxRecordIOReaderSeek - , mxRtcCreate - , mxRtcPush - , mxRtcFree - , mxCustomOpRegister - ) where -import MXNet.Core.Internal.Types.Raw -import MXNet.Core.Base.Internal.Raw +module MXNet.Core.Base + ( -- * Necessary raw functions + mxGetLastError + , mxListAllOpNames + -- * NDArray + , NDArray + , waitAll + , makeEmptyNDArray + , makeNDArray + , ndshape + , ndsize + , context + , at + , items + , slice + , waitToRead + , onehotEncode + , zeros + , ones + , full + , array + -- * Symbol + , Symbol + , variable + , getName + , getAttr + , setAttr + , infershape + , grad + , bind + , bind' + , listInputs + , listOutputs + , listAuxiliaries + -- * Executor + , Executor + , makeExecutor + , forward + , backward + , getOutputs + -- * DType + , module MXNet.Core.Base.DType + -- * Heterogeneous Dictionary. + , module MXNet.Core.Base.HMap + )where + +import MXNet.Core.Base.DType +import MXNet.Core.Base.Executor +import MXNet.Core.Base.HMap +import MXNet.Core.Base.NDArray +import MXNet.Core.Base.Symbol +import MXNet.Core.Base.Internal diff --git a/src/MXNet/Core/Base/DType.hs b/src/MXNet/Core/Base/DType.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/DType.hs @@ -0,0 +1,339 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.DType +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- DType corresponding between Haskell's data type and numpy's data type. +-- +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE KindSignatures #-} + +module MXNet.Core.Base.DType + ( DType (..) + , pattern FLOAT32 + , pattern FLOAT64 + , pattern FLOAT16 + , pattern UINT8 + , pattern INT32 + , Tensor (..) + , Neural (..) + , Context (..) + , contextCPU + , contextGPU + ) where + +import Data.Int +import Foreign.Storable (Storable) + +-- | DType class, used to quantify types that can be passed to mxnet. +class (Storable a, Show a, Eq a, Ord a, Num a, Real a) => DType a where + typeid :: a -> Int + typename :: a -> String + +pattern FLOAT32 = 0 +pattern FLOAT64 = 1 +pattern FLOAT16 = 2 +pattern UINT8 = 3 +pattern INT32 = 4 + +instance DType Float where + typeid _ = FLOAT32 + {-# INLINE typeid #-} + typename _ = "float32" + {-# INLINE typename #-} + +instance DType Double where + typeid _ = FLOAT64 + {-# INLINE typeid #-} + typename _ = "float64" + {-# INLINE typename #-} + +instance DType Int8 where + typeid _ = UINT8 + {-# INLINE typeid #-} + typename _ = "uint8" + {-# INLINE typename #-} + +instance DType Int32 where + typeid _ = INT32 + {-# INLINE typeid #-} + typename _ = "int32" + {-# INLINE typename #-} + +-- | Tensor operations. +class Tensor (tensor :: * -> *) where + -- | Dot product. + dot :: DType a => tensor a -> tensor a -> IO (tensor a) + -- | Reshape a tensor value. + reshape :: DType a => tensor a -> [Int] -> IO (tensor a) + -- | Transpose a tensor value. + transpose :: DType a => tensor a -> IO (tensor a) + -- | Add, subtract, multiply, divide and power with IO action. + (+.), (-.), (*.), (/.), (^.) :: DType a => tensor a -> tensor a -> IO (tensor a) + -- | Ordinary arithmetic operators with scalar value. + (.+), (.-), (.*), (./), (.^) :: DType a => tensor a -> a -> IO (tensor a) + -- | Flip version of ordinary arithmetic operators with scalar value. + (..-), (../), (..^) :: DType a => a -> tensor a -> IO (tensor a) + -- | Mutable ordinary arithmetic operators with scalar value. + (.+=), (.-=), (.*=), (./=), (.^=) :: DType a => tensor a -> a -> IO () + -- | Compare two tensor values, after comparison, all cell may be set as a same value, or /0/, or /1/. + _Maximum, _Minimum, equal, notEqual, greater, greaterEqual, lesser, lesserEqual + :: DType a => tensor a -> tensor a -> IO (tensor a) + -- | Compare a tensor value with a scalar value, after comparison, all cell may be set as a same value, or /0/, or /1/. + _Maximum', _Minimum', equal', notEqual', greater', greaterEqual', lesser', lesserEqual' + :: DType a => tensor a -> a -> IO (tensor a) + +infixl 6 .+, .-, ..- +infixl 7 .*, ./, ../ +infixr 8 .^, ..^ + +-- | Neural network combinators. +class Tensor tensor => Neural tensor where + -- | Apply a linear transformation: /Y = X W^T + b/. + fullyConnected + :: DType a + => tensor a -- ^ Input data. + -> tensor a -- ^ Weight matrix. + -> tensor a -- ^ Bias parameter. + -> Int -- ^ Number of hidden nodes of the output. + -> IO (tensor a) + -- | Apply correlation to inputs + correlation + :: DType a + => tensor a -- ^ Input data1 to the correlation. + -> tensor a -- ^ Input data2 to the correlation. + -> IO (tensor a) + -- | ElementWise activation function. + activation + :: DType a + => tensor a -- ^ Input data to activation function. + -> String -- ^ Activation function to be applied, one of {'relu', 'sigmoid', 'softrelu', 'tanh'}. + -> IO (tensor a) + -- | Leaky ReLu activation + -- + -- The following types are supported: + -- + -- 1. elu: /y = x > 0 ? x : slop * (exp(x)-1)/ + -- 2. leaky: /y = x > 0 ? x : slope * x/ + -- 3. prelu: same as leaky but the slope is learnable. + -- 4. rrelu: same as leaky but the slope is uniformly randomly chosen from [lower_bound, upper_bound) for + -- training, while fixed to be (lower_bound+upper_bound)/2 for inference. + leakyReLU + :: DType a + => tensor a -- ^ Input data to activation function. + -> String -- ^ Activation function to be applied, one of {'elu', 'leaky', 'prelu', 'rrelu'}, default is 'leaky'. + -> IO (tensor a) + -- | Apply softmax activation to input. + softmaxActivation + :: DType a + => tensor a -- ^ Input data to activation function. + -> IO (tensor a) + -- | Apply dropout to input. + dropout + :: DType a + => tensor a -- ^ Input data to dropout. + -> Float -- ^ Fraction of the input that gets dropped out at training time, default is 0.5. + -> IO (tensor a) + -- | Batch normalization. + batchNorm + :: DType a + => tensor a -- ^ Input data to batch normalization. + -> tensor a -- ^ Gamma + -> tensor a -- ^ Beta + -> tensor a -- ^ Moving mean + -> tensor a -- ^ Moving var + -> IO (tensor a) + -- | An operator taking in a n-dimensional input tensor (n > 2), and normalizing the input by subtracting the mean + -- and variance calculated over the spatial dimensions. + instanceNorm + :: DType a + => tensor a -- ^ A n-dimensional tensor (n > 2) of the form [batch, channel, spatial_dim1, spatial_dim2, ...]. + -> tensor a -- ^ Gamma, a vector of length 'channel', which multiplies the normalized input. + -> tensor a -- ^ Beta, a vector of length 'channel', which is added to the product of the normalized input and the weight. + -> Float -- ^ Epsilon to prevent division by 0. + -> IO (tensor a) + -- | Set the l2 norm of each instance to a constant. + l2Normalization + :: DType a + => tensor a -- ^ Input data to the L2NormalizationOp. + -> Float -- ^ Epsilon to prevent div 0, default is /1e-10/. + -> String -- ^ Normalization Mode, one of {'channel', 'instance', 'spatial'}, default is 'instance'. + -> IO (tensor a) + -- | Convolution Compute N-D convolution on (N+2)-D input. + convolution + :: DType a + => tensor a -- ^ Input data. + -> tensor a -- ^ Weight matrix. + -> tensor a -- ^ Bias parameter. + -> String -- ^ Convolution kernel size: (h, w) or (d, h, w). + -> Int -- ^ Convolution filter(channel) number. + -> IO (tensor a) + -- | Apply convolution to input then add a bias. + lrn :: DType a + => tensor a -- ^ Input data to the ConvolutionOp. + -> Float -- ^ Alpha, value of the alpha variance scaling parameter in the normalization formula, default is 0.0001. + -> Float -- ^ Beta, value of the beta power parameter in the normalization formula, default is 0.75. + -> Float -- ^ Value of the k parameter in normalization formula, default is 2. + -> Int -- ^ Normalization window width in elements. + -> IO (tensor a) + -- | Apply deconvolution to input then add a bias. + deconvolution + :: DType a + => tensor a -- ^ Input data to the DeconvolutionOp. + -> tensor a -- ^ Weight matrix. + -> tensor a -- ^ Bias parameter. + -> String -- ^ Convolution kernel size: (h, w) or (d, h, w). + -> Int -- ^ Convolution filter(channel) number. + -> IO (tensor a) + -- | Perform pooling on the input. + pooling + :: DType a + => tensor a -- ^ Input data to the pooling operator. + -> String -- ^ Pooling kernel size: (y, x) or (d, y, x). + -> String -- ^ Pooling type to be applied, one of {'avg', 'max', 'sum'}. + -> IO (tensor a) + -- | Performs region-of-interest pooling on inputs. + roiPooling + :: DType a + => tensor a -- ^ Input data to the pooling operator, a 4D Feature maps. + -> tensor a -- ^ Bounding box coordinates. + -> String -- ^ Fix pooled size: (h, w). + -> Int -- ^ Ratio of input feature map height (or w) to raw image height (or w). + -> IO (tensor a) + -- | Apply a recurrent layer to input. + rnn :: DType a + => tensor a -- ^ Input data to RNN. + -> tensor a -- ^ Vector of all RNN trainable parameters concatenated. + -> tensor a -- ^ Initial hidden state of the RNN. + -> tensor a -- ^ Initial cell state for LSTM networks (only for LSTM). + -> Int -- ^ Size of the state for each layer. + -> Int -- ^ Number of stacked layers. + -> String -- ^ The type of RNN to compute, one of {'gru', 'lstm', 'rnn_relu', 'rnn_tanh'}. + -> IO (tensor a) + -- | Map integer index to vector representations (embeddings). + embedding + :: DType a + => tensor a -- ^ Input data to the EmbeddingOp. + -> tensor a -- ^ Embedding weight matrix. + -> Int -- ^ Vocabulary size of the input indices. + -> Int -- ^ Dimension of the embedding vectors. + -> IO (tensor a) + -- | Apply bilinear sampling to input feature map, which is the key of “[NIPS2015] Spatial Transformer Networks” output[batch, channel, y_dst, x_dst] = G(data[batch, channel, y_src, x_src) x_dst, y_dst enumerate all spatial locations in output x_src = grid[batch, 0, y_dst, x_dst] y_src = grid[batch, 1, y_dst, x_dst] G() denotes the bilinear interpolation kernel The out-boundary points will be padded as zeros. + bilinearSampler + :: DType a + => tensor a -- ^ Input data to the BilinearsamplerOp. + -> tensor a -- ^ Input grid to the BilinearsamplerOp.grid has two channels: x_src, y_src. + -> IO (tensor a) + -- | generate sampling grid for bilinear sampling. + gridGenerator + :: DType a + => tensor a -- ^ Input data to the BilinearsamplerOp. + -> tensor a -- ^ Input grid to the BilinearsamplerOp.grid has two channels: x_src, y_src. + -> IO (tensor a) + -- | Perform nearest neighboor/bilinear up sampling to inputs + upSampling + :: DType a + => [tensor a] -- ^ Array of tensors to upsample. + -> Int -- ^ Up sampling scale. + -> String -- ^ Upsampling method, one of {'bilinear', 'nearest'}. + -> IO (tensor a) + -- | Apply spatial transformer to input feature map. + spatialTransformer + :: DType a + => tensor a -- ^ Input data to the SpatialTransformerOp. + -> tensor a -- ^ Localisation net, the output dim should be 6 when transform_type is affine. + -> IO (tensor a) + -- | Use linear regression for final output, this is used on final output of a net. + linearRegressionOutput + :: DType a + => tensor a -- ^ Input data to function. + -> tensor a -- ^ Input label to function. + -> IO (tensor a) + -- | Use Logistic regression for final output, this is used on final output of a net. + logisticRegressionOutput + :: DType a + => tensor a -- ^ Input data to function. + -> tensor a -- ^ Input label to function. + -> IO (tensor a) + -- | Softmax with logit loss. + softmaxOutput + :: DType a + => tensor a -- ^ Input data. + -> tensor a -- ^ Ground truth label. + -> IO (tensor a) + -- | Use mean absolute error regression for final output, this is used on final output of a net. + maeRegressionOutput + :: DType a + => tensor a -- ^ Input data to function. + -> tensor a -- ^ Input label to function. + -> IO (tensor a) + -- | Support Vector Machine based transformation on input, backprop L2-SVM + svmOutput + :: DType a + => tensor a -- ^ Input data to svm. + -> tensor a -- ^ Label data. + -> Int -- ^ Margin, scale the DType(param_.margin) for activation size, default is 1. + -> Float -- ^ Regularization coefficient, Scale the coefficient responsible for balacing coefficient size and error + -- tradeoff, default is 1. + -> Bool -- ^ Use linear, if set true, uses L1-SVM objective function. Default uses L2-SVM objective, default is False. + -> IO (tensor a) + -- | Calculate cross_entropy(data, one_hot(label)) + softmaxCrossEntropy + :: DType a + => tensor a -- ^ Input data. + -> tensor a -- ^ Input label. + -> IO (tensor a) + -- | Calculate Smooth L1 Loss(lhs, scalar) + smoothL1 + :: DType a + => tensor a -- ^ Source input + -> Float -- ^ Scalar input. + -> IO (tensor a) + -- | Apply a sparse regularization to the output a sigmoid activation function. + identityAttachKLSparsereg + :: DType a + => tensor a -- ^ Input data. + -> IO (tensor a) + -- | Get output from a symbol and pass 1 gradient back. + makeLoss + :: DType a + => tensor a -- ^ Input data. + -> Float -- ^ Gradient scale as a supplement to unary and binary operators, default is 1. + -> Float -- ^ Valid thresh, default is 0. Regard element valid when x > valid_thresh, this is used only + -- in valid normalization mode. + -> String -- ^ Normalization, one of {'batch', 'null', 'valid'}, default is 'null'. + -> IO (tensor a) + -- | Get output from a symbol and pass 0 gradient back + blockGrad + :: DType a + => tensor a -- ^ The input. + -> IO (tensor a) + -- | Custom operator implemented in frontend. + custom + :: DType a + => [tensor a] -- ^ Input of custom operator + -> String -- ^ Type of custom operator, must be registered first. + -> IO (tensor a) + + +-- | Context definition. +-- +-- * DeviceType +-- +-- 1. cpu +-- 2. gpu +-- 3. cpu_pinned +data Context = Context { deviceType :: Int + , deviceId :: Int + } deriving (Eq, Show) + +-- | Context for CPU 0. +contextCPU :: Context +contextCPU = Context 1 0 + +-- | Context for GPU 0. +contextGPU :: Context +contextGPU = Context 2 0 diff --git a/src/MXNet/Core/Base/Executor.hs b/src/MXNet/Core/Base/Executor.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/Executor.hs @@ -0,0 +1,46 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.Executor +-- copyright: (c) 2016 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Symbol module. +-- +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module MXNet.Core.Base.Executor where + +import Control.Monad +import MXNet.Core.Base.Internal +import MXNet.Core.Base.DType +import MXNet.Core.Base.NDArray (NDArray(NDArray)) + +-- | Type alias for variable. +newtype Executor a = Executor { getHandle :: ExecutorHandle } + +-- | Make an executor using the given handler. +makeExecutor :: DType a + => ExecutorHandle + -> IO (Executor a) +makeExecutor = return . Executor + +-- | Executor forward method. +forward :: DType a + => Executor a -- ^ The executor handle. + -> Bool -- ^ Whether this forward is for evaluation purpose. + -> IO () +forward exec train = void $ mxExecutorForward (getHandle exec) (if train then 1 else 0) + +-- | Executor backward method. +backward :: DType a + => Executor a -- ^ The executor handle. + -> IO () +backward exec = void $ mxExecutorBackward (getHandle exec) 0 [] + +getOutputs :: DType a + => Executor a + -> IO [NDArray a] +getOutputs exec = do + (_, outs) <- mxExecutorOutputs (getHandle exec) + return $ NDArray <$> outs diff --git a/src/MXNet/Core/Base/HMap.hs b/src/MXNet/Core/Base/HMap.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/HMap.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.HMap +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Updatable heterogeneous map. +-- +-- @ +-- > let a = add @"a" (1 :: Int) nil +-- > a +-- [a = 1] +-- > let b = update @"a" (+1) a +-- > b +-- [a = 2] +-- > let c = add @"b" (Nothing :: Maybe Float) b +-- > c +-- [b = Nothing, a = 2] +-- > set @"b" (Just 128) c +-- [b = Just 128.0, a = 2] +-- @ +-- +{-# OPTIONS_GHC -Wno-unused-foralls #-} +{-# OPTIONS_GHC -Wno-unused-type-patterns #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module MXNet.Core.Base.HMap + ( -- * HMap type definition + HMap + -- * Type level constraints and operators + , KV (..) + , ShowKV (..) + , MatchKVList (..) + -- * Operations on HMap. + , nil + , add + , add' + , (.+.) + , get + , (.->.) + , update + , set + , mergeTo + , dump + ) where + +import GHC.TypeLits +import Data.List (intercalate) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable, typeOf) + +data KV v = Symbol := v + +infixr 6 := + +data KVList (kvs :: [KV *]) where + Nil :: KVList '[] + Cons :: v -> KVList kvs -> KVList (k ':= v ': kvs) + +-- | If a KVList has a specified type of KV pair. +data IfHasKey = Yes Symbol | No + +-- | Find specified key-value type pair in KVList. +type family FindKV (k :: Symbol) v (kvs :: [KV *]) :: IfHasKey where + FindKV k _ '[] = 'No + FindKV k v (k ':= v ': kvs) = 'Yes k + FindKV k1 v1 (k2 ':= v2 ': kvs) = FindKV k1 v1 kvs + +-- | HMap definition. +newtype HMap (kvs :: [KV *]) = HMap { getKVList :: KVList kvs } + +-- | Constraint ensure 'HMap' must contain k-v pair. +class InDict (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where + get' :: HMap kvs -> v + update' :: (v -> v) -> HMap kvs -> HMap kvs + +instance {-# OVERLAPPING #-} InDict k v (k ':= v ': kvs) where + get' (HMap (Cons v _)) = v + {-# INLINE get' #-} + update' f (HMap (Cons v kvs)) = HMap $ Cons (f v) kvs + {-# INLINE update' #-} + +instance (InDict k v kvs, 'Yes k ~ FindKV k v (k' ':= v' ': kvs)) => InDict k v (k' ':= v' ': kvs) where + get' (HMap (Cons _ kvs)) = get' @k (HMap kvs) + {-# INLINE get' #-} + update' f (HMap (Cons v kvs)) = HMap $ Cons v (getKVList $ update' @k f (HMap kvs)) + {-# INLINE update' #-} + +-- | Create an empty HMap. +nil :: HMap '[] +nil = HMap Nil + +{-# INLINE nil #-} + +-- | Add a key-value pair into the HMap (via TypeApplications). +add :: forall k v kvs. 'No ~ FindKV k v kvs => v -> HMap kvs -> HMap (k ':= v ': kvs) +add v (HMap kvs) = HMap (Cons v kvs) + +{-# INLINE add #-} + +-- | Add a key-value pair into the HMap (via TypeApplications). +-- +-- FIXME should have a @'No ~ FindKV k v kvs@ constraint here. +add' :: forall k v kvs. Proxy k -> v -> HMap kvs -> HMap (k ':= v ': kvs) +add' _ v (HMap kvs) = HMap (Cons v kvs) + +{-# INLINE add' #-} + + +-- | Infix version of @add@. +(.+.) :: forall k v kvs. 'No ~ FindKV k v kvs => v -> HMap kvs -> HMap (k ':= v ': kvs) +(.+.) = add + +infix 8 .+. + +{-# INLINE (.+.) #-} + +-- | Get the value of an existing key. +get :: forall (k :: Symbol) v kvs. InDict k v kvs => HMap kvs -> v +get = get' @k + +{-# INLINE get #-} + +-- | Infix version of @get@. +(.->.) :: forall (k :: Symbol) v kvs. InDict k v kvs => HMap kvs -> v +(.->.) = get @k + +infix 7 .->. + +{-# INLINE (.->.) #-} + +-- | Update the value of an existing key. +update :: forall (k :: Symbol) v kvs. InDict k v kvs => (v -> v) -> HMap kvs -> HMap kvs +update = update' @k + +{-# INLINE update #-} + +-- | Set the value of an existing key. +set :: forall k v kvs. InDict k v kvs => v -> HMap kvs -> HMap kvs +set v = update' @k (const v) + +{-# INLINE set #-} + +-- | Merge the first KVList into the second one. +class MatchKVList (kvs1 :: [KV *]) (kvs2 :: [KV *]) where + -- | Update all values in the first HMap into the second KVList. + mergeTo' :: HMap kvs1 -> HMap kvs2 -> HMap kvs2 + +instance MatchKVList ('[]) (kvs2) where + mergeTo' _ m2 = m2 + +instance (MatchKVList kvs1 kvs2, InDict k v kvs2) => MatchKVList (k ':= v ': kvs1) kvs2 where + mergeTo' (HMap (Cons v kvs)) m2 = mergeTo' (HMap kvs) (set @k v m2) + +-- | Update all values in the first HMap into the second KVList. +mergeTo :: forall (kvs1 :: [KV *]) (kvs2 :: [KV *]). MatchKVList kvs1 kvs2 => HMap kvs1 -> HMap kvs2 -> HMap kvs2 +mergeTo = mergeTo' + +class ShowKV (kvs :: [KV *]) where + show' :: forall k v. KVList kvs -> [(String, String)] + +instance ShowKV '[] where + show' _ = [] + {-# INLINE show' #-} + +instance (KnownSymbol k, Typeable v, Show v, ShowKV kvs) => ShowKV (k ':= v ': kvs) where + show' (Cons v kvs') = showImpl v : show' kvs' + where showImpl value = (symbolVal (Proxy :: Proxy k), if typeOf value == typeOf "" then (init . tail . show) value else show value) -- special rule for string value. + {-# INLINE show' #-} + +instance ShowKV kvs => Show (HMap kvs) where + show m = "[" <> (intercalate ", " . map (\(k, v) -> k <> " = " <> v) . show' . getKVList $ m) <> "]" + {-# INLINE show #-} + +-- | Dump key-value pair in HMap as [(k, v)]. +dump :: forall kvs. ShowKV kvs => HMap kvs -> [(String, String)] +dump = show' . getKVList + +{-# INLINE dump #-} diff --git a/src/MXNet/Core/Base/Internal.hs b/src/MXNet/Core/Base/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/Internal.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.Internal +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Interfaces in core module of MXNet. +-- +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module MXNet.Core.Base.Internal + ( -- * Data type definitions + -- ** Type alias + MXUInt + , MXFloat + -- ** Handlers and Creators + , NDArrayHandle + , FunctionHandle + , AtomicSymbolCreator + , SymbolHandle + , AtomicSymbolHandle + , ExecutorHandle + , DataIterCreator + , DataIterHandle + , KVStoreHandle + , RecordIOHandle + , RtcHandle + -- ** Callback types + , ExecutorMonitorCallback + , CustomOpPropCreator + , MXKVStoreUpdater + , MXKVStoreServerController + -- * Error handling. + , mxGetLastError + -- * Global State setups + , mxRandomSeed + , mxNotifyShutdown + , mxSetProfilerConfig + , mxSetProfilerState + , mxDumpProfile + -- * NDArray creation and deletion + , mxNDArrayCreateNone + , mxNDArrayCreate + , mxNDArrayCreateEx + , mxNDArrayLoadFromRawBytes + , mxNDArraySaveRawBytes + , mxNDArraySave + , mxNDArrayLoad + , mxNDArraySyncCopyFromCPU + , mxNDArraySyncCopyToCPU + , mxNDArrayWaitToRead + , mxNDArrayWaitToWrite + , mxNDArrayWaitAll + , mxNDArrayFree + , mxNDArraySlice + , mxNDArrayAt + , mxNDArrayReshape + , mxNDArrayGetShape + , mxNDArrayGetData + , mxNDArrayGetDType + , mxNDArrayGetContext + -- * Functions on NDArray + , mxListFunctions + , mxGetFunction + , mxFuncGetInfo + , mxFuncDescribe + , mxFuncInvoke + , mxFuncInvokeEx + , mxImperativeInvoke + -- * Symbolic configuration generation + , mxListAllOpNames + , mxSymbolListAtomicSymbolCreators + , mxSymbolGetAtomicSymbolName + , mxSymbolGetAtomicSymbolInfo + , mxSymbolCreateAtomicSymbol + , mxSymbolCreateVariable + , mxSymbolCreateGroup + , mxSymbolCreateFromFile + , mxSymbolCreateFromJSON + , mxSymbolSaveToFile + , mxSymbolSaveToJSON + , mxSymbolFree + , mxSymbolCopy + , mxSymbolPrint + , mxSymbolGetName + , mxSymbolGetAttr + , mxSymbolSetAttr + , mxSymbolListAttr + , mxSymbolListAttrShallow + , mxSymbolListArguments + , mxSymbolListOutputs + , mxSymbolGetInternals + , mxSymbolGetOutput + , mxSymbolListAuxiliaryStates + , mxSymbolCompose + , mxSymbolGrad + , mxSymbolInferShape + , mxSymbolInferShapePartial + , mxSymbolInferType + -- * Executor interface + , mxExecutorFree + , mxExecutorPrint + , mxExecutorForward + , mxExecutorBackward + , mxExecutorOutputs + , mxExecutorBind + , mxExecutorBindX + , mxExecutorBindEX + , mxExecutorSetMonitorCallback + -- * IO Interface + , mxListDataIters + , mxDataIterCreateIter + , mxDataIterGetIterInfo + , mxDataIterFree + , mxDataIterNext + , mxDataIterBeforeFirst + , mxDataIterGetData + , mxDataIterGetIndex + , mxDataIterGetPadNum + , mxDataIterGetLabel + -- * Basic KVStore interface + , mxInitPSEnv + , mxKVStoreCreate + , mxKVStoreFree + , mxKVStoreInit + , mxKVStorePush + , mxKVStorePull + , mxKVStoreSetUpdater + , mxKVStoreGetType + -- * Advanced KVStore for multi-machines + , mxKVStoreGetRank + , mxKVStoreGetGroupSize + , mxKVStoreIsWorkerNode + , mxKVStoreIsServerNode + , mxKVStoreIsSchedulerNode + , mxKVStoreBarrier + , mxKVStoreSetBarrierBeforeExit + , mxKVStoreRunServer + , mxKVStoreSendCommmandToServers + , mxKVStoreGetNumDeadNode + , mxRecordIOWriterCreate + , mxRecordIOWriterFree + , mxRecordIOWriterWriteRecord + , mxRecordIOWriterTell + , mxRecordIOReaderCreate + , mxRecordIOReaderFree + , mxRecordIOReaderReadRecord + , mxRecordIOReaderSeek + , mxRtcCreate + , mxRtcPush + , mxRtcFree + , mxCustomOpRegister + ) where + +import MXNet.Core.Types.Internal +import MXNet.Core.Base.Internal.Raw diff --git a/src/MXNet/Core/Base/Internal/Raw.chs b/src/MXNet/Core/Base/Internal/Raw.chs --- a/src/MXNet/Core/Base/Internal/Raw.chs +++ b/src/MXNet/Core/Base/Internal/Raw.chs @@ -12,6 +12,9 @@ #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 801 +{-# LANGUAGE Strict #-} +#endif {-# LANGUAGE ForeignFunctionInterface #-} module MXNet.Core.Base.Internal.Raw where @@ -24,7 +27,7 @@ import C2HS.C.Extra.Marshal -{#import MXNet.Core.Internal.Types.Raw #} +{#import MXNet.Core.Types.Internal.Raw #} #include @@ -219,7 +222,7 @@ -- | Get the content of the data in NDArray. {#fun MXNDArrayGetData as mxNDArrayGetData { id `NDArrayHandle' -- ^ The NDArray handle. - , alloca- `Ptr MXFloat' peek* + , alloca- `Ptr ()' peek* } -> `Int' -- ^ Pointer holder to get pointer of data. #} @@ -246,11 +249,11 @@ } -> `Int' #} -- | List all the available functions handles. -mxListFunctions :: IO (Int, MXUInt, [FunctionHandle]) -- ^ The output function handle array. +mxListFunctions :: IO (Int, [FunctionHandle]) -- ^ The output function handle array. mxListFunctions = do (res, c, p) <- mxListFunctionsImpl fs <- peekArray (fromIntegral c) p - return (res, c, fs) + return (res, fs) -- | Get the function handle by name. {#fun MXGetFunction as mxGetFunction @@ -320,11 +323,61 @@ , withStringArray* `[String]' -- ^ Values for keyword parameters. } -> `Int' #} --- | Invoke a nnvm op and imperative function. FIXME -mxImperativeInvoke = undefined +{#fun MXImperativeInvoke as mxImperativeInvokeImpl + { id `AtomicSymbolCreator' -- ^ Creator of the OP. + , `Int' + , withArray* `[NDArrayHandle]' + , id `Ptr CInt' + , id `Ptr (Ptr NDArrayHandle)' + , `Int' + , withStringArray* `[String]' + , withStringArray* `[String]' + } -> `Int' #} +-- | Invoke a nnvm op and imperative function. +mxImperativeInvoke :: AtomicSymbolCreator -- ^ Creator/Handler of the OP. + -> [NDArrayHandle] -- ^ Input NDArrays. + -> [(String, String)] -- ^ Keywords parameters. + -> Maybe [NDArrayHandle] -- ^ Original given output handles array. + -> IO (Int, [NDArrayHandle]) -- ^ Return NDArrays as result. +mxImperativeInvoke creator inputs params outputs = do + let (keys, values) = unzip params + ninput = length inputs + nparam = length params + (res, n, p) <- case outputs of + Nothing -> alloca $ \pn -> + alloca $ \pp -> do + poke pn 0 + poke pp nullPtr + res' <- mxImperativeInvokeImpl creator ninput inputs pn pp nparam keys values + n' <- fromIntegral <$> peek pn + p' <- peek pp + return (res', n', p') + Just out -> alloca $ \pn -> + alloca $ \pp -> do + withArray out $ \p' -> do + poke pn (fromIntegral $ length out) + poke pp p' + res' <- mxImperativeInvokeImpl creator ninput inputs pn pp nparam keys values + n' <- fromIntegral <$> peek pn + return (res', n', p') + arrays <- if n == 0 then return [] else peekArray n p + return (res, arrays) + ------------------------------------------------------------------------------- +{#fun MXListAllOpNames as mxListAllOpNamesImpl + { alloca- `MXUInt' peek* + , alloca- `Ptr (Ptr CChar)' peek* + } -> `Int' #} + +-- | List all the available operator names, include entries. +mxListAllOpNames :: IO (Int, [String]) +mxListAllOpNames = do + (res, n, p) <- mxListAllOpNamesImpl + names <- peekStringArray (fromIntegral n :: Int) p + return (res, names) + {#fun MXSymbolListAtomicSymbolCreators as mxSymbolListAtomicSymbolCreatorsImpl { alloca- `MXUInt' peek* , alloca- `Ptr AtomicSymbolCreator' peek* @@ -332,12 +385,11 @@ -- | List all the available @AtomicSymbolCreator@. mxSymbolListAtomicSymbolCreators - :: IO (Int, MXUInt, [AtomicSymbolCreator]) -- ^ The number of atomic symbol creators and - -- the atomic symbol creators list. + :: IO (Int, [AtomicSymbolCreator]) -- ^ The atomic symbol creators list. mxSymbolListAtomicSymbolCreators = do (res, n, p) <- mxSymbolListAtomicSymbolCreatorsImpl ss <- peekArray (fromIntegral n) p - return (res, n, ss) + return (res, ss) -- | Get the name of an atomic symbol. {#fun MXSymbolGetAtomicSymbolName as mxSymbolGetAtomicSymbolName @@ -354,27 +406,27 @@ , alloca- `Ptr (Ptr CChar)' peek* , alloca- `Ptr (Ptr CChar)' peek* , alloca- `Ptr (Ptr CChar)' peek* - , withStringArray* `[String]' , alloca- `String' peekString* + , alloca- `String' peekString* } -> `Int' #} -- | Get the detailed information about atomic symbol. mxSymbolGetAtomicSymbolInfo :: AtomicSymbolCreator - -> [String] -- ^ TODO document for this argument. - -- The keyword arguments for specifying variable - -- number of arguments. -> IO (Int, String, String, MXUInt, [String], [String], [String], - String) -- ^ Return the name and description of the symbol, + String, String) -- ^ Return the name and description of the symbol, -- the name, type and description of it's arguments, - -- as well as the return type of this symbol. -mxSymbolGetAtomicSymbolInfo creator kargs = do - (res, name, desc, argc, argv, argtype, argdesc, rettype) <- mxSymbolGetAtomicSymbolInfoImpl creator kargs + -- the keyword argument for specifying variable number + -- of arguments, as well as the return type of this + -- symbol. +mxSymbolGetAtomicSymbolInfo creator = do + -- Documentation for kargs: https://github.com/dmlc/mxnet/blob/master/include/mxnet/c_api.h#L555 + (res, name, desc, argc, argv, argtype, argdesc, kargs, rettype) <- mxSymbolGetAtomicSymbolInfoImpl creator argv' <- peekStringArray argc argv argtype' <- peekStringArray argc argtype argdesc' <- peekStringArray argc argdesc - return (res, name, desc, argc, argv', argtype', argdesc', rettype) + return (res, name, desc, argc, argv', argtype', argdesc', kargs, rettype) -- | Create an AtomicSymbol. {#fun MXSymbolCreateAtomicSymbol as mxSymbolCreateAtomicSymbol @@ -476,12 +528,11 @@ -- | Get all attributes from symbol, including all descendents. mxSymbolListAttr :: SymbolHandle - -> IO (Int, MXUInt, [String]) -- ^ The number of attributes and - -- attributes list. + -> IO (Int, [String]) -- ^ The attributes list. mxSymbolListAttr symbol = do (res, n, p) <- mxSymbolListAttrImpl symbol ss <- peekStringArray n p - return (res, n, ss) + return (res, ss) {#fun MXSymbolListAttrShallow as mxSymbolListAttrShallowImpl { id `SymbolHandle' @@ -491,12 +542,11 @@ -- | Get all attributes from symbol, excluding descendents. mxSymbolListAttrShallow :: SymbolHandle - -> IO (Int, MXUInt, [String]) -- ^ The number of attributes and - -- attributes list. + -> IO (Int, [String]) -- ^ The attributes list. mxSymbolListAttrShallow symbol = do (res, n, p) <- mxSymbolListAttrShallowImpl symbol ss <- peekStringArray n p - return (res, n, ss) + return (res, ss) {#fun MXSymbolListArguments as mxSymbolListArgumentsImpl { id `SymbolHandle' @@ -506,12 +556,11 @@ -- | List arguments in the symbol. mxSymbolListArguments :: SymbolHandle - -> IO (Int, MXUInt, [String]) -- ^ The number of arguments and list of - -- arguments' names. + -> IO (Int, [String]) -- ^ List of arguments' names. mxSymbolListArguments symbol = do (res, n, p) <- mxSymbolListArgumentsImpl symbol ss <- peekStringArray n p - return (res, n, ss) + return (res, ss) {#fun MXSymbolListOutputs as mxSymbolListOutputsImpl { id `SymbolHandle' @@ -521,12 +570,11 @@ -- | List returns in the symbol. mxSymbolListOutputs :: SymbolHandle - -> IO (Int, MXUInt, [String]) -- ^ The number of outputs and list of - -- outputs' names. + -> IO (Int, [String]) -- ^ The outputs' names. mxSymbolListOutputs symbol = do (res, n, p) <- mxSymbolListOutputsImpl symbol ss <- peekStringArray n p - return (res, n, ss) + return (res, ss) -- | Get a symbol that contains all the internals. {#fun MXSymbolGetInternals as mxSymbolGetInternals @@ -552,11 +600,11 @@ -- | List auxiliary states in the symbol. mxSymbolListAuxiliaryStates :: SymbolHandle - -> IO (Int, MXUInt, [String]) -- ^ The output size and the output string array. + -> IO (Int, [String]) -- ^ The output string array. mxSymbolListAuxiliaryStates symbol = do (res, n, p) <- mxSymbolListAuxiliaryStatesImpl symbol ss <- peekStringArray n p - return (res, n, ss) + return (res, ss) -- | Compose the symbol on other symbols. {#fun MXSymbolCompose as mxSymbolCompose @@ -580,8 +628,8 @@ { id `SymbolHandle' , id `MXUInt' , withStringArray* `[String]' - , id `Ptr MXUInt' - , id `Ptr MXUInt' + , withIntegralArray* `[Int]' + , withIntegralArray* `[Int]' , alloca- `MXUInt' peek* , alloca- `Ptr MXUInt' peek* , alloca- `Ptr (Ptr MXUInt)' peek* @@ -595,37 +643,38 @@ } -> `Int' #} -- | Infer shape of unknown input shapes given the known one. -mxSymbolInferShape :: SymbolHandle -- ^ Symbol handle. - -> MXUInt -- ^ Number of input arguments. - -> [String] -- ^ Number of input arguments. - -> Ptr MXUInt -- ^ Keys of keyword arguments, optional. - -> Ptr MXUInt -- ^ The head pointer of the rows in CSR - -> IO (Int, - (MXUInt, [MXUInt], [Ptr MXUInt]), - (MXUInt, [MXUInt], [Ptr MXUInt]), - (MXUInt, [MXUInt], [Ptr MXUInt]), - Int) -- ^ Return the in, out and auxiliary - -- shape size, ndim and data (array - -- of pointers to head of the input - -- shape), and whether infer shape - -- completes or more information is - -- needed. -mxSymbolInferShape sym argc keys indptr shapedata = do - (res, in_size, in_ndim, in_data, out_size, out_ndim, out_data, aux_size, aux_ndim, aux_data, success) <- mxSymbolInferShapeImpl sym argc keys indptr shapedata - in_ndim' <- peekArray (fromIntegral in_size) in_ndim +mxSymbolInferShape + :: SymbolHandle -- ^ Symbol handle. + -> [String] -- ^ Keys of keyword arguments, optional. + -> [Int] -- ^ The head pointer of the rows in CSR. + -> [Int] -- ^ The content of the CSR. + -> IO (Int, [[Int]], [[Int]], [[Int]]) -- ^ Return the in, out and auxiliary + -- shape size, ndim and data (array + -- of pointers to head of the input + -- shape), and whether infer shape + -- completes or more information is + -- needed. +mxSymbolInferShape sym keys ind shapedata = do + let argc = fromIntegral (length keys) -- Number of input arguments. + -- Notice: the complete result are ignored for simplification. + (res, in_size, in_ndim, in_data, out_size, out_ndim, out_data, aux_size, aux_ndim, aux_data, _) <- mxSymbolInferShapeImpl sym argc keys ind shapedata + in_ndim' <- peekIntegralArray (fromIntegral in_size) in_ndim in_data' <- peekArray (fromIntegral in_size) in_data - out_ndim' <- peekArray (fromIntegral out_size) out_ndim + in_data'' <- mapM (uncurry peekIntegralArray) (zip in_ndim' in_data') + out_ndim' <- peekIntegralArray (fromIntegral out_size) out_ndim out_data' <- peekArray (fromIntegral out_size) out_data - aux_ndim' <- peekArray (fromIntegral aux_size) aux_ndim + out_data'' <- mapM (uncurry peekIntegralArray) (zip out_ndim' out_data') + aux_ndim' <- peekIntegralArray (fromIntegral aux_size) aux_ndim aux_data' <- peekArray (fromIntegral aux_size) aux_data - return (res, (in_size, in_ndim', in_data'), (out_size, out_ndim', out_data'), (aux_size, aux_ndim', aux_data'), success) + aux_data'' <- mapM (uncurry peekIntegralArray) (zip aux_ndim' aux_data') + return (res, in_data'', out_data'', aux_data'') {#fun MXSymbolInferShapePartial as mxSymbolInferShapePartialImpl { id `SymbolHandle' , id `MXUInt' , withStringArray* `[String]' - , id `Ptr MXUInt' - , id `Ptr MXUInt' + , withIntegralArray* `[Int]' + , withIntegralArray* `[Int]' , alloca- `MXUInt' peek* , alloca- `Ptr MXUInt' peek* , alloca- `Ptr (Ptr MXUInt)' peek* @@ -640,47 +689,60 @@ -- | Partially infer shape of unknown input shapes given the known one. mxSymbolInferShapePartial - :: SymbolHandle -- ^ Symbol handle. - -> MXUInt -- ^ Number of input arguments. - -> [String] -- ^ Number of input arguments. - -> Ptr MXUInt -- ^ Keys of keyword arguments, optional. - -> Ptr MXUInt -- ^ The head pointer of the rows in CSR - -> IO (Int, - (MXUInt, [MXUInt], [Ptr MXUInt]), - (MXUInt, [MXUInt], [Ptr MXUInt]), - (MXUInt, [MXUInt], [Ptr MXUInt]), - Int) -- ^ Return the in, out and auxiliary array's - -- shape size, ndim and data (array of pointers - -- to head of the input shape), and whether - -- infer shape completes or more information is - -- needed. -mxSymbolInferShapePartial sym argc keys indptr shapedata = do - (res, in_size, in_ndim, in_data, out_size, out_ndim, out_data, aux_size, aux_ndim, aux_data, success) <- mxSymbolInferShapePartialImpl sym argc keys indptr shapedata - in_ndim' <- peekArray (fromIntegral in_size) in_ndim + :: SymbolHandle -- ^ Symbol handle. + -> [String] -- ^ Keys of keyword arguments, optional. + -> [Int] -- ^ The head pointer of the rows in CSR. + -> [Int] -- ^ The content of the CSR. + -> IO (Int, [[Int]], [[Int]], [[Int]]) -- ^ Return the in, out and auxiliary array's + -- shape size, ndim and data (array of pointers + -- to head of the input shape), and whether + -- infer shape completes or more information is + -- needed. +mxSymbolInferShapePartial sym keys ind shapedata = do + let argc = fromIntegral (length keys) -- Number of input arguments. + -- Notice: the complete result are ignored for simplification. + (res, in_size, in_ndim, in_data, out_size, out_ndim, out_data, aux_size, aux_ndim, aux_data, _) <- mxSymbolInferShapePartialImpl sym argc keys ind shapedata + in_ndim' <- peekIntegralArray (fromIntegral in_size) in_ndim in_data' <- peekArray (fromIntegral in_size) in_data - out_ndim' <- peekArray (fromIntegral out_size) out_ndim + in_data'' <- mapM (uncurry peekIntegralArray) (zip in_ndim' in_data') + out_ndim' <- peekIntegralArray (fromIntegral out_size) out_ndim out_data' <- peekArray (fromIntegral out_size) out_data - aux_ndim' <- peekArray (fromIntegral aux_size) aux_ndim + out_data'' <- mapM (uncurry peekIntegralArray) (zip out_ndim' out_data') + aux_ndim' <- peekIntegralArray (fromIntegral aux_size) aux_ndim aux_data' <- peekArray (fromIntegral aux_size) aux_data - return (res, (in_size, in_ndim', in_data'), (out_size, out_ndim', out_data'), (aux_size, aux_ndim', aux_data'), success) + aux_data'' <- mapM (uncurry peekIntegralArray) (zip aux_ndim' aux_data') + return (res, in_data'', out_data'', aux_data'') --- | Infer type of unknown input types given the known one. -{#fun MXSymbolInferType as mxSymbolInferType +{#fun MXSymbolInferType as mxSymbolInferTypeImpl { id `SymbolHandle' -- ^ Symbol handle. , id `MXUInt' -- ^ Number of input arguments. , withStringArray* `[String]' -- ^ Key of keyword arguments, optional. - , id `Ptr CInt' -- ^ The content of the CSR. + , withIntegralArray* `[Int]' -- ^ The content of the CSR. , alloca- `MXUInt' peek* - , alloca- `Ptr CInt' + , alloca- `Ptr CInt' peek* , alloca- `MXUInt' peek* - , alloca- `Ptr CInt' + , alloca- `Ptr CInt' peek* , alloca- `MXUInt' peek* - , alloca- `Ptr CInt' + , alloca- `Ptr CInt' peek* , alloca- `Int' peekIntegral* } -> `Int' -- ^ Return the size and an array of pointers to head the input, output and -- auxiliary type, as well as whether infer type completes or more information -- is needed. #} + +-- | Infer type of unknown input types given the known one. +mxSymbolInferType :: SymbolHandle -- ^ Symbol handle. + -> [String] -- ^ Input arguments. + -> IO (Int, [Int], [Int], [Int]) -- ^ Return arg_types, out_types and aux_types. +mxSymbolInferType handle args = do + let nargs = fromIntegral (length args) + csr = [] + -- Notice: the complete result are ignored for simplification. + (res, narg, parg, nout, pout, naux, paux, _) <- mxSymbolInferTypeImpl handle nargs args csr + args <- peekIntegralArray (fromIntegral narg) parg + outs <- peekIntegralArray (fromIntegral nout) pout + auxs <- peekIntegralArray (fromIntegral naux) paux + return (res, args, outs, auxs) ------------------------------------------------------------------------------- diff --git a/src/MXNet/Core/Base/Internal/TH.hs b/src/MXNet/Core/Base/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/Internal/TH.hs @@ -0,0 +1,437 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.Internal.TH +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Template haskell tools for finding Ops on NDArray and Symbol from dynamic library. +-- +module MXNet.Core.Base.Internal.TH where + +import Data.Char +import Data.List +import Data.Monoid +import Language.Haskell.TH + +import MXNet.Core.NNVM.Internal +import MXNet.Core.Base.Internal + +------------------------------------------------------------------------------- + +-- | Register NDArray ops. +registerNDArrayOps :: Bool -- ^ If support "out" key in argument dictionary. + -> Q [Dec] +registerNDArrayOps mutable = runIO $ do + (_, names) <- mxListAllOpNames + concat <$> mapM (register mutable) names + where + register mutable _name = do + (_, handle) <- nnGetOpHandle _name + (_, _, desc, _, argv, argtype, _, _, _) <- mxSymbolGetAtomicSymbolInfo handle + makeNDArrayFunc mutable _name desc argv argtype + +-- | Register symbol functions. +registerSymbolOps :: Q [Dec] +registerSymbolOps = runIO $ do + (_, names) <- mxListAllOpNames + concat <$> mapM register names + where + register _name = do + (_, handle) <- nnGetOpHandle _name + (_, _, desc, _, argv, argtype, _, _, _) <- mxSymbolGetAtomicSymbolInfo handle + makeSymbolFunc _name desc argv argtype + +------------------------------------------------------------------------------- +-- | Generate the TH AST of a function for a NDArray op. +makeNDArrayFunc :: Bool -- ^ If support "out" key in argument dictionary. + -> String -- ^ Function's name. + -> String -- ^ Function's description. + -> [String] -- ^ Function's argument names. + -> [String] -- ^ Function's argument types. + -> IO [Dec] -- ^ Generated signature and function definition. +makeNDArrayFunc mutable _name desc argv argtype = do + + let deprecated = desc `startWith` "DEPRECATED" || + _name == "Softmax" -- Softmax is renamed to SoftmaxOutput + + let alias = _name `elem` ["Concat", "Pad", "Flatten", "Reshape"] + + let name = let str = if head _name == '_' + then _name + else if _name == "where" + then "where_" + else toLower <$> _name + in if mutable then str <> "'" else str + + let explicitArg = getExplicitArg argv argtype + ndarrayArg = filter (\(_, t) -> t `startWith` "NDArray" || t `startWith` "Symbol") explicitArg + ordinaryArg = filter (\(_, t) -> not (t `startWith` "NDArray" || t `startWith` "Symbol")) explicitArg + implicitArg = getImplicitArg argv argtype + hasImplicit = (not . null) implicitArg + + let forallArgT = makeForallArgT implicitArg + + explicitArgT = (makeHsType . snd) <$> explicitArg + + implicitArgT = if hasImplicit + then [AppT (ConT (mkName "HMap")) (VarT (mkName "kvs"))] + else error "Impossible: no implicit available." -- will never be evaluated + + let ndarrayArgP = (VarP . mkName . ("arg'" <>) . fst) <$> ndarrayArg + ordinaryArgP = (VarP . mkName . ("arg'" <>) . fst) <$> ordinaryArg + implicitArgP = if hasImplicit + then [VarP . mkName $ "varargs"] + else [] + returnArgP = if mutable + then [VarP (mkName "outputs")] + else [] + + let ndargs = foldr (\(v, t) args-> case makeHsType t of + ConT _ -> UInfixE (VarE . mkName . ("arg'" <>) $ v) (ConE . mkName $ ":") args + AppT ListT _ -> UInfixE (VarE . mkName . ("arg'" <>) $ v) (VarE . mkName $ "++") args + _ -> error "Impossible: not a valid haskell type representation.") + (ListE []) + ndarrayArg + + dictargs = UInfixE (VarE (mkName "varArgK")) (VarE (mkName "zip")) (VarE (mkName "varArgV")) + + let func = NormalB . DoE $ + [ LetS [ ValD (VarP (mkName "allArgs")) + (NormalB $ + foldr (\(name, t) acc -> AppE (AppE (AppE (VarE (mkName "add'")) + (SigE (ConE (mkName "Proxy")) + (AppT (ConT (mkName "Proxy")) (LitT (StrTyLit name))))) + (SigE (VarE (mkName ("arg'" <> name))) (makeHsType t))) + acc) + (VarE (mkName $ if hasImplicit then "varargs" else "nil")) + ordinaryArg + ) + [] + ] + , LetS [ ValD (VarP (mkName "args")) + (NormalB $ + AppE (VarE (mkName "dump")) + (VarE (mkName "allArgs")) + ) + [] + , ValD (TupP [VarP (mkName "varArgK"), VarP (mkName "varArgV")]) + (NormalB $ + AppE (VarE (mkName "unzip")) + (VarE (mkName "args")) + ) + [] + , ValD (VarP (mkName "outArg")) + (NormalB $ + if mutable + then AppE (ConE (mkName "Just")) (VarE (mkName "outputs")) + else ConE (mkName "Nothing") + ) + [] + ] + , BindS (TupP [VarP (mkName "_"), VarP (mkName "op")]) $ + AppE (VarE (mkName "nnGetOpHandle")) (LitE (StringL _name)) + , BindS (TupP [VarP (mkName "_"), VarP (mkName "res")]) $ + AppE (AppE (AppE (AppE (VarE (mkName "mxImperativeInvoke")) + (VarE (mkName "op"))) + ndargs) + dictargs) + (VarE (mkName "outArg")) + , NoBindS $ + AppE (VarE (mkName "return")) $ + AppE (VarE (mkName "toResult")) (VarE (mkName "res")) + ] + + let argT = explicitArgT <> (if hasImplicit then implicitArgT else []) + <> (if mutable then [AppT ListT (ConT (mkName "NDArrayHandle"))] else []) + + sig = SigD (mkName name) $ + ForallT [ PlainTV (mkName "r")] + [ AppT (ConT (mkName "NDArrayOpResult")) (VarT (mkName "r"))] + (forallArgT (foldr (\a b -> ArrowT `AppT` a `AppT` b) + (AppT (ConT (mkName "IO")) (VarT (mkName "r"))) + argT)) + + pragma = PragmaD $ + SpecialiseP (mkName name) + (forallArgT (foldr (\a b -> ArrowT `AppT` a `AppT` b) + (AppT (ConT (mkName "IO")) (ConT (mkName "NDArrayHandle"))) + argT)) + (Just Inline) + AllPhases + + fun = FunD (mkName name) [Clause (ndarrayArgP <> ordinaryArgP <> implicitArgP <> returnArgP) func []] + + + return $ if null argv || deprecated + || alias + || _name `elem` ["_NDArray", "_Native", "_arange"] + || _name `elem` ["cast", "crop"] -- duplicate with "Cast" and "Crop" + || null explicitArg + || _name == "take" -- Operator @take@ will take two @SymbolHandle@ as arguments, can't be marshalled as strings. + then [] + else [sig, fun, pragma] + where + -- | Translate mxnet's type name to Haskell's type name. + makeHsType :: String -> Type + makeHsType s = case s of + "boolean" -> ConT . mkName $ "Bool" + "float" -> ConT . mkName $ "Float" + "double" -> ConT . mkName $ "Double" + "real_t" -> ConT . mkName $ "Float" + 'i':'n':'t':_ -> ConT . mkName $ "Int" + 'l':'o':'n':'g':_ -> ConT . mkName $ "Int" + "string" -> ConT . mkName $ "String" + "NDArray" -> ConT . mkName $ "NDArrayHandle" + "NDArray-or-Symbol" -> ConT . mkName $ "NDArrayHandle" + "NDArray-or-Symbol[]" -> AppT ListT . ConT . mkName $ "NDArrayHandle" + "Symbol" -> ConT . mkName $ "NDArrayHandle" + "NDArray[]" -> AppT ListT . ConT . mkName $ "NDArrayHandle" + "Symbol[]" -> AppT ListT . ConT . mkName $ "NDArrayHandle" + "Symbol or Symbol[]" -> AppT ListT . ConT . mkName $ "NDArrayHandle" + '{':_ -> ConT . mkName $ "String" + "Shape(tuple)" -> ConT . mkName $ "String" + "tuple of " -> AppT ListT . ConT . mkName $ "Float" + "tuple of " -> AppT ListT . ConT . mkName $ "Double" + s -> ConT . mkName $ "unknown type name: " <> s + + -- | Generate type signatures for implicit arguments. + makeKVListT :: [(String, String, String)] -- ^ [(name, type, default value)] + -> Type + makeKVListT args = foldr combineKV PromotedNilT ((\(v, t, _) -> makeKV v t) <$> args) + where + makeKV v t = AppT (AppT (PromotedT (mkName ":=")) + (LitT (StrTyLit v))) + (makeHsType t) + combineKV a acc = AppT (AppT (PromotedT (mkName ":")) a) acc + + -- | Make forall arguments signature according to it's implicit argument. + makeForallArgT :: [(String, String, String)] -- ^ Implicit arguments, (name, type, default value) + -> (Type -> Type) + makeForallArgT [] = id + makeForallArgT implicitArg = + ForallT [ KindedTV (mkName "kvs") + (AppT ListT + (AppT (ConT (mkName "KV")) StarT)) + ] + [ AppT (ConT (mkName "ShowKV")) + (VarT (mkName "kvs")) + , AppT (AppT (ConT (mkName "MatchKVList")) + (VarT (mkName "kvs"))) + (makeKVListT implicitArg) + ] + +-- | Generate the TH AST of a function for a Symbol op. +makeSymbolFunc :: String -- ^ Function's name. + -> String -- ^ Function's description. + -> [String] -- ^ Function's argument names. + -> [String] -- ^ Function's argument types. + -> IO [Dec] -- ^ Generated signature and function definition. +makeSymbolFunc _name desc argv argtype = do + + let deprecated = desc `startWith` "DEPRECATED" || + _name == "Softmax" -- Softmax is renamed to SoftmaxOutput + + let alias = _name `elem` ["Concat", "Pad", "Flatten", "Reshape"] + + let name = let str = if head _name == '_' + then _name + else if _name == "where" + then "where_" + else toLower <$> _name + in str + + let explicitArg = getExplicitArg argv argtype + ndarrayArg = filter (\(v, t) -> t `startWith` "NDArray" || t `startWith` "Symbol") explicitArg + ordinaryArg = filter (\(v, t) -> not (t `startWith` "NDArray" || t `startWith` "Symbol")) explicitArg + implicitArg = getImplicitArg argv argtype + hasImplicit = (not . null) implicitArg + + let forallArgT = makeForallArgT implicitArg + + explicitArgT = (makeHsType . snd) <$> explicitArg + + implicitArgT = if hasImplicit + then [AppT (ConT (mkName "HMap")) (VarT (mkName "kvs"))] + else error "Impossible: no implicit available." -- will never be evaluated + + let nameArgP = [VarP . mkName $ "name"] + ndarrayArgP = (VarP . mkName . ("arg'" <>) . fst) <$> ndarrayArg + ordinaryArgP = (VarP . mkName . ("arg'" <>) . fst) <$> ordinaryArg + implicitArgP = if hasImplicit + then [VarP . mkName $ "varargs"] + else [] + + let ndargs = foldr (\(v, t) args -> case makeHsType t of + ConT _ -> UInfixE (VarE . mkName . ("arg'" <>) $ v) (ConE . mkName $ ":") args + AppT ListT _ -> UInfixE (VarE . mkName . ("arg'" <>) $ v) (VarE . mkName $ "++") args + _ -> error "Impossible: not a valid haskell type representation.") + (ListE []) + ndarrayArg + + let func = NormalB . DoE $ + [ LetS [ ValD (VarP (mkName "allArgs")) + (NormalB $ + foldr (\(name, t) acc -> AppE (AppE (AppE (VarE (mkName "add'")) + (SigE (ConE (mkName "Proxy")) + (AppT (ConT (mkName "Proxy")) (LitT (StrTyLit name))))) + (SigE (VarE (mkName ("arg'" <> name))) (makeHsType t))) + acc) + (VarE (mkName $ if hasImplicit then "varargs" else "nil")) + ordinaryArg + ) + [] + ] + , LetS [ ValD (VarP (mkName "args")) + (NormalB $ + AppE (VarE (mkName "dump")) + (VarE (mkName "allArgs")) + ) + [] + , ValD (TupP [VarP (mkName "varArgK"), VarP (mkName "varArgV")]) + (NormalB $ + AppE (VarE (mkName "unzip")) + (VarE (mkName "args")) + ) + [] + ] + , BindS (TupP [VarP (mkName "_"), VarP (mkName "op")]) $ + AppE (VarE (mkName "nnGetOpHandle")) (LitE (StringL _name)) + , LetS [ ValD (VarP (mkName "nargs")) + (NormalB (AppE (VarE (mkName "fromIntegral")) + (AppE (VarE (mkName "length")) + (VarE (mkName "varArgK"))))) + [] + ] + , BindS (TupP [VarP (mkName "_"), VarP (mkName "sym")]) $ + AppE (AppE (AppE (AppE (VarE (mkName "mxSymbolCreateAtomicSymbol")) + (VarE (mkName "op"))) + (VarE (mkName "nargs"))) + (VarE (mkName "varArgK"))) + (VarE (mkName "varArgV")) + , BindS (VarP (mkName "_")) $ + AppE (AppE (AppE (AppE (VarE (mkName "nnSymbolCompose")) + (VarE (mkName "sym"))) + (VarE (mkName "name"))) + (ListE [])) + ndargs + , NoBindS $ + AppE (VarE (mkName "return")) + (VarE (mkName "sym")) + ] + + let argT = (ConT . mkName $ "String") : explicitArgT <> (if hasImplicit then implicitArgT else []) + + sig = SigD (mkName name) $ + forallArgT (foldr (\a b -> ArrowT `AppT` a `AppT` b) + (AppT (ConT (mkName "IO")) (ConT (mkName "SymbolHandle"))) + argT) + + fun = FunD (mkName name) [Clause (nameArgP <> ndarrayArgP <> ordinaryArgP <> implicitArgP) func []] + + + return $ if null argv || deprecated + || alias + || _name `elem` ["_NDArray", "_Native", "_arange"] + || _name `elem` ["cast", "crop"] -- duplicate with "Cast" and "Crop" + || null explicitArg + || _name == "take" -- Operator @take@ will take two @SymbolHandle@ as arguments, can't be marshalled as strings. + || _name == "where" + then [] + else [sig, fun] + where + -- | Translate mxnet's type name to Haskell's type name. + makeHsType :: String -> Type + makeHsType s = case s of + "boolean" -> ConT . mkName $ "Bool" + "float" -> ConT . mkName $ "Float" + "double" -> ConT . mkName $ "Double" + "real_t" -> ConT . mkName $ "Float" + 'i':'n':'t':_ -> ConT . mkName $ "Int" + 'l':'o':'n':'g':_ -> ConT . mkName $ "Int" + "string" -> ConT . mkName $ "String" + "NDArray" -> ConT . mkName $ "SymbolHandle" + "Symbol" -> ConT . mkName $ "SymbolHandle" + "NDArray-or-Symbol" -> ConT . mkName $ "SymbolHandle" + "NDArray-or-Symbol[]" -> AppT ListT . ConT . mkName $ "SymbolHandle" + "NDArray[]" -> AppT ListT . ConT . mkName $ "SymbolHandle" + "Symbol[]" -> AppT ListT . ConT . mkName $ "SymbolHandle" + "Symbol or Symbol[]" -> AppT ListT . ConT . mkName $ "SymbolHandle" + '{':_ -> ConT . mkName $ "String" + "Shape(tuple)" -> ConT . mkName $ "String" + "tuple of " -> AppT ListT . ConT . mkName $ "Float" + "tuple of " -> AppT ListT . ConT . mkName $ "Double" + s -> ConT . mkName $ "unknown type name: " <> s + + -- | Generate type signatures for implicit arguments. + makeKVListT :: [(String, String, String)] -- ^ [(name, type, default value)] + -> Type + makeKVListT args = foldr combineKV PromotedNilT ((\(v, t, _) -> makeKV v t) <$> args) + where + makeKV v t = AppT (AppT (PromotedT (mkName ":=")) + (LitT (StrTyLit v))) + (makeHsType t) + combineKV a acc = AppT (AppT (PromotedT (mkName ":")) a) acc + + -- | Make forall arguments signature according to it's implicit argument. + makeForallArgT :: [(String, String, String)] -- ^ Implicit arguments, (name, type, default value) + -> (Type -> Type) + makeForallArgT [] = id + makeForallArgT implicitArg = + ForallT [ KindedTV (mkName "kvs") + (AppT ListT + (AppT (ConT (mkName "KV")) StarT)) + ] + [ AppT (ConT (mkName "ShowKV")) + (VarT (mkName "kvs")) + , AppT (AppT (ConT (mkName "MatchKVList")) + (VarT (mkName "kvs"))) + (makeKVListT implicitArg) + ] + +------------------------------------------------------------------------------- + +-- | @startWith s t@ means @s@ starts with @t@. +startWith :: String -> String -> Bool +startWith s t = take (length t) s == t + +-- | Prepend elements in the second map into the first one. +updateMap :: [(String, String)] -> [(String, String)] -> [(String, String)] +updateMap xs [] = xs +updateMap xs ((k, v) : ts) = case findIndex ((== k) . fst) xs of + Just _ -> xs `updateMap` ts + Nothing -> ((k, v) : xs) `updateMap` ts + +-- | Split argument string with ",", split name, type, default value and required information. +splitArgType :: String -> [String] +splitArgType (' ' : xs) = splitArgType xs +splitArgType ts = case break (== ',') ts of + ([], _) -> [] + (t, []) -> [t] + (t, _:xs) -> t : splitArgType xs + +-- | Get explicit arguments from all arugments. +getExplicitArg :: [String] -- ^ Argument names. + -> [String] -- ^ Argument types. + -> [(String, String)] -- ^ Return necessary arguments' name and type. +getExplicitArg argv argtype = [t | Just t <- resolve <$> zip argv argtype] + where + resolve (v, t) = let ts = splitArgType t + in if "optional" `elem` ts + then Nothing + else if null ts -- Seems that `tuple of ` can't be exported correctly by mxSymbolGetAtomicSymbolInfo. + then Just (v, "tuple of ") + else Just (v, head ts) + +-- | Get implicit arguments from all arguments. +getImplicitArg :: [String] -- ^ Argument names. + -> [String] -- ^ Argument types. + -> [(String, String, String)] -- ^ Return necessary arguments' names, types and default value. +getImplicitArg argv argtype = [t | Just t <- resolve <$> zip argv argtype] + where + resolve (v, t) = let ts = splitArgType t + in if "optional" `elem` ts + then (\a -> (v, head ts, a)) <$> getDefault ts + else Nothing + + getDefault = stripPrefix "default=" . head . filter (isPrefixOf "default=") diff --git a/src/MXNet/Core/Base/Internal/TH/NDArray.hs b/src/MXNet/Core/Base/Internal/TH/NDArray.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/Internal/TH/NDArray.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.Internal.TH.NDArray +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Functions about NDArray that generated by template haskell. +-- +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module MXNet.Core.Base.Internal.TH.NDArray where + +import Data.Proxy + +import MXNet.Core.Base.HMap +import MXNet.Core.Base.Internal +import MXNet.Core.Base.Internal.TH (registerNDArrayOps) +import MXNet.Core.NNVM.Internal (nnGetOpHandle) +import Prelude hiding (sin, sinh, cos, cosh, tan, tanh, min, max, round, floor, + abs, sum, sqrt, log, exp, flip, concat, reverse, repeat) + +-- | Result representation for generic NDArray op. +class NDArrayOpResult a where + toResult :: [NDArrayHandle] -> a + fromResult :: a -> [NDArrayHandle] + +instance NDArrayOpResult () where + toResult _ = () + {-# INLINE toResult #-} + fromResult _ = [] + {-# INLINE fromResult #-} + +instance NDArrayOpResult NDArrayHandle where + toResult [] = error "This operation didn't return any result." + toResult (x:_) = x + {-# INLINE toResult #-} + fromResult a = [a] + {-# INLINE fromResult #-} + +instance NDArrayOpResult [NDArrayHandle] where + toResult = id + {-# INLINE toResult #-} + fromResult = id + {-# INLINE fromResult #-} + +-- | Register immutable version of ndarray operators. +$(registerNDArrayOps False) + +-- | Register mutable version of ndarray operators. +$(registerNDArrayOps True) diff --git a/src/MXNet/Core/Base/Internal/TH/Symbol.hs b/src/MXNet/Core/Base/Internal/TH/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/Internal/TH/Symbol.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.Internal.TH.Symbol +-- copyright: (c) 2016 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Functions about Symbol that generated by template haskell. +-- +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module MXNet.Core.Base.Internal.TH.Symbol where + +import Data.Proxy + +import MXNet.Core.Base.HMap +import MXNet.Core.Base.Internal +import MXNet.Core.Base.Internal.TH (registerSymbolOps) +import MXNet.Core.NNVM.Internal (nnGetOpHandle, nnSymbolCompose) +import Prelude hiding (sin, sinh, cos, cosh, tan, tanh, min, max, round, floor, + abs, sum, sqrt, log, exp, flip, concat, repeat, reverse) + +-- | Register symbol operators. +$(registerSymbolOps) diff --git a/src/MXNet/Core/Base/NDArray.hs b/src/MXNet/Core/Base/NDArray.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/NDArray.hs @@ -0,0 +1,504 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.NDArray +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- NDArray module, provide an imperative-style programming interface. +-- +{-# OPTIONS_GHC -Wno-missing-methods #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module MXNet.Core.Base.NDArray where + +import Control.Monad +import Data.Int +import Data.Monoid +import Data.Vector.Storable (Vector) +import qualified Data.Vector.Storable as V +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (peekArray) +import Foreign.Ptr +import GHC.Exts (IsList(..)) +import Text.PrettyPrint.Annotated.HughesPJClass (Pretty(..), prettyShow) +import System.IO.Unsafe (unsafePerformIO) + +import MXNet.Core.Base.DType +import MXNet.Core.Base.Internal +import qualified MXNet.Core.Base.Internal.TH.NDArray as I +import MXNet.Core.Base.HMap + +-- | NDArray type alias. +newtype NDArray a = NDArray { getHandle :: NDArrayHandle } + +-- | Wait all async operation to finish in MXNet. +waitAll :: IO () +waitAll = void mxNDArrayWaitAll + +-- | Make a new empty ndarray with specified shape, context and data type. +makeEmptyNDArray :: forall a. DType a + => [Int] -- ^ Shape. + -> Context -- ^ Context/ + -> Bool -- ^ If delayed allocate. + -> IO (NDArray a) +makeEmptyNDArray sh ctx delayed = do + let sh' = fromIntegral <$> sh + nlen = fromIntegral . length $ sh + dtype = typeid (undefined :: a) + (_, handle) <- mxNDArrayCreateEx sh' nlen (deviceType ctx) (deviceId ctx) (if delayed then 1 else 0) dtype + return $ NDArray handle + +-- | Make a new NDArray with given shape. +makeNDArray :: DType a + => [Int] -- ^ size of every dimensions. + -> Context + -> Vector a + -> IO (NDArray a) +makeNDArray sh ctx ds = do + let sh' = fromIntegral <$> sh + nlen = fromIntegral . length $ sh + (_, handle) <- mxNDArrayCreate sh' nlen (deviceType ctx) (deviceId ctx) 0 + V.unsafeWith ds $ \p -> do + let len = fromIntegral (V.length ds) + void $ mxNDArraySyncCopyFromCPU handle (castPtr p) len + return $ NDArray handle + +-- | Get the shape of given NDArray. +ndshape :: DType a + => NDArray a + -> IO (Int, [Int]) -- ^ Dimensions and size of every dimensions. +ndshape arr = do + (_, nlen, sh) <- mxNDArrayGetShape (getHandle arr) + return (fromIntegral nlen, fromIntegral <$> sh) + +-- | Get size of the given ndarray. +ndsize :: DType a + => NDArray a + -> IO Int -- ^ Dimensions and size of every dimensions. +ndsize arr = (product . snd) <$> ndshape arr + +-- | Get context of the given ndarray. +context :: DType a => NDArray a -> IO Context +context arr = do + (_, device'type, device'id) <- mxNDArrayGetContext (getHandle arr) + return $ Context device'type device'id + +-- | Make a copy of the give ndarray. +copy :: DType a => NDArray a -> IO (NDArray a) +copy arr = NDArray <$> I._copy (getHandle arr) + +-- | Get data stored in NDArray. +items :: DType a => NDArray a -> IO (Vector a) +items arr = do + nlen <- ndsize arr + alloca $ \p -> do + _ <- mxNDArraySyncCopyToCPU (getHandle arr) p (fromIntegral nlen) + fromList <$> peekArray nlen (castPtr p :: Ptr a) + +-- | Return a sliced ndarray that __shares memory__ with current one. +slice :: DType a + => NDArray a + -> Int -- ^ The beginning index of slice. + -> Int -- ^ The end index of slices. + -> NDArray a +slice arr start end = NDArray . unsafePerformIO $ do + let handle = getHandle arr + (_, handle') <- mxNDArraySlice handle (fromIntegral start) (fromIntegral end) + return handle' + +-- | Return a sub ndarray that __shares memory__ with current one. +at :: DType a + => NDArray a + -> Int -- ^ The index. + -> NDArray a +at arr idx = NDArray . unsafePerformIO $ do + let handle = getHandle arr + (_, handle') <- mxNDArrayAt handle (fromIntegral idx) + return handle' + +-- | Block until all pending writes operations on current ndarray are finished. +waitToRead :: DType a => NDArray a -> IO () +waitToRead arr = void $ mxNDArrayWaitToRead (getHandle arr) + +-- | One hot encoding indices into matrix out. +onehotEncode :: DType a + => NDArray a -- ^ An ndarray containing indices of the categorical features. + -> NDArray a -- ^ The result holder of the encoding. + -> IO (NDArray a) -- ^ The encoding ndarray. +onehotEncode indices out = do + let handle1 = getHandle indices + handle2 = getHandle out + NDArray <$> I._onehot_encode' handle1 handle2 [handle2] + +-- | Create a new NDArray filled with 0, with specified shape and context. +zeros :: DType a + => [Int] -- ^ Shape. + -> IO (NDArray a) +zeros sh = full sh 0 + +-- | Create a new NDArray filled with 1, with specified shape and context. +ones :: DType a + => [Int] -- ^ Shape. + -> IO (NDArray a) +ones sh = full sh 1 + +-- | Create a new NDArray filled with given value, with specified shape and context. +full :: DType a + => [Int] -- ^ Shape. + -> a -- ^ Given value to fill the ndarray. + -> IO (NDArray a) +full sh value = makeNDArray sh contextCPU $ V.replicate (product sh) value + +-- | Create a new NDArray that copies content from source_array. +array :: DType a + => [Int] -- ^ Shape. + -> Vector a + -> IO (NDArray a) +array sh = makeNDArray sh contextCPU + +instance {-# OVERLAPPABLE #-} (DType a, Floating a) => Eq (NDArray a) where + (==) arr1 arr2 = unsafePerformIO $ do + (_, sh1) <- ndshape arr1 + (_, sh2) <- ndshape arr2 + if sh1 == sh2 + then do + r <- (abs (arr1 - arr2) `lesser`) =<< full sh1 0.0001 + V.all (== fromIntegral (1 :: Int)) <$> items r + else return False + +instance (DType a, a ~ Int8) => Eq (NDArray Int8) where + (==) arr1 arr2 = unsafePerformIO $ do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + let cmp = V.all (== fromIntegral (1 :: Int)) :: Vector a -> Bool + (cmp <$>) . items . NDArray =<< I.broadcast_equal handle1 handle2 + +instance (DType a, a ~ Int32) => Eq (NDArray Int32) where + (==) arr1 arr2 = unsafePerformIO $ do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + let cmp = V.all (== fromIntegral (1 :: Int)) :: Vector a -> Bool + (cmp <$>) . items . NDArray =<< I.broadcast_equal handle1 handle2 + +-- | Wrapper for pretty print multiple dimensions matrices. +data PrettyWrapper = forall a. Pretty a => MkPretty { runPretty :: a } + +-- | Destruct pretty +instance Pretty PrettyWrapper where + pPrint (MkPretty inner) = pPrint inner + +instance (DType a, Pretty a) => Show (NDArray a) where + -- TODO display more related information. + show arr = unsafePerformIO $ do + (_, dims) <- ndshape arr + values <- items arr + let info = show dims + body = prettyShow . splitItems values dims $ 0 + return ("NDArray " <> info <> "\n" <> body) + where + splitItems :: Vector a -> [Int] -> Int -> PrettyWrapper + splitItems _ [] _ = error "Impossible: never match an empty list." + splitItems values [x] s = MkPretty . toList $ V.unsafeSlice s x values + splitItems values (d:ds) s = MkPretty $ (\x -> splitItems values ds (s + (product ds) * x)) <$> ([0 .. (d - 1)] :: [Int]) + +instance DType a => Num (NDArray a) where + (+) arr1 arr2 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_add handle1 handle2 + (-) arr1 arr2 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_sub handle1 handle2 + (*) arr1 arr2 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_mul handle1 handle2 + abs arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.abs handle1 + negate arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.negative handle1 + signum = error "Unsupported operator: signum(NDArray)" + fromInteger = error "Unsupported operator: fromInteger(NDArray)" + +instance DType a => Fractional (NDArray a) where + (/) arr1 arr2 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_div handle1 handle2 + fromRational = error "Unsupported operator: fromRational(NDArray)" + +instance DType a => Floating (NDArray a) where + exp arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.exp handle1 + log arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.log handle1 + sqrt arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.sqrt handle1 + sin arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.sin handle1 + cos arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.cos handle1 + tan arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.tan handle1 + sinh arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.sinh handle1 + cosh arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.cosh handle1 + tanh arr1 = NDArray . unsafePerformIO $ do + let handle1 = getHandle arr1 + I.tanh handle1 + +instance Tensor NDArray where + dot arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.dot handle1 handle2 nil + reshape arr sh = NDArray <$> do + let handle = getHandle arr + (_, handle') <- mxNDArrayReshape handle (length sh) sh + return handle' + transpose arr = NDArray <$> do + let handle = getHandle arr + I.transpose handle nil + (+.) arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_add handle1 handle2 + (-.) arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_sub handle1 handle2 + (*.) arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_mul handle1 handle2 + (/.) arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_div handle1 handle2 + (^.) arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_power handle1 handle2 + (.+) arr value = NDArray <$> do + let handle = getHandle arr + I._plus_scalar handle (realToFrac value) + {-# INLINE (.+) #-} + (.-) arr value = NDArray <$> do + let handle = getHandle arr + I._minus_scalar handle (realToFrac value) + {-# INLINE (.-) #-} + (.*) arr value = NDArray <$> do + let handle = getHandle arr + I._mul_scalar handle (realToFrac value) + {-# INLINE (.*) #-} + (./) arr value = NDArray <$> do + let handle = getHandle arr + I._div_scalar handle (realToFrac value) + {-# INLINE (./) #-} + (.^) arr value = NDArray <$> do + let handle = getHandle arr + I._power_scalar handle (realToFrac value) + {-# INLINE (.^) #-} + + (..-) value arr = NDArray <$> do + let handle = getHandle arr + I._rminus_scalar handle (realToFrac value) + {-# INLINE (..-) #-} + (../) value arr = NDArray <$> do + let handle = getHandle arr + I._rdiv_scalar handle (realToFrac value) + {-# INLINE (../) #-} + (..^) value arr = NDArray <$> do + let handle = getHandle arr + I._rpower_scalar handle (realToFrac value) + {-# INLINE (..^) #-} + + (.+=) arr value = do + let handle = getHandle arr + I._plus_scalar' handle (realToFrac value) [handle] + (.-=) arr value = do + let handle = getHandle arr + I._minus_scalar' handle (realToFrac value) [handle] + (.*=) arr value = do + let handle = getHandle arr + I._mul_scalar' handle (realToFrac value) [handle] + (./=) arr value = do + let handle = getHandle arr + I._div_scalar' handle (realToFrac value) [handle] + (.^=) arr value = do + let handle = getHandle arr + I._power_scalar' handle (realToFrac value) [handle] + + _Maximum arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_maximum handle1 handle2 + {-# INLINE _Maximum #-} + _Maximum' arr scalar = NDArray <$> do + let handle = getHandle arr + I._maximum_scalar handle (realToFrac scalar) + {-# INLINE _Maximum' #-} + _Minimum arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_minimum handle1 handle2 + {-# INLINE _Minimum #-} + _Minimum' arr scalar = NDArray <$> do + let handle = getHandle arr + I._minimum_scalar handle (realToFrac scalar) + {-# INLINE _Minimum' #-} + equal arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_equal handle1 handle2 + {-# INLINE equal #-} + equal' arr scalar = NDArray <$> do + let handle = getHandle arr + I._equal_scalar handle (realToFrac scalar) + {-# INLINE equal' #-} + notEqual arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_not_equal handle1 handle2 + {-# INLINE notEqual #-} + notEqual' arr scalar = NDArray <$> do + let handle = getHandle arr + I._not_equal_scalar handle (realToFrac scalar) + {-# INLINE notEqual' #-} + greater arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_greater handle1 handle2 + {-# INLINE greater #-} + greater' arr scalar = NDArray <$> do + let handle = getHandle arr + I._greater_scalar handle (realToFrac scalar) + {-# INLINE greater' #-} + greaterEqual arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_greater_equal handle1 handle2 + {-# INLINE greaterEqual #-} + greaterEqual' arr scalar = NDArray <$> do + let handle = getHandle arr + I._greater_equal_scalar handle (realToFrac scalar) + {-# INLINE greaterEqual' #-} + lesser arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_lesser handle1 handle2 + {-# INLINE lesser #-} + lesser' arr scalar = NDArray <$> do + let handle = getHandle arr + I._lesser_scalar handle (realToFrac scalar) + {-# INLINE lesser' #-} + lesserEqual arr1 arr2 = NDArray <$> do + let handle1 = getHandle arr1 + handle2 = getHandle arr2 + I.broadcast_lesser_equal handle1 handle2 + {-# INLINE lesserEqual #-} + lesserEqual' arr scalar = NDArray <$> do + let handle = getHandle arr + I._lesser_equal_scalar handle (realToFrac scalar) + {-# INLINE lesserEqual' #-} + +instance Neural NDArray where + fullyConnected input weight bias n = NDArray <$> do + let handle1 = getHandle input + handle2 = getHandle weight + handle3 = getHandle bias + I.fullyconnected handle1 handle2 handle3 n nil + correlation input1 input2 = NDArray <$> do + let handle1 = getHandle input1 + handle2 = getHandle input2 + I.correlation handle1 handle2 nil + activation input act = NDArray <$> do + let handle1 = getHandle input + I.activation handle1 act + leakyReLU input act = NDArray <$> do + let handle1 = getHandle input + I.leakyrelu handle1 (add @"act_type" act nil) + softmaxActivation input = NDArray <$> do + let handle1 = getHandle input + I.softmaxactivation handle1 nil + dropout input p = NDArray <$> do + let handle1 = getHandle input + I.dropout handle1 (add @"p" p nil) + batchNorm input gm bt mm mv = NDArray <$> do + let handle1 = getHandle input + let handle2 = getHandle gm + let handle3 = getHandle bt + let handle4 = getHandle mm + let handle5 = getHandle mv + I.batchnorm handle1 handle2 handle3 handle4 handle5 nil + instanceNorm input gamma beta eps = NDArray <$> do + let handle1 = getHandle input + handle2 = getHandle gamma + handle3 = getHandle beta + I.instancenorm handle1 handle2 handle3 (add @"eps" eps nil) + l2Normalization input eps mode = NDArray <$> do + let handle1 = getHandle input + I.l2normalization handle1 (add @"eps" eps $ add @"mode" mode nil) + convolution input weight bias kernel n = NDArray <$> do + let handle1 = getHandle input + handle2 = getHandle weight + handle3 = getHandle bias + I.convolution handle1 handle2 handle3 kernel n nil + lrn input alpha beta knorm nsize = NDArray <$> do + let handle1 = getHandle input + I.lrn handle1 nsize (add @"alpha" alpha $ add @"beta" beta $ add @"knorm" knorm nil) + deconvolution input weight bias kernel nfilter = NDArray <$> do + let handle1 = getHandle input + handle2 = getHandle weight + handle3 = getHandle bias + I.deconvolution handle1 handle2 handle3 kernel nfilter nil + pooling input kernel pooltype = NDArray <$> do + let handle1 = getHandle input + I.pooling handle1 kernel pooltype nil + -- roiPooling + -- rnn + -- embedding + -- bilinearSampler + -- gridGenerator + -- upSampling + -- spatialTransformer + -- linearRegressionOutput + -- logisticRegressionOutput + softmaxOutput input label = NDArray <$> do + let handle1 = getHandle input + handle2 = getHandle label + I.softmaxoutput handle1 handle2 nil + -- maeRegressionOutput + -- svmOutput + -- softmaxCrossEntropy + -- smoothL1 + -- identityAttachKLSparsereg + makeLoss input grad_scale valid_thresh normalization = NDArray <$> do + let handle1 = getHandle input + I.makeloss handle1 (add @"grad_scale" grad_scale $ add @"valid_thresh" valid_thresh $ add @"normalization" normalization nil) + blockGrad input = NDArray <$> do + let handle1 = getHandle input + I.blockgrad handle1 + custom input op = NDArray <$> do + let handles = map getHandle input + I.custom handles op diff --git a/src/MXNet/Core/Base/Symbol.hs b/src/MXNet/Core/Base/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Base/Symbol.hs @@ -0,0 +1,499 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Base.Symbol +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Symbol module. +-- +{-# OPTIONS_GHC -Wno-missing-methods #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module MXNet.Core.Base.Symbol where + +import Control.Exception (assert, throw) +import Control.Monad +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.IORef +import Data.Monoid +import Foreign.Ptr (nullPtr) +import System.IO.Unsafe +import Unsafe.Coerce (unsafeCoerce) + +import MXNet.Core.Base.DType +import MXNet.Core.Base.Internal +import qualified MXNet.Core.Base.Internal.TH.Symbol as I +import MXNet.Core.Base.HMap +import MXNet.Core.Base.Executor hiding (getHandle) +import MXNet.Core.Base.NDArray hiding (getHandle) +import qualified MXNet.Core.Base.NDArray as NDArray (getHandle) + +-- | Type alias for variable. +newtype Symbol a = Symbol { getHandle :: SymbolHandle } + +instance DType a => Show (Symbol a) where + show sym = unsafePerformIO $ do + (_, str) <- mxSymbolPrint (getHandle sym) + return str + +-- | Make a new symbolic variable with given name. +variable :: DType a + => String -- ^ Name. + -> IO (Symbol a) -- ^ Result variable. +variable name = do + (_, handle) <- mxSymbolCreateVariable name + return $ Symbol handle + +-- | Get the name of a given variable. +getName :: DType a => Symbol a -> IO String +getName = mxSymbolGetName . getHandle >=> \(_, nm, _) -> return nm + +-- | Get specified attribute of symbol. +getAttr :: DType a => Symbol a -> String -> IO (Maybe String) +getAttr sym key = do + (_, s, success) <- mxSymbolGetAttr (getHandle sym) key + return $ if success == 0 -- 0 when success, -1 when failure happens + then Just s + else Nothing + +-- | Set specified attribute of symbol. +setAttr :: DType a => Symbol a -> String -> String -> IO () +setAttr sym key value = void $ mxSymbolSetAttr (getHandle sym) key value + +-- | Infer the shape of the given symbol, return the in, out and auxiliary shape size. +infershape :: DType a => Symbol a -> [String] -> IO ([[Int]], [[Int]], [[Int]]) +infershape sym args = do + (_, arg, out, aux) <- mxSymbolInferShape (getHandle sym) args [0] [] + return (arg, out, aux) + +-- | Get the autodiff of current symbol. +-- This function can only be used if current symbol is a loss function. +grad :: DType a => Symbol a -> [String] -> IO (Symbol a) +grad sym args = do + let nargs = fromIntegral (length args) + (_, handle) <- mxSymbolGrad (getHandle sym) nargs args + return $ Symbol handle + +-- | Bind with explicit argument mapping (name -- value mapping). +bind :: DType a + => Symbol a + -> Context + -> HashMap String (NDArray a) + -> IO (Executor a) +bind sym Context{..} args = do + inputs <- genNDArrayMapping <$> listInputs sym + -- req_map = {'null': 0, 'write': 1, 'add': 3} + let req_types = replicate (HM.size inputs) 1 -- use default value. + (_, exec) <- mxExecutorBind (getHandle sym) + deviceType + deviceId + (fromIntegral (HM.size inputs)) -- length of input arguments. + (NDArray.getHandle <$> HM.elems inputs) + (replicate (HM.size inputs) (unsafeCoerce nullPtr)) + req_types + 0 -- length of auxiliary states. + [] -- no auxiliary states. + return $ Executor exec + where + -- | Get ndarray lists handles from input arguments. + genNDArrayMapping arg_names = HM.fromList (genfn <$> arg_names) + where + genfn nm = case HM.lookup nm args of + Just v -> (nm, v) + Nothing -> throw . userError $ "getNDArrayInputs: no argument " <> nm + +-- | Bind without explicit argument mapping (name -- value mapping). +bind' :: DType a + => Symbol a + -> Context + -> [NDArray a] + -> IO (Executor a) +bind' sym Context{..} args = do + inputs <- genNDArrayMapping <$> listInputs sym + -- req_map = {'null': 0, 'write': 1, 'add': 3} + let req_types = replicate (HM.size inputs) 1 -- use default value. + (_, exec) <- mxExecutorBind (getHandle sym) + deviceType + deviceId + (fromIntegral (HM.size inputs)) -- length of input arguments. + (NDArray.getHandle <$> HM.elems inputs) + (replicate (HM.size inputs) (unsafeCoerce nullPtr)) + req_types + 0 -- length of auxiliary states. + [] -- no auxiliary states. + return $ Executor exec + where + -- | Get ndarray lists handles from input arguments without explicit argument names. + genNDArrayMapping names = + assert (length args == length names) $ + HM.fromList (zip names args) + +-- | List all input arguments. +listInputs :: DType a => Symbol a -> IO [String] +listInputs sym = snd <$> mxSymbolListArguments (getHandle sym) + +-- | List all output results. +listOutputs :: DType a => Symbol a -> IO [String] +listOutputs sym = snd <$> mxSymbolListOutputs (getHandle sym) + +-- | List all auxiliary states. +listAuxiliaries :: DType a => Symbol a -> IO [String] +listAuxiliaries sym = snd <$> mxSymbolListAuxiliaryStates (getHandle sym) + +instance DType a => Num (Symbol a) where + (+) sym1 sym2 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Plus (name1 <> "+" <> name2) handle1 handle2 + (-) sym1 sym2 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Minus (name1 <> "-" <> name2) handle1 handle2 + (*) sym1 sym2 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Mul (name1 <> "*" <> name2) handle1 handle2 + abs sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.abs ("|" <> name1 <> "|") handle1 + negate sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.negative ("(-" <> name1 <> ")") handle1 + signum = error "Unsupported operator: signum(Symbol)" + fromInteger = error "Unsupported operator: fromInteger(Symbol)" + +instance DType a => Fractional (Symbol a) where + (/) sym1 sym2 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Div (name1 <> "/" <> name2) handle1 handle2 + fromRational = error "Unsupported operator: fromRational(Symbol)" + +instance DType a => Floating (Symbol a) where + exp sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.exp ("exp(" <> name1 <> ")") handle1 + log sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.log ("log(" <> name1 <> ")") handle1 + sqrt sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.sqrt ("sqrt(" <> name1 <> ")") handle1 + sin sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.sin ("sin(" <> name1 <> ")") handle1 + cos sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.cos ("cos(" <> name1 <> ")") handle1 + tan sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.tan ("tan(" <> name1 <> ")") handle1 + sinh sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.sinh ("sinh(" <> name1 <> ")") handle1 + cosh sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.cosh ("cosh(" <> name1 <> ")") handle1 + tanh sym1 = Symbol . unsafePerformIO $ do + let handle1 = getHandle sym1 + name1 <- getName sym1 + I.tanh ("tanh(" <> name1 <> ")") handle1 + +instance Tensor Symbol where + dot sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.dot ("dot(" <> name1 <> "," <> name2 <> ")") handle1 handle2 nil + reshape sym sh = Symbol <$> do + let handle = getHandle sym + sh' = "(" <> (init . tail . show $ sh) <> ")" + name1 <- getName sym + I.reshape ("reshape(" <> name1 <> "," <> sh' <> ")") handle (add @"shape" sh' nil) + transpose sym = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I.transpose ("transpose(" <> name1 <> ")") handle nil + (+.) sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Plus (name1 <> "+" <> name2) handle1 handle2 + (-.) sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Minus (name1 <> "-" <> name2) handle1 handle2 + (*.) sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Mul (name1 <> "*" <> name2) handle1 handle2 + (/.) sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Div (name1 <> "*" <> name2) handle1 handle2 + (^.) sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Power (name1 <> "*" <> name2) handle1 handle2 + (.+) sym value = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._PlusScalar (name1 <> "+" <> show value) handle (realToFrac value) + {-# INLINE (.+) #-} + (.-) sym value = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._MinusScalar (name1 <> "-" <> show value) handle (realToFrac value) + {-# INLINE (.-) #-} + (.*) sym value = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._MulScalar (name1 <> "*" <> show value) handle (realToFrac value) + {-# INLINE (.*) #-} + (./) sym value = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._DivScalar (name1 <> "/" <> show value) handle (realToFrac value) + {-# INLINE (./) #-} + (.^) sym value = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._PowerScalar (name1 <> "^" <> show value) handle (realToFrac value) + {-# INLINE (.^) #-} + (..-) value sym = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._RMinusScalar (show value <> "-" <> name1) handle (realToFrac value) + {-# INLINE (..-) #-} + (../) value sym = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._RDivScalar (show value <> "/" <> name1) handle (realToFrac value) + {-# INLINE (../) #-} + (..^) value sym = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._RPowerScalar (show value <> "^" <> name1) handle (realToFrac value) + {-# INLINE (..^) #-} + + _Maximum sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Maximum ("_Maximum(" <> name1 <> "," <> name2 <> ")") handle1 handle2 + {-# INLINE _Maximum #-} + _Maximum' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._MaximumScalar ("_Maximum'(" <> name1 <> "," <> show scalar <> ")") handle (realToFrac scalar) + {-# INLINE _Maximum' #-} + _Minimum sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I._Minimum ("_Minimum(" <> name1 <> "," <> name2 <> ")") handle1 handle2 + {-# INLINE _Minimum #-} + _Minimum' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._MinimumScalar ("_Minimum'(" <> name1 <> "," <> show scalar <> ")") handle (realToFrac scalar) + {-# INLINE _Minimum' #-} + equal sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.broadcast_equal (name1 <> "==" <> name2) handle1 handle2 + {-# INLINE equal #-} + equal' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._equal_scalar (name1 <> "==" <> show scalar) handle (realToFrac scalar) + {-# INLINE equal' #-} + notEqual sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.broadcast_not_equal (name1 <> "/=" <> name2) handle1 handle2 + {-# INLINE notEqual #-} + notEqual' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._not_equal_scalar (name1 <> "/=" <> show scalar) handle (realToFrac scalar) + {-# INLINE notEqual' #-} + greater sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.broadcast_greater (name1 <> ">" <> name2) handle1 handle2 + {-# INLINE greater #-} + greater' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._greater_scalar (name1 <> ">" <> show scalar) handle (realToFrac scalar) + {-# INLINE greater' #-} + greaterEqual sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.broadcast_greater_equal (name1 <> ">=" <> name2) handle1 handle2 + {-# INLINE greaterEqual #-} + greaterEqual' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._greater_equal_scalar (name1 <> ">=" <> show scalar) handle (realToFrac scalar) + {-# INLINE greaterEqual' #-} + lesser sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.broadcast_lesser (name1 <> "<" <> name2) handle1 handle2 + {-# INLINE lesser #-} + lesser' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._lesser_scalar (name1 <> "<" <> show scalar) handle (realToFrac scalar) + {-# INLINE lesser' #-} + lesserEqual sym1 sym2 = Symbol <$> do + let handle1 = getHandle sym1 + handle2 = getHandle sym2 + name1 <- getName sym1 + name2 <- getName sym2 + I.broadcast_lesser_equal (name1 <> "<=" <> name2) handle1 handle2 + {-# INLINE lesserEqual #-} + lesserEqual' sym scalar = Symbol <$> do + let handle = getHandle sym + name1 <- getName sym + I._lesser_equal_scalar (name1 <> "<=" <> show scalar) handle (realToFrac scalar) + {-# INLINE lesserEqual' #-} + +-- | Provide a globally unique serial ID for each symbol. +symid :: IORef Int +symid = unsafePerformIO (newIORef 0) + +-- | Generate a globally unique name for each symbol, thread safely. +naming :: String -> IO String +naming prefix = ((prefix <>) . show) <$> atomicModifyIORef symid (\a -> (a+1, a)) + +instance Neural Symbol where + fullyConnected input weight bias n = Symbol <$> do + let handle1 = getHandle input + handle2 = getHandle weight + handle3 = getHandle bias + name <- naming "FullyConnected" + I.fullyconnected name handle1 handle2 handle3 n nil + correlation input1 input2 = Symbol <$> do + let handle1 = getHandle input1 + handle2 = getHandle input2 + name <- naming "Correlation" + I.correlation name handle1 handle2 nil + activation input act = Symbol <$> do + let handle1 = getHandle input + name <- naming "Activation" + I.activation name handle1 act + leakyReLU input act = Symbol <$> do + let handle1 = getHandle input + name <- naming "LeakyReLU" + I.leakyrelu name handle1 (add @"act_type" act nil) + softmaxActivation input = Symbol <$> do + let handle1 = getHandle input + name <- naming "SoftmaxActivation" + I.softmaxactivation name handle1 nil + dropout input p = Symbol <$> do + let handle1 = getHandle input + name <- naming "Dropout" + I.dropout name handle1 (add @"p" p nil) + batchNorm input gm bt mm mv = Symbol <$> do + let handle1 = getHandle input + let handle2 = getHandle gm + let handle3 = getHandle bt + let handle4 = getHandle mm + let handle5 = getHandle mv + name <- naming "BatchNorm" + I.batchnorm name handle1 handle2 handle3 handle4 handle5 nil + instanceNorm input gamma beta eps = Symbol <$> do + let handle1 = getHandle input + handle2 = getHandle gamma + handle3 = getHandle beta + name <- naming "InstnaceNorm" + I.instancenorm name handle1 handle2 handle3 (add @"eps" eps nil) + l2Normalization input eps mode = Symbol <$> do + let handle1 = getHandle input + name <- naming "L2Normalization" + I.l2normalization name handle1 (add @"eps" eps $ add @"mode" mode nil) + convolution input weight bias kernel n = Symbol <$> do + let handle1 = getHandle input + handle2 = getHandle weight + handle3 = getHandle bias + name <- naming "Convolution" + I.convolution name handle1 handle2 handle3 kernel n nil + lrn input alpha beta knorm nsize = Symbol <$> do + let handle1 = getHandle input + name <- naming "LRN" + I.lrn name handle1 nsize (add @"alpha" alpha $ add @"beta" beta $ add @"knorm" knorm nil) + deconvolution input weight bias kernel nfilter = Symbol <$> do + let handle1 = getHandle input + handle2 = getHandle weight + handle3 = getHandle bias + name <- naming "Deconvolution" + I.deconvolution name handle1 handle2 handle3 kernel nfilter nil + pooling input kernel pooltype = Symbol <$> do + let handle1 = getHandle input + name <- naming "Pooling" + I.pooling name handle1 kernel pooltype nil + softmaxOutput input label = Symbol <$> do + let handle1 = getHandle input + handle2 = getHandle label + name <- naming "SoftmaxOutput" + I.softmaxoutput name handle1 handle2 nil + makeLoss input grad_scale valid_thresh normalization = Symbol <$> do + let handle1 = getHandle input + name <- naming "MakeLoss" + I.makeloss name handle1 (add @"grad_scale" grad_scale $ add @"valid_thresh" valid_thresh $ add @"normalization" normalization nil) + blockGrad input = Symbol <$> do + let handle1 = getHandle input + name <- naming "BlockGrad" + I.blockgrad name handle1 + custom input op = Symbol <$> do + let handles = map getHandle input + name <- naming "Custom" + I.custom name handles op diff --git a/src/MXNet/Core/Internal/Types/Raw.chs b/src/MXNet/Core/Internal/Types/Raw.chs deleted file mode 100644 --- a/src/MXNet/Core/Internal/Types/Raw.chs +++ /dev/null @@ -1,183 +0,0 @@ ------------------------------------------------------------ --- | --- module: MXNet.Core.Internal.Types.Raw --- copyright: (c) 2016 Tao He --- license: MIT --- maintainer: sighingnow@gmail.com --- --- Collect data type defintions into a single raw binding module to avoid redefinitions. --- -#if __GLASGOW_HASKELL__ >= 709 -{-# LANGUAGE Safe #-} -#elif __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE Trustworthy #-} -#endif -{-# LANGUAGE ForeignFunctionInterface #-} - -module MXNet.Core.Internal.Types.Raw where - -import Foreign.C.Types -import Foreign.Ptr -import Foreign.Storable - -#include -#include - --- | Handle size_t type. -{#typedef size_t CSize#} - -{--------------------------------------------------------------------- -- ----------------------------------------------------------------------} - --- | MXUint type alias. -type MXUInt = CUInt - --- | MXFloat type alias. -type MXFloat = CFloat - --- | Handle to NDArray. -{#pointer NDArrayHandle newtype #} - -instance Storable NDArrayHandle where - sizeOf (NDArrayHandle t) = sizeOf t - alignment (NDArrayHandle t) = alignment t - peek p = fmap NDArrayHandle (peek (castPtr p)) - poke p (NDArrayHandle t) = poke (castPtr p) t - --- | Handle to a mxnet narray function that changes NDArray. -{#pointer FunctionHandle newtype #} - -instance Storable FunctionHandle where - sizeOf (FunctionHandle t) = sizeOf t - alignment (FunctionHandle t) = alignment t - peek p = fmap FunctionHandle (peek (castPtr p)) - poke p (FunctionHandle t) = poke (castPtr p) t - --- | Handle to a function that takes param and creates symbol. -{#pointer AtomicSymbolCreator newtype #} - -instance Storable AtomicSymbolCreator where - sizeOf (AtomicSymbolCreator t) = sizeOf t - alignment (AtomicSymbolCreator t) = alignment t - peek p = fmap AtomicSymbolCreator (peek (castPtr p)) - poke p (AtomicSymbolCreator t) = poke (castPtr p) t - --- | Handle to a symbol that can be bind as operator. -{#pointer SymbolHandle newtype #} - -instance Storable SymbolHandle where - sizeOf (SymbolHandle t) = sizeOf t - alignment (SymbolHandle t) = alignment t - peek p = fmap SymbolHandle (peek (castPtr p)) - poke p (SymbolHandle t) = poke (castPtr p) t - --- | Handle to a AtomicSymbol. -{#pointer AtomicSymbolHandle newtype #} - -instance Storable AtomicSymbolHandle where - sizeOf (AtomicSymbolHandle t) = sizeOf t - alignment (AtomicSymbolHandle t) = alignment t - peek p = fmap AtomicSymbolHandle (peek (castPtr p)) - poke p (AtomicSymbolHandle t) = poke (castPtr p) t - -{#pointer ExecutorHandle newtype #} - --- | Handle to an Executor. -instance Storable ExecutorHandle where - sizeOf (ExecutorHandle t) = sizeOf t - alignment (ExecutorHandle t) = alignment t - peek p = fmap ExecutorHandle (peek (castPtr p)) - poke p (ExecutorHandle t) = poke (castPtr p) t - --- | Handle a dataiter creator. -{#pointer DataIterCreator newtype #} - -instance Storable DataIterCreator where - sizeOf (DataIterCreator t) = sizeOf t - alignment (DataIterCreator t) = alignment t - peek p = fmap DataIterCreator (peek (castPtr p)) - poke p (DataIterCreator t) = poke (castPtr p) t - --- | Handle to a DataIterator. -{#pointer DataIterHandle newtype #} - -instance Storable DataIterHandle where - sizeOf (DataIterHandle t) = sizeOf t - alignment (DataIterHandle t) = alignment t - peek p = fmap DataIterHandle (peek (castPtr p)) - poke p (DataIterHandle t) = poke (castPtr p) t - --- | Handle to KVStore. -{#pointer KVStoreHandle newtype #} - -instance Storable KVStoreHandle where - sizeOf (KVStoreHandle t) = sizeOf t - alignment (KVStoreHandle t) = alignment t - peek p = fmap KVStoreHandle (peek (castPtr p)) - poke p (KVStoreHandle t) = poke (castPtr p) t - --- | Handle to RecordIO. -{#pointer RecordIOHandle newtype #} - -instance Storable RecordIOHandle where - sizeOf (RecordIOHandle t) = sizeOf t - alignment (RecordIOHandle t) = alignment t - peek p = fmap RecordIOHandle (peek (castPtr p)) - poke p (RecordIOHandle t) = poke (castPtr p) t - --- | Handle to MXRtc. -{#pointer RtcHandle newtype #} - -instance Storable RtcHandle where - sizeOf (RtcHandle t) = sizeOf t - alignment (RtcHandle t) = alignment t - peek p = fmap RtcHandle (peek (castPtr p)) - poke p (RtcHandle t) = poke (castPtr p) t - --- | Callback: ExecutorMonitorCallback. -{#pointer ExecutorMonitorCallback newtype #} - --- | Callback: CustomOpPropCreator. -{#pointer CustomOpPropCreator newtype #} - --- | Callback: MXKVStoreUpdater, user-defined updater for the kvstore. -type MXKVStoreUpdater = Int -- ^ The key. - -> NDArrayHandle -- ^ The pushed value on the key. - -> NDArrayHandle -- ^ The value stored on local on the key. - -> Ptr () -- ^ The additional handle to the updater. - -> IO Int - -foreign import ccall "wrapper" - makeMXKVStoreUpdater :: MXKVStoreUpdater -> IO (FunPtr MXKVStoreUpdater) - --- | Callback: MXKVStoreServerController, the prototype of a server controller. -type MXKVStoreServerController = Int -- ^ The head of the command. - -> Ptr CChar -- ^ The body of the command. - -> Ptr () -- ^ Helper handle for implementing controller. - -> IO Int - -foreign import ccall "wrapper" - makeMXKVStoreServerController :: MXKVStoreServerController -> IO (FunPtr MXKVStoreServerController) - -{--------------------------------------------------------------------- -- ----------------------------------------------------------------------} - --- | Handle to Predictor. -{#pointer PredictorHandle newtype #} - -instance Storable PredictorHandle where - sizeOf (PredictorHandle t) = sizeOf t - alignment (PredictorHandle t) = alignment t - peek p = fmap PredictorHandle (peek (castPtr p)) - poke p (PredictorHandle t) = poke (castPtr p) t - --- | Handle to NDArrayList. -{#pointer NDListHandle newtype #} - -instance Storable NDListHandle where - sizeOf (NDListHandle t) = sizeOf t - alignment (NDListHandle t) = alignment t - peek p = fmap NDListHandle (peek (castPtr p)) - poke p (NDListHandle t) = poke (castPtr p) t diff --git a/src/MXNet/Core/NDArray.hs b/src/MXNet/Core/NDArray.hs deleted file mode 100644 --- a/src/MXNet/Core/NDArray.hs +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------ --- | --- module: MXNet.Core.NDArray --- copyright: (c) 2016 Tao He --- license: MIT --- maintainer: sighingnow@gmail.com --- --- NDArray module. --- -module MXNet.Core.NDArray ( - -- * Data type definitions - NDArray - , Context - -- * Functions about NDArray - , makeNDArray - , getNDArrayShape - -- * Default contexts - , defaultContext - , contextCPU - , contextGPU - ) where - -import MXNet.Core.Base - --- | NDArray type alias. -type NDArray = NDArrayHandle - --- | Context definition. --- --- * DeviceType --- --- 1. cpu --- 2. gpu --- 3. cpu_pinned -data Context = Context { deviceType :: Int - , deviceId :: Int - } deriving (Eq, Show) - --- | Default context, use the CPU 0 as device. -defaultContext :: Context -defaultContext = Context { deviceType = 1 -- cpu - , deviceId = 1 -- default value. - } - --- | Context for CPU 0. -contextCPU :: Context -contextCPU = Context 1 0 - --- | Context for GPU 0. -contextGPU :: Context -contextGPU = Context 2 0 - --- | Make a new NDArray with given shape. -makeNDArray :: [Int] -- ^ size of every dimensions. - -> IO NDArray -makeNDArray shape = do - let shape' = fromIntegral <$> shape - nlen = fromIntegral . length $ shape - (_, handle) <- mxNDArrayCreate shape' nlen (deviceType contextCPU) (deviceId contextCPU) 0 - return handle - --- | Get the shape of given NDArray. -getNDArrayShape :: NDArray - -> IO (Int, [Int]) -- ^ Dimensions and size of every dimensions. -getNDArrayShape array = do - (_, nlen, shape) <- mxNDArrayGetShape array - return (fromIntegral nlen, fromIntegral <$> shape) diff --git a/src/MXNet/Core/NNVM/Internal.hs b/src/MXNet/Core/NNVM/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/NNVM/Internal.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.NNVM.Internal +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Interfaces in core module of NNVM. +-- +module MXNet.Core.NNVM.Internal ( + -- * Re-export data type definitions + NNUInt + , OpHandle + , SymbolHandle + , GraphHandle + -- * Re-export functions. + , nnAPISetLastError + , nnGetLastError + , nnListAllOpNames + , nnGetOpHandle + , nnListUniqueOps + , nnGetOpInfo + , nnSymbolCreateAtomicSymbol + , nnSymbolCreateVariable + , nnSymbolCreateGroup + , nnAddControlDeps + , nnSymbolFree + , nnSymbolCopy + , nnSymbolPrint + , nnSymbolGetAttr + , nnSymbolSetAttrs + , nnSymbolListAttrs + , nnSymbolListInputVariables + , nnSymbolListInputNames + , nnSymbolListOutputNames + , nnSymbolGetInternals + , nnSymbolGetOutput + , nnSymbolCompose + , nnGraphCreate + , nnGraphFree + , nnGraphGetSymbol + , nnGraphSetJSONAttr + , nnGraphGetJSONAttr + , nnGraphSetNodeEntryListAttr_ + , nnGraphApplyPasses + ) where + +import MXNet.Core.Types.Internal (NNUInt, OpHandle, SymbolHandle, GraphHandle) +import MXNet.Core.NNVM.Internal.Raw diff --git a/src/MXNet/Core/NNVM/Internal/Raw.chs b/src/MXNet/Core/NNVM/Internal/Raw.chs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/NNVM/Internal/Raw.chs @@ -0,0 +1,296 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.NNVM.Internal.Raw +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Direct C FFI bindings for . +-- +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +#if __GLASGOW_HASKELL__ >= 801 +{-# LANGUAGE Strict #-} +#endif +{-# LANGUAGE ForeignFunctionInterface #-} + +module MXNet.Core.NNVM.Internal.Raw where + +import Control.Exception (throwIO) +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable + +import C2HS.C.Extra.Marshal + +{#import MXNet.Core.Types.Internal.Raw #} + +#include + +-- | Set the last error message needed by C API. +{#fun NNAPISetLastError as nnAPISetLastError + { `String' + } -> `()' #} + +-- | Return str message of the last error. +{#fun NNGetLastError as nnGetLastError + { + } -> `String' #} + +{#fun NNListAllOpNames as nnListAllOpNamesImpl + { alloca- `NNUInt' peek* + , alloca- `Ptr (Ptr CChar)' peek* + } -> `Int' #} + +-- | List all the available operator names, include entries. +nnListAllOpNames :: IO (Int, [String]) +nnListAllOpNames = do + (res, n, p) <- nnListAllOpNamesImpl + ss <- peekStringArray n p + return (res, ss) + +-- | Get operator handle given name. +{#fun NNGetOpHandle as nnGetOpHandle + { `String' -- ^ The name of the operator. + , alloca- `OpHandle' peek* + } -> `Int' #} + +{#fun NNListUniqueOps as nnListUniqueOpsImpl + { alloca- `NNUInt' peek* + , alloca- `Ptr OpHandle' peek* + } -> `Int' #} + +-- | List all the available operators. +nnListUniqueOps :: IO (Int, [OpHandle]) +nnListUniqueOps = do + (res, n, p) <- nnListUniqueOpsImpl + ops <- peekArray (fromIntegral n) p + return (res, ops) + +{#fun NNGetOpInfo as nnGetOpInfoImpl + { id `OpHandle' + , alloca- `String' peekString* -- ^ return a name (string). + , alloca- `String' peekString* -- ^ return description (string). + , alloca- `NNUInt' peek* + , alloca- `Ptr (Ptr CChar)' peek* + , alloca- `Ptr (Ptr CChar)' peek* + , alloca- `Ptr (Ptr CChar)' peek* + , alloca- `String' peekString* + } -> `Int' #} + +-- | Get the detailed information about atomic symbol. +nnGetOpInfo :: OpHandle + -> IO (Int, String, String, NNUInt, [String], [String], [String], String) +nnGetOpInfo handle = do + (res, name, desc, argc, pargv, pargt, pargdesc, rettype) <- nnGetOpInfoImpl handle + argv <- peekStringArray argc pargv + argt <- peekStringArray argc pargt + argdesc <- peekStringArray argc pargdesc + return (res, name, desc, argc, argv, argt, argdesc, rettype) + +-- | Create an AtomicSymbol functor. +{#fun NNSymbolCreateAtomicSymbol as nnSymbolCreateAtomicSymbol + { id `OpHandle' -- ^ The operator handle. + , id `NNUInt' -- ^ The number of parameters. + , withStringArray* `[String]' -- ^ The keys to the params. + , withStringArray* `[String]' -- ^ The values to the params. + , alloca- `SymbolHandle' peek* + } -> `Int' #} + +-- | Create a Variable Symbol. +{#fun NNSymbolCreateVariable as nnSymbolCreateVariable + { `String' -- ^ The name of the variable. + , alloca- `SymbolHandle' peek* + } -> `Int' #} + +-- | Create a Symbol by grouping list of symbols together. +{#fun NNSymbolCreateGroup as nnSymbolCreateGroup + { id `NNUInt' -- ^ Number of symbols to be grouped. + , withArray* `[SymbolHandle]' -- ^ Array of symbol handles. + , alloca- `SymbolHandle' peek* + } -> `Int' #} + +-- | Add src_dep to the handle as control dep. +{#fun NNAddControlDeps as nnAddControlDeps + { id `SymbolHandle' -- ^ The symbol to add dependency edges on. + , id `SymbolHandle' -- ^ The source handles. + } -> `Int' #} + +-- | Free the symbol handle. +{#fun NNSymbolFree as nnSymbolFree + { id `SymbolHandle' + } -> `Int' #} + +-- | Copy the symbol to another handle. +{#fun NNSymbolCopy as nnSymbolCopy + { id `SymbolHandle' + , alloca- `SymbolHandle' peek* + } -> `Int' #} + +-- | Print the content of symbol, used for debug. +{#fun NNSymbolPrint as nnSymbolPrint + { id `SymbolHandle' + , alloca- `String' peekString* + } -> `Int' #} + +-- | Get string attribute from symbol. +{#fun NNSymbolGetAttr as nnSymbolGetAttr + { id `SymbolHandle' -- ^ symbol handle + , `String' -- ^ key + , alloca- `String' peekString* -- ^ result value + , alloca- `Int' peekIntegral* -- ^ if success, 0 when success, -1 when failure happens. + } -> `Int' #} + +-- | Set string attribute from symbol. +{#fun NNSymbolSetAttrs as nnSymbolSetAttrs + { id `SymbolHandle' + , id `NNUInt' + , withStringArray* `[String]' -- ^ attribute keys + , withStringArray* `[String]' -- ^ attribute values + } -> `Int' #} + +{#fun NNSymbolListAttrs as nnSymbolListAttrsImpl + { id `SymbolHandle' + , `Int' -- ^ 0 for recursive, 1 for shallow + , alloca- `NNUInt' peek* -- ^ out size + , alloca- `Ptr (Ptr CChar)' peek* -- ^ out attributes + } -> `Int' #} + +-- | Get all attributes from symbol, including all descendents. +nnSymbolListAttrs :: SymbolHandle -> Int -> IO (Int, [String]) +nnSymbolListAttrs sym recursive = do + (res, n, p) <- nnSymbolListAttrsImpl sym recursive + ss <- peekStringArray n p + return (res, ss) + +{#fun NNSymbolListInputVariables as nnSymbolListInputVariablesImpl + { id `SymbolHandle' + , `Int' + , alloca- `NNUInt' peek* + , alloca- `Ptr SymbolHandle' peek* + } -> `Int' #} + +-- | List inputs variables in the symbol. +nnSymbolListInputVariables :: SymbolHandle -> Int -> IO (Int, [SymbolHandle]) +nnSymbolListInputVariables sym opt = do + (res, n, p) <- nnSymbolListInputVariablesImpl sym opt + vs <- peekArray (fromIntegral n) p + return (res, vs) + +{#fun NNSymbolListInputNames as nnSymbolListInputNamesImpl + { id `SymbolHandle' + , `Int' + , alloca- `NNUInt' peek* + , alloca- `Ptr (Ptr CChar)' peek* + } -> `Int' #} + +-- | List input names in the symbol. +nnSymbolListInputNames :: SymbolHandle -> Int -> IO (Int, [String]) +nnSymbolListInputNames sym opt = do + (res, n, p) <- nnSymbolListInputNamesImpl sym opt + ss <- peekStringArray n p + return (res, ss) + +{#fun NNSymbolListOutputNames as nnSymbolListOutputNamesImpl + { id `SymbolHandle' + , alloca- `NNUInt' peek* + , alloca- `Ptr (Ptr CChar)' peek* + } -> `Int' #} + +-- | List returns names in the symbol. +nnSymbolListOutputNames :: SymbolHandle -> IO (Int, [String]) +nnSymbolListOutputNames sym = do + (res, n, p) <- nnSymbolListOutputNamesImpl sym + ss <- peekStringArray n p + return (res, ss) + +-- | Get a symbol that contains all the internals. +{#fun NNSymbolGetInternals as nnSymbolGetInternals + { id `SymbolHandle' + , alloca- `SymbolHandle' peek* + } -> `Int' #} + +-- | Get index-th outputs of the symbol. +{#fun NNSymbolGetOutput as nnSymbolGetOutput + { id `SymbolHandle' + , id `NNUInt' + , alloca- `SymbolHandle' peek* + } -> `Int' #} + +-- | Compose the symbol on other symbols. +{#fun NNSymbolCompose as nnSymbolComposeImpl + { id `SymbolHandle' + , id `Ptr CChar' + , id `NNUInt' + , withStringArray* `[String]' + , withArray* `[SymbolHandle]' + } -> `Int' #} + + +-- | Invoke a nnvm op and imperative function. +nnSymbolCompose :: SymbolHandle -- ^ Creator/Handler of the OP. + -> String + -> [String] + -> [SymbolHandle] + -> IO Int +nnSymbolCompose sym name keys args = do + if null keys || length keys == length args + then return () + else throwIO $ userError "nnSymbolCompose: keyword arguments mismatch." + let nargs = fromIntegral $ length args + if null name + then nnSymbolComposeImpl sym nullPtr nargs keys args + else withCString name $ \p -> nnSymbolComposeImpl sym p nargs keys args + +-- | Create a graph handle from symbol. +{#fun NNGraphCreate as nnGraphCreate + { id `SymbolHandle' + , alloca- `GraphHandle' peek* + } -> `Int' #} + +-- | Free the graph handle. +{#fun NNGraphFree as nnGraphFree + { id `GraphHandle' + } -> `Int' #} + +-- | Get a new symbol from the graph. +{#fun NNGraphGetSymbol as nnGraphGetSymbol + { id `GraphHandle' -- ^ the graph handle. + , alloca- `SymbolHandle' peek* -- ^ the corresponding symbol. + } -> `Int' #} + +-- | Get Set a attribute in json format. +{#fun NNGraphSetJSONAttr as nnGraphSetJSONAttr + { id `GraphHandle' + , `String' + , `String' + } -> `Int' #} + +-- | Get a serialized attrirbute from graph. +{#fun NNGraphGetJSONAttr as nnGraphGetJSONAttr + { id `SymbolHandle' + , `String' + , alloca- `String' peekString* + , alloca- `Int' peekIntegral* -- ^ if success. + } -> `Int' #} + +-- | Set a attribute whose type is std::vector in c++. +{#fun NNGraphSetNodeEntryListAttr_ as nnGraphSetNodeEntryListAttr_ + { id `GraphHandle' + , `String' + , `SymbolHandle' + } -> `Int' #} + +-- | Apply passes on the src graph. +{#fun NNGraphApplyPasses as nnGraphApplyPasses + { id `GraphHandle' + , id `NNUInt' + , withStringArray* `[String]' + , alloca- `GraphHandle' peek* + } -> `Int' #} diff --git a/src/MXNet/Core/Predict/Base.hs b/src/MXNet/Core/Predict/Base.hs deleted file mode 100644 --- a/src/MXNet/Core/Predict/Base.hs +++ /dev/null @@ -1,31 +0,0 @@ ------------------------------------------------------------ --- | --- module: MXNet.Core.Predict.Base --- copyright: (c) 2016 Tao He --- license: MIT --- maintainer: sighingnow@gmail.com --- --- Predict interfaces in core module of MXNet. --- -module MXNet.Core.Predict.Base ( - -- * Data types - PredictorHandle - , NDListHandle - -- * Re-exports functions. - , mxGetLastError - , mxPredCreate - , mxPredCreatePartialOut - , mxPredGetOutputShape - , mxPredSetInput - , mxPredForward - , mxPredPartialForward - , mxPredGetOutput - , mxPredFree - , mxNDListCreate - , mxNDListGet - , mxNDListFree - ) where - -import MXNet.Core.Internal.Types.Raw ( PredictorHandle, NDListHandle ) -import MXNet.Core.Base.Internal.Raw ( mxGetLastError ) -import MXNet.Core.Predict.Internal.Raw diff --git a/src/MXNet/Core/Predict/Internal.hs b/src/MXNet/Core/Predict/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Predict/Internal.hs @@ -0,0 +1,32 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Predict.Internal +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Predict interfaces in core module of MXNet. +-- +module MXNet.Core.Predict.Internal + ( -- * Data types + PredictorHandle + , NDListHandle + -- * Re-exports functions. + , mxGetLastError + , mxPredCreate + , mxPredCreatePartialOut + , mxPredGetOutputShape + , mxPredSetInput + , mxPredForward + , mxPredPartialForward + , mxPredGetOutput + , mxPredFree + , mxNDListCreate + , mxNDListGet + , mxNDListFree + ) where + +import MXNet.Core.Types.Internal ( PredictorHandle, NDListHandle ) +import MXNet.Core.Base.Internal ( mxGetLastError ) +import MXNet.Core.Predict.Internal.Raw + diff --git a/src/MXNet/Core/Predict/Internal/Raw.chs b/src/MXNet/Core/Predict/Internal/Raw.chs --- a/src/MXNet/Core/Predict/Internal/Raw.chs +++ b/src/MXNet/Core/Predict/Internal/Raw.chs @@ -24,7 +24,7 @@ import C2HS.C.Extra.Marshal -{#import MXNet.Core.Internal.Types.Raw #} +{#import MXNet.Core.Types.Internal.Raw #} #include diff --git a/src/MXNet/Core/Types/Internal.hs b/src/MXNet/Core/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Types/Internal.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Types.Internal +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Types in MXNet and NNVM. +-- +module MXNet.Core.Types.Internal + ( -- * Type alias + NNUInt + , MXUInt + , MXFloat + -- * Handlers and Creators + , NDArrayHandle + , FunctionHandle + , AtomicSymbolCreator + , SymbolHandle + , AtomicSymbolHandle + , ExecutorHandle + , DataIterCreator + , DataIterHandle + , KVStoreHandle + , RecordIOHandle + , RtcHandle + -- * Handlers in predict API + , PredictorHandle + , NDListHandle + -- * Handlers in nnvm + , OpHandle + , GraphHandle + -- * Callback types + , ExecutorMonitorCallback + , CustomOpPropCreator + , MXKVStoreUpdater + , MXKVStoreServerController + ) where + +import MXNet.Core.Types.Internal.Raw diff --git a/src/MXNet/Core/Types/Internal/Raw.chs b/src/MXNet/Core/Types/Internal/Raw.chs new file mode 100644 --- /dev/null +++ b/src/MXNet/Core/Types/Internal/Raw.chs @@ -0,0 +1,215 @@ +----------------------------------------------------------- +-- | +-- module: MXNet.Core.Types.Internal.Raw +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Collect data type defintions into a single raw binding module to avoid redefinitions. +-- +#if __GLASGOW_HASKELL__ >= 709 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE ForeignFunctionInterface #-} + +module MXNet.Core.Types.Internal.Raw where + +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable + +#include +#include +#include + +-- | Handle size_t type. +{#typedef size_t CSize#} + +{--------------------------------------------------------------------- +- Primitive type alias. +---------------------------------------------------------------------} + +-- | NNUint type alias. +type NNUInt = CUInt + +-- | MXUint type alias. +type MXUInt = CUInt + +-- | MXFloat type alias. +type MXFloat = CFloat + +{--------------------------------------------------------------------- +- +---------------------------------------------------------------------} + +-- | Handle to a function that takes param and creates symbol. + +{#pointer OpHandle #} + +{- FIXME maybe a bug from c2hs, when make a type alias of OpHandle, the + generated CFFI function will not be correct. + +{#pointer OpHandle newtype #} + +instance Storable OpHandle where + sizeOf (OpHandle t) = sizeOf t + alignment (OpHandle t) = alignment t + peek p = fmap OpHandle (peek (castPtr p)) + poke p (OpHandle t) = poke (castPtr p) t + +--} + +-- | Handle to a symbol that can be bind as operator. +{#pointer SymbolHandle newtype #} + +instance Storable SymbolHandle where + sizeOf (SymbolHandle t) = sizeOf t + alignment (SymbolHandle t) = alignment t + peek p = fmap SymbolHandle (peek (castPtr p)) + poke p (SymbolHandle t) = poke (castPtr p) t + +-- | Handle to Graph. +{#pointer GraphHandle newtype #} + +instance Storable GraphHandle where + sizeOf (GraphHandle t) = sizeOf t + alignment (GraphHandle t) = alignment t + peek p = fmap GraphHandle (peek (castPtr p)) + poke p (GraphHandle t) = poke (castPtr p) t + +{--------------------------------------------------------------------- +- +---------------------------------------------------------------------} + +-- | Handle to NDArray. +{#pointer NDArrayHandle newtype #} + +instance Storable NDArrayHandle where + sizeOf (NDArrayHandle t) = sizeOf t + alignment (NDArrayHandle t) = alignment t + peek p = fmap NDArrayHandle (peek (castPtr p)) + poke p (NDArrayHandle t) = poke (castPtr p) t + +-- | Handle to a mxnet narray function that changes NDArray. +{#pointer FunctionHandle newtype #} + +instance Storable FunctionHandle where + sizeOf (FunctionHandle t) = sizeOf t + alignment (FunctionHandle t) = alignment t + peek p = fmap FunctionHandle (peek (castPtr p)) + poke p (FunctionHandle t) = poke (castPtr p) t + +-- | Handle to a function that takes param and creates symbol. +type AtomicSymbolCreator = OpHandle + +-- | Handle to a AtomicSymbol. +{#pointer AtomicSymbolHandle newtype #} + +instance Storable AtomicSymbolHandle where + sizeOf (AtomicSymbolHandle t) = sizeOf t + alignment (AtomicSymbolHandle t) = alignment t + peek p = fmap AtomicSymbolHandle (peek (castPtr p)) + poke p (AtomicSymbolHandle t) = poke (castPtr p) t + +{#pointer ExecutorHandle newtype #} + +-- | Handle to an Executor. +instance Storable ExecutorHandle where + sizeOf (ExecutorHandle t) = sizeOf t + alignment (ExecutorHandle t) = alignment t + peek p = fmap ExecutorHandle (peek (castPtr p)) + poke p (ExecutorHandle t) = poke (castPtr p) t + +-- | Handle a dataiter creator. +{#pointer DataIterCreator newtype #} + +instance Storable DataIterCreator where + sizeOf (DataIterCreator t) = sizeOf t + alignment (DataIterCreator t) = alignment t + peek p = fmap DataIterCreator (peek (castPtr p)) + poke p (DataIterCreator t) = poke (castPtr p) t + +-- | Handle to a DataIterator. +{#pointer DataIterHandle newtype #} + +instance Storable DataIterHandle where + sizeOf (DataIterHandle t) = sizeOf t + alignment (DataIterHandle t) = alignment t + peek p = fmap DataIterHandle (peek (castPtr p)) + poke p (DataIterHandle t) = poke (castPtr p) t + +-- | Handle to KVStore. +{#pointer KVStoreHandle newtype #} + +instance Storable KVStoreHandle where + sizeOf (KVStoreHandle t) = sizeOf t + alignment (KVStoreHandle t) = alignment t + peek p = fmap KVStoreHandle (peek (castPtr p)) + poke p (KVStoreHandle t) = poke (castPtr p) t + +-- | Handle to RecordIO. +{#pointer RecordIOHandle newtype #} + +instance Storable RecordIOHandle where + sizeOf (RecordIOHandle t) = sizeOf t + alignment (RecordIOHandle t) = alignment t + peek p = fmap RecordIOHandle (peek (castPtr p)) + poke p (RecordIOHandle t) = poke (castPtr p) t + +-- | Handle to MXRtc. +{#pointer RtcHandle newtype #} + +instance Storable RtcHandle where + sizeOf (RtcHandle t) = sizeOf t + alignment (RtcHandle t) = alignment t + peek p = fmap RtcHandle (peek (castPtr p)) + poke p (RtcHandle t) = poke (castPtr p) t + +-- | Callback: ExecutorMonitorCallback. +{#pointer ExecutorMonitorCallback newtype #} + +-- | Callback: CustomOpPropCreator. +{#pointer CustomOpPropCreator newtype #} + +-- | Callback: MXKVStoreUpdater, user-defined updater for the kvstore. +type MXKVStoreUpdater = Int -- ^ The key. + -> NDArrayHandle -- ^ The pushed value on the key. + -> NDArrayHandle -- ^ The value stored on local on the key. + -> Ptr () -- ^ The additional handle to the updater. + -> IO Int + +foreign import ccall "wrapper" + makeMXKVStoreUpdater :: MXKVStoreUpdater -> IO (FunPtr MXKVStoreUpdater) + +-- | Callback: MXKVStoreServerController, the prototype of a server controller. +type MXKVStoreServerController = Int -- ^ The head of the command. + -> Ptr CChar -- ^ The body of the command. + -> Ptr () -- ^ Helper handle for implementing controller. + -> IO Int + +foreign import ccall "wrapper" + makeMXKVStoreServerController :: MXKVStoreServerController -> IO (FunPtr MXKVStoreServerController) + +{--------------------------------------------------------------------- +- +---------------------------------------------------------------------} + +-- | Handle to Predictor. +{#pointer PredictorHandle newtype #} + +instance Storable PredictorHandle where + sizeOf (PredictorHandle t) = sizeOf t + alignment (PredictorHandle t) = alignment t + peek p = fmap PredictorHandle (peek (castPtr p)) + poke p (PredictorHandle t) = poke (castPtr p) t + +-- | Handle to NDArrayList. +{#pointer NDListHandle newtype #} + +instance Storable NDListHandle where + sizeOf (NDListHandle t) = sizeOf t + alignment (NDListHandle t) = alignment t + peek p = fmap NDListHandle (peek (castPtr p)) + poke p (NDListHandle t) = poke (castPtr p) t diff --git a/tests/mxnet-test.hs b/tests/mxnet-test.hs new file mode 100644 --- /dev/null +++ b/tests/mxnet-test.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------- +-- | +-- copyright: (c) 2016-2017 Tao He +-- license: MIT +-- maintainer: sighingnow@gmail.com +-- +-- Test suite for mxnet package. +-- +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} + +import qualified Data.Vector.Storable as V + +import Test.Tasty +import Test.Tasty.HUnit + +import MXNet.Core.Base + +main :: IO () +main = mxListAllOpNames >> defaultMain mxnetTest + +mxnetTest :: TestTree +mxnetTest = testGroup "MXNet Test Suite" + [ hmapTest + , ndarrayTest + , symbolTest + ] + +hmapTest :: TestTree +hmapTest = testGroup "HMap" + [ testCase "Get after add" $ do + let expected = 1 + got = get @"a" (add @"a" (1 :: Int) nil) + assertEqual "get after add" expected got + ] + +ndarrayTest :: TestTree +ndarrayTest = testGroup "NDArray" + [ testCaseSteps "NDArray basic operation" $ \step -> do + step "preparing ndarray" + let sh = [2, 3, 4, 5] + p = product sh + arr <- array sh [1 .. fromIntegral $ product sh] :: IO (NDArray Float) + + step "shape and size" + (d, sh') <- ndshape arr + assertEqual "dimension should coincide" 4 d + assertEqual "shape should coincide" sh sh' + s <- ndsize arr + assertEqual "size should coincide" p s + + step "arithmetic operators" + b <- (arr + arr) .* 3 >>= (./ 2) + r <- V.sum <$> items b + let expected = 3 * (p * (p+1) `div` 2) + assertEqual "sum of elements should be as expected" expected (round r) + + step "comparison with scalar" + b <- _Maximum' arr 1000 + r <- V.sum <$> items b + let expected = 1000 * p + assertEqual "_Maximum' should set the whole ndarray" expected (round r) + + , testCaseSteps "NDArray linear algebra" $ \step -> do + step "preparing ndarray" + a <- array [2, 3] [1 .. 6] + + step "ndarray dot product" + b <- (a `dot`) =<< transpose a + expected1 <- array [2, 2] [14, 32, 32, 77] :: IO (NDArray Float) + assertEqual "a `dot` transpose a" expected1 b + c <- transpose a >>= (`dot` a) + expected2 <- array [3, 3] [17, 22, 27, 22, 29, 36, 27, 36, 45] :: IO (NDArray Float) + assertEqual "transpose a `dot` a" expected2 c + + , testCaseSteps "NDArray activation" $ \step -> do + step "preparing ndarray" + a <- array [4] [-0.5, -0.1, 0.1, 0.5] + + step "relu activation" + r <- activation a "relu" + expected <- array [4] [0.0, 0.0, 0.1, 0.5] :: IO (NDArray Float) + assertEqual "relu activation" expected r + + step "sigmoid activation" + r <- activation a "sigmoid" + expected <- array [4] [0.37754068, 0.4750208, 0.52497917, 0.62245935] :: IO (NDArray Float) + assertEqual "sigmoid activation" expected r + + step "softrelu activation" + r <- activation a "softrelu" + expected <- array [4] [0.47407699, 0.64439672, 0.74439669, 0.97407699] :: IO (NDArray Float) + assertEqual "softrelu activation" expected r + + step "tanh activation" + r <- activation a "tanh" + expected <- array [4] [-0.46211717, -0.099667996, 0.099667996, 0.46211717] :: IO (NDArray Float) + assertEqual "tanh activation" expected r + + step "softmax activation" + r <- softmaxActivation a + expected <- array [4] [0.1422025, 0.21214119, 0.25910985, 0.38654646] :: IO (NDArray Float) + assertEqual "softmax activation" expected r + + step "leakyReLU activation" -- for leakyReLU, input must be a multiple dimensions ndarray. + a' <- array [1, 4] [-0.5, -0.1, 0.1, 0.5] + r <- leakyReLU a' "leaky" + expected <- array [1, 4] [-0.125, -0.025, 0.1, 0.5] :: IO (NDArray Float) + assertEqual "leakyReLU activation" expected r + ] + +symbolTest :: TestTree +symbolTest = testGroup "Symbol" + [ testCaseSteps "Symbol basic operation" $ \step -> do + step "preparing symbol" + a <- variable "a" :: IO (Symbol Float) + + step "get name" + a' <- getName a + assertEqual "get symbol name" "a" a' + + , testCaseSteps "Symbol bind ndarray data" $ \step -> do + step "preparing symbol and ndarray" + a <- variable "a" :: IO (Symbol Float) + b <- variable "b" :: IO (Symbol Float) + arr1 <- array [2, 3] [1 .. 6] + arr2 <- array [2, 3] [5 .. 10] + + step "bind and arithmetic operators" + c <- a + b .+ 2 >>= (./ 2) + expected <- array [2, 3] [4 .. 9] + exec <- bind c contextCPU [ ("a", arr1) + , ("b", arr2) ] + forward exec False + [r] <- getOutputs exec + assertEqual "bind and arithmetics with scalar" expected r + + step "bind and linear algebra" + c <- (a `dot`) =<< transpose b + expected <- array [2, 2] [38, 56, 92, 137] + exec <- bind c contextCPU [ ("a", arr1) + , ("b", arr2) ] + forward exec False + [r] <- getOutputs exec + assertEqual "bind and a `dot` transpose b" expected r + c <- transpose a >>= (`dot` b) + expected <- array [3, 3] [ 37, 42, 47 + , 50, 57, 64 + , 63, 72, 81 ] + exec <- bind c contextCPU [ ("a", arr1) + , ("b", arr2) ] + forward exec False + [r] <- getOutputs exec + assertEqual "bind and transpose a `dot` b" expected r + + step "bind and activation" + c <- softmaxActivation a + expected <- array [2, 3] [ 0.09003057, 0.24472848, 0.66524094 + , 0.09003057, 0.24472848, 0.66524094 ] + exec <- bind c contextCPU [ ("a", arr1) ] + forward exec False + [r] <- getOutputs exec + assertEqual "bind and softmax activation" expected r + c <- leakyReLU a "leaky" + expected <- array [2, 3] [ 1.0, 2.0, 3.0, 4.0, 5.0, 6.0 ] + exec <- bind c contextCPU [ ("a", arr1) ] + forward exec False + [r] <- getOutputs exec + assertEqual "bind and leakyReLU activation" expected r + ] +