diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,19 @@ Changelog ========= +Version 0.1.2.0 +--------------- + +*Feb 7, 2018* + + + +* Added currying and uncurrying functions for tuples in + *Numeric.Backprop.Tuple*. +* `opIsoN`, for isomorphisms between a tuple of values and a value. +* (Internal) AD engine now using `Any` from *ghc-prim* instead of `Some I` + from *type-combinators* + Version 0.1.1.0 --------------- diff --git a/backprop.cabal b/backprop.cabal --- a/backprop.cabal +++ b/backprop.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 910fed99cfe32b65c18c047c45e8694c914a2eb4f7bdceec90d9ab4e3eba535c +-- hash: d40da486697c0035648b98d75f36ea36bb66bdb648bb3406bf9eed465f497bb2 name: backprop -version: 0.1.1.0 +version: 0.1.2.0 synopsis: Heterogeneous automatic differentation (backpropagation) description: Write your functions to compute your result, and the library will automatically generate functions to compute your gradient. 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 @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -46,13 +45,14 @@ import Data.IORef import Data.Kind import Data.Maybe -import Data.Monoid +import Data.Monoid hiding (Any(..)) import Data.Proxy import Data.Reflection import Data.Type.Index import Data.Type.Product hiding (toList) import Data.Type.Util import Data.Type.Vector hiding (itraverse) +import GHC.Exts (Any) import GHC.Generics import Lens.Micro import Numeric.Backprop.Op @@ -124,7 +124,7 @@ {-# INLINE bvConst #-} forceBVar :: BVar s a -> () -forceBVar (BV !r !_) = force r `seq` () +forceBVar (BV r !_) = force r `seq` () {-# INLINE forceBVar #-} data InpRef :: Type -> Type where @@ -135,7 +135,7 @@ -> InpRef a forceInpRef :: InpRef a -> () -forceInpRef (IR !v !_ !_) = forceBVar v `seq` () +forceInpRef (IR v !_ !_) = forceBVar v `seq` () {-# INLINE forceInpRef #-} -- | Debugging string for an 'InpRef'. @@ -149,7 +149,7 @@ -> TapeNode a forceTapeNode :: TapeNode a -> () -forceTapeNode (TN !inps !_) = foldMap1 forceInpRef inps `seq` () +forceTapeNode (TN inps !_) = foldMap1 forceInpRef inps `seq` () {-# INLINE forceTapeNode #-} data SomeTapeNode :: Type where @@ -158,7 +158,7 @@ -> SomeTapeNode forceSomeTapeNode :: SomeTapeNode -> () -forceSomeTapeNode (STN !tn) = forceTapeNode tn `seq` () +forceSomeTapeNode (STN tn) = forceTapeNode tn `seq` () {-# INLINE forceSomeTapeNode #-} -- | Debugging string for a 'SomeTapeMode'. @@ -182,7 +182,7 @@ -> a -> W -> IO (BVar s a) -insertNode !tn !x !w = fmap ((`BV` x) . BRIx) . atomicModifyIORef' (wRef w) $ \(!n,!t) -> +insertNode tn !x !w = fmap ((`BV` x) . BRIx) . atomicModifyIORef' (wRef w) $ \(!n,!t) -> let n' = n + 1 t' = STN tn:t in forceTapeNode tn `seq` n' `seq` t' `seq` ((n', t'), n) @@ -211,6 +211,7 @@ } go :: forall a. Index as a -> BVar s a -> InpRef a go i !v = forceBVar v `seq` (IR v id (+) \\ every @_ @Num i) + {-# INLINE go #-} {-# INLINE liftOp_ #-} -- | Lift an 'Op' with an arbitrary number of inputs to a function on the @@ -236,7 +237,7 @@ -> BVar s a -> IO (BVar s b) liftOp1_ o (bvConst->Just x) = return . constVar . evalOp o $ (x ::< Ø) -liftOp1_ o !v = forceBVar v `seq` insertNode tn y (reflect (Proxy @s)) +liftOp1_ o v = forceBVar v `seq` insertNode tn y (reflect (Proxy @s)) where (y,g) = runOpWith o (_bvVal v ::< Ø) tn = TN { _tnInputs = IR v id (+) :< Ø @@ -266,9 +267,9 @@ -> BVar s b -> IO (BVar s c) liftOp2_ o (bvConst->Just x) (bvConst->Just y) = return . constVar . evalOp o $ x ::< y ::< Ø -liftOp2_ o !v !u = forceBVar v - `seq` forceBVar u - `seq` insertNode tn y (reflect (Proxy @s)) +liftOp2_ o v u = forceBVar v + `seq` forceBVar u + `seq` insertNode tn y (reflect (Proxy @s)) where (y,g) = runOpWith o (_bvVal v ::< _bvVal u ::< Ø) tn = TN { _tnInputs = IR v id (+) :< IR u id (+) :< Ø @@ -301,10 +302,10 @@ -> IO (BVar s d) liftOp3_ o (bvConst->Just x) (bvConst->Just y) (bvConst->Just z) = return . constVar . evalOp o $ x ::< y ::< z ::< Ø -liftOp3_ o !v !u !w = forceBVar v - `seq` forceBVar u - `seq` forceBVar w - `seq` insertNode tn y (reflect (Proxy @s)) +liftOp3_ o v u w = forceBVar v + `seq` forceBVar u + `seq` forceBVar w + `seq` insertNode tn y (reflect (Proxy @s)) where (y, g) = runOpWith o (_bvVal v ::< _bvVal u ::< _bvVal w ::< Ø) tn = TN { _tnInputs = IR v id (+) :< IR u id (+) :< IR w id (+) :< Ø @@ -334,7 +335,7 @@ => Lens' b a -> BVar s b -> IO (BVar s a) -viewVar_ l !v = forceBVar v `seq` insertNode tn y (reflect (Proxy @s)) +viewVar_ l v = forceBVar v `seq` insertNode tn y (reflect (Proxy @s)) where y = _bvVal v ^. l tn = TN { _tnInputs = IR v l (+) :< Ø @@ -360,9 +361,9 @@ -> BVar s a -> BVar s b -> IO (BVar s b) -setVar_ l !w !v = forceBVar v - `seq` forceBVar w - `seq` insertNode tn y (reflect (Proxy @s)) +setVar_ l w v = forceBVar v + `seq` forceBVar w + `seq` insertNode tn y (reflect (Proxy @s)) where y = _bvVal v & l .~ _bvVal w tn = TN { _tnInputs = IR w id (+) :< IR v id (+) :< Ø @@ -410,6 +411,11 @@ -- | Collect all of the 'BVar's in a container into a 'BVar' of that -- container's contents. +-- +-- Note that this requires @t a@ to have a 'Num' instance. If you are +-- using a list, I recommend using +-- instead: +-- it's a fixed-length vector type with a very appropriate 'Num' instance! collectVar :: forall a t s. (Reifies s W, Foldable t, Functor t, Num (t a), Num a) => t (BVar s a) @@ -423,8 +429,8 @@ -> Traversal' b a -> BVar s b -> IO (f (BVar s a)) -traverseVar' f t !v = forceBVar v - `seq` itraverse go (f (_bvVal v)) +traverseVar' f t v = forceBVar v + `seq` itraverse go (f (_bvVal v)) where go :: Int -> a -> IO (BVar s a) go i y = insertNode tn y (reflect (Proxy @s)) @@ -432,6 +438,7 @@ tn = TN { _tnInputs = IR v (ixt t i) (+) :< Ø , _tnGrad = only_ } + {-# INLINE go #-} {-# INLINE traverseVar' #-} -- | Using a 'Traversal'', extract a single value /inside/ a 'BVar', if it @@ -460,8 +467,8 @@ toListOfVar t !v = unsafePerformIO $ traverseVar' (toListOf t) t v {-# INLINE toListOfVar #-} -data Runner s = R { _rDelta :: MV.MVector s (Some I) - , _rInputs :: MV.MVector s (Some I) +data Runner s = R { _rDelta :: !(MV.MVector s Any) + , _rInputs :: !(MV.MVector s Any) } initRunner @@ -472,10 +479,10 @@ initRunner (n, stns) (nx,xs) = do delts <- MV.new n for_ (zip [n-1,n-2..] stns) $ \(i, STN (TN{..} :: TapeNode c)) -> - MV.write delts i $ Some @_ @_ @c (I 0) + MV.write delts i $ unsafeCoerce @c 0 inps <- MV.new nx for_ (zip [0..] xs) $ \(i, Some (Wit1 :: Wit1 Num c)) -> - MV.write inps i $ Some @_ @_ @c (I 0) + MV.write inps i $ unsafeCoerce @c 0 return $ R delts inps {-# INLINE initRunner #-} @@ -487,23 +494,23 @@ -> m () gradRunner _ R{..} (n,stns) = do when (n > 0) $ - MV.write _rDelta (n - 1) (Some @_ @_ @b (I 1)) + MV.write _rDelta (n - 1) (unsafeCoerce @b 1) zipWithM_ go [n-1,n-2..] stns where go :: Int -> SomeTapeNode -> m () go i (STN TN{..}) = do - Some (I delt) <- MV.read _rDelta i + delt <- MV.read _rDelta i let gs = _tnGrad (unsafeCoerce delt) zipWithPM_ propagate _tnInputs gs + {-# INLINE go #-} propagate :: forall x. InpRef x -> I x -> m () - propagate (IR v ln (+*)) (I !d) = case _bvRef v of - BRInp !i -> flip (MV.modify _rInputs) i $ \case - Some (I !y) -> let y' = unsafeCoerce y & ln %~ (+* d) - in y' `seq` Some (I y') - BRIx !i -> flip (MV.modify _rDelta) i $ \case - Some (I !y) -> let y' = unsafeCoerce y & ln %~ (+* d) - in y' `seq` Some (I y') + propagate (IR v ln (+*)) (I d) = case _bvRef v of + BRInp i -> flip (MV.modify _rInputs) i $ + unsafeCoerce . (ln %~ (+* d)) . unsafeCoerce + BRIx i -> flip (MV.modify _rDelta) i $ + unsafeCoerce . (ln %~ (+* d)) . unsafeCoerce BRC -> return () + {-# INLINE propagate #-} {-# INLINE gradRunner #-} -- | 'backprop' generalized to multiple inputs of different types. See the @@ -538,7 +545,7 @@ => (forall s. Reifies s W => Prod (BVar s) as -> BVar s b) -> Tuple as -> (b, Tuple as) -backpropN f xs = (y, g) +backpropN f !xs = (y, g) where !(!tp@(!_,!_),!y) = unsafePerformIO $ fillWengert f xs g :: Tuple as @@ -547,10 +554,11 @@ gradRunner (Proxy @b) r tp delts <- toList <$> V.freeze (_rInputs r) return . fromMaybe (error "backpropN") $ - fillProd (\_ (Some (I d)) -> I (unsafeCoerce d)) xs delts + fillProd (\_ d -> I (unsafeCoerce d)) xs delts where go :: forall a. Index as a -> I a -> (Sum Int, [Some (Wit1 Num)]) go i (I _) = (1, [Some (Wit1 :: Wit1 Num a)]) \\ every @_ @Num i + {-# INLINE go #-} {-# INLINE backpropN #-} -- | 'evalBP' generalized to multiple inputs of different types. See @@ -583,6 +591,8 @@ where go :: a -> Int -> (BVar s a, Int) go x i = (BV (BRInp i) x, i + 1) + {-# INLINE go #-} + {-# INLINE inpProd #-} {-# INLINE fillWengert #-} diff --git a/src/Numeric/Backprop/Op.hs b/src/Numeric/Backprop/Op.hs --- a/src/Numeric/Backprop/Op.hs +++ b/src/Numeric/Backprop/Op.hs @@ -51,7 +51,7 @@ -- ** Giving gradients directly , op1, op2, op3 -- ** From Isomorphisms - , opCoerce, opTup, opIso, opLens + , opCoerce, opTup, opIso, opLens, opIsoN -- * Manipulation , composeOp, composeOp1, (~.) , composeOp', composeOp1' @@ -360,6 +360,19 @@ opIso :: (a -> b) -> (b -> a) -> Op '[ a ] b opIso to' from' = op1 $ \x -> (to' x, from') {-# INLINE opIso #-} + +-- | An 'Op' that runs the input value through an isomorphism between +-- a tuple of values and a value. +-- +-- Warning: This is unsafe! It assumes that the isomorphisms themselves +-- have derivative 1, so will break for things like +-- 'Numeric.Lens.exponentiating'. Basically, don't use this for any +-- "numeric" isomorphisms. +-- +-- @since 0.1.2.0 +opIsoN :: (Tuple as -> b) -> (b -> Tuple as) -> Op as b +opIsoN to' from' = Op $ \xs -> (to' xs, from') +{-# INLINE opIsoN #-} -- | An 'Op' that extracts a value from an input value using a 'Lens''. -- diff --git a/src/Numeric/Backprop/Tuple.hs b/src/Numeric/Backprop/Tuple.hs --- a/src/Numeric/Backprop/Tuple.hs +++ b/src/Numeric/Backprop/Tuple.hs @@ -57,6 +57,8 @@ -- ** Conversions -- $t2iso , t2Tup, tupT2 + -- ** Consumption + , uncurryT2, curryT2 -- ** Lenses , t2_1, t2_2 -- * Three-tuples @@ -66,6 +68,8 @@ , t3Tup, tupT3 -- ** Lenses , t3_1, t3_2, t3_3 + -- ** Consumption + , uncurryT3, curryT3 ) where import Control.DeepSeq @@ -100,15 +104,12 @@ -- | Convert to a Haskell tuple. -- -- Forms an isomorphism with 'tupT2'. --- @since 0.1.1.0 t2Tup :: T2 a b -> (a, b) t2Tup (T2 x y) = (x, y) -- | Convert from Haskell tuple. -- -- Forms an isomorphism with 't2Tup'. --- --- @since 0.1.1.0 tupT2 :: (a, b) -> T2 a b tupT2 (x, y) = T2 x y @@ -123,6 +124,30 @@ -- Forms an isomorphism with 't3Tup'. tupT3 :: (a, b, c) -> T3 a b c tupT3 (x, y, z) = T3 x y z + +-- | Uncurry a function to take in a 'T2' of its arguments +-- +-- @since 0.1.2.0 +uncurryT2 :: (a -> b -> c) -> T2 a b -> c +uncurryT2 f (T2 x y) = f x y + +-- | Curry a function taking a 'T2' of its arguments +-- +-- @since 0.1.2.0 +curryT2 :: (T2 a b -> c) -> a -> b -> c +curryT2 f x y = f (T2 x y) + +-- | Uncurry a function to take in a 'T3' of its arguments +-- +-- @since 0.1.2.0 +uncurryT3 :: (a -> b -> c -> d) -> T3 a b c -> d +uncurryT3 f (T3 x y z) = f x y z + +-- | Curry a function taking a 'T3' of its arguments +-- +-- @since 0.1.2.0 +curryT3 :: (T3 a b c -> d) -> a -> b -> c -> d +curryT3 f x y z = f (T3 x y z) instance Field1 (T2 a b) (T2 a' b) a a' where _1 f (T2 x y) = (`T2` y) <$> f x