diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,203 @@ +Copyright 2016 The TensorFlow Authors. All rights reserved. + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2016, The TensorFlow Authors. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/src/TensorFlow/EmbeddingOps.hs b/src/TensorFlow/EmbeddingOps.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/EmbeddingOps.hs @@ -0,0 +1,91 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +-- | Parallel lookups on the list of tensors. +module TensorFlow.EmbeddingOps where + +import Control.Monad (zipWithM) +import Data.Int (Int32, Int64) +import TensorFlow.Build (MonadBuild) +import TensorFlow.Ops (shape, vector) -- Also Num instance for Tensor +import TensorFlow.Tensor (Tensor, Value, Rendered, colocateWith, render) +import TensorFlow.Types (OneOf, TensorType) +import qualified TensorFlow.GenOps.Core as CoreOps + +-- | Looks up `ids` in a list of embedding tensors. +-- +-- This function is used to perform parallel lookups on the list of +-- tensors in `params`. It is a generalization of `TF.gather`, where +-- `params` is interpreted as a partition of a larger embedding +-- tensor. +-- +-- The partition_strategy is "mod", we assign each id to partition +-- `p = id % len(params)`. For instance, +-- 13 ids are split across 5 partitions as: +-- `[[0, 5, 10], [1, 6, 11], [2, 7, 12], [3, 8], [4, 9]]` +-- +-- The results of the lookup are concatenated into a dense +-- tensor. The returned tensor has shape `shape(ids) + shape(params)[1:]`. +embeddingLookup :: forall a b v1 v2 m . + ( MonadBuild m + , Rendered v1 + , TensorType a + , OneOf '[Int64, Int32] b + , Num b + ) + => [Tensor v1 a] + -- ^ A list of tensors which can be concatenated along + -- dimension 0. Each `Tensor` must be appropriately + -- sized for `mod` partition strategy. + -> Tensor v2 b + -- ^ A `Tensor` with type `int32` or `int64` + -- containing the ids to be looked up in `params`. + -- The ids are required to have fewer than 2^31 + -- entries. + -> m (Tensor Value a) + -- ^ A dense tensor with shape `shape(ids) + shape(params)[1:]`. +embeddingLookup [p0] ids = colocateWith p0 (render $ CoreOps.gather p0 ids) +embeddingLookup params@(p0 : _) ids = do + -- Do np separate lookups, finding embeddings for plist[p] in params[p] + partitionedResult <- zipWithM + (\p g -> colocateWith p $ render $ CoreOps.gather p g) + params gatherIds + let unshapedResult = CoreOps.dynamicStitch pindices partitionedResult + -- Shape restoration is not as optimal as it would be with client + -- side shape tracking. + paramShape <- colocateWith p0 (render (shape p0)) + let finalShape = CoreOps.concat 0 [shape ids, tailShape] + tailShape = CoreOps.slice paramShape (singleton 1) (singleton (-1)) + render $ CoreOps.reshape unshapedResult finalShape + where + -- Avoids genericLength here which would be evaluated by TF. + np = fromIntegral (length params) + flatIds = CoreOps.reshape ids (singleton (-1)) + pAssignments = CoreOps.cast (flatIds `CoreOps.mod` np) + newIds = flatIds `CoreOps.div` np + originalIndices = CoreOps.range 0 (CoreOps.size flatIds) 1 + -- Partition list of ids based on assignments into np separate lists + gatherIds = CoreOps.dynamicPartition np newIds pAssignments + -- Similarly, partition the original indices. + pindices = CoreOps.dynamicPartition np originalIndices pAssignments + singleton i = vector [i :: Int32] + +embeddingLookup [] _ = error "embeddingLookup requires params to be non empty" diff --git a/src/TensorFlow/Gradient.hs b/src/TensorFlow/Gradient.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Gradient.hs @@ -0,0 +1,756 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module TensorFlow.Gradient + ( gradients + ) where + +import Control.Monad (forM, zipWithM) +import Control.Monad.State.Strict (State, evalState, gets, modify) +import Data.ByteString (ByteString) +import Data.Complex (Complex) +import Data.Default (def) +import Data.Int (Int32, Int64) +import Data.Foldable (foldlM) +import Data.List (foldl', sortBy) +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe, maybeToList, mapMaybe) +import Data.Ord (comparing) +import Data.ProtoLens.TextFormat (showMessage) +import Data.Set (Set) +import Data.Text (Text) +import Data.Tuple (swap) +import Lens.Family2 (Lens', view, (&), (^.), (.~), (%~)) +import Lens.Family2.State.Strict (uses) +import Lens.Family2.Stock (at, intAt) +import Lens.Family2.Unchecked (lens, iso) +import Prelude hiding (sum) +import Text.Printf (printf) +import qualified Data.Graph.Inductive.Basic as FGL +import qualified Data.Graph.Inductive.Graph as FGL +import qualified Data.Graph.Inductive.PatriciaTree as FGL +import qualified Data.Graph.Inductive.Query.DFS as FGL +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as Text + +import qualified TensorFlow.GenOps.Core as CoreOps +import TensorFlow.Build + ( MonadBuild + , Build + , build + , renderedNodeDefs + , opDef + , opAttr + , opInputs + ) +import TensorFlow.BuildOp +import TensorFlow.Ops + ( addN + , broadcastGradientArgs + , expandDims + , fill + , matMul + , matMul' + , reducedShape + , reluGrad + , reshape + , scalar + , shape + , softmaxCrossEntropyWithLogits + , sum + , scalarize + , vector + , zerosLike + ) +import TensorFlow.Output + ( NodeName(..) + , Output(..) + , OutputIx(..) + , outputIndex + ) +import TensorFlow.Tensor + ( Tensor(..) + , Value + , render + , expr + , Rendered + , tensorNodeName + , renderedOutput + , renderValue + ) +import TensorFlow.Types (Attribute, OneOf, TensorType, attrLens) +import Proto.Tensorflow.Core.Framework.NodeDef + (NodeDef, attr, input, op, name) + +type GradientCompatible a = + -- TODO(fmayle): MaxPoolGrad doesn't support Double for some reason. + (Num a, OneOf '[ Float, Complex Float, Complex Double ] a) + +-- TODO(fmayle): Support control flow. +-- TODO(fmayle): Support gate_gradients-like option to avoid race conditions. +-- TODO(fmayle): Do we need to consider control inputs? See _PendingCount in +-- tensorflow/python/ops/gradients.py. +-- TODO(fmayle): Maybe store the gradient functions and numOutputs on the OpDef. + + +-- | Gradient of @y@ w.r.t. each element of @xs@. +gradients :: forall a v1 v2 m . (MonadBuild m + , Rendered v2 + , GradientCompatible a + ) + => Tensor v1 a -- ^ The output of the graph. + -> [Tensor v2 a] -- ^ Tensors for which gradients are computed. + -> m [Tensor Value a] +gradients y xs = build $ do + -- The gradients are computed using "reverse accumulation", similarly to + -- what is described here: + -- https://en.wikipedia.org/wiki/Automatic_differentiation#The_chain_rule.2C_forward_and_reverse_accumulation + -- + -- The code is summarised as follows: + -- + -- 1. Create an fgl graph of the relevant nodes (ops) and edges (tensors). + -- 2. Initialize the gradient of y to 1 (∂y/∂y = 1) and the rest of tensor's + -- gradients to nothing. + -- 3. Process the nodes in reverse topological order (i.e. each node comes + -- after all of its outputs so that the output gradients for a node have + -- been completely calculated before it is processed): + -- a. Record the gradient for each of the node's output tensors (∂y/∂w + -- for each output tensor w). + -- b. Calculate the gradient of y w.r.t. each of the node's input + -- tensors using the gradients of the node's output tensors. + -- + -- Written differently, for each output tensor w and input tensor v: + -- ∂y/∂w = ... (calculated in previous steps) + -- ∂w/∂v = ... (op specific) + -- ∂y/∂v = ∂y/∂w * ∂w/∂v (technically, if tensor v is an input + -- to multiple nodes, then this is only + -- part of ∂y/∂v) + -- + -- 4. Lookup the recorded gradient for each x in xs. + + y' <- renderValue y + let yName = tensorNodeName y' + yOne <- render $ fill (shape y') (scalar 1) + -- TODO(fmayle): Move this into Build.hs and call it unsafeNodeDefFromName? + nodeDefLookup :: (NodeName -> NodeDef) <- uses renderedNodeDefs $ + (\f x -> fromMaybe (error $ "no NodeDef found for " ++ show x) (f x)) + . flip Map.lookup + let (gr, nodeMap) = createGraph yName nodeDefLookup + -- Set gradient of y to one. + -- TODO: nicer + let initPending :: Map.Map FGL.Node (PendingGradients a) + = Map.empty & (at (nodeMap Map.! yName) + . nonEmpty + . outputIxAt (outputIndex $ renderedOutput y') + . nonEmpty + .~ [yOne] + ) + -- Calculate the gradients of y w.r.t. each node in the graph. + gradientMap <- graphGrads gr initPending + -- Lookup the gradients for each x. + forM xs $ \x -> + let xName = tensorNodeName x + in maybe (render $ zerosLike x) return $ do + n <- nodeMap ^. at xName + let i = outputIndex $ renderedOutput x + gradientMap ^. at n . nonEmpty . outputIxAt i + +outputIxAt :: OutputIx -> Lens' (IntMap.IntMap v) (Maybe v) +outputIxAt = intAt . unOutputIx + +-- | Incomplete gradients of a node's outputs. +-- +-- The lists represent partial sums. The key is an OutputIx sans newtype. +type PendingGradients a = IntMap.IntMap [Tensor Value a] + +-- | Gradients of a node's outputs. The key is an OutputIx sans newtype. +-- TODO: precache the rendering? +type Gradients a = IntMap.IntMap (Tensor Value a) + +-- | Graph of TensorFlow operations. +type Graph = FGL.Gr NodeDef EdgeLabel + +-- | Data associated with an edge. +-- +-- Pair of +-- 1. Output index of a tensor from the source node. +-- 2. Input index that the tensor connects to on the destination node. +type EdgeLabel = (OutputIx, OutputIx) + + +-- | State used for calculating gradients. +data GradientsState a = GradientsState + { _gradientsPending :: !(Map FGL.Node (PendingGradients a)) + , _gradientsResult :: !(Map FGL.Node (Gradients a)) + } + +gradientsPending :: Lens' (GradientsState a) (Map FGL.Node (PendingGradients a)) +gradientsPending = lens _gradientsPending (\x y -> x { _gradientsPending = y }) + +gradientsResult :: Lens' (GradientsState a) (Map FGL.Node (Gradients a)) +gradientsResult = lens _gradientsResult (\x y -> x { _gradientsResult = y }) + + +-- TODO(fmayle): Use something like Data.List.Safe. +-- | Safe version of (!!). +safeIndex :: [a] -> Int -> Maybe a +_ `safeIndex` n | n < 0 = Nothing +[] `safeIndex` _ = Nothing +(x:_) `safeIndex` 0 = Just x +(_:xs) `safeIndex` n = xs `safeIndex` (n-1) + +-- Copy of http://hackage.haskell.org/package/lens-3.9.0.2/docs/Control-Lens-Iso.html#v%3anon +anon :: a -> (a -> Bool) -> Lens' (Maybe a) a +anon a p = iso (fromMaybe a) go where + go b | p b = Nothing + | otherwise = Just b + +non :: Eq a => a -> Lens' (Maybe a) a +non a = anon a (a==) + +-- | Lens that defaults Nothing to mempty. +nonEmpty :: (Monoid (t v), Foldable t) => Lens' (Maybe (t v)) (t v) +nonEmpty = anon mempty null + +-- TODO: strictness (e.g., foldlM') + +-- | Calculate the gradients for every node in a graph. +graphGrads :: forall a. GradientCompatible a + => Graph + -> Map FGL.Node (PendingGradients a) + -- ^ Initial gradients (usually just 1 for the node of interest). + -> Build (Map FGL.Node (Gradients a)) +graphGrads gr initPending = view gradientsResult <$> foldlM go initState nodeOrder + where + initState = GradientsState initPending Map.empty + -- Reverse topological sort. + -- TODO(fmayle): Filter out nodes that are not successors of any x in xs to + -- avoid calculating gradients that won't be used. + nodeOrder = FGL.topsort $ FGL.grev gr + go :: GradientsState a -> Int -> Build (GradientsState a) + go state node = do + -- Aggregate the accumulated gradients for this node. + outputGrads <- + sumPendingGradient (state ^. gradientsPending . at node . nonEmpty) + if null outputGrads + then pure state + else do + let ctx = FGL.context gr node + inputGrads <- calculateInputGrads ctx outputGrads gr + -- Calculate the gradients for each of the node's inputs. + let nextState = state & gradientsResult %~ Map.insert node outputGrads + pure $ updatePendingGradients ctx inputGrads nextState + +-- | Reduce accumulated gradients for each output to one Tensor. +sumPendingGradient :: GradientCompatible a + => PendingGradients a -> Build (Gradients a) +sumPendingGradient = sequence . IntMap.mapMaybe f + where + f [] = Nothing + f [x] = Just (pure x) + f xs = Just (render $ addN xs) + + +-- | Calculate the gradients of a node's input tensors. +-- +-- This is mostly just a wrapper around opGrad. +calculateInputGrads :: forall a. GradientCompatible a + => FGL.Context NodeDef EdgeLabel + -> Gradients a -- ^ Output gradients of the node. + -> Graph + -> Build [Maybe (Tensor Value a)] +calculateInputGrads (inputEdges, _, nodeDef, _) outputGrads gr = do + fullOutGrads <- fullOutputGrads (numOutputs nodeDef) (nodeDefName nodeDef) + outputGrads + traverse (traverse render) $ opGrad (nodeDef ^. op) nodeDef inputTensors fullOutGrads + where + -- Create a tensor from an edge (technically an Output, but it seems less + -- confusing to refer to it as a tensor here). + edgeToTensor :: (EdgeLabel, FGL.Node) -> Output + edgeToTensor ((i, _), n) = + case FGL.lab gr n of + Just edgeNodeDef -> Output i (NodeName $ edgeNodeDef ^. name) + Nothing -> error $ "calculateInputGrads: missing input node for " + ++ Text.unpack (nodeDef ^. name) + -- Input tensors, sorted by input index. + inputTensors = map edgeToTensor $ sortBy (comparing (snd . fst)) inputEdges + +-- | Convert a Map of gradients to a list, with zeros for missing outputs. +fullOutputGrads :: (TensorType a, Num a) + => OutputIx -- ^ Number of outputs. + -> NodeName + -> Gradients a + -> Build [Tensor Value a] +fullOutputGrads n o gs = + mapM (\i -> maybe (render $ zero i) return (gs ^. outputIxAt i)) [0..n-1] + where + -- A tensor of zeros with the same shape as the i'th output. + zero i = zerosLike $ toT (Output i o) + + +-- | Update the pending gradients of a node's inputs. +updatePendingGradients :: forall a. (TensorType a, Num a) + => FGL.Context NodeDef EdgeLabel + -> [Maybe (Tensor Value a)] + -- ^ Gradient of each input tensor. + -> GradientsState a + -> GradientsState a +updatePendingGradients (inputEdges, _, nodeDef, _) inputGrads initState = + foldl' go initState inputEdges + where + go :: GradientsState a -> (EdgeLabel, FGL.Node) -> GradientsState a + go state ((outIndex, OutputIx inIndex), node) = + case maybeGradient of + Nothing -> state + Just g -> + -- Add to the list of pending gradients for this tensor. + state & gradientsPending + . at node + . nonEmpty + . outputIxAt outIndex + . nonEmpty + %~ (g:) + where + badSizeErr = error $ printf "updatePendingGradients: bad input index \ + \%d for inputGrads of length %d in %s" + inIndex (length inputGrads) + (show (nodeDef ^. name)) + maybeGradient = fromMaybe badSizeErr (safeIndex inputGrads inIndex) + + +-- | Create a graph that includes a node and its transitive dependencies. +createGraph :: NodeName -> (NodeName -> NodeDef) + -> (Graph, Map NodeName FGL.Node) +createGraph nodeName nodeDefLookup = (FGL.nmap nodeDefLookup graph, nodeMap) + where + -- Parse a tensor name. + parseTensorName :: Text -> Maybe (NodeName, OutputIx) + parseTensorName n + | Text.null n = error "parseTensorName: empty name" + | Text.head n == '^' = Nothing -- Control edge + | otherwise = + let (nm, indexStr) = Text.breakOn ":" n + index | Text.null indexStr = 0 + | otherwise = read $ Text.unpack $ Text.tail indexStr + in Just (NodeName nm, OutputIx index) + + -- Build a map from node name to outward edges. + -- + -- The state is the set of visited nodes. + collect :: Maybe (NodeName, OutputIx, OutputIx) + -> NodeName + -> State (Set NodeName) + (Map NodeName [(NodeName, OutputIx, OutputIx)]) + collect outgoingEdge nm = do + let nextLookup = Map.singleton nm (maybeToList outgoingEdge) + seen <- gets (Set.member nm) + modify (Set.insert nm) + if seen + then pure nextLookup + else do + let inputs = nodeDefLookup nm ^. input + recurse inIndex (parentName, outIndex) = + collect (Just (nm, outIndex, inIndex)) parentName + subEdgeLookups <- + zipWithM recurse [0..] $ mapMaybe parseTensorName inputs + pure $ Map.unionsWith (++) (nextLookup:subEdgeLookups) + + edgeLookup = evalState (collect Nothing nodeName) Set.empty + -- Associate an ID with each node name. + nodeMap = Map.fromList $ zip (Map.keys edgeLookup) [0..] + -- Create the graph. + graph = FGL.mkGraph (swap <$> Map.toList nodeMap) + [ (nodeMap Map.! n, nodeMap Map.! m, (i, j)) + | (n, edges) <- Map.toList edgeLookup + , (m, i, j) <- edges + ] + +-- | Function to compute the gradient of y w.r.t. each input. +-- +-- Let y be an arbitrary tensor +-- and [w_0, ..., w_n] be the output tensors of a node +-- and [v_0, ..., v_n] be the input tensors of the same node. +-- +-- Given [∂y/∂w_0, ..., ∂y/∂w_n] and [v_0, ..., v_n], a GradientFunc computes +-- [∂y/∂v_0, ..., ∂y/∂v_n] for a particular op type. +-- +-- A Nothing gradient is equivalent to zero (but allows for short circuiting +-- computation when all the gradients for something are Nothing). +type GradientFunc a = NodeDef + -> [Output] + -- ^ Input tensors. + -> [Tensor Value a] + -- ^ Gradient of y w.r.t. each output tensor. + -> [Maybe (Tensor Build a)] + -- ^ Gradient of y w.r.t. each input tensor. + + +-- TODO(fmayle): Assert the type is correct. +-- | Create a Tensor from an Output. +toT :: Output -> Tensor Build a +toT = Tensor . pure + + +-- | Wrapper around `TensorFlow.GenOps.Core.slice` that builds vectors from scalars for +-- simple slicing operations. +flatSlice :: forall v1 t . TensorType t + => Tensor v1 t -- ^ __input__ + -> Int32 -- ^ __begin__: specifies the offset into the first dimension of + -- 'input' to slice from. + -> Int32 -- ^ __size__: specifies the number of elements of the first dimension + -- of 'input' to slice. If size is -1, all remaining elements in the dimension + -- are included in the slice (i.e. this is equivalent to setting + -- size = input.dim_size(0) - begin). + -> Tensor Build t -- ^ __output__ +flatSlice t begin size = CoreOps.slice t (vector [begin]) (vector [size]) + +nodeDefName :: NodeDef -> NodeName +nodeDefName = NodeName . view name + + +-- | The gradient function for an op type. +-- +-- These implementations should match their python counterparts in: +-- third_party/tensorflow/python/ops/*_grad.py +opGrad :: forall a . GradientCompatible a => Text -> GradientFunc a + +opGrad "Abs" _ [toT -> x] [dz] = [Just $ expr dz * signum x] +opGrad "Neg" _ [_] [dz] = [Just $ negate $ expr dz] +opGrad "Relu" _ [toT -> x] [dz] = [Just $ reluGrad dz x] +opGrad "ReluGrad" _ [_, toT -> x ] [dz] = [Just $ reluGrad dz x, Just $ CoreOps.zerosLike x] + +opGrad "Square" _ [toT -> x] [dz] = + -- TODO(fmayle): Handle complex numbers. + -- TODO(fmayle): The python code makes dz a control dependency of the 2*x + -- (for performance reasons?). Will need to put these functions in the Build + -- monad to replicate that. + [Just $ dz `CoreOps.mul` (2 * x)] + +opGrad "Gather" _ [toT -> x, toT -> indices] [dz] = + -- TODO(fmayle): The python version uses a better performance implementation + -- when the shape is known without having to run the graph. + -- TODO(fmayle): We shouldn't convert the result to a dense tensor. Sparse + -- tensor support will require some thinking. + [ Just $ CoreOps.unsortedSegmentSum values indices' numRows + , Nothing + ] + where + -- TODO(gnezdo): Use colocateWith but it requires Build monad. + denseShape = shape (x :: Tensor Build a) + numRows = scalarize $ flatSlice denseShape 0 1 + valuesShape = CoreOps.concat 0 [ allDimensions + , flatSlice denseShape 1 (-1) + ] + values = reshape dz valuesShape + -- TODO(fmayle): This could be either Int32 or Int64. + indices' = reshape indices allDimensions :: Tensor Build Int32 + +opGrad "Max" _ [toT -> x, toT -> indices] [dz] = + [Just $ indicators `CoreOps.div` numSelected * dz', Nothing] + where + sx = shape (x :: Tensor Build a) + outputShapeKeptDims = reducedShape sx (indices :: Tensor Build Int32) + y = CoreOps.max x indices + y' = reshape y outputShapeKeptDims + dz' = reshape dz outputShapeKeptDims + indicators = CoreOps.cast $ CoreOps.equal y' x + numSelected = reshape (sum indicators indices) outputShapeKeptDims + +-- Min and Max have identical gradient implementations. +opGrad "Min" u v w = opGrad "Max" u v w + +opGrad "Sum" _ [toT -> x, toT -> indices] [dz] = + [ Just $ CoreOps.tile grad tileScaling, Nothing ] + where + -- TODO(gnezdo): Implement the fast-path from math_grad._SumGrad. + sx = shape (x :: Tensor Build a) + outputShapeKeptDims = reducedShape sx (indices :: Tensor Build Int32) + tileScaling = safeShapeDiv sx outputShapeKeptDims + grad = reshape dz outputShapeKeptDims + +opGrad "Mean" u v@[toT -> x, _] w = + [Just $ dz `CoreOps.div` CoreOps.cast factor, Nothing] + where + [Just dz, Nothing] = opGrad "Sum" u v w + inputShape = shape (x :: Tensor Build a) + outputShape = shape (dz :: Tensor Build a) + -- TODO(fmayle): Add fast path when shape is known. + inputSize = CoreOps.prod inputShape $ rangeOfRank inputShape + outputSize = CoreOps.prod outputShape $ rangeOfRank outputShape + factor = safeShapeDiv inputSize outputSize + +opGrad "Add" _ [toT -> x, toT -> y] [dz] = + [ Just $ reshape (sum dz rx) sx + , Just $ reshape (sum dz ry) sy ] + where + sx = shape (x :: Tensor Build a) + sy = shape (y :: Tensor Build a) + (rx, ry) = broadcastGradientArgs sx sy + +opGrad "Sub" u v w = + [Just x, Just (-y)] + where + [Just x, Just y] = opGrad "Add" u v w + +opGrad "SoftmaxCrossEntropyWithLogits" _ [toT -> x, toT -> y] [dz, _] = + [ Just $ expandDims dz (-1) * snd (softmaxCrossEntropyWithLogits x y) + , Nothing ] + +opGrad "Mul" _ [toT -> x, toT -> y] [dz] = + -- TODO(fmayle): Handle complex numbers. + [ Just $ reshape (sum (dz `CoreOps.mul` y) rx) sx + , Just $ reshape (sum (x `CoreOps.mul` dz) ry) sy ] + where + sx = shape (x :: Tensor Build a) + sy = shape (y :: Tensor Build a) + (rx, ry) = broadcastGradientArgs sx sy + +opGrad "Div" _ [toT -> x, toT -> y] [dz] = + -- TODO(fmayle): Handle complex numbers. + -- TODO(gnezdo): Provide Fractional instance and use '/' instead of div. + [ Just $ reshape (sum (dz `CoreOps.div` y) rx) sx + , Just $ reshape (sum (dz `CoreOps.mul` (negate x `CoreOps.div` (y * y))) + ry) + sy + ] + where + sx = shape (x :: Tensor Build a) + sy = shape (y :: Tensor Build a) + (rx, ry) = broadcastGradientArgs sx sy + +opGrad "MatMul" nodeDef [toT -> x, toT -> y] [dz] = + let transposeA = lookupAttr nodeDef "transpose_a" + transposeB = lookupAttr nodeDef "transpose_b" + transAttrs a b = + (opAttr "transpose_a" .~ a) . (opAttr "transpose_b" .~ b) + in case (transposeA, transposeB) of + (False, False) -> + [ Just $ matMul' (transAttrs False True) dz y + , Just $ matMul' (transAttrs True False) x dz] + (False, True) -> + [ Just $ matMul dz y + , Just $ matMul' (transAttrs True False) dz x] + (True, False) -> + [ Just $ matMul' (transAttrs False True) y dz + , Just $ matMul x dz] + (True, True) -> + [ Just $ matMul' (transAttrs True True) y dz + , Just $ matMul' (transAttrs True True) dz x] + +opGrad "Transpose" _ [_, toT -> p] [dz] = + [ Just $ CoreOps.transpose dz + (CoreOps.invertPermutation p :: Tensor Build Int32) + , Nothing + ] + +opGrad "Conv2D" nodeDef [toT -> x, toT -> y] [dz] = + [ Just $ CoreOps.conv2DBackpropInput' + ((opAttr "strides" .~ strides) + . (opAttr "padding" .~ padding) + . (opAttr "use_cudnn_on_gpu" .~ useCudnnOnGpu) + . (opAttr "data_format" .~ dataFormat)) + (shape x) y dz + , Just $ CoreOps.conv2DBackpropFilter' + ((opAttr "strides" .~ strides) + . (opAttr "padding" .~ padding) + . (opAttr "use_cudnn_on_gpu" .~ useCudnnOnGpu) + . (opAttr "data_format" .~ dataFormat)) + x (shape y) dz + ] + where + strides = lookupAttr nodeDef "strides" :: [Int64] + padding = lookupAttr nodeDef "padding" :: ByteString + useCudnnOnGpu = lookupAttr nodeDef "use_cudnn_on_gpu" :: Bool + dataFormat = lookupAttr nodeDef "data_format" :: ByteString + +opGrad "MaxPool" nodeDef [toT -> x] [dz] = + [ Just $ CoreOps.maxPoolGrad' + ((opAttr "ksize" .~ ksize) + . (opAttr "strides" .~ strides) + . (opAttr "padding" .~ padding) + . (opAttr "data_format" .~ dataFormat)) + x output dz + ] + where + output :: Tensor Build a + output = toT $ Output 0 (nodeDefName nodeDef) + ksize = lookupAttr nodeDef "ksize" :: [Int64] + strides = lookupAttr nodeDef "strides" :: [Int64] + padding = lookupAttr nodeDef "padding" :: ByteString + dataFormat = lookupAttr nodeDef "data_format" :: ByteString + +opGrad "Reshape" _ [toT -> x, _] [dz] = + [Just $ reshape dz $ shape (x :: Tensor Build a), Nothing] + +opGrad "OneHot" _ _ _ = [Nothing, Nothing, Nothing, Nothing] +opGrad "TruncatedNormal" _ _ _ = [Nothing] + +opGrad "RefIdentity" _ _ [dz] = [Just $ expr dz] +opGrad "Cast" nodeDef _ [dz] = [Just reverseCast] + where + -- TODO(gnezdo): too permissive, python only allows float types as src_type. + reverseCast = + pureOp [] $ pure (opDef "Cast" + & opAttr "DstT" .~ (lookupAttr nodeDef "SrcT" :: ByteString) + & opAttr "SrcT" .~ (lookupAttr nodeDef "DstT" :: ByteString) + & opInputs .~ [renderedOutput dz]) + +opGrad "DynamicStitch" nodeDef inputs [dz] = + replicate halfLen Nothing ++ valuesGrads + where + halfLen = + let len = length inputs + half = len `div` 2 + in if 2 * half == len + then half + else error ("Uneven input size " ++ show (len, showMessage nodeDef)) + valuesGrads = [ Just $ CoreOps.gather dz (toT idx :: Tensor Build Int32) + | idx <- take halfLen inputs + ] + +opGrad "DynamicPartition" nodeDef [toT -> xs, toT -> indices] dz = + [ Just reconstructed, Nothing ] + where + reconstructed = CoreOps.reshape stitched + (CoreOps.shape (xs :: Tensor Build a) :: Tensor Build Int32) + stitched = CoreOps.dynamicStitch partitionedIndices dz + partitionedIndices = CoreOps.dynamicPartition np originalIndices indices + np = lookupAttr nodeDef "num_partitions" :: Int64 + originalIndices = + CoreOps.reshape (CoreOps.range 0 (CoreOps.size indices) 1) prefixShape + prefixShape = shapeInt32 indices + shapeInt32 t = CoreOps.shape t :: Tensor Build Int32 + +opGrad "Select" _ [toT -> c, toT -> x, _] [dz] = + [ Nothing + , Just $ CoreOps.select c dz zeros + , Just $ CoreOps.select c zeros dz + ] + where zeros = CoreOps.zerosLike x + +-- TODO(gnezdo): Unlike Python, no control dependency on dz. +opGrad "Log" _ [toT -> x] [dz] = [ Just $ dz `CoreOps.mul` CoreOps.inv x ] +-- TODO(gnezdo): Reuse the output instead of doing another exp, +-- though, it is probably CSE'd away anyway. +opGrad "Exp" _ [toT -> x] [dz] = [ Just $ dz `CoreOps.mul` CoreOps.exp x ] +opGrad "SparseSegmentSum" _ [toT -> x, toT -> y, toT -> t] [dz] = + [ Just $ CoreOps.unsortedSegmentSum + (CoreOps.gather dz (t :: Tensor Build Int32)) + (y :: Tensor Build Int32) inputRows + , Nothing + , Nothing + ] + where inputRows = flatSlice (shape (x :: Tensor Build a)) 0 1 + +opGrad "LabelClasses" _ _ _ = [Nothing, Nothing] +opGrad "LabelWeights" _ _ _ = [Nothing] +opGrad "Size" _ _ _ = [Nothing] + +-- TODO (jcberentsen): Python implementation uses set_shape for +-- static shape inference, which is unsupported. +-- TODO: implement support for static shape inference +opGrad "Tile" _ [toT -> x, toT -> multiples] [dz] = + [Just inputGrad, Nothing] + where + inputGrad = sum reshapedDz axes + inputShape = shape (x :: Tensor Build a) + packed = CoreOps.pack [multiples, inputShape] + perm = vector [1, 0 :: Int32] + splitShape = CoreOps.reshape (CoreOps.transpose packed perm) allDimensions + axes = CoreOps.range 0 (CoreOps.size splitShape) (2 :: Tensor Build Int32) + reshapedDz = CoreOps.reshape dz splitShape + +opGrad "ZerosLike" _ _ _ = [Nothing] +opGrad "Fill" _ _ [dz] = [Nothing, Just $ sum dz rx] + where + rx = rangeOfRank dz + +-- TODO(fmayle): These can go away if we properly prune the graph. +opGrad "Const" _ _ _ = [Nothing, Nothing] +opGrad "Placeholder" _ _ _ = [] +opGrad "Variable" _ _ _ = [] + +opGrad n nodeDef ins grads = + error $ "no gradient implemented for " ++ + show (n, length ins, length grads, showMessage nodeDef, ins) + +-- | The number of outputs for an op type. +numOutputs :: NodeDef -> OutputIx +numOutputs o = + case o ^. op of + "Abs" -> 1 + "Add" -> 1 + "Cast" -> 1 + "Const" -> 1 + "Conv2D" -> 1 + "Div" -> 1 + "DynamicStitch" -> 1 + "DynamicPartition" -> + fromIntegral (lookupAttr o "num_partitions" :: Int64) + "Exp" -> 1 + "Gather" -> 1 + "LabelClasses" -> 1 + "LabelWeights" -> 1 + "Log" -> 1 + "MatMul" -> 1 + "Max" -> 1 + "MaxPool" -> 1 + "Mean" -> 1 + "Min" -> 1 + "Mul" -> 1 + "Neg" -> 1 + "Placeholder" -> 1 + "OneHot" -> 1 + "RefIdentity" -> 1 + "Relu" -> 1 + "ReluGrad" -> 1 + "Reshape" -> 1 + "Select" -> 1 + "Size" -> 1 + "SoftmaxCrossEntropyWithLogits" -> 2 + "Square" -> 1 + "SparseSegmentSum" -> 1 + "Sub" -> 1 + "Sum" -> 1 + "Tile" -> 1 + "Transpose" -> 1 + "TruncatedNormal" -> 1 + "Variable" -> 1 + "ZerosLike" -> 1 + "Fill" -> 1 + _ -> error $ "numOuputs not implemented for " ++ show (o ^. op) + +-- Divides `x / y` assuming `x, y >= 0`, treating `0 / 0 = 0` +safeShapeDiv :: Tensor v1 Int32 -> Tensor v2 Int32 -> Tensor Build Int32 +safeShapeDiv x y = x `CoreOps.div` (CoreOps.maximum y 1) + +allDimensions :: Tensor Build Int32 +allDimensions = vector [-1 :: Int32] + +rangeOfRank :: forall v1 t. TensorType t => Tensor v1 t -> Tensor Build Int32 +rangeOfRank x = CoreOps.range 0 (CoreOps.rank x) 1 + +lookupAttr :: Attribute a1 => NodeDef -> Text -> a1 +lookupAttr nodeDef attrName = nodeDef ^. attr . at attrName . non def . attrLens diff --git a/src/TensorFlow/NN.hs b/src/TensorFlow/NN.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/NN.hs @@ -0,0 +1,88 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module TensorFlow.NN + ( sigmoidCrossEntropyWithLogits + ) where + +import Prelude hiding ( log + , exp + ) +import TensorFlow.Build ( MonadBuild + , withNameScope + ) +import TensorFlow.GenOps.Core ( greaterEqual + , select + , log + , exp + ) +import TensorFlow.Tensor ( Tensor(..) + , render + , Value + ) +import TensorFlow.Types ( TensorType(..) + , OneOf + ) +import TensorFlow.Ops ( zerosLike + , add + , mul + , neg + ) + +-- | Computes sigmoid cross entropy given `logits`. +-- +-- Measures the probability error in discrete classification tasks in which each +-- class is independent and not mutually exclusive. For instance, one could +-- perform multilabel classification where a picture can contain both an elephant +-- and a dog at the same time. +-- +-- For brevity, let `x = logits`, `z = targets`. The logistic loss is +-- +-- z * -log(sigmoid(x)) + (1 - z) * -log(1 - sigmoid(x)) +-- = z * -log(1 / (1 + exp(-x))) + (1 - z) * -log(exp(-x) / (1 + exp(-x))) +-- = z * log(1 + exp(-x)) + (1 - z) * (-log(exp(-x)) + log(1 + exp(-x))) +-- = z * log(1 + exp(-x)) + (1 - z) * (x + log(1 + exp(-x)) +-- = (1 - z) * x + log(1 + exp(-x)) +-- = x - x * z + log(1 + exp(-x)) +-- +-- For x < 0, to avoid overflow in exp(-x), we reformulate the above +-- +-- x - x * z + log(1 + exp(-x)) +-- = log(exp(x)) - x * z + log(1 + exp(-x)) +-- = - x * z + log(1 + exp(x)) +-- +-- Hence, to ensure stability and avoid overflow, the implementation uses this +-- equivalent formulation +-- +-- max(x, 0) - x * z + log(1 + exp(-abs(x))) +-- +-- `logits` and `targets` must have the same type and shape. +sigmoidCrossEntropyWithLogits + :: (MonadBuild m, OneOf '[Float, Double] a, TensorType a, Num a) + => Tensor Value a -- ^ __logits__ + -> Tensor Value a -- ^ __targets__ + -> m (Tensor Value a) +sigmoidCrossEntropyWithLogits logits targets = do + let zeros = zerosLike logits + cond = logits `greaterEqual` zeros + relu_logits = select cond logits zeros + neg_abs_logits = select cond (neg logits) logits + withNameScope "logistic_loss" $ do + left <- render $ relu_logits - logits `mul` targets + right <- render $ log (1 + exp neg_abs_logits) + withNameScope "sigmoid_add" $ render $ left `add` right diff --git a/src/TensorFlow/Ops.hs b/src/TensorFlow/Ops.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Ops.hs @@ -0,0 +1,389 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +-- | This module contains definitions for some built-in TensorFlow operations. +-- +-- Note that certain, "stateful" ops like 'variable' and 'assign' return a +-- 'Build' action (e.g., @Build (Tensor Ref a)@ instead of a pure value; the +-- returned 'Tensor's are always rendered in the current 'Build' context. This +-- approach helps us avoid problems with inlining or common subexpression +-- elimination, by writing +-- +-- > do +-- > v <- variable [] +-- > w <- assign v 3 +-- > render $ w * w +-- +-- instead of +-- +-- > let +-- > v = variable [] +-- > w = assign v 3 +-- > in w * w +-- +-- since the latter could be reasonably transformed by the compiler into (or +-- vice versa) +-- +-- > let +-- > v = variable [] +-- > w = assign v 3 +-- > w' = assign v 3 +-- > in w * w' +-- +-- Ops should return a 'Build' action if their original 'OpDef' marks them as +-- stateful, or if they take any Refs as input. (This mirrors the rules that +-- TensorFlow uses to avoid common subexpression elimination.) +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module TensorFlow.Ops + ( CoreOps.add + , CoreOps.add' + , CoreOps.abs + , CoreOps.abs' + , CoreOps.addN + , CoreOps.addN' + , CoreOps.argMax + , CoreOps.argMax' + , CoreOps.assign + , CoreOps.assign' + , CoreOps.broadcastGradientArgs + , CoreOps.broadcastGradientArgs' + , CoreOps.cast + , CoreOps.cast' + , CoreOps.concat + , CoreOps.concat' + , constant + , constant' + , CoreOps.equal + , CoreOps.equal' + , expandDims + , expandDims' + , initializedVariable + , initializedVariable' + , zeroInitializedVariable + , zeroInitializedVariable' + , CoreOps.fill + , CoreOps.fill' + , CoreOps.identity + , CoreOps.identity' + , CoreOps.matMul + , CoreOps.matMul' + , matTranspose + , matTranspose' + , CoreOps.mean + , CoreOps.mean' + , CoreOps.mul + , CoreOps.mul' + , CoreOps.neg + , CoreOps.neg' + , CoreOps.oneHot + , CoreOps.oneHot' + , CoreOps.pack + , CoreOps.pack' + , placeholder + , placeholder' + , CoreOps.range + , CoreOps.range' + , reducedShape + , CoreOps.relu + , CoreOps.relu' + , CoreOps.reluGrad + , CoreOps.reluGrad' + , CoreOps.reshape + , CoreOps.reshape' + , restore + , restoreFromName + , save + , scalar + , scalar' + , shape + , shape' + , CoreOps.sign + , CoreOps.sign' + , CoreOps.size + , CoreOps.size' + , CoreOps.softmax + , CoreOps.softmax' + , CoreOps.softmaxCrossEntropyWithLogits + , CoreOps.softmaxCrossEntropyWithLogits' + , CoreOps.sparseToDense + , CoreOps.sparseToDense' + , CoreOps.sub + , CoreOps.sub' + , CoreOps.sum + , CoreOps.sum' + , reduceSum + , reduceSum' + , CoreOps.transpose + , CoreOps.transpose' + , truncatedNormal + , truncatedNormal' + , CoreOps.variable + , CoreOps.variable' + , vector + , vector' + , zeros + , CoreOps.zerosLike + , CoreOps.zerosLike' + , scalarize + ) where + +import Data.ByteString (ByteString) +import Data.Complex (Complex) +import Data.Int (Int32, Int64) +import Data.Word (Word16) +import Prelude hiding (abs, sum, concat) +import Data.ProtoLens (def) +import Data.Text.Encoding (encodeUtf8) +import Lens.Family2 ((.~), (&)) +import Text.Printf (printf) +import Proto.Tensorflow.Core.Framework.Tensor + ( TensorProto + , dtype + , tensorShape + ) +import qualified Proto.Tensorflow.Core.Framework.TensorShape + as TensorShape +import TensorFlow.Build +import TensorFlow.BuildOp +import TensorFlow.ControlFlow (group) +import TensorFlow.Tensor +import TensorFlow.Types + +import qualified TensorFlow.GenOps.Core as CoreOps + +import qualified Prelude (abs) + +-- TODO: Look into hs-boot refactoring to allow mutually recursive imports. +-- | Must be defined as an orphan because of the dependency order between Ops +-- and Tensor. +-- +-- The indirect constraint "v ~ Value" helps disambiguate types, for example in +-- "neg 1 :: Tensor Value Float", it helps find the type of the subexpression +-- "1". +instance ( TensorType a + , Num a + , v ~ Build + , OneOf '[ Double, Float, Int32, Int64 + , Complex Float, Complex Double] a) => Num (Tensor v a) where + (+) = CoreOps.add + (*) = CoreOps.mul + (-) = CoreOps.sub + abs = CoreOps.abs + fromInteger = scalar . fromInteger + signum = CoreOps.sign + negate = CoreOps.neg + +matTranspose :: TensorType a => Tensor e a -> Tensor Build a +matTranspose = matTranspose' id + +matTranspose' :: TensorType a => OpParams -> Tensor v a -> Tensor Build a +matTranspose' params = flip (CoreOps.transpose' params) (vector [1, 0 :: Int32]) + +placeholder :: (MonadBuild m, TensorType a) => Shape -> m (Tensor Value a) +placeholder = placeholder' id + +placeholder' :: forall m a . (MonadBuild m, TensorType a) + => OpParams -> Shape -> m (Tensor Value a) +placeholder' params pShape + -- Note: we don't use CoreOps.placeholder' since that op isn't stateful, + -- and thus would be CSE'd. + = build $ buildOp [] $ opDef "Placeholder" + & opAttr "dtype" .~ tensorType (undefined :: a) + & opAttr "shape" .~ pShape + & params + +-- | Creates a variable initialized to the given value. +-- Initialization happens next time session runs. +initializedVariable :: (MonadBuild m, TensorType a) + => Tensor v a -> m (Tensor Ref a) +initializedVariable = initializedVariable' id + +initializedVariable' :: (MonadBuild m, TensorType a) + => OpParams -> Tensor v a -> m (Tensor Ref a) +initializedVariable' params initializer = do + v <- CoreOps.variable' params [] -- The shape is not known initially. + i <- CoreOps.assign' (opAttr "validate_shape" .~ False) v + initializer + addInitializer =<< group i + return v + +-- | Creates a zero-initialized variable with the given shape. +zeroInitializedVariable + :: (MonadBuild m, TensorType a, Num a) => + TensorFlow.Types.Shape -> m (Tensor TensorFlow.Tensor.Ref a) +zeroInitializedVariable = zeroInitializedVariable' id + +zeroInitializedVariable' + :: (MonadBuild m, TensorType a, Num a) => + OpParams -> TensorFlow.Types.Shape -> m (Tensor TensorFlow.Tensor.Ref a) +zeroInitializedVariable' params = initializedVariable' params . zeros + +-- TODO: Support heterogeneous list of tensors. +save :: forall a m v . (Rendered v, MonadBuild m, TensorType a) + => ByteString -- ^ File path. + -> [Tensor v a] -- ^ Tensors to save. + -> m ControlNode +save path xs = build $ do + let toByteStringTensor = scalar . encodeUtf8 . encodeOutput . renderedOutput + let names = fmap toByteStringTensor xs + let types = replicate (length xs) (tensorType (undefined :: a)) + names' <- buildInputs $ CoreOps.pack names + xs' <- buildInputs xs + path' <- buildInputs $ scalar path + buildOp [] $ opDef "Save" + & opAttr "T" .~ types + & opInputs .~ (path' ++ names' ++ xs') + +-- | Restore a tensor's value from a checkpoint file. +-- +-- This version allows restoring from a checkpoint file that uses a different +-- tensor name than the variable. +restoreFromName :: forall a m . (MonadBuild m, TensorType a) + => ByteString -- ^ File path. + -> ByteString -- ^ Tensor name override. + -> Tensor Ref a -- ^ Tensor to restore. + -> m ControlNode +restoreFromName path name x = build $ do + path' <- buildInputs $ scalar path + name' <- buildInputs $ scalar name + restoreOp <- buildOp [] $ opDef "Restore" + & opAttr "dt" .~ tensorType (undefined :: a) + & opInputs .~ (path' ++ name') + group =<< CoreOps.assign x (restoreOp :: Tensor Value a) + +-- | Restore a tensor's value from a checkpoint file. +restore :: forall a m . (MonadBuild m, TensorType a) + => ByteString -- ^ File path. + -> Tensor Ref a -- ^ Tensor to restore. + -> m ControlNode +restore path x = restoreFromName path name x + where + name = encodeUtf8 $ encodeOutput $ renderedOutput x + +-- | Create a constant tensor. +-- +-- The values should be in row major order, e.g., +-- +-- element 0: index (0, ..., 0) +-- element 1: index (0, ..., 1) +-- ... +constant :: TensorType a => Shape -> [a] -> Tensor Build a +constant = constant' id + +constant' :: forall a . TensorType a => OpParams -> Shape -> [a] -> Tensor Build a +constant' params (Shape cShape) values + | invalidLength = error invalidLengthMsg + | otherwise = CoreOps.const' (params . (opAttr "value" .~ typedNode)) + where + invalidLength = product cShape /= fromIntegral (length values) + invalidLengthMsg = printf "invalid tensor length: expected %d got %d" + (product cShape) + (length values) + typedNode :: TensorProto + typedNode = def + & dtype .~ tensorType (undefined :: a) + & tensorShape.TensorShape.dim .~ + [def & TensorShape.size .~ x | x <- cShape] + & tensorVal .~ values + +-- | Reshape a N-D tensor down to a scalar. +-- +-- See `TensorFlow.GenOps.Core.reshape`. +scalarize :: TensorType a => Tensor v a -> Tensor Build a +scalarize t = CoreOps.reshape t (vector scalarShape) + where + scalarShape = [] :: [Int32] + +-- | Sum a tensor down to a scalar +-- Seee `TensorFlow.GenOps.Core.sum` +reduceSum :: (OneOf '[ Double, Float, Int32, Int64 + , Complex Float, Complex Double] a) => + Tensor v a -> Tensor Build a +reduceSum x = CoreOps.sum x allAxes + where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1 + +reduceSum' :: (OneOf '[ Double, Float, Int32, Int64 + , Complex Float, Complex Double] a) => + OpParams -> Tensor v a -> Tensor Build a +reduceSum' params x = CoreOps.sum' params x allAxes + where allAxes = CoreOps.range 0 (CoreOps.rank x :: Tensor Build Int32) 1 + +-- | Create a constant vector. +vector :: TensorType a => [a] -> Tensor Build a +vector = vector' id + +vector' :: TensorType a => OpParams -> [a] -> Tensor Build a +vector' params xs = constant' params [fromIntegral $ length xs] xs + +-- | Create a constant scalar. +scalar :: TensorType a => a -> Tensor Build a +scalar = scalar' id + +scalar' :: TensorType a => OpParams -> a -> Tensor Build a +scalar' params x = constant' params [] [x] + +-- | Random tensor from the unit normal distribution with bounded values. +-- +-- This is a type-restricted version of 'TensorFlow.GenOps.Core.truncatedNormal'. +truncatedNormal :: (MonadBuild m, OneOf '[Word16, Double, Float] a) + => Tensor v Int64 -- ^ Shape. + -> m (Tensor Value a) +truncatedNormal = CoreOps.truncatedNormal + +truncatedNormal' :: (MonadBuild m, OneOf '[Word16, Double, Float] a) + => OpParams -> Tensor v Int64 -- ^ Shape. + -> m (Tensor Value a) +truncatedNormal' = CoreOps.truncatedNormal' + +zeros :: forall a . (Num a, TensorType a) => Shape -> Tensor Build a +zeros (Shape s) = CoreOps.fill (vector $ map fromIntegral s) (scalar 0) + +shape :: TensorType t => Tensor v t -> Tensor Build Int32 +shape = CoreOps.shape + +shape' :: TensorType t => OpParams -> Tensor v t -> Tensor Build Int32 +shape' = CoreOps.shape' + +expandDims :: TensorType t => Tensor v1 t -> Tensor v2 Int32 -> Tensor Build t +expandDims = CoreOps.expandDims + +expandDims' :: TensorType t => OpParams -> Tensor v1 t -> Tensor v2 Int32 -> Tensor Build t +expandDims' = CoreOps.expandDims' + +-- | Helper function for reduction ops (translation of math_ops.reduced_shape). +reducedShape :: (OneOf '[ Int32, Int64 ] t1, OneOf '[ Int32, Int64 ] t2) => + Tensor v1 t1 -> Tensor v2 t2 -> Tensor Build Int32 +reducedShape inputShape axes = + let inputShape32 = toInt32 inputShape -- [2, 3, 5, 7] + axes32 = toInt32 axes -- [1, 2] + toInt32 x = CoreOps.cast x :: Tensor Build Int32 + inputRank = CoreOps.size inputShape32 -- 4 + axesMod = (axes32 + inputRank) `CoreOps.mod` inputRank + axesShape = shape axesMod -- [2] + in CoreOps.dynamicStitch -- [2, 1, 1, 7] + [CoreOps.range 0 inputRank 1, -- [0, 1, 2, 3] + axesMod] -- [1, 2] + [inputShape32, -- [2, 3, 5, 7] + CoreOps.fill axesShape 1] -- [1, 1] diff --git a/src/TensorFlow/Queue.hs b/src/TensorFlow/Queue.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Queue.hs @@ -0,0 +1,71 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Queues in TensorFlow graph. Very limited support for now. +module TensorFlow.Queue (Queue, makeQueue, enqueue, dequeue) where + +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Proxy (Proxy(..)) +import Lens.Family2 ((.~), (&)) +import TensorFlow.Build (ControlNode, MonadBuild, build, addInitializer, opAttr, opDef) +import TensorFlow.BuildOp (buildOp) +import TensorFlow.ControlFlow (group) +import qualified TensorFlow.GenOps.Core as CoreOps +import TensorFlow.Tensor (Ref, Value, Tensor, TensorList) +import TensorFlow.Types (TensorTypes, fromTensorTypes) + +-- | A queue carrying tuples. +data Queue (as :: [*]) = Queue { handle :: Handle } + +type Handle = Tensor Ref ByteString + +-- | Adds the given values to the queue. +enqueue :: forall as v m . (MonadBuild m, TensorTypes as) + => Queue as + -> TensorList v as + -> m ControlNode +enqueue = CoreOps.queueEnqueue . handle + +-- | Retrieves the values from the queue. +dequeue :: forall as m . (MonadBuild m, TensorTypes as) + => Queue as + -> m (TensorList Value as) + -- ^ Dequeued tensors. They are coupled in a sense + -- that values appear together, even if they are + -- not consumed together. +dequeue = CoreOps.queueDequeue . handle + +-- | Creates a new queue with the given capacity and shared name. +makeQueue :: forall as m . (MonadBuild m, TensorTypes as) + => Int64 -- ^ The upper bound on the number of elements in + -- this queue. Negative numbers mean no limit. + -> ByteString -- ^ If non-empty, this queue will be shared + -- under the given name across multiple sessions. + -> m (Queue as) +makeQueue capacity sharedName = do + q <- build $ buildOp [] (opDef "FIFOQueue" + & opAttr "component_types" .~ fromTensorTypes (Proxy :: Proxy as) + & opAttr "shared_name" .~ sharedName + & opAttr "capacity" .~ capacity + ) + group q >>= addInitializer + return (Queue q) + +-- TODO(gnezdo): Figure out the closing story for queues. diff --git a/src/TensorFlow/Variable.hs b/src/TensorFlow/Variable.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Variable.hs @@ -0,0 +1,123 @@ +-- | An implementation of ResourceHandle-based variables. +-- +-- The main difference between this and 'Ref'-based variables is +-- that reads are explicit, via the 'readValue' op. +-- +-- TODO: given that distinction, figure out a good story around +-- gradients and save/restore. Then, merge this module into +-- TensorFlow.Ops. +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +module TensorFlow.Variable + ( Variable + , variable + , variable' + , readValue + , initializedVariable + , initializedVariable' + , zeroInitializedVariable + , zeroInitializedVariable' + , assign + , assign' + , assignAdd + , assignAdd' + ) where + +import Data.Text.Encoding (encodeUtf8) +import Lens.Family2 ((.~), (&)) +import TensorFlow.Core +import TensorFlow.Build (opDef) +import TensorFlow.BuildOp (buildInputs, pureOp, OpParams) +import TensorFlow.Output (opInputs, unNodeName) +import TensorFlow.Tensor (tensorNodeName) +import TensorFlow.Types (tensorType) +import qualified TensorFlow.GenOps.Core as CoreOps +import TensorFlow.Ops (zeros) + +newtype Variable a = Variable (Tensor Value ResourceHandle) + +-- | Creates a new, uninitialized variable. +variable :: (MonadBuild m, TensorType a) => Shape -> m (Variable a) +variable = variable' id + +variable' :: forall m a . (MonadBuild m, TensorType a) + => OpParams -> Shape -> m (Variable a) +variable' params s = build $ do + -- Each variable needs a unique "shared_name". Use MonadFix to + -- set the attribute to the same name as the variable itself, without + -- exposing more internals of the Build module. + rec t <- CoreOps.varHandleOp' (params . (opAttr "shared_name" .~ n)) + (tensorType (undefined :: a)) s + let n = encodeUtf8 $ unNodeName $ tensorNodeName t + return $ Variable t + +-- | Creates a variable initialized to the given value. +-- Initialization happens next time session runs. +initializedVariable :: (MonadBuild m, TensorType a) + => Tensor v a -> m (Variable a) +initializedVariable = initializedVariable' id + +initializedVariable' :: forall a m v . (MonadBuild m, TensorType a) + => OpParams -> Tensor v a -> m (Variable a) +initializedVariable' params initializer = do + -- The shape is not known initially. + v@(Variable h) <- variable' params (Shape []) + i <- CoreOps.assignVariableOp h initializer + addInitializer =<< group i + return v + +-- | Creates a zero-initialized variable with the given shape. +zeroInitializedVariable + :: (MonadBuild m, TensorType a, Num a) => Shape -> m (Variable a) +zeroInitializedVariable = zeroInitializedVariable' id + +zeroInitializedVariable' + :: (MonadBuild m, TensorType a, Num a) => OpParams -> Shape -> m (Variable a) +zeroInitializedVariable' params = initializedVariable' params . zeros + +-- | Gets the value stored in a variable. +-- +-- Note that this op is stateful since it depends on the value of the variable; +-- however, it may be CSE'd with other reads in the same context. The context can +-- be fixed by using 'render' along with (for example) 'withControlDependencies'. +-- For example: +-- +-- > runSession $ do +-- > v <- variable [] +-- > a <- assign v 24 +-- > r <- withControlDependencies a $ render $ readValue v + 18 +-- > result <- run r +-- > liftIO $ (42 :: Float) @=? unScalar result +-- +-- +readValue :: TensorType a => Variable a -> Tensor Build a +readValue = readValue' id + +readValue' :: forall a . TensorType a + => OpParams -> Variable a -> Tensor Build a +readValue' params (Variable h) + = pureOp [] $ do + os <- buildInputs h + pure $ opDef "ReadVariableOp" + & (params + . (opAttr "dtype" .~ tensorType (undefined :: a)) + . (opInputs .~ os)) + +-- | Sets the value of a variable. +assign :: (MonadBuild m, TensorType a) + => Variable a -> Tensor v a -> m ControlNode +assign = assign' id + +assign' :: (MonadBuild m, TensorType a) + => OpParams -> Variable a -> Tensor v a -> m ControlNode +assign' params (Variable h) v = CoreOps.assignVariableOp' params h v + +-- | Increments the value of a variable. +assignAdd :: (MonadBuild m, TensorType a) + => Variable a -> Tensor v a -> m ControlNode +assignAdd = assignAdd' id + +assignAdd' :: (MonadBuild m, TensorType a) + => OpParams -> Variable a -> Tensor v a -> m ControlNode +assignAdd' params (Variable h) v = CoreOps.assignAddVariableOp' params h v diff --git a/tensorflow-ops.cabal b/tensorflow-ops.cabal new file mode 100644 --- /dev/null +++ b/tensorflow-ops.cabal @@ -0,0 +1,306 @@ +name: tensorflow-ops +version: 0.1.0.0 +synopsis: Friendly layer around TensorFlow bindings. +description: Please see README.md +homepage: https://github.com/tensorflow/haskell#readme +license: Apache +license-file: LICENSE +author: TensorFlow authors +maintainer: tensorflow-haskell@googlegroups.com +copyright: Google Inc. +category: Machine Learning +build-type: Simple +cabal-version: >=1.22 + +library + hs-source-dirs: src + exposed-modules: TensorFlow.Gradient + , TensorFlow.Ops + , TensorFlow.EmbeddingOps + , TensorFlow.NN + , TensorFlow.Queue + , TensorFlow.Variable + build-depends: proto-lens == 0.2.* + , base >= 4.7 && < 5 + , bytestring + , fgl + , mtl + , data-default + , lens-family + , containers + , tensorflow == 0.1.* + , tensorflow-proto == 0.1.* + , tensorflow-core-ops == 0.1.* + , text + default-language: Haskell2010 + +Test-Suite RegressionTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: RegressionTest.hs + hs-source-dirs: tests + build-depends: base + , HUnit + , lens-family + , transformers + , random + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + +Test-Suite MatrixTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: MatrixTest.hs + hs-source-dirs: tests + build-depends: base + , HUnit + , random + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-test + , test-framework + , test-framework-hunit + , transformers + , vector + +Test-Suite BuildTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: BuildTest.hs + hs-source-dirs: tests + build-depends: HUnit + , base + , proto-lens + , lens-family + , tensorflow + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + , transformers + , vector + +Test-Suite EmbeddingOpsTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: EmbeddingOpsTest.hs + hs-source-dirs: tests + build-depends: HUnit + , QuickCheck + , base + , proto-lens + , lens-family + , tensorflow + , tensorflow-test + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , transformers + , vector + +Test-Suite ArrayOpsTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: ArrayOpsTest.hs + hs-source-dirs: tests + build-depends: HUnit + , QuickCheck + , base + , proto-lens + , lens-family + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , transformers + , vector + +Test-Suite OpsTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: OpsTest.hs + hs-source-dirs: tests + build-depends: HUnit + , QuickCheck + , base + , bytestring + , proto-lens + , lens-family + , temporary + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , transformers + , vector + +Test-Suite VariableTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: VariableTest.hs + hs-source-dirs: tests + build-depends: HUnit + , base + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , test-framework + , test-framework-hunit + , transformers + , vector + + +Test-Suite DataFlowOpsTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: DataFlowOpsTest.hs + hs-source-dirs: tests + build-depends: HUnit + , QuickCheck + , base + , proto-lens + , lens-family + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , vector + +Test-Suite GradientTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: GradientTest.hs + hs-source-dirs: tests + build-depends: HUnit + , base + , proto-lens + , lens-family + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + , transformers + , vector + +Test-Suite MiscTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: MiscTest.hs + hs-source-dirs: tests + build-depends: HUnit + , base + , bytestring + , vector + , transformers + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , test-framework + , test-framework-hunit + +Test-Suite NNTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: NNTest.hs + hs-source-dirs: tests + build-depends: HUnit + , QuickCheck + , base + , tensorflow + , tensorflow-test + , tensorflow-ops + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , vector + +Test-Suite QueueTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: QueueTest.hs + hs-source-dirs: tests + -- Uses multiple threads and blocks without this option. + ghc-options: -threaded + build-depends: HUnit + , base + , bytestring + , proto-lens + , lens-family + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , test-framework + , test-framework-hunit + , transformers + , vector + +Test-Suite TracingTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: TracingTest.hs + hs-source-dirs: tests + build-depends: HUnit + , base + , bytestring + , data-default + , lens-family + , tensorflow + , tensorflow-ops + , test-framework + , test-framework-hunit + +Test-Suite TypesTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: TypesTest.hs + hs-source-dirs: tests + build-depends: HUnit + , QuickCheck + , base + , bytestring + , proto-lens + , lens-family + , tensorflow + , tensorflow-core-ops + , tensorflow-ops + , tensorflow-proto + , transformers + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , vector + +Benchmark FeedFetchBench + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: FeedFetchBench.hs + hs-source-dirs: tests + build-depends: base + , criterion + , deepseq + , tensorflow + , tensorflow-ops + , transformers + , vector + ghc-options: -O2 -threaded + +source-repository head + type: git + location: https://github.com/tensorflow/haskell diff --git a/tests/ArrayOpsTest.hs b/tests/ArrayOpsTest.hs new file mode 100644 --- /dev/null +++ b/tests/ArrayOpsTest.hs @@ -0,0 +1,51 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedLists #-} +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) +import qualified Data.Vector as V + +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Core as TF +import qualified TensorFlow.GenOps.Core as CoreOps + +-- | Test split and concat are inverses. +testSplit :: Test +testSplit = testCase "testSplit" $ TF.runSession $ do + let original = TF.constant [2, 3] [0..5 :: Float] + splitList = CoreOps.split 3 dim original + restored = CoreOps.concat dim splitList + dim = 1 -- dimension to split along (with size of 3 in original) + liftIO $ 3 @=? length splitList + (x, y, z) <- TF.run (original, restored, splitList !! 1) + liftIO $ x @=? (y :: V.Vector Float) + liftIO $ V.fromList [1, 4] @=? z + +testShapeN :: Test +testShapeN = testCase "testShapeN" $ TF.runSession $ do + let shapes = map TF.Shape [[1],[2,3]] + let tensors = map TF.zeros shapes :: [TF.Tensor TF.Build Float] + result <- TF.run $ CoreOps.shapeN tensors + liftIO $ [V.fromList [1], V.fromList [2,3]] @=? (result :: [V.Vector Int64]) + +main :: IO () +main = defaultMain [ testSplit + , testShapeN + ] diff --git a/tests/BuildTest.hs b/tests/BuildTest.hs new file mode 100644 --- /dev/null +++ b/tests/BuildTest.hs @@ -0,0 +1,176 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad.IO.Class (liftIO) +import Lens.Family2 ((^.), (.~)) +import Data.List (sort) +import Proto.Tensorflow.Core.Framework.Graph + ( node ) +import Proto.Tensorflow.Core.Framework.NodeDef + ( NodeDef + , device + , name + , op ) +import TensorFlow.Build + ( Build + , BuildT + , asGraphDef + , evalBuildT + , flushNodeBuffer + , withDevice + , withNameScope + , opName + ) +import TensorFlow.Types (unScalar) +import TensorFlow.Ops + ( add + , assign + , constant + , initializedVariable + , variable + , variable' + ) +import TensorFlow.Output (Device(..)) +import TensorFlow.Tensor + ( colocateWith + , render + , Tensor + , Value + , Ref + ) +import TensorFlow.Session + ( run + , runSession + , run_ + ) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) +import qualified Data.Vector as V + +-- | Test 'opName' behavior. +testOpName :: Test +testOpName = testCase "testOpName" $ do + let graph = variable' (opName .~ "foo") [] :: Build (Tensor Ref Float) + nodeDef :: NodeDef + nodeDef = head $ asGraphDef graph ^. node + "Variable" @=? (nodeDef ^. op) + "foo" @=? (nodeDef ^. name) + +-- | Test that "run" will render and extend any pure ops that haven't already +-- been rendered. +testPureRender :: Test +testPureRender = testCase "testPureRender" $ runSession $ do + result <- run $ 2 `add` 2 + liftIO $ 4 @=? (unScalar result :: Float) + +-- | Test that "run" assigns any previously accumulated initializers. +testInitializedVariable :: Test +testInitializedVariable = + testCase "testInitializedVariable" $ runSession $ do + (formula, reset) <- do + v <- initializedVariable 42 + r <- assign v 24 + return (1 `add` v, r) + result <- run formula + liftIO $ 43 @=? (unScalar result :: Float) + run_ reset -- Updates v to a different value + rerunResult <- run formula + liftIO $ 25 @=? (unScalar rerunResult :: Float) + +testInitializedVariableShape :: Test +testInitializedVariableShape = + testCase "testInitializedVariableShape" $ runSession $ do + vector <- initializedVariable (constant [1] [42 :: Float]) + result <- run vector + liftIO $ [42] @=? (result :: V.Vector Float) + +-- | Test nameScoped behavior. +testNameScoped :: Test +testNameScoped = testCase "testNameScoped" $ do + let graph = withNameScope "foo" $ variable [] :: Build (Tensor Ref Float) + nodeDef :: NodeDef + [nodeDef] = asGraphDef graph ^. node + "foo/Variable_0" @=? (nodeDef ^. name) -- TODO: Check prefix. + "Variable" @=? (nodeDef ^. op) + +-- | Test combined opName and nameScoped behavior. +testNamedAndScoped :: Test +testNamedAndScoped = testCase "testNamedAndScoped" $ do + let graph :: Build (Tensor Ref Float) + graph = withNameScope "foo1" (variable' (opName .~ "bar1") []) + nodeDef :: NodeDef + nodeDef = head $ asGraphDef graph ^. node + "Variable" @=? (nodeDef ^. op) + "foo1/bar1" @=? (nodeDef ^. name) + +-- | Flush the node buffer and sort the nodes by name (for more stable tests). +flushed :: Ord a => (NodeDef -> a) -> BuildT IO [a] +flushed field = sort . map field <$> flushNodeBuffer + +-- | Test the interaction of rendering, CSE and scoping. +testRenderDedup :: Test +testRenderDedup = testCase "testRenderDedup" $ evalBuildT $ do + renderNodes + names <- flushed (^. name) + liftIO $ ["Const_1", "Variable_0", "Variable_2"] @=? names + -- Render the nodes in a different scope, which should cause them + -- to be distinct from the previous ones. + withNameScope "foo" renderNodes + scopedNames <- flushed (^. name) + liftIO $ ["foo/Const_4", "foo/Variable_3", "foo/Variable_5"] @=? scopedNames + where + renderNodes = do + -- A stateful op and a pure op. + _ :: Tensor Ref Float <- variable [] + _ :: Tensor Value Float <- render 3 + -- Another stateful op, and a pure op which should be + -- deduped with the previous one. + _ :: Tensor Ref Float <- variable [] + _ :: Tensor Value Float <- render 3 + return () + +-- | Test the interaction of rendering, CSE and scoping. +testDeviceColocation :: Test +testDeviceColocation = testCase "testDeviceColocation" $ evalBuildT $ do + renderNodes + devices <- flushed (\x -> (x ^. name, x ^. device)) + liftIO $ [ ("Add_2","dev0") + , ("Const_1","dev0") + , ("Variable_0","dev0")] @=? devices + where + renderNodes = do + -- A stateful op and a pure op. + var :: Tensor Ref Float <- withDevice (Just $ Device "dev0") $ variable [] + -- Uses render to cause the expression be added to the graph. + _ <- colocateWith var $ render $ 3 `add` var + return () + +main :: IO () +main = defaultMain + [ testInitializedVariable + , testInitializedVariableShape + , testDeviceColocation + , testOpName + , testNameScoped + , testNamedAndScoped + , testPureRender + , testRenderDedup + ] diff --git a/tests/DataFlowOpsTest.hs b/tests/DataFlowOpsTest.hs new file mode 100644 --- /dev/null +++ b/tests/DataFlowOpsTest.hs @@ -0,0 +1,65 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +import Data.Int (Int32, Int64) +import Data.List (genericLength) +import Test.Framework (defaultMain) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@=?)) +import Test.QuickCheck (Arbitrary(..), Property, choose, vectorOf) +import Test.QuickCheck.Monadic (monadicIO, run) + +import qualified Data.Vector as V +import qualified TensorFlow.GenOps.Core as CoreOps +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Core as TF + +-- DynamicSplit is undone with DynamicStitch to get the original input +-- back. +testDynamicPartitionStitchInverse :: forall a. + (TF.TensorDataType V.Vector a, Show a, Eq a) => StitchExample a -> Property +testDynamicPartitionStitchInverse (StitchExample numParts values partitions) = + let splitParts :: [TF.Tensor TF.Build a] = + CoreOps.dynamicPartition numParts (TF.vector values) partTensor + partTensor = TF.vector partitions + restitchIndices = CoreOps.dynamicPartition numParts + (TF.vector [0..genericLength values-1]) + partTensor + -- drop (numParts - 2) from both args to expose b/27343984 + restitch = CoreOps.dynamicStitch restitchIndices splitParts + in monadicIO $ run $ do + fromIntegral numParts @=? length splitParts + valuesOut <- TF.runSession $ TF.run restitch + V.fromList values @=? valuesOut + +data StitchExample a = StitchExample Int64 [a] [Int32] + deriving Show + +instance Arbitrary a => Arbitrary (StitchExample a) where + arbitrary = do + -- Limits the size of the vector. + size <- choose (1, 100) + values <- vectorOf size arbitrary + numParts <- choose (2, 15) + partitions <- vectorOf size (choose (0, fromIntegral numParts - 1)) + return $ StitchExample numParts values partitions + +main :: IO () +main = defaultMain + [ testProperty "DynamicPartitionStitchInverse" + (testDynamicPartitionStitchInverse :: StitchExample Int64 -> Property) + ] diff --git a/tests/EmbeddingOpsTest.hs b/tests/EmbeddingOpsTest.hs new file mode 100644 --- /dev/null +++ b/tests/EmbeddingOpsTest.hs @@ -0,0 +1,177 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for EmbeddingOps. +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int32, Int64) +import Data.List (genericLength) +import TensorFlow.EmbeddingOps (embeddingLookup) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@=?)) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck (Arbitrary(..), Property, choose, vectorOf) +import Test.QuickCheck.Monadic (monadicIO, run) +import TensorFlow.Test (assertAllClose) + +import qualified Data.Vector as V +import qualified TensorFlow.GenOps.Core as CoreOps +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Session as TF +import qualified TensorFlow.Tensor as TF +import qualified TensorFlow.Types as TF +import qualified TensorFlow.Gradient as TF +import qualified TensorFlow.Build as TF + + +-- | Tries to perform a simple embedding lookup, with two partitions. +testEmbeddingLookupHasRightShapeWithPartition :: Test +testEmbeddingLookupHasRightShapeWithPartition = + testCase "testEmbeddingLookupHasRightShapeWithPartition" $ do + let embShape = TF.Shape [1, 3] -- Consider a 3-dim embedding of two items. + let embedding1 = [1, 1, 1 :: Int32] + let embedding2 = [0, 0, 0 :: Int32] + + let idValues = [0, 1 :: Int32] + + (values, shape) <- TF.runSession $ do + embedding <- mapM TF.render [ TF.constant embShape embedding1 + , TF.constant embShape embedding2 + ] + let ids = TF.constant (TF.Shape [1, 2]) idValues + vs <- embeddingLookup embedding ids + TF.run (vs, TF.shape vs) + + -- This is the shape that is returned in the equiv. Python. + shape @=? V.fromList [1, 2, 3] + + -- "[0, 1]" should pull out the resulting vector. + values @=? V.fromList [1, 1, 1, 0, 0, 0] + + +-- | Tries to perform a simple embedding lookup, with only a single partition. +testEmbeddingLookupHasRightShape :: Test +testEmbeddingLookupHasRightShape = + testCase "testEmbeddingLookupHasRightShape" $ do + -- Consider a 3-dim embedding of two items + let embShape = TF.Shape [2, 3] + let embeddingInit = [ 1, 1, 1 + , 0, 0, 0 :: Int32 + ] + + let idValues = [0, 1 :: Int32] + + (values, shape) <- TF.runSession $ do + embedding <- TF.render $ TF.constant embShape embeddingInit + let ids = TF.constant (TF.Shape [1, 2]) idValues + vs <- embeddingLookup [embedding] ids + TF.run (vs, TF.shape vs) + + -- This is the shape that is returned in the equiv. Python. + shape @=? V.fromList [1, 2, 3] + + -- "[0, 1]" should pull out the resulting vector. + values @=? V.fromList [1, 1, 1, 0, 0, 0] + +-- | Check that we can calculate gradients w.r.t embeddings. +testEmbeddingLookupGradients :: Test +testEmbeddingLookupGradients = testCase "testEmbeddingLookupGradients" $ do + -- Agrees with "embedding", so gradient should be zero. + let xVals = V.fromList ([20, 20 :: Float]) + let shape = TF.Shape [2] + + gs <- TF.runSession $ do + let embShape = TF.Shape [2, 1] + let embeddingInit = [1, 20 ::Float] + let idValues = [1, 1 :: Int32] + let ids = TF.constant (TF.Shape [1, 2]) idValues + + x <- TF.placeholder (TF.Shape [2]) + embedding <- TF.initializedVariable + (TF.constant embShape embeddingInit) + + op <- embeddingLookup [embedding] ids + let twoNorm = CoreOps.square $ TF.abs (op `TF.sub` x) + loss = TF.mean twoNorm (TF.scalar (0 :: Int32)) + + grad <- fmap head (TF.gradients loss [embedding]) + TF.runWithFeeds + [TF.feed x $ TF.encodeTensorData shape xVals] + grad + -- Gradients should be zero (or close) + assertAllClose gs (V.fromList ([0, 0 :: Float])) + + +-- Verifies that direct gather is the same as dynamic split into +-- partitions, followed by embedding lookup. +testEmbeddingLookupUndoesSplit :: + forall a. (TF.TensorDataType V.Vector a, Show a, Eq a) + => LookupExample a -> Property +testEmbeddingLookupUndoesSplit + (LookupExample numParts + shape@(TF.Shape (firstDim : restDims)) + values + indices) = monadicIO $ run $ TF.runSession $ do + let shapedValues = TF.constant shape values + indicesVector <- TF.render $ TF.vector indices + let directs = CoreOps.gather shapedValues indicesVector + let cyclicCounter :: TF.Tensor TF.Build Int32 = + TF.vector [0..fromIntegral firstDim-1] + `CoreOps.mod` fromIntegral numParts + modShardedValues :: [TF.Tensor TF.Value a] <- + mapM TF.render $ CoreOps.dynamicPartition numParts shapedValues cyclicCounter + embeddings <- embeddingLookup modShardedValues indicesVector + (shapeOut, got, want :: V.Vector a) <- + TF.run (TF.cast (TF.shape embeddings), embeddings, directs) + -- Checks the explicitly documented invariant of embeddingLookup. + liftIO $ shapeOut @=? V.fromList (genericLength indices : restDims) + liftIO $ got @=? want +testEmbeddingLookupUndoesSplit _ = error "Bug in Arbitrary (LookupExample)" + +-- | Consistent set of parameters for EmbeddingLookupUndoesSplit. +data LookupExample a = LookupExample + Int64 -- ^ number of ways to split. + TF.Shape -- ^ shape of the generated tensor + [a] -- ^ data for the tensor + [Int32] -- ^ indices to split the tensor by + deriving Show + +instance Arbitrary a => Arbitrary (LookupExample a) where + arbitrary = do + rank <- choose (1, 4) + -- Takes rank-th root of 100 to cap the tensor size. + let maxDim = fromIntegral (ceiling doubleMaxDim :: Int64) + doubleMaxDim :: Double + doubleMaxDim = 100 ** (1 / fromIntegral rank) + shape@(firstDim : _) <- vectorOf rank (choose (1, maxDim)) + values <- vectorOf (fromIntegral $ product shape) arbitrary + numParts <- choose (2, 15) + indSize <- choose (0, fromIntegral $ firstDim - 1) + indices <- vectorOf indSize (choose (0, fromIntegral firstDim - 1)) + return $ LookupExample numParts (TF.Shape shape) values indices + +main :: IO () +main = defaultMain + [ testProperty "EmbeddingLookupUndoesSplit" + (testEmbeddingLookupUndoesSplit :: LookupExample Double -> Property) + , testEmbeddingLookupHasRightShape + , testEmbeddingLookupHasRightShapeWithPartition + , testEmbeddingLookupGradients + ] diff --git a/tests/FeedFetchBench.hs b/tests/FeedFetchBench.hs new file mode 100644 --- /dev/null +++ b/tests/FeedFetchBench.hs @@ -0,0 +1,43 @@ +-- Disable full-laziness to keep ghc from optimizing most of the benchmark away. +{-# OPTIONS_GHC -fno-full-laziness #-} +import Control.DeepSeq (NFData(rnf)) +import Control.Exception (evaluate) +import Control.Monad.IO.Class (liftIO) +import Criterion.Main (defaultMain, bgroup, bench) +import Criterion.Types (Benchmarkable(..)) +import qualified Data.Vector.Storable as S +import qualified TensorFlow.Core as TF +import qualified TensorFlow.Ops as TF + +-- | Create 'Benchmarkable' for 'TF.Session'. +-- +-- The entire benchmark will be run in a single tensorflow session. The +-- 'TF.Session' argument will be run once and then its result will be run N +-- times. +nfSession :: NFData b => TF.Session (a -> TF.Session b) -> a -> Benchmarkable +nfSession init x = Benchmarkable $ \m -> TF.runSession $ do + f <- init + -- Can't use replicateM because n is Int64. + let go n | n <= 0 = return () + | otherwise = f x >>= liftIO . evaluate . rnf >> go (n-1) + go m + +-- | Benchmark feeding and fetching a vector. +feedFetchBenchmark :: TF.Session (S.Vector Float -> TF.Session (S.Vector Float)) +feedFetchBenchmark = do + input <- TF.build (TF.placeholder (TF.Shape [-1])) + output <- TF.build (TF.render (TF.identity input)) + return $ \v -> do + let shape = TF.Shape [fromIntegral (S.length v)] + inputData = TF.encodeTensorData shape v + feeds = [TF.feed input inputData] + TF.runWithFeeds feeds output + +main :: IO () +main = defaultMain + [ bgroup "feedFetch" + [ bench "4 byte" $ nfSession feedFetchBenchmark (S.replicate 1 0) + , bench "4 KiB" $ nfSession feedFetchBenchmark (S.replicate 1024 0) + , bench "4 MiB" $ nfSession feedFetchBenchmark (S.replicate (1024^2) 0) + ] + ] diff --git a/tests/GradientTest.hs b/tests/GradientTest.hs new file mode 100644 --- /dev/null +++ b/tests/GradientTest.hs @@ -0,0 +1,312 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} + +import Data.Int (Int32, Int64) +import Data.List (sort) +import Data.ProtoLens.TextFormat (showMessage) +import Test.Framework (defaultMain, Test) +import Lens.Family2 ((^..), (.~)) + +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?), assertEqual) +import qualified Data.Vector as V +import Control.Monad.IO.Class (liftIO) + +import qualified TensorFlow.Core as TF +import qualified TensorFlow.GenOps.Core as TF (max, tile) +import qualified TensorFlow.Gradient as TF +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Output as TF +import qualified TensorFlow.Types as TF + +import Proto.Tensorflow.Core.Framework.Graph (node) +import Proto.Tensorflow.Core.Framework.NodeDef (op) + +testGradientSimple :: Test +testGradientSimple = testCase "testGradientSimple" $ do + let grads = do + x <- TF.render $ TF.scalar (3 :: Float) + b <- TF.render $ TF.scalar (4 :: Float) + let y = x `TF.mul` x `TF.add` b + TF.gradients y [x, b] + -- Assert that the gradients are right. + [dx, db] <- TF.runSession $ grads >>= TF.run + 6 @=? TF.unScalar dx + 1 @=? TF.unScalar db + -- Assert that the graph has the expected ops. + let graphDef = TF.asGraphDef grads + putStrLn $ showMessage graphDef + let ops = graphDef ^.. node . traverse . op + expected = [ "Const" + , "Mul" + , "Const" + , "Add" + -- Default output gradient of y. + , "Shape" + , "Const" + , "Fill" + -- Add gradient. + , "Shape" + , "Shape" + , "BroadcastGradientArgs" + , "Sum" + , "Sum" + , "Reshape" + , "Reshape" + -- Mul gradient. + , "Shape" + -- This Op gets dedup'd because the inputs are the same. + -- TODO(fmayle): The same would happen to the Mul and Sum ops + -- below if the gradient function didn't multiply one as + -- 'dz * y' and the other as 'x * dz'. We could change the + -- order, but I'm going to keep it the same as the python + -- version for now. + -- + -- , "Shape" + , "BroadcastGradientArgs" + , "Mul" + , "Mul" + , "Sum" + , "Sum" + , "Reshape" + , "Reshape" + -- AddN to combine x's output gradients. + , "AddN" + ] + sort expected @=? sort ops + +testGradientDisconnected :: Test +testGradientDisconnected = testCase "testGradientDisconnected" $ do + let grads = do + x <- TF.render $ TF.scalar (3 :: Float) + b <- TF.render $ TF.scalar (4 :: Float) + TF.gradients x [x, b] + -- Assert that the gradients are right. + [dx, db] <- TF.runSession $ grads >>= TF.run + 1 @=? TF.unScalar dx + 0 @=? TF.unScalar db + -- Assert that the graph has the expected ops. + let graphDef = TF.asGraphDef grads + putStrLn $ showMessage graphDef + let ops = graphDef ^.. node . traverse . op + expected = [ "Const" + , "Const" + -- Default output gradient of x. + , "Shape" + , "Const" + , "Fill" + -- Default output gradient of b. + , "ZerosLike" + ] + sort expected @=? sort ops + + +-- Test that identical "stateful" ops work with createGraph. +testCreateGraphStateful :: Test +testCreateGraphStateful = testCase "testCreateGraphStateful" $ do + [dx, dy] <- TF.runSession $ do + let shape = TF.constant (TF.Shape [1]) [1] + x :: TF.Tensor TF.Value Float <- TF.truncatedNormal shape + y :: TF.Tensor TF.Value Float <- TF.truncatedNormal shape + TF.gradients (TF.expr x + TF.expr y * 3) [x, y] >>= TF.run + -- If this test fails, it will likely be caused by an exception within + -- `TF.gradients`. These asserts are extra. + 1 @=? TF.unScalar dx + 3 @=? TF.unScalar dy + + +-- Test that name scopes work with createGraph. +testCreateGraphNameScopes :: Test +testCreateGraphNameScopes = testCase "testCreateGraphNameScopes" $ do + [dx] <- TF.runSession $ do + let shape = TF.constant (TF.Shape [1]) [1] + x :: TF.Tensor TF.Value Float <- + TF.withNameScope "foo" (TF.truncatedNormal shape) + TF.gradients x [x] >>= TF.run + -- If this test fails, it will likely be caused by an exception within + -- `TF.gradients`. This assert is extra. + 1 @=? TF.unScalar dx + + +-- Test that createGraph can handle graphs with diamond shapes. +testDiamond :: Test +testDiamond = testCase "testDiamond" $ do + [dx] <- TF.runSession $ do + x <- TF.render $ TF.vector [1] + let y = x `TF.mul` x + z = y*y + TF.gradients z [x] >>= TF.run + (4 :: Float) @=? TF.unScalar dx + + +testMaxGradient :: Test +testMaxGradient = testCase "testMaxGradient" $ do + [dx] <- TF.runSession $ do + x <- TF.render $ TF.vector [1, 2, 3, 0, 1 :: Float] + let y = TF.max x (0 :: TF.Tensor TF.Build Int32) + TF.gradients y [x] >>= TF.run + V.fromList [0, 0, 1, 0, 0 :: Float] @=? dx + + +testReluGrad :: Test +testReluGrad = testCase "testReluGrad" $ do + [dx] <- TF.runSession $ do + x <- TF.render $ TF.vector [2 :: Float] + let y = TF.relu x + TF.gradients y [x] >>= TF.run + V.fromList [1] @=? dx + +testReluGradGrad :: Test +testReluGradGrad = testCase "testReluGradGrad" $ do + [dx] <- TF.runSession $ do + x <- TF.render $ TF.vector [2 :: Float] + let y = TF.relu x + [y'] <- TF.gradients y [x] + TF.gradients y' [x] >>= TF.run + V.fromList [0] @=? dx + + +testFillGrad :: Test +testFillGrad = testCase "testFillGrad" $ do + [dx] <- TF.runSession $ do + x <- TF.render $ TF.scalar (9 :: Float) + let shape = TF.vector [2, 3 :: Int32] + let y = TF.fill shape x + TF.gradients y [x] >>= TF.run + V.fromList [6] @=? dx + + +testTileGrad :: Test +testTileGrad = testCase "testTileGrad" $ do + [dx] <- TF.runSession $ do + x <- TF.render $ TF.vector [5, 9 :: Float] + let multiples = TF.vector [2 :: Int32] + let y = TF.tile x multiples + TF.gradients y [x] >>= TF.run + V.fromList [2, 2] @=? dx + + +testTile2DGrad :: Test +testTile2DGrad = testCase "testTileGrad2D" $ do + (dx, shapeDX, shapeX) <- TF.runSession $ do + let shape = TF.vector [3, 2 :: Int32] + x <- TF.render $ TF.fill shape (TF.scalar (1::Float)) + let multiples = TF.vector [2, 3 :: Int32] + let y = TF.tile x multiples + + [dx] <- TF.gradients y [x] + TF.run (dx, TF.shape dx, TF.shape x) + shapeX @=? (shapeDX :: V.Vector Int32) + V.fromList [6, 6, 6, 6, 6, 6::Float] @=? (dx :: V.Vector Float) + + +matMulGradient :: Test +matMulGradient = testCase "matMulGradients" $ do + + let dfBuild = do + x <- TF.render $ TF.zeros $ TF.Shape [3, 1 :: Int64] + w <- TF.zeroInitializedVariable $ TF.Shape [1, 2 :: Int64] + let f = x `TF.matMul` w :: TF.Tensor TF.Build Float + dfs <- TF.gradients f [x] + return (x, dfs) + + (xShape, dxShape) <- TF.runSession $ do + (x, [dx]) <- TF.build dfBuild + TF.run (TF.shape x, TF.shape dx) + + assertEqual "Shape of gradient must match shape of input" xShape (dxShape :: V.Vector Int32) + + +-- test that gradient of matMul can be taken gradient of +matMulGradGrad :: Test +matMulGradGrad = testCase "matMulGradGrad" $ do + let width = 2 :: Int64 + batch = 4 :: Int64 + + let tower = do + x <- TF.render $ TF.zeros $ TF.Shape [batch, 1] + w <- TF.zeroInitializedVariable $ TF.Shape [1, width] + let f = x `TF.matMul` w + [dfdx] <- TF.gradients f [x] + let f'x = TF.reduceSum dfdx + [dfdw] <- TF.gradients f'x [w] -- take gradient again (this time over w) + return [TF.value w, dfdw] + + TF.runSession $ do + [w, dfdw] <- TF.build tower + (wShape, dfdwShape) <- TF.run (TF.shape w, TF.shape dfdw) + liftIO $ assertEqual "Shape of gradient must match input" wShape (dfdwShape :: V.Vector Int32) + + let step = w `TF.add` dfdw + w0 <- TF.run step + liftIO $ ((V.fromList [4, 4 :: Float]) @=? w0) + + +-- test that gradient of matMul deals correctly with transpose_a and transpose_b +matMulTransposeGradient :: (Bool, Bool) -> Test +matMulTransposeGradient txw = testCase ("matMulTransposeGradients " ++ (show txw)) $ do + let (transposeX, transposeW) = txw + + let dfBuild = do + let xShape = TF.Shape [3, 1 :: Int64] + let xZeros = TF.zeros xShape + x <- TF.render $ if transposeX then TF.matTranspose xZeros else xZeros + variable <- TF.zeroInitializedVariable $ TF.Shape [1, 2 :: Int64] + let wv = if transposeW then TF.matTranspose variable else TF.expr variable + let f = TF.matMul' (transAttrs transposeX transposeW) x wv :: TF.Tensor TF.Build Float + w <- TF.render wv + ds <- TF.gradients f [x, w] + return (x, w, ds) + + TF.runSession $ do + (x, w, [dx, dw]) <- TF.build dfBuild + xShape <- TF.run $ TF.shape x + dxShape <- TF.run $ TF.shape dx + liftIO $ assertEqual "xShape must match dxShape" xShape (dxShape :: V.Vector Int32) + + wShape <- TF.run $ TF.shape w + dwShape <- TF.run $ TF.shape dw + liftIO $ assertEqual "wShape must match dwShape" wShape (dwShape :: V.Vector Int32) + +transAttrs :: (TF.Attribute a, + TF.Attribute b) => + a -> b -> TF.OpDef -> TF.OpDef +transAttrs a b = + (TF.opAttr "transpose_a" .~ a) . (TF.opAttr "transpose_b" .~ b) + +main :: IO () +main = defaultMain + [ testGradientSimple + , testGradientDisconnected + , testCreateGraphStateful + , testCreateGraphNameScopes + , testDiamond + , testMaxGradient + , testReluGrad + , testReluGradGrad + , testFillGrad + , testTileGrad + , testTile2DGrad + , matMulGradient + , matMulGradGrad + , matMulTransposeGradient (False, False) + , matMulTransposeGradient (False, True) + , matMulTransposeGradient (True, False) + , matMulTransposeGradient (True, True) + ] diff --git a/tests/MatrixTest.hs b/tests/MatrixTest.hs new file mode 100644 --- /dev/null +++ b/tests/MatrixTest.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} + +import Control.Monad.IO.Class (liftIO) +import Control.Monad (replicateM_, zipWithM) + +import qualified TensorFlow.GenOps.Core as TF (square, rank) +import qualified TensorFlow.Core as TF +import qualified TensorFlow.Gradient as TF +import qualified TensorFlow.Ops as TF +import qualified Data.Vector as V + +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import TensorFlow.Test (assertAllClose) + +randomParam :: TF.Shape -> TF.Session (TF.Tensor TF.Value Float) +randomParam (TF.Shape shape) = TF.truncatedNormal (TF.vector shape) + +reduceMean :: TF.Tensor v Float -> TF.Tensor TF.Build Float +reduceMean xs = TF.mean xs (TF.range 0 (TF.rank xs) 1) + +fitMatrix :: Test +fitMatrix = testCase "fitMatrix" $ TF.runSession $ do + u <- TF.initializedVariable =<< randomParam [2, 1] + v <- TF.initializedVariable =<< randomParam [1, 2] + let ones = [1, 1, 1, 1] :: [Float] + matx = TF.constant [2, 2] ones + diff = matx `TF.sub` (u `TF.matMul` v) + loss = reduceMean $ TF.square diff + trainStep <- gradientDescent 0.01 loss [u, v] + replicateM_ 1000 (TF.run trainStep) + (u',v') <- TF.run (u, v) + -- ones = u * v + liftIO $ assertAllClose (V.fromList ones) ((*) <$> u' <*> v') + +gradientDescent :: Float + -> TF.Tensor TF.Build Float + -> [TF.Tensor TF.Ref Float] + -> TF.Session TF.ControlNode +gradientDescent alpha loss params = do + let applyGrad param grad = + TF.assign param (param `TF.sub` (TF.scalar alpha `TF.mul` grad)) + TF.group =<< zipWithM applyGrad params =<< TF.gradients loss params + +main :: IO () +main = defaultMain [ fitMatrix ] diff --git a/tests/MiscTest.hs b/tests/MiscTest.hs new file mode 100644 --- /dev/null +++ b/tests/MiscTest.hs @@ -0,0 +1,50 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} + +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int32) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) +import qualified Data.Vector as V +import qualified TensorFlow.GenOps.Core as CoreOps + +import TensorFlow.Ops +import TensorFlow.Session + +-- | Test fetching multiple outputs from an op. +testMultipleOutputs :: Test +testMultipleOutputs = testCase "testMultipleOutputs" $ + runSession $ do + (values, indices) <- + run $ CoreOps.topKV2 (constant [1, 4] [10, 40, 20, 30]) 2 + liftIO $ [40, 30] @=? V.toList (values :: V.Vector Float) + liftIO $ [1, 3] @=? V.toList (indices :: V.Vector Int32) + +-- | Test op with variable number of inputs. +testVarargs :: Test +testVarargs = testCase "testVarargs" $ + runSession $ do + xs <- run $ pack $ map scalar [1..8] + liftIO $ [1..8] @=? V.toList (xs :: V.Vector Float) + +main :: IO () +main = defaultMain [ testMultipleOutputs + , testVarargs + ] diff --git a/tests/NNTest.hs b/tests/NNTest.hs new file mode 100644 --- /dev/null +++ b/tests/NNTest.hs @@ -0,0 +1,103 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} + +module Main where + +import TensorFlow.Test (assertAllClose) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import qualified Data.Vector as V +import qualified TensorFlow.Gradient as TF +import qualified TensorFlow.NN as TF +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Core as TF + +-- | These tests are ported from: +-- +-- /tensorflow/python/ops/nn_xent_tests.py +-- +-- This is the implementation we use to check the implementation we +-- wrote in `TensorFlow.NN.sigmoidCrossEntropyWithLogits`. +-- +sigmoidXentWithLogits :: Floating a => Ord a => [a] -> [a] -> [a] +sigmoidXentWithLogits logits' targets' = + let sig = map (\x -> 1 / (1 + exp (-x))) logits' + eps = 0.0001 + predictions = map (\p -> min (max p eps) (1 - eps)) sig + xent y z = (-z) * (log y) - (1 - z) * log (1 - y) + in zipWith xent predictions targets' + + +data Inputs = Inputs { + logits :: [Float] + , targets :: [Float] + } + + +defInputs :: Inputs +defInputs = Inputs { + logits = [-100, -2, -2, 0, 2, 2, 2, 100] + , targets = [ 0, 0, 1, 0, 0, 1, 0.5, 1] + } + + +testLogisticOutput :: Test +testLogisticOutput = testCase "testLogisticOutput" $ do + let inputs = defInputs + r <- run $ do + vLogits <- TF.render $ TF.vector $ logits inputs + vTargets <- TF.render $ TF.vector $ targets inputs + TF.sigmoidCrossEntropyWithLogits vLogits vTargets + let ourLoss = V.fromList $ sigmoidXentWithLogits (logits inputs) (targets inputs) + assertAllClose r ourLoss + + +testLogisticOutputMultipleDim :: Test +testLogisticOutputMultipleDim = + testCase "testLogisticOutputMultipleDim" $ do + let inputs = defInputs + shape = [2, 2, 2] + r <- run $ do + vLogits <- TF.render $ TF.constant shape (logits inputs) + vTargets <- TF.render $ TF.constant shape (targets inputs) + TF.sigmoidCrossEntropyWithLogits vLogits vTargets + let ourLoss = V.fromList $ sigmoidXentWithLogits (logits inputs) (targets inputs) + assertAllClose r ourLoss + + +testGradientAtZero :: Test +testGradientAtZero = testCase "testGradientAtZero" $ do + r <- run $ do + let inputs = defInputs { logits = [0, 0], targets = [0, 1] } + vTargets <- TF.render $ TF.vector $ targets inputs + vLogits <- TF.render $ TF.vector $ logits inputs + let tfLoss = TF.sigmoidCrossEntropyWithLogits vLogits vTargets + + l <- tfLoss + TF.gradients l [vLogits] + + assertAllClose (head r) (V.fromList [0.5, -0.5]) + +run :: TF.Fetchable t a => TF.Session t -> IO a +run = TF.runSession . (>>= TF.run) + +main :: IO () +main = defaultMain + [ testGradientAtZero + , testLogisticOutput + , testLogisticOutputMultipleDim + ] diff --git a/tests/OpsTest.hs b/tests/OpsTest.hs new file mode 100644 --- /dev/null +++ b/tests/OpsTest.hs @@ -0,0 +1,115 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int32, Int64) +import Test.Framework (defaultMain, Test) +import Lens.Family2 ((.~)) +import System.IO.Temp (withSystemTempDirectory) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) +import qualified Data.ByteString.Char8 as B8 + +import qualified Data.Vector as V +import qualified TensorFlow.Build as TF +import qualified TensorFlow.Nodes as TF +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Session as TF +import qualified TensorFlow.Tensor as TF +import qualified TensorFlow.Types as TF + +-- | Test that one can easily determine number of elements in the tensor. +testSize :: Test +testSize = testCase "testSize" $ do + x <- eval $ TF.size (TF.constant (TF.Shape [2, 3]) [0..5 :: Float]) + TF.Scalar (2 * 3 :: Int32) @=? x + +eval :: TF.Fetchable t a => t -> IO a +eval = TF.runSession . TF.run + +-- | Confirms that the original example from Python code works. +testReducedShape :: Test +testReducedShape = testCase "testReducedShape" $ do + x <- eval $ TF.reducedShape (TF.vector [2, 3, 5, 7 :: Int64]) + (TF.vector [1, 2 :: Int32]) + V.fromList [2, 1, 1, 7 :: Int32] @=? x + +testSaveRestore :: Test +testSaveRestore = testCase "testSaveRestore" $ + withSystemTempDirectory "" $ \dirPath -> do + let path = B8.pack $ dirPath ++ "/checkpoint" + var :: TF.MonadBuild m => m (TF.Tensor TF.Ref Float) + var = TF.zeroInitializedVariable' (TF.opName .~ "a") + (TF.Shape []) + TF.runSession $ do + v <- var + TF.assign v 134 >>= TF.run_ + TF.save path [v] >>= TF.run_ + result <- TF.runSession $ do + v <- var + TF.restore path v >>= TF.run_ + TF.run v + liftIO $ TF.Scalar 134 @=? result + +-- | Test that 'placeholder' is not CSE'd. +testPlaceholderCse :: Test +testPlaceholderCse = testCase "testPlaceholderCse" $ TF.runSession $ do + p1 <- TF.placeholder [] + p2 <- TF.placeholder [] + let enc :: Float -> TF.TensorData Float + enc n = TF.encodeTensorData [] (V.fromList [n]) + result <- TF.runWithFeeds [TF.feed p1 (enc 2), TF.feed p2 (enc 3)] + $ p1 `TF.add` p2 + liftIO $ result @=? TF.Scalar 5 + +-- | Test that regular tensors can also be used for feeds, as long as they each +-- have a different name. +testScalarFeedCse :: Test +testScalarFeedCse = testCase "testScalarFeedCse" $ TF.runSession $ do + p1 <- TF.render $ TF.scalar' (TF.opName .~ "A") 0 + -- The second op is identical to the first other than its name; make sure + -- we don't aggressively CSE them together and prevent feeding them + -- separately. + p2 <- TF.render $ TF.scalar' (TF.opName .~ "B") 0 + let enc :: Float -> TF.TensorData Float + enc n = TF.encodeTensorData [] (V.fromList [n]) + result <- TF.runWithFeeds [TF.feed p1 (enc 2), TF.feed p2 (enc 3)] + $ p1 `TF.add` p2 + liftIO $ result @=? TF.Scalar 5 + +-- | See https://github.com/tensorflow/haskell/issues/92. +-- Even though we're not explicitly evaluating `f0` until the end, +-- it should hold the earlier value of the variable. +testRereadRef :: Test +testRereadRef = testCase "testReRunAssign" $ TF.runSession $ do + w <- TF.initializedVariable 0 + f0 <- TF.run w + TF.run_ =<< TF.assign w (TF.scalar (0.1 :: Float)) + f1 <- TF.run w + liftIO $ (0.0, 0.1) @=? (TF.unScalar f0, TF.unScalar f1) + +main :: IO () +main = defaultMain + [ testSaveRestore + , testSize + , testReducedShape + , testPlaceholderCse + , testScalarFeedCse + , testRereadRef + ] diff --git a/tests/QueueTest.hs b/tests/QueueTest.hs new file mode 100644 --- /dev/null +++ b/tests/QueueTest.hs @@ -0,0 +1,91 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import Test.Framework (defaultMain, Test) +import TensorFlow.Types (ListOf(..), Scalar(..), (/:/)) +import TensorFlow.Ops (scalar) +import TensorFlow.Queue +import TensorFlow.Session + ( asyncProdNodes + , build + , run + , runSession + , run_ + ) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) +import qualified Data.ByteString as BS + +-- | Test basic queue behaviors. +testBasic :: Test +testBasic = testCase "testBasic" $ runSession $ do + q :: Queue [Int64, BS.ByteString] <- build $ makeQueue 1 "" + run_ =<< enqueue q (42 :/ scalar "Hi" :/ Nil) + x <- run =<< dequeue q + liftIO $ (Scalar 42 /:/ Scalar "Hi" /:/ Nil) @=? x + + run_ =<< enqueue q (56 :/ scalar "Bar" :/ Nil) + y <- run =<< dequeue q + -- Note: we use explicit "Scalar" here to specify the type that was + -- fetched. Equivalently we could write + -- 56 /:/ "Bar" /:/ Nil :: List [Scalar Int64, Scalar BS.ByteString] + -- or else allow the types to be determined by future use of the fetched + -- value. + let expected = Scalar 56 /:/ Scalar "Bar" /:/ Nil + liftIO $ expected @=? y + +-- | Test queue pumping. +testPump :: Test +testPump = testCase "testPump" $ runSession $ do + (deq, pump) <- build $ do + q :: Queue [Int64, BS.ByteString] <- makeQueue 2 "ThePumpQueue" + (,) <$> dequeue q + <*> enqueue q (31 :/ scalar "Baz" :/ Nil) + -- This is a realistic use. The pump inputs are pre-bound to some + -- nodes that produce values when pumped (e.g. read from a + -- file). + run_ (pump, pump) + + (x, y) <- run (deq, deq) + let expected = Scalar 31 /:/ Scalar "Baz" /:/ Nil + liftIO $ expected @=? x + liftIO $ expected @=? y + +testAsync :: Test +testAsync = testCase "testAsync" $ runSession $ do + (deq, pump) <- do + q :: Queue [Int64, BS.ByteString] <- makeQueue 2 "" + (,) <$> dequeue q + <*> enqueue q (10 :/ scalar "Async" :/ Nil) + -- Pumps the queue until canceled by runSession exiting. + asyncProdNodes pump + -- Picks up a couple values and verifies they are as expected. + let expected = Scalar 10 /:/ Scalar "Async" /:/ Nil + run deq >>= liftIO . (expected @=?) + run deq >>= liftIO . (expected @=?) + +main :: IO () +main = defaultMain + [ testBasic + , testPump + , testAsync + ] diff --git a/tests/RegressionTest.hs b/tests/RegressionTest.hs new file mode 100644 --- /dev/null +++ b/tests/RegressionTest.hs @@ -0,0 +1,47 @@ +-- | Simple linear regression example for the README. + +import Control.Monad (replicateM, replicateM_, zipWithM) +import System.Random (randomIO) +import Test.HUnit (assertBool) + +import qualified TensorFlow.Core as TF +import qualified TensorFlow.GenOps.Core as TF +import qualified TensorFlow.Gradient as TF +import qualified TensorFlow.Ops as TF + +main :: IO () +main = do + -- Generate data where `y = x*3 + 8`. + xData <- replicateM 100 randomIO + let yData = [x*3 + 8 | x <- xData] + -- Fit linear regression model. + (w, b) <- fit xData yData + assertBool "w == 3" (abs (3 - w) < 0.001) + assertBool "b == 8" (abs (8 - b) < 0.001) + +fit :: [Float] -> [Float] -> IO (Float, Float) +fit xData yData = TF.runSession $ do + -- Create tensorflow constants for x and y. + let x = TF.vector xData + y = TF.vector yData + -- Create scalar variables for slope and intercept. + w <- TF.initializedVariable 0 + b <- TF.initializedVariable 0 + -- Define the loss function. + let yHat = (x `TF.mul` w) `TF.add` b + loss = TF.square (yHat `TF.sub` y) + -- Optimize with gradient descent. + trainStep <- gradientDescent 0.001 loss [w, b] + replicateM_ 1000 (TF.run trainStep) + -- Return the learned parameters. + (TF.Scalar w', TF.Scalar b') <- TF.run (w, b) + return (w', b') + +gradientDescent :: Float + -> TF.Tensor TF.Build Float + -> [TF.Tensor TF.Ref Float] + -> TF.Session TF.ControlNode +gradientDescent alpha loss params = do + let applyGrad param grad = + TF.assign param (param `TF.sub` (TF.scalar alpha `TF.mul` grad)) + TF.group =<< zipWithM applyGrad params =<< TF.gradients loss params diff --git a/tests/TracingTest.hs b/tests/TracingTest.hs new file mode 100644 --- /dev/null +++ b/tests/TracingTest.hs @@ -0,0 +1,49 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE OverloadedStrings #-} + +-- | Testing tracing. +module Main where + +import Control.Concurrent.MVar (newEmptyMVar, putMVar, tryReadMVar) +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy (isPrefixOf) +import Data.Default (def) +import Lens.Family2 ((&), (.~)) +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (assertBool, assertFailure) + +import qualified TensorFlow.Core as TF +import qualified TensorFlow.Ops as TF + +testTracing :: IO () +testTracing = do + -- Verifies that tracing happens as a side-effect of graph extension. + loggedValue <- newEmptyMVar + TF.runSessionWithOptions + (def & TF.sessionTracer .~ putMVar loggedValue) + (TF.run_ (TF.scalar (0 :: Float))) + tryReadMVar loggedValue >>= + maybe (assertFailure "Logging never happened") expectedFormat + where expectedFormat x = + let got = toLazyByteString x in + assertBool ("Unexpected log entry " ++ show got) + ("Session.extend" `isPrefixOf` got) + +main :: IO () +main = defaultMain + [ testCase "Tracing" testTracing + ] diff --git a/tests/TypesTest.hs b/tests/TypesTest.hs new file mode 100644 --- /dev/null +++ b/tests/TypesTest.hs @@ -0,0 +1,134 @@ +-- Copyright 2016 TensorFlow authors. +-- +-- Licensed under the Apache License, Version 2.0 (the "License"); +-- you may not use this file except in compliance with the License. +-- You may obtain a copy of the License at +-- +-- http://www.apache.org/licenses/LICENSE-2.0 +-- +-- Unless required by applicable law or agreed to in writing, software +-- distributed under the License is distributed on an "AS IS" BASIS, +-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +-- See the License for the specific language governing permissions and +-- limitations under the License. + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Purposely disabled to confirm doubleFuncNoSig can be written without type. +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +import Control.Monad (replicateM) +import Control.Monad.IO.Class (liftIO) +import Data.Int (Int64) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@=?)) +import Test.QuickCheck (Arbitrary(..), listOf, suchThat) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Vector as V + +import qualified TensorFlow.GenOps.Core as TF (select) +import qualified TensorFlow.Ops as TF +import qualified TensorFlow.Session as TF +import qualified TensorFlow.Tensor as TF +import qualified TensorFlow.Types as TF + +instance Arbitrary B.ByteString where + arbitrary = B.pack <$> arbitrary + +-- Test encoding tensors, feeding them through tensorflow, and decoding the +-- results. +testFFIRoundTrip :: Test +testFFIRoundTrip = testCase "testFFIRoundTrip" $ + TF.runSession $ do + let floatData = V.fromList [1..6 :: Float] + stringData = V.fromList [B8.pack (show x) | x <- [1..6::Integer]] + boolData = V.fromList [True, True, False, True, False, False] + f <- TF.placeholder [2,3] + s <- TF.placeholder [2,3] + b <- TF.placeholder [2,3] + let feeds = [ TF.feed f (TF.encodeTensorData [2,3] floatData) + , TF.feed s (TF.encodeTensorData [2,3] stringData) + , TF.feed b (TF.encodeTensorData [2,3] boolData) + ] + -- Do something idempotent to the tensors to verify that tensorflow can + -- handle the encoding. Originally this used `TF.identity`, but that + -- wasn't enough to catch a bug in the encoding of Bool. + (f', s', b') <- TF.runWithFeeds feeds + (f `TF.add` 0, TF.identity s, TF.select b b b) + liftIO $ do + floatData @=? f' + stringData @=? s' + boolData @=? b' + + +data TensorDataInputs a = TensorDataInputs [Int64] (V.Vector a) + deriving Show + +instance Arbitrary a => Arbitrary (TensorDataInputs a) where + arbitrary = do + -- Limit the size of the final vector, and also guard against overflow + -- (i.e., p<0) when there are too many dimensions + let validProduct p = p > 0 && p < 100 + sizes <- listOf (arbitrary `suchThat` (>0)) + `suchThat` (validProduct . product) + elems <- replicateM (fromIntegral $ product sizes) arbitrary + return $ TensorDataInputs sizes (V.fromList elems) + +-- Test that a vector is unchanged after being encoded and decoded. +encodeDecodeProp :: (TF.TensorDataType V.Vector a, Eq a) => TensorDataInputs a -> Bool +encodeDecodeProp (TensorDataInputs shape vec) = + TF.decodeTensorData (TF.encodeTensorData (TF.Shape shape) vec) == vec + +testEncodeDecodeQcFloat :: Test +testEncodeDecodeQcFloat = testProperty "testEncodeDecodeQcFloat" + (encodeDecodeProp :: TensorDataInputs Float -> Bool) + +testEncodeDecodeQcInt64 :: Test +testEncodeDecodeQcInt64 = testProperty "testEncodeDecodeQcInt64" + (encodeDecodeProp :: TensorDataInputs Int64 -> Bool) + +testEncodeDecodeQcString :: Test +testEncodeDecodeQcString = testProperty "testEncodeDecodeQcString" + (encodeDecodeProp :: TensorDataInputs B.ByteString -> Bool) + +doubleOrInt64Func :: TF.OneOf '[Double, Int64] a => a -> a +doubleOrInt64Func = id + +doubleOrFloatFunc :: TF.OneOf '[Double, Float] a => a -> a +doubleOrFloatFunc = id + +doubleFunc :: TF.OneOf '[Double] a => a -> a +doubleFunc = doubleOrFloatFunc . doubleOrInt64Func + +-- No explicit type signature; make sure it can be inferred automatically. +-- (Note: this would fail if we didn't have NoMonomorphismRestriction, since it +-- can't simplify the type all the way to `Double -> Double`. +doubleFuncNoSig = doubleOrFloatFunc . doubleOrInt64Func + +typeConstraintTests :: Test +typeConstraintTests = testCase "type constraints" $ do + 42 @=? doubleOrInt64Func (42 :: Double) + 42 @=? doubleOrInt64Func (42 :: Int64) + 42 @=? doubleOrFloatFunc (42 :: Double) + 42 @=? doubleOrFloatFunc (42 :: Float) + 42 @=? doubleFunc (42 :: Double) + 42 @=? doubleFuncNoSig (42 :: Double) + + +main :: IO () +main = defaultMain + [ testFFIRoundTrip + , testEncodeDecodeQcFloat + , testEncodeDecodeQcInt64 + , testEncodeDecodeQcString + , typeConstraintTests + ] diff --git a/tests/VariableTest.hs b/tests/VariableTest.hs new file mode 100644 --- /dev/null +++ b/tests/VariableTest.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedLists #-} +module Main (main) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Vector.Storable as V +import TensorFlow.Core + ( unScalar + , render + , run_ + , runSession + , run + , withControlDependencies) +import qualified TensorFlow.Ops as Ops +import TensorFlow.Variable + ( readValue + , initializedVariable + , assign + , assignAdd + , variable + ) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@=?)) + +main :: IO () +main = defaultMain + [ testInitializedVariable + , testInitializedVariableShape + , testDependency + , testRereadRef + , testAssignAdd + ] + +testInitializedVariable :: Test +testInitializedVariable = + testCase "testInitializedVariable" $ runSession $ do + (formula, reset) <- do + v <- initializedVariable 42 + r <- assign v 24 + return (1 + readValue v, r) + result <- run formula + liftIO $ 43 @=? (unScalar result :: Float) + run_ reset -- Updates v to a different value + rerunResult <- run formula + liftIO $ 25 @=? (unScalar rerunResult :: Float) + +testInitializedVariableShape :: Test +testInitializedVariableShape = + testCase "testInitializedVariableShape" $ runSession $ do + vector <- initializedVariable (Ops.constant [1] [42 :: Float]) + result <- run (readValue vector) + liftIO $ [42] @=? (result :: V.Vector Float) + +testDependency :: Test +testDependency = + testCase "testDependency" $ runSession $ do + v <- variable [] + a <- assign v 24 + r <- withControlDependencies a $ render (readValue v + 18) + result <- run r + liftIO $ (42 :: Float) @=? unScalar result + +-- | See https://github.com/tensorflow/haskell/issues/92. +-- Even though we're not explicitly evaluating `f0` until the end, +-- it should hold the earlier value of the variable. +testRereadRef :: Test +testRereadRef = testCase "testReRunAssign" $ runSession $ do + w <- initializedVariable 0 + f0 <- run (readValue w) + run_ =<< assign w (Ops.scalar (0.1 :: Float)) + f1 <- run (readValue w) + liftIO $ (0.0, 0.1) @=? (unScalar f0, unScalar f1) + +testAssignAdd :: Test +testAssignAdd = testCase "testAssignAdd" $ runSession $ do + w <- initializedVariable 42 + run_ =<< assignAdd w 17 + f1 <- run (readValue w) + liftIO $ (42 + 17 :: Float) @=? unScalar f1