diff --git a/Build.hs b/Build.hs --- a/Build.hs +++ b/Build.hs @@ -75,9 +75,18 @@ removeFilesAfter "samples" ["/*.o"] cmd "stack ghc" "--stack-yaml stack.yaml" + "--package finite-typelits" + "--package hmatrix-backprop" + "--package hmatrix-vector-sized" + "--package microlens-th" "--package mnist-idx" - "--package singletons" + "--package mwc-random" + "--package one-liner" "--package one-liner-instances" + "--package random" + "--package singletons" + "--package split" + "--package vector-sized" "--" ("samples" src) "-o" f diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,18 @@ Changelog ========= +Version 0.2.6.2 +--------------- + +*April 7, 2019* + + + +* Fix a numerical bug that would occur when an input is used directly as the + result of a computation. (For example, `gradBP id` or `gradBP2 const`). +* Some internal changes to strictness which offers some performance boosts in + computation of gradients. + Version 0.2.6.1 --------------- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -143,7 +143,7 @@ This can be run, again: ```haskell -evalBP (netError myTarget myVector) :: Network -> Network +evalBP (netError myTarget myVector) :: Network -> Double ``` Now, we just wrote a *normal function to compute the error of our network*. diff --git a/backprop.cabal b/backprop.cabal --- a/backprop.cabal +++ b/backprop.cabal @@ -1,11 +1,13 @@ --- This file has been generated from package.yaml by hpack version 0.28.2. +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- --- hash: 009a268e1d551f52673b7339f93986c16870d9402a854ad8157d133450ef7591 +-- hash: fe389131c629c91aba7d98e6c95411c83f558b8fec788d0d12405bdf4db507aa name: backprop -version: 0.2.6.1 +version: 0.2.6.2 synopsis: Heterogeneous automatic differentation description: Write your functions to compute your result, and the library will automatically generate functions to compute your gradient. @@ -24,10 +26,16 @@ license-file: LICENSE tested-with: GHC >= 8.0 build-type: Simple -cabal-version: >= 1.10 extra-source-files: - Build.hs + README.md CHANGELOG.md + Build.hs + samples/backprop-mnist.lhs + samples/extensible-neural.lhs + renders/backprop-mnist.pdf + renders/extensible-neural.pdf + renders/backprop-mnist.md + renders/extensible-neural.md doc/01-getting-started.md doc/02-a-detailed-look.md doc/03-manipulating-bvars.md @@ -38,19 +46,24 @@ doc/08-equipping-your-library.md doc/09-comparisons.md doc/index.md - README.md - renders/backprop-mnist.md - renders/backprop-mnist.pdf - renders/extensible-neural.md - renders/extensible-neural.pdf - samples/backprop-mnist.lhs - samples/extensible-neural.lhs source-repository head type: git location: https://github.com/mstksg/backprop library + exposed-modules: + Numeric.Backprop + Numeric.Backprop.Class + Numeric.Backprop.Explicit + Numeric.Backprop.Num + Numeric.Backprop.Op + Prelude.Backprop + Prelude.Backprop.Explicit + Prelude.Backprop.Num + other-modules: + Numeric.Backprop.Internal + Data.Type.Util hs-source-dirs: src ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints @@ -64,23 +77,13 @@ , transformers , vector , vinyl >=0.9.1 - exposed-modules: - Numeric.Backprop - Numeric.Backprop.Class - Numeric.Backprop.Explicit - Numeric.Backprop.Num - Numeric.Backprop.Op - Prelude.Backprop - Prelude.Backprop.Explicit - Prelude.Backprop.Num - other-modules: - Numeric.Backprop.Internal - Data.Type.Util default-language: Haskell2010 benchmark backprop-mnist-bench type: exitcode-stdio-1.0 main-is: bench.hs + other-modules: + Paths_backprop hs-source-dirs: bench ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -O2 @@ -96,6 +99,4 @@ , mwc-random , time , vector - other-modules: - Paths_backprop default-language: Haskell2010 diff --git a/doc/03-manipulating-bvars.md b/doc/03-manipulating-bvars.md --- a/doc/03-manipulating-bvars.md +++ b/doc/03-manipulating-bvars.md @@ -327,7 +327,7 @@ `BVar s (a, b)` to get a `BVar s a` and `BVar s b`. The `T3` pattern is also provided, which does the same thing for three-tuples. -Note that `T2` and `T2` are bidirectional pattern synonyms, and can be used to +Note that `T2` and `T3` are *bidirectional* pattern synonyms, and can be used to construct as well as deconstruct. Combining BVars diff --git a/renders/backprop-mnist.md b/renders/backprop-mnist.md --- a/renders/backprop-mnist.md +++ b/renders/backprop-mnist.md @@ -35,24 +35,23 @@ - split ``` {.sourceCode .literate .haskell} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} import Control.DeepSeq import Control.Exception -import Control.Lens hiding ((<.>)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Maybe @@ -66,6 +65,8 @@ import Data.Tuple import GHC.Generics (Generic) import GHC.TypeLits +import Lens.Micro +import Lens.Micro.TH import Numeric.Backprop import Numeric.Backprop.Class import Numeric.LinearAlgebra.Static diff --git a/renders/backprop-mnist.pdf b/renders/backprop-mnist.pdf Binary files a/renders/backprop-mnist.pdf and b/renders/backprop-mnist.pdf differ diff --git a/renders/extensible-neural.md b/renders/extensible-neural.md --- a/renders/extensible-neural.md +++ b/renders/extensible-neural.md @@ -24,26 +24,24 @@ - split ``` {.sourceCode .literate .haskell} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} import Control.DeepSeq import Control.Exception -import Control.Lens hiding ((<.>)) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Primitive @@ -61,6 +59,8 @@ import Data.Traversable import Data.Tuple import GHC.Generics (Generic) +import Lens.Micro +import Lens.Micro.TH import Numeric.Backprop import Numeric.Backprop.Class import Numeric.LinearAlgebra.Static diff --git a/renders/extensible-neural.pdf b/renders/extensible-neural.pdf Binary files a/renders/extensible-neural.pdf and b/renders/extensible-neural.pdf differ diff --git a/src/Data/Type/Util.hs b/src/Data/Type/Util.hs --- a/src/Data/Type/Util.hs +++ b/src/Data/Type/Util.hs @@ -15,12 +15,11 @@ runzipWith , rzipWithM_ , Replicate - , VecT(.., (:+)), Vec + , VecT(.., (:+)) , vmap , withVec , vecToRec , fillRec - , rtraverse_ , zipVecList , splitRec , p1, p2, s1, s2 @@ -53,9 +52,7 @@ VNil :: VecT 'Z f a (:*) :: !(f a) -> VecT n f a -> VecT ('S n) f a -type Vec n = VecT n Identity - -pattern (:+) :: a -> Vec n a -> Vec ('S n) a +pattern (:+) :: a -> VecT n Identity a -> VecT ('S n) Identity a pattern x :+ xs = Identity x :* xs vmap @@ -105,18 +102,6 @@ [] -> Nothing y:ys -> (f x y :&) <$> go xs ys {-# INLINE fillRec #-} - -rtraverse_ - :: forall f g. Applicative g - => (forall x. f x -> g ()) - -> (forall xs. Rec f xs -> g ()) -rtraverse_ f = go - where - go :: Rec f ys -> g () - go = \case - RNil -> pure () - x :& xs -> f x *> go xs -{-# INLINE rtraverse_ #-} rzipWithM_ :: forall h f g as. Applicative h diff --git a/src/Numeric/Backprop/Internal.hs b/src/Numeric/Backprop/Internal.hs --- a/src/Numeric/Backprop/Internal.hs +++ b/src/Numeric/Backprop/Internal.hs @@ -242,6 +242,9 @@ } -> SomeTapeNode +forceSomeTapeNode :: SomeTapeNode -> () +forceSomeTapeNode (STN n) = forceTapeNode n + -- | Debugging string for a 'SomeTapeMode'. debugSTN :: SomeTapeNode -> String debugSTN (STN TN{..}) = show . VR.rfoldMap ((:[]) . debugIR) $ _tnInputs @@ -628,6 +631,11 @@ Just y -> Just (x +* y) {-# INLINE bumpMaybe #-} +seqEither :: Either a (b, [SomeTapeNode]) -> Either a (b, [SomeTapeNode]) +seqEither e@(Left !_) = e +seqEither e@(Right (!_,foldMap forceSomeTapeNode->(!_))) = e +{-# INLINE seqEither #-} + -- | 'Numeric.Backprop.backpropWithN', but with explicit 'zero' and 'one'. -- -- Note that argument order changed in v0.2.4. @@ -639,14 +647,19 @@ -> (forall s. Reifies s W => Rec (BVar s) as -> BVar s b) -> Rec Identity as -> (b, b -> Rec Identity as) -backpropWithN zfs f !xs = (y, g) +backpropWithN zfs f !xs = (y, g') where - !(!tp@(!_,!_),!y) = unsafePerformIO $ fillWengert f xs - g :: b -> Rec Identity as - g o = runST $ do - r <- initRunner tp $ bimap getSum (`appEndo` []) - . fst - $ rtraverse_ go xs + !(seqEither->(!tp0),!y) = unsafePerformIO $ fillWengert f xs + g' :: b -> Rec Identity as + g' = case tp0 of + Left i -> setInput i + Right tp -> g tp + {-# INLINE g' #-} + g :: (Int, [SomeTapeNode]) -> b -> Rec Identity as + g tp o = runST $ do + r <- initRunner tp . bimap getSum (`appEndo` []) + . VR.rfoldMap go -- TODO: use strict tuple? + $ xs gradRunner o r tp delts <- toList <$> V.freeze (_rInputs r) return . fromMaybe (internalError "backpropN") $ @@ -654,9 +667,21 @@ (VR.rzipWith (fmap . runZF) zfs xs) delts where - go :: forall a. Identity a -> ((Sum Int, Endo [Maybe Any]),()) - go _ = ((1, Endo (unsafeCoerce (Nothing @a) :)), ()) + go :: forall a. Identity a -> (Sum Int, Endo [Maybe Any]) + go _ = (1, Endo (unsafeCoerce (Nothing @a) :)) {-# INLINE go #-} + setInput :: Int -> b -> Rec Identity as + setInput !i !x = go zfs xs 0 + where + go :: Rec ZeroFunc bs -> Rec Identity bs -> Int -> Rec Identity bs + go = \case + RNil -> \_ _ -> RNil + z :& zs -> \case + q :& qs -> \(!j) -> + if j == i + then Identity (unsafeCoerce x) :& VR.rzipWith coerce zs qs + else coerce z q :& go zs qs (j + 1) + {-# INLINE setInput #-} {-# INLINE backpropWithN #-} -- | 'evalBP' generalized to multiple inputs of different types. See @@ -673,15 +698,20 @@ :: forall as b. () => (forall s. Reifies s W => Rec (BVar s) as -> BVar s b) -> Rec Identity as - -> IO ((Int, [SomeTapeNode]), b) + -> IO (Either Int (Int, [SomeTapeNode]), b) fillWengert f xs = do w <- initWengert - o <- reify w $ \(Proxy :: Proxy s) -> do + (i, o) <- reify w $ \(Proxy :: Proxy s) -> do let oVar = f (inpRec @s) evaluate (forceBVar oVar) - return (_bvVal oVar) - t <- readIORef (wRef w) - return (t, o) + let isInput = case _bvRef oVar of + BRInp i -> Just i + _ -> Nothing + pure (isInput, _bvVal oVar) + t <- case i of + Nothing -> Right <$> readIORef (wRef w) + Just i' -> pure $ Left i' + pure (t, o) where inpRec :: forall s. Rec (BVar s) as inpRec = evalState (rtraverse (state . go . runIdentity) xs) 0