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/Build.hs b/src/TensorFlow/Build.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Build.hs @@ -0,0 +1,339 @@ +-- 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 GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +module TensorFlow.Build + ( -- * Graph node types + ControlNode(..) + , Unique + -- * Ops + , explicitName + , implicitName + , opDef + , opDefWithName + , opName + , opType + , opAttr + , opInputs + , opControlInputs + -- * The Build monad + , GraphState + , renderedNodeDefs + , BuildT + , Build + , MonadBuild(..) + , addInitializer + , hoistBuildT + , evalBuildT + , runBuildT + , asGraphDef + , addGraphDef + , flushInitializers + , flushNodeBuffer + , summaries + -- * Creating and looking up Ops + , getOrAddOp + , addNewOp + , encodeOutput + , lookupNode + -- * Modifying all nodes in a Build action + , withStateLens + , withDevice + , withNameScope + , withNodeDependencies + ) where + +import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.State.Strict(StateT(..), mapStateT, evalStateT) +import Data.Default (def) +import Data.Functor.Identity (Identity(..)) +import qualified Data.Map.Strict as Map +import Data.Monoid ((<>)) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Lens.Family2 (Lens', (.~), (^.), (&)) +import Lens.Family2.State.Strict (MonadState, use, uses, (.=), (<>=), (%=)) +import Lens.Family2.Unchecked (lens) +import Proto.Tensorflow.Core.Framework.Graph + ( GraphDef + , node + ) +import Proto.Tensorflow.Core.Framework.NodeDef + ( NodeDef + , attr + , input + , device + , name + , op + ) + +import TensorFlow.Orphans () +import TensorFlow.Output + +newtype Unique = Unique Int + deriving (Eq, Ord, Enum) + +-------------- + +implicitName :: PendingNodeName +implicitName = ImplicitName + +explicitName :: Text -> PendingNodeName +explicitName = ExplicitName + +newtype Scope = Scope {unScope :: Text} + deriving (Eq, Ord, IsString) + +instance Show Scope where + show = show . unScope + +opDef :: OpType -> OpDef +opDef = opDefWithName ImplicitName + +opDefWithName :: PendingNodeName -> OpType -> OpDef +opDefWithName n t = OpDef + { _opName = n + , _opType = t + , _opAttrs = Map.empty + , _opInputs = [] + , _opControlInputs = [] + } + +data GraphState = GraphState + { _renderedNodes :: !(Map.Map PendingNode NodeDef) + -- ^ Nodes which have been rendered. Keeps track of the unique ID we + -- assign each implicitly-named node. Also prevents us from adding the + -- same node (implicit or explicit) more than once to the nodeBuffer. + , _renderedNodeDefs :: !(Map.Map NodeName NodeDef) + -- ^ The NodeDefs of nodes which have been rendered. Used by the + -- Gradient module to inspect the node graph. + , _nodeBuffer :: [NodeDef] + -- ^ A list of nodes that should be passed to TensorFlow during + -- the next call to Session.extend (TF_ExtendGraph). + , _nextUnique :: !Unique + -- ^ Unique ID for the next node + -- TODO(judahjacobson): watch for clashes between auto and user names. + , _defaultDevice :: !(Maybe Device) + , _currentScope :: [Scope] + , _defaultControlInputs :: !(Set NodeName) + , _initializationNodes :: [NodeName] + -- ^ The nodes to run next time a TF.run is issued, typically + -- variable initializers. + , _summaries :: [Output] + -- ^ The tensors for summary (ByteString type) + } + +-- | A node definition without its final name. Used as a key in the +-- "renderedNodes" map. +-- The NodeDef contained inside has an empty "name" field. +data PendingNode = PendingNode [Scope] !PendingNodeName !NodeDef + deriving (Eq, Ord) + +-- Returns an _incomplete_ NodeDef. The name is fixed by addNewOpFromPending. +pendingNodeDef :: PendingNode -> NodeDef +pendingNodeDef (PendingNode _ _ n) = n + +initGraphState :: GraphState +initGraphState = + GraphState Map.empty Map.empty [] (Unique 0) Nothing [] Set.empty [] [] + +renderedNodes :: Lens' GraphState (Map.Map PendingNode NodeDef) +renderedNodes = lens _renderedNodes (\g x -> g { _renderedNodes = x }) + +renderedNodeDefs :: Lens' GraphState (Map.Map NodeName NodeDef) +renderedNodeDefs = lens _renderedNodeDefs (\g x -> g { _renderedNodeDefs = x }) + +nodeBuffer :: Lens' GraphState [NodeDef] +nodeBuffer = lens _nodeBuffer (\g x -> g { _nodeBuffer = x }) + +nextUnique :: Lens' GraphState Unique +nextUnique = lens _nextUnique (\g x -> g { _nextUnique = x }) + +defaultDevice :: Lens' GraphState (Maybe Device) +defaultDevice = lens _defaultDevice (\g x -> g { _defaultDevice = x }) + +currentScope :: Lens' GraphState [Scope] +currentScope = lens _currentScope (\g x -> g { _currentScope = x }) + +defaultControlInputs :: Lens' GraphState (Set NodeName) +defaultControlInputs = lens _defaultControlInputs + (\g x -> g { _defaultControlInputs = x }) + +initializationNodes :: Lens' GraphState [NodeName] +initializationNodes = lens _initializationNodes (\g x -> g { _initializationNodes = x }) + +summaries :: Lens' GraphState [Output] +summaries = lens _summaries (\g x -> g { _summaries = x }) + +-- | An action for building nodes in a TensorFlow graph. +-- Used to manage build state internally as part of the @Session@ monad. +newtype BuildT m a = BuildT (StateT GraphState m a) + deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, + MonadState GraphState, MonadThrow, MonadCatch, MonadMask, + MonadFix) + +-- | An action for building nodes in a TensorFlow graph. +type Build = BuildT Identity + +-- | This is Control.Monad.Morph.hoist sans the dependency. +hoistBuildT :: (forall a . m a -> n a) -> BuildT m b -> BuildT n b +hoistBuildT f (BuildT m) = BuildT $ mapStateT f m + +runBuildT :: BuildT m a -> m (a, GraphState) +runBuildT (BuildT f) = runStateT f initGraphState + +evalBuildT :: Monad m => BuildT m a -> m a +evalBuildT (BuildT f) = evalStateT f initGraphState + +-- | Lift a 'Build' action into a monad, including any explicit op renderings. +class Monad m => MonadBuild m where + build :: Build a -> m a + +instance Monad m => MonadBuild (BuildT m) where + build = hoistBuildT $ return . runIdentity + +-- | Get all the NodeDefs that have accumulated so far, and clear that buffer. +flushNodeBuffer :: MonadBuild m => m [NodeDef] +flushNodeBuffer = build $ do + ns <- use nodeBuffer + nodeBuffer .= [] + return ns + +-- | Get all the initializers that have accumulated so far, and clear +-- that buffer. +flushInitializers :: Monad m => BuildT m [NodeName] +flushInitializers = do + ns <- use initializationNodes + initializationNodes .= [] + return ns + +-- | Registers the given node to be executed before the next +-- 'TensorFlow.Session.run'. +addInitializer :: MonadBuild m => ControlNode -> m () +addInitializer (ControlNode i) = build $ initializationNodes %= (i:) + +-- | Produce a GraphDef proto representation of the nodes that are rendered in +-- the given 'Build' action. +asGraphDef :: Build a -> GraphDef +asGraphDef b = def & node .~ gs ^. nodeBuffer + where + gs = snd $ runIdentity $ runBuildT b + +-- TODO: check against existing nodes for conflicts? +addGraphDef :: MonadBuild m => GraphDef -> m () +addGraphDef g = build $ nodeBuffer <>= g ^. node + +-- | Render the given op if it hasn't been rendered already, and return its +-- name. +getOrAddOp :: OpDef -> Build NodeName +getOrAddOp o = do + pending <- getPendingNode o + uses renderedNodes (Map.lookup pending) >>= \case + Just n -> return $ NodeName $ n ^. name + Nothing -> addNewOpFromPending pending + +lookupNode :: NodeName -> Build NodeDef +lookupNode n = uses renderedNodeDefs (Map.lookup n) >>= \case + Just n' -> return n' + Nothing -> error $ "lookupNode: unknown node name " ++ show n + +-- | Add a new node for a given 'OpDef'. This is used for making "stateful" ops +-- which are not safe to dedup (e.g, "variable" and "assign"). +addNewOp :: OpDef -> Build NodeName +addNewOp o = getPendingNode o >>= addNewOpFromPending + +addNewOpFromPending :: PendingNode -> Build NodeName +addNewOpFromPending pending = do + nodeName <- renderPendingNode pending + let nodeDef = pendingNodeDef pending & name .~ unNodeName nodeName + nodeBuffer %= (nodeDef :) + renderedNodes %= Map.insert pending nodeDef + renderedNodeDefs %= Map.insert nodeName nodeDef + return nodeName + +-- | Get the pending node corresponding to an OpDef, which may or may not have +-- been rendered before. Implicitly renders all of this node's inputs. +getPendingNode :: OpDef -> Build PendingNode +getPendingNode o = do + -- An empty string in the proto field means that no specific + -- device is specified. + dev <- maybe "" deviceName <$> use defaultDevice + scope <- use currentScope + controls <- use defaultControlInputs + let inputs = map encodeOutput (o ^. opInputs) + let controlInputs + = map makeDep (o ^. opControlInputs ++ Set.toList controls) + return $ PendingNode scope (o ^. opName) + $ def & op .~ (unOpType (o ^. opType) :: Text) + & attr .~ _opAttrs o + & input .~ (inputs ++ controlInputs) + & device .~ dev + where + makeDep = ("^" <>) . unNodeName + +-- | Pick a name for a pending node. If it has an explicit name, just use that; +-- if the name is implicit, assign a new unique name based on the op type. +renderPendingNode :: PendingNode -> Build NodeName +renderPendingNode (PendingNode scope pendingName nodeDef) + = NodeName . (scopePrefix <>) <$> getName + where + scopePrefix = Text.concat $ fmap ((<> "/") . unScope) scope + getName = case pendingName of + ExplicitName n -> return n + ImplicitName -> do + u@(Unique k) <- use nextUnique + nextUnique .= succ u + return $ nodeDef ^. op <> "_" <> Text.pack (show k) + +-- | Turn an 'Output' into a string representation for the TensorFlow +-- foreign APIs. +encodeOutput :: Output -> Text +encodeOutput (Output (OutputIx 0) n) = unNodeName n +encodeOutput (Output (OutputIx i) n) = unNodeName n <> Text.pack (':' : show i) + +-- | Modify some part of the state, run an action, and restore the state +-- after that action is done. +withStateLens :: MonadBuild m => Lens' GraphState a -> (a -> a) -> m b -> m b +withStateLens accessor f act = do + old <- build $ use accessor + build $ accessor %= f + result <- act + build $ accessor .= old + return result + +-- | Set a device for all nodes rendered in the given 'Build' action +-- (unless further overridden by another use of withDevice). +withDevice :: MonadBuild m => Maybe Device -> m a -> m a +withDevice d = withStateLens defaultDevice (const d) + +-- | Prepend a scope to all nodes rendered in the given 'Build' action. +withNameScope :: MonadBuild m => Text -> m a -> m a +withNameScope s = withStateLens currentScope (Scope s :) + +-- | Add control inputs to all nodes rendered in the given 'Build' action. +withNodeDependencies :: MonadBuild m => Set NodeName -> m a -> m a +withNodeDependencies nodes = withStateLens defaultControlInputs (<> nodes) diff --git a/src/TensorFlow/BuildOp.hs b/src/TensorFlow/BuildOp.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/BuildOp.hs @@ -0,0 +1,306 @@ +-- 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 FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module TensorFlow.BuildOp + ( BuildResult(..) + , buildOp + , PureResult(..) + , pureOp + , eqLengthGuard + , BuildInputs(..) + , OpParams + ) + where + +import Control.Monad (liftM2, replicateM) +import Control.Monad.Reader (ReaderT, runReaderT, ask) +import Control.Monad.State.Strict (State, evalState, get, put) +import Data.Int (Int64) + +import TensorFlow.Build +import TensorFlow.Output +import TensorFlow.Tensor +import TensorFlow.Types + +data ResultState = ResultState !OutputIx [Int64] deriving Show + +type Result = ReaderT NodeName (State ResultState) + +-- | Class of types that can be used as op outputs. +class BuildResult a where + buildResult :: Result a + +instance (BuildResult a1, BuildResult a2) => BuildResult (a1, a2) where + buildResult = (,) <$> buildResult <*> buildResult + +instance (BuildResult a1, BuildResult a2, BuildResult a3) => BuildResult (a1, a2, a3) where + buildResult = (,,) <$> buildResult <*> buildResult <*> buildResult + +instance (BuildResult a1, BuildResult a2, BuildResult a3, BuildResult a4) + => BuildResult (a1, a2, a3, a4) where + buildResult = (,,,) <$> buildResult <*> buildResult <*> buildResult <*> buildResult + +instance (BuildResult a1, BuildResult a2, BuildResult a3, BuildResult a4, BuildResult a5) + => BuildResult (a1, a2, a3, a4, a5) where + buildResult = (,,,,) <$> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + +instance ( BuildResult a1 + , BuildResult a2 + , BuildResult a3 + , BuildResult a4 + , BuildResult a5 + , BuildResult a6 + ) + => BuildResult (a1, a2, a3, a4, a5, a6) where + buildResult = (,,,,,) + <$> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + +instance ( BuildResult a1 + , BuildResult a2 + , BuildResult a3 + , BuildResult a4 + , BuildResult a5 + , BuildResult a6 + , BuildResult a7 + ) + => BuildResult (a1, a2, a3, a4, a5, a6, a7) where + buildResult = (,,,,,,) + <$> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + +instance ( BuildResult a1 + , BuildResult a2 + , BuildResult a3 + , BuildResult a4 + , BuildResult a5 + , BuildResult a6 + , BuildResult a7 + , BuildResult a8 + ) + => BuildResult (a1, a2, a3, a4, a5, a6, a7, a8) where + buildResult = (,,,,,,,) + <$> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + <*> buildResult + +recordResult :: Result Output +recordResult = do + o <- ask + ResultState i ns <- get + put $! ResultState (i+1) ns + return $! output i o + +instance Rendered v => BuildResult (Tensor v a) where + buildResult = Tensor . pure <$> recordResult + +instance BuildResult ControlNode where + buildResult = ControlNode <$> ask + +instance (Rendered v, TensorTypes as) => BuildResult (TensorList v as) where + buildResult = loop (tensorTypes :: TensorTypeList as) + where + loop :: TensorTypeList bs -> Result (TensorList v bs) + loop Nil = return Nil + loop (TensorTypeProxy :/ ls) = do + t <- buildResult + ts <- loop ls + return (t :/ ts) + +instance BuildResult a => BuildResult [a] where + buildResult = do + ResultState i ns <- get + case ns of + [] -> error $ "Ran out of counts in buildResult. " ++ + "Likely misuse of buildOp." + (n : rest) -> do + put $! ResultState i rest + replicateM (fromIntegral n) buildResult + +buildOp :: BuildResult a => [Int64] -> OpDef -> Build a +buildOp sizes o = do + n <- addNewOp o + return $ flip evalState (ResultState 0 sizes) (runReaderT buildResult n) + +-- | Returns true if all the integers in each tuple are identical. +-- Throws an error with a descriptive message if not. +eqLengthGuard :: [(String, [(String, Int)])] -> Bool +eqLengthGuard = all eachOk + where + eachOk (_, []) = True + -- The next line has (== 1) . length . nub in disguise + eachOk (numberAttrName, pairs@((_, x) : zs)) = all (\z -> snd z == x) zs || + error ("number_attr " ++ numberAttrName ++ + " contains tensors with different length " ++ show pairs) + +----------- + + +-- | Class of types that can be used as op outputs. +class PureResult a where + pureResult :: ReaderT (Build OpDef) (State ResultState) a + +instance PureResult (Tensor Build a) where + pureResult = do + ResultState i ns <- get + put $! ResultState (i+1) ns + makeOp <- ask + return $ Tensor $ do + o <- makeOp + -- TODO: unify with BuildResult (Tensor v) + output i <$> getOrAddOp o + +instance (PureResult a1, PureResult a2) => PureResult (a1, a2) where + pureResult = (,) <$> pureResult <*> pureResult + +instance (PureResult a1, PureResult a2, PureResult a3) => PureResult (a1, a2, a3) where + pureResult = (,,) <$> pureResult <*> pureResult <*> pureResult + +instance (PureResult a1, PureResult a2, PureResult a3, PureResult a4) + => PureResult (a1, a2, a3, a4) where + pureResult = (,,,) <$> pureResult <*> pureResult <*> pureResult <*> pureResult + +instance (PureResult a1, PureResult a2, PureResult a3, PureResult a4, PureResult a5) + => PureResult (a1, a2, a3, a4, a5) where + pureResult = (,,,,) <$> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + +instance ( PureResult a1 + , PureResult a2 + , PureResult a3 + , PureResult a4 + , PureResult a5 + , PureResult a6 + ) + => PureResult (a1, a2, a3, a4, a5, a6) where + pureResult = (,,,,,) + <$> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + +instance ( PureResult a1 + , PureResult a2 + , PureResult a3 + , PureResult a4 + , PureResult a5 + , PureResult a6 + , PureResult a7 + ) + => PureResult (a1, a2, a3, a4, a5, a6, a7) where + pureResult = (,,,,,,) + <$> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + +instance ( PureResult a1 + , PureResult a2 + , PureResult a3 + , PureResult a4 + , PureResult a5 + , PureResult a6 + , PureResult a7 + , PureResult a8 + ) + => PureResult (a1, a2, a3, a4, a5, a6, a7, a8) where + pureResult = (,,,,,,,) + <$> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + <*> pureResult + +instance PureResult a => PureResult [a] where + pureResult = do + ResultState i ns <- get + case ns of + [] -> error $ "Ran out of counts in pureResult. " ++ + "Likely misuse of pureOp with output lists." + n : rest -> do + put $! ResultState i rest + replicateM (fromIntegral n) pureResult + +instance TensorTypes as => PureResult (TensorList Build as) where + pureResult = loop (tensorTypes :: TensorTypeList as) + where + loop :: TensorTypeList bs -> ReaderT (Build OpDef) (State ResultState) + (TensorList Build bs) + loop Nil = return Nil + loop (TensorTypeProxy :/ ls) = do + t <- pureResult + ts <- loop ls + return (t :/ ts) + +pureOp :: PureResult a => [Int64] -> Build OpDef -> a +pureOp sizes o = flip evalState (ResultState 0 sizes) (runReaderT pureResult o) + +----- +-- Class of types that can be used as arguments + +class BuildInputs a where + buildInputs :: a -> Build [Output] + +instance BuildInputs a => BuildInputs [a] where + buildInputs = fmap concat . mapM buildInputs + +instance BuildInputs (Tensor v a) where + buildInputs (Tensor t) = do + o <- toBuild t + return [o] + +instance BuildInputs (ListOf (Tensor v) as) where + buildInputs Nil = return [] + buildInputs (t :/ ts) = liftM2 (++) (buildInputs t) (buildInputs ts) + +---- + +-- | Parameters to build an op (for example, the node name or optional attributes). +-- TODO: be more type safe. +type OpParams = OpDef -> OpDef diff --git a/src/TensorFlow/ControlFlow.hs b/src/TensorFlow/ControlFlow.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/ControlFlow.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 GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TensorFlow.ControlFlow + ( -- * Dependencies + withControlDependencies + , group + -- * Operations + , noOp + ) where + +import TensorFlow.BuildOp +import TensorFlow.Build +import TensorFlow.Nodes + +-- | Modify a 'Build' action, such that all new ops rendered in it will depend +-- on the nodes in the first argument. +withControlDependencies :: (MonadBuild m, Nodes t) => t -> m a -> m a +withControlDependencies deps act = do + nodes <- build $ getNodes deps + withNodeDependencies nodes act + +-- TODO(judahjacobson): Reimplement withDependencies. + +-- | Create an op that groups multiple operations. +-- +-- When this op finishes, all ops in the input @n@ have finished. This op has +-- no output. +group :: (MonadBuild m, Nodes t) => t -> m ControlNode +group deps = withControlDependencies deps noOp + +-- | Does nothing. Only useful as a placeholder for control edges. +noOp :: MonadBuild m => m ControlNode +noOp = build $ buildOp [] $ opDef "NoOp" diff --git a/src/TensorFlow/Core.hs b/src/TensorFlow/Core.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Core.hs @@ -0,0 +1,92 @@ +-- 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 ExplicitNamespaces #-} + +-- | The core functionality of TensorFlow. +-- +-- Unless you are defining ops, you do not need to import other modules from +-- this package. +-- +-- Basic ops are provided in the tensorflow-ops and tensorflow-core-ops +-- packages. +module TensorFlow.Core + ( -- * Session + Session + , Options + , sessionConfig + , sessionTarget + , sessionTracer + , runSession + , runSessionWithOptions + -- ** Building graphs + , MonadBuild(..) + -- ** Running graphs + , Fetchable + , Nodes + , run + , run_ + , Feed + , feed + , runWithFeeds + , runWithFeeds_ + -- ** Async + , asyncProdNodes + + -- * Build + , Build + , BuildT + , render + , asGraphDef + , addGraphDef + , opName + , opAttr + , addInitializer + -- * Tensor + , ControlNode + , Tensor + , Value + , Ref + , value + , tensorFromName + , expr + -- ** Element types + , TensorType + , TensorData + , TensorDataType(decodeTensorData, encodeTensorData) + , ResourceHandle + , Scalar(..) + , Shape(..) + , OneOf + , type (/=) + + -- * Op combinators + , colocateWith + , Device(..) + , withDevice + , withNameScope + -- ** Dependencies + , withControlDependencies + , group + -- ** Misc + , noOp + ) where + +import TensorFlow.Build +import TensorFlow.ControlFlow +import TensorFlow.Nodes +import TensorFlow.Output +import TensorFlow.Session +import TensorFlow.Tensor +import TensorFlow.Types diff --git a/src/TensorFlow/Internal/FFI.hs b/src/TensorFlow/Internal/FFI.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Internal/FFI.hs @@ -0,0 +1,264 @@ +-- 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 DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TensorFlow.Internal.FFI + ( TensorFlowException(..) + , Raw.Session + , withSession + , extendGraph + , run + , TensorData(..) + , setSessionConfig + , setSessionTarget + , getAllOpList + -- * Internal helper. + , useProtoAsVoidPtrLen + ) + where + +import Control.Concurrent.Async (Async, async, cancel, waitCatch) +import Control.Concurrent.MVar (MVar, modifyMVarMasked_, newMVar, takeMVar) +import Control.Exception (Exception, throwIO, bracket, finally, mask_) +import Control.Monad (when) +import Data.Bits (Bits, toIntegralSized) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Foreign (Ptr, FunPtr, nullPtr, castPtr) +import Foreign.C.String (CString) +import Foreign.ForeignPtr (newForeignPtr, newForeignPtr_, withForeignPtr) +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (withArrayLen, peekArray, mallocArray, copyArray) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T +import qualified Data.Vector.Storable as S +import qualified Data.Vector.Storable.Mutable as M + +import Data.ProtoLens (Message, encodeMessage) +import Proto.Tensorflow.Core.Framework.Graph (GraphDef) +import Proto.Tensorflow.Core.Framework.Types (DataType(..)) +import Proto.Tensorflow.Core.Protobuf.Config (ConfigProto) + +import qualified TensorFlow.Internal.Raw as Raw + +data TensorFlowException = TensorFlowException Raw.Code T.Text + deriving (Show, Eq, Typeable) + +instance Exception TensorFlowException + +-- | All of the data needed to represent a tensor. +data TensorData = TensorData + { tensorDataDimensions :: [Int64] + , tensorDataType :: !DataType + , tensorDataBytes :: !(S.Vector Word8) + } + deriving (Show, Eq) + +-- | Runs the given action after creating a session with options +-- populated by the given optionSetter. +withSession :: (Raw.SessionOptions -> IO ()) + -> ((IO () -> IO ()) -> Raw.Session -> IO a) + -- ^ The action can spawn concurrent tasks which will + -- be canceled before withSession returns. + -> IO a +withSession optionSetter action = do + drain <- newMVar [] + let cleanup s = + -- Closes the session to nudge the pending run calls to fail and exit. + finally (checkStatus (Raw.closeSession s)) $ do + runners <- takeMVar drain + -- Collects all runners before deleting the session. + mapM_ shutDownRunner runners + checkStatus (Raw.deleteSession s) + bracket Raw.newSessionOptions Raw.deleteSessionOptions $ \options -> do + optionSetter options + bracket + (checkStatus (Raw.newSession options)) + cleanup + (action (asyncCollector drain)) + +asyncCollector :: MVar [Async ()] -> IO () -> IO () +asyncCollector drain runner = modifyMVarMasked_ drain launchAndRecord + where + launchAndRecord restRunners = (: restRunners) <$> async runner + +shutDownRunner :: Async () -> IO () +shutDownRunner r = do + cancel r + -- TODO(gnezdo): manage exceptions better than print. + either print (const (return ())) =<< waitCatch r + +extendGraph :: Raw.Session -> GraphDef -> IO () +extendGraph session pb = + useProtoAsVoidPtrLen pb $ \ptr len -> + checkStatus $ Raw.extendGraph session ptr len + + +run :: Raw.Session + -> [(B.ByteString, TensorData)] -- ^ Feeds. + -> [B.ByteString] -- ^ Fetches. + -> [B.ByteString] -- ^ Targets. + -> IO [TensorData] +run session feeds fetches targets = do + let nullTensor = Raw.Tensor nullPtr + -- Use mask to avoid leaking input tensors before they are passed to 'run' + -- and output tensors before they are passed to 'createTensorData'. + mask_ $ + -- Feeds + withStringArrayLen (fst <$> feeds) $ \feedsLen feedNames -> + mapM (createRawTensor . snd) feeds >>= \feedTensors -> + withArrayLen feedTensors $ \_ cFeedTensors -> + -- Fetches. + withStringArrayLen fetches $ \fetchesLen fetchNames -> + -- tensorOuts is an array of null Tensor pointers that will be filled + -- by the call to Raw.run. + withArrayLen (replicate fetchesLen nullTensor) $ \_ tensorOuts -> + -- Targets. + withStringArrayLen targets $ \targetsLen ctargets -> do + checkStatus $ Raw.run + session + nullPtr + feedNames cFeedTensors (safeConvert feedsLen) + fetchNames tensorOuts (safeConvert fetchesLen) + ctargets (safeConvert targetsLen) + nullPtr + mapM_ Raw.deleteTensor feedTensors + outTensors <- peekArray fetchesLen tensorOuts + mapM createTensorData outTensors + + +-- Internal. + + +-- | Same as 'fromIntegral', but throws an error if conversion is "lossy". +safeConvert :: + forall a b. (Show a, Show b, Bits a, Bits b, Integral a, Integral b) + => a -> b +safeConvert x = + fromMaybe + (error ("Failed to convert " ++ show x ++ ", got " ++ + show (fromIntegral x :: b))) + (toIntegralSized x) + + +-- | Use a list of ByteString as a list of CString. +withStringList :: [B.ByteString] -> ([CString] -> IO a) -> IO a +withStringList strings fn = go strings [] + where + go [] cs = fn (reverse cs) + -- TODO(fmayle): Is it worth using unsafeAsCString here? + go (x:xs) cs = B.useAsCString x $ \c -> go xs (c:cs) + + +-- | Use a list of ByteString as an array of CString. +withStringArrayLen :: [B.ByteString] -> (Int -> Ptr CString -> IO a) -> IO a +withStringArrayLen xs fn = withStringList xs (`withArrayLen` fn) + + +-- | Create a Raw.Tensor from a TensorData. +createRawTensor :: TensorData -> IO Raw.Tensor +createRawTensor (TensorData dims dt byteVec) = + withArrayLen (map safeConvert dims) $ \cdimsLen cdims -> do + let len = S.length byteVec + dest <- mallocArray len + S.unsafeWith byteVec $ \x -> copyArray dest x len + Raw.newTensor (toEnum $ fromEnum dt) + cdims (safeConvert cdimsLen) + (castPtr dest) (safeConvert len) + tensorDeallocFunPtr nullPtr + +{-# NOINLINE tensorDeallocFunPtr #-} +tensorDeallocFunPtr :: FunPtr Raw.TensorDeallocFn +tensorDeallocFunPtr = unsafePerformIO $ Raw.wrapTensorDealloc $ \x _ _ -> free x + +-- | Create a TensorData from a Raw.Tensor. +-- +-- Takes ownership of the Raw.Tensor. +-- TODO: Currently, it just makes a copy of the Tensor (and then deletes it), +-- since the raw pointer may refer to storage inside a mutable TensorFlow +-- variable. We should avoid that copy when it's not needed; for example, +-- by making TensorData wrap an IOVector, and changing the code that uses it. +createTensorData :: Raw.Tensor -> IO TensorData +createTensorData t = do + -- Read dimensions. + numDims <- Raw.numDims t + dims <- mapM (Raw.dim t) [0..numDims-1] + -- Read type. + dtype <- toEnum . fromEnum <$> Raw.tensorType t + -- Read data. + len <- safeConvert <$> Raw.tensorByteSize t + bytes <- castPtr <$> Raw.tensorData t :: IO (Ptr Word8) + fp <- newForeignPtr_ bytes + -- Make an explicit copy of the raw data, since it might point + -- to a mutable variable's memory. + v <- S.freeze (M.unsafeFromForeignPtr0 fp len) + Raw.deleteTensor t + return $ TensorData (map safeConvert dims) dtype v + +-- | Runs the given action which does FFI calls updating a provided +-- status object. If the status is not OK it is thrown as +-- TensorFlowException. +checkStatus :: (Raw.Status -> IO a) -> IO a +checkStatus fn = + bracket Raw.newStatus Raw.deleteStatus $ \status -> do + result <- fn status + code <- Raw.getCode status + when (code /= Raw.TF_OK) $ do + msg <- T.decodeUtf8With T.lenientDecode <$> + (Raw.message status >>= B.packCString) + throwIO $ TensorFlowException code msg + return result + +setSessionConfig :: ConfigProto -> Raw.SessionOptions -> IO () +setSessionConfig pb opt = + useProtoAsVoidPtrLen pb $ \ptr len -> + checkStatus (Raw.setConfig opt ptr len) + +setSessionTarget :: B.ByteString -> Raw.SessionOptions -> IO () +setSessionTarget target = B.useAsCString target . Raw.setTarget + +-- | Serializes the given msg and provides it as (ptr,len) argument +-- to the given action. +useProtoAsVoidPtrLen :: (Message msg, Integral c, Show c, Bits c) => + msg -> (Ptr b -> c -> IO a) -> IO a +useProtoAsVoidPtrLen msg f = B.useAsCStringLen (encodeMessage msg) $ + \(bytes, len) -> f (castPtr bytes) (safeConvert len) + +-- | Returns the serialized OpList of all OpDefs defined in this +-- address space. +getAllOpList :: IO B.ByteString +getAllOpList = do + foreignPtr <- + mask_ (newForeignPtr Raw.deleteBuffer =<< checkCall) + -- Makes a copy because it is more reliable than eviscerating + -- Buffer to steal its memory (including custom deallocator). + withForeignPtr foreignPtr $ + \ptr -> B.packCStringLen =<< (,) + <$> (castPtr <$> Raw.getBufferData ptr) + <*> (safeConvert <$> Raw.getBufferLength ptr) + where + checkCall = do + p <- Raw.getAllOpList + when (p == nullPtr) (throwIO exception) + return p + exception = TensorFlowException + Raw.TF_UNKNOWN "GetAllOpList failure, check logs" diff --git a/src/TensorFlow/Internal/Raw.chs b/src/TensorFlow/Internal/Raw.chs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Internal/Raw.chs @@ -0,0 +1,158 @@ +-- 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 ForeignFunctionInterface #-} + +module TensorFlow.Internal.Raw where + +#include "third_party/tensorflow/c/c_api.h" + +import Foreign +import Foreign.C + +{#enum TF_DataType as DataType {} deriving (Show, Eq) #} +{#enum TF_Code as Code {} deriving (Show, Eq) #} + + +-- Status. +{#pointer *TF_Status as Status newtype #} + +newStatus :: IO Status +newStatus = {# call TF_NewStatus as ^ #} + +deleteStatus :: Status -> IO () +deleteStatus = {# call TF_DeleteStatus as ^ #} + +setStatus :: Status -> Code -> CString -> IO () +setStatus s c = {# call TF_SetStatus as ^ #} s (fromIntegral $ fromEnum c) + +getCode :: Status -> IO Code +getCode s = toEnum . fromIntegral <$> {# call TF_GetCode as ^ #} s + +message :: Status -> IO CString +message = {# call TF_Message as ^ #} + + +-- Buffer. +data Buffer +{#pointer *TF_Buffer as BufferPtr -> Buffer #} + +getBufferData :: BufferPtr -> IO (Ptr ()) +getBufferData = {#get TF_Buffer->data #} + +getBufferLength :: BufferPtr -> IO CULong +getBufferLength ={#get TF_Buffer->length #} + +-- Tensor. +{#pointer *TF_Tensor as Tensor newtype #} + +instance Storable Tensor where + sizeOf (Tensor t) = sizeOf t + alignment (Tensor t) = alignment t + peek p = fmap Tensor (peek (castPtr p)) + poke p (Tensor t) = poke (castPtr p) t + +-- A synonym for the int64_t type, which is used in the TensorFlow API. +-- On some platforms it's `long`; on others (e.g., Mac OS X) it's `long long`; +-- and as far as Haskell is concerned, those are distinct types (`CLong` vs +-- `CLLong`). +type CInt64 = {#type int64_t #} + +newTensor :: DataType + -> Ptr CInt64 -- dimensions array + -> CInt -- num dimensions + -> Ptr () -- data + -> CULong -- data len + -> FunPtr (Ptr () -> CULong -> Ptr () -> IO ()) -- deallocator + -> Ptr () -- deallocator arg + -> IO Tensor +newTensor dt = {# call TF_NewTensor as ^ #} (fromIntegral $ fromEnum dt) + +deleteTensor :: Tensor -> IO () +deleteTensor = {# call TF_DeleteTensor as ^ #} + +tensorType :: Tensor -> IO DataType +tensorType t = toEnum . fromIntegral <$> {# call TF_TensorType as ^ #} t + +numDims :: Tensor -> IO CInt +numDims = {# call TF_NumDims as ^ #} + +dim :: Tensor -> CInt -> IO CInt64 +dim = {# call TF_Dim as ^ #} + +tensorByteSize :: Tensor -> IO CULong +tensorByteSize = {# call TF_TensorByteSize as ^ #} + +tensorData :: Tensor -> IO (Ptr ()) +tensorData = {# call TF_TensorData as ^ #} + + +-- Session Options. +{# pointer *TF_SessionOptions as SessionOptions newtype #} + +newSessionOptions :: IO SessionOptions +newSessionOptions = {# call TF_NewSessionOptions as ^ #} + +setTarget :: SessionOptions -> CString -> IO () +setTarget = {# call TF_SetTarget as ^ #} + +setConfig :: SessionOptions -> Ptr () -> CULong -> Status -> IO () +setConfig = {# call TF_SetConfig as ^ #} + +deleteSessionOptions :: SessionOptions -> IO () +deleteSessionOptions = {# call TF_DeleteSessionOptions as ^ #} + + +-- Session. +{# pointer *TF_DeprecatedSession as Session newtype #} + +newSession :: SessionOptions -> Status -> IO Session +newSession = {# call TF_NewDeprecatedSession as ^ #} + +closeSession :: Session -> Status -> IO () +closeSession = {# call TF_CloseDeprecatedSession as ^ #} + +deleteSession :: Session -> Status -> IO () +deleteSession = {# call TF_DeleteDeprecatedSession as ^ #} + +extendGraph :: Session -> Ptr () -> CULong -> Status -> IO () +extendGraph = {# call TF_ExtendGraph as ^ #} + +run :: Session + -> BufferPtr -- RunOptions proto. + -> Ptr CString -> Ptr Tensor -> CInt -- Input (names, tensors, count). + -> Ptr CString -> Ptr Tensor -> CInt -- Output (names, tensors, count). + -> Ptr CString -> CInt -- Target nodes (names, count). + -> BufferPtr -- RunMetadata proto. + -> Status + -> IO () +run = {# call TF_Run as ^ #} + +-- FFI helpers. +type TensorDeallocFn = Ptr () -> CULong -> Ptr () -> IO () +foreign import ccall "wrapper" + wrapTensorDealloc :: TensorDeallocFn -> IO (FunPtr TensorDeallocFn) + + +-- | Get the OpList of all OpDefs defined in this address space. +-- Returns a BufferPtr, ownership of which is transferred to the caller +-- (and can be freed using deleteBuffer). +-- +-- The data in the buffer will be the serialized OpList proto for ops registered +-- in this address space. +getAllOpList :: IO BufferPtr +getAllOpList = {# call TF_GetAllOpList as ^ #} + +foreign import ccall "&TF_DeleteBuffer" + deleteBuffer :: FunPtr (BufferPtr -> IO ()) diff --git a/src/TensorFlow/Internal/VarInt.hs b/src/TensorFlow/Internal/VarInt.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Internal/VarInt.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 BangPatterns #-} + +{-| +Module : TensorFlow.Internal.VarInt +Description : Encoders and decoders for varint types. + +Originally taken from internal proto-lens code. +-} +module TensorFlow.Internal.VarInt + ( getVarInt + , putVarInt + ) where + +import Data.Attoparsec.ByteString as Parse +import Data.Bits +import Data.ByteString.Lazy.Builder as Builder +import Data.Monoid ((<>)) +import Data.Word (Word64) + +-- | Decode an unsigned varint. +getVarInt :: Parser Word64 +getVarInt = loop 1 0 + where + loop !s !n = do + b <- anyWord8 + let n' = n + s * fromIntegral (b .&. 127) + if (b .&. 128) == 0 + then return n' + else loop (128*s) n' + +-- | Encode a Word64. +putVarInt :: Word64 -> Builder +putVarInt n + | n < 128 = Builder.word8 (fromIntegral n) + | otherwise = Builder.word8 (fromIntegral $ n .&. 127 .|. 128) + <> putVarInt (n `shiftR` 7) diff --git a/src/TensorFlow/Nodes.hs b/src/TensorFlow/Nodes.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Nodes.hs @@ -0,0 +1,140 @@ +-- 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 FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- For Fetchable (TensorExpr a) +module TensorFlow.Nodes where + +import Control.Applicative (liftA2, liftA3) +import Data.Functor.Identity (Identity) +import Data.Map.Strict (Map) +import Data.Monoid ((<>)) +import Data.Set (Set) +import Data.Text (Text) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import TensorFlow.Build +import TensorFlow.Output +import TensorFlow.Tensor +import TensorFlow.Types +import qualified TensorFlow.Internal.FFI as FFI + +-- | Types that contain ops which can be run. +class Nodes t where + getNodes :: t -> Build (Set NodeName) + +-- | Types that tensor representations (e.g. 'Tensor', 'ControlNode') can be +-- fetched into. +-- +-- Includes collections of tensors (e.g. tuples). +class Nodes t => Fetchable t a where + getFetch :: t -> Build (Fetch a) + +-- | Fetch action. Keeps track of what needs to be fetched and how to decode +-- the fetched data. +data Fetch a = Fetch + { -- | Nodes to fetch + fetches :: Set Text + -- | Function to create an 'a' from the fetched data. + , fetchRestore :: Map Text FFI.TensorData -> a + } + +instance Functor Fetch where + fmap f (Fetch fetch restore) = Fetch fetch (f . restore) + +instance Applicative Fetch where + pure x = Fetch Set.empty (const x) + Fetch fetch restore <*> Fetch fetch' restore' = + Fetch (fetch <> fetch') (restore <*> restore') + +nodesUnion :: (Monoid b, Traversable t, Applicative f) => t (f b) -> f b +nodesUnion = fmap (foldMap id) . sequenceA + +instance (Nodes t1, Nodes t2) => Nodes (t1, t2) where + getNodes (x, y) = nodesUnion [getNodes x, getNodes y] + +instance (Nodes t1, Nodes t2, Nodes t3) => Nodes (t1, t2, t3) where + getNodes (x, y, z) = nodesUnion [getNodes x, getNodes y, getNodes z] + +instance (Fetchable t1 a1, Fetchable t2 a2) => Fetchable (t1, t2) (a1, a2) where + getFetch (x, y) = liftA2 (,) <$> getFetch x <*> getFetch y + +instance (Fetchable t1 a1, Fetchable t2 a2, Fetchable t3 a3) + => Fetchable (t1, t2, t3) (a1, a2, a3) where + getFetch (x, y, z) = + liftA3 (,,) <$> getFetch x <*> getFetch y <*> getFetch z + +instance Nodes t => Nodes [t] where + getNodes = nodesUnion . map getNodes + +instance Fetchable t a => Fetchable [t] [a] where + getFetch ts = sequenceA <$> mapM getFetch ts + +instance Nodes ControlNode where + getNodes (ControlNode o) = pure $ Set.singleton o + +-- We use the constraint @(a ~ ())@ to help with type inference. For example, +-- if @t :: ControlNode@, then this constraint ensures that @run t :: Session +-- ()@. If we used @instance Fetchable ControlNode ()@ instead, then that +-- expression would be ambiguous without explicitly specifying the return type. +instance a ~ () => Fetchable ControlNode a where + getFetch _ = return $ pure () + +instance Nodes (ListOf f '[]) where + getNodes _ = return Set.empty + +instance (Nodes (f a), Nodes (ListOf f as)) => Nodes (ListOf f (a ': as)) where + getNodes (x :/ xs) = liftA2 Set.union (getNodes x) (getNodes xs) + +instance l ~ List '[] => Fetchable (ListOf f '[]) l where + getFetch _ = return $ pure Nil + +instance (Fetchable (f t) a, Fetchable (ListOf f ts) (List as), i ~ Identity) + => Fetchable (ListOf f (t ': ts)) (ListOf i (a ': as)) where + getFetch (x :/ xs) = liftA2 (\y ys -> y /:/ ys) <$> getFetch x <*> getFetch xs + +instance Nodes (Tensor v a) where + getNodes (Tensor o) = Set.singleton . outputNodeName <$> toBuild o + +fetchTensorVector :: forall a v . (TensorType a) + => Tensor v a -> Build (Fetch (TensorData a)) +fetchTensorVector (Tensor o) = do + outputName <- encodeOutput <$> toBuild o + pure $ Fetch (Set.singleton outputName) $ \tensors -> + let tensorData = tensors Map.! outputName + expectedType = tensorType (undefined :: a) + actualType = FFI.tensorDataType tensorData + badTypeError = error $ "Bad tensor type: expected " + ++ show expectedType + ++ ", got " + ++ show actualType + in if expectedType /= actualType + then badTypeError + else TensorData tensorData + +-- The constraint "a ~ a'" means that the input/output of fetch can constrain +-- the TensorType of each other. +instance (TensorType a, a ~ a') => Fetchable (Tensor v a) (TensorData a') where + getFetch = fetchTensorVector + +instance (TensorType a, TensorDataType s a, a ~ a') => Fetchable (Tensor v a) (s a') where + getFetch t = fmap decodeTensorData <$> fetchTensorVector t diff --git a/src/TensorFlow/Orphans.hs b/src/TensorFlow/Orphans.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Orphans.hs @@ -0,0 +1,46 @@ +-- 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 StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Orphan instances for certain proto messages/enums, used internally. +-- TODO(judahjacobson): consider making proto-lens generate some or all of +-- these automatically; or, alternately, make new Haskell datatypes. +module TensorFlow.Orphans() where + +import Proto.Tensorflow.Core.Framework.AttrValue + ( AttrValue(..) + , AttrValue'ListValue(..) + , NameAttrList(..) + ) +import Proto.Tensorflow.Core.Framework.NodeDef + ( NodeDef(..)) +import Proto.Tensorflow.Core.Framework.ResourceHandle + ( ResourceHandle(..)) +import Proto.Tensorflow.Core.Framework.Tensor + (TensorProto(..)) +import Proto.Tensorflow.Core.Framework.TensorShape + (TensorShapeProto(..), TensorShapeProto'Dim(..)) +import Proto.Tensorflow.Core.Framework.Types (DataType(..)) + +deriving instance Ord AttrValue +deriving instance Ord AttrValue'ListValue +deriving instance Ord DataType +deriving instance Ord NameAttrList +deriving instance Ord NodeDef +deriving instance Ord ResourceHandle +deriving instance Ord TensorProto +deriving instance Ord TensorShapeProto +deriving instance Ord TensorShapeProto'Dim diff --git a/src/TensorFlow/Output.hs b/src/TensorFlow/Output.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Output.hs @@ -0,0 +1,128 @@ +-- 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 GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TensorFlow.Output + ( ControlNode(..) + , Device(..) + -- * Ops + , NodeName(..) + , OpDef(..) + , opName + , opType + , opAttr + , opInputs + , opControlInputs + , OpType(..) + , OutputIx(..) + , Output(..) + , output + , PendingNodeName(..) + ) where + +import qualified Data.Map.Strict as Map +import Data.String (IsString(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Lens.Family2 (Lens') +import Lens.Family2.Unchecked (lens) +import Proto.Tensorflow.Core.Framework.AttrValue (AttrValue(..)) +import Data.Default (def) +import TensorFlow.Types (Attribute, attrLens) +import TensorFlow.Orphans () + +-- | A type of graph node which has no outputs. These nodes are +-- valuable for causing side effects when they are run. +newtype ControlNode = ControlNode { unControlNode :: NodeName } + +-- | The type of op of a node in the graph. This corresponds to the proto field +-- NodeDef.op. +newtype OpType = OpType { unOpType :: Text } + deriving (Eq, Ord, Show) + +instance IsString OpType where + fromString = OpType . Text.pack + +-- | An output of a TensorFlow node. +data Output = Output {outputIndex :: !OutputIx, outputNodeName :: !NodeName} + deriving (Eq, Ord, Show) + +output :: OutputIx -> NodeName -> Output +output = Output + +newtype OutputIx = OutputIx { unOutputIx :: Int } + deriving (Eq, Ord, Num, Enum, Show) + +-- | A device that a node can be assigned to. +-- There's a naming convention where the device names +-- are constructed from job and replica names. +newtype Device = Device {deviceName :: Text} + deriving (Eq, Ord, IsString) + +instance Show Device where + show (Device d) = show d + +-- | Op definition. This corresponds somewhat to the 'NodeDef' proto. +data OpDef = OpDef + { _opName :: !PendingNodeName + , _opType :: !OpType + , _opAttrs :: !(Map.Map Text AttrValue) + , _opInputs :: [Output] + , _opControlInputs :: [NodeName] + } deriving (Eq, Ord) + +-- | The name specified for an unrendered Op. If an Op has an +-- ImplicitName, it will be assigned based on the opType plus a +-- unique identifier. Does not contain the "scope" prefix. +data PendingNodeName = ExplicitName !Text | ImplicitName + deriving (Eq, Ord, Show) + +instance IsString PendingNodeName where + fromString = ExplicitName . fromString + +-- | The name of a node in the graph. This corresponds to the proto field +-- NodeDef.name. Includes the scope prefix (if any) and a unique identifier +-- (if the node was implicitly named). +newtype NodeName = NodeName { unNodeName :: Text } + deriving (Eq, Ord, Show) + +opName :: Lens' OpDef PendingNodeName +opName = lens _opName (\o x -> o {_opName = x}) + +opType :: Lens' OpDef OpType +opType = lens _opType (\o x -> o { _opType = x}) + +opAttr :: Attribute a => Text -> Lens' OpDef a +opAttr n = lens _opAttrs (\o x -> o {_opAttrs = x}) + . lens (Map.findWithDefault def n) (flip (Map.insert n)) + . attrLens + +opInputs :: Lens' OpDef [Output] +opInputs = lens _opInputs (\o x -> o {_opInputs = x}) + +opControlInputs :: Lens' OpDef [NodeName] +opControlInputs = lens _opControlInputs (\o x -> o {_opControlInputs = x}) + +-- TODO(gnezdo): IsString instance is weird and we should move that +-- code into a Build function +instance IsString Output where + fromString s = case break (==':') s of + (n, ':':ixStr) | [(ix, "" :: String)] <- read ixStr + -> Output (fromInteger ix) $ assigned n + _ -> Output 0 $ assigned s + where assigned = NodeName . Text.pack diff --git a/src/TensorFlow/Session.hs b/src/TensorFlow/Session.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Session.hs @@ -0,0 +1,211 @@ +-- 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 GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module TensorFlow.Session ( + Session, + Options, + sessionConfig, + sessionTarget, + sessionTracer, + runSession, + runSessionWithOptions, + MonadBuild(..), + extend, + addGraphDef, + run, + runWithFeeds, + run_, + runWithFeeds_, + asyncProdNodes, + ) where + +import Control.Monad (forever, unless, void) +import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT(..), ask, asks) +import Data.ByteString (ByteString) +import Data.Default (Default, def) +import Data.Monoid ((<>)) +import Data.ProtoLens (showMessage) +import Data.Set (Set) +import Data.Text.Encoding (encodeUtf8) +import Lens.Family2 (Lens', (^.), (&), (.~)) +import Lens.Family2.Unchecked (lens) +import Proto.Tensorflow.Core.Framework.Graph (GraphDef, node) +import Proto.Tensorflow.Core.Protobuf.Config (ConfigProto) +import TensorFlow.Build +import TensorFlow.Nodes +import TensorFlow.Output (NodeName, unNodeName) +import TensorFlow.Tensor + +import qualified Data.ByteString.Builder as Builder +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified TensorFlow.Internal.FFI as FFI + +-- | An action for logging. +type Tracer = Builder.Builder -> IO () + +-- Common state threaded through the session. +data SessionState + = SessionState { + rawSession :: FFI.Session + , asyncCollector :: IO () -> IO () + -- ^ Starts the given action concurrently. + , tracer :: Tracer + } + +newtype Session a + = Session (ReaderT SessionState (BuildT IO) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, + MonadMask) + +-- | Run 'Session' actions in a new TensorFlow session. +runSession :: Session a -> IO a +runSession = runSessionWithOptions def + +-- | Customization for session. Use the lenses to update: +-- 'sessionTarget', 'sessionTracer', 'sessionConfig'. +data Options = Options + { _sessionTarget :: ByteString + , _sessionConfig :: ConfigProto + , _sessionTracer :: Tracer + } + +instance Default Options where + def = Options + { _sessionTarget = "" + , _sessionConfig = def + , _sessionTracer = const (return ()) + } + +-- | Target can be: "local", ip:port, host:port. +-- The set of supported factories depends on the linked in libraries. +sessionTarget :: Lens' Options ByteString +sessionTarget = lens _sessionTarget (\g x -> g { _sessionTarget = x }) + +-- | Uses the specified config for the created session. +sessionConfig :: Lens' Options ConfigProto +sessionConfig = lens _sessionConfig (\g x -> g { _sessionConfig = x }) + +-- | Uses the given logger to monitor session progress. +sessionTracer :: Lens' Options Tracer +sessionTracer = lens _sessionTracer (\g x -> g { _sessionTracer = x }) + +-- | Run 'Session' actions in a new TensorFlow session created with +-- the given option setter actions ('sessionTarget', 'sessionConfig'). +runSessionWithOptions :: Options -> Session a -> IO a +runSessionWithOptions options (Session m) = + FFI.withSession applyOptions $ + \as rs -> + let initState = SessionState rs as (options ^. sessionTracer) + in evalBuildT (runReaderT m initState) + where applyOptions opt = do + FFI.setSessionTarget (options ^. sessionTarget) opt + FFI.setSessionConfig (options ^. sessionConfig) opt + +instance MonadBuild Session where + build = Session . lift . build + +-- | Add all pending rendered nodes to the TensorFlow graph and runs +-- any pending initializers. +-- +-- Note that run, runWithFeeds, etc. will all call this function implicitly. +extend :: Session () +extend = do + session <- Session (asks rawSession) + trace <- Session (asks tracer) + nodesToExtend <- build flushNodeBuffer + unless (null nodesToExtend) $ liftIO $ do + let graphDef = (def :: GraphDef) & node .~ nodesToExtend + trace ("Session.extend " <> Builder.string8 (showMessage graphDef)) + FFI.extendGraph session graphDef + -- Now that all the nodes are created, run the initializers. + initializers <- build flushInitializers + unless (null initializers) $ + void $ liftIO $ FFI.run session [] [] (toNodeNames initializers) + +-- | Run a subgraph 't', rendering any dependent nodes that aren't already +-- rendered, and fetch the corresponding values for 'a'. +run :: Fetchable t a => t -> Session a +run = runWithFeeds [] + +-- | Run a subgraph 't', rendering any dependent nodes that aren't already +-- rendered, feed the given input values, and fetch the corresponding result +-- values for 'a'. +runWithFeeds :: Fetchable t a => [Feed] -> t -> Session a +runWithFeeds feeds t = do + ns <- build $ getNodes t + -- Note that this call to "fetch" shouldn't affect the following "extend" + -- call, since all nodes in t and its inputs/deps will be rendered by the + -- above call to getNodes. + fetch <- build $ getFetch t + runFetchWithFeeds feeds ns fetch + +runFetchWithFeeds :: [Feed] -> Set NodeName -> Fetch a -> Session a +runFetchWithFeeds feeds target (Fetch fetch restore) = do + extend + let feeds' = fixFeeds feeds + let fetchNames = encodeUtf8 <$> Set.toList fetch + targetNames = toNodeNames $ Set.toList target + session <- Session (asks rawSession) + runResult <- liftIO $ FFI.run session + feeds' + fetchNames + targetNames + let resultTensorsMap = Map.fromList $ zip (Set.toList fetch) runResult + return $ restore resultTensorsMap + +toNodeNames :: [NodeName] -> [ByteString] +toNodeNames = map (encodeUtf8 . unNodeName) + +-- | Run a subgraph 't', rendering and extending any dependent nodes that aren't +-- already rendered. This behaves like 'run' except that it doesn't do any +-- fetches. +run_ :: Nodes t => t -> Session () +run_ = runWithFeeds_ [] + +-- | Run a subgraph 't', rendering any dependent nodes that aren't already +-- rendered, feed the given input values, and fetch the corresponding result +-- values for 'a'. This behaves like 'runWithFeeds' except that it doesn't do +-- any fetches. +runWithFeeds_ :: Nodes t => [Feed] -> t -> Session () +runWithFeeds_ feeds t = do + ns <- build $ getNodes t + runFetchWithFeeds feeds ns (pure ()) + +fixFeeds :: [Feed] -> [(ByteString, FFI.TensorData)] +fixFeeds = map $ \(Feed o d) -> (encodeUtf8 $ encodeOutput o, d) + +-- | Starts a concurrent thread which evaluates the given Nodes +-- forever until runSession exits or an exception occurs. Graph +-- extension happens synchronously, but the resultant run proceeds as +-- a separate thread. +asyncProdNodes :: Nodes t + => t -- ^ Node to evaluate concurrently. + -> Session () +asyncProdNodes nodes = do + target <- build (getNodes nodes) + extend + let targetNames = toNodeNames $ Set.toList target + state <- Session ask + let loop = forever (void (FFI.run (rawSession state) [] [] targetNames)) + liftIO (asyncCollector state loop) diff --git a/src/TensorFlow/Tensor.hs b/src/TensorFlow/Tensor.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Tensor.hs @@ -0,0 +1,193 @@ +-- 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 FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- For the Render class + +module TensorFlow.Tensor where + +import Data.ByteString (ByteString) +import Data.String (IsString(..)) +import qualified Data.Text as Text +import Lens.Family2 ((^.)) +import Lens.Family2.State ((%=), use) + +import Proto.Tensorflow.Core.Framework.NodeDef (device) +import TensorFlow.Build +import TensorFlow.Output (Output, NodeName, outputNodeName, Device(..)) +import TensorFlow.Types + ( TensorData(..) + , ListOf(..) + ) +import qualified TensorFlow.Internal.FFI as FFI + +-- | A named output of a TensorFlow operation. +-- +-- The type parameter @a@ is the type of the elements in the 'Tensor'. The +-- parameter @v@ is either: +-- +-- * 'Build': An unrendered, immutable value. +-- * 'Value': A rendered, immutable value. +-- * 'Ref': A rendered stateful handle (e.g., a variable). +-- +-- Note that 'expr', 'value', 'render' and 'renderValue' can help convert between +-- the different types of 'Tensor'. +data Tensor v a where + Tensor :: TensorKind v => {tensorOutput :: v Output} -> Tensor v a + +newtype Value a = Value {runValue :: a} + deriving Functor + +instance Applicative Value where + pure = Value + Value f <*> Value x = Value $ f x + +instance Monad Value where + f >>= g = g $ runValue f + +newtype Ref a = Ref {runRef :: a} + deriving Functor + +instance Applicative Ref where + pure = Ref + Ref f <*> Ref x = Ref $ f x + +instance Monad Ref where + f >>= g = g $ runRef f + +-- | Cast a 'Tensor Ref' into a 'Tensor Value'. This behaves like a no-op. +value :: Tensor Ref a -> Tensor Value a +value (Tensor o) = Tensor $ Value $ runRef o + +renderValue :: MonadBuild m => Tensor v a -> m (Tensor Value a) +renderValue (Tensor o) = render $ Tensor $ toBuild o + +-- | A pair of a 'Tensor' and some data that should be fed into that 'Tensor' +-- when running the graph. +data Feed = Feed Output FFI.TensorData + +-- | A class ensuring that a given tensor is rendered, i.e., has a fixed +-- name, device, etc. +class TensorKind v => Rendered v where + rendered :: v a -> a + +instance Rendered Value where + rendered = runValue + +instance Rendered Ref where + rendered = runRef + +renderedOutput :: Rendered v => Tensor v a -> Output +renderedOutput = rendered . tensorOutput + +tensorNodeName :: Rendered v => Tensor v a -> NodeName +tensorNodeName = outputNodeName . renderedOutput + + +-- | Create a 'Feed' for feeding the given data into a 'Tensor' when running +-- the graph. +-- +-- Note that if a 'Tensor' is rendered, its identity may change; so feeding the +-- rendered 'Tensor' may be different than feeding the original 'Tensor'. +feed :: Rendered v => Tensor v a -> TensorData a -> Feed +feed t (TensorData td) = Feed (renderedOutput t) td + +-- | Create a 'Tensor' for a given name. This can be used to reference nodes +-- in a 'GraphDef' that was loaded via 'addGraphDef'. +-- TODO(judahjacobson): add more safety checks here. +tensorFromName :: TensorKind v => Text.Text -> Tensor v a +tensorFromName = Tensor . pure . fromString . Text.unpack + +-- | Like 'tensorFromName', but type-restricted to 'Value'. +tensorValueFromName :: Text.Text -> Tensor Value a +tensorValueFromName = tensorFromName + +-- | Like 'tensorFromName', but type-restricted to 'Ref'. +tensorRefFromName :: Text.Text -> Tensor Ref a +tensorRefFromName = tensorFromName + +type TensorList v = ListOf (Tensor v) + +tensorListOutputs :: Rendered v => TensorList v as -> [Output] +tensorListOutputs Nil = [] +tensorListOutputs (t :/ ts) = renderedOutput t : tensorListOutputs ts + +-- | Places all nodes rendered in the given 'Build' action on the same +-- device as the given Tensor (see also 'withDevice'). Make sure that +-- the action has side effects of rendering the desired tensors. A pure +-- return would not have the desired effect. +colocateWith :: (MonadBuild m, Rendered v) => Tensor v b -> m a -> m a +colocateWith t x = do + d <- build $ Device . (^. device) + <$> lookupNode (outputNodeName $ renderedOutput t) + withDevice (Just d) x + + +-- | Render a 'Tensor', fixing its name, scope, device and control inputs from +-- the 'MonadBuild' context. Also renders any dependencies of the 'Tensor' that +-- weren't already rendered. +-- +-- This operation is idempotent; calling 'render' on the same input in the same +-- context will produce the same result. However, rendering the same +-- @Tensor Build@ in two different contexts may result in two different +-- @Tensor Value@s. +render :: MonadBuild m => Tensor Build a -> m (Tensor Value a) +render (Tensor t) = Tensor . Value <$> build t + +-- TODO: better name. +expr :: TensorKind v => Tensor v a -> Tensor Build a +expr (Tensor o) = Tensor $ toBuild o + +-- | Records the given summary action in Build for retrieval with +-- Summary protocol buffer in string form. For safety, use the +-- pre-composed functions: Logging.scalarSummary and +-- Logging.histogramSummary. +addSummary :: (MonadBuild m, TensorKind v) => Tensor v ByteString -- ^ A 'SummaryTensor' + -> m () +addSummary t = build $ do + -- TODO: more generic way + o <- toBuild $ tensorOutput t + summaries %= (o :) + +-- | Retrieves the summary ops collected thus far. Typically this only +-- happens once, but if 'TensorFlow.Session.buildWithSummary' is used +-- repeatedly, the values accumulate. +collectAllSummaries :: MonadBuild m => m [SummaryTensor] +collectAllSummaries = build $ map (Tensor . Value) <$> use summaries + +-- | Synonym for the tensors that return serialized Summary proto. +type SummaryTensor = Tensor Value ByteString + +-- | An internal class for kinds of Tensors. +class Monad v => TensorKind v where + toBuild :: v a -> Build a + +instance TensorKind Value where + toBuild = return . rendered + +instance TensorKind Ref where + toBuild = return . rendered + +instance TensorKind Build where + toBuild = id diff --git a/src/TensorFlow/Types.hs b/src/TensorFlow/Types.hs new file mode 100644 --- /dev/null +++ b/src/TensorFlow/Types.hs @@ -0,0 +1,539 @@ +-- 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 CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- We use UndecidableInstances for type families with recursive definitions +-- like "\\". Those instances will terminate since each equation unwraps one +-- cons cell of a type-level list. +{-# LANGUAGE UndecidableInstances #-} + +module TensorFlow.Types + ( TensorType(..) + , TensorData(..) + , TensorDataType(..) + , Scalar(..) + , Shape(..) + , protoShape + , Attribute(..) + , DataType(..) + , ResourceHandle + -- * Lists + , ListOf(..) + , List + , (/:/) + , TensorTypeProxy(..) + , TensorTypes(..) + , TensorTypeList + , fromTensorTypeList + , fromTensorTypes + -- * Type constraints + , OneOf + , type (/=) + , OneOfs + -- ** Implementation of constraints + , TypeError + , ExcludedCase + , NoneOf + , type (\\) + , Delete + , AllTensorTypes + ) where + +import Data.Functor.Identity (Identity(..)) +import Data.Complex (Complex) +import Data.Default (def) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy(..)) +import Data.String (IsString) +import Data.Word (Word8, Word16, Word64) +import Foreign.Storable (Storable) +import GHC.Exts (Constraint, IsList(..)) +import Lens.Family2 (Lens', view, (&), (.~)) +import Lens.Family2.Unchecked (iso) +import Text.Printf (printf) +import qualified Data.Attoparsec.ByteString as Atto +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Vector.Storable as S +import Proto.Tensorflow.Core.Framework.AttrValue + ( AttrValue(..) + , AttrValue'ListValue(..) + , b + , f + , i + , s + , list + , type' + , shape + , tensor + ) +import Proto.Tensorflow.Core.Framework.ResourceHandle + (ResourceHandle) +import Proto.Tensorflow.Core.Framework.Tensor as Tensor + ( TensorProto(..) + , boolVal + , doubleVal + , floatVal + , intVal + , int64Val + , resourceHandleVal + , stringVal + , stringVal + ) +import Proto.Tensorflow.Core.Framework.TensorShape + ( TensorShapeProto(..) + , dim + , size + ) +import Proto.Tensorflow.Core.Framework.Types (DataType(..)) + +import TensorFlow.Internal.VarInt (getVarInt, putVarInt) +import qualified TensorFlow.Internal.FFI as FFI + +-- | The class of scalar types supported by tensorflow. +class TensorType a where + tensorType :: a -> DataType + tensorRefType :: a -> DataType + tensorVal :: Lens' TensorProto [a] + +instance TensorType Float where + tensorType _ = DT_FLOAT + tensorRefType _ = DT_FLOAT_REF + tensorVal = floatVal + +instance TensorType Double where + tensorType _ = DT_DOUBLE + tensorRefType _ = DT_DOUBLE_REF + tensorVal = doubleVal + +instance TensorType Int32 where + tensorType _ = DT_INT32 + tensorRefType _ = DT_INT32_REF + tensorVal = intVal + +instance TensorType Int64 where + tensorType _ = DT_INT64 + tensorRefType _ = DT_INT64_REF + tensorVal = int64Val + +integral :: Integral a => Lens' [Int32] [a] +integral = iso (fmap fromIntegral) (fmap fromIntegral) + +instance TensorType Word8 where + tensorType _ = DT_UINT8 + tensorRefType _ = DT_UINT8_REF + tensorVal = intVal . integral + +instance TensorType Word16 where + tensorType _ = DT_UINT16 + tensorRefType _ = DT_UINT16_REF + tensorVal = intVal . integral + +instance TensorType Int16 where + tensorType _ = DT_INT16 + tensorRefType _ = DT_INT16_REF + tensorVal = intVal . integral + +instance TensorType Int8 where + tensorType _ = DT_INT8 + tensorRefType _ = DT_INT8_REF + tensorVal = intVal . integral + +instance TensorType ByteString where + tensorType _ = DT_STRING + tensorRefType _ = DT_STRING_REF + tensorVal = stringVal + +instance TensorType Bool where + tensorType _ = DT_BOOL + tensorRefType _ = DT_BOOL_REF + tensorVal = boolVal + +instance TensorType (Complex Float) where + tensorType _ = DT_COMPLEX64 + tensorRefType _ = DT_COMPLEX64 + tensorVal = error "TODO (Complex Float)" + +instance TensorType (Complex Double) where + tensorType _ = DT_COMPLEX128 + tensorRefType _ = DT_COMPLEX128 + tensorVal = error "TODO (Complex Double)" + +instance TensorType ResourceHandle where + tensorType _ = DT_RESOURCE + tensorRefType _ = DT_RESOURCE_REF + tensorVal = resourceHandleVal + +-- | Tensor data with the correct memory layout for tensorflow. +newtype TensorData a = TensorData { unTensorData :: FFI.TensorData } + +-- | Types that can be converted to and from 'TensorData'. +-- +-- 'S.Vector' is the most efficient to encode/decode for most element types. +class TensorType a => TensorDataType s a where + -- | Decode the bytes of a 'TensorData' into an 's'. + decodeTensorData :: TensorData a -> s a + -- | Encode an 's' into a 'TensorData'. + -- + -- The values should be in row major order, e.g., + -- + -- element 0: index (0, ..., 0) + -- element 1: index (0, ..., 1) + -- ... + encodeTensorData :: Shape -> s a -> TensorData a + +-- All types, besides ByteString and Bool, are encoded as simple arrays and we +-- can use Vector.Storable to encode/decode by type casting pointers. + +-- TODO(fmayle): Assert that the data type matches the return type. +simpleDecode :: Storable a => TensorData a -> S.Vector a +simpleDecode = S.unsafeCast . FFI.tensorDataBytes . unTensorData + +simpleEncode :: forall a . (TensorType a, Storable a) + => Shape -> S.Vector a -> TensorData a +simpleEncode (Shape xs) v = + if product xs /= fromIntegral (S.length v) + then error $ printf + "simpleEncode: bad vector length for shape %v: expected=%d got=%d" + (show xs) (product xs) (S.length v) + else TensorData (FFI.TensorData xs dt (S.unsafeCast v)) + where + dt = tensorType (undefined :: a) + +instance TensorDataType S.Vector Float where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Double where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Int8 where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Int16 where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Int32 where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Int64 where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Word8 where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +instance TensorDataType S.Vector Word16 where + decodeTensorData = simpleDecode + encodeTensorData = simpleEncode + +-- TODO: Haskell and tensorflow use different byte sizes for bools, which makes +-- encoding more expensive. It may make sense to define a custom boolean type. +instance TensorDataType S.Vector Bool where + decodeTensorData = + S.convert . S.map (/= 0) . FFI.tensorDataBytes . unTensorData + encodeTensorData (Shape xs) = + TensorData . FFI.TensorData xs DT_BOOL . S.map fromBool . S.convert + where + fromBool x = if x then 1 else 0 :: Word8 + +instance {-# OVERLAPPABLE #-} (Storable a, TensorDataType S.Vector a, TensorType a) + => TensorDataType V.Vector a where + decodeTensorData = (S.convert :: S.Vector a -> V.Vector a) . decodeTensorData + encodeTensorData x = encodeTensorData x . (S.convert :: V.Vector a -> S.Vector a) + +instance {-# OVERLAPPING #-} TensorDataType V.Vector (Complex Float) where + decodeTensorData = error "TODO (Complex Float)" + encodeTensorData = error "TODO (Complex Float)" + +instance {-# OVERLAPPING #-} TensorDataType V.Vector (Complex Double) where + decodeTensorData = error "TODO (Complex Double)" + encodeTensorData = error "TODO (Complex Double)" + +instance {-# OVERLAPPING #-} TensorDataType V.Vector ByteString where + -- Encoded data layout (described in third_party/tensorflow/c/c_api.h): + -- table offsets for each element :: [Word64] + -- at each element offset: + -- string length :: VarInt64 + -- string data :: [Word8] + decodeTensorData tensorData = + either (\err -> error $ "Malformed TF_STRING tensor; " ++ err) id $ + if expected /= count + then Left $ "decodeTensorData for ByteString count mismatch " ++ + show (expected, count) + else V.mapM decodeString (S.convert offsets) + where + expected = S.length offsets + count = fromIntegral $ product $ FFI.tensorDataDimensions + $ unTensorData tensorData + bytes = FFI.tensorDataBytes $ unTensorData tensorData + offsets = S.take count $ S.unsafeCast bytes :: S.Vector Word64 + dataBytes = B.pack $ S.toList $ S.drop (count * 8) bytes + decodeString :: Word64 -> Either String ByteString + decodeString offset = + let stringDataStart = B.drop (fromIntegral offset) dataBytes + in Atto.eitherResult $ Atto.parse stringParser stringDataStart + stringParser :: Atto.Parser ByteString + stringParser = getVarInt >>= Atto.take . fromIntegral + encodeTensorData (Shape xs) vec = + TensorData $ FFI.TensorData xs dt byteVector + where + dt = tensorType (undefined :: ByteString) + -- Add a string to an offset table and data blob. + addString :: (Builder, Builder, Word64) + -> ByteString + -> (Builder, Builder, Word64) + addString (table, strings, offset) str = + ( table <> Builder.word64LE offset + , strings <> lengthBytes <> Builder.byteString str + , offset + lengthBytesLen + strLen + ) + where + strLen = fromIntegral $ B.length str + lengthBytes = putVarInt $ fromIntegral $ B.length str + lengthBytesLen = + fromIntegral $ L.length $ Builder.toLazyByteString lengthBytes + -- Encode all strings. + (table', strings', _) = V.foldl' addString (mempty, mempty, 0) vec + -- Concat offset table with data. + bytes = table' <> strings' + -- Convert to Vector Word8. + byteVector = S.fromList $ L.unpack $ Builder.toLazyByteString bytes + +newtype Scalar a = Scalar {unScalar :: a} + deriving (Show, Eq, Ord, Num, Fractional, Floating, Real, RealFloat, + RealFrac, IsString) + +instance (TensorDataType V.Vector a, TensorType a) => TensorDataType Scalar a where + decodeTensorData = Scalar . headFromSingleton . decodeTensorData + encodeTensorData x (Scalar y) = encodeTensorData x (V.fromList [y]) + +headFromSingleton :: V.Vector a -> a +headFromSingleton x + | V.length x == 1 = V.head x + | otherwise = error $ + "Unable to extract singleton from tensor of length " + ++ show (V.length x) + + +-- | Shape (dimensions) of a tensor. +newtype Shape = Shape [Int64] deriving Show + +instance IsList Shape where + type Item Shape = Int64 + fromList = Shape . fromList + toList (Shape ss) = toList ss + +protoShape :: Lens' TensorShapeProto Shape +protoShape = iso protoToShape shapeToProto + where + protoToShape = Shape . fmap (view size) . view dim + shapeToProto (Shape ds) = (def :: TensorShapeProto) & dim .~ fmap (\d -> def & size .~ d) ds + + +class Attribute a where + attrLens :: Lens' AttrValue a + +instance Attribute Float where + attrLens = f + +instance Attribute ByteString where + attrLens = s + +instance Attribute Int64 where + attrLens = i + +instance Attribute DataType where + attrLens = type' + +instance Attribute TensorProto where + attrLens = tensor + +instance Attribute Bool where + attrLens = b + +instance Attribute Shape where + attrLens = shape . protoShape + +-- TODO(gnezdo): support generating list(Foo) from [Foo]. +instance Attribute AttrValue'ListValue where + attrLens = list + +instance Attribute [DataType] where + attrLens = list . type' + +instance Attribute [Int64] where + attrLens = list . i + +-- | A heterogeneous list type. +data ListOf f as where + Nil :: ListOf f '[] + (:/) :: f a -> ListOf f as -> ListOf f (a ': as) + +infixr 5 :/ + +type family All f as :: Constraint where + All f '[] = () + All f (a ': as) = (f a, All f as) + +type family Map f as where + Map f '[] = '[] + Map f (a ': as) = f a ': Map f as + +instance All Eq (Map f as) => Eq (ListOf f as) where + Nil == Nil = True + (x :/ xs) == (y :/ ys) = x == y && xs == ys + -- Newer versions of GHC use the GADT to tell that the previous cases are + -- exhaustive. +#if __GLASGOW_HASKELL__ < 800 + _ == _ = False +#endif + +instance All Show (Map f as) => Show (ListOf f as) where + showsPrec _ Nil = showString "Nil" + showsPrec d (x :/ xs) = showParen (d > 10) + $ showsPrec 6 x . showString " :/ " + . showsPrec 6 xs + +type List = ListOf Identity + +-- | Equivalent of ':/' for lists. +(/:/) :: a -> List as -> List (a ': as) +(/:/) = (:/) . Identity + +infixr 5 /:/ + +-- | A 'Constraint' specifying the possible choices of a 'TensorType'. +-- +-- We implement a 'Constraint' like @OneOf '[Double, Float] a@ by turning the +-- natural representation as a conjunction, i.e., +-- +-- @ +-- a == Double || a == Float +-- @ +-- +-- into a disjunction like +-- +-- @ +-- a \/= Int32 && a \/= Int64 && a \/= ByteString && ... +-- @ +-- +-- using an enumeration of all the possible 'TensorType's. +type OneOf ts a + -- Assert `TensorTypes ts` to make error messages a little better. + = (TensorType a, TensorTypes ts, NoneOf (AllTensorTypes \\ ts) a) + +type OneOfs ts as = (TensorTypes as, TensorTypes ts, + NoneOfs (AllTensorTypes \\ ts) as) + +type family NoneOfs ts as :: Constraint where + NoneOfs ts '[] = () + NoneOfs ts (a ': as) = (NoneOf ts a, NoneOfs ts as) + +data TensorTypeProxy a where + TensorTypeProxy :: TensorType a => TensorTypeProxy a + +type TensorTypeList = ListOf TensorTypeProxy + +fromTensorTypeList :: TensorTypeList ts -> [DataType] +fromTensorTypeList Nil = [] +fromTensorTypeList ((TensorTypeProxy :: TensorTypeProxy t) :/ ts) + = tensorType (undefined :: t) : fromTensorTypeList ts + +fromTensorTypes :: forall as . TensorTypes as => Proxy as -> [DataType] +fromTensorTypes _ = fromTensorTypeList (tensorTypes :: TensorTypeList as) + +class TensorTypes (ts :: [*]) where + tensorTypes :: TensorTypeList ts + +instance TensorTypes '[] where + tensorTypes = Nil + +-- | A constraint that the input is a list of 'TensorTypes'. +instance (TensorType t, TensorTypes ts) => TensorTypes (t ': ts) where + tensorTypes = TensorTypeProxy :/ tensorTypes + +-- | A constraint checking that two types are different. +type family a /= b :: Constraint where + a /= a = TypeError a ~ ExcludedCase + a /= b = () + +-- | Helper types to produce a reasonable type error message when the Constraint +-- "a /= a" fails. +-- TODO(judahjacobson): Use ghc-8's CustomTypeErrors for this. +data TypeError a +data ExcludedCase + +-- | An enumeration of all valid 'TensorType's. +type AllTensorTypes = + -- NOTE: This list should be kept in sync with + -- TensorFlow.OpGen.dtTypeToHaskell. + -- TODO: Add support for Complex Float/Double. + '[ Float + , Double + , Int8 + , Int16 + , Int32 + , Int64 + , Word8 + , Word16 + , ByteString + , Bool + ] + +-- | Removes a type from the given list of types. +type family Delete a as where + Delete a '[] = '[] + Delete a (a ': as) = Delete a as + Delete a (b ': as) = b ': Delete a as + +-- | Takes the difference of two lists of types. +type family as \\ bs where + as \\ '[] = as + as \\ (b ': bs) = Delete b as \\ bs + +-- | A constraint that the type @a@ doesn't appear in the type list @ts@. +-- Assumes that @a@ and each of the elements of @ts@ are 'TensorType's. +type family NoneOf ts a :: Constraint where + -- Specialize this type family when `ts` is a long list, to avoid deeply + -- nested tuples of constraints. Works around a bug in ghc-8: + -- https://ghc.haskell.org/trac/ghc/ticket/12175 + NoneOf (t1 ': t2 ': t3 ': t4 ': ts) a + = (a /= t1, a /= t2, a /= t3, a /= t4, NoneOf ts a) + NoneOf (t1 ': t2 ': t3 ': ts) a = (a /= t1, a /= t2, a /= t3, NoneOf ts a) + NoneOf (t1 ': t2 ': ts) a = (a /= t1, a /= t2, NoneOf ts a) + NoneOf (t1 ': ts) a = (a /= t1, NoneOf ts a) + NoneOf '[] a = () diff --git a/tensorflow.cabal b/tensorflow.cabal new file mode 100644 --- /dev/null +++ b/tensorflow.cabal @@ -0,0 +1,94 @@ +name: tensorflow +version: 0.1.0.0 +synopsis: TensorFlow bindings. +description: + This library provides an interface to the TensorFlow + bindings. "TensorFlow.Core" contains the base API for + building and running computational graphs. Other packages + such as @tensorflow-ops@ contain bindings to the actual + computational kernels. + . + For more documentation and examples, see + +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.Build + , TensorFlow.BuildOp + , TensorFlow.ControlFlow + , TensorFlow.Core + , TensorFlow.Internal.FFI + , TensorFlow.Internal.VarInt + , TensorFlow.Nodes + , TensorFlow.Output + , TensorFlow.Session + , TensorFlow.Tensor + , TensorFlow.Types + other-modules: TensorFlow.Internal.Raw + , TensorFlow.Orphans + build-tools: c2hs + build-depends: proto-lens == 0.2.* + -- Used by the custom Setup script (for the test-suite). + , proto-lens-protoc == 0.2.* + , tensorflow-proto == 0.1.* + , base >= 4.7 && < 5 + , async + , attoparsec + , bytestring + , containers + , data-default + , exceptions + , fgl + , lens-family + , mainland-pretty + , mtl + , semigroups + , split + , text + , temporary + , transformers + , vector + extra-libraries: tensorflow + default-language: Haskell2010 + include-dirs: . + +Test-Suite FFITest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: FFITest.hs + hs-source-dirs: tests + build-depends: HUnit + , base + , bytestring + , lens-family + , proto-lens + , tensorflow + , tensorflow-proto + , test-framework + , test-framework-hunit + + +Test-Suite VarIntTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: VarIntTest.hs + hs-source-dirs: tests + build-depends: base + , attoparsec + , bytestring + , tensorflow + , test-framework + , test-framework-quickcheck2 + +source-repository head + type: git + location: https://github.com/tensorflow/haskell diff --git a/tests/FFITest.hs b/tests/FFITest.hs new file mode 100644 --- /dev/null +++ b/tests/FFITest.hs @@ -0,0 +1,39 @@ +-- 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. + +-- | Tests for FFI. + +module Main where + +import Data.ProtoLens (decodeMessage) +import Lens.Family2 (view) +import TensorFlow.Internal.FFI (getAllOpList) +import Test.HUnit (assertBool, assertFailure) +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Proto.Tensorflow.Core.Framework.OpDef (OpList, op) + +testParseAll :: IO () +testParseAll = do + opList <- getAllOpList + either + assertFailure + (assertBool "Expected non-empty list of default Ops" + . not . null . view op) + (decodeMessage opList :: Either String OpList) + +main :: IO () +main = defaultMain + [ testCase "ParseAllOps" testParseAll + ] diff --git a/tests/VarIntTest.hs b/tests/VarIntTest.hs new file mode 100644 --- /dev/null +++ b/tests/VarIntTest.hs @@ -0,0 +1,33 @@ +-- 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. + +module Main where + +import Data.ByteString.Builder (toLazyByteString) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import qualified Data.Attoparsec.ByteString.Lazy as Atto + +import TensorFlow.Internal.VarInt + +testEncodeDecode :: Test +testEncodeDecode = testProperty "testEncodeDecode" $ \x -> + let bytes = toLazyByteString (putVarInt x) + in case Atto.eitherResult $ Atto.parse getVarInt bytes of + Left _ -> False + Right y -> x == y + +main :: IO () +main = defaultMain [ testEncodeDecode + ]