├── Setup.hs ├── examples ├── Setup.hs ├── Common.hs ├── blast-examples.cabal ├── WordCount │ ├── Main.hs │ └── files │ │ └── f1.txt ├── Simple │ └── Main.hs ├── KMeans │ └── Main.hs └── LICENSE ├── .gitignore ├── test ├── Spec.hs └── Test │ ├── Syntax.hs │ └── Computation.hs ├── src └── Control │ └── Distributed │ ├── Blast.hs │ └── Blast │ ├── Distributed │ ├── Interface.hs │ ├── Types.hs │ ├── Slave.hs │ └── Master.hs │ ├── Common │ └── Analyser.hs │ ├── Runner │ ├── Simple.hs │ ├── Local.hs │ └── CloudHaskell.hs │ ├── Master │ └── Analyser.hs │ ├── Syntax.hs │ ├── Slave │ └── Analyser.hs │ └── Types.hs ├── stack.yaml ├── README.md ├── blast.cabal └── LICENSE /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # OSX 2 | .DS_Store 3 | ._.DS_Store 4 | 5 | # LaTex 6 | *.aux 7 | *.bbl 8 | *.blg 9 | *.log 10 | *.out 11 | *.synctex.gz 12 | *.toc 13 | *.dep 14 | *.src 15 | 16 | # The Rest 17 | .docker-sandbox/ 18 | dist/ 19 | /.project 20 | *.lkshs 21 | *.lkshw 22 | *.un~ 23 | cabal.sandbox.config 24 | .hsenv 25 | .stack-work/ 26 | dist-stack/ 27 | *.tix 28 | /.local-bin/ 29 | # Emacs 30 | *~ 31 | \#*\# 32 | .\#* 33 | 34 | # Vim 35 | *.swp 36 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This Source Code Form is subject to the terms of the Mozilla Public 3 | License, v. 2.0. If a copy of the MPL was not distributed with this 4 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 5 | -} 6 | 7 | 8 | import Debug.Trace 9 | import Control.Applicative 10 | import qualified Data.Vector as V 11 | import Test.HUnit 12 | import Test.Framework 13 | import Test.Framework.Providers.HUnit 14 | import Test.Framework.Providers.QuickCheck2 (testProperty) 15 | import Test.QuickCheck 16 | import Test.QuickCheck.Arbitrary 17 | 18 | import Control.Distributed.Blast 19 | import Control.Distributed.Blast.Syntax 20 | 21 | import Test.Computation as C 22 | import Test.Syntax as S 23 | 24 | main :: IO () 25 | main = do 26 | defaultMain (S.tests ++ C.tests) 27 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | module Control.Distributed.Blast 10 | ( 11 | -- * Types. 12 | Computation 13 | , LocalComputation 14 | , RemoteComputation 15 | , Kind (..) 16 | , Partition 17 | , Syntax () 18 | 19 | -- * Classes. 20 | 21 | , Builder 22 | , Chunkable (..) 23 | , UnChunkable (..) 24 | , ChunkableFreeVar (..) 25 | 26 | -- * Core syntax primitives. 27 | , rapply 28 | , rconst 29 | , rconstIO 30 | , lconst 31 | , lconstIO 32 | , collect 33 | , lapply 34 | 35 | -- * Job description. 36 | , JobDesc (..) 37 | , Config (..) 38 | , defaultConfig 39 | 40 | -- * Helper functions to create closures. 41 | , fun 42 | , closure 43 | , foldFun 44 | , foldClosure 45 | , funIO 46 | , closureIO 47 | , foldFunIO 48 | , foldClosureIO 49 | 50 | 51 | 52 | ) 53 | where 54 | 55 | import Control.Distributed.Blast.Types 56 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-8.2 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | - examples 11 | 12 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 13 | extra-deps: [ 14 | distributed-process-client-server-0.1.3.2 15 | ,distributed-process-extras-0.2.1.2 16 | , distributed-process-async-0.2.3 17 | , distributed-static-0.3.5.0 18 | ] 19 | 20 | # Override default flag values for local packages and extra-deps 21 | flags: {} 22 | 23 | # Extra package databases containing global packages 24 | extra-package-dbs: [] 25 | 26 | # Control whether we use the GHC we find on the path 27 | # system-ghc: true 28 | 29 | # Require a specific version of stack, using version ranges 30 | # require-stack-version: -any # Default 31 | # require-stack-version: >= 1.0.0 32 | 33 | # Override the architecture used by stack, especially useful on Windows 34 | # arch: i386 35 | # arch: x86_64 36 | 37 | # Extra directories used by stack for building 38 | # extra-include-dirs: [/path/to/dir] 39 | # extra-lib-dirs: [/path/to/dir] 40 | 41 | # Allow a newer minor version of GHC than the snapshot specifies 42 | # compiler-check: newer-minor 43 | -------------------------------------------------------------------------------- /test/Test/Syntax.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This Source Code Form is subject to the terms of the Mozilla Public 3 | License, v. 2.0. If a copy of the MPL was not distributed with this 4 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 5 | -} 6 | 7 | 8 | module Test.Syntax 9 | where 10 | 11 | import Debug.Trace 12 | import Control.Applicative 13 | import qualified Data.Vector as V 14 | import Test.HUnit 15 | import Test.Framework 16 | import Test.Framework.Providers.HUnit 17 | import Test.Framework.Providers.QuickCheck2 (testProperty) 18 | import Test.QuickCheck 19 | import Test.QuickCheck.Arbitrary 20 | 21 | import Control.Distributed.Blast 22 | import Control.Distributed.Blast.Syntax 23 | 24 | tests = [ 25 | testProperty "testRangeProp" testRangeProp 26 | ] 27 | 28 | 29 | rangeGen :: Gen Range 30 | rangeGen = do 31 | a <- choose (0, 100) 32 | d <- choose (1, 50) 33 | return $ Range a (a+d) 34 | 35 | 36 | testRangeProp = 37 | forAll ((,) <$> rangeGen <*> (choose (1, 10))) prop 38 | where 39 | prop (range@(Range start end), nbBuckets) = 40 | case trace (show $ length ranges) ranges of 41 | [] -> False 42 | (Range a b:t) | a == start -> 43 | case check ranges of 44 | Just b | b == end -> True 45 | _ -> False 46 | where 47 | p = chunk nbBuckets range 48 | ranges = V.toList p 49 | check [] = Nothing 50 | check [Range a b] | a <= b = Just b 51 | check (Range a b:Range c d:t) | b == c && a <= b && c <= d = check (Range c d:t) 52 | check _ = Nothing 53 | 54 | 55 | -------------------------------------------------------------------------------- /examples/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | 11 | 12 | module Common where 13 | 14 | import Control.Monad.Logger 15 | 16 | import Control.Distributed.Process (RemoteTable, Process) 17 | import Control.Distributed.Static (Closure) 18 | 19 | import Data.Serialize (Serialize) 20 | import System.Environment (getArgs) 21 | 22 | import Control.Distributed.Blast 23 | import Control.Distributed.Blast.Runner.Local as Loc 24 | import Control.Distributed.Blast.Runner.CloudHaskell as CH 25 | 26 | 27 | -- a slow implementation of Fibonnacci 28 | fib :: Int -> Int 29 | fib 0 = 0 30 | fib 1 = 1 31 | fib 2 = 3 32 | fib n = fib (n-1) + fib (n-2) 33 | 34 | noReporting :: a -> b -> IO a 35 | noReporting a _ = return a 36 | 37 | noIteration :: a -> a -> b -> Bool 38 | noIteration _ _ _ = True 39 | 40 | 41 | 42 | runLocally :: (Serialize b, Serialize a) => 43 | Bool -> JobDesc a b -> IO (a, b) 44 | runLocally statefull jobDesc = do 45 | let cf = defaultConfig { statefullSlaves = statefull } 46 | let nbSlaves = 8 47 | runStdoutLoggingT $ Loc.runRec nbSlaves cf jobDesc 48 | 49 | 50 | rpcConfigAction :: IO RpcConfig 51 | rpcConfigAction = return $ 52 | MkRpcConfig 53 | defaultConfig 54 | (MkMasterConfig runStdoutLoggingT) 55 | (MkSlaveConfig runStdoutLoggingT) 56 | 57 | 58 | runCloudHaskell :: (Show a, Show b, Serialize a, Serialize b) => 59 | RemoteTable 60 | -> JobDesc a b 61 | -> (Int -> Closure (Process ())) 62 | -> IO () 63 | runCloudHaskell rtable jobDesc chClosure = do 64 | args <- getArgs 65 | rpcConfig <- rpcConfigAction 66 | CH.runRec rtable rpcConfig args jobDesc chClosure k 67 | where 68 | k a b = do 69 | print a 70 | print b 71 | print "End" 72 | 73 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Blast: Distributed Computing in Haskell 2 | 3 | **Blast** is a pure Haskell library for doing distributed computing. It has the following characteristics: 4 | 5 | * Works on any RPC backend. The current implementation runs on both local threads and CloudHaskell. 6 | * Is based on 5 simple primitives, allowing the user to define his own syntax above them. 7 | * Has a buit-in fail/safe mechanism in case of slave failure. 8 | * Transparently works with both stateless and stateful slaves. 9 | * Automatically handles slave caching. 10 | 11 | 12 | ## Getting started 13 | 14 | ``` 15 | $ stack build 16 | ``` 17 | 18 | Builds the library and the examples. 19 | 20 | ## Examples 21 | 22 | Each example can be run on 2 backends: 23 | 24 | * A local backend that uses local threads. 25 | * A CloudHaskell backend. 26 | 27 | To run an example on CloudHaskell: 28 | 29 | * Edit `Main.hs` and choose the right CloudHaskell main function (the one that is suffixed with CH). 30 | * Starts as many slaves as needed. 31 | 32 | ``` 33 | $ stack exec -- example-name slave host port 34 | ``` 35 | * Starts the master. 36 | ``` 37 | $ stack exec -- example-name master host port 38 | ``` 39 | 40 | I.E. The following commands starts the KMean example with 2 slaves. 41 | 42 | ``` 43 | $ stack exec -- kmeans slave localhost 5001 44 | $ stack exec -- kmeans slave localhost 5002 45 | $ stack exec -- kmeans master localhost 5000 46 | ``` 47 | 48 | ### Simple 49 | 50 | A set a simple examples illustrating remote mapping and folding as well as an iterative distributed algorithm. 51 | 52 | ``` 53 | $ stack exec -- simple 54 | ``` 55 | 56 | ### KMeans 57 | 58 | Implementation of the distributed KMean algorithm. 59 | 60 | ``` 61 | $ stack exec -- kmeans 62 | ``` 63 | 64 | ### WordCount 65 | 66 | Counts the number of occurrences of each character in multiple files. 67 | 68 | ``` 69 | $ cd examples/WordCount 70 | $ stack exec -- wordcount 71 | ``` 72 | 73 | 74 | ## License 75 | 76 | Copyright (c) 2016-2017 Jean-Christophe Mincke. 77 | 78 | All rights reserved. 79 | 80 | **Blast** is free software, and may be redistributed under the terms 81 | specified in the [LICENSE](LICENSE) file. -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Distributed/Interface.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE RecordWildCards #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | 15 | module Control.Distributed.Blast.Distributed.Interface 16 | ( 17 | -- * Types 18 | SlaveContext 19 | , SlaveRequest 20 | , SlaveResponse 21 | 22 | -- * Class 23 | , CommandClass (..) 24 | 25 | -- * Functions 26 | 27 | , runCommand 28 | 29 | , resetCommand 30 | 31 | , runComputation 32 | , makeSlaveContext 33 | ) 34 | where 35 | 36 | 37 | --import Debug.Trace 38 | import Control.Monad.IO.Class 39 | import Control.Monad.Logger 40 | import Control.Monad.Trans.State 41 | 42 | import qualified Data.Map as M 43 | import qualified Data.Serialize as S 44 | import qualified Data.Vault.Strict as V 45 | 46 | 47 | import Control.Distributed.Blast.Distributed.Master (runLocal) 48 | import Control.Distributed.Blast.Distributed.Slave 49 | import Control.Distributed.Blast.Distributed.Types (resetCommand, CommandClass (..), SlaveRequest(..), SlaveResponse(..)) 50 | import Control.Distributed.Blast.Master.Analyser (analyseLocal) 51 | import Control.Distributed.Blast.Types 52 | 53 | -- | Executes a computation on the master node using the given instance of the "CommandClass" to delegate work to the slaves. 54 | runComputation :: (S.Serialize a, CommandClass s a, MonadLoggerIO m) 55 | => Config -- ^ Configuration. 56 | -> s a -- ^ Instance of a "CommandClass". 57 | -> JobDesc a b -- ^ Job description. 58 | -> m (a, b) -- ^ Result : new value of the seed and the computation output. 59 | runComputation (MkConfig {..}) s (MkJobDesc {..}) = do 60 | let program = computationGen seed 61 | 62 | (refMap, count) <- generateReferenceMap 0 M.empty program 63 | e <- build refMap count program 64 | 65 | infos <- execStateT (analyseLocal e) M.empty 66 | s' <- liftIO $ setSeed s seed 67 | (r, _) <- evalStateT (runLocal e) (s', V.empty, infos) 68 | 69 | return r 70 | 71 | 72 | 73 | 74 | 75 | 76 | -------------------------------------------------------------------------------- /examples/blast-examples.cabal: -------------------------------------------------------------------------------- 1 | name: blast-examples 2 | version: 0.1.0.0 3 | synopsis: A distributed computing library 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/blast#readme 6 | license: MPL-2.0 7 | license-file: LICENSE 8 | author: Jean-Christophe Mincke 9 | maintainer: jeanchristophe.mincke@gmail.com 10 | copyright: 2016-2017 Jean-Christophe Mincke 11 | category: Distributed computing 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | 17 | executable simple 18 | hs-source-dirs: . 19 | main-is: Simple/Main.hs 20 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 21 | build-depends: 22 | base >= 4.7 && < 5 23 | , cereal 24 | , containers 25 | , deepseq 26 | , distributed-process 27 | , distributed-process-client-server 28 | , distributed-process-extras 29 | , distributed-process-simplelocalnet 30 | , distributed-static 31 | , monad-logger 32 | , operational 33 | , transformers 34 | , vault 35 | , blast 36 | default-language: Haskell2010 37 | 38 | 39 | executable kmeans 40 | hs-source-dirs: . 41 | main-is: KMeans/Main.hs 42 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 43 | build-depends: 44 | base >= 4.7 && < 5 45 | , cereal 46 | , containers 47 | , deepseq 48 | , distributed-process 49 | , distributed-process-client-server 50 | , distributed-process-extras 51 | , distributed-process-simplelocalnet 52 | , distributed-static 53 | , monad-logger 54 | , operational 55 | , random 56 | , transformers 57 | , vault 58 | , blast 59 | default-language: Haskell2010 60 | 61 | 62 | executable wordcount 63 | hs-source-dirs: . 64 | main-is: WordCount/Main.hs 65 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 66 | build-depends: 67 | base >= 4.7 && < 5 68 | , bytestring 69 | , cereal 70 | , conduit 71 | , conduit-extra 72 | , containers 73 | , deepseq 74 | , distributed-process 75 | , distributed-process-client-server 76 | , distributed-process-extras 77 | , distributed-process-simplelocalnet 78 | , distributed-static 79 | , monad-logger 80 | , operational 81 | , resourcet 82 | , transformers 83 | , vault 84 | , vector 85 | , blast 86 | default-language: Haskell2010 87 | 88 | 89 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Common/Analyser.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | {-# LANGUAGE DeriveGeneric #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE TemplateHaskell #-} 15 | 16 | module Control.Distributed.Blast.Common.Analyser 17 | ( 18 | CachedValType (..) 19 | , RemoteClosureResult (..) 20 | , RemoteClosureImpl 21 | , Data (..) 22 | , referenceM 23 | , wasVisitedM 24 | ) 25 | where 26 | 27 | --import Debug.Trace 28 | 29 | import Control.DeepSeq 30 | import Control.Monad.Logger 31 | import Control.Monad.Trans.State 32 | import Data.Binary (Binary) 33 | import qualified Data.Map as M 34 | import qualified Data.Set as S 35 | import qualified Data.Text as T 36 | import qualified Data.Vault.Strict as V 37 | import GHC.Generics (Generic) 38 | 39 | import Control.Distributed.Blast.Types 40 | 41 | 42 | data CachedValType = CachedArg | CachedFreeVar 43 | deriving (Show, Generic) 44 | 45 | data RemoteClosureResult = 46 | RcRespCacheMiss CachedValType 47 | |RcRespOk 48 | |RcRespError String 49 | deriving (Generic, Show) 50 | 51 | 52 | instance NFData RemoteClosureResult 53 | instance NFData CachedValType 54 | 55 | instance Binary RemoteClosureResult 56 | instance Binary CachedValType 57 | 58 | type RemoteClosureImpl = V.Vault -> IO (RemoteClosureResult, V.Vault) 59 | 60 | 61 | data Data a = 62 | Data a 63 | |NoData 64 | deriving (Show, Generic) 65 | 66 | instance (Binary a) => Binary (Data a) 67 | instance (NFData a) => NFData (Data a) 68 | 69 | referenceM :: forall i m. MonadLoggerIO m => 70 | Int -> Int -> StateT (GenericInfoMap i) m () 71 | referenceM parent child = do 72 | $(logInfo) $ T.pack ("Parent node "++show parent ++ " references child node " ++ show child) 73 | m <- get 74 | put (doReference m) 75 | where 76 | doReference m = 77 | case M.lookup child m of 78 | Just inf@(GenericInfo old _) -> M.insert child (inf {giRefs = S.insert parent old}) m 79 | Nothing -> error $ ("Node " ++ show child ++ " is referenced before being visited") 80 | 81 | 82 | 83 | wasVisitedM :: forall i m. Monad m => 84 | Int -> StateT (GenericInfoMap i) m Bool 85 | wasVisitedM n = do 86 | m <- get 87 | return $ M.member n m 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /blast.cabal: -------------------------------------------------------------------------------- 1 | name: blast 2 | version: 0.1.1.0 3 | synopsis: A distributed computing library 4 | description: Blast is a library for doing Apache Spark like distributed computing. 5 | homepage: https://github.com/githubuser/blast#readme 6 | license: MPL-2.0 7 | license-file: LICENSE 8 | author: Jean-Christophe Mincke 9 | maintainer: jeanchristophe.mincke@gmail.com 10 | copyright: 2016-2017 Jean-Christophe Mincke 11 | category: Distributed computing 12 | build-type: Simple 13 | 14 | cabal-version: >=1.10 15 | 16 | -- extra-source-files: 17 | 18 | source-repository head 19 | type: git 20 | location: http://github.com/jcmincke/Blast.git 21 | 22 | 23 | library 24 | hs-source-dirs: src 25 | exposed-modules: 26 | Control.Distributed.Blast 27 | Control.Distributed.Blast.Syntax 28 | Control.Distributed.Blast.Runner.CloudHaskell 29 | Control.Distributed.Blast.Runner.Local 30 | Control.Distributed.Blast.Runner.Simple 31 | Control.Distributed.Blast.Distributed.Interface 32 | Control.Distributed.Blast.Distributed.Slave 33 | Control.Distributed.Blast.Distributed.Types 34 | other-modules: 35 | Control.Distributed.Blast.Common.Analyser 36 | Control.Distributed.Blast.Distributed.Master 37 | Control.Distributed.Blast.Master.Analyser 38 | Control.Distributed.Blast.Slave.Analyser 39 | Control.Distributed.Blast.Types 40 | build-depends: 41 | base >= 4.7 && < 5 42 | , async 43 | , binary 44 | , bytestring 45 | , cereal 46 | , containers 47 | , control-bool 48 | , data-default 49 | , deepseq 50 | , distributed-process 51 | , distributed-process-client-server 52 | , distributed-process-extras 53 | , distributed-process-simplelocalnet 54 | , either 55 | , hashable 56 | , lens 57 | , monad-logger 58 | , operational 59 | , random 60 | , stm 61 | , syb 62 | , text 63 | , transformers 64 | , unordered-containers 65 | , vault 66 | , vector 67 | default-language: Haskell2010 68 | ghc-options: -Wall 69 | 70 | 71 | 72 | 73 | test-suite blast-test 74 | type: exitcode-stdio-1.0 75 | hs-source-dirs: test 76 | main-is: Spec.hs 77 | build-depends: base 78 | , blast 79 | , vector 80 | , HUnit 81 | , monad-logger 82 | , QuickCheck 83 | , scientific 84 | , test-framework 85 | , test-framework-hunit 86 | , test-framework-quickcheck2 87 | , transformers 88 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 89 | default-language: Haskell2010 90 | 91 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Distributed/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | {-# LANGUAGE BangPatterns #-} 10 | {-# LANGUAGE DeriveGeneric #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | {-# LANGUAGE RecordWildCards #-} 16 | {-# LANGUAGE TemplateHaskell #-} 17 | 18 | 19 | module Control.Distributed.Blast.Distributed.Types 20 | ( 21 | CommandClass (..) 22 | , SlaveRequest (..) 23 | , SlaveResponse (..) 24 | , RemoteClosureIndex 25 | , resetCommand 26 | ) 27 | where 28 | 29 | 30 | import Control.DeepSeq 31 | import Data.Binary 32 | 33 | import qualified Data.ByteString as BS 34 | import qualified Data.Serialize as S 35 | 36 | import GHC.Generics (Generic) 37 | 38 | import Control.Distributed.Blast.Common.Analyser 39 | 40 | 41 | type RemoteClosureIndex = Int 42 | 43 | 44 | -- | The list of primitives for master-slave communication. 45 | class (S.Serialize x) => CommandClass s x where 46 | -- | True if slaves are statefull. 47 | isStatefullSlave :: s x -> Bool 48 | -- | The number of slaves. 49 | getNbSlaves :: s x -> Int 50 | 51 | send :: s x -> Int -> SlaveRequest -> IO (Either String SlaveResponse) 52 | 53 | -- | Stops the system. 54 | stop :: s x -> IO () 55 | setSeed :: s x -> x -> IO (s x) 56 | 57 | 58 | data SlaveRequest = 59 | LsReqExecute RemoteClosureIndex 60 | |LsReqCache Int (Data BS.ByteString) 61 | |LsReqUncache Int 62 | |LsReqFetch Int 63 | |LsReqReset BS.ByteString 64 | |LsReqBatch Int [SlaveRequest] 65 | deriving (Generic) 66 | 67 | instance Show SlaveRequest where 68 | show (LsReqExecute n) = "LsReqExecute "++ show n 69 | show (LsReqCache n _) = "LsReqCache "++ show n 70 | show (LsReqUncache n) = "LsReqUncache "++ show n 71 | show (LsReqFetch n) = "LsReqFetch "++ show n 72 | show (LsReqReset _) = "LsReqReset" 73 | show (LsReqBatch n _) = "LsReqBatch "++ show n 74 | 75 | 76 | data SlaveResponse = 77 | LsRespVoid 78 | |LsRespFetch (Data BS.ByteString) 79 | |LsRespFetchMiss 80 | |LsRespExecute RemoteClosureResult 81 | |LsRespBatch (Data BS.ByteString) 82 | |LsRespError String 83 | deriving (Generic) 84 | 85 | instance Show SlaveResponse where 86 | show (LsRespError e) = "LsRespError "++e 87 | show (LsRespVoid) = "LsRespVoid" 88 | show (LsRespFetch _) = "LsFetch" 89 | show (LsRespExecute v) = "LocalSlaveExecuteResult "++show v 90 | show (LsRespBatch _) = "LsRespBatch" 91 | 92 | -- | Creates a 'reset' request. 93 | resetCommand :: BS.ByteString -- ^ The serialized value of the seed. 94 | -> SlaveRequest -- ^ The reset request 95 | resetCommand seedBS = LsReqReset seedBS 96 | 97 | 98 | instance Binary SlaveRequest 99 | instance Binary SlaveResponse 100 | 101 | instance NFData SlaveResponse 102 | instance NFData SlaveRequest 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Runner/Simple.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | {-# LANGUAGE BangPatterns #-} 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | {-# LANGUAGE KindSignatures #-} 16 | {-# LANGUAGE MultiParamTypeClasses #-} 17 | {-# LANGUAGE OverloadedStrings #-} 18 | {-# LANGUAGE RankNTypes #-} 19 | {-# LANGUAGE RecordWildCards #-} 20 | {-# LANGUAGE ScopedTypeVariables #-} 21 | {-# LANGUAGE TemplateHaskell #-} 22 | 23 | 24 | module Control.Distributed.Blast.Runner.Simple 25 | ( 26 | runRec 27 | ) 28 | where 29 | 30 | import Debug.Trace 31 | import Control.Monad.IO.Class 32 | import Control.Monad.Logger 33 | import qualified Data.Map as M 34 | import qualified Data.Vector as Vc 35 | 36 | import Control.Distributed.Blast.Types 37 | 38 | data Exp (k::Kind) a where 39 | RApply :: Int -> ExpClosure Exp a b -> Exp 'Remote a -> Exp 'Remote b 40 | RConst :: Int -> ChunkFun a b -> IO a -> Exp 'Remote b 41 | LConst :: Int -> IO a -> Exp 'Local a 42 | Collect :: Int -> UnChunkFun b a -> Exp 'Remote b -> Exp 'Local a 43 | LApply :: Int -> Exp 'Local (a -> b) -> Exp 'Local a -> Exp 'Local b 44 | 45 | 46 | instance (Monad m) => Builder m Exp where 47 | makeRApply n f a = do 48 | return $ RApply n f a 49 | makeRConst n f a = do 50 | return $ RConst n f a 51 | makeLConst n a = do 52 | return $ LConst n a 53 | makeCollect n f a = do 54 | return $ Collect n f a 55 | makeLApply n f a = do 56 | return $ LApply n f a 57 | 58 | 59 | 60 | instance Indexable Exp where 61 | getIndex (RApply n _ _) = n 62 | getIndex (RConst n _ _ ) = n 63 | getIndex (LConst n _) = n 64 | getIndex (Collect n _ _) = n 65 | getIndex (LApply n _ _) = n 66 | 67 | 68 | 69 | 70 | 71 | -- | Runs a computation using a simple interpreter. Execute all computations on just one thread. 72 | runRec :: forall a b m. (MonadLoggerIO m) => 73 | JobDesc a b 74 | -> m (a, b) 75 | runRec (jobDesc@MkJobDesc {..}) = do 76 | let program = computationGen seed 77 | (refMap, count) <- generateReferenceMap 0 M.empty program 78 | !(e::Exp 'Local (a,b)) <- build refMap count program 79 | (a, b) <- liftIO $ runLocal e 80 | a' <- liftIO $ reportingAction a b 81 | case shouldStop seed a' b of 82 | True -> do 83 | return (a', b) 84 | False -> do 85 | runRec (jobDesc {seed = a'}) 86 | 87 | 88 | 89 | runFun :: ExpClosure Exp a b -> IO (a -> IO b) 90 | runFun (ExpClosure e f) = do 91 | r <- runLocal e 92 | return $ f r 93 | 94 | 95 | 96 | runRemote :: Exp 'Remote a -> IO a 97 | runRemote (RApply _ cs e) = do 98 | f' <- runFun cs 99 | e' <- runRemote e 100 | trace "RApply" $ f' e' 101 | 102 | runRemote (RConst _ chunkFun eio) = do 103 | e <- eio 104 | return (chunkFun 1 e Vc.! 0) 105 | where 106 | 107 | 108 | runLocal :: Exp 'Local a -> IO a 109 | runLocal (Collect _ unChunkFun e) = do 110 | b <- runRemote e 111 | return $ unChunkFun [b] 112 | runLocal (LConst _ a) = a 113 | runLocal (LApply _ f e) = do 114 | f' <- runLocal f 115 | e' <- runLocal e 116 | return $ f' e' 117 | 118 | -------------------------------------------------------------------------------- /examples/WordCount/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | 7 | 8 | module Main where 9 | 10 | --import Debug.Trace 11 | import Control.Distributed.Process (RemoteTable, Process) 12 | import Control.Distributed.Process.Node (initRemoteTable) 13 | import Control.Distributed.Process.Closure (mkClosure, remotable) 14 | import Control.Distributed.Static (Closure) 15 | import Control.Monad.Trans.Resource 16 | 17 | import qualified Data.ByteString as BS 18 | import Data.Conduit 19 | import Data.Conduit.Binary as CB 20 | import Data.Conduit.List as CL 21 | import qualified Data.List as L 22 | import qualified Data.Map.Strict as M 23 | import Data.Word 24 | 25 | 26 | import Control.Distributed.Blast 27 | import Control.Distributed.Blast.Syntax 28 | import Control.Distributed.Blast.Runner.CloudHaskell as CH 29 | 30 | 31 | import Common 32 | 33 | 34 | 35 | 36 | countChar :: M.Map Word8 Int -> BS.ByteString -> M.Map Word8 Int 37 | countChar m bs = 38 | BS.foldl' foldProc m bs 39 | where 40 | foldProc m' c = M.insertWith (+) c 1 m' 41 | 42 | 43 | reduceCharMap :: M.Map Word8 Int -> M.Map Word8 Int -> M.Map Word8 Int 44 | reduceCharMap acc m = M.unionWith (+) acc m 45 | 46 | expGenerator :: Int -> () -> LocalComputation ((), M.Map Word8 Int) 47 | expGenerator nbFiles () = do 48 | range <- rconst $ Range 1 (nbFiles+1) 49 | indexes <- rapply (fun rangeToList) range 50 | -- build the list of filenames to read. 51 | filenames <- rmap (fun (\i -> "./files/f"++show i++".txt")) indexes 52 | -- read each file 4 times (increase computation time) 53 | filenames' <- rflatmap (fun (\f -> L.replicate 4 f)) filenames 54 | -- creat source conduit 55 | sources <- rmap (fun sourceFile) filenames' 56 | -- read each each file and count the nb of occurence per characters 57 | countMaps <- rmap (funIO (\s -> runResourceT $ (s $$ CL.fold countChar M.empty))) sources 58 | 59 | -- reduce step 60 | zeroCountMap <- lconst M.empty 61 | reducedCount <- rfold' (foldFun reduceCharMap) (L.foldl' reduceCharMap M.empty) zeroCountMap countMaps 62 | 63 | r <- (\x -> ((), x)) <$$> reducedCount 64 | return r 65 | 66 | 67 | jobDesc :: JobDesc () (M.Map Word8 Int) 68 | jobDesc = MkJobDesc () (expGenerator 8) noReporting noIteration 69 | 70 | slaveClosure :: Int -> Process () 71 | slaveClosure = CH.slaveProcess rpcConfigAction jobDesc 72 | 73 | 74 | -- create remotables 75 | remotable ['slaveClosure] 76 | 77 | 78 | chClosure :: Int -> Closure (Process ()) 79 | chClosure = $(mkClosure 'slaveClosure) 80 | 81 | rtable :: RemoteTable 82 | rtable = __remoteTable initRemoteTable 83 | 84 | 85 | 86 | 87 | -- main functions, choose the one you want to run. 88 | 89 | mainCH :: IO () 90 | mainCH = runCloudHaskell rtable jobDesc chClosure 91 | 92 | mainLocal :: IO () 93 | mainLocal = do 94 | (_, r) <- runLocally True jobDesc 95 | print r 96 | 97 | 98 | {- 99 | 100 | cd examples/WordCount 101 | 102 | Run Local: 103 | wordcount 104 | 105 | Run with CloudHaskell 106 | 107 | * start slaves: 108 | 109 | wordcount slave host port 110 | 111 | * start master: 112 | 113 | wordcount master host port 114 | 115 | ex: 116 | > wordcount slave localhost 5001 117 | > wordcount slave localhost 5002 118 | > wordcount master localhost 5000 119 | 120 | -} 121 | 122 | main :: IO () 123 | main = mainLocal 124 | 125 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Master/Analyser.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | 11 | {-# LANGUAGE GADTs #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE DeriveGeneric #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | {-# LANGUAGE KindSignatures #-} 16 | {-# LANGUAGE MultiParamTypeClasses #-} 17 | {-# LANGUAGE OverloadedStrings #-} 18 | {-# LANGUAGE RankNTypes #-} 19 | {-# LANGUAGE TemplateHaskell #-} 20 | 21 | module Control.Distributed.Blast.Master.Analyser 22 | ( 23 | MExp (..) 24 | , InfoMap 25 | , LocalKey 26 | , analyseLocal 27 | , getLocalIndex 28 | , getRemoteIndex 29 | ) 30 | where 31 | 32 | --import Debug.Trace 33 | import Control.Bool (unlessM) 34 | import Control.Monad.Logger 35 | import Control.Monad.IO.Class 36 | import Control.Monad.Trans.State 37 | import qualified Data.ByteString as BS 38 | import qualified Data.Map as M 39 | import qualified Data.Set as S 40 | import qualified Data.Serialize as S 41 | import qualified Data.Text as T 42 | import qualified Data.Vault.Strict as V 43 | 44 | import Control.Distributed.Blast.Types 45 | import Control.Distributed.Blast.Common.Analyser 46 | 47 | type InfoMap = GenericInfoMap () 48 | 49 | type LocalKey a = V.Key (a, Maybe (Partition BS.ByteString)) 50 | 51 | data MExp (k::Kind) a where 52 | MRApply :: Int -> ExpClosure MExp a b -> MExp 'Remote a -> MExp 'Remote b 53 | MRConst :: (S.Serialize b) => Int -> V.Key (Partition BS.ByteString) -> ChunkFun a b -> IO a -> MExp 'Remote b 54 | MLConst :: Int -> LocalKey a -> IO a -> MExp 'Local a 55 | MCollect :: (S.Serialize b) => Int -> LocalKey a -> UnChunkFun b a -> MExp 'Remote b -> MExp 'Local a 56 | MLApply :: Int -> LocalKey b -> MExp 'Local (a -> b) -> MExp 'Local a -> MExp 'Local b 57 | 58 | 59 | 60 | instance (MonadLoggerIO m) => Builder m MExp where 61 | makeRApply i f a = do 62 | return $ MRApply i f a 63 | makeRConst i chunkFun a = do 64 | k <- liftIO V.newKey 65 | return $ MRConst i k chunkFun a 66 | makeLConst i a = do 67 | k <- liftIO V.newKey 68 | return $ MLConst i k a 69 | makeCollect i unChunkFun a = do 70 | k <- liftIO V.newKey 71 | return $ MCollect i k unChunkFun a 72 | makeLApply i f a = do 73 | k <- liftIO V.newKey 74 | return $ MLApply i k f a 75 | 76 | 77 | 78 | 79 | instance Indexable MExp where 80 | getIndex (MRApply n _ _) = n 81 | getIndex (MRConst n _ _ _) = n 82 | getIndex (MLConst n _ _) = n 83 | getIndex (MCollect n _ _ _) = n 84 | getIndex (MLApply n _ _ _) = n 85 | 86 | 87 | 88 | 89 | getRemoteIndex :: MExp 'Remote a -> Int 90 | getRemoteIndex (MRApply i _ _) = i 91 | getRemoteIndex (MRConst i _ _ _) = i 92 | 93 | getLocalIndex :: MExp 'Local a -> Int 94 | getLocalIndex (MLConst i _ _) = i 95 | getLocalIndex (MCollect i _ _ _) = i 96 | getLocalIndex (MLApply i _ _ _) = i 97 | 98 | 99 | 100 | visit :: Int -> InfoMap -> InfoMap 101 | visit n m = 102 | case M.lookup n m of 103 | Just (GenericInfo _ _) -> error ("Node " ++ show n ++ " has already been visited") 104 | Nothing -> M.insert n (GenericInfo S.empty ()) m 105 | 106 | 107 | visitRemoteM :: forall a m. (MonadLoggerIO m) => 108 | MExp 'Remote a -> StateT InfoMap m () 109 | visitRemoteM e = do 110 | let n = getRemoteIndex e 111 | $(logInfo) $ T.pack ("Visiting node: " ++ show n) 112 | m <- get 113 | put $ visit n m 114 | 115 | visitLocalM :: forall a m. (MonadLoggerIO m) => 116 | MExp 'Local a -> StateT InfoMap m () 117 | visitLocalM e = do 118 | let n = getLocalIndex e 119 | $(logInfo) $ T.pack ("Visiting node: " ++ show n) 120 | m <- get 121 | put $ visit n m 122 | 123 | 124 | analyseRemote :: (MonadLoggerIO m) => MExp 'Remote a -> StateT InfoMap m () 125 | analyseRemote e@(MRApply n (ExpClosure ce _) a) = 126 | unlessM (wasVisitedM n) $ do 127 | analyseRemote a 128 | referenceM n (getRemoteIndex a) 129 | analyseLocal ce 130 | referenceM n (getLocalIndex ce) 131 | visitRemoteM e 132 | 133 | 134 | 135 | analyseRemote e@(MRConst n _ _ _) = unlessM (wasVisitedM n) $ visitRemoteM e 136 | 137 | 138 | analyseLocal :: (MonadLoggerIO m) => MExp 'Local a -> StateT InfoMap m () 139 | 140 | analyseLocal e@(MLConst n _ _) = unlessM (wasVisitedM n) $ visitLocalM e 141 | 142 | analyseLocal e@(MCollect n _ _ a) = 143 | unlessM (wasVisitedM n) $ do 144 | analyseRemote a 145 | referenceM n (getRemoteIndex a) 146 | visitLocalM e 147 | 148 | analyseLocal e@(MLApply n _ f a) = 149 | unlessM (wasVisitedM n) $ do 150 | analyseLocal f 151 | analyseLocal a 152 | visitLocalM e 153 | 154 | 155 | 156 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Runner/Local.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | {-# LANGUAGE BangPatterns #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE DeriveGeneric #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | {-# LANGUAGE GADTs #-} 16 | {-# LANGUAGE MultiParamTypeClasses #-} 17 | {-# LANGUAGE OverloadedStrings #-} 18 | {-# LANGUAGE RankNTypes #-} 19 | {-# LANGUAGE RecordWildCards #-} 20 | {-# LANGUAGE ScopedTypeVariables #-} 21 | {-# LANGUAGE TemplateHaskell #-} 22 | 23 | 24 | module Control.Distributed.Blast.Runner.Local 25 | ( 26 | runRec 27 | ) 28 | where 29 | 30 | --import Debug.Trace 31 | import Control.Concurrent 32 | import Control.Concurrent.Async 33 | import Control.DeepSeq 34 | import Control.Monad 35 | import Control.Monad.IO.Class 36 | import Control.Monad.Logger 37 | 38 | import qualified Data.Map as M 39 | import qualified Data.Serialize as S 40 | 41 | import System.Random 42 | 43 | import Control.Distributed.Blast 44 | import Control.Distributed.Blast.Distributed.Interface 45 | 46 | 47 | 48 | -- | Runs a computation locally. 49 | -- Uses threads to distribute the remote computations. 50 | runRec :: forall a b m. 51 | (m ~ LoggingT IO, S.Serialize a, S.Serialize b) => 52 | Int -- ^ Number of slaves. 53 | -> Config -- ^ Configuration. 54 | -> JobDesc a b -- ^ Job to execute. 55 | -> m (a, b) -- ^ Results. 56 | runRec nbSlaves config jobDesc = do 57 | controller <- createController config nbSlaves jobDesc 58 | doRunRec config controller jobDesc 59 | 60 | 61 | doRunRec :: forall a b m. 62 | (S.Serialize a, S.Serialize b, MonadLoggerIO m) => 63 | Config -> Controller a -> JobDesc a b -> m (a, b) 64 | doRunRec config@(MkConfig {..}) s (jobDesc@MkJobDesc {..}) = do 65 | (a, b) <- runComputation config s jobDesc 66 | a' <- liftIO $ reportingAction a b 67 | case shouldStop seed a' b of 68 | True -> return (a', b) 69 | False -> doRunRec config s (jobDesc {seed = a'}) 70 | 71 | 72 | data RemoteChannels = MkRemoteChannels { 73 | iocOutChan :: Chan SlaveRequest 74 | ,iocInChan :: Chan SlaveResponse 75 | } 76 | 77 | data Controller a = MkController { 78 | slaveChannels :: M.Map Int RemoteChannels 79 | , seedM :: Maybe a 80 | , config :: Config 81 | , statefullSlaveMode :: Bool 82 | } 83 | 84 | 85 | randomSlaveReset :: (S.Serialize a) => Controller a -> Int -> IO () 86 | randomSlaveReset s@(MkController {config = MkConfig {..}, seedM = seedM}) slaveId = do 87 | case seedM of 88 | Just a -> do 89 | r <- randomRIO (0.0, 1.0) 90 | when (r > slaveAvailability) $ do 91 | let req = resetCommand (S.encode a) 92 | _ <- send s slaveId req 93 | return () 94 | Nothing -> return () 95 | 96 | instance (S.Serialize a) => CommandClass Controller a where 97 | isStatefullSlave (MkController{ statefullSlaveMode = mode }) = mode 98 | getNbSlaves (MkController {..}) = M.size slaveChannels 99 | 100 | send s@(MkController {..}) slaveId req = do 101 | randomSlaveReset s slaveId 102 | let (MkRemoteChannels {..}) = slaveChannels M.! slaveId 103 | let !req' = force req 104 | writeChan iocOutChan req' 105 | resp <- readChan iocInChan 106 | return $ Right resp 107 | 108 | stop _ = return () 109 | setSeed s@(MkController {..}) a = do 110 | let s' = s {seedM = Just a} 111 | resetAll s' 112 | return s' 113 | where 114 | resetAll as = do 115 | let nbSlaves = getNbSlaves as 116 | let slaveIds = [0 .. nbSlaves - 1] 117 | let req = resetCommand (S.encode a) 118 | _ <- mapConcurrently (\slaveId -> send as slaveId req) slaveIds 119 | return () 120 | 121 | createController :: (S.Serialize a) => 122 | Config -> Int -> JobDesc a b 123 | -> LoggingT IO (Controller a) 124 | createController cf@(MkConfig {..}) nbSlaves jobDesc@(MkJobDesc {..}) = do 125 | m <- liftIO $ foldM proc M.empty [0..nbSlaves-1] 126 | return $ MkController m Nothing cf statefullSlaves 127 | where 128 | proc acc i = do 129 | (iChan, oChan, ls) <- createOneSlave i 130 | let rc = MkRemoteChannels iChan oChan 131 | _ <- (forkIO $ runSlave iChan oChan ls) 132 | return $ M.insert i rc acc 133 | 134 | createOneSlave slaveId = do 135 | iChan <- newChan 136 | oChan <- newChan 137 | return $ (iChan, oChan, makeSlaveContext cf slaveId jobDesc) 138 | 139 | 140 | runSlave :: (S.Serialize a) => Chan SlaveRequest -> Chan SlaveResponse -> SlaveContext (LoggingT IO) a b -> IO () 141 | runSlave inChan outChan als = 142 | runStdoutLoggingT $ go als 143 | where 144 | go ls = do 145 | req <- liftIO $ readChan inChan 146 | (resp, ls') <- runCommand req ls 147 | let resp' = force resp 148 | liftIO $ writeChan outChan resp' 149 | go ls' 150 | 151 | 152 | 153 | 154 | 155 | -------------------------------------------------------------------------------- /test/Test/Computation.hs: -------------------------------------------------------------------------------- 1 | {- 2 | This Source Code Form is subject to the terms of the Mozilla Public 3 | License, v. 2.0. If a copy of the MPL was not distributed with this 4 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 5 | -} 6 | 7 | {-# LANGUAGE AllowAmbiguousTypes #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE ImpredicativeTypes #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeSynonymInstances #-} 14 | 15 | module Test.Computation 16 | where 17 | 18 | import Debug.Trace 19 | import Control.Monad.Logger 20 | import Control.Monad.IO.Class 21 | import qualified Data.List as L 22 | import Data.Proxy 23 | import qualified Data.Vector as V 24 | 25 | import Test.HUnit 26 | import Test.Framework 27 | import Test.Framework.Providers.HUnit 28 | import Test.Framework.Providers.QuickCheck2 (testProperty) 29 | import Test.QuickCheck 30 | import Test.QuickCheck.Arbitrary 31 | import Test.QuickCheck.Monadic 32 | import Test.QuickCheck.Random 33 | import Test.QuickCheck.Gen 34 | 35 | import Control.Distributed.Blast as S 36 | import Control.Distributed.Blast.Runner.Local as Loc 37 | import Control.Distributed.Blast.Runner.Simple as S 38 | import Control.Distributed.Blast.Syntax as S 39 | 40 | import Control.Distributed.Blast.Distributed.Interface as I 41 | 42 | 43 | 44 | generateOne :: Int -> Gen a -> a 45 | generateOne seed (MkGen g) = 46 | g qCGen 30 47 | where 48 | qCGen = mkQCGen seed 49 | 50 | tests = [ 51 | testProperty "testComputation" testComputation 52 | ] 53 | 54 | testComputation :: Property 55 | testComputation = 56 | monadicIO $ forAllM arbitrary prop 57 | 58 | 59 | prop :: Int -> PropertyM IO Bool 60 | prop seed = do 61 | (a1, b1::Int) <- liftIO $ prop1 (jobDescFun ()) 62 | (a2, b2::Int) <- liftIO $ prop2 (jobDescFun ()) 63 | (a3, b3::Int) <- liftIO $ prop3 (jobDescFun ()) 64 | 65 | return $ (a1, b1) == (a2, b2) 66 | && (a1, b1) == (a3, b3) 67 | where 68 | depth = 100 69 | jobDescFun () = 70 | let proc a = do 71 | let computation = generateOne seed (compGen depth) 72 | 73 | b <- computation 74 | a' <- lconst (a+1) 75 | r <- ((,) <$$> a' <**> b) 76 | return r 77 | jobDesc = MkJobDesc (0::Int) 78 | proc 79 | (\a _ -> return a) 80 | (\_ x _ -> x==1) 81 | in jobDesc 82 | 83 | 84 | prop1 :: JobDesc Int Int -> IO (Int, Int) 85 | prop1 jobDesc = do 86 | (a1, b1::Int) <- runStdoutLoggingT $ S.runRec jobDesc 87 | return (a1, b1) 88 | 89 | 90 | prop2 :: JobDesc Int Int -> IO (Int, Int) 91 | prop2 jobDesc = do 92 | let cf = defaultConfig { statefullSlaves = True } 93 | (a2, b2::Int) <- runStdoutLoggingT $ Loc.runRec 4 cf jobDesc 94 | return (a2, b2) 95 | 96 | prop3 :: JobDesc Int Int -> IO (Int, Int) 97 | prop3 jobDesc = do 98 | let cf = defaultConfig { statefullSlaves = False } 99 | (a2, b2::Int) <- runStdoutLoggingT $ Loc.runRec 4 cf jobDesc 100 | return (a2, b2) 101 | 102 | 103 | go :: forall m e. (Monad m, Builder m e) => Int -> [Computation m e 'Remote [Int]] -> [Computation m e 'Local Int] -> Gen (Computation m e 'Local Int) 104 | go 0 _ locals = elements locals 105 | go n remotes locals = do 106 | b <- arbitrary 107 | case b of 108 | True -> do 109 | remotes' <- addRemote remotes locals 110 | go (n-1) remotes' locals 111 | False -> do 112 | locals' <- addLocal remotes locals 113 | go (n-1) remotes locals' 114 | 115 | compGen :: forall m e. (Monad m, Builder m e) => Int -> Gen (Computation m e 'Local Int) 116 | compGen n = do 117 | let remotes0 = [rconst []] 118 | let locals0 = [lconst (0::Int)] 119 | computation <- go n remotes0 locals0 120 | return computation 121 | where 122 | 123 | 124 | addRemote :: forall m e. (Monad m, Builder m e) 125 | => [Computation m e 'Remote [Int]] 126 | -> [Computation m e 'Local Int] 127 | -> Gen [Computation m e 'Remote [Int]] 128 | addRemote remotes locals = do 129 | frequency [(1, gen1), (1, gen2)] 130 | where 131 | gen1 :: Gen [Computation m e 'Remote [Int]] 132 | gen1 = do 133 | local <- elements locals 134 | remote <- elements remotes 135 | let (c :: Computation m e 'Remote [Int]) = do 136 | r <- remote 137 | a <- local 138 | rmap (closure a (\a' e -> e+a')) r 139 | return (c:remotes) 140 | gen2 :: Gen [Computation m e 'Remote [Int]] 141 | gen2 = do 142 | n <- choose (10, 50) 143 | vals <- vectorOf n (choose (-1, 1)) 144 | let (c :: Computation m e 'Remote [Int]) = rconst vals 145 | return (c:remotes) 146 | 147 | 148 | 149 | 150 | addLocal ::forall m e. (Monad m, Builder m e) 151 | => [Computation m e 'Remote [Int]] 152 | -> [Computation m e 'Local Int] 153 | -> Gen [Computation m e 'Local Int] 154 | addLocal remotes locals = do 155 | frequency [(1, gen1), (1, gen2), (1, gen3), (1, gen4)] 156 | gen3 157 | where 158 | gen1 = do 159 | remote <- elements remotes 160 | let c = do 161 | r <- remote 162 | a <- S.collect r 163 | zero <- lconst (0::Int) 164 | lfold' (+) zero a 165 | return (c:locals) 166 | gen2 = do 167 | v <- choose (-1, 1) 168 | let c = lconst v 169 | return (c:locals) 170 | gen3 = do 171 | l1 <- elements locals 172 | l2 <- elements locals 173 | let c = do 174 | a1 <- l1 175 | a2 <- l2 176 | (+) <$$> a1 <**> a2 177 | return (c:locals) 178 | gen4 = do 179 | remote <- elements remotes 180 | zero <- elements locals 181 | offset <- elements locals 182 | let c = do 183 | r <- remote 184 | z <- zero 185 | o <- offset 186 | rfold' (foldClosure o (\a b c -> a+b+c)) (L.foldl' (+) 0) z r 187 | return (c:locals) 188 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Distributed/Slave.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE BangPatterns #-} 11 | {-# LANGUAGE DeriveGeneric #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE GADTs #-} 15 | {-# LANGUAGE MultiParamTypeClasses #-} 16 | {-# LANGUAGE OverloadedStrings #-} 17 | {-# LANGUAGE RankNTypes #-} 18 | {-# LANGUAGE RecordWildCards #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | {-# LANGUAGE TemplateHaskell #-} 21 | 22 | 23 | module Control.Distributed.Blast.Distributed.Slave 24 | ( 25 | SlaveContext (..) 26 | , runCommand 27 | , makeSlaveContext 28 | ) 29 | where 30 | 31 | --import Debug.Trace 32 | import Control.Monad 33 | import Control.Monad.IO.Class 34 | import Control.Monad.Logger 35 | import Control.Monad.Operational 36 | import Control.Monad.Trans.State 37 | 38 | import qualified Data.Map as M 39 | import qualified Data.Serialize as S 40 | import qualified Data.Vault.Strict as V 41 | 42 | 43 | import Control.Distributed.Blast.Types 44 | import Control.Distributed.Blast.Distributed.Types 45 | import Control.Distributed.Blast.Common.Analyser 46 | import Control.Distributed.Blast.Slave.Analyser 47 | 48 | 49 | 50 | -- | Describes the current context of a slave. 51 | data SlaveContext m a b = MkSlaveContext { 52 | localSlaveId :: Int -- todo maybe not useful 53 | , infos :: InfoMap 54 | , vault :: V.Vault 55 | , expGen :: a -> ProgramT (Syntax m) m (SExp 'Local (a, b)) 56 | , config :: Config 57 | } 58 | 59 | -- | Creates a "SlaveContext" for a given slave. 60 | makeSlaveContext :: (MonadLoggerIO m) 61 | => Config -- ^ Configuration 62 | -> Int -- ^Index of the slave. 63 | -> JobDesc a b -- ^ Job description 64 | -> SlaveContext m a b -- ^ Slave Context 65 | makeSlaveContext config slaveId (MkJobDesc {..}) = 66 | MkSlaveContext slaveId M.empty V.empty computationGen config 67 | 68 | -- | Runs the given command against the specified state of a slave. 69 | runCommand :: forall a b m. (S.Serialize a, MonadLoggerIO m) 70 | => SlaveRequest -- ^ Command. 71 | -> SlaveContext m a b -- ^ Slave context 72 | -> m (SlaveResponse, SlaveContext m a b) -- ^ Returns the response from the slave and the new slave context. 73 | runCommand (LsReqReset bs) ls@(MkSlaveContext {..}) = do 74 | case S.decode bs of 75 | Left e -> error e 76 | Right a -> do 77 | let program = expGen a 78 | (refMap, count) <- generateReferenceMap 0 M.empty program 79 | (e::SExp 'Local (a,b)) <- build refMap count program 80 | infos' <- execStateT (analyseLocal e) M.empty 81 | let ls' = ls {infos = infos', vault = V.empty} 82 | return (LsRespVoid, ls') 83 | runCommand (LsReqExecute i) ls = do 84 | case M.lookup i (infos ls) of 85 | Just (GenericInfo _ (NtRMap (MkRMapInfo cs _ _))) -> do 86 | (res, vault') <- liftIO $ cs (vault ls) 87 | let ls' = ls {vault = vault'} 88 | case res of 89 | RcRespError err -> return (LsRespError err, ls') 90 | _ -> return (LsRespExecute res, ls') 91 | _ -> return (LsRespError ("Info not found: "++show i), ls) 92 | runCommand (LsReqCache i bs) ls = 93 | case M.lookup i (infos ls) of 94 | Just (GenericInfo _ (NtRConst (MkRConstInfo cacherFun _ _))) -> do 95 | let vault' = cacherFun bs (vault ls) 96 | return (LsRespVoid, ls {vault = vault'}) 97 | 98 | Just (GenericInfo _ (NtLExp (MkLExpInfo cacherFun _ ))) -> do 99 | case bs of 100 | Data bs' -> do 101 | let vault' = cacherFun bs' (vault ls) 102 | return (LsRespVoid, ls {vault = vault'}) 103 | NoData -> return (LsRespError ("NtLExp trying to cache no data: "++show i), ls) 104 | Just (GenericInfo _ (NtRMap _)) -> return (LsRespError ("NtRMap GenericInfo not found: "++show i), ls) 105 | Just (GenericInfo _ (NtLExpNoCache)) -> return (LsRespError ("NtLExpNoCache GenericInfo not found: "++show i), ls) 106 | _ -> return (LsRespError ("Nothing : GenericInfo not found: "++show i), ls) 107 | runCommand (LsReqUncache i) ls = do 108 | case M.lookup i (infos ls) of 109 | Just (GenericInfo _ (NtRMap (MkRMapInfo _ unCacherFun _))) -> do 110 | let vault' = unCacherFun (vault ls) 111 | return (LsRespVoid, ls {vault = vault'}) 112 | Just (GenericInfo _ (NtRConst (MkRConstInfo _ unCacherFun _))) -> do 113 | let vault' = unCacherFun (vault ls) 114 | return (LsRespVoid, ls {vault = vault'}) 115 | Just (GenericInfo _ (NtLExp (MkLExpInfo _ unCacherFun))) -> do 116 | let vault' = unCacherFun (vault ls) 117 | return (LsRespVoid, ls {vault = vault'}) 118 | _ -> return (LsRespError ("GenericInfo not found: "++show i), ls) 119 | runCommand (LsReqFetch i) ls = do 120 | case M.lookup i (infos ls) of 121 | Just (GenericInfo _ (NtRMap (MkRMapInfo _ _ (Just cacheReaderFun)))) -> do 122 | case cacheReaderFun (vault ls) of 123 | Just a -> return (LsRespFetch a, ls) 124 | Nothing -> return (LsRespFetchMiss, ls) 125 | Just (GenericInfo _ (NtRConst (MkRConstInfo _ _ (Just cacheReaderFun)))) -> do 126 | case cacheReaderFun (vault ls) of 127 | Just a -> return (LsRespFetch a, ls) 128 | Nothing -> return (LsRespFetchMiss , ls) 129 | _ -> return $ (LsRespError "Cannot fetch results", ls) 130 | runCommand (LsReqBatch nRes requests) ls = do 131 | ls' <- foldM (\acc req -> do (_, acc') <- runCommand req acc 132 | return acc') ls requests 133 | -- fetch results 134 | (res, ls'') <- runCommand (LsReqFetch nRes) ls' 135 | case res of 136 | LsRespFetch r -> return $ (LsRespBatch r, ls'') 137 | LsRespFetchMiss -> return $ (LsRespError "Fetch miss in Batch", ls'') 138 | LsRespError err -> return $ (LsRespError err, ls'') 139 | _ -> return $ (LsRespError "Batch: bad response", ls'') 140 | 141 | -------------------------------------------------------------------------------- /examples/Simple/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | 11 | 12 | module Main where 13 | 14 | import qualified Data.List as L 15 | import Data.Map as M 16 | 17 | import Control.Distributed.Process (RemoteTable, Process) 18 | import Control.Distributed.Process.Node (initRemoteTable) 19 | import Control.Distributed.Process.Closure (mkClosure, remotable) 20 | import Control.Distributed.Static (Closure) 21 | 22 | import Control.Distributed.Blast 23 | import Control.Distributed.Blast.Runner.CloudHaskell as CH 24 | import Control.Distributed.Blast.Syntax 25 | 26 | import Common 27 | 28 | 29 | -- Example 1: Simple mapping. Sum of fibonacci numbers 30 | 31 | comp1 :: () -> LocalComputation ((), Int) 32 | comp1 () = do 33 | -- create a remote list [32, 32, 32 ,...] 34 | r1 <- rconst [ (31::Int)| _ <- [1..32::Int]] 35 | -- map fib over the remote list r1 36 | r2 <- rmap (fun fib) r1 37 | -- repatriate the results locally. 38 | l1 <- collect r2 39 | -- sum them 40 | l2 <- sum <$$> l1 41 | -- associate new seed 42 | r <- (\x -> ((), x)) <$$> l2 43 | return r 44 | 45 | -- create the job, no intermediate reporting, no iteration. 46 | 47 | jobDesc1 :: JobDesc () Int 48 | jobDesc1 = MkJobDesc () comp1 noReporting noIteration 49 | 50 | slaveClosure1 :: Int -> Process () 51 | slaveClosure1 = CH.slaveProcess rpcConfigAction jobDesc1 52 | 53 | 54 | 55 | 56 | -- Example 2: Simple optimized folding on both slaves and master. Sum of fibonacci numbers 57 | 58 | comp2 :: () -> LocalComputation ((), Int) 59 | comp2 () = do 60 | -- create a remote list [32, 32, 32 ,...] 61 | r1 <- rconst [ (31::Int)| _ <- [1..32::Int]] 62 | -- fold over the remote list r1 63 | zero <- lconst (0::Int) 64 | l1 <- rfold' (foldFun (\acc i -> acc + fib i)) sum zero r1 65 | -- associate new seed 66 | r <- (\x -> ((), x)) <$$> l1 67 | return r 68 | 69 | 70 | -- create the job, no intermediate reporting, no iteration. 71 | 72 | jobDesc2 :: JobDesc () Int 73 | jobDesc2 = MkJobDesc () comp2 noReporting noIteration 74 | 75 | slaveClosure2 :: Int -> Process () 76 | slaveClosure2 = CH.slaveProcess rpcConfigAction jobDesc2 77 | 78 | 79 | 80 | 81 | -- Example 3: Simple iterative process. 82 | strangeConjecture :: Int -> Int 83 | strangeConjecture 1 = 1 84 | strangeConjecture n | even n = n `div` 2 85 | strangeConjecture n = 3 * n + 1 86 | 87 | comp3 :: [Int] -> LocalComputation ([Int], Int) 88 | comp3 ints = do 89 | r1 <- rconst ints 90 | r2 <- rmap (fun strangeConjecture) r1 91 | l1 <- collect r2 92 | l2 <- removeOnes <$$> l1 93 | lc <- L.length <$$> l2 94 | r <- (,) <$$> l2 <**> lc 95 | return r 96 | where 97 | removeOnes l = L.filter (\x -> x > 1) l 98 | 99 | -- create the job, iterate until the result list is empty 100 | 101 | jobDesc3 :: JobDesc [Int] Int 102 | jobDesc3 = 103 | MkJobDesc ints comp3 report stop 104 | where 105 | ints = [1..1000] 106 | report a c = do 107 | putStrLn $ "Nb of remaining ints: " ++ show c 108 | return a 109 | stop _ _ c = c==0 110 | 111 | 112 | slaveClosure3 :: Int -> Process () 113 | slaveClosure3 = CH.slaveProcess rpcConfigAction jobDesc3 114 | 115 | -- Example 4: Elaborate on example 3: 116 | -- Compute the number of calls to strange required to reach 1. 117 | 118 | comp4 :: ([(Int, Int, Int)], Map Int Int) -> LocalComputation (([(Int, Int, Int)], Map Int Int), ()) 119 | comp4 (values, m) = do 120 | r1 <- rconst values 121 | r2 <- rmap (fun mapStrange) r1 122 | l1 <- collect r2 123 | l2 <- (removeOnes m) <$$> l1 124 | r <- (\x -> (x, ())) <$$> l2 125 | return r 126 | where 127 | mapStrange (i, n, c) = (i, strangeConjecture n, c+1) 128 | removeOnes :: (M.Map Int Int) -> [(Int, Int, Int)] -> ([(Int, Int, Int)], M.Map Int Int) 129 | removeOnes m' l = 130 | L.foldl' proc ([], m') l 131 | where 132 | proc (acc, m'') e@(i, n, c) = 133 | if n > 1 134 | then (e:acc, m'') 135 | else (acc, M.insert i c m'') 136 | 137 | -- create the job, iterate until the result list is empty 138 | 139 | jobDesc4 :: JobDesc ([(Int, Int, Int)], (M.Map Int Int)) () 140 | jobDesc4 = 141 | MkJobDesc (values, M.empty) comp4 report stop 142 | where 143 | values = [(i, i, 0) | i <- [1..1000]] 144 | report a@(values', _) () = do 145 | putStrLn $ "Nb of remaining values: " ++ show (L.length values') 146 | return a 147 | stop _ (values', _) () = L.length values' == 0 148 | 149 | 150 | slaveClosure4 :: Int -> Process () 151 | slaveClosure4 = CH.slaveProcess rpcConfigAction jobDesc4 152 | 153 | 154 | 155 | -- Example 5: Simple closure. 156 | 157 | comp5 :: () -> LocalComputation ((), Int) 158 | comp5 () = do 159 | r1 <- rconst [1..1000::Int] 160 | lc1 <- lconst 2 161 | r2 <- rmap (closure lc1 (\c a -> a*c)) r1 162 | l1 <- collect r2 163 | l2 <- sum <$$> l1 164 | r <- (\x -> ((), x)) <$$> l2 165 | return r 166 | 167 | -- create the job, no intermediate reporting, no iteration. 168 | 169 | jobDesc5 :: JobDesc () Int 170 | jobDesc5 = MkJobDesc () comp5 noReporting noIteration 171 | 172 | slaveClosure5 :: Int -> Process () 173 | slaveClosure5 = CH.slaveProcess rpcConfigAction jobDesc5 174 | 175 | 176 | 177 | 178 | 179 | -- create remotables 180 | remotable ['slaveClosure1, 'slaveClosure2, 'slaveClosure3, 'slaveClosure4, 'slaveClosure5] 181 | 182 | 183 | chClosure1 :: Int -> Closure (Process ()) 184 | chClosure1 = $(mkClosure 'slaveClosure1) 185 | 186 | chClosure2 :: Int -> Closure (Process ()) 187 | chClosure2 = $(mkClosure 'slaveClosure2) 188 | 189 | chClosure3 :: Int -> Closure (Process ()) 190 | chClosure3 = $(mkClosure 'slaveClosure3) 191 | 192 | chClosure4 :: Int -> Closure (Process ()) 193 | chClosure4 = $(mkClosure 'slaveClosure4) 194 | 195 | chClosure5 :: Int -> Closure (Process ()) 196 | chClosure5 = $(mkClosure 'slaveClosure5) 197 | 198 | rtable :: RemoteTable 199 | rtable = __remoteTable initRemoteTable 200 | 201 | 202 | 203 | 204 | -- main functions, choose the one you want to run. 205 | 206 | mainCH1 :: IO () 207 | mainCH1 = runCloudHaskell rtable jobDesc1 chClosure1 208 | 209 | mainLocal1 :: IO () 210 | mainLocal1 = do 211 | (_, r) <- runLocally True jobDesc1 212 | print r 213 | 214 | 215 | mainCH2 :: IO () 216 | mainCH2 = runCloudHaskell rtable jobDesc2 chClosure2 217 | 218 | mainLocal2 :: IO () 219 | mainLocal2 = do 220 | (_, r) <- runLocally True jobDesc2 221 | print r 222 | 223 | 224 | mainCH3 :: IO () 225 | mainCH3 = runCloudHaskell rtable jobDesc3 chClosure3 226 | 227 | mainLocal3 :: IO () 228 | mainLocal3 = do 229 | (_, r) <- runLocally True jobDesc3 230 | print r 231 | 232 | 233 | mainCH4 :: IO () 234 | mainCH4 = runCloudHaskell rtable jobDesc4 chClosure4 235 | 236 | mainLocal4 :: IO () 237 | mainLocal4 = do 238 | (([], m), ()) <- runLocally True jobDesc4 239 | print m 240 | 241 | 242 | mainCH5 :: IO () 243 | mainCH5 = runCloudHaskell rtable jobDesc4 chClosure4 244 | 245 | mainLocal5 :: IO () 246 | mainLocal5 = do 247 | (_, r) <- runLocally True jobDesc5 248 | print r 249 | 250 | 251 | 252 | {- 253 | Run Local: 254 | simple 255 | 256 | Run with CloudHaskell 257 | 258 | * start slaves: 259 | 260 | simple slave host port 261 | 262 | * start master: 263 | 264 | simple master host port 265 | 266 | ex: 267 | > simple slave localhost 5001 268 | > simple slave localhost 5002 269 | > simple master localhost 5000 270 | 271 | -} 272 | 273 | -- main and rtable 274 | main :: IO () 275 | main = mainLocal1 276 | 277 | 278 | -------------------------------------------------------------------------------- /examples/KMeans/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | 7 | 8 | module Main where 9 | 10 | 11 | --import Debug.Trace 12 | import Control.DeepSeq 13 | import qualified Data.List as L 14 | 15 | import qualified Data.Map.Strict as M 16 | 17 | import Control.Distributed.Process (RemoteTable, Process) 18 | import Control.Distributed.Process.Node (initRemoteTable) 19 | import Control.Distributed.Process.Closure (mkClosure, remotable) 20 | import Control.Distributed.Static (Closure) 21 | 22 | import System.Random 23 | 24 | import Control.Distributed.Blast 25 | import Control.Distributed.Blast.Runner.CloudHaskell as CH 26 | import Control.Distributed.Blast.Syntax 27 | 28 | import Common 29 | 30 | 31 | type Point = (Double, Double) 32 | 33 | dist :: forall a. Num a => (a, a) -> (a, a) -> a 34 | dist (x1, y1) (x2, y2) = let 35 | dx = x2-x1 36 | dy = y2 -y1 37 | in dx * dx + dy * dy 38 | 39 | p0 :: Point 40 | p0 = (0, 0) 41 | 42 | chooseCenter :: M.Map Point (Point, Int) -> Point -> M.Map Point (Point, Int) 43 | chooseCenter centerAndSums p = 44 | r 45 | where 46 | !r = force $ M.insertWith (\((x0, y0), _) ((x, y), n) -> ((x0+x, y0+y), n+1)) bestCenter (p, 1) centerAndSums 47 | 48 | bestCenter = findCenter c d t 49 | (c:t) = M.keys centerAndSums 50 | d = dist c p 51 | findCenter currentCenter _ [] = currentCenter 52 | findCenter currentCenter currentDist (center:rest) = let 53 | d' = dist center p 54 | in if d' < currentDist 55 | then findCenter center d' rest 56 | else findCenter currentCenter currentDist rest 57 | 58 | 59 | computeNewCenters :: [M.Map Point (Point, Int)] -> M.Map Point Point 60 | computeNewCenters l = 61 | y 62 | where 63 | l1 = do 64 | m <- l 65 | M.toList m 66 | x::M.Map Point [(Point, Int)] 67 | x = L.foldl' (\m (c, (p,n)) -> M.insertWith (++) c [(p, n)] m) M.empty l1 68 | y::M.Map Point Point 69 | y = M.map (\l' -> let (ps, ns) = L.unzip l' 70 | (xs, ys) = L.unzip ps 71 | sumX = sum xs 72 | sumY = sum ys 73 | n = sum ns 74 | r = (sumX / (fromIntegral n), sumY / (fromIntegral n)) 75 | in r) 76 | x 77 | 78 | deltaCenter :: M.Map Point Point -> Double 79 | deltaCenter centers = 80 | r 81 | where 82 | r = maximum l 83 | l = L.map (\(p1, p2) -> sqrt $ dist p1 p2) $ M.toList centers 84 | 85 | stop :: forall t t1 t2. Double -> (t1, Double) -> (t2, Double) -> t -> Bool 86 | stop tol (_, x) (_, y::Double) _ = abs (x - y) < tol 87 | 88 | 89 | -- example 1: based on a random generator, the cloud of points is generated on the master (no IO). 90 | 91 | kmeansComputation1 :: StdGen -> Int -> ([Point], Double) -> LocalComputation (([Point], Double), [Point]) 92 | kmeansComputation1 stdGen nbPoints (centers, _) = do 93 | let vals = randomRs (0, 1) stdGen 94 | let points = L.take nbPoints $ makePoints vals 95 | rpoints <- rconst $ points 96 | centers0 <- lconst $ M.fromList $ L.map (\c -> (c, (p0, 0::Int))) centers 97 | centerMap <- rfold' (foldFun chooseCenter) computeNewCenters centers0 rpoints 98 | var' <- deltaCenter <$$> centerMap 99 | centers' <- M.elems <$$> centerMap 100 | r <- (,) <$$> centers' <**> var' 101 | (,) <$$> r <**> centers' 102 | where 103 | makePoints [] = [] 104 | makePoints [_] = [] 105 | makePoints (x:y:r) = (x,y):makePoints r 106 | 107 | 108 | jobDesc1 :: JobDesc ([(Double, Double)], Double) [Point] 109 | jobDesc1 = 110 | MkJobDesc (centers, 1000.0) (kmeansComputation1 stdGen nbPoints) noReporting (stop 0.1) 111 | where 112 | stdGen = mkStdGen 31415 113 | nbPoints = 100 114 | centers = [(0.0, 0.0), (1.0, 1.0)] 115 | 116 | 117 | slaveClosure1 :: Int -> Process () 118 | slaveClosure1 = CH.slaveProcess rpcConfigAction jobDesc1 119 | 120 | 121 | 122 | 123 | -- example 2: the cloud of points is generated on the master from a IO action 124 | -- This simulates the case where the master reads some data (from a file, queue etc.) and sends it to the slaves. 125 | kmeansComputation2 :: Int -> Int -> ([Point], Double) -> LocalComputation (([Point], Double), [Point]) 126 | kmeansComputation2 theSeed nbPoints (centers, _) = do 127 | rpoints <- rconstIO $ genPoints nbPoints 128 | centers0 <- lconst $ M.fromList $ L.map (\c -> (c, (p0, 0::Int))) centers 129 | centerMap <- rfold' (foldFun chooseCenter) computeNewCenters centers0 rpoints 130 | var' <- deltaCenter <$$> centerMap 131 | centers' <- M.elems <$$> centerMap 132 | r <- (,) <$$> centers' <**> var' 133 | (,) <$$> r <**> centers' 134 | where 135 | genPoints nbPoints' = do 136 | let stdGen = mkStdGen theSeed 137 | let vals = randomRs (0, 1) stdGen 138 | return $ L.take nbPoints' $ makePoints vals 139 | 140 | makePoints [] = [] 141 | makePoints [_] = [] 142 | makePoints (x:y:r) = (x,y):makePoints r 143 | 144 | 145 | jobDesc2 :: JobDesc ([(Double, Double)], Double) [Point] 146 | jobDesc2 = 147 | MkJobDesc (centers, 1000.0) (kmeansComputation2 theSeed nbPoints) noReporting (stop 0.1) 148 | where 149 | theSeed = 31415 150 | nbPoints = 100 151 | centers = [(0.0, 0.0), (1.0, 1.0)] 152 | 153 | 154 | slaveClosure2 :: Int -> Process () 155 | slaveClosure2 = CH.slaveProcess rpcConfigAction jobDesc2 156 | 157 | 158 | 159 | 160 | 161 | -- example 3: the cloud of points is generated on the slaves from a IO action 162 | -- This simulates the case where each slave reads the data from a file, queue,... 163 | -- Each slaves generates (around) nbPoints/nb-of-slaves. 164 | kmeansComputation3 :: Int -> ([Point], Double) -> LocalComputation (([Point], Double), [Point]) 165 | kmeansComputation3 nbPoints (centers, _) = do 166 | range <- rconst $ Range 0 nbPoints 167 | rpoints <- rapply (funIO (\r -> do let n = L.length $ rangeToList r 168 | genPoints n)) range 169 | centers0 <- lconst $ M.fromList $ L.map (\c -> (c, (p0, 0::Int))) centers 170 | centerMap <- rfold' (foldFun chooseCenter) computeNewCenters centers0 rpoints 171 | var' <- deltaCenter <$$> centerMap 172 | centers' <- M.elems <$$> centerMap 173 | r <- (,) <$$> centers' <**> var' 174 | (,) <$$> r <**> centers' 175 | where 176 | genPoints nbPoints' = do 177 | stdGen <- newStdGen 178 | let vals = randomRs (0, 1) stdGen 179 | return $ L.take nbPoints' $ makePoints vals 180 | 181 | makePoints [] = [] 182 | makePoints [_] = [] 183 | makePoints (x:y:r) = (x,y):makePoints r 184 | 185 | 186 | 187 | 188 | jobDesc3 :: JobDesc ([(Double, Double)], Double) [Point] 189 | jobDesc3 = 190 | MkJobDesc (centers, 1000.0) (kmeansComputation3 nbPoints) noReporting (stop 0.1) 191 | where 192 | nbPoints = 100 193 | centers = [(0.0, 0.0), (1.0, 1.0)] 194 | 195 | 196 | slaveClosure3 :: Int -> Process () 197 | slaveClosure3 = CH.slaveProcess rpcConfigAction jobDesc3 198 | 199 | remotable ['slaveClosure1, 'slaveClosure2, 'slaveClosure3] 200 | 201 | chClosure1 :: Int -> Closure (Process ()) 202 | chClosure1 = $(mkClosure 'slaveClosure1) 203 | 204 | chClosure2 :: Int -> Closure (Process ()) 205 | chClosure2 = $(mkClosure 'slaveClosure2) 206 | 207 | chClosure3 :: Int -> Closure (Process ()) 208 | chClosure3 = $(mkClosure 'slaveClosure3) 209 | 210 | rtable :: RemoteTable 211 | rtable = __remoteTable initRemoteTable 212 | 213 | 214 | 215 | 216 | 217 | -- main functions, choose the one you want to run. 218 | 219 | mainCH1 :: IO () 220 | mainCH1 = runCloudHaskell rtable jobDesc1 chClosure1 221 | 222 | mainLocal1 :: IO () 223 | mainLocal1 = do 224 | (a, r) <- runLocally True jobDesc1 225 | print a 226 | print r 227 | 228 | 229 | mainCH2 :: IO () 230 | mainCH2 = runCloudHaskell rtable jobDesc2 chClosure2 231 | 232 | mainLocal2 :: IO () 233 | mainLocal2 = do 234 | (a, r) <- runLocally True jobDesc2 235 | print a 236 | print r 237 | 238 | 239 | 240 | mainCH3 :: IO () 241 | mainCH3 = runCloudHaskell rtable jobDesc3 chClosure3 242 | 243 | mainLocal3 :: IO () 244 | mainLocal3 = do 245 | (a, r) <- runLocally True jobDesc3 246 | print a 247 | print r 248 | 249 | {- 250 | Run Local: 251 | kmeans 252 | 253 | Run with CloudHaskell 254 | 255 | * start slaves: 256 | 257 | kmeans slave host port 258 | 259 | * start master: 260 | 261 | kmeans master host port 262 | 263 | ex: 264 | > kmeans slave localhost 5001 265 | > kmeans slave localhost 5002 266 | > kmeans master localhost 5000 267 | 268 | -} 269 | 270 | main :: IO () 271 | main = mainLocal1 272 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Syntax.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveAnyClass #-} 12 | {-# LANGUAGE DeriveFunctor #-} 13 | {-# LANGUAGE DeriveGeneric #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | {-# LANGUAGE FlexibleInstances #-} 16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 17 | {-# LANGUAGE MultiParamTypeClasses #-} 18 | {-# LANGUAGE RankNTypes #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | {-# LANGUAGE TypeFamilies #-} 21 | {-# LANGUAGE UndecidableInstances #-} 22 | 23 | module Control.Distributed.Blast.Syntax 24 | ( 25 | -- * Specialized syntax primitives. 26 | rmap 27 | , rflatmap 28 | , rfilter 29 | , (<**>) 30 | , (<$$>) 31 | , lfold 32 | , lfold' 33 | , rfold 34 | , rfold' 35 | , rjoin 36 | , count 37 | , rKeyedJoin 38 | 39 | -- * Types. 40 | , KeyedVal (..) 41 | , Range (..) 42 | 43 | -- * Miscellanous functions. 44 | , rangeToList 45 | 46 | -- * Class. 47 | , Joinable (..) 48 | ) 49 | where 50 | 51 | --import Debug.Trace 52 | import Control.Monad hiding (join) 53 | import Data.Foldable 54 | import Data.Hashable 55 | import qualified Data.HashMap.Lazy as M 56 | import qualified Data.List as L 57 | import Data.Maybe (catMaybes) 58 | import Data.Proxy 59 | import qualified Data.Vector as Vc 60 | import qualified Data.Serialize as S 61 | 62 | import GHC.Generics (Generic) 63 | 64 | 65 | import Control.Distributed.Blast.Types 66 | 67 | class Joinable a b where 68 | join :: a -> b -> Maybe (a, b) 69 | 70 | 71 | 72 | -- | Maps a closure over a remote collection. 73 | rmap :: (Monad m, Builder m e, Traversable t) => 74 | Fun e a b -> e 'Remote (t a) -> Computation m e 'Remote (t b) 75 | rmap fm e = do 76 | cs <- mkRemoteClosure fm 77 | rapply' cs e 78 | where 79 | mkRemoteClosure (Pure f) = do 80 | ue <- lconst () 81 | return $ ExpClosure ue (\() a -> mapM f a) 82 | mkRemoteClosure (Closure ce f) = return $ ExpClosure ce (\c a -> mapM (f c) a) 83 | 84 | -- | Maps a closure over a remote collection and concatenates the results. 85 | rflatmap :: (Monad m, Foldable t, Builder m e, Monoid b) => 86 | Fun e a b -> e 'Remote (t a) -> Computation m e 'Remote b 87 | rflatmap fp e = do 88 | cs <- mkRemoteClosure fp 89 | rapply' cs e 90 | where 91 | mkRemoteClosure (Pure f) = do 92 | ue <- lconst () 93 | return $ ExpClosure ue (\() a -> foldMap f a) 94 | mkRemoteClosure (Closure ce f) = return $ ExpClosure ce (\c a -> foldMap (f c) a) 95 | 96 | -- | Applies a filter on a remote collection. 97 | rfilter :: (Monad m, Applicative f, Foldable t, Monoid (f a), 98 | Monoid (IO (f a)), Builder m e) => 99 | Fun e a Bool -> e 'Remote (t a) -> Computation m e 'Remote (f a) 100 | rfilter p e = do 101 | cs <- mkRemoteClosure p 102 | rapply' cs e 103 | where 104 | mkRemoteClosure (Pure f) = do 105 | ue <- lconst () 106 | return $ ExpClosure ue (\() ta -> do 107 | r <- foldMap (\a -> do 108 | b <- f a 109 | return $ if b then pure a else mempty) ta 110 | return r) 111 | mkRemoteClosure (Closure ce f) = return $ ExpClosure ce (\c ta -> do 112 | r <- foldMap (\a -> do 113 | b <- f c a 114 | return $ if b then pure a else mempty) ta 115 | return r) 116 | 117 | -- | Pseudo applicative syntax for local values. 118 | (<**>) :: (Monad m, Builder m e) 119 | => Computation m e 'Local (a -> b) 120 | -> e 'Local a -> Computation m e 'Local b 121 | f <**> a = do 122 | cs <- f 123 | lapply cs a 124 | 125 | 126 | -- | Pseudo applicative syntax for local values. 127 | (<$$>) :: (Monad m, Builder m e) 128 | => (a -> b) -> e 'Local a -> Computation m e 'Local b 129 | f <$$> e = lconst f <**> e 130 | 131 | 132 | -- | Local fold. 133 | lfold :: (Monad m, Foldable t, Builder m e) 134 | => e 'Local (b -> a -> b) 135 | -> e 'Local b 136 | -> e 'Local (t a) 137 | -> Computation m e 'Local b 138 | lfold f zero a = do 139 | f' <- foldl <$$> f <**> zero 140 | lapply f' a 141 | 142 | 143 | -- | Local fold. 144 | lfold' :: (Monad m, Foldable t, Builder m e) => 145 | (b -> a -> b) 146 | -> e 'Local b 147 | -> e 'Local (t a) 148 | -> Computation m e 'Local b 149 | lfold' f zero a = do 150 | f' <- lconst f 151 | lfold f' zero a 152 | 153 | -- | Counts the number of elements in a collection. 154 | count :: (Monad m, Foldable t, Builder m e) 155 | => e 'Local (t a) -> Computation m e 'Local Int 156 | count e = do 157 | zero <- lconst (0::Int) 158 | f <- lconst (\b _ -> b+1) 159 | lfold f zero e 160 | 161 | -- | Remote fold. Returns a value of type '[r]' which is guaranteed to be "Unchunkable". 162 | rfold :: (Builder m e, Traversable t, Applicative t, S.Serialize r, Monad m, ChunkableFreeVar r) 163 | => FoldFun e a r -> e 'Local r -> e 'Remote (t a) -> Computation m e 'Remote [r] 164 | rfold fp zero e = do 165 | cs <- mkRemoteClosure fp 166 | rapply' cs e 167 | where 168 | mkRemoteClosure (FoldPure f) = do 169 | cv <- (\z -> ((), z)) <$$> zero 170 | return $ ExpClosure cv (\((), z) a -> do 171 | r <- foldM f z a 172 | return [r]) 173 | mkRemoteClosure (FoldClosure ce f) = do 174 | cv <- (\c z -> (c, z)) <$$> ce <**> zero 175 | return $ ExpClosure cv (\(c,z) a -> do 176 | r <- foldM (f c) z a 177 | return [r]) 178 | 179 | 180 | -- | Remote fold followed by a local aggregation. 181 | -- Correct if and only if the folding function is both associative and commutative. 182 | rfold' :: (Monad m, Applicative t, Traversable t, S.Serialize r, Builder m e, ChunkableFreeVar r) => 183 | FoldFun e a r 184 | -> ([r] -> b) 185 | -> e 'Local r 186 | -> e 'Remote (t a) 187 | -> Computation m e 'Local b 188 | rfold' f aggregator zero a = do 189 | rs <- rfold f zero a 190 | ars <- collect' unChunk rs 191 | aggregator <$$> ars 192 | 193 | 194 | instance Joinable a b where 195 | join a b = Just (a, b) 196 | 197 | 198 | fromList' :: (Applicative t, Foldable t, Monoid (t a)) => [a] -> t a 199 | fromList' l = foldMap pure l 200 | 201 | rjoin :: (Monad m, Applicative t, Foldable t, Foldable t1, Foldable t2, 202 | Monoid (t (a1, a2)), S.Serialize (t1 a1), 203 | Builder m e, 204 | Joinable a1 a2, 205 | ChunkableFreeVar (t1 a1), 206 | UnChunkable (t1 a1) (t1 a1) ) => 207 | e 'Remote (t1 a1) -> e 'Remote (t2 a2) -> Computation m e 'Remote (t (a1, a2)) 208 | rjoin a b = do 209 | a' <- collect' unChunk a 210 | let cs = ExpClosure a' (\av bv -> return $ fromList' $ catMaybes [join x y | x <- toList av, y <- toList bv]) 211 | rapply' cs b 212 | 213 | data KeyedVal k v = KeyedVal k v 214 | deriving (Generic, S.Serialize, Show) 215 | 216 | instance (Eq k) => Joinable (KeyedVal k a) (KeyedVal k b) where 217 | join (KeyedVal k1 a) (KeyedVal k2 b) | k1 == k2 = Just (KeyedVal k1 a, KeyedVal k2 b) 218 | join (KeyedVal _ _) (KeyedVal _ _) = Nothing 219 | 220 | 221 | data OptiT t k v = OptiT (t (KeyedVal k v)) 222 | deriving (Generic) 223 | 224 | instance (Show (t (KeyedVal k v))) => Show (OptiT t k v) where 225 | show (OptiT x) = show x 226 | 227 | instance (S.Serialize (t (KeyedVal k v))) => S.Serialize (OptiT t k v) 228 | 229 | instance {-# OVERLAPPING #-} (Hashable k) => Chunkable [KeyedVal k v] [KeyedVal k v] where 230 | chunk nbBuckets l = 231 | Vc.reverse $ Vc.generate nbBuckets (\i -> buckets M.! i) 232 | where 233 | buckets = L.foldl proc M.empty l 234 | proc bucket' kv@(KeyedVal k _) = let 235 | i = hash k `mod` nbBuckets 236 | in M.insertWith (++) i [kv] bucket' 237 | 238 | 239 | 240 | instance (Applicative t, Foldable t, Monoid (t (KeyedVal k v)) 241 | , Chunkable (t (KeyedVal k v)) (t (KeyedVal k v)) 242 | ) => 243 | ChunkableFreeVar (OptiT t k v) where 244 | chunk' n (OptiT tkvs) = fmap OptiT $ chunk n tkvs 245 | 246 | 247 | -- | Optimized remote join operation between 2 collections of (key, value) pairs. 248 | -- Only works if the remote value "e 'Remote (t2 (KeyedVal k b))" is chunked according to "Chunkable (t (KeyedVal k v)) (t (KeyedVal k v))" 249 | rKeyedJoin 250 | :: (Eq k, Monad m, Applicative t, Applicative t1, 251 | Foldable t, Foldable t1, Foldable t2, 252 | Monoid (t (KeyedVal k (a, b))), Monoid (t1 (KeyedVal k a)), 253 | UnChunkable (t1 (KeyedVal k a)) (t1 (KeyedVal k a)), Chunkable (t1 (KeyedVal k a)) (t1 (KeyedVal k a)), 254 | Builder m e, S.Serialize (t1 (KeyedVal k a))) => 255 | Proxy t 256 | -> e 'Remote (t1 (KeyedVal k a)) 257 | -> e 'Remote (t2 (KeyedVal k b)) 258 | -> Computation m e 'Remote (t (KeyedVal k (a, b))) 259 | rKeyedJoin _ a b = do 260 | a' <- collect' unChunk a 261 | ja <- OptiT <$$> a' 262 | let cs = ExpClosure ja (\(OptiT av) bv -> return $ fromList' $ catMaybes [doJoin x y | x <- toList av, y <- toList bv]) 263 | rapply' cs b 264 | where 265 | doJoin (KeyedVal k1 a') (KeyedVal k2 b') | k1 == k2 = Just $ KeyedVal k1 (a', b') 266 | doJoin (KeyedVal _ _) (KeyedVal _ _) = Nothing 267 | 268 | 269 | 270 | 271 | -- | A Range defined by two integer: [a, b[ 272 | data Range = Range Int Int 273 | deriving (Eq, Show, Generic, S.Serialize) 274 | 275 | -- | Transforms a "Range" into a list. 276 | -- 277 | -- @ 278 | -- rangeToList (Range 1 4) == [1,2,3] 279 | -- @ 280 | rangeToList :: Range -> [Int] 281 | rangeToList (Range a b) = [a .. (b-1)] 282 | 283 | 284 | instance Chunkable Range Range where 285 | chunk nbBuckets (Range minV maxV) = 286 | Vc.fromList $ L.reverse $ go [] minV nbBuckets 287 | where 288 | delta = (maxV - minV) `div` nbBuckets 289 | go ranges current 1 = (Range current maxV):ranges 290 | go ranges current n | current >= maxV = go (Range current current : ranges) current (n - 1) 291 | go ranges current n = 292 | go (Range current end' : ranges) end' (n - 1) 293 | where 294 | end' = if end > maxV then maxV else end 295 | end = current + delta 296 | 297 | 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 | 306 | 307 | 308 | 309 | 310 | 311 | 312 | 313 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Slave/Analyser.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveGeneric #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE MultiParamTypeClasses #-} 15 | {-# LANGUAGE OverloadedStrings #-} 16 | {-# LANGUAGE RankNTypes #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | 19 | 20 | module Control.Distributed.Blast.Slave.Analyser 21 | ( 22 | SExp (..) 23 | , NodeTypeInfo (..) 24 | , LExpInfo (..) 25 | , RConstInfo (..) 26 | , RMapInfo (..) 27 | , InfoMap 28 | , analyseLocal 29 | ) 30 | where 31 | 32 | --import Debug.Trace 33 | import Control.Bool (unlessM) 34 | import Control.Monad.Logger 35 | import Control.Monad.IO.Class 36 | import Control.Monad.Trans.Either 37 | import Control.Monad.Trans.State 38 | import qualified Data.ByteString as BS 39 | import qualified Data.Map as M 40 | import qualified Data.Set as S 41 | import qualified Data.Serialize as S 42 | import qualified Data.Text as T 43 | import qualified Data.Vault.Strict as V 44 | 45 | import Control.Distributed.Blast.Types 46 | import Control.Distributed.Blast.Common.Analyser 47 | 48 | 49 | 50 | data SExp (k::Kind) a where 51 | SRApply :: Int -> V.Key (Data b) -> ExpClosure SExp a b -> SExp 'Remote a -> SExp 'Remote b 52 | SRConst :: (S.Serialize b) => Int -> V.Key (Data b) -> a -> SExp 'Remote b 53 | SLConst :: Int -> V.Key a -> IO a -> SExp 'Local a 54 | SCollect :: (S.Serialize b) => Int -> V.Key a -> SExp 'Remote b -> SExp 'Local a 55 | SLApply :: Int -> V.Key b -> SExp 'Local (a -> b) -> SExp 'Local a -> SExp 'Local b 56 | 57 | 58 | 59 | instance (MonadLoggerIO m) => Builder m SExp where 60 | makeRApply i f a = do 61 | k <- liftIO V.newKey 62 | return $ SRApply i k f a 63 | makeRConst i _ a = do 64 | k <- liftIO V.newKey 65 | return $ SRConst i k a 66 | makeLConst i a = do 67 | k <- liftIO V.newKey 68 | return $ SLConst i k a 69 | makeCollect i _ a = do 70 | k <- liftIO V.newKey 71 | return $ SCollect i k a 72 | makeLApply i f a = do 73 | k <- liftIO V.newKey 74 | return $ SLApply i k f a 75 | 76 | instance Indexable SExp where 77 | getIndex (SRApply n _ _ _) = n 78 | getIndex (SRConst n _ _) = n 79 | getIndex (SLConst n _ _) = n 80 | getIndex (SCollect n _ _) = n 81 | getIndex (SLApply n _ _ _) = n 82 | 83 | 84 | 85 | type RemoteCacher = Data BS.ByteString -> V.Vault -> V.Vault 86 | type LocalCacher = BS.ByteString -> V.Vault -> V.Vault 87 | 88 | type RemoteCacheReader = V.Vault -> Maybe (Data BS.ByteString) 89 | 90 | type UnCacher = V.Vault -> V.Vault 91 | 92 | data NodeTypeInfo = 93 | NtRMap RMapInfo 94 | |NtRConst RConstInfo 95 | |NtLExp LExpInfo 96 | |NtLExpNoCache 97 | 98 | data RMapInfo = MkRMapInfo { 99 | _rmRemoteClosure :: RemoteClosureImpl 100 | , _rmUnCacher :: UnCacher 101 | , _rmCacheReader :: Maybe RemoteCacheReader 102 | } 103 | 104 | data RConstInfo = MkRConstInfo { 105 | _rcstCacher :: RemoteCacher 106 | , _rcstUnCacher :: UnCacher 107 | , _rcstCacheReader :: Maybe RemoteCacheReader 108 | } 109 | 110 | data LExpInfo = MkLExpInfo { 111 | _lexpCacher :: LocalCacher 112 | , _lexpUnCacher :: UnCacher 113 | } 114 | 115 | type InfoMap = GenericInfoMap NodeTypeInfo 116 | 117 | 118 | 119 | getVal :: (Monad m) => CachedValType -> V.Vault -> V.Key a -> EitherT RemoteClosureResult m a 120 | getVal cvt vault key = 121 | case V.lookup key vault of 122 | Just v -> right v 123 | Nothing -> left $ RcRespCacheMiss cvt 124 | 125 | getLocalVal :: (Monad m) => CachedValType -> V.Vault -> V.Key a -> EitherT RemoteClosureResult m a 126 | getLocalVal cvt vault key = 127 | case V.lookup key vault of 128 | Just v -> right v 129 | Nothing -> left $ RcRespCacheMiss cvt 130 | 131 | makeUnCacher :: V.Key a -> V.Vault -> V.Vault 132 | makeUnCacher k vault = V.delete k vault 133 | 134 | mkRemoteClosure :: forall a b m . (MonadLoggerIO m) => 135 | V.Key (Data a) -> V.Key (Data b) -> ExpClosure SExp a b -> StateT InfoMap m RemoteClosureImpl 136 | mkRemoteClosure keya keyb (ExpClosure e f) = do 137 | analyseLocal e 138 | addLocalExpCacheM e 139 | let keyc = getLocalVaultKey e 140 | return $ wrapClosure keyc keya keyb f 141 | 142 | 143 | wrapClosure :: forall a b c . 144 | V.Key c -> V.Key (Data a) -> V.Key (Data b) -> (c -> a -> IO b) -> RemoteClosureImpl 145 | wrapClosure keyc keya keyb f = 146 | proc 147 | where 148 | proc vault = do 149 | r' <- runEitherT r 150 | return $ either (\l -> (l, vault)) id r' 151 | where 152 | r = do 153 | c <- getLocalVal CachedFreeVar vault keyc 154 | av <- getVal CachedArg vault keya 155 | brdd <- liftIO $ f' c av 156 | let vault' = V.insert keyb brdd vault 157 | return (RcRespOk, vault') 158 | f' _ NoData = return NoData 159 | f' c (Data a) = do 160 | x <- f c a 161 | return $ Data x 162 | 163 | visitLocalExp :: Int -> InfoMap -> InfoMap 164 | visitLocalExp n m = 165 | case M.lookup n m of 166 | Just (GenericInfo _ _ ) -> m 167 | Nothing -> M.insert n (GenericInfo S.empty NtLExpNoCache) m 168 | 169 | 170 | 171 | visitLocalExpM :: (MonadLoggerIO m) => Int -> StateT InfoMap m () 172 | visitLocalExpM n = do 173 | $(logInfo) $ T.pack ("Visiting local exp node: " ++ show n) 174 | m <- get 175 | put $ visitLocalExp n m 176 | 177 | 178 | addLocalExpCache :: (S.Serialize a) => Int -> V.Key a -> InfoMap -> InfoMap 179 | addLocalExpCache n key m = 180 | case M.lookup n m of 181 | Just (GenericInfo c NtLExpNoCache) -> M.insert n (GenericInfo c (NtLExp (MkLExpInfo (makeCacher key) (makeUnCacher key)))) m 182 | Nothing -> M.insert n (GenericInfo S.empty (NtLExp (MkLExpInfo (makeCacher key) (makeUnCacher key)))) m 183 | Just (GenericInfo _ (NtLExp _)) -> m 184 | _ -> error ("Node " ++ show n ++ " cannot add local exp cache") 185 | where 186 | makeCacher :: (S.Serialize a) => V.Key a -> BS.ByteString -> V.Vault -> V.Vault 187 | makeCacher k bs vault = 188 | case S.decode bs of 189 | Left e -> error $ ("Cannot deserialize value: " ++ e) 190 | Right a -> V.insert k a vault 191 | 192 | addLocalExpCacheM :: forall a m. (MonadLoggerIO m, S.Serialize a) => 193 | SExp 'Local a -> StateT InfoMap m () 194 | addLocalExpCacheM e = do 195 | let n = getLocalIndex e 196 | $(logInfo) $ T.pack ("Adding cache to local exp node: " ++ show n) 197 | let key = getLocalVaultKey e 198 | m <- get 199 | put $ addLocalExpCache n key m 200 | 201 | addRemoteExpCacheReader :: (S.Serialize a) => Int -> V.Key (Data a) -> InfoMap -> InfoMap 202 | addRemoteExpCacheReader n key m = 203 | case M.lookup n m of 204 | Just (GenericInfo _ (NtRMap (MkRMapInfo _ _ (Just _)))) -> m 205 | Just (GenericInfo c (NtRMap (MkRMapInfo cs uncacher Nothing))) -> 206 | M.insert n (GenericInfo c (NtRMap (MkRMapInfo cs uncacher (Just cacheReader)))) m 207 | Just (GenericInfo _ (NtRConst (MkRConstInfo _ _ (Just _)))) -> m 208 | Just (GenericInfo c (NtRConst (MkRConstInfo cacher uncacher Nothing))) -> 209 | M.insert n (GenericInfo c (NtRConst (MkRConstInfo cacher uncacher (Just cacheReader)))) m 210 | _ -> error ("Node " ++ show n ++ " cannot add remote exp cache reader") 211 | where 212 | cacheReader :: V.Vault -> Maybe (Data BS.ByteString) 213 | cacheReader vault = 214 | case V.lookup key vault of 215 | Nothing -> Nothing 216 | Just NoData -> Just NoData 217 | Just (Data b) -> Just $ Data $ S.encode b 218 | 219 | 220 | addRemoteExpCacheReaderM :: 221 | forall a m. (MonadLoggerIO m, S.Serialize a) 222 | => SExp 'Remote a -> StateT InfoMap m () 223 | addRemoteExpCacheReaderM e = do 224 | let n = getRemoteIndex e 225 | $(logInfo) $ T.pack ("Adding cache reader to remote exp node: " ++ show n) 226 | let key = getRemoteVaultKey e 227 | m <- get 228 | put $ addRemoteExpCacheReader n key m 229 | 230 | 231 | 232 | getRemoteIndex :: SExp 'Remote a -> Int 233 | getRemoteIndex (SRApply i _ _ _) = i 234 | getRemoteIndex (SRConst i _ _) = i 235 | 236 | getRemoteVaultKey :: SExp 'Remote a -> V.Key (Data a) 237 | getRemoteVaultKey (SRApply _ k _ _) = k 238 | getRemoteVaultKey (SRConst _ k _) = k 239 | 240 | getLocalIndex :: SExp 'Local a -> Int 241 | getLocalIndex (SLConst i _ _) = i 242 | getLocalIndex (SCollect i _ _) = i 243 | getLocalIndex (SLApply i _ _ _) = i 244 | 245 | getLocalVaultKey :: SExp 'Local a -> V.Key a 246 | getLocalVaultKey (SLConst _ k _) = k 247 | getLocalVaultKey (SCollect _ k _) = k 248 | getLocalVaultKey (SLApply _ k _ _) = k 249 | 250 | 251 | analyseRemote :: (MonadLoggerIO m) => SExp 'Remote a -> StateT InfoMap m () 252 | analyseRemote (SRApply n keyb cs@(ExpClosure ce _) a) = do 253 | unlessM (wasVisitedM n) $ do 254 | analyseRemote a 255 | referenceM n (getRemoteIndex a) 256 | analyseLocal ce 257 | referenceM n (getLocalIndex ce) 258 | $(logInfo) $ T.pack ("create closure for RApply node " ++ show n) 259 | let keya = getRemoteVaultKey a 260 | rcs <- mkRemoteClosure keya keyb cs 261 | visitRApplyM rcs 262 | where 263 | visitRApplyM cs' = do 264 | $(logInfo) $ T.pack ("Visiting RMap node: " ++ show n) 265 | m <- get 266 | put $ visitRApply cs' m 267 | visitRApply cs' m = 268 | case M.lookup n m of 269 | Just (GenericInfo _ _) -> m 270 | Nothing -> M.insert n (GenericInfo S.empty (NtRMap (MkRMapInfo cs' (makeUnCacher keyb) Nothing))) m 271 | 272 | analyseRemote (SRConst n key _) = do 273 | unlessM (wasVisitedM n) $ visitRConstExpM 274 | where 275 | visitRConstExpM = do 276 | $(logInfo) $ T.pack ("Visiting RConst node: " ++ show n) 277 | m <- get 278 | put $ visitRConst m 279 | visitRConst m = 280 | case M.lookup n m of 281 | Just (GenericInfo _ _) -> error ("RConst Node " ++ show n ++ " has already been visited") 282 | Nothing -> M.insert n (GenericInfo S.empty (NtRConst (MkRConstInfo (makeCacher key) (makeUnCacher key) Nothing))) m 283 | where 284 | makeCacher :: (S.Serialize a) => V.Key (Data a) -> (Data BS.ByteString) -> V.Vault -> V.Vault 285 | makeCacher k (NoData) vault = V.insert k NoData vault 286 | makeCacher k (Data bs) vault = 287 | case S.decode bs of 288 | Left e -> error $ ("Cannot deserialize value: " ++ e) 289 | Right a -> V.insert k (Data a) vault 290 | 291 | 292 | 293 | analyseLocal :: (MonadLoggerIO m) => SExp 'Local a -> StateT InfoMap m () 294 | 295 | analyseLocal(SLConst n _ _) = do 296 | unlessM (wasVisitedM n) $ visitLocalExpM n 297 | 298 | analyseLocal (SCollect n _ e) = do 299 | unlessM (wasVisitedM n) $ do 300 | analyseRemote e 301 | addRemoteExpCacheReaderM e 302 | referenceM n (getRemoteIndex e) 303 | visitLocalExpM n 304 | 305 | analyseLocal (SLApply n _ f e) = do 306 | unlessM (wasVisitedM n) $ do 307 | analyseLocal f 308 | analyseLocal e 309 | visitLocalExpM n 310 | 311 | 312 | 313 | 314 | 315 | 316 | 317 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Runner/CloudHaskell.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | 10 | 11 | {-# LANGUAGE BangPatterns #-} 12 | {-# LANGUAGE DataKinds #-} 13 | {-# LANGUAGE DeriveGeneric #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | {-# LANGUAGE FlexibleInstances #-} 16 | {-# LANGUAGE GADTs #-} 17 | {-# LANGUAGE ImpredicativeTypes #-} 18 | {-# LANGUAGE KindSignatures #-} 19 | {-# LANGUAGE MultiParamTypeClasses #-} 20 | {-# LANGUAGE OverloadedStrings #-} 21 | {-# LANGUAGE RecordWildCards #-} 22 | {-# LANGUAGE TemplateHaskell #-} 23 | {-# LANGUAGE ScopedTypeVariables #-} 24 | 25 | 26 | 27 | module Control.Distributed.Blast.Runner.CloudHaskell 28 | ( 29 | slaveProcess 30 | , runRec 31 | , RpcConfig (..) 32 | , MasterConfig (..) 33 | , SlaveConfig (..) 34 | ) 35 | where 36 | 37 | import Control.Concurrent (threadDelay) 38 | import Control.Concurrent.Async 39 | import Control.Concurrent.STM.TChan 40 | import Control.DeepSeq 41 | import Control.Monad.IO.Class 42 | import Control.Monad.Logger 43 | import Control.Monad.STM 44 | 45 | import Control.Distributed.Process hiding (newChan, send) 46 | import Control.Distributed.Process.Backend.SimpleLocalnet 47 | import Control.Distributed.Process.Extras.Internal.Types (ExitReason(..)) 48 | import Control.Distributed.Process.Extras.Time (Delay(..)) 49 | import Control.Distributed.Process.ManagedProcess as DMP hiding (runProcess, stop) 50 | 51 | import Data.Binary 52 | import qualified Data.List as L 53 | import qualified Data.Map as M 54 | import qualified Data.Serialize as S 55 | import Data.Typeable 56 | 57 | import GHC.Generics (Generic) 58 | 59 | import Control.Distributed.Blast 60 | import Control.Distributed.Blast.Distributed.Interface 61 | 62 | 63 | -- | General configuration. 64 | data RpcConfig = MkRpcConfig { 65 | commonConfig :: Config -- ^ Blast configuration. 66 | , masterConfig :: MasterConfig -- ^ Specific configuration for master. 67 | , slaveConfig :: SlaveConfig -- ^ Specific configuration for slaves. 68 | } 69 | 70 | -- | Master configuration. 71 | data MasterConfig = MkMasterConfig { 72 | masterLogger :: forall m a. (MonadIO m) => LoggingT m a -> m a -- ^ Logger. 73 | } 74 | 75 | -- | Master configuration. 76 | data SlaveConfig = MkSlaveConfig { 77 | slaveLogger :: forall m a. (MonadIO m) => LoggingT m a -> m a -- ^ Logger. 78 | } 79 | 80 | data RpcRequestControl = 81 | RpcRequestControlStop 82 | 83 | data RpcResponseControl = 84 | RpcResponseControlError String 85 | |RpcResponseControlStopped 86 | 87 | data SlaveInfo = MkSlaveInfo { 88 | _slaveIndex :: Int 89 | , _slaveNodeId :: NodeId 90 | , _slaveRequestChannel :: TChan (Either RpcRequestControl SlaveRequest) 91 | , _slaveResponseChannel :: TChan (Either RpcResponseControl SlaveResponse) 92 | } 93 | 94 | 95 | data SlaveControl = 96 | SlaveCtrlStop 97 | deriving (Typeable, Generic, Show) 98 | 99 | instance Binary SlaveControl 100 | 101 | 102 | 103 | -- | Defines the CloudHaskell closure. 104 | slaveProcess :: forall a b . (S.Serialize a, Typeable a, Typeable b) => 105 | IO RpcConfig -> JobDesc a b -> Int -> Process () 106 | slaveProcess configurator jobDesc@(MkJobDesc {..}) slaveIdx = do 107 | (MkRpcConfig config _ (MkSlaveConfig {..})) <- liftIO configurator 108 | liftIO $ putStrLn $ "starting slave process: " ++ show slaveIdx 109 | let slaveContext = makeSlaveContext config slaveIdx jobDesc 110 | 111 | let (server::ProcessDefinition (SlaveContext (LoggingT IO) a b)) = defaultProcess { 112 | apiHandlers = [handleCall (handle slaveLogger)] 113 | , exitHandlers = [handleExit exitHandler] 114 | , shutdownHandler = shutdownHandler 115 | , unhandledMessagePolicy = Drop 116 | } 117 | serve slaveContext (\ls -> return $ InitOk ls Infinity) server 118 | where 119 | handle logger ls req = do 120 | (resp, ls') <- liftIO $ logger $ runCommand req ls 121 | let resp' = force resp 122 | replyWith resp' (ProcessContinue ls') 123 | exitHandler _ _ () = do 124 | liftIO $ putStrLn "slave exit" 125 | return $ ProcessStop ExitShutdown 126 | shutdownHandler _ _ = do 127 | liftIO $ putStrLn "slave shutdown" 128 | return $ () 129 | 130 | data RpcState a = MkRpcState { 131 | rpcSlaves :: M.Map Int SlaveInfo 132 | -- not sure we should store it there since it is in the job desc 133 | , rpcSeed :: Maybe a 134 | , statefullSlaveMode :: Bool 135 | } 136 | 137 | 138 | rpcCall :: forall a. (S.Serialize a ) => RpcState a -> Int -> SlaveRequest -> IO SlaveResponse 139 | rpcCall (MkRpcState {..}) slaveIdx request = do 140 | let (MkSlaveInfo {..}) = rpcSlaves M.! slaveIdx 141 | atomically $ writeTChan _slaveRequestChannel (Right request) 142 | 143 | respE <- atomically $ readTChan _slaveResponseChannel 144 | case respE of 145 | Right resp -> return resp 146 | Left (RpcResponseControlError err) -> error ("Error in CloudHaskell RPC: " ++ err) 147 | Left RpcResponseControlStopped -> error "should not reach" 148 | 149 | 150 | instance (S.Serialize a) => CommandClass RpcState a where 151 | isStatefullSlave (MkRpcState{ statefullSlaveMode = mode }) = mode 152 | getNbSlaves (MkRpcState {..}) = M.size rpcSlaves 153 | 154 | send rpc@(MkRpcState {..}) slaveId req = do 155 | r <- rpcCall rpc slaveId req 156 | return $ Right r 157 | 158 | stop (MkRpcState {..}) = do 159 | let slaveInfos = M.elems rpcSlaves 160 | mapM_ (\(MkSlaveInfo {..}) -> do 161 | atomically $ writeTChan _slaveRequestChannel (Left RpcRequestControlStop) 162 | _ <- atomically $ readTChan _slaveResponseChannel 163 | -- todo add error management 164 | return () 165 | ) slaveInfos 166 | 167 | setSeed rpc@(MkRpcState {..}) a = do 168 | let rpc' = rpc {rpcSeed = Just a} 169 | resetAll rpc' 170 | return rpc' 171 | where 172 | resetAll aRpc = do 173 | let nbSlaves = getNbSlaves aRpc 174 | let slaveIds = [0 .. nbSlaves - 1] 175 | let req = resetCommand (S.encode a) 176 | _ <- mapConcurrently (\slaveId -> send aRpc slaveId req) slaveIds 177 | return () 178 | 179 | 180 | startClientRpc :: forall a b. (S.Serialize a, S.Serialize b, CommandClass RpcState a) => 181 | RpcConfig 182 | -> JobDesc a b 183 | -> (Int -> Closure (Process())) 184 | -> (a -> b -> IO ()) 185 | -> Backend 186 | -> [NodeId] 187 | -> Process () 188 | startClientRpc (MkRpcConfig config (MkMasterConfig logger) _) theJobDesc slaveClosure k backend _ = do 189 | loop 0 theJobDesc 190 | where 191 | mkSlaveInfo i nodeId = do 192 | requestChan <- newTChanIO 193 | responseChannel <- newTChanIO 194 | return $ (i, MkSlaveInfo i nodeId requestChan responseChannel) 195 | findSlaveNodes = do 196 | selfNode <- getSelfNode 197 | nodeIds <- liftIO $ findPeers backend 1000000 198 | return $ nodeIds L.\\ [selfNode] 199 | loop :: Int -> JobDesc a b -> Process () 200 | loop n (jobDesc@MkJobDesc {..}) = do 201 | nodeIds <- findSlaveNodes 202 | case nodeIds of 203 | [] -> do 204 | liftIO $ putStrLn "No node found, retrying" 205 | liftIO $ threadDelay 5000000 206 | loop n jobDesc 207 | _ -> do 208 | liftIO $ putStrLn ("Nodes found: " ++ show nodeIds) 209 | slaveInfos <- liftIO $ mapM (\(i, nodeId) -> mkSlaveInfo i nodeId) $ L.zip [0..] nodeIds 210 | let slaveInfoMap = M.fromList slaveInfos 211 | -- create processes that handle RPC 212 | mapM_ (\slaveInfo -> spawnLocal (startOneClientRpc slaveInfo slaveClosure)) $ M.elems slaveInfoMap 213 | let rpcState = MkRpcState slaveInfoMap Nothing (statefullSlaves config) 214 | (a, b) <- liftIO $ do logger $ runComputation config rpcState jobDesc 215 | liftIO $ stop rpcState 216 | a' <- liftIO $ reportingAction a b 217 | case shouldStop seed a' b of 218 | True -> liftIO $ k a b 219 | False -> do let jobDesc' = jobDesc {seed = a'} 220 | liftIO $ putStrLn "iteration finished" 221 | loop (n+1) jobDesc' 222 | 223 | 224 | 225 | startOneClientRpc :: SlaveInfo -> (Int -> Closure (Process ())) -> Process () 226 | startOneClientRpc (MkSlaveInfo {..}) slaveClosure = do 227 | slavePid <- spawn _slaveNodeId (slaveClosure _slaveIndex) 228 | catchExit 229 | (localProcess 0 slavePid) 230 | (\slavePid' () -> do 231 | liftIO $ putStrLn ("stopping slave from handler:" ++ show slavePid) 232 | exit slavePid' () 233 | -- shutdown slavePid 234 | ) 235 | where 236 | localProcess :: Int -> ProcessId -> Process () 237 | localProcess nbError slavePid = do 238 | requestE <- liftIO $ atomically $ readTChan _slaveRequestChannel 239 | case requestE of 240 | Right request -> do 241 | (respE::Either ExitReason SlaveResponse) <- safeCall slavePid request 242 | case respE of 243 | Right resp -> do 244 | liftIO $ atomically $ writeTChan _slaveResponseChannel $ Right resp 245 | localProcess 0 slavePid 246 | Left e | nbError < 10 -> do 247 | liftIO $ putStrLn ("error: "++show e) 248 | liftIO $ threadDelay 5000000 249 | -- todo deprecated, fix me 250 | liftIO $ atomically $ unGetTChan _slaveRequestChannel requestE 251 | newSlavePid <- spawn _slaveNodeId (slaveClosure _slaveIndex) 252 | localProcess (nbError+1) newSlavePid 253 | Left e -> do 254 | liftIO $ atomically $ writeTChan _slaveResponseChannel $ Left $ RpcResponseControlError $ show e 255 | localProcess nbError slavePid 256 | Left RpcRequestControlStop -> do 257 | liftIO $ putStrLn ("stopping slave in a controlled way:" ++ show slavePid) 258 | exit slavePid () 259 | liftIO $ atomically $ writeTChan _slaveResponseChannel $ Left $ RpcResponseControlStopped 260 | liftIO $ putStrLn "Terminating client process" 261 | 262 | 263 | -- | Run the computation on CloudHaskell 264 | runRec :: forall a b. (S.Serialize a, S.Serialize b) => 265 | RemoteTable -- ^ CloudHaskell remote table. 266 | -> RpcConfig -- ^ Configuration. 267 | -> [String] -- ^ Command line arguments 268 | -> JobDesc a b -- ^ Job description. 269 | -> (Int -> Closure (Process())) -- ^ Function that takes a slave index and returns the CloudHaskell closure to execute on that slave (see "slaveProcess"). 270 | -> (a -> b -> IO ()) -- ^ A continuation that is called when the computation ends. 271 | -> IO () 272 | runRec rtable rpcConfig args jobDesc slaveClosure k = do 273 | case args of 274 | ["master", host, port] -> do 275 | backend <- initializeBackend host port rtable 276 | startMaster backend (startClientRpc rpcConfig jobDesc slaveClosure k backend) 277 | putStrLn ("End") 278 | ["slave", host, port] -> do 279 | backend <- initializeBackend host port rtable 280 | startSlave backend 281 | _ -> putStrLn ("Bad args: " ++ show args) 282 | 283 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Types.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | {-# LANGUAGE AllowAmbiguousTypes #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveAnyClass #-} 12 | {-# LANGUAGE DeriveGeneric #-} 13 | {-# LANGUAGE FlexibleContexts #-} 14 | {-# LANGUAGE FlexibleInstances #-} 15 | {-# LANGUAGE FunctionalDependencies #-} 16 | {-# LANGUAGE GADTs #-} 17 | {-# LANGUAGE MultiParamTypeClasses #-} 18 | {-# LANGUAGE OverloadedStrings #-} 19 | {-# LANGUAGE RankNTypes #-} 20 | {-# LANGUAGE ScopedTypeVariables #-} 21 | {-# LANGUAGE TemplateHaskell #-} 22 | {-# LANGUAGE TypeFamilies #-} 23 | {-# LANGUAGE UndecidableInstances #-} 24 | 25 | 26 | module Control.Distributed.Blast.Types 27 | ( 28 | Computation 29 | , LocalComputation 30 | , RemoteComputation 31 | , Kind (..) 32 | , Partition 33 | , Chunkable (..) 34 | , UnChunkable (..) 35 | , ChunkableFreeVar (..) 36 | , ChunkFun 37 | , UnChunkFun 38 | , Fun (..) 39 | , FoldFun (..) 40 | , ExpClosure (..) 41 | , Indexable (..) 42 | , Builder (..) 43 | , Syntax (..) 44 | , GenericInfoMap 45 | , GenericInfo (..) 46 | , rapply' 47 | , rconst' 48 | , rconst 49 | , rconstIO 50 | , lconst 51 | , lconstIO 52 | , collect' 53 | , collect 54 | , lapply 55 | , rapply 56 | , refCount 57 | , generateReferenceMap 58 | , build 59 | , JobDesc (..) 60 | , Config (..) 61 | , defaultConfig 62 | , fun 63 | , closure 64 | , foldFun 65 | , foldClosure 66 | , funIO 67 | , closureIO 68 | , foldFunIO 69 | , foldClosureIO 70 | , partitionSize 71 | , getPart 72 | 73 | ) 74 | where 75 | 76 | --import Debug.Trace 77 | import qualified Control.Lens as Lens () 78 | import Control.Monad.Operational 79 | import qualified Data.List as L 80 | import qualified Data.Map as M 81 | import qualified Data.Set as S 82 | import qualified Data.Serialize as S 83 | import qualified Data.Vector as Vc 84 | 85 | 86 | data GenericInfo i = GenericInfo { 87 | giRefs :: S.Set Int -- set of parents, that is, nodes that reference this node 88 | , giInfo :: i 89 | } 90 | deriving Show 91 | 92 | -- $(Lens.makeLenses ''GenericInfo) 93 | 94 | type GenericInfoMap i = M.Map Int (GenericInfo i) 95 | 96 | -- | Generic type describing a computation. 97 | type Computation m e (k::Kind) a = 98 | Control.Monad.Operational.ProgramT (Syntax m) m (e k a) 99 | 100 | -- | A computation that evaluates as a local value. 101 | type LocalComputation a = forall e m. (Monad m, Builder m e) => Computation m e 'Local a 102 | 103 | 104 | -- | A computation that evaluates as a remote value. 105 | type RemoteComputation a = forall e m. (Monad m, Builder m e) => Computation m e 'Remote a 106 | 107 | -- | Kind of computation. 108 | data Kind = Remote | Local 109 | 110 | -- | Represents the partitioning of a remote value. 111 | type Partition a = Vc.Vector a 112 | 113 | partitionSize :: Partition a -> Int 114 | partitionSize v = Vc.length v 115 | 116 | getPart :: Int -> Partition a -> Maybe a 117 | getPart i p | i <= partitionSize p - 1 = Just $ p Vc.! i 118 | getPart _ _ = Nothing 119 | 120 | -- | Values that can be partitionned. 121 | class Chunkable a b | a -> b, b -> a where 122 | -- | Given a value "a", chunk it into 'n' parts. 123 | chunk :: Int -> a -> Partition b 124 | 125 | -- | Values that can be reconstructed from a list of parts. 126 | class UnChunkable b a | b -> a, b -> a where 127 | -- | Given a list of parts, reconstruct a value. 128 | unChunk :: [b] -> a 129 | 130 | -- | Values that can be reconstructed from a list of parts. 131 | -- This applies to local values that are captured by a closure. 132 | -- Helps optimize the implementation of remote relational operators or more generally, remote dyadic operators. 133 | class ChunkableFreeVar a where 134 | -- | Given a list of parts, reconstruct a value. 135 | chunk' :: Int -> a -> Partition a 136 | chunk' n a = Vc.generate n (const a) 137 | 138 | 139 | data Fun e a b = 140 | Pure (a -> IO b) 141 | |forall c . (S.Serialize c, ChunkableFreeVar c) => Closure (e 'Local c) (c -> a -> IO b) 142 | 143 | data FoldFun e a r = 144 | FoldPure (r -> a -> IO r) 145 | |forall c . (S.Serialize c,ChunkableFreeVar c) => FoldClosure (e 'Local c) (c -> r -> a -> IO r) 146 | 147 | data ExpClosure e a b = 148 | forall c . (S.Serialize c, ChunkableFreeVar c) => ExpClosure (e 'Local c) (c -> a -> IO b) 149 | 150 | 151 | class Indexable e where 152 | getIndex :: e (k::Kind) a -> Int 153 | 154 | type ChunkFun a b = Int -> a -> Partition b 155 | type UnChunkFun b a = [b] -> a 156 | 157 | class (Indexable e) => Builder m e where 158 | makeRApply :: Int -> ExpClosure e a b -> e 'Remote a -> m (e 'Remote b) 159 | makeRConst :: (S.Serialize b) => Int -> ChunkFun a b -> IO a -> m (e 'Remote b) 160 | makeLConst :: Int -> IO a -> m (e 'Local a) 161 | makeCollect :: (S.Serialize b) => Int -> UnChunkFun b a -> e 'Remote b -> m (e 'Local a) 162 | makeLApply :: Int -> e 'Local (a -> b) -> e 'Local a -> m (e 'Local b) 163 | 164 | data Syntax m e where 165 | StxRApply :: (Builder m e) => ExpClosure e a b -> e 'Remote a -> Syntax m (e 'Remote b) 166 | StxRConst :: (Builder m e, S.Serialize b) => ChunkFun a b -> IO a -> Syntax m (e 'Remote b) 167 | StxLConst :: (Builder m e) => IO a -> Syntax m (e 'Local a) 168 | StxCollect :: (Builder m e, S.Serialize b) => UnChunkFun b a -> e 'Remote b -> Syntax m (e 'Local a) 169 | StxLApply :: (Builder m e) => e 'Local (a -> b) -> e 'Local a -> Syntax m (e 'Local b) 170 | 171 | -- | Applies a ExpClosure to remote value. 172 | rapply' :: (Builder m e) 173 | => ExpClosure e a b 174 | -> e 'Remote a 175 | -> Computation m e 'Remote b 176 | rapply' f a = singleton (StxRApply f a) 177 | 178 | -- | Creates a remote value, passing a specific chunk function. 179 | rconst' :: (S.Serialize b) => 180 | ChunkFun a b -> IO a -> RemoteComputation b 181 | rconst' f a = singleton (StxRConst f a) 182 | 183 | -- | Creates a remote value. 184 | rconst :: (S.Serialize b, Chunkable a b) => a -> RemoteComputation b 185 | rconst a = rconst' chunk (return a) 186 | 187 | -- | Creates a remote value. 188 | rconstIO :: (S.Serialize b, Chunkable a b) => IO a -> RemoteComputation b 189 | rconstIO a = rconst' chunk a 190 | 191 | -- | Creates a local value. 192 | lconst :: a -> LocalComputation a 193 | lconst a = singleton (StxLConst (return a)) 194 | 195 | -- | Creates a local value. 196 | lconstIO :: IO a -> LocalComputation a 197 | lconstIO a = singleton (StxLConst a) 198 | 199 | -- | Creates a local value from a remote value, passing a specific chunk function. 200 | collect' :: (S.Serialize b, Builder m e) => 201 | UnChunkFun b a -> e 'Remote b -> Computation m e 'Local a 202 | collect' f a = singleton (StxCollect f a) 203 | 204 | -- | Creates a local value from a remote value, passing a specific chunk function. 205 | collect :: (S.Serialize b, Builder m e, UnChunkable b a) => 206 | e 'Remote b -> Computation m e 'Local a 207 | collect a = collect' unChunk a 208 | 209 | -- | Applies a function to a local value. 210 | lapply :: (Builder m e) => 211 | e 'Local (a -> b) -> e 'Local a -> Computation m e 'Local b 212 | lapply f a = singleton (StxLApply f a) 213 | 214 | 215 | -- | Applies a closure to remote value. 216 | rapply :: (Monad m, Builder m e) => 217 | Fun e a b -> e 'Remote a -> Computation m e 'Remote b 218 | rapply fm e = do 219 | cs <- mkRemoteClosure fm 220 | rapply' cs e 221 | where 222 | mkRemoteClosure (Pure f) = do 223 | ue <- lconst () 224 | return $ ExpClosure ue (\() a -> f a) 225 | mkRemoteClosure (Closure ce f) = return $ ExpClosure ce (\c a -> f c a) 226 | 227 | 228 | 229 | refCount :: Int -> GenericInfoMap i -> Int 230 | refCount n m = 231 | case M.lookup n m of 232 | Just (GenericInfo refs _) -> S.size refs 233 | Nothing -> error ("Ref count not found for node: " ++ show n) 234 | 235 | addUnitInfo :: Int -> GenericInfoMap () -> GenericInfoMap () 236 | addUnitInfo n refMap = 237 | case M.lookup n refMap of 238 | Just _ -> error $ ("Node " ++ show n ++ " already exists") 239 | Nothing -> M.insert n (GenericInfo S.empty ()) refMap 240 | 241 | 242 | reference :: Int -> Int -> GenericInfoMap i -> GenericInfoMap i 243 | reference parent child refMap = do 244 | case M.lookup child refMap of 245 | Just inf@(GenericInfo old _) -> M.insert child (inf {giRefs = S.insert parent old}) refMap 246 | Nothing -> error $ ("Node " ++ show child ++ " is referenced before being visited") 247 | 248 | generateReferenceMap ::forall a m e. (Builder m e, Monad m) => Int -> GenericInfoMap () -> ProgramT (Syntax m) m (e 'Local a) -> m (GenericInfoMap (), Int) 249 | generateReferenceMap counter refMap p = do 250 | pv <- viewT p 251 | eval pv 252 | where 253 | eval :: (Builder m e, Monad m) => ProgramViewT (Syntax m) m (e 'Local a) -> m (GenericInfoMap(), Int) 254 | eval (StxRApply cs@(ExpClosure ce _) a :>>= is) = do 255 | e <- makeRApply counter cs a 256 | let refMap' = addUnitInfo counter refMap 257 | let refMap'' = reference counter (getIndex ce) refMap' 258 | let refMap''' = reference counter (getIndex a) refMap'' 259 | generateReferenceMap (counter+1) refMap''' (is e) 260 | eval (StxRConst f a :>>= is) = do 261 | e <- makeRConst counter f a 262 | let refMap' = addUnitInfo counter refMap 263 | generateReferenceMap (counter+1) refMap' (is e) 264 | eval (StxLConst a :>>= is) = do 265 | e <- makeLConst counter a 266 | let refMap' = addUnitInfo counter refMap 267 | generateReferenceMap (counter+1) refMap' (is e) 268 | eval (StxCollect f a :>>= is) = do 269 | e <- makeCollect counter f a 270 | let refMap' = addUnitInfo counter refMap 271 | let refMap'' = reference counter (getIndex a) refMap' 272 | generateReferenceMap (counter+1) refMap'' (is e) 273 | eval (StxLApply f a :>>= is) = do 274 | e <- makeLApply counter f a 275 | let refMap' = addUnitInfo counter refMap 276 | let refMap'' = reference counter (getIndex f) refMap' 277 | let refMap''' = reference counter (getIndex a) refMap'' 278 | generateReferenceMap (counter+1) refMap''' (is e) 279 | eval (Return _) = return (refMap, counter) 280 | 281 | 282 | 283 | build ::forall a m e. (Builder m e, Monad m) => GenericInfoMap () -> Int -> ProgramT (Syntax m) m (e 'Local a) -> m (e 'Local a) 284 | build refMap counter p = do 285 | pv <- viewT p 286 | eval pv 287 | where 288 | eval :: (Builder m e, Monad m) => ProgramViewT (Syntax m) m (e 'Local a) -> m (e 'Local a) 289 | eval (StxRApply cs@(ExpClosure _ _) a :>>= is) = do 290 | e <- makeRApply counter cs a 291 | build refMap (counter+1) (is e) 292 | eval (StxRConst chunkFun a :>>= is) = do 293 | e <- makeRConst counter chunkFun a 294 | build refMap (counter+1) (is e) 295 | eval (StxLConst a :>>= is) = do 296 | e <- makeLConst counter a 297 | build refMap (counter+1) (is e) 298 | eval (StxCollect f a :>>= is) = do 299 | e <- makeCollect counter f a 300 | build refMap (counter+1) (is e) 301 | eval (StxLApply f a :>>= is) = do 302 | e <- makeLApply counter f a 303 | build refMap (counter+1) (is e) 304 | eval (Return a) = return a 305 | 306 | 307 | -- | Definition of a recursive job. 308 | data JobDesc a b = MkJobDesc { 309 | -- | The initial value passed to the computation generator. 310 | seed :: a 311 | -- | The computation generator. 312 | , computationGen :: a -> (forall e m. (Monad m, Builder m e) => Computation m e 'Local (a, b)) 313 | -- | An action that is executed after each iteration. 314 | , reportingAction :: a -> b -> IO a 315 | -- | Predicate that determines whether or not to continue the computation (False to continue, True to exit) 316 | , shouldStop :: a -> a -> b -> Bool 317 | } 318 | 319 | 320 | data Config = MkConfig 321 | { 322 | slaveAvailability :: Float -- ^ Probability of slave failure. Used in testing. 323 | , statefullSlaves :: Bool -- ^ True turns on the statefull slave mode. Slaves are stateless if False. 324 | } 325 | 326 | -- | Default configuration 327 | -- @ 328 | -- defaultConfig = MkConfig False 1.0 True 329 | -- @ 330 | defaultConfig :: Config 331 | defaultConfig = MkConfig 1.0 True 332 | 333 | -- instances 334 | 335 | instance {-# OVERLAPPABLE #-} ChunkableFreeVar a 336 | instance {-# OVERLAPPABLE #-} (ChunkableFreeVar a , ChunkableFreeVar b) => ChunkableFreeVar (a,b) where 337 | chunk' n (a, c) = 338 | Vc.zip pb pd 339 | where 340 | pb = chunk' n a 341 | pd = chunk' n c 342 | 343 | instance ChunkableFreeVar () 344 | 345 | 346 | instance {-# OVERLAPPABLE #-} Chunkable [a] [a] where 347 | chunk nbBuckets l = 348 | Vc.reverse $ Vc.fromList $ go [] nbBuckets l 349 | where 350 | go acc 1 ls = ls:acc 351 | go acc n ls = go (L.take nbPerBucket ls : acc) (n-1) (L.drop nbPerBucket ls) 352 | len = L.length l 353 | nbPerBucket = len `div` nbBuckets 354 | 355 | instance {-# OVERLAPPABLE #-} UnChunkable [a] [a] where 356 | unChunk l = L.concat l 357 | 358 | 359 | 360 | -- | Creates a closure from a pure function. 361 | fun :: (a -> b) -> Fun e a b 362 | fun f = Pure (return . f) 363 | 364 | -- | Creates a closure from a pure function and a local value. 365 | closure :: (S.Serialize c, ChunkableFreeVar c) => e 'Local c -> (c -> a -> b) -> Fun e a b 366 | closure ce f = Closure ce (\c a -> return $ f c a) 367 | 368 | 369 | -- | Creates a folding closure from a pure function. 370 | foldFun :: (r -> a -> r) -> FoldFun e a r 371 | foldFun f = FoldPure (\r a -> return $ f r a) 372 | 373 | -- | Creates a folding closure from a pure function and a local value. 374 | foldClosure :: (S.Serialize c, ChunkableFreeVar c) => e 'Local c -> (c -> r -> a -> r) -> FoldFun e a r 375 | foldClosure ce f = FoldClosure ce (\c r a -> return $ f c r a) 376 | 377 | -- | Creates a closure from a impure function. 378 | funIO :: (a -> IO b) -> Fun k a b 379 | funIO f = Pure f 380 | 381 | -- | Creates a closure from a impure function and a local value. 382 | closureIO :: (S.Serialize c, ChunkableFreeVar c) => e 'Local c -> (c -> a -> IO b) -> Fun e a b 383 | closureIO ce f = Closure ce f 384 | 385 | -- | Creates a folding closure from a impure function. 386 | foldFunIO :: (r -> a -> IO r) -> FoldFun e a r 387 | foldFunIO f = FoldPure f 388 | 389 | -- | Creates a folding closure from a impure function and a local value. 390 | foldClosureIO :: (S.Serialize c, ChunkableFreeVar c) => e 'Local c -> (c -> r -> a -> IO r) -> FoldFun e a r 391 | foldClosureIO ce f = FoldClosure ce f 392 | 393 | -------------------------------------------------------------------------------- /src/Control/Distributed/Blast/Distributed/Master.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Copyright : (c) Jean-Christophe Mincke, 2016-2017 3 | 4 | This Source Code Form is subject to the terms of the Mozilla Public 5 | License, v. 2.0. If a copy of the MPL was not distributed with this 6 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 7 | -} 8 | 9 | {-# LANGUAGE BangPatterns #-} 10 | {-# LANGUAGE DataKinds #-} 11 | {-# LANGUAGE DeriveGeneric #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | {-# LANGUAGE GADTs #-} 14 | {-# LANGUAGE MultiParamTypeClasses #-} 15 | {-# LANGUAGE OverloadedStrings #-} 16 | {-# LANGUAGE RankNTypes #-} 17 | {-# LANGUAGE RecordWildCards #-} 18 | {-# LANGUAGE ScopedTypeVariables #-} 19 | {-# LANGUAGE TemplateHaskell #-} 20 | 21 | module Control.Distributed.Blast.Distributed.Master 22 | ( 23 | runLocal 24 | ) 25 | where 26 | 27 | 28 | import Control.Concurrent.Async 29 | import Control.Monad 30 | import Control.Monad.IO.Class 31 | import Control.Monad.Logger 32 | import Control.Monad.Trans.State 33 | 34 | import qualified Data.ByteString as BS 35 | import qualified Data.List as L 36 | import qualified Data.Map as M 37 | import Data.Maybe (catMaybes) 38 | import qualified Data.Serialize as S 39 | import qualified Data.Set as S 40 | import qualified Data.Vault.Strict as V 41 | import qualified Data.Vector as Vc 42 | 43 | import Control.Distributed.Blast.Types 44 | import Control.Distributed.Blast.Distributed.Types 45 | import Control.Distributed.Blast.Common.Analyser 46 | import Control.Distributed.Blast.Master.Analyser 47 | 48 | toData :: Maybe a -> Data a 49 | toData (Just a) = Data a 50 | toData Nothing = NoData 51 | 52 | getLocalVaultKey :: MExp 'Local a -> LocalKey a 53 | getLocalVaultKey (MLConst _ k _) = k 54 | getLocalVaultKey (MCollect _ k _ _) = k 55 | getLocalVaultKey (MLApply _ k _ _) = k 56 | 57 | getRemote :: (Monad m) => StateT (s, V.Vault, InfoMap) m s 58 | getRemote = do 59 | (s, _, _) <- get 60 | return s 61 | 62 | getVault :: (Monad m) => StateT (s, V.Vault, InfoMap) m (V.Vault) 63 | getVault = do 64 | (_, vault, _) <- get 65 | return vault 66 | 67 | setVault :: (Monad m) => V.Vault -> StateT (s, V.Vault, InfoMap) m () 68 | setVault vault= do 69 | (s, _, m) <- get 70 | put (s, vault, m) 71 | 72 | dereference :: (Monad m) => Int -> Int -> StateT (s, V.Vault, InfoMap) m Bool 73 | dereference parent child = do 74 | (s, vault, m) <- get 75 | let (GenericInfo crefs i) = m M.! child 76 | if S.member parent crefs 77 | then do 78 | let crefs' = S.delete parent crefs 79 | let m' = M.insert child (GenericInfo crefs' i) m 80 | put (s, vault, m') 81 | return $ S.null crefs' 82 | else error ("Remove parent reference twice for parent "++show parent ++" and child "++show child) 83 | 84 | handleRpcError :: Either String t -> t 85 | handleRpcError (Right a) = a 86 | handleRpcError (Left err) = error ("Error in RPC: "++err) 87 | 88 | handleRpcErrorM :: (Monad m) => Either String t -> m t 89 | handleRpcErrorM a = return $ handleRpcError a 90 | 91 | 92 | handleSlaveErrorM :: (Monad m) => SlaveResponse -> m SlaveResponse 93 | handleSlaveErrorM (LsRespError err) = error ("Error in Slave: "++err) 94 | handleSlaveErrorM r = return r 95 | 96 | 97 | 98 | runAndFetchRemoteOneSlaveStatefull ::(CommandClass s x, MonadIO m, S.Serialize a) => Int -> MExp 'Remote a -> StateT (s x , V.Vault, InfoMap) m (Maybe a) 99 | runAndFetchRemoteOneSlaveStatefull slaveId oe@(MRApply n (ExpClosure ce _) e) = do 100 | runRemoteOneSlaveStatefull slaveId oe 101 | fetchRes <- fetchOneSlaveResults slaveId oe 102 | case fetchRes of 103 | Just (Data a) -> return $ Just a 104 | Just (NoData) -> return $ Nothing 105 | Nothing -> 106 | -- We a fectch miss. Redo the remote computation 107 | -- Risk of infinite recursion: not really because a fetch miss 108 | -- is due to (temporary) slave failure. 109 | -- If the slave cannot never be reached gain, the backend will raise an specific error 110 | runAndFetchRemoteOneSlaveStatefull slaveId oe 111 | 112 | 113 | runRemoteOneSlaveStatefull ::(CommandClass s x, MonadIO m) => Int -> MExp 'Remote a -> StateT (s x , V.Vault, InfoMap) m () 114 | runRemoteOneSlaveStatefull slaveId oe@(MRApply n (ExpClosure ce _) e) = do 115 | s <- getRemote 116 | let req = LsReqExecute n 117 | r <- liftIO $ send s slaveId req 118 | case handleRpcError r of 119 | LsRespExecute (RcRespCacheMiss CachedFreeVar) -> do 120 | vault <- getVault 121 | let keyce = getLocalVaultKey ce 122 | let cem = V.lookup keyce vault 123 | case cem of 124 | Nothing -> error "local value not cached while executing remote on one slave" 125 | Just (_, Nothing) -> error "local value not cached (BS) while executing remote on one slave" 126 | Just (_, Just p) -> do 127 | let ceId = getLocalIndex ce 128 | let csBs = toData $ getPart slaveId p 129 | let req' = LsReqCache ceId csBs 130 | r' <- liftIO $ send s slaveId req' 131 | sr <- handleRpcErrorM r' 132 | _ <- handleSlaveErrorM sr 133 | runRemoteOneSlaveStatefull slaveId oe 134 | LsRespExecute (RcRespCacheMiss CachedArg) -> do 135 | runRemoteOneSlaveStatefull slaveId e 136 | runRemoteOneSlaveStatefull slaveId oe 137 | -- todo uncache e if should not be cached 138 | LsRespExecute RcRespOk -> return () 139 | LsRespExecute (RcRespError err) -> error ( "remote call: " ++ err) 140 | LsRespError err -> error ( "remote call: " ++ err) 141 | _ -> error ( "Should not reach here") 142 | 143 | runRemoteOneSlaveStatefull slaveId (MRConst n key _ _) = do 144 | s <- getRemote 145 | vault <- getVault 146 | case V.lookup key vault of 147 | Just partition -> do 148 | let bs = toData $ getPart slaveId partition 149 | let req = LsReqCache n bs 150 | r <- liftIO $ send s slaveId req 151 | -- TODO :verify next line. 152 | sr <- handleRpcErrorM r 153 | _ <- handleSlaveErrorM sr 154 | return () 155 | Nothing -> error ("MRConst value not cached"::String) 156 | 157 | 158 | 159 | runRemoteOneSlaveStateless ::(CommandClass s x, MonadIO m) => Int -> [SlaveRequest] -> MExp 'Remote a -> StateT (s x , V.Vault, InfoMap) m [SlaveRequest] 160 | runRemoteOneSlaveStateless slaveId requests (MRApply n (ExpClosure ce _) e) = do 161 | requests' <- runRemoteOneSlaveStateless slaveId requests e 162 | -- caching value of ce 163 | vault <- getVault 164 | let keyce = getLocalVaultKey ce 165 | let cem = V.lookup keyce vault 166 | case cem of 167 | Nothing -> error "local value not cached while executing remote on one slave" 168 | Just (_, Nothing) -> error "local value not cached (BS) while executing remote on one slave" 169 | Just (_, Just p) -> do 170 | let ceId = getLocalIndex ce 171 | let csBs = toData $ getPart slaveId p 172 | return (LsReqExecute n : LsReqCache ceId csBs : requests') 173 | 174 | runRemoteOneSlaveStateless slaveId requests (MRConst n key _ _) = do 175 | vault <- getVault 176 | case V.lookup key vault of 177 | Just partition -> do 178 | let bs = toData $ getPart slaveId partition 179 | return (LsReqCache n bs : requests) 180 | Nothing -> error "MRConst value not cached" 181 | 182 | 183 | fetchOneSlaveResults :: forall a s x m. 184 | (S.Serialize a, CommandClass s x, MonadIO m) 185 | => Int -> MExp 'Remote a -> StateT (s x, V.Vault, InfoMap) m (Maybe (Data a)) 186 | fetchOneSlaveResults slaveId e = do 187 | s <- getRemote 188 | let n = getRemoteIndex e 189 | let req = LsReqFetch n 190 | rE <- liftIO $ send s slaveId req 191 | case handleRpcError rE of 192 | LsRespFetch (Data bs) -> 193 | case S.decode bs of 194 | Right v -> return $ Just (Data v) 195 | Left err -> error ("Cannot decode fetched value: " ++ err) 196 | LsRespFetch NoData -> return $ Just NoData 197 | LsRespFetchMiss -> return Nothing 198 | LsRespError err -> error ("Cannot fetch results for node: "++ err) 199 | _ -> error ( "Should not reach here") 200 | 201 | --fetchOneSlaveResults :: forall a s x m. 202 | -- (S.Serialize a, CommandClass s x, MonadIO m) 203 | -- => Int -> MExp 'Remote a -> StateT (s x, V.Vault, InfoMap) m (Maybe a) 204 | --fetchOneSlaveResults slaveId e = do 205 | -- s <- getRemote 206 | -- let n = getRemoteIndex e 207 | -- let req = LsReqFetch n 208 | -- rE <- liftIO $ send s slaveId req 209 | -- case handleRpcError rE of 210 | -- LsRespFetch (Data bs) -> 211 | -- case S.decode bs of 212 | -- Right v -> return $ Just v 213 | -- Left err -> error ("Cannot decode fetched value: " ++ err) 214 | -- LsRespFetch NoData -> return Nothing 215 | -- LsRespError err -> error ("Cannot fetch results for node: "++ err) 216 | -- _ -> error ( "Should not reach here") 217 | 218 | 219 | --fetchResults :: (S.Serialize b, MonadIO m, CommandClass s x) => 220 | -- UnChunkFun b a -> MExp 'Remote b -> StateT (s x, V.Vault, InfoMap) m a 221 | --fetchResults unChunkFun e = do 222 | -- s <- getRemote 223 | -- let nbSlaves = getNbSlaves s 224 | -- let slaveIds = [0 .. nbSlaves - 1] 225 | -- st <- get 226 | -- r <- liftIO $ mapConcurrently (\slaveId -> evalStateT (fetchOneSlaveResults slaveId e) st) slaveIds 227 | -- return $ unChunkFun $ catMaybes r 228 | 229 | 230 | unCacheRemoteOneSlave :: (CommandClass s x, MonadIO m) => Int -> MExp 'Remote a -> StateT (s x , V.Vault, InfoMap) m () 231 | unCacheRemoteOneSlave slaveId e = do 232 | s <- getRemote 233 | let req = LsReqUncache (getRemoteIndex e) 234 | rE <- liftIO $ send s slaveId req 235 | case handleRpcError rE of 236 | LsRespVoid -> return () 237 | LsRespError err -> error ("Error, uncaching: "++err) 238 | _ -> error ( "Should not reach here") 239 | 240 | unCacheRemote :: (CommandClass s x, MonadIO m) => MExp 'Remote a -> StateT (s x , V.Vault, InfoMap) m () 241 | unCacheRemote e = do 242 | s <- getRemote 243 | let nbSlaves = getNbSlaves s 244 | let slaveIds = [0 .. nbSlaves - 1] 245 | st <- get 246 | _ <- liftIO $ mapConcurrently (\slaveId -> evalStateT (unCacheRemoteOneSlave slaveId e) st) slaveIds 247 | return () 248 | 249 | unCacheLocalOneSlave :: (CommandClass s x, MonadIO m) => Int -> MExp 'Local a -> StateT (s x , V.Vault, InfoMap) m () 250 | unCacheLocalOneSlave slaveId e = do 251 | s <- getRemote 252 | let req = LsReqUncache (getLocalIndex e) 253 | rE <- liftIO $ send s slaveId req 254 | case handleRpcError rE of 255 | LsRespVoid -> return () 256 | LsRespError err -> error ("Error, uncaching: "++err) 257 | _ -> error ("Should not reach here") 258 | 259 | unCacheLocal :: (CommandClass s x, MonadIO m) => MExp 'Local a -> StateT (s x , V.Vault, InfoMap) m () 260 | unCacheLocal e = do 261 | s <- getRemote 262 | let nbSlaves = getNbSlaves s 263 | let slaveIds = [0 .. nbSlaves - 1] 264 | st <- get 265 | _ <- liftIO $ mapConcurrently (\slaveId -> evalStateT (unCacheLocalOneSlave slaveId e) st) slaveIds 266 | return () 267 | 268 | runRemote ::(CommandClass s x, MonadLoggerIO m, S.Serialize b) => 269 | UnChunkFun b a -> MExp 'Remote b -> StateT (s x, V.Vault, InfoMap) m a 270 | runRemote unChunkFun e = do 271 | prepareRunRemote e 272 | s <- getRemote 273 | case isStatefullSlave s of 274 | True -> do 275 | doRunAndFetchRemoteStatefull unChunkFun e 276 | False -> doRunRemoteStateless unChunkFun e 277 | 278 | doRunAndFetchRemoteStatefull ::(CommandClass s x, MonadLoggerIO m, S.Serialize b) => 279 | UnChunkFun b a 280 | -> MExp 'Remote b 281 | -> StateT (s x, V.Vault, InfoMap) m a 282 | doRunAndFetchRemoteStatefull unChunkFun oe@(MRApply n (ExpClosure ce _) e) = do 283 | s <- getRemote 284 | doRunRemoteStatefull e 285 | cp <- runLocal ce 286 | case cp of 287 | (_, Just _) -> return () 288 | (c, Nothing) -> do 289 | let nbSlaves = getNbSlaves s 290 | let partition = fmap S.encode $ chunk' nbSlaves c 291 | vault <- getVault 292 | let key = getLocalVaultKey ce 293 | setVault (V.insert key (c, Just partition) vault) 294 | let nbSlaves = getNbSlaves s 295 | let slaveIds = [0 .. nbSlaves - 1] 296 | st <- get 297 | r <- liftIO $ mapConcurrently (\slaveId -> evalStateT (runAndFetchRemoteOneSlaveStatefull slaveId oe) st) slaveIds 298 | 299 | -- dereference children and cleanup remote cache if necessary 300 | cleanupCacheE <- dereference n (getRemoteIndex e) 301 | when cleanupCacheE $ do unCacheRemote e 302 | 303 | cleanupCacheCe <- dereference n (getLocalIndex ce) 304 | when cleanupCacheCe $ do unCacheLocal ce 305 | return $ unChunkFun $ catMaybes r 306 | 307 | doRunRemoteStatefull ::(CommandClass s x, MonadLoggerIO m) => 308 | MExp 'Remote a 309 | -> StateT (s x, V.Vault, InfoMap) m () 310 | doRunRemoteStatefull e@(MRConst _ key chunkFun aio) = do 311 | a <- liftIO aio 312 | s <- getRemote 313 | vault <- getVault 314 | let nbSlaves = getNbSlaves s 315 | let slaveIds = [0 .. nbSlaves - 1] 316 | let partition = fmap S.encode $ chunkFun nbSlaves a 317 | let vault' = V.insert key partition vault 318 | setVault vault' 319 | st <- get 320 | _ <- liftIO $ mapConcurrently (\slaveId -> evalStateT (runRemoteOneSlaveStatefull slaveId e) st) slaveIds 321 | return () 322 | 323 | doRunRemoteStateless :: forall a b m s x. (CommandClass s x, MonadLoggerIO m, S.Serialize b) 324 | => UnChunkFun b a -> MExp 'Remote b -> StateT (s x, V.Vault, InfoMap) m a 325 | doRunRemoteStateless unChunkFun oe@(MRApply n _ _) = do 326 | s <- getRemote 327 | let nbSlaves = getNbSlaves s 328 | let slaveIds = [0 .. nbSlaves - 1] 329 | st <- get 330 | rs <- liftIO $ mapConcurrently (\slaveId -> evalStateT (proc slaveId) st) slaveIds 331 | return $ unChunkFun $ catMaybes rs 332 | where 333 | proc slaveId = do 334 | requests <- runRemoteOneSlaveStateless slaveId [] oe 335 | -- fetch the results 336 | let requests' = L.reverse requests 337 | s <- getRemote 338 | let req = LsReqBatch n requests' 339 | aE <- liftIO $ send s slaveId req 340 | case handleRpcError aE of 341 | LsRespBatch (Data bs) -> 342 | case S.decode bs of 343 | Right a -> return $ Just (a::b) 344 | Left err -> error ("Cannot decode value from a batch execution: "++err) 345 | LsRespBatch NoData -> return Nothing 346 | LsRespError err -> error ("Batch error: "++err) 347 | _ -> error ( "Should not reach here") 348 | 349 | -- TODO uncomment 350 | doRunRemoteStateless unChunkFun (MRConst _ _ chunkFun aio) = do 351 | a <- liftIO aio 352 | return $ unChunkFun [(chunkFun 1 a Vc.! 0)] 353 | 354 | 355 | 356 | -- evaluate all local values (captured in closures) 357 | -- partition and cache MRConst's 358 | prepareRunRemote ::(CommandClass s x, MonadLoggerIO m) => MExp 'Remote a -> StateT (s x, V.Vault, InfoMap) m () 359 | prepareRunRemote (MRApply _ (ExpClosure ce _) e) = do 360 | s <- getRemote 361 | prepareRunRemote e 362 | cp <- runLocal ce 363 | case cp of 364 | (_, Just _) -> return () 365 | (c, Nothing) -> do 366 | let nbSlaves = getNbSlaves s 367 | let partition = fmap S.encode $ chunk' nbSlaves c 368 | vault <- getVault 369 | let key = getLocalVaultKey ce 370 | setVault (V.insert key (c, Just partition) vault) 371 | return () 372 | 373 | 374 | prepareRunRemote (MRConst _ key chunkFun aio) = do 375 | a <- liftIO aio 376 | s <- getRemote 377 | vault <- getVault 378 | let nbSlaves = getNbSlaves s 379 | let partition = fmap S.encode $ chunkFun nbSlaves a 380 | let vault' = V.insert key partition vault 381 | setVault vault' 382 | return () 383 | 384 | runLocal ::(CommandClass s x, MonadLoggerIO m) => MExp 'Local a -> StateT (s x, V.Vault, InfoMap) m (a, Maybe (Partition BS.ByteString)) 385 | runLocal (MLConst _ key aio) = do 386 | vault <- getVault 387 | let cvm = V.lookup key vault 388 | case cvm of 389 | Just cv -> return cv 390 | Nothing -> do 391 | a <- liftIO aio 392 | setVault (V.insert key (a, Nothing) vault) 393 | return (a, Nothing) 394 | 395 | runLocal (MCollect n key unChunkFun e) = do 396 | vault <- getVault 397 | let cvm = V.lookup key vault 398 | case cvm of 399 | Just a -> return a 400 | Nothing -> do 401 | a <- runRemote unChunkFun e 402 | vault' <- getVault 403 | setVault (V.insert key (a, Nothing) vault') 404 | 405 | -- dereference children and clenup remote cache if necessary 406 | cleanupCacheE <- dereference n (getRemoteIndex e) 407 | when cleanupCacheE $ do unCacheRemote e 408 | return (a, Nothing) 409 | 410 | runLocal (MLApply _ key f e) = do 411 | vault <- getVault 412 | let cvm = V.lookup key vault 413 | case cvm of 414 | Just a -> return a 415 | Nothing -> do 416 | (a, _) <- runLocal e 417 | (f', _) <- runLocal f 418 | let r = f' a 419 | vault' <- getVault 420 | setVault (V.insert key (r, Nothing) vault') 421 | return (r, Nothing) 422 | 423 | 424 | 425 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Jean-Christophe Mincke (c) 2016-2017 2 | 3 | Mozilla Public License Version 2.0 4 | ================================== 5 | 6 | 1. Definitions 7 | -------------- 8 | 9 | 1.1. "Contributor" 10 | means each individual or legal entity that creates, contributes to 11 | the creation of, or owns Covered Software. 12 | 13 | 1.2. "Contributor Version" 14 | means the combination of the Contributions of others (if any) used 15 | by a Contributor and that particular Contributor's Contribution. 16 | 17 | 1.3. "Contribution" 18 | means Covered Software of a particular Contributor. 19 | 20 | 1.4. "Covered Software" 21 | means Source Code Form to which the initial Contributor has attached 22 | the notice in Exhibit A, the Executable Form of such Source Code 23 | Form, and Modifications of such Source Code Form, in each case 24 | including portions thereof. 25 | 26 | 1.5. "Incompatible With Secondary Licenses" 27 | means 28 | 29 | (a) that the initial Contributor has attached the notice described 30 | in Exhibit B to the Covered Software; or 31 | 32 | (b) that the Covered Software was made available under the terms of 33 | version 1.1 or earlier of the License, but not also under the 34 | terms of a Secondary License. 35 | 36 | 1.6. "Executable Form" 37 | means any form of the work other than Source Code Form. 38 | 39 | 1.7. "Larger Work" 40 | means a work that combines Covered Software with other material, in 41 | a separate file or files, that is not Covered Software. 42 | 43 | 1.8. "License" 44 | means this document. 45 | 46 | 1.9. "Licensable" 47 | means having the right to grant, to the maximum extent possible, 48 | whether at the time of the initial grant or subsequently, any and 49 | all of the rights conveyed by this License. 50 | 51 | 1.10. "Modifications" 52 | means any of the following: 53 | 54 | (a) any file in Source Code Form that results from an addition to, 55 | deletion from, or modification of the contents of Covered 56 | Software; or 57 | 58 | (b) any new file in Source Code Form that contains any Covered 59 | Software. 60 | 61 | 1.11. "Patent Claims" of a Contributor 62 | means any patent claim(s), including without limitation, method, 63 | process, and apparatus claims, in any patent Licensable by such 64 | Contributor that would be infringed, but for the grant of the 65 | License, by the making, using, selling, offering for sale, having 66 | made, import, or transfer of either its Contributions or its 67 | Contributor Version. 68 | 69 | 1.12. "Secondary License" 70 | means either the GNU General Public License, Version 2.0, the GNU 71 | Lesser General Public License, Version 2.1, the GNU Affero General 72 | Public License, Version 3.0, or any later versions of those 73 | licenses. 74 | 75 | 1.13. "Source Code Form" 76 | means the form of the work preferred for making modifications. 77 | 78 | 1.14. "You" (or "Your") 79 | means an individual or a legal entity exercising rights under this 80 | License. For legal entities, "You" includes any entity that 81 | controls, is controlled by, or is under common control with You. For 82 | purposes of this definition, "control" means (a) the power, direct 83 | or indirect, to cause the direction or management of such entity, 84 | whether by contract or otherwise, or (b) ownership of more than 85 | fifty percent (50%) of the outstanding shares or beneficial 86 | ownership of such entity. 87 | 88 | 2. License Grants and Conditions 89 | -------------------------------- 90 | 91 | 2.1. Grants 92 | 93 | Each Contributor hereby grants You a world-wide, royalty-free, 94 | non-exclusive license: 95 | 96 | (a) under intellectual property rights (other than patent or trademark) 97 | Licensable by such Contributor to use, reproduce, make available, 98 | modify, display, perform, distribute, and otherwise exploit its 99 | Contributions, either on an unmodified basis, with Modifications, or 100 | as part of a Larger Work; and 101 | 102 | (b) under Patent Claims of such Contributor to make, use, sell, offer 103 | for sale, have made, import, and otherwise transfer either its 104 | Contributions or its Contributor Version. 105 | 106 | 2.2. Effective Date 107 | 108 | The licenses granted in Section 2.1 with respect to any Contribution 109 | become effective for each Contribution on the date the Contributor first 110 | distributes such Contribution. 111 | 112 | 2.3. Limitations on Grant Scope 113 | 114 | The licenses granted in this Section 2 are the only rights granted under 115 | this License. No additional rights or licenses will be implied from the 116 | distribution or licensing of Covered Software under this License. 117 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 118 | Contributor: 119 | 120 | (a) for any code that a Contributor has removed from Covered Software; 121 | or 122 | 123 | (b) for infringements caused by: (i) Your and any other third party's 124 | modifications of Covered Software, or (ii) the combination of its 125 | Contributions with other software (except as part of its Contributor 126 | Version); or 127 | 128 | (c) under Patent Claims infringed by Covered Software in the absence of 129 | its Contributions. 130 | 131 | This License does not grant any rights in the trademarks, service marks, 132 | or logos of any Contributor (except as may be necessary to comply with 133 | the notice requirements in Section 3.4). 134 | 135 | 2.4. Subsequent Licenses 136 | 137 | No Contributor makes additional grants as a result of Your choice to 138 | distribute the Covered Software under a subsequent version of this 139 | License (see Section 10.2) or under the terms of a Secondary License (if 140 | permitted under the terms of Section 3.3). 141 | 142 | 2.5. Representation 143 | 144 | Each Contributor represents that the Contributor believes its 145 | Contributions are its original creation(s) or it has sufficient rights 146 | to grant the rights to its Contributions conveyed by this License. 147 | 148 | 2.6. Fair Use 149 | 150 | This License is not intended to limit any rights You have under 151 | applicable copyright doctrines of fair use, fair dealing, or other 152 | equivalents. 153 | 154 | 2.7. Conditions 155 | 156 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 157 | in Section 2.1. 158 | 159 | 3. Responsibilities 160 | ------------------- 161 | 162 | 3.1. Distribution of Source Form 163 | 164 | All distribution of Covered Software in Source Code Form, including any 165 | Modifications that You create or to which You contribute, must be under 166 | the terms of this License. You must inform recipients that the Source 167 | Code Form of the Covered Software is governed by the terms of this 168 | License, and how they can obtain a copy of this License. You may not 169 | attempt to alter or restrict the recipients' rights in the Source Code 170 | Form. 171 | 172 | 3.2. Distribution of Executable Form 173 | 174 | If You distribute Covered Software in Executable Form then: 175 | 176 | (a) such Covered Software must also be made available in Source Code 177 | Form, as described in Section 3.1, and You must inform recipients of 178 | the Executable Form how they can obtain a copy of such Source Code 179 | Form by reasonable means in a timely manner, at a charge no more 180 | than the cost of distribution to the recipient; and 181 | 182 | (b) You may distribute such Executable Form under the terms of this 183 | License, or sublicense it under different terms, provided that the 184 | license for the Executable Form does not attempt to limit or alter 185 | the recipients' rights in the Source Code Form under this License. 186 | 187 | 3.3. Distribution of a Larger Work 188 | 189 | You may create and distribute a Larger Work under terms of Your choice, 190 | provided that You also comply with the requirements of this License for 191 | the Covered Software. If the Larger Work is a combination of Covered 192 | Software with a work governed by one or more Secondary Licenses, and the 193 | Covered Software is not Incompatible With Secondary Licenses, this 194 | License permits You to additionally distribute such Covered Software 195 | under the terms of such Secondary License(s), so that the recipient of 196 | the Larger Work may, at their option, further distribute the Covered 197 | Software under the terms of either this License or such Secondary 198 | License(s). 199 | 200 | 3.4. Notices 201 | 202 | You may not remove or alter the substance of any license notices 203 | (including copyright notices, patent notices, disclaimers of warranty, 204 | or limitations of liability) contained within the Source Code Form of 205 | the Covered Software, except that You may alter any license notices to 206 | the extent required to remedy known factual inaccuracies. 207 | 208 | 3.5. Application of Additional Terms 209 | 210 | You may choose to offer, and to charge a fee for, warranty, support, 211 | indemnity or liability obligations to one or more recipients of Covered 212 | Software. However, You may do so only on Your own behalf, and not on 213 | behalf of any Contributor. You must make it absolutely clear that any 214 | such warranty, support, indemnity, or liability obligation is offered by 215 | You alone, and You hereby agree to indemnify every Contributor for any 216 | liability incurred by such Contributor as a result of warranty, support, 217 | indemnity or liability terms You offer. You may include additional 218 | disclaimers of warranty and limitations of liability specific to any 219 | jurisdiction. 220 | 221 | 4. Inability to Comply Due to Statute or Regulation 222 | --------------------------------------------------- 223 | 224 | If it is impossible for You to comply with any of the terms of this 225 | License with respect to some or all of the Covered Software due to 226 | statute, judicial order, or regulation then You must: (a) comply with 227 | the terms of this License to the maximum extent possible; and (b) 228 | describe the limitations and the code they affect. Such description must 229 | be placed in a text file included with all distributions of the Covered 230 | Software under this License. Except to the extent prohibited by statute 231 | or regulation, such description must be sufficiently detailed for a 232 | recipient of ordinary skill to be able to understand it. 233 | 234 | 5. Termination 235 | -------------- 236 | 237 | 5.1. The rights granted under this License will terminate automatically 238 | if You fail to comply with any of its terms. However, if You become 239 | compliant, then the rights granted under this License from a particular 240 | Contributor are reinstated (a) provisionally, unless and until such 241 | Contributor explicitly and finally terminates Your grants, and (b) on an 242 | ongoing basis, if such Contributor fails to notify You of the 243 | non-compliance by some reasonable means prior to 60 days after You have 244 | come back into compliance. Moreover, Your grants from a particular 245 | Contributor are reinstated on an ongoing basis if such Contributor 246 | notifies You of the non-compliance by some reasonable means, this is the 247 | first time You have received notice of non-compliance with this License 248 | from such Contributor, and You become compliant prior to 30 days after 249 | Your receipt of the notice. 250 | 251 | 5.2. If You initiate litigation against any entity by asserting a patent 252 | infringement claim (excluding declaratory judgment actions, 253 | counter-claims, and cross-claims) alleging that a Contributor Version 254 | directly or indirectly infringes any patent, then the rights granted to 255 | You by any and all Contributors for the Covered Software under Section 256 | 2.1 of this License shall terminate. 257 | 258 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 259 | end user license agreements (excluding distributors and resellers) which 260 | have been validly granted by You or Your distributors under this License 261 | prior to termination shall survive termination. 262 | 263 | ************************************************************************ 264 | * * 265 | * 6. Disclaimer of Warranty * 266 | * ------------------------- * 267 | * * 268 | * Covered Software is provided under this License on an "as is" * 269 | * basis, without warranty of any kind, either expressed, implied, or * 270 | * statutory, including, without limitation, warranties that the * 271 | * Covered Software is free of defects, merchantable, fit for a * 272 | * particular purpose or non-infringing. The entire risk as to the * 273 | * quality and performance of the Covered Software is with You. * 274 | * Should any Covered Software prove defective in any respect, You * 275 | * (not any Contributor) assume the cost of any necessary servicing, * 276 | * repair, or correction. This disclaimer of warranty constitutes an * 277 | * essential part of this License. No use of any Covered Software is * 278 | * authorized under this License except under this disclaimer. * 279 | * * 280 | ************************************************************************ 281 | 282 | ************************************************************************ 283 | * * 284 | * 7. Limitation of Liability * 285 | * -------------------------- * 286 | * * 287 | * Under no circumstances and under no legal theory, whether tort * 288 | * (including negligence), contract, or otherwise, shall any * 289 | * Contributor, or anyone who distributes Covered Software as * 290 | * permitted above, be liable to You for any direct, indirect, * 291 | * special, incidental, or consequential damages of any character * 292 | * including, without limitation, damages for lost profits, loss of * 293 | * goodwill, work stoppage, computer failure or malfunction, or any * 294 | * and all other commercial damages or losses, even if such party * 295 | * shall have been informed of the possibility of such damages. This * 296 | * limitation of liability shall not apply to liability for death or * 297 | * personal injury resulting from such party's negligence to the * 298 | * extent applicable law prohibits such limitation. Some * 299 | * jurisdictions do not allow the exclusion or limitation of * 300 | * incidental or consequential damages, so this exclusion and * 301 | * limitation may not apply to You. * 302 | * * 303 | ************************************************************************ 304 | 305 | 8. Litigation 306 | ------------- 307 | 308 | Any litigation relating to this License may be brought only in the 309 | courts of a jurisdiction where the defendant maintains its principal 310 | place of business and such litigation shall be governed by laws of that 311 | jurisdiction, without reference to its conflict-of-law provisions. 312 | Nothing in this Section shall prevent a party's ability to bring 313 | cross-claims or counter-claims. 314 | 315 | 9. Miscellaneous 316 | ---------------- 317 | 318 | This License represents the complete agreement concerning the subject 319 | matter hereof. If any provision of this License is held to be 320 | unenforceable, such provision shall be reformed only to the extent 321 | necessary to make it enforceable. Any law or regulation which provides 322 | that the language of a contract shall be construed against the drafter 323 | shall not be used to construe this License against a Contributor. 324 | 325 | 10. Versions of the License 326 | --------------------------- 327 | 328 | 10.1. New Versions 329 | 330 | Mozilla Foundation is the license steward. Except as provided in Section 331 | 10.3, no one other than the license steward has the right to modify or 332 | publish new versions of this License. Each version will be given a 333 | distinguishing version number. 334 | 335 | 10.2. Effect of New Versions 336 | 337 | You may distribute the Covered Software under the terms of the version 338 | of the License under which You originally received the Covered Software, 339 | or under the terms of any subsequent version published by the license 340 | steward. 341 | 342 | 10.3. Modified Versions 343 | 344 | If you create software not governed by this License, and you want to 345 | create a new license for such software, you may create and use a 346 | modified version of this License if you rename the license and remove 347 | any references to the name of the license steward (except to note that 348 | such modified license differs from this License). 349 | 350 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 351 | Licenses 352 | 353 | If You choose to distribute Source Code Form that is Incompatible With 354 | Secondary Licenses under the terms of this version of the License, the 355 | notice described in Exhibit B of this License must be attached. 356 | 357 | Exhibit A - Source Code Form License Notice 358 | ------------------------------------------- 359 | 360 | This Source Code Form is subject to the terms of the Mozilla Public 361 | License, v. 2.0. If a copy of the MPL was not distributed with this 362 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 363 | 364 | If it is not possible or desirable to put the notice in a particular 365 | file, then You may include the notice in a location (such as a LICENSE 366 | file in a relevant directory) where a recipient would be likely to look 367 | for such a notice. 368 | 369 | You may add additional accurate notices of copyright ownership. 370 | 371 | Exhibit B - "Incompatible With Secondary Licenses" Notice 372 | --------------------------------------------------------- 373 | 374 | This Source Code Form is "Incompatible With Secondary Licenses", as 375 | defined by the Mozilla Public License, v. 2.0. -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Jean-Christophe Mincke (c) 2016-2017 2 | 3 | Mozilla Public License Version 2.0 4 | ================================== 5 | 6 | 1. Definitions 7 | -------------- 8 | 9 | 1.1. "Contributor" 10 | means each individual or legal entity that creates, contributes to 11 | the creation of, or owns Covered Software. 12 | 13 | 1.2. "Contributor Version" 14 | means the combination of the Contributions of others (if any) used 15 | by a Contributor and that particular Contributor's Contribution. 16 | 17 | 1.3. "Contribution" 18 | means Covered Software of a particular Contributor. 19 | 20 | 1.4. "Covered Software" 21 | means Source Code Form to which the initial Contributor has attached 22 | the notice in Exhibit A, the Executable Form of such Source Code 23 | Form, and Modifications of such Source Code Form, in each case 24 | including portions thereof. 25 | 26 | 1.5. "Incompatible With Secondary Licenses" 27 | means 28 | 29 | (a) that the initial Contributor has attached the notice described 30 | in Exhibit B to the Covered Software; or 31 | 32 | (b) that the Covered Software was made available under the terms of 33 | version 1.1 or earlier of the License, but not also under the 34 | terms of a Secondary License. 35 | 36 | 1.6. "Executable Form" 37 | means any form of the work other than Source Code Form. 38 | 39 | 1.7. "Larger Work" 40 | means a work that combines Covered Software with other material, in 41 | a separate file or files, that is not Covered Software. 42 | 43 | 1.8. "License" 44 | means this document. 45 | 46 | 1.9. "Licensable" 47 | means having the right to grant, to the maximum extent possible, 48 | whether at the time of the initial grant or subsequently, any and 49 | all of the rights conveyed by this License. 50 | 51 | 1.10. "Modifications" 52 | means any of the following: 53 | 54 | (a) any file in Source Code Form that results from an addition to, 55 | deletion from, or modification of the contents of Covered 56 | Software; or 57 | 58 | (b) any new file in Source Code Form that contains any Covered 59 | Software. 60 | 61 | 1.11. "Patent Claims" of a Contributor 62 | means any patent claim(s), including without limitation, method, 63 | process, and apparatus claims, in any patent Licensable by such 64 | Contributor that would be infringed, but for the grant of the 65 | License, by the making, using, selling, offering for sale, having 66 | made, import, or transfer of either its Contributions or its 67 | Contributor Version. 68 | 69 | 1.12. "Secondary License" 70 | means either the GNU General Public License, Version 2.0, the GNU 71 | Lesser General Public License, Version 2.1, the GNU Affero General 72 | Public License, Version 3.0, or any later versions of those 73 | licenses. 74 | 75 | 1.13. "Source Code Form" 76 | means the form of the work preferred for making modifications. 77 | 78 | 1.14. "You" (or "Your") 79 | means an individual or a legal entity exercising rights under this 80 | License. For legal entities, "You" includes any entity that 81 | controls, is controlled by, or is under common control with You. For 82 | purposes of this definition, "control" means (a) the power, direct 83 | or indirect, to cause the direction or management of such entity, 84 | whether by contract or otherwise, or (b) ownership of more than 85 | fifty percent (50%) of the outstanding shares or beneficial 86 | ownership of such entity. 87 | 88 | 2. License Grants and Conditions 89 | -------------------------------- 90 | 91 | 2.1. Grants 92 | 93 | Each Contributor hereby grants You a world-wide, royalty-free, 94 | non-exclusive license: 95 | 96 | (a) under intellectual property rights (other than patent or trademark) 97 | Licensable by such Contributor to use, reproduce, make available, 98 | modify, display, perform, distribute, and otherwise exploit its 99 | Contributions, either on an unmodified basis, with Modifications, or 100 | as part of a Larger Work; and 101 | 102 | (b) under Patent Claims of such Contributor to make, use, sell, offer 103 | for sale, have made, import, and otherwise transfer either its 104 | Contributions or its Contributor Version. 105 | 106 | 2.2. Effective Date 107 | 108 | The licenses granted in Section 2.1 with respect to any Contribution 109 | become effective for each Contribution on the date the Contributor first 110 | distributes such Contribution. 111 | 112 | 2.3. Limitations on Grant Scope 113 | 114 | The licenses granted in this Section 2 are the only rights granted under 115 | this License. No additional rights or licenses will be implied from the 116 | distribution or licensing of Covered Software under this License. 117 | Notwithstanding Section 2.1(b) above, no patent license is granted by a 118 | Contributor: 119 | 120 | (a) for any code that a Contributor has removed from Covered Software; 121 | or 122 | 123 | (b) for infringements caused by: (i) Your and any other third party's 124 | modifications of Covered Software, or (ii) the combination of its 125 | Contributions with other software (except as part of its Contributor 126 | Version); or 127 | 128 | (c) under Patent Claims infringed by Covered Software in the absence of 129 | its Contributions. 130 | 131 | This License does not grant any rights in the trademarks, service marks, 132 | or logos of any Contributor (except as may be necessary to comply with 133 | the notice requirements in Section 3.4). 134 | 135 | 2.4. Subsequent Licenses 136 | 137 | No Contributor makes additional grants as a result of Your choice to 138 | distribute the Covered Software under a subsequent version of this 139 | License (see Section 10.2) or under the terms of a Secondary License (if 140 | permitted under the terms of Section 3.3). 141 | 142 | 2.5. Representation 143 | 144 | Each Contributor represents that the Contributor believes its 145 | Contributions are its original creation(s) or it has sufficient rights 146 | to grant the rights to its Contributions conveyed by this License. 147 | 148 | 2.6. Fair Use 149 | 150 | This License is not intended to limit any rights You have under 151 | applicable copyright doctrines of fair use, fair dealing, or other 152 | equivalents. 153 | 154 | 2.7. Conditions 155 | 156 | Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted 157 | in Section 2.1. 158 | 159 | 3. Responsibilities 160 | ------------------- 161 | 162 | 3.1. Distribution of Source Form 163 | 164 | All distribution of Covered Software in Source Code Form, including any 165 | Modifications that You create or to which You contribute, must be under 166 | the terms of this License. You must inform recipients that the Source 167 | Code Form of the Covered Software is governed by the terms of this 168 | License, and how they can obtain a copy of this License. You may not 169 | attempt to alter or restrict the recipients' rights in the Source Code 170 | Form. 171 | 172 | 3.2. Distribution of Executable Form 173 | 174 | If You distribute Covered Software in Executable Form then: 175 | 176 | (a) such Covered Software must also be made available in Source Code 177 | Form, as described in Section 3.1, and You must inform recipients of 178 | the Executable Form how they can obtain a copy of such Source Code 179 | Form by reasonable means in a timely manner, at a charge no more 180 | than the cost of distribution to the recipient; and 181 | 182 | (b) You may distribute such Executable Form under the terms of this 183 | License, or sublicense it under different terms, provided that the 184 | license for the Executable Form does not attempt to limit or alter 185 | the recipients' rights in the Source Code Form under this License. 186 | 187 | 3.3. Distribution of a Larger Work 188 | 189 | You may create and distribute a Larger Work under terms of Your choice, 190 | provided that You also comply with the requirements of this License for 191 | the Covered Software. If the Larger Work is a combination of Covered 192 | Software with a work governed by one or more Secondary Licenses, and the 193 | Covered Software is not Incompatible With Secondary Licenses, this 194 | License permits You to additionally distribute such Covered Software 195 | under the terms of such Secondary License(s), so that the recipient of 196 | the Larger Work may, at their option, further distribute the Covered 197 | Software under the terms of either this License or such Secondary 198 | License(s). 199 | 200 | 3.4. Notices 201 | 202 | You may not remove or alter the substance of any license notices 203 | (including copyright notices, patent notices, disclaimers of warranty, 204 | or limitations of liability) contained within the Source Code Form of 205 | the Covered Software, except that You may alter any license notices to 206 | the extent required to remedy known factual inaccuracies. 207 | 208 | 3.5. Application of Additional Terms 209 | 210 | You may choose to offer, and to charge a fee for, warranty, support, 211 | indemnity or liability obligations to one or more recipients of Covered 212 | Software. However, You may do so only on Your own behalf, and not on 213 | behalf of any Contributor. You must make it absolutely clear that any 214 | such warranty, support, indemnity, or liability obligation is offered by 215 | You alone, and You hereby agree to indemnify every Contributor for any 216 | liability incurred by such Contributor as a result of warranty, support, 217 | indemnity or liability terms You offer. You may include additional 218 | disclaimers of warranty and limitations of liability specific to any 219 | jurisdiction. 220 | 221 | 4. Inability to Comply Due to Statute or Regulation 222 | --------------------------------------------------- 223 | 224 | If it is impossible for You to comply with any of the terms of this 225 | License with respect to some or all of the Covered Software due to 226 | statute, judicial order, or regulation then You must: (a) comply with 227 | the terms of this License to the maximum extent possible; and (b) 228 | describe the limitations and the code they affect. Such description must 229 | be placed in a text file included with all distributions of the Covered 230 | Software under this License. Except to the extent prohibited by statute 231 | or regulation, such description must be sufficiently detailed for a 232 | recipient of ordinary skill to be able to understand it. 233 | 234 | 5. Termination 235 | -------------- 236 | 237 | 5.1. The rights granted under this License will terminate automatically 238 | if You fail to comply with any of its terms. However, if You become 239 | compliant, then the rights granted under this License from a particular 240 | Contributor are reinstated (a) provisionally, unless and until such 241 | Contributor explicitly and finally terminates Your grants, and (b) on an 242 | ongoing basis, if such Contributor fails to notify You of the 243 | non-compliance by some reasonable means prior to 60 days after You have 244 | come back into compliance. Moreover, Your grants from a particular 245 | Contributor are reinstated on an ongoing basis if such Contributor 246 | notifies You of the non-compliance by some reasonable means, this is the 247 | first time You have received notice of non-compliance with this License 248 | from such Contributor, and You become compliant prior to 30 days after 249 | Your receipt of the notice. 250 | 251 | 5.2. If You initiate litigation against any entity by asserting a patent 252 | infringement claim (excluding declaratory judgment actions, 253 | counter-claims, and cross-claims) alleging that a Contributor Version 254 | directly or indirectly infringes any patent, then the rights granted to 255 | You by any and all Contributors for the Covered Software under Section 256 | 2.1 of this License shall terminate. 257 | 258 | 5.3. In the event of termination under Sections 5.1 or 5.2 above, all 259 | end user license agreements (excluding distributors and resellers) which 260 | have been validly granted by You or Your distributors under this License 261 | prior to termination shall survive termination. 262 | 263 | ************************************************************************ 264 | * * 265 | * 6. Disclaimer of Warranty * 266 | * ------------------------- * 267 | * * 268 | * Covered Software is provided under this License on an "as is" * 269 | * basis, without warranty of any kind, either expressed, implied, or * 270 | * statutory, including, without limitation, warranties that the * 271 | * Covered Software is free of defects, merchantable, fit for a * 272 | * particular purpose or non-infringing. The entire risk as to the * 273 | * quality and performance of the Covered Software is with You. * 274 | * Should any Covered Software prove defective in any respect, You * 275 | * (not any Contributor) assume the cost of any necessary servicing, * 276 | * repair, or correction. This disclaimer of warranty constitutes an * 277 | * essential part of this License. No use of any Covered Software is * 278 | * authorized under this License except under this disclaimer. * 279 | * * 280 | ************************************************************************ 281 | 282 | ************************************************************************ 283 | * * 284 | * 7. Limitation of Liability * 285 | * -------------------------- * 286 | * * 287 | * Under no circumstances and under no legal theory, whether tort * 288 | * (including negligence), contract, or otherwise, shall any * 289 | * Contributor, or anyone who distributes Covered Software as * 290 | * permitted above, be liable to You for any direct, indirect, * 291 | * special, incidental, or consequential damages of any character * 292 | * including, without limitation, damages for lost profits, loss of * 293 | * goodwill, work stoppage, computer failure or malfunction, or any * 294 | * and all other commercial damages or losses, even if such party * 295 | * shall have been informed of the possibility of such damages. This * 296 | * limitation of liability shall not apply to liability for death or * 297 | * personal injury resulting from such party's negligence to the * 298 | * extent applicable law prohibits such limitation. Some * 299 | * jurisdictions do not allow the exclusion or limitation of * 300 | * incidental or consequential damages, so this exclusion and * 301 | * limitation may not apply to You. * 302 | * * 303 | ************************************************************************ 304 | 305 | 8. Litigation 306 | ------------- 307 | 308 | Any litigation relating to this License may be brought only in the 309 | courts of a jurisdiction where the defendant maintains its principal 310 | place of business and such litigation shall be governed by laws of that 311 | jurisdiction, without reference to its conflict-of-law provisions. 312 | Nothing in this Section shall prevent a party's ability to bring 313 | cross-claims or counter-claims. 314 | 315 | 9. Miscellaneous 316 | ---------------- 317 | 318 | This License represents the complete agreement concerning the subject 319 | matter hereof. If any provision of this License is held to be 320 | unenforceable, such provision shall be reformed only to the extent 321 | necessary to make it enforceable. Any law or regulation which provides 322 | that the language of a contract shall be construed against the drafter 323 | shall not be used to construe this License against a Contributor. 324 | 325 | 10. Versions of the License 326 | --------------------------- 327 | 328 | 10.1. New Versions 329 | 330 | Mozilla Foundation is the license steward. Except as provided in Section 331 | 10.3, no one other than the license steward has the right to modify or 332 | publish new versions of this License. Each version will be given a 333 | distinguishing version number. 334 | 335 | 10.2. Effect of New Versions 336 | 337 | You may distribute the Covered Software under the terms of the version 338 | of the License under which You originally received the Covered Software, 339 | or under the terms of any subsequent version published by the license 340 | steward. 341 | 342 | 10.3. Modified Versions 343 | 344 | If you create software not governed by this License, and you want to 345 | create a new license for such software, you may create and use a 346 | modified version of this License if you rename the license and remove 347 | any references to the name of the license steward (except to note that 348 | such modified license differs from this License). 349 | 350 | 10.4. Distributing Source Code Form that is Incompatible With Secondary 351 | Licenses 352 | 353 | If You choose to distribute Source Code Form that is Incompatible With 354 | Secondary Licenses under the terms of this version of the License, the 355 | notice described in Exhibit B of this License must be attached. 356 | 357 | Exhibit A - Source Code Form License Notice 358 | ------------------------------------------- 359 | 360 | This Source Code Form is subject to the terms of the Mozilla Public 361 | License, v. 2.0. If a copy of the MPL was not distributed with this 362 | file, You can obtain one at http://mozilla.org/MPL/2.0/. 363 | 364 | If it is not possible or desirable to put the notice in a particular 365 | file, then You may include the notice in a location (such as a LICENSE 366 | file in a relevant directory) where a recipient would be likely to look 367 | for such a notice. 368 | 369 | You may add additional accurate notices of copyright ownership. 370 | 371 | Exhibit B - "Incompatible With Secondary Licenses" Notice 372 | --------------------------------------------------------- 373 | 374 | This Source Code Form is "Incompatible With Secondary Licenses", as 375 | defined by the Mozilla Public License, v. 2.0. -------------------------------------------------------------------------------- /examples/WordCount/files/f1.txt: -------------------------------------------------------------------------------- 1 | At nunc si ad aliquem bene nummatum tumentemque ideo honestus advena salutatum introieris, primitus tamquam exoptatus suscipieris et interrogatus multa coactusque mentiri, miraberis numquam antea visus summatem virum tenuem te sic enixius observantem, ut paeniteat ob haec bona tamquam praecipua non vidisse ante decennium Romam. 2 | 3 | Nec piget dicere avide magis hanc insulam populum Romanum invasisse quam iuste. Ptolomaeo enim rege foederato nobis et socio ob aerarii nostri angustias iusso sine ulla culpa proscribi ideoque hausto veneno voluntaria morte deleto et tributaria facta est et velut hostiles eius exuviae classi inpositae in urbem advectae sunt per Catonem, nunc repetetur ordo gestorum. 4 | 5 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 6 | 7 | Iis igitur est difficilius satis facere, qui se Latina scripta dicunt contemnere. in quibus hoc primum est in quo admirer, cur in gravissimis rebus non delectet eos sermo patrius, cum idem fabellas Latinas ad verbum e Graecis expressas non inviti legant. quis enim tam inimicus paene nomini Romano est, qui Ennii Medeam aut Antiopam Pacuvii spernat aut reiciat, quod se isdem Euripidis fabulis delectari dicat, Latinas litteras oderit? 8 | 9 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 10 | 11 | Victus universis caro ferina est lactisque abundans copia qua sustentantur, et herbae multiplices et siquae alites capi per aucupium possint, et plerosque mos vidimus frumenti usum et vini penitus ignorantes. 12 | 13 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 14 | 15 | Altera sententia est, quae definit amicitiam paribus officiis ac voluntatibus. Hoc quidem est nimis exigue et exiliter ad calculos vocare amicitiam, ut par sit ratio acceptorum et datorum. Divitior mihi et affluentior videtur esse vera amicitia nec observare restricte, ne plus reddat quam acceperit; neque enim verendum est, ne quid excidat, aut ne quid in terram defluat, aut ne plus aequo quid in amicitiam congeratur. 16 | 17 | Primi igitur omnium statuuntur Epigonus et Eusebius ob nominum gentilitatem oppressi. praediximus enim Montium sub ipso vivendi termino his vocabulis appellatos fabricarum culpasse tribunos ut adminicula futurae molitioni pollicitos. 18 | 19 | Cum autem commodis intervallata temporibus convivia longa et noxia coeperint apparari vel distributio sollemnium sportularum, anxia deliberatione tractatur an exceptis his quibus vicissitudo debetur, peregrinum invitari conveniet, et si digesto plene consilio id placuerit fieri, is adhibetur qui pro domibus excubat aurigarum aut artem tesserariam profitetur aut secretiora quaedam se nosse confingit. 20 | 21 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 22 | 23 | Quare hoc quidem praeceptum, cuiuscumque est, ad tollendam amicitiam valet; illud potius praecipiendum fuit, ut eam diligentiam adhiberemus in amicitiis comparandis, ut ne quando amare inciperemus eum, quem aliquando odisse possemus. Quin etiam si minus felices in diligendo fuissemus, ferendum id Scipio potius quam inimicitiarum tempus cogitandum putabat. 24 | 25 | Ipsam vero urbem Byzantiorum fuisse refertissimam atque ornatissimam signis quis ignorat? Quae illi, exhausti sumptibus bellisque maximis, cum omnis Mithridaticos impetus totumque Pontum armatum affervescentem in Asiam atque erumpentem, ore repulsum et cervicibus interclusum suis sustinerent, tum, inquam, Byzantii et postea signa illa et reliqua urbis ornanemta sanctissime custodita tenuerunt. 26 | 27 | Quod si rectum statuerimus vel concedere amicis, quidquid velint, vel impetrare ab iis, quidquid velimus, perfecta quidem sapientia si simus, nihil habeat res vitii; sed loquimur de iis amicis qui ante oculos sunt, quos vidimus aut de quibus memoriam accepimus, quos novit vita communis. Ex hoc numero nobis exempla sumenda sunt, et eorum quidem maxime qui ad sapientiam proxime accedunt. 28 | 29 | Martinus agens illas provincias pro praefectis aerumnas innocentium graviter gemens saepeque obsecrans, ut ab omni culpa inmunibus parceretur, cum non inpetraret, minabatur se discessurum: ut saltem id metuens perquisitor malivolus tandem desineret quieti coalitos homines in aperta pericula proiectare. 30 | 31 | Postremo ad id indignitatis est ventum, ut cum peregrini ob formidatam haut ita dudum alimentorum inopiam pellerentur ab urbe praecipites, sectatoribus disciplinarum liberalium inpendio paucis sine respiratione ulla extrusis, tenerentur minimarum adseclae veri, quique id simularunt ad tempus, et tria milia saltatricum ne interpellata quidem cum choris totidemque remanerent magistris. 32 | 33 | Paphius quin etiam et Cornelius senatores, ambo venenorum artibus pravis se polluisse confessi, eodem pronuntiante Maximino sunt interfecti. pari sorte etiam procurator monetae extinctus est. Sericum enim et Asbolium supra dictos, quoniam cum hortaretur passim nominare, quos vellent, adiecta religione firmarat, nullum igni vel ferro se puniri iussurum, plumbi validis ictibus interemit. et post hoe flammis Campensem aruspicem dedit, in negotio eius nullo sacramento constrictus. 34 | 35 | Ob haec et huius modi multa, quae cernebantur in paucis, omnibus timeri sunt coepta. et ne tot malis dissimulatis paulatimque serpentibus acervi crescerent aerumnarum, nobilitatis decreto legati mittuntur: Praetextatus ex urbi praefecto et ex vicario Venustus et ex consulari Minervius oraturi, ne delictis supplicia sint grandiora, neve senator quisquam inusitato et inlicito more tormentis exponeretur. 36 | 37 | Latius iam disseminata licentia onerosus bonis omnibus Caesar nullum post haec adhibens modum orientis latera cuncta vexabat nec honoratis parcens nec urbium primatibus nec plebeiis. 38 | 39 | Haec igitur prima lex amicitiae sanciatur, ut ab amicis honesta petamus, amicorum causa honesta faciamus, ne exspectemus quidem, dum rogemur; studium semper adsit, cunctatio absit; consilium vero dare audeamus libere. Plurimum in amicitia amicorum bene suadentium valeat auctoritas, eaque et adhibeatur ad monendum non modo aperte sed etiam acriter, si res postulabit, et adhibitae pareatur.At nunc si ad aliquem bene nummatum tumentemque ideo honestus advena salutatum introieris, primitus tamquam exoptatus suscipieris et interrogatus multa coactusque mentiri, miraberis numquam antea visus summatem virum tenuem te sic enixius observantem, ut paeniteat ob haec bona tamquam praecipua non vidisse ante decennium Romam. 40 | 41 | Nec piget dicere avide magis hanc insulam populum Romanum invasisse quam iuste. Ptolomaeo enim rege foederato nobis et socio ob aerarii nostri angustias iusso sine ulla culpa proscribi ideoque hausto veneno voluntaria morte deleto et tributaria facta est et velut hostiles eius exuviae classi inpositae in urbem advectae sunt per Catonem, nunc repetetur ordo gestorum. 42 | 43 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 44 | 45 | Iis igitur est difficilius satis facere, qui se Latina scripta dicunt contemnere. in quibus hoc primum est in quo admirer, cur in gravissimis rebus non delectet eos sermo patrius, cum idem fabellas Latinas ad verbum e Graecis expressas non inviti legant. quis enim tam inimicus paene nomini Romano est, qui Ennii Medeam aut Antiopam Pacuvii spernat aut reiciat, quod se isdem Euripidis fabulis delectari dicat, Latinas litteras oderit? 46 | 47 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 48 | 49 | Victus universis caro ferina est lactisque abundans copia qua sustentantur, et herbae multiplices et siquae alites capi per aucupium possint, et plerosque mos vidimus frumenti usum et vini penitus ignorantes. 50 | 51 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 52 | 53 | Altera sententia est, quae definit amicitiam paribus officiis ac voluntatibus. Hoc quidem est nimis exigue et exiliter ad calculos vocare amicitiam, ut par sit ratio acceptorum et datorum. Divitior mihi et affluentior videtur esse vera amicitia nec observare restricte, ne plus reddat quam acceperit; neque enim verendum est, ne quid excidat, aut ne quid in terram defluat, aut ne plus aequo quid in amicitiam congeratur. 54 | 55 | Primi igitur omnium statuuntur Epigonus et Eusebius ob nominum gentilitatem oppressi. praediximus enim Montium sub ipso vivendi termino his vocabulis appellatos fabricarum culpasse tribunos ut adminicula futurae molitioni pollicitos. 56 | 57 | Cum autem commodis intervallata temporibus convivia longa et noxia coeperint apparari vel distributio sollemnium sportularum, anxia deliberatione tractatur an exceptis his quibus vicissitudo debetur, peregrinum invitari conveniet, et si digesto plene consilio id placuerit fieri, is adhibetur qui pro domibus excubat aurigarum aut artem tesserariam profitetur aut secretiora quaedam se nosse confingit. 58 | 59 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 60 | 61 | Quare hoc quidem praeceptum, cuiuscumque est, ad tollendam amicitiam valet; illud potius praecipiendum fuit, ut eam diligentiam adhiberemus in amicitiis comparandis, ut ne quando amare inciperemus eum, quem aliquando odisse possemus. Quin etiam si minus felices in diligendo fuissemus, ferendum id Scipio potius quam inimicitiarum tempus cogitandum putabat. 62 | 63 | Ipsam vero urbem Byzantiorum fuisse refertissimam atque ornatissimam signis quis ignorat? Quae illi, exhausti sumptibus bellisque maximis, cum omnis Mithridaticos impetus totumque Pontum armatum affervescentem in Asiam atque erumpentem, ore repulsum et cervicibus interclusum suis sustinerent, tum, inquam, Byzantii et postea signa illa et reliqua urbis ornanemta sanctissime custodita tenuerunt. 64 | 65 | Quod si rectum statuerimus vel concedere amicis, quidquid velint, vel impetrare ab iis, quidquid velimus, perfecta quidem sapientia si simus, nihil habeat res vitii; sed loquimur de iis amicis qui ante oculos sunt, quos vidimus aut de quibus memoriam accepimus, quos novit vita communis. Ex hoc numero nobis exempla sumenda sunt, et eorum quidem maxime qui ad sapientiam proxime accedunt. 66 | 67 | Martinus agens illas provincias pro praefectis aerumnas innocentium graviter gemens saepeque obsecrans, ut ab omni culpa inmunibus parceretur, cum non inpetraret, minabatur se discessurum: ut saltem id metuens perquisitor malivolus tandem desineret quieti coalitos homines in aperta pericula proiectare. 68 | 69 | Postremo ad id indignitatis est ventum, ut cum peregrini ob formidatam haut ita dudum alimentorum inopiam pellerentur ab urbe praecipites, sectatoribus disciplinarum liberalium inpendio paucis sine respiratione ulla extrusis, tenerentur minimarum adseclae veri, quique id simularunt ad tempus, et tria milia saltatricum ne interpellata quidem cum choris totidemque remanerent magistris. 70 | 71 | Paphius quin etiam et Cornelius senatores, ambo venenorum artibus pravis se polluisse confessi, eodem pronuntiante Maximino sunt interfecti. pari sorte etiam procurator monetae extinctus est. Sericum enim et Asbolium supra dictos, quoniam cum hortaretur passim nominare, quos vellent, adiecta religione firmarat, nullum igni vel ferro se puniri iussurum, plumbi validis ictibus interemit. et post hoe flammis Campensem aruspicem dedit, in negotio eius nullo sacramento constrictus. 72 | 73 | Ob haec et huius modi multa, quae cernebantur in paucis, omnibus timeri sunt coepta. et ne tot malis dissimulatis paulatimque serpentibus acervi crescerent aerumnarum, nobilitatis decreto legati mittuntur: Praetextatus ex urbi praefecto et ex vicario Venustus et ex consulari Minervius oraturi, ne delictis supplicia sint grandiora, neve senator quisquam inusitato et inlicito more tormentis exponeretur. 74 | 75 | Latius iam disseminata licentia onerosus bonis omnibus Caesar nullum post haec adhibens modum orientis latera cuncta vexabat nec honoratis parcens nec urbium primatibus nec plebeiis. 76 | 77 | Haec igitur prima lex amicitiae sanciatur, ut ab amicis honesta petamus, amicorum causa honesta faciamus, ne exspectemus quidem, dum rogemur; studium semper adsit, cunctatio absit; consilium vero dare audeamus libere. Plurimum in amicitia amicorum bene suadentium valeat auctoritas, eaque et adhibeatur ad monendum non modo aperte sed etiam acriter, si res postulabit, et adhibitae pareatur.At nunc si ad aliquem bene nummatum tumentemque ideo honestus advena salutatum introieris, primitus tamquam exoptatus suscipieris et interrogatus multa coactusque mentiri, miraberis numquam antea visus summatem virum tenuem te sic enixius observantem, ut paeniteat ob haec bona tamquam praecipua non vidisse ante decennium Romam. 78 | 79 | Nec piget dicere avide magis hanc insulam populum Romanum invasisse quam iuste. Ptolomaeo enim rege foederato nobis et socio ob aerarii nostri angustias iusso sine ulla culpa proscribi ideoque hausto veneno voluntaria morte deleto et tributaria facta est et velut hostiles eius exuviae classi inpositae in urbem advectae sunt per Catonem, nunc repetetur ordo gestorum. 80 | 81 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 82 | 83 | Iis igitur est difficilius satis facere, qui se Latina scripta dicunt contemnere. in quibus hoc primum est in quo admirer, cur in gravissimis rebus non delectet eos sermo patrius, cum idem fabellas Latinas ad verbum e Graecis expressas non inviti legant. quis enim tam inimicus paene nomini Romano est, qui Ennii Medeam aut Antiopam Pacuvii spernat aut reiciat, quod se isdem Euripidis fabulis delectari dicat, Latinas litteras oderit? 84 | 85 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 86 | 87 | Victus universis caro ferina est lactisque abundans copia qua sustentantur, et herbae multiplices et siquae alites capi per aucupium possint, et plerosque mos vidimus frumenti usum et vini penitus ignorantes. 88 | 89 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 90 | 91 | Altera sententia est, quae definit amicitiam paribus officiis ac voluntatibus. Hoc quidem est nimis exigue et exiliter ad calculos vocare amicitiam, ut par sit ratio acceptorum et datorum. Divitior mihi et affluentior videtur esse vera amicitia nec observare restricte, ne plus reddat quam acceperit; neque enim verendum est, ne quid excidat, aut ne quid in terram defluat, aut ne plus aequo quid in amicitiam congeratur. 92 | 93 | Primi igitur omnium statuuntur Epigonus et Eusebius ob nominum gentilitatem oppressi. praediximus enim Montium sub ipso vivendi termino his vocabulis appellatos fabricarum culpasse tribunos ut adminicula futurae molitioni pollicitos. 94 | 95 | Cum autem commodis intervallata temporibus convivia longa et noxia coeperint apparari vel distributio sollemnium sportularum, anxia deliberatione tractatur an exceptis his quibus vicissitudo debetur, peregrinum invitari conveniet, et si digesto plene consilio id placuerit fieri, is adhibetur qui pro domibus excubat aurigarum aut artem tesserariam profitetur aut secretiora quaedam se nosse confingit. 96 | 97 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 98 | 99 | Quare hoc quidem praeceptum, cuiuscumque est, ad tollendam amicitiam valet; illud potius praecipiendum fuit, ut eam diligentiam adhiberemus in amicitiis comparandis, ut ne quando amare inciperemus eum, quem aliquando odisse possemus. Quin etiam si minus felices in diligendo fuissemus, ferendum id Scipio potius quam inimicitiarum tempus cogitandum putabat. 100 | 101 | Ipsam vero urbem Byzantiorum fuisse refertissimam atque ornatissimam signis quis ignorat? Quae illi, exhausti sumptibus bellisque maximis, cum omnis Mithridaticos impetus totumque Pontum armatum affervescentem in Asiam atque erumpentem, ore repulsum et cervicibus interclusum suis sustinerent, tum, inquam, Byzantii et postea signa illa et reliqua urbis ornanemta sanctissime custodita tenuerunt. 102 | 103 | Quod si rectum statuerimus vel concedere amicis, quidquid velint, vel impetrare ab iis, quidquid velimus, perfecta quidem sapientia si simus, nihil habeat res vitii; sed loquimur de iis amicis qui ante oculos sunt, quos vidimus aut de quibus memoriam accepimus, quos novit vita communis. Ex hoc numero nobis exempla sumenda sunt, et eorum quidem maxime qui ad sapientiam proxime accedunt. 104 | 105 | Martinus agens illas provincias pro praefectis aerumnas innocentium graviter gemens saepeque obsecrans, ut ab omni culpa inmunibus parceretur, cum non inpetraret, minabatur se discessurum: ut saltem id metuens perquisitor malivolus tandem desineret quieti coalitos homines in aperta pericula proiectare. 106 | 107 | Postremo ad id indignitatis est ventum, ut cum peregrini ob formidatam haut ita dudum alimentorum inopiam pellerentur ab urbe praecipites, sectatoribus disciplinarum liberalium inpendio paucis sine respiratione ulla extrusis, tenerentur minimarum adseclae veri, quique id simularunt ad tempus, et tria milia saltatricum ne interpellata quidem cum choris totidemque remanerent magistris. 108 | 109 | Paphius quin etiam et Cornelius senatores, ambo venenorum artibus pravis se polluisse confessi, eodem pronuntiante Maximino sunt interfecti. pari sorte etiam procurator monetae extinctus est. Sericum enim et Asbolium supra dictos, quoniam cum hortaretur passim nominare, quos vellent, adiecta religione firmarat, nullum igni vel ferro se puniri iussurum, plumbi validis ictibus interemit. et post hoe flammis Campensem aruspicem dedit, in negotio eius nullo sacramento constrictus. 110 | 111 | Ob haec et huius modi multa, quae cernebantur in paucis, omnibus timeri sunt coepta. et ne tot malis dissimulatis paulatimque serpentibus acervi crescerent aerumnarum, nobilitatis decreto legati mittuntur: Praetextatus ex urbi praefecto et ex vicario Venustus et ex consulari Minervius oraturi, ne delictis supplicia sint grandiora, neve senator quisquam inusitato et inlicito more tormentis exponeretur. 112 | 113 | Latius iam disseminata licentia onerosus bonis omnibus Caesar nullum post haec adhibens modum orientis latera cuncta vexabat nec honoratis parcens nec urbium primatibus nec plebeiis. 114 | 115 | Haec igitur prima lex amicitiae sanciatur, ut ab amicis honesta petamus, amicorum causa honesta faciamus, ne exspectemus quidem, dum rogemur; studium semper adsit, cunctatio absit; consilium vero dare audeamus libere. Plurimum in amicitia amicorum bene suadentium valeat auctoritas, eaque et adhibeatur ad monendum non modo aperte sed etiam acriter, si res postulabit, et adhibitae pareatur.At nunc si ad aliquem bene nummatum tumentemque ideo honestus advena salutatum introieris, primitus tamquam exoptatus suscipieris et interrogatus multa coactusque mentiri, miraberis numquam antea visus summatem virum tenuem te sic enixius observantem, ut paeniteat ob haec bona tamquam praecipua non vidisse ante decennium Romam. 116 | 117 | Nec piget dicere avide magis hanc insulam populum Romanum invasisse quam iuste. Ptolomaeo enim rege foederato nobis et socio ob aerarii nostri angustias iusso sine ulla culpa proscribi ideoque hausto veneno voluntaria morte deleto et tributaria facta est et velut hostiles eius exuviae classi inpositae in urbem advectae sunt per Catonem, nunc repetetur ordo gestorum. 118 | 119 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 120 | 121 | Iis igitur est difficilius satis facere, qui se Latina scripta dicunt contemnere. in quibus hoc primum est in quo admirer, cur in gravissimis rebus non delectet eos sermo patrius, cum idem fabellas Latinas ad verbum e Graecis expressas non inviti legant. quis enim tam inimicus paene nomini Romano est, qui Ennii Medeam aut Antiopam Pacuvii spernat aut reiciat, quod se isdem Euripidis fabulis delectari dicat, Latinas litteras oderit? 122 | 123 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 124 | 125 | Victus universis caro ferina est lactisque abundans copia qua sustentantur, et herbae multiplices et siquae alites capi per aucupium possint, et plerosque mos vidimus frumenti usum et vini penitus ignorantes. 126 | 127 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 128 | 129 | Altera sententia est, quae definit amicitiam paribus officiis ac voluntatibus. Hoc quidem est nimis exigue et exiliter ad calculos vocare amicitiam, ut par sit ratio acceptorum et datorum. Divitior mihi et affluentior videtur esse vera amicitia nec observare restricte, ne plus reddat quam acceperit; neque enim verendum est, ne quid excidat, aut ne quid in terram defluat, aut ne plus aequo quid in amicitiam congeratur. 130 | 131 | Primi igitur omnium statuuntur Epigonus et Eusebius ob nominum gentilitatem oppressi. praediximus enim Montium sub ipso vivendi termino his vocabulis appellatos fabricarum culpasse tribunos ut adminicula futurae molitioni pollicitos. 132 | 133 | Cum autem commodis intervallata temporibus convivia longa et noxia coeperint apparari vel distributio sollemnium sportularum, anxia deliberatione tractatur an exceptis his quibus vicissitudo debetur, peregrinum invitari conveniet, et si digesto plene consilio id placuerit fieri, is adhibetur qui pro domibus excubat aurigarum aut artem tesserariam profitetur aut secretiora quaedam se nosse confingit. 134 | 135 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 136 | 137 | Quare hoc quidem praeceptum, cuiuscumque est, ad tollendam amicitiam valet; illud potius praecipiendum fuit, ut eam diligentiam adhiberemus in amicitiis comparandis, ut ne quando amare inciperemus eum, quem aliquando odisse possemus. Quin etiam si minus felices in diligendo fuissemus, ferendum id Scipio potius quam inimicitiarum tempus cogitandum putabat. 138 | 139 | Ipsam vero urbem Byzantiorum fuisse refertissimam atque ornatissimam signis quis ignorat? Quae illi, exhausti sumptibus bellisque maximis, cum omnis Mithridaticos impetus totumque Pontum armatum affervescentem in Asiam atque erumpentem, ore repulsum et cervicibus interclusum suis sustinerent, tum, inquam, Byzantii et postea signa illa et reliqua urbis ornanemta sanctissime custodita tenuerunt. 140 | 141 | Quod si rectum statuerimus vel concedere amicis, quidquid velint, vel impetrare ab iis, quidquid velimus, perfecta quidem sapientia si simus, nihil habeat res vitii; sed loquimur de iis amicis qui ante oculos sunt, quos vidimus aut de quibus memoriam accepimus, quos novit vita communis. Ex hoc numero nobis exempla sumenda sunt, et eorum quidem maxime qui ad sapientiam proxime accedunt. 142 | 143 | Martinus agens illas provincias pro praefectis aerumnas innocentium graviter gemens saepeque obsecrans, ut ab omni culpa inmunibus parceretur, cum non inpetraret, minabatur se discessurum: ut saltem id metuens perquisitor malivolus tandem desineret quieti coalitos homines in aperta pericula proiectare. 144 | 145 | Postremo ad id indignitatis est ventum, ut cum peregrini ob formidatam haut ita dudum alimentorum inopiam pellerentur ab urbe praecipites, sectatoribus disciplinarum liberalium inpendio paucis sine respiratione ulla extrusis, tenerentur minimarum adseclae veri, quique id simularunt ad tempus, et tria milia saltatricum ne interpellata quidem cum choris totidemque remanerent magistris. 146 | 147 | Paphius quin etiam et Cornelius senatores, ambo venenorum artibus pravis se polluisse confessi, eodem pronuntiante Maximino sunt interfecti. pari sorte etiam procurator monetae extinctus est. Sericum enim et Asbolium supra dictos, quoniam cum hortaretur passim nominare, quos vellent, adiecta religione firmarat, nullum igni vel ferro se puniri iussurum, plumbi validis ictibus interemit. et post hoe flammis Campensem aruspicem dedit, in negotio eius nullo sacramento constrictus. 148 | 149 | Ob haec et huius modi multa, quae cernebantur in paucis, omnibus timeri sunt coepta. et ne tot malis dissimulatis paulatimque serpentibus acervi crescerent aerumnarum, nobilitatis decreto legati mittuntur: Praetextatus ex urbi praefecto et ex vicario Venustus et ex consulari Minervius oraturi, ne delictis supplicia sint grandiora, neve senator quisquam inusitato et inlicito more tormentis exponeretur. 150 | 151 | Latius iam disseminata licentia onerosus bonis omnibus Caesar nullum post haec adhibens modum orientis latera cuncta vexabat nec honoratis parcens nec urbium primatibus nec plebeiis. 152 | 153 | Haec igitur prima lex amicitiae sanciatur, ut ab amicis honesta petamus, amicorum causa honesta faciamus, ne exspectemus quidem, dum rogemur; studium semper adsit, cunctatio absit; consilium vero dare audeamus libere. Plurimum in amicitia amicorum bene suadentium valeat auctoritas, eaque et adhibeatur ad monendum non modo aperte sed etiam acriter, si res postulabit, et adhibitae pareatur.At nunc si ad aliquem bene nummatum tumentemque ideo honestus advena salutatum introieris, primitus tamquam exoptatus suscipieris et interrogatus multa coactusque mentiri, miraberis numquam antea visus summatem virum tenuem te sic enixius observantem, ut paeniteat ob haec bona tamquam praecipua non vidisse ante decennium Romam. 154 | 155 | Nec piget dicere avide magis hanc insulam populum Romanum invasisse quam iuste. Ptolomaeo enim rege foederato nobis et socio ob aerarii nostri angustias iusso sine ulla culpa proscribi ideoque hausto veneno voluntaria morte deleto et tributaria facta est et velut hostiles eius exuviae classi inpositae in urbem advectae sunt per Catonem, nunc repetetur ordo gestorum. 156 | 157 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 158 | 159 | Iis igitur est difficilius satis facere, qui se Latina scripta dicunt contemnere. in quibus hoc primum est in quo admirer, cur in gravissimis rebus non delectet eos sermo patrius, cum idem fabellas Latinas ad verbum e Graecis expressas non inviti legant. quis enim tam inimicus paene nomini Romano est, qui Ennii Medeam aut Antiopam Pacuvii spernat aut reiciat, quod se isdem Euripidis fabulis delectari dicat, Latinas litteras oderit? 160 | 161 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 162 | 163 | Victus universis caro ferina est lactisque abundans copia qua sustentantur, et herbae multiplices et siquae alites capi per aucupium possint, et plerosque mos vidimus frumenti usum et vini penitus ignorantes. 164 | 165 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 166 | 167 | Altera sententia est, quae definit amicitiam paribus officiis ac voluntatibus. Hoc quidem est nimis exigue et exiliter ad calculos vocare amicitiam, ut par sit ratio acceptorum et datorum. Divitior mihi et affluentior videtur esse vera amicitia nec observare restricte, ne plus reddat quam acceperit; neque enim verendum est, ne quid excidat, aut ne quid in terram defluat, aut ne plus aequo quid in amicitiam congeratur. 168 | 169 | Primi igitur omnium statuuntur Epigonus et Eusebius ob nominum gentilitatem oppressi. praediximus enim Montium sub ipso vivendi termino his vocabulis appellatos fabricarum culpasse tribunos ut adminicula futurae molitioni pollicitos. 170 | 171 | Cum autem commodis intervallata temporibus convivia longa et noxia coeperint apparari vel distributio sollemnium sportularum, anxia deliberatione tractatur an exceptis his quibus vicissitudo debetur, peregrinum invitari conveniet, et si digesto plene consilio id placuerit fieri, is adhibetur qui pro domibus excubat aurigarum aut artem tesserariam profitetur aut secretiora quaedam se nosse confingit. 172 | 173 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 174 | 175 | Quare hoc quidem praeceptum, cuiuscumque est, ad tollendam amicitiam valet; illud potius praecipiendum fuit, ut eam diligentiam adhiberemus in amicitiis comparandis, ut ne quando amare inciperemus eum, quem aliquando odisse possemus. Quin etiam si minus felices in diligendo fuissemus, ferendum id Scipio potius quam inimicitiarum tempus cogitandum putabat. 176 | 177 | Ipsam vero urbem Byzantiorum fuisse refertissimam atque ornatissimam signis quis ignorat? Quae illi, exhausti sumptibus bellisque maximis, cum omnis Mithridaticos impetus totumque Pontum armatum affervescentem in Asiam atque erumpentem, ore repulsum et cervicibus interclusum suis sustinerent, tum, inquam, Byzantii et postea signa illa et reliqua urbis ornanemta sanctissime custodita tenuerunt. 178 | 179 | Quod si rectum statuerimus vel concedere amicis, quidquid velint, vel impetrare ab iis, quidquid velimus, perfecta quidem sapientia si simus, nihil habeat res vitii; sed loquimur de iis amicis qui ante oculos sunt, quos vidimus aut de quibus memoriam accepimus, quos novit vita communis. Ex hoc numero nobis exempla sumenda sunt, et eorum quidem maxime qui ad sapientiam proxime accedunt. 180 | 181 | Martinus agens illas provincias pro praefectis aerumnas innocentium graviter gemens saepeque obsecrans, ut ab omni culpa inmunibus parceretur, cum non inpetraret, minabatur se discessurum: ut saltem id metuens perquisitor malivolus tandem desineret quieti coalitos homines in aperta pericula proiectare. 182 | 183 | Postremo ad id indignitatis est ventum, ut cum peregrini ob formidatam haut ita dudum alimentorum inopiam pellerentur ab urbe praecipites, sectatoribus disciplinarum liberalium inpendio paucis sine respiratione ulla extrusis, tenerentur minimarum adseclae veri, quique id simularunt ad tempus, et tria milia saltatricum ne interpellata quidem cum choris totidemque remanerent magistris. 184 | 185 | Paphius quin etiam et Cornelius senatores, ambo venenorum artibus pravis se polluisse confessi, eodem pronuntiante Maximino sunt interfecti. pari sorte etiam procurator monetae extinctus est. Sericum enim et Asbolium supra dictos, quoniam cum hortaretur passim nominare, quos vellent, adiecta religione firmarat, nullum igni vel ferro se puniri iussurum, plumbi validis ictibus interemit. et post hoe flammis Campensem aruspicem dedit, in negotio eius nullo sacramento constrictus. 186 | 187 | Ob haec et huius modi multa, quae cernebantur in paucis, omnibus timeri sunt coepta. et ne tot malis dissimulatis paulatimque serpentibus acervi crescerent aerumnarum, nobilitatis decreto legati mittuntur: Praetextatus ex urbi praefecto et ex vicario Venustus et ex consulari Minervius oraturi, ne delictis supplicia sint grandiora, neve senator quisquam inusitato et inlicito more tormentis exponeretur. 188 | 189 | Latius iam disseminata licentia onerosus bonis omnibus Caesar nullum post haec adhibens modum orientis latera cuncta vexabat nec honoratis parcens nec urbium primatibus nec plebeiis. 190 | 191 | Haec igitur prima lex amicitiae sanciatur, ut ab amicis honesta petamus, amicorum causa honesta faciamus, ne exspectemus quidem, dum rogemur; studium semper adsit, cunctatio absit; consilium vero dare audeamus libere. Plurimum in amicitia amicorum bene suadentium valeat auctoritas, eaque et adhibeatur ad monendum non modo aperte sed etiam acriter, si res postulabit, et adhibitae pareatur.At nunc si ad aliquem bene nummatum tumentemque ideo honestus advena salutatum introieris, primitus tamquam exoptatus suscipieris et interrogatus multa coactusque mentiri, miraberis numquam antea visus summatem virum tenuem te sic enixius observantem, ut paeniteat ob haec bona tamquam praecipua non vidisse ante decennium Romam. 192 | 193 | Nec piget dicere avide magis hanc insulam populum Romanum invasisse quam iuste. Ptolomaeo enim rege foederato nobis et socio ob aerarii nostri angustias iusso sine ulla culpa proscribi ideoque hausto veneno voluntaria morte deleto et tributaria facta est et velut hostiles eius exuviae classi inpositae in urbem advectae sunt per Catonem, nunc repetetur ordo gestorum. 194 | 195 | Sed maximum est in amicitia parem esse inferiori. Saepe enim excellentiae quaedam sunt, qualis erat Scipionis in nostro, ut ita dicam, grege. Numquam se ille Philo, numquam Rupilio, numquam Mummio anteposuit, numquam inferioris ordinis amicis, Q. vero Maximum fratrem, egregium virum omnino, sibi nequaquam parem, quod is anteibat aetate, tamquam superiorem colebat suosque omnes per se posse esse ampliores volebat. 196 | 197 | Iis igitur est difficilius satis facere, qui se Latina scripta dicunt contemnere. in quibus hoc primum est in quo admirer, cur in gravissimis rebus non delectet eos sermo patrius, cum idem fabellas Latinas ad verbum e Graecis expressas non inviti legant. quis enim tam inimicus paene nomini Romano est, qui Ennii Medeam aut Antiopam Pacuvii spernat aut reiciat, quod se isdem Euripidis fabulis delectari dicat, Latinas litteras oderit? 198 | 199 | Omitto iuris dictionem in libera civitate contra leges senatusque consulta; caedes relinquo; libidines praetereo, quarum acerbissimum extat indicium et ad insignem memoriam turpitudinis et paene ad iustum odium imperii nostri, quod constat nobilissimas virgines se in puteos abiecisse et morte voluntaria necessariam turpitudinem depulisse. Nec haec idcirco omitto, quod non gravissima sint, sed quia nunc sine teste dico. 200 | --------------------------------------------------------------------------------