mxnet 0.1.0.1 → 0.2.0.0
raw patch · 23 files changed
+3344/−515 lines, 23 filesdep +mxnetdep +prettydep +tastydep ~c2hs-extrabuild-type:Customsetup-changed
Dependencies added: mxnet, pretty, tasty, tasty-hunit, template-haskell, unordered-containers, vector
Dependency ranges changed: c2hs-extra
Files
- Setup.hs +30/−1
- mxnet.cabal +32/−5
- src/MXNet/Core/Base.hs +52/−144
- src/MXNet/Core/Base/DType.hs +339/−0
- src/MXNet/Core/Base/Executor.hs +46/−0
- src/MXNet/Core/Base/HMap.hs +193/−0
- src/MXNet/Core/Base/Internal.hs +164/−0
- src/MXNet/Core/Base/Internal/Raw.chs +145/−83
- src/MXNet/Core/Base/Internal/TH.hs +437/−0
- src/MXNet/Core/Base/Internal/TH/NDArray.hs +62/−0
- src/MXNet/Core/Base/Internal/TH/Symbol.hs +35/−0
- src/MXNet/Core/Base/NDArray.hs +504/−0
- src/MXNet/Core/Base/Symbol.hs +499/−0
- src/MXNet/Core/Internal/Types/Raw.chs +0/−183
- src/MXNet/Core/NDArray.hs +0/−67
- src/MXNet/Core/NNVM/Internal.hs +49/−0
- src/MXNet/Core/NNVM/Internal/Raw.chs +296/−0
- src/MXNet/Core/Predict/Base.hs +0/−31
- src/MXNet/Core/Predict/Internal.hs +32/−0
- src/MXNet/Core/Predict/Internal/Raw.chs +1/−1
- src/MXNet/Core/Types/Internal.hs +40/−0
- src/MXNet/Core/Types/Internal/Raw.chs +215/−0
- tests/mxnet-test.hs +173/−0
Setup.hs view
@@ -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
mxnet.cabal view
@@ -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
src/MXNet/Core/Base.hs view
@@ -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
+ src/MXNet/Core/Base/DType.hs view
@@ -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
+ src/MXNet/Core/Base/Executor.hs view
@@ -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
+ src/MXNet/Core/Base/HMap.hs view
@@ -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 #-}
+ src/MXNet/Core/Base/Internal.hs view
@@ -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
src/MXNet/Core/Base/Internal/Raw.chs view
@@ -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 <mxnet/c_api.h> @@ -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) -------------------------------------------------------------------------------
+ src/MXNet/Core/Base/Internal/TH.hs view
@@ -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 <float>" -> AppT ListT . ConT . mkName $ "Float"+ "tuple of <double>" -> 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 <float>" -> AppT ListT . ConT . mkName $ "Float"+ "tuple of <double>" -> 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 <float>` can't be exported correctly by mxSymbolGetAtomicSymbolInfo.+ then Just (v, "tuple of <float>")+ 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=")
+ src/MXNet/Core/Base/Internal/TH/NDArray.hs view
@@ -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)
+ src/MXNet/Core/Base/Internal/TH/Symbol.hs view
@@ -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)
+ src/MXNet/Core/Base/NDArray.hs view
@@ -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
+ src/MXNet/Core/Base/Symbol.hs view
@@ -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
− src/MXNet/Core/Internal/Types/Raw.chs
@@ -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 <mxnet/c_api.h>-#include <mxnet/c_predict_api.h>---- | Handle size_t type.-{#typedef size_t CSize#}--{----------------------------------------------------------------------- <mxnet/c_api.h>----------------------------------------------------------------------}---- | 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)--{----------------------------------------------------------------------- <mxnet/c_predict_api.h>----------------------------------------------------------------------}---- | 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
− src/MXNet/Core/NDArray.hs
@@ -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)
+ src/MXNet/Core/NNVM/Internal.hs view
@@ -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
+ src/MXNet/Core/NNVM/Internal/Raw.chs view
@@ -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 <nnvm/c_api.h>.+--+#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 <nnvm/c_api.h>++-- | 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<NodeEntry> 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' #}
− src/MXNet/Core/Predict/Base.hs
@@ -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
+ src/MXNet/Core/Predict/Internal.hs view
@@ -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+
src/MXNet/Core/Predict/Internal/Raw.chs view
@@ -24,7 +24,7 @@ import C2HS.C.Extra.Marshal -{#import MXNet.Core.Internal.Types.Raw #}+{#import MXNet.Core.Types.Internal.Raw #} #include <mxnet/c_predict_api.h>
+ src/MXNet/Core/Types/Internal.hs view
@@ -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
+ src/MXNet/Core/Types/Internal/Raw.chs view
@@ -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 <nnvm/c_api.h>+#include <mxnet/c_api.h>+#include <mxnet/c_predict_api.h>++-- | 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++{---------------------------------------------------------------------+- <nnvm/c_api.h>+---------------------------------------------------------------------}++-- | 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++{---------------------------------------------------------------------+- <mxnet/c_api.h>+---------------------------------------------------------------------}++-- | 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)++{---------------------------------------------------------------------+- <mxnet/c_predict_api.h>+---------------------------------------------------------------------}++-- | 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
+ tests/mxnet-test.hs view
@@ -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+ ]+