diff --git a/bench/Alloc.hs b/bench/Alloc.hs --- a/bench/Alloc.hs +++ b/bench/Alloc.hs @@ -45,10 +45,6 @@ n :: Int n = 100 -instance NFData T.Tensor - where - rnf (T.Unsafe _) = () - instance NFData (ForeignPtr a) where rnf v = v `seq` () diff --git a/bench/Runtime.hs b/bench/Runtime.hs --- a/bench/Runtime.hs +++ b/bench/Runtime.hs @@ -49,10 +49,6 @@ #define N3 1000 -instance NFData T.Tensor - where - rnf (T.Unsafe _) = () - instance NFData (ForeignPtr a) where rnf v = v `seq` () diff --git a/hasktorch.cabal b/hasktorch.cabal --- a/hasktorch.cabal +++ b/hasktorch.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasktorch -version: 0.2.1.4 +version: 0.2.1.6 synopsis: Haskell bindings to libtorch, supporting both typed and untyped tensors. description: Hasktorch is a library for tensors and neural networks in Haskell. It is an independent open source community project which leverages the core C++ libraries shared by PyTorch. homepage: https://github.com/hasktorch/hasktorch#readme @@ -142,6 +142,7 @@ , megaparsec >= 9.5 && < 9.8 , half >= 0.3 && < 0.4 , constraints >= 0.14 && < 0.15 + , deepseq >= 1.4.8 && < 1.6 default-extensions: Strict , StrictData @@ -210,6 +211,7 @@ , lens-family-core , data-default-class , half + , vector test-suite doctests if os(darwin) || flag(disable-doctest) @@ -221,7 +223,7 @@ main-is: doctests.hs ghc-options: -Wall -threaded -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver -fplugin GHC.TypeLits.Extra.Solver -fconstraint-solver-iterations=0 default-language: Haskell2010 - build-depends: doctest >=0.16.0.1 && <0.23 + build-depends: doctest >=0.16.0.1 && <0.25 , async , base , libtorch-ffi diff --git a/src/Torch/Optim.hs b/src/Torch/Optim.hs --- a/src/Torch/Optim.hs +++ b/src/Torch/Optim.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Torch.Optim where @@ -12,6 +13,8 @@ import Torch.Tensor import Torch.TensorFactories import Prelude hiding (sqrt) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData, force) type LearningRate = Tensor @@ -107,8 +110,10 @@ m2 :: [Tensor], -- 2nd moment iter :: Int -- iteration } - deriving (Show) + deriving (Show, Generic) +instance NFData Adam + mkAdam :: Int -> Float -> @@ -142,8 +147,9 @@ -- decaying averages of 1st & 2nd moments f1 m1 dp = mulScalar beta1 m1 + mulScalar (1 - beta1) dp f2 m2 dp = mulScalar beta2 m2 + mulScalar (1 - beta2) (dp * dp) - m1' = zipWith f1 m1 gradients - m2' = zipWith f2 m2 gradients + -- force to prevent spine laziness. See https://github.com/hasktorch/hasktorch/pull/728 + m1' = force $ zipWith f1 m1 gradients + m2' = force $ zipWith f2 m2 gradients -- bias adjustment a beta = divScalar (1 - beta ^ (iter + 1)) a1 = fmap (a beta1) m1' diff --git a/src/Torch/Tensor.hs b/src/Torch/Tensor.hs --- a/src/Torch/Tensor.hs +++ b/src/Torch/Tensor.hs @@ -24,12 +24,17 @@ import Data.Proxy import Data.Reflection import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG import Data.Word (Word8) import Foreign.C.Types import Foreign.ForeignPtr +import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr import Foreign.Storable import GHC.Generics +import GHC.ForeignPtr(mallocPlainForeignPtrBytes) import Numeric import System.IO.Unsafe import Torch.DType @@ -51,12 +56,16 @@ import qualified Torch.Internal.Unmanaged.Type.Tensor as Unmanaged (tensor_data_ptr) import Torch.Lens import Torch.TensorOptions +import Control.DeepSeq (NFData, rnf) type ATenTensor = ForeignPtr ATen.Tensor -- do not use the constructor newtype Tensor = Unsafe ATenTensor +instance NFData Tensor where + rnf (Unsafe _) = () + instance Castable Tensor ATenTensor where cast (Unsafe aten_tensor) f = f aten_tensor uncast aten_tensor f = f $ Unsafe aten_tensor @@ -701,6 +710,45 @@ if product (_dims d) == width -- This validation may be slow. then (_pokeElemOff @a) ptr (offset + i * width) d else throwIO $ userError $ "There are lists having different length." + +instance {-# OVERLAPPING #-} (Reifies a DType, Storable a) => TensorLike (VS.Vector a) where + asTensor v = unsafePerformIO $ do + t <- ((cast2 ATen.new_empty_tensor) :: [Int] -> TensorOptions -> IO Tensor) [VS.length v] $ withDType (_dtype @a) defaultOpts + _withTensor t $ \ptr -> do + VS.unsafeWith v $ \vptr -> do + copyBytes + (castPtr ptr) + (castPtr vptr) + (VS.length v * (sizeOf (undefined :: a))) + return t + + _asValue t = unsafePerformIO $ + let len = head (shape t) + in + withTensor t $ \ptr -> do + fp <- mallocPlainForeignPtrBytes (len * (sizeOf (undefined :: a))) + withForeignPtr fp $ \vptr -> do + copyBytes + (castPtr vptr) + (castPtr ptr) + (len * (sizeOf (undefined :: a))) + return $ VS.unsafeFromForeignPtr fp 0 len + + _dtype = reflect (Proxy :: Proxy a) + _dims v = [VS.length v] + _deepDims v = Just [VS.length v] + _peekElemOff = error "Not implemented for storable vector" + _pokeElemOff = error "Not implemented for storable vector" + +instance {-# OVERLAPPING #-} (Reifies a DType, Storable a, VG.Vector VU.Vector a) => TensorLike (VU.Vector a) where + asTensor v = asTensor (VG.convert v :: VS.Vector a) + _asValue t = VG.convert (_asValue t :: VS.Vector a) + + _dtype = reflect (Proxy :: Proxy a) + _dims v = [VG.length v] + _deepDims v = Just [VG.length v] + _peekElemOff = error "Not implemented for unboxed vector" + _pokeElemOff = error "Not implemented for unboxed vector" class AsTensors as where toTensors :: as -> V.Vector Tensor diff --git a/test/TensorSpec.hs b/test/TensorSpec.hs --- a/test/TensorSpec.hs +++ b/test/TensorSpec.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} module TensorSpec (spec) where @@ -17,11 +19,32 @@ import Torch.TensorFactories import Torch.TensorOptions import Test.QuickCheck.Arbitrary +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Generic as VG instance Arbitrary Half where arbitrary = arbitrarySizedFractional shrink = shrinkDecimal +instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where + arbitrary = do + n <- choose (0, 20) -- limit length to at most 20 + xs <- vectorOf n arbitrary -- exactly n randomly generated `a`s + return (VS.fromList xs) + + shrink v = [ VS.fromList xs + | xs <- shrink (VS.toList v) ] + +instance (Arbitrary a, VS.Storable a, VG.Vector VU.Vector a) => Arbitrary (VU.Vector a) where + arbitrary = do + n <- choose (0, 20) -- limit length to at most 20 + xs <- vectorOf n arbitrary -- exactly n randomly generated `a`s + return (VG.fromList xs) + + shrink v = [ VG.fromList xs + | xs <- shrink (VG.toList v) ] + spec :: Spec spec = do describe "TensorLike" $ do @@ -64,6 +87,15 @@ it "TensorLike Complex Double" $ property $ \x -> asValue (asTensor x) `shouldBe` (x :: Complex Double) + it "TensorLike Storable Vector Float" $ + property $ + \x -> asValue (asTensor x) `shouldBe` (x :: VS.Vector Float) + it "TensorLike Storable Vector Double" $ + property $ + \x -> asValue (asTensor x) `shouldBe` (x :: VS.Vector Double) + it "TensorLike Unboxed Vector Double" $ + property $ + \x -> asValue (asTensor x) `shouldBe` (x :: VU.Vector Double) it "Compare internal expression of c++ with Storable expression of haskell" $ do show (asTensor [True, False, True, False])