From adc352048798c578947d25649adc2ee504d37e68 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Tue, 3 Nov 2015 13:01:32 +0300 Subject: [PATCH 01/15] Move flow compiler to the tree --- MS5/{dna-compiler/Step.hs => dna-flow/Flow/DnaCompiler.hs} | 0 MS5/ms5.cabal | 4 ++-- 2 files changed, 2 insertions(+), 2 deletions(-) rename MS5/{dna-compiler/Step.hs => dna-flow/Flow/DnaCompiler.hs} (100%) diff --git a/MS5/dna-compiler/Step.hs b/MS5/dna-flow/Flow/DnaCompiler.hs similarity index 100% rename from MS5/dna-compiler/Step.hs rename to MS5/dna-flow/Flow/DnaCompiler.hs diff --git a/MS5/ms5.cabal b/MS5/ms5.cabal index 7548e295..e7db9660 100644 --- a/MS5/ms5.cabal +++ b/MS5/ms5.cabal @@ -34,7 +34,7 @@ executable dotproduct kernel/cpu/dotproduct/generate_g.cpp kernel/cpu/dotproduct/dotp.cpp kernel/cpu/dotproduct/sum.cpp - x-halide-options: -Wall -fno-strict-aliasing -std=c++0x -lm -lstdc++ -lHalide + x-halide-options: -Wall -fno-strict-aliasing -std=c++0x -lm -lstdc++ -lHalide -lLLVM-3.6 executable imaging default-language: Haskell2010 @@ -58,4 +58,4 @@ executable gridding x-halide-sources: kernel/cpu/gridding/scatter.cpp kernel/cpu/gridding/init.cpp kernel/cpu/gridding/fft.cpp - x-halide-options: -Wall -fno-strict-aliasing -std=c++11 -lm -lpthread -lstdc++ -lHalide + x-halide-options: -Wall -fno-strict-aliasing -std=c++11 -lm -lpthread -lstdc++ -lHalide -lLLVM-3.6 From d0f96c814d4856b568917fb1826db4fd4fa1b1fa Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 4 Nov 2015 14:54:19 +0300 Subject: [PATCH 02/15] Update compiler --- MS5/dna-flow/Flow/DnaCompiler.hs | 76 +++++++++++++++++++++++++------- 1 file changed, 61 insertions(+), 15 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index 7a827423..6e9f9795 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} @@ -5,7 +6,7 @@ {-# LANGUAGE LambdaCase #-} -- | -- Compilation @[Step] → AST@ -module Step where +module Flow.DnaCompiler where import Control.Applicative import Control.Monad @@ -13,6 +14,8 @@ import qualified Data.HashMap.Strict as HM import Data.Foldable (Foldable) import Data.Traversable (Traversable) import Bound +import Prelude.Extras +import GHC.Generics (Generic) import Flow import Flow.Internal @@ -26,11 +29,12 @@ data StepE a = V a -- ^ Untyped variable | Pair (StepE a) (StepE a) - -- ^ 2-tuple + -- ^ 2-tuple. At the moment pair of kernel-region box] + | List [StepE a] -- ^ List of variables - | SDom (IO Domain) + | SDom NewRegion -- ^ Create domain | SKern KernelBind [StepE a] [StepE a] -- ^ Kernel call @@ -38,18 +42,42 @@ data StepE a -- * Kernel description -- * Parameters -- * Output domain + | SSplit (StepE a) RegSplit (StepE a) + -- Split command + -- + -- * Domain + -- * Split function + -- * Subexpression + | SDistribute (StepE a) (StepE a) + -- * Domain + -- * Steps + | SSeq (StepE a) (StepE a) + -- ^ Sequence two monadic actions | SBind (StepE a) (Scope () StepE a) -- ^ Monadic bind. We only introduce new variables in monadic context. - deriving (Functor,Foldable,Traversable) + deriving (Show,Functor,Foldable,Traversable,Generic) +instance Show1 StepE + +-- | Newtype wrapper for function for splitting regions. Only used to +-- get free Show instance for StepE +newtype RegSplit = RegSplit (Region -> IO [Region]) +newtype NewRegion = NewRegion (IO Region) + +instance Show RegSplit where + show _ = "RegSplit" +instance Show NewRegion where + show _ = "NewRegion" -- | Variable name data V = KernVar Int + -- ^ @Vector ()@ produced by kernel. It's referenced by KernelID | DomVar Int + -- ^ Region (referenced by DomainID) deriving (Show,Eq) instance Applicative StepE where - pure = return + pure = V (<*>) = ap instance Monad StepE where return = V @@ -57,6 +85,7 @@ instance Monad StepE where Pair a b >>= f = Pair (a >>= f) (b >>= f) List xs >>= f = List (map (>>= f) xs) SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) + SSeq a b >>= f = SSeq (a >>= f) (b >>= f) SBind e g >>= f = SBind (e >>= f) (g >>>= f) @@ -64,6 +93,12 @@ instance Monad StepE where -- Compilation to expression tree ---------------------------------------------------------------- +{- +data AnyDH = forall a. Typeable a => AnyDH (Domain a) +type DataMap = IM.IntMap (ReprI, Map.Map RegionBox (Vector ())) +type DomainMap = IM.IntMap (AnyDH, RegionBox) +-} + compileSteps :: [Step] -> StepE V compileSteps [] = error "compileSteps: empty list" compileSteps [x] = fst $ singleStep x @@ -74,12 +109,19 @@ compileSteps (x:xs) = singleStep :: Step -> (StepE V, V) singleStep = \case - DomainStep dh -> (SDom (dhCreate dh), DomVar (dhId dh)) - KernelStep kb -> ( SKern kb - [ Pair (V $ KernVar i) (List $ V . DomVar <$> ds) - | (i,ds) <- kernDeps kb ] - (kbDomList kb) - , KernVar (kernId kb)) + DomainStep dh -> ( SDom (NewRegion $ dhCreate dh) + , DomVar (dhId dh)) + KernelStep kb -> + ( SKern kb + -- Parameters + [ Pair (V $ KernVar kid) + (List $ V . DomVar <$> reprDomain repr) + | KernelDep kid (ReprI repr) <- kernDeps kb + ] + -- Output domains + (kbDomList kb) + , KernVar (kernId kb) + ) DistributeStep{} -> error "DistributeStep is not supported" SplitStep{} -> error "SplitStep is not supported" where @@ -92,9 +134,10 @@ singleStep = \case ---------------------------------------------------------------- data Box - = VDom Domain + = VReg RegionBox | VVec (Vector ()) +{- interpretAST :: StepE V -> DNA Box interpretAST e = case closed e of Just e' -> go e' @@ -103,14 +146,15 @@ interpretAST e = case closed e of go = \case V{} -> error "Naked variable at the top level" Pair{} -> error "Naked pair at the top level" - List{} -> error "Naked list at the top level" + -- List{} -> error "Naked list at the top level" -- Create new domain SDom dom -> - DNA.kernel "dom" [] $ liftIO $ VDom <$> dom + DNA.kernel "dom" [] $ liftIO $ VReg <$> dom -- Call kernel + {- SKern kb deps dom -> let toDom = \case - V (VDom d) -> d + V (VReg d) -> d V (VVec _) -> error "Vector where domain expected" _ -> error "Only variables expected" toParam = \case @@ -119,8 +163,10 @@ interpretAST e = case closed e of xs = map toParam deps out = map toDom dom in DNA.kernel "kern" [] $ liftIO $ VVec <$> kernCode kb xs out +-} -- Monadic bind SBind expr lam -> let dnaE = go expr lamE = \a -> go $ instantiate1 (V a) lam in dnaE >>= lamE +-} From b8b613ff9053224f1f9782a603c4c668f88a5b87 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 4 Nov 2015 15:00:34 +0300 Subject: [PATCH 03/15] Add compiler to cabal file --- MS5/dna-flow/dna-flow.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/MS5/dna-flow/dna-flow.cabal b/MS5/dna-flow/dna-flow.cabal index d28ccf6b..9b59d619 100644 --- a/MS5/dna-flow/dna-flow.cabal +++ b/MS5/dna-flow/dna-flow.cabal @@ -30,6 +30,8 @@ library bytestring >= 0.10, time, fixed-vector-hetero >= 0.2, + bound >= 1.0.6, + prelude-extras >= 0.4, dna >= 0.5 Exposed-modules: Flow, Flow.Builder, @@ -38,6 +40,7 @@ library Flow.Domain, Flow.Vector, Flow.Halide.Types + Flow.DnaCompiler Flow.Internal, Flow.Halide, Flow.Halide.BufferT, From 773c712bdbcd60ea9a18a634a6284ac0ef40c727 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 4 Nov 2015 15:39:18 +0300 Subject: [PATCH 04/15] Add example program --- MS5/ms5.cabal | 17 +++++ MS5/programs/dotproduct-dna.hs | 114 +++++++++++++++++++++++++++++++++ 2 files changed, 131 insertions(+) create mode 100644 MS5/programs/dotproduct-dna.hs diff --git a/MS5/ms5.cabal b/MS5/ms5.cabal index e7db9660..b6ffb10d 100644 --- a/MS5/ms5.cabal +++ b/MS5/ms5.cabal @@ -36,6 +36,23 @@ executable dotproduct kernel/cpu/dotproduct/sum.cpp x-halide-options: -Wall -fno-strict-aliasing -std=c++0x -lm -lstdc++ -lHalide -lLLVM-3.6 +executable dotproduct-dna + default-language: Haskell2010 + ghc-options: -O2 -Wall -threaded -rtsopts + Hs-source-dirs: programs + main-is: dotproduct-dna.hs + build-depends: + base >= 4.6, + dna-flow >= 0.5, + groom, + dna, + fixed-vector-hetero + x-halide-sources: kernel/cpu/dotproduct/generate_f.cpp + kernel/cpu/dotproduct/generate_g.cpp + kernel/cpu/dotproduct/dotp.cpp + kernel/cpu/dotproduct/sum.cpp + x-halide-options: -Wall -fno-strict-aliasing -std=c++0x -lm -lstdc++ -lHalide -lLLVM-3.6 + executable imaging default-language: Haskell2010 ghc-options: -O2 -Wall diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs new file mode 100644 index 00000000..9c930a2b --- /dev/null +++ b/MS5/programs/dotproduct-dna.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Data.Typeable + +import Control.Monad +import Flow +import Flow.Vector +import Flow.Halide +import Text.Groom +-- import DNA (dnaRun) + +-- Needed for FFI to work +import Data.Vector.HFixed.Class () +import Flow.Halide.Types () +import Flow.DnaCompiler + +-- Data tags +data Vec deriving Typeable +data Sum deriving Typeable + +-- Abstract flow signatures +f, g :: Flow Vec +f = flow "f" +g = flow "g" +pp :: Flow Vec -> Flow Vec -> Flow Vec +pp = flow "product" +a :: Flow Vec -> Flow Sum +a = flow "sum" +ddp :: Flow Sum +ddp = a $ pp f g + +-- Vector representation +type VecRepr = DynHalideRepr Dim0 Float Vec +vecRepr :: Domain Range -> VecRepr +vecRepr = dynHalideRepr dim0 +type SumRepr = HalideRepr Z Float Sum +sumRepr :: SumRepr +sumRepr = halideRepr Z + +-- Kernels + +fKern :: Domain Range -> Kernel Vec +fKern size = halideKernel0 "f" (vecRepr size) kern_generate_f +foreign import ccall unsafe kern_generate_f :: HalideFun '[] VecRepr + +gKern :: Domain Range -> Kernel Vec +gKern size = halideKernel0 "g" (vecRepr size) kern_generate_g +foreign import ccall unsafe kern_generate_g :: HalideFun '[] VecRepr + +ppKern :: Domain Range -> Flow Vec -> Flow Vec -> Kernel Vec +ppKern size = halideKernel1Write "pp" (vecRepr size) (vecRepr size) kern_dotp +foreign import ccall unsafe kern_dotp :: HalideFun '[ VecRepr ] VecRepr + +aKern :: Domain Range -> Flow Vec -> Kernel Sum +aKern size = halideKernel1 "a" (vecRepr size) sumRepr kern_sum +foreign import ccall unsafe kern_sum :: HalideFun '[ VecRepr ] SumRepr + +printKern :: Flow Sum -> Kernel Sum +printKern = kernel "print" (sumRepr :. Z) NoRepr $ \case + [(sv,_)]-> \_ -> do + s <- peekVector (castVector sv :: Vector Float) 0 + putStrLn $ "Sum: " ++ show s + return nullVector + _other -> fail "printKern: Received wrong number of input buffers!" + +-- | Dot product, non-distributed +dpStrat :: Int -> Strategy () +dpStrat size = do + + -- Make vector domain + dom <- makeRangeDomain 0 size + + -- Calculate ddp for the whole domain + bind f (fKern dom) + bind g (gKern dom) + bindRule pp (ppKern dom) + bindRule a (aKern dom) + calculate ddp + rebind ddp printKern + +-- | Dot product, distributed +ddpStrat :: Int -> Strategy () +ddpStrat size = do + + -- Make vector domain + dom <- makeRangeDomain 0 size + + -- Calculate ddp for the whole domain + split dom 10 $ \regs -> + distribute regs ParSchedule $ do + bind f (fKern regs) + bind g (gKern regs) + bind (pp f g) (ppKern regs f g) + bindRule a (aKern dom) + calculate ddp + void $ bindNew $ printKern ddp + +main :: IO () +main = do + let size = 1000000 + strat = dpStrat size + dumpSteps $ dpStrat size + putStrLn "----------------------------------------------------------------" + let ast = compileSteps $ runStrategy strat + putStrLn $ groom ast + -- dnaRun id $ do + -- interpretAST $ + -- return () + -- putStrLn $ "Expected: " ++ show ((size-1)*size`div`20) From eb10b00fad078644135f9b272131d780985c2a94 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 4 Nov 2015 16:15:14 +0300 Subject: [PATCH 05/15] Add pretty-printing of AST --- MS5/ms5.cabal | 4 ++- MS5/programs/dotproduct-dna.hs | 49 ++++++++++++++++++++++++++++++---- 2 files changed, 47 insertions(+), 6 deletions(-) diff --git a/MS5/ms5.cabal b/MS5/ms5.cabal index b6ffb10d..8340542e 100644 --- a/MS5/ms5.cabal +++ b/MS5/ms5.cabal @@ -44,7 +44,9 @@ executable dotproduct-dna build-depends: base >= 4.6, dna-flow >= 0.5, - groom, + mtl, + bound, + pretty, dna, fixed-vector-hetero x-halide-sources: kernel/cpu/dotproduct/generate_f.cpp diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 9c930a2b..8666a5e7 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} module Main where import Data.Typeable import Control.Monad +import Control.Monad.State +import Data.List import Flow import Flow.Vector import Flow.Halide -import Text.Groom +import Text.PrettyPrint -- import DNA (dnaRun) -- Needed for FFI to work import Data.Vector.HFixed.Class () import Flow.Halide.Types () import Flow.DnaCompiler +import Bound -- Data tags data Vec deriving Typeable @@ -100,6 +104,40 @@ ddpStrat size = do calculate ddp void $ bindNew $ printKern ddp +prettyprint :: Show a => StepE a -> Doc +prettyprint = flip evalState varNames . ppr . fmap Right + where + varNames = map (:[]) ['a' .. 'z'] + pprList es = do ss <- mapM ppr es + return $ brackets $ hcat $ intersperse comma ss + ppr = \case + V (Left v) -> return $ text v + V (Right a) -> return $ text (show a) + Pair e g -> do se <- ppr e + sg <- ppr g + return $ parens $ se <> comma <> sg + List es -> pprList es + SDom r -> return $ text $ show r + SKern kb vars dom -> do + vs <- pprList vars + ds <- pprList dom + return $ text "Kernel call" $$ nest 2 + (vcat [ text (show kb), vs, ds ]) + SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) + SBind e lam -> do + -- Get fresh var + (v : rest) <- get + put rest + -- + se <- ppr e + sl <- ppr $ instantiate1 (V $ Left v) lam + return $ vcat + [ se <> text (" $ λ"++v++" →") + , nest 2 sl + ] + + + main :: IO () main = do let size = 1000000 @@ -107,7 +145,8 @@ main = do dumpSteps $ dpStrat size putStrLn "----------------------------------------------------------------" let ast = compileSteps $ runStrategy strat - putStrLn $ groom ast + putStrLn $ render $ prettyprint ast + -- putStrLn $ groom ast -- dnaRun id $ do -- interpretAST $ -- return () From 44d865862039213babbb18dde7dd3b73df2659e2 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 4 Nov 2015 17:08:27 +0300 Subject: [PATCH 06/15] Complete pretty printer --- MS5/programs/dotproduct-dna.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 8666a5e7..6ee881c6 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -117,13 +117,21 @@ prettyprint = flip evalState varNames . ppr . fmap Right sg <- ppr g return $ parens $ se <> comma <> sg List es -> pprList es - SDom r -> return $ text $ show r + SDom i r -> return $ text (show r) <> text " " <> int i SKern kb vars dom -> do vs <- pprList vars ds <- pprList dom return $ text "Kernel call" $$ nest 2 (vcat [ text (show kb), vs, ds ]) SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) + SSplit e _ steps -> do + se <- ppr e + ss <- ppr steps + return $ (text "Split " <> se) $$ nest 2 ss + SDistribute e steps -> do + se <- ppr e + ss <- ppr steps + return $ (text "Distribute " <> se) $$ nest 2 ss SBind e lam -> do -- Get fresh var (v : rest) <- get From 15c02a9dbb4b67f91a4184d1b85e0c71cbd12237 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 4 Nov 2015 17:18:29 +0300 Subject: [PATCH 07/15] Convert all Step constructs to AST --- MS5/dna-flow/Flow/DnaCompiler.hs | 74 ++++++++++++++++++++------------ MS5/programs/dotproduct-dna.hs | 3 +- 2 files changed, 49 insertions(+), 28 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index 6e9f9795..fa267e46 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -34,7 +34,7 @@ data StepE a | List [StepE a] -- ^ List of variables - | SDom NewRegion + | SDom Int NewRegion -- ^ Create domain | SKern KernelBind [StepE a] [StepE a] -- ^ Kernel call @@ -81,12 +81,14 @@ instance Applicative StepE where (<*>) = ap instance Monad StepE where return = V - V a >>= f = f a - Pair a b >>= f = Pair (a >>= f) (b >>= f) - List xs >>= f = List (map (>>= f) xs) - SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) - SSeq a b >>= f = SSeq (a >>= f) (b >>= f) - SBind e g >>= f = SBind (e >>= f) (g >>>= f) + V a >>= f = f a + Pair a b >>= f = Pair (a >>= f) (b >>= f) + List xs >>= f = List (map (>>= f) xs) + SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) + SSplit a r ss >>= f = SSplit (a >>= f) r (ss >>= f) + SDistribute a ss >>= f = SDistribute (a >>= f) (ss >>= f) + SSeq a b >>= f = SSeq (a >>= f) (b >>= f) + SBind e g >>= f = SBind (e >>= f) (g >>>= f) ---------------------------------------------------------------- @@ -101,29 +103,47 @@ type DomainMap = IM.IntMap (AnyDH, RegionBox) compileSteps :: [Step] -> StepE V compileSteps [] = error "compileSteps: empty list" -compileSteps [x] = fst $ singleStep x +compileSteps [x] = toStep $ singleStep x compileSteps (x:xs) = - let (expr,v) = singleStep x - rest = compileSteps xs - in expr `SBind` abstract1 v rest + let rest = compileSteps xs + in case singleStep x of + StepVal expr v -> expr `SBind` abstract1 v rest + StepNoVal expr -> expr `SSeq` rest -singleStep :: Step -> (StepE V, V) +data StepRes + = StepVal (StepE V) V + | StepNoVal (StepE V) + +toStep :: StepRes -> StepE V +toStep = \case + StepVal e _ -> e + StepNoVal e -> e + +singleStep :: Step -> StepRes singleStep = \case - DomainStep dh -> ( SDom (NewRegion $ dhCreate dh) - , DomVar (dhId dh)) - KernelStep kb -> - ( SKern kb - -- Parameters - [ Pair (V $ KernVar kid) - (List $ V . DomVar <$> reprDomain repr) - | KernelDep kid (ReprI repr) <- kernDeps kb - ] - -- Output domains - (kbDomList kb) - , KernVar (kernId kb) - ) - DistributeStep{} -> error "DistributeStep is not supported" - SplitStep{} -> error "SplitStep is not supported" + DomainStep dh -> StepVal + (SDom (dhId dh) (NewRegion $ dhCreate dh)) + (DomVar (dhId dh)) + KernelStep kb -> StepVal + (SKern kb + -- Parameters + [ Pair (V $ KernVar kid) + (List $ V . DomVar <$> reprDomain repr) + | KernelDep kid (ReprI repr) <- kernDeps kb + ] + -- Output domains + (kbDomList kb)) + (KernVar (kernId kb)) + DistributeStep dh _ steps -> + StepNoVal $ + SDistribute + (V $ DomVar (dhId dh)) + (compileSteps steps) + SplitStep dh steps -> + StepNoVal $ SSplit + (V $ DomVar (dhId dh)) + (RegSplit $ dhRegion dh) + (compileSteps steps) where kbDomList kb = case kernRepr kb of ReprI r -> V . DomVar <$> reprDomain r diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 6ee881c6..6d0fde72 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -149,7 +149,8 @@ prettyprint = flip evalState varNames . ppr . fmap Right main :: IO () main = do let size = 1000000 - strat = dpStrat size + -- strat = dpStrat size + strat = ddpStrat size dumpSteps $ dpStrat size putStrLn "----------------------------------------------------------------" let ast = compileSteps $ runStrategy strat From 42a01e911b5174824b6a68cca6e11f590d65a18f Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Thu, 5 Nov 2015 13:16:06 +0300 Subject: [PATCH 08/15] Move pretty printer to compiler +1 +1 +1 Prase tree --- MS5/dna-flow/Flow/DnaCompiler.hs | 454 ++++++++++++++++++++++++++++++- MS5/dna-flow/Flow/Run.hs | 30 +- MS5/dna-flow/dna-flow.cabal | 1 + MS5/programs/dotproduct-dna.hs | 112 ++++---- 4 files changed, 525 insertions(+), 72 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index fa267e46..dae8ae75 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} @@ -8,14 +9,24 @@ -- Compilation @[Step] → AST@ module Flow.DnaCompiler where +import Control.Arrow (Arrow(..)) import Control.Applicative import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Writer import qualified Data.HashMap.Strict as HM -import Data.Foldable (Foldable) +import Data.HashMap.Strict ((!)) +import qualified Data.HashSet as HS +import Data.Typeable +import Data.Hashable +import Data.List +import Data.Monoid +import Data.Foldable (Foldable(foldMap),toList) import Data.Traversable (Traversable) import Bound import Prelude.Extras import GHC.Generics (Generic) +import Text.PrettyPrint hiding ((<>)) import Flow import Flow.Internal @@ -36,16 +47,20 @@ data StepE a | SDom Int NewRegion -- ^ Create domain + -- + -- * Domain ID + -- * Action to generate new region. | SKern KernelBind [StepE a] [StepE a] -- ^ Kernel call - -- + -- -- * Kernel description -- * Parameters - -- * Output domain - | SSplit (StepE a) RegSplit (StepE a) + -- * Output domain + | SSplit (StepE a) Int RegSplit (Scope () StepE a) -- Split command -- - -- * Domain + -- * Parent domain + -- * Domain id of domain being split -- * Split function -- * Subexpression | SDistribute (StepE a) (StepE a) @@ -55,9 +70,40 @@ data StepE a -- ^ Sequence two monadic actions | SBind (StepE a) (Scope () StepE a) -- ^ Monadic bind. We only introduce new variables in monadic context. + + | SActorGrp Int [StepE a] + -- ^ Corresponds to group of actor + -- + -- * Actor ID + -- * Input parameters + | SActorRecv + -- ^ Receive data from actors + + + | SYieldVec (StepE a) + -- ^ Yield vector deriving (Show,Functor,Foldable,Traversable,Generic) instance Show1 StepE +{- +-- | Provides foldable instance where we don't go down into +-- split\/distribute combinators +newtype NoNested a = NoNested (StepE a) + +instance Foldable NoNested where + foldMap f (NoNested a) = case a of + V a -> f (NoNested a) + Pair a b -> foldMap f (NoNested a) <> foldMap f (NoNested b) + List xs -> mconcat $ map (foldMap f . NoNested) xs + SDom{} -> mempty + SKern _ xs ys -> mconcat $ map (foldMap f . NoNested) xs ++ map (foldMap f . NoNested) xs + SSplit{} -> mempty + SDistribute{} -> mempty + SSeq a b -> foldMap f (NoNested a) <> foldMap f (NoNested b) + SBind a b -> foldMap f (NoNested a) <> foldMap f (NoNested b) + SYieldVec a -> foldMap f (NoNested a) +-} + -- | Newtype wrapper for function for splitting regions. Only used to -- get free Show instance for StepE newtype RegSplit = RegSplit (Region -> IO [Region]) @@ -74,7 +120,11 @@ data V -- ^ @Vector ()@ produced by kernel. It's referenced by KernelID | DomVar Int -- ^ Region (referenced by DomainID) - deriving (Show,Eq) + | ChanVar Int + deriving (Show,Eq,Generic) + +instance Hashable V + instance Applicative StepE where pure = V @@ -85,10 +135,222 @@ instance Monad StepE where Pair a b >>= f = Pair (a >>= f) (b >>= f) List xs >>= f = List (map (>>= f) xs) SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) - SSplit a r ss >>= f = SSplit (a >>= f) r (ss >>= f) + SSplit a i r ss >>= f = SSplit (a >>= f) i r (ss >>>= f) SDistribute a ss >>= f = SDistribute (a >>= f) (ss >>= f) SSeq a b >>= f = SSeq (a >>= f) (b >>= f) SBind e g >>= f = SBind (e >>= f) (g >>>= f) + SYieldVec e >>= f = SYieldVec (e >>= f) + + +---------------------------------------------------------------- +-- Preprocessing of [Steps] +---------------------------------------------------------------- + + +-- | Tree of actors. +data ActorTree a = ActorTree a (HM.HashMap Int (ActorTree a)) + deriving (Show,Eq,Functor) + +walkActorTree :: b -> (a -> a -> b) -> ActorTree a -> ActorTree b +walkActorTree b f (ActorTree a hm) + = ActorTree b (fmap (go a) hm) + where + go a0 (ActorTree a' hmm) = ActorTree (f a0 a') (fmap (go a') hmm) + + +-- | Variables as used in Step definition +data VV + = KVar Int [Int] + | DVar Int + deriving (Show,Eq,Generic) +instance Hashable VV + +-- | Extended Step data type +data ExtStep where + Step :: Step -> ExtStep + Call :: Typeable a => Domain a -> [VV] -> Int -> ExtStep + -- SplitDistr + -- :: (Typeable a) + -- => Domain a -- From distribute + -- -> Schedule + -- -> [ExtStep] + -- -> ExtStep + Expect :: [VV] -> ExtStep + Yield :: [VV] -> ExtStep + Gather :: [VV] -> ExtStep + +-- | Actor type +data ActorTy + = SimpleActor + | DistrActor Int Int + deriving (Show) + +-- | Variables for actor definition +data Vars = Vars + { varsUsed :: HS.HashSet VV + , varsProd :: HS.HashSet VV + , varsMissing :: HS.HashSet VV + } + deriving (Show) + + +{- + + [Step] + + + + ActorTree $ [ExtStep] × How this actor invoлed + +Actor + = BaseActor + | SplitDistrActor + + + +-} + + + + +-- Compilation algo: +-- +-- 1. Separate actors +-- 2. Find out input and output parameters for actors +-- 3. Insert gather for each use of output +-- 4. Convert to AST + +-- Split off code for DNA actors +makeActorTree :: [Step] -> ActorTree (ActorTy, [ExtStep]) +makeActorTree steps + = flip evalState 0 + $ run + $ fmap ((,) SimpleActor) + $ go steps + where + run :: Monad m => WriterT [(Int, ActorTree a)] m a -> m (ActorTree a) + run m = do (a,pairs) <- runWriterT m + return $ ActorTree a (HM.fromList pairs) + -- + go :: [Step] -> WriterT [(Int, ActorTree (ActorTy, [ExtStep]))] (State Int) [ExtStep] + go [] = return [] + go (x:xs) = do + x' <- case x of + (SplitStep dh [DistributeStep dh' sched ss]) -> do + n <- get + put $! n+1 + let Just pdom = dhParent dh + child <- lift + $ run + $ fmap ((,) (DistrActor (dhId pdom) (dhId dh'))) + $ go ss + tell [(n , child)] + return (Call dh [] n) + _ -> return (Step x) + xs' <- go xs + return $ x' : xs' + +-- Determine inputs and outputs for actors +findInOut :: Functor f => ActorTree (f [ExtStep]) -> ActorTree (f (Vars,[ExtStep])) +findInOut = (fmap . fmap) makeVars + where + makeVars ast = (Vars u p (HS.difference u p),ast) + where + u = foldMap collectReferencedVars ast + p = foldMap collectProducedVars ast + +-- Add explicit data transfer commands +addCommands :: ActorTree (ActorTy, (Vars,[ExtStep])) -> ActorTree (ActorTy, (Vars,[ExtStep])) +addCommands + = fmap (\(_,_,a) -> (a)) + . transform (Vars mempty mempty mempty) + where + -- Parameters: variables defined in parent and missing in child + transform pvars (ActorTree (ty,(vars,steps)) children) + = ActorTree (params,retV,(ty,(vars,steps'''))) children'' + where + -- Parameters for current actor: + -- * Variables generated by parent by not in child. + params = varsProd pvars `HS.intersection` varsMissing vars + -- Return values + -- * Variables missing in parent and produced in child when + -- adjusted for domain + retV = case ty of + SimpleActor -> mempty + DistrActor dhPar dhCh -> + (varsProd vars) + `HS.intersection` + HS.map (changeDom dhPar dhCh) (varsMissing pvars) + + -- Transform child actors recursively + children' = transform vars <$> children + children'' = children' + -- Reference parameter from children + steps' = flip concatMap steps $ \case + Call dh _ i -> let ActorTree (p,rv,_) _ = children' ! i + in [ Call dh (HS.toList p) i + -- FIXME: Here we ignore wrong domain + , Expect $ HS.toList rv + ] + x -> [x] + -- Prepend expect parameters if it isn't done + steps'' | HS.null params = steps' + | otherwise = Expect (HS.toList params) : steps' + -- Append yield + steps''' | HS.null retV = steps'' + | otherwise = steps'' ++ [Yield $ HS.toList retV] + + + +changeDom :: Int -> Int -> VV -> VV +changeDom old new (KVar k ds) = KVar k ((\i -> if i == old then new else i) <$> ds) +changeDom _ _ v = v + + + +-- Collect variables referenced by step +collectReferencedVars :: ExtStep -> HS.HashSet VV +collectReferencedVars = withExtStep collectReferencedVars' + +collectProducedVars :: ExtStep -> HS.HashSet VV +collectProducedVars = withExtStep collectProducedVars' + +withExtStep f = \case + Step s -> f s + Call dh _ _ -> f (SplitStep dh []) + -- SplitDistr dh' sched steps + -- -> (f (DistributeStep dh' sched [])) + -- <> foldMap (withExtStep f) steps + +-- Collect variables referenced by step +collectReferencedVars' :: Step -> HS.HashSet VV +collectReferencedVars' = \case + DomainStep dh -> mempty + KernelStep kb -> HS.fromList $ concat + [ KVar kid (reprDomain repr) + : (DVar <$> reprDomain repr) + | KernelDep kid (ReprI repr) <- kernDeps kb + ] + -- singleton $ KernVar $ kernId kb + SplitStep dh ss -> + let Just parD = dhParent dh + in (HS.singleton $ DVar $ dhId parD) + <> foldMap collectReferencedVars' ss + DistributeStep dh _ ss -> (HS.singleton $ DVar $ dhId dh) + <> foldMap collectReferencedVars' ss + +-- Collect variables produced by step +collectProducedVars' :: Step -> HS.HashSet VV +collectProducedVars' = \case + DomainStep dh -> HS.singleton $ DVar $ dhId dh + KernelStep kb -> case kernRepr kb of + ReprI repr -> HS.singleton $ KVar (kernId kb) (reprDomain repr) + SplitStep dh ss -> (HS.singleton $ DVar $ dhId dh) + <> foldMap collectProducedVars' ss + DistributeStep dh _ ss -> foldMap collectProducedVars' ss + + + ---------------------------------------------------------------- @@ -141,14 +403,130 @@ singleStep = \case (compileSteps steps) SplitStep dh steps -> StepNoVal $ SSplit - (V $ DomVar (dhId dh)) + (V $ DomVar (maybe (error "Domain doesn't have parent") dhId $ dhParent dh)) + (dhId dh) (RegSplit $ dhRegion dh) - (compileSteps steps) + (abstract1 (DomVar (dhId dh)) $ compileSteps steps) where kbDomList kb = case kernRepr kb of ReprI r -> V . DomVar <$> reprDomain r +---------------------------------------------------------------- +-- AST transformations +---------------------------------------------------------------- + +-- Algorithm outline: +-- +-- 1. Separate parallel parts into additional programs: +-- +-- [Step] → ActorTree ([Step + Extra commands]) +-- +-- 2. Determine input/output parameters for commands + + +-- evalAST :: StepV V -> Maybe V +-- evalAST = undefined + +{- +-- | Rewrite AST using given rule until fixed point is reached +rewriteAST :: (StepE V -> Maybe (StepE V)) -> StepE V -> StepE V +rewriteAST rule ast = case loop ast of + Pair a b -> Pair (go a) (go b) + List xs -> List (map go xs) + SKern kb xs ys -> SKern kb (map go xs) (map go ys) + SSplit e did fun lam -> + let var = DomVar did + in SSplit e did fun (abstract1 var $ go $ instantiate1 var lam) + SDistribute a b -> SDistribute (go a) (go b) + SBind expr lam -> undefined + SSeq a b -> SSeq (go a) (go b) + SActorGrp n xs -> SActorGrp n (map go xs) + x -> x + where + -- Rewrite until fixed point is reached + loop a = case rule a of + Just a' -> loop a' + Nothing -> a + -- Recurse down and generate (optionally) value for the AST fragment + go = rewriteAST rule + recur ast' = case ast' of + V v -> (Just v, ast') + Pair a b -> (Nothing, Pair (go a) (go b)) + List xs -> (Nothing, List (map go xs)) + SKern kb xs ys -> ( Just (kernId kb) + , +-} + +addYields :: Eq a => StepE a -> StepE a +addYields ast + = undefined + where + -- 1. + + -- List of free variables + freeVars = nub $ toList ast + -- freeVecs = [ i | KernVar i <- freeVars ] + -- Traverse AST and add yield operations for values yielded + trvDistr x = case x of + -- Go deeper + SSeq a b -> SSeq (trvDistr a) (trvDistr b) + SBind e lam -> SBind (trvDistr e) undefined + -- We only recognize split immediately followed by distribute + SSplit dh did f _ -> -- (SDistribute dd steps) -> + undefined + -- everything else passed unchanged + _ -> x + + + + + + +-- Now we need to find out values which needed to be passed as parameters +-- and received as results +-- +-- 1. Parameter: free var in child and +-- 2. Result: free var in parent, defined in child +-- +-- To that end we build sets of free and defined vars both in child +-- and parent + + +-- We also need to merge vectors for each vector result. To that end +-- we need to pass regions with buffers + + + + + + + + + + + + + +{- + +-- | Generate actor definition for each actor. +-- +-- 1. We nonrecursively replace each split→distribute pair with actor +-- call and generate map of such calls. Input/output parameters are +-- not handled at this stage +separateActors :: StepE V -> (StepE V, HM.Int (StepE V)) +separateActors = undefined + +-- | Get parameters which are needed for an actor +obtainParameters :: StepE V -> ??? +obtainParameters = undefined +-} + + + + + ---------------------------------------------------------------- -- Interpretation ---------------------------------------------------------------- @@ -190,3 +568,59 @@ interpretAST e = case closed e of lamE = \a -> go $ instantiate1 (V a) lam in dnaE >>= lamE -} + + + +---------------------------------------------------------------- +-- Pretty printer +---------------------------------------------------------------- + +-- | Pretty print AST +prettyprint :: Show a => StepE a -> Doc +prettyprint = flip evalState varNames . ppr . fmap Right + where + varNames = map (:[]) ['a' .. 'z'] + pprList es = do ss <- mapM ppr es + return $ brackets $ hcat $ intersperse comma ss + ppr = \case + V (Left v) -> return $ text v + V (Right a) -> return $ text (show a) + Pair e g -> do se <- ppr e + sg <- ppr g + return $ parens $ se <> comma <> sg + List es -> pprList es + SDom i r -> return $ text (show r) <> text " " <> int i + SKern kb vars dom -> do + vs <- pprList vars + ds <- pprList dom + return $ text "Kernel call" $$ nest 2 + (vcat [ text (show kb), vs, ds ]) + SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) + SSplit e i _ steps -> do + v <- fresh + se <- ppr e + ss <- ppr $ instantiate1 (V $ Left v) steps + (v : rest) <- get + put rest + return $ (text "Split: " <> se <> text " to " <> int i <> text " λ " <> text v <> text " →") + $$ nest 2 ss + SDistribute e steps -> do + se <- ppr e + ss <- ppr steps + return $ (text "Distribute " <> se) $$ nest 2 ss + SBind e lam -> do + v <- fresh + se <- ppr e + sl <- ppr $ instantiate1 (V $ Left v) lam + return $ vcat + [ se <> text (" $ λ"++v++" →") + , nest 2 sl + ] + -- + SYieldVec v -> do + s <- ppr v + return $ text "YieldVec " <> s + fresh = do + v : rest <- get + put rest + return v diff --git a/MS5/dna-flow/Flow/Run.hs b/MS5/dna-flow/Flow/Run.hs index 0ec876d4..d57c9c6a 100644 --- a/MS5/dna-flow/Flow/Run.hs +++ b/MS5/dna-flow/Flow/Run.hs @@ -4,6 +4,7 @@ module Flow.Run ( dumpStrategy , dumpStrategyDOT + , dumpStep , dumpSteps , execStrategy ) where @@ -67,22 +68,23 @@ dumpStrategyDOT file strat = do hPutStrLn h "}" hClose h + + +dumpStep ind (DomainStep dh) + = putStrLn $ ind ++ "Domain " ++ show dh +dumpStep ind (SplitStep dh steps) + = do putStrLn $ ind ++ "Split Domain " ++ show (dhId (fromJust $ dhParent dh)) ++ " into " ++ show dh + forM_ steps (dumpStep (" " ++ ind)) +dumpStep ind (KernelStep kb@KernelBind{kernRepr=ReprI rep}) + = putStrLn $ ind ++ "Over " ++ show (reprDomain rep) ++ " run " ++ show kb +dumpStep ind step@(DistributeStep did sched steps) + = do putStrLn $ ind ++ "Distribute " ++ show did ++ " using " ++ show sched ++ + " deps " ++ show (stepKernDeps step) + forM_ steps (dumpStep (" " ++ ind)) + dumpSteps :: Strategy a -> IO () dumpSteps strat = do - - let dump ind (DomainStep dh) - = putStrLn $ ind ++ "Domain " ++ show dh - dump ind (SplitStep dh steps) - = do putStrLn $ ind ++ "Split Domain " ++ show (dhId (fromJust $ dhParent dh)) ++ " into " ++ show dh - forM_ steps (dump (" " ++ ind)) - dump ind (KernelStep kb@KernelBind{kernRepr=ReprI rep}) - = putStrLn $ ind ++ "Over " ++ show (reprDomain rep) ++ " run " ++ show kb - dump ind step@(DistributeStep did sched steps) - = do putStrLn $ ind ++ "Distribute " ++ show did ++ " using " ++ show sched ++ - " deps " ++ show (stepKernDeps step) - forM_ steps (dump (" " ++ ind)) - - forM_ (runStrategy (void strat)) (dump "") + forM_ (runStrategy (void strat)) (dumpStep "") data AnyDH = forall a. Typeable a => AnyDH (Domain a) type DataMap = IM.IntMap (ReprI, Map.Map RegionBox (Vector ())) diff --git a/MS5/dna-flow/dna-flow.cabal b/MS5/dna-flow/dna-flow.cabal index 9b59d619..3c9e20b7 100644 --- a/MS5/dna-flow/dna-flow.cabal +++ b/MS5/dna-flow/dna-flow.cabal @@ -32,6 +32,7 @@ library fixed-vector-hetero >= 0.2, bound >= 1.0.6, prelude-extras >= 0.4, + pretty, dna >= 0.5 Exposed-modules: Flow, Flow.Builder, diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 6d0fde72..801f16a4 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -2,15 +2,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE LambdaCase #-} module Main where import Data.Typeable +import Control.Arrow (Arrow(..)) import Control.Monad import Control.Monad.State import Data.List +import Data.Monoid (Monoid(..)) import Flow import Flow.Vector import Flow.Halide @@ -18,9 +19,13 @@ import Text.PrettyPrint -- import DNA (dnaRun) -- Needed for FFI to work +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS import Data.Vector.HFixed.Class () +import qualified Data.Foldable as T import Flow.Halide.Types () import Flow.DnaCompiler +import Flow.Internal import Bound -- Data tags @@ -104,59 +109,70 @@ ddpStrat size = do calculate ddp void $ bindNew $ printKern ddp -prettyprint :: Show a => StepE a -> Doc -prettyprint = flip evalState varNames . ppr . fmap Right + +dumpES ind (Step s) = dumpStep ind s +dumpES ind (Call dh pars i) = do + putStrLn $ ind ++ "Call " ++ show i ++ " " ++ show pars + dumpStep (ind ++ " ") $ SplitStep dh [] +-- dumpES ind (SplitDistr dh' sched ss) = do +-- dumpStep ind (DistributeStep dh' sched []) +-- mapM_ (dumpES (ind++" ")) ss +dumpES ind (Expect vs) = + putStrLn $ ind ++ "Expect " ++ show vs +dumpES ind (Yield vs) = + putStrLn $ ind ++ "Yield " ++ show vs +dumpES ind (Gather vs) = + putStrLn $ ind ++ "Gather " ++ show vs + + +dumpTreeWith :: (String -> a -> IO ()) -> ActorTree a -> IO () +dumpTreeWith out = go "" where - varNames = map (:[]) ['a' .. 'z'] - pprList es = do ss <- mapM ppr es - return $ brackets $ hcat $ intersperse comma ss - ppr = \case - V (Left v) -> return $ text v - V (Right a) -> return $ text (show a) - Pair e g -> do se <- ppr e - sg <- ppr g - return $ parens $ se <> comma <> sg - List es -> pprList es - SDom i r -> return $ text (show r) <> text " " <> int i - SKern kb vars dom -> do - vs <- pprList vars - ds <- pprList dom - return $ text "Kernel call" $$ nest 2 - (vcat [ text (show kb), vs, ds ]) - SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) - SSplit e _ steps -> do - se <- ppr e - ss <- ppr steps - return $ (text "Split " <> se) $$ nest 2 ss - SDistribute e steps -> do - se <- ppr e - ss <- ppr steps - return $ (text "Distribute " <> se) $$ nest 2 ss - SBind e lam -> do - -- Get fresh var - (v : rest) <- get - put rest - -- - se <- ppr e - sl <- ppr $ instantiate1 (V $ Left v) lam - return $ vcat - [ se <> text (" $ λ"++v++" →") - , nest 2 sl - ] - + go off (ActorTree a m) = do + out off a + let off' = " " ++ off + forM_ (HM.toList m) $ \(i,a') -> do + putStrLn $ off' ++ "[Key=" ++ show i ++ "]" + go off' a' +dumpTree :: Show a => ActorTree a -> IO () +dumpTree = dumpTreeWith (\off a -> putStr off >> print a) + main :: IO () main = do + -- Peter's part let size = 1000000 -- strat = dpStrat size strat = ddpStrat size - dumpSteps $ dpStrat size + steps = runStrategy strat putStrLn "----------------------------------------------------------------" - let ast = compileSteps $ runStrategy strat - putStrLn $ render $ prettyprint ast - -- putStrLn $ groom ast - -- dnaRun id $ do - -- interpretAST $ - -- return () - -- putStrLn $ "Expected: " ++ show ((size-1)*size`div`20) + dumpSteps strat + -- Transformation + let ast0@(ActorTree ss acts) = makeActorTree steps + ast1 = findInOut ast0 + ast2 = addCommands ast1 + putStrLn "\n-- Actor split -------------------------------------------------" + dumpTreeWith (\off -> mapM_ (dumpES off) . snd) ast0 + putStrLn "\n-- Used --------------------------------------------------------" + dumpTree $ fmap (varsUsed . fst . snd) ast1 + putStrLn "-- Produced ----------------------------------------------------" + dumpTree $ fmap (varsProd . fst . snd) ast1 + putStrLn "-- Missing -----------------------------------------------------" + dumpTree $ fmap (varsMissing . fst . snd) ast1 + -- + putStrLn "\n-- Annotated ---------------------------------------------------" + dumpTreeWith (\off -> mapM_ (dumpES (off++"")) . snd . snd) ast2 + -- Find parameters and return values + -- let walk x f (ActorTree v hm) + -- = ActorTree x (fmap (go v) hm) + -- where + -- go a f (ActorTree vv hmm) = ActorTree (f a vv) (fmap (go vv) hmm) + -- return () + -- putStrLn "-- Param - -----------------------------------------------------" + -- let getp vPar vCh = ( varsProd vPar `HS.intersection` varsMissing vCh + -- , varsMissing vPar `HS.intersection` varsProd vCh + -- ) + -- dumpTree $ walkTree (mempty,mempty) getp vars + -- Find out what to pass as parameters + From 2fe2a1877666564ba860a74873b08a65140e47f4 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 13 Nov 2015 15:50:39 +0300 Subject: [PATCH 09/15] Trasformation to DNA AST is mostly complete --- MS5/dna-flow/Flow/DnaCompiler.hs | 656 ++++++++++++++----------------- MS5/programs/dotproduct-dna.hs | 35 +- 2 files changed, 316 insertions(+), 375 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index dae8ae75..eba6ee0a 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} @@ -7,7 +6,31 @@ {-# LANGUAGE LambdaCase #-} -- | -- Compilation @[Step] → AST@ -module Flow.DnaCompiler where +module Flow.DnaCompiler ( + -- * Ext. steps + ActorTree(..) + , walkActorTree + -- ** Extended steps + , VV(..) + , ExtStep(..) + , Vars(..) + -- ** Transformations + , makeActorTree + , findInOut + , addCommands + -- * Compilation to AST for DNA + -- ** AST + , StepE(..) + , RegSplit(..) + , NewRegion(..) + -- ** Compilation + , DnaActor(..) + , V(..) + , compileProgram + -- ** Pretty-printing + , prettyprint + , prettyprintLam + ) where import Control.Arrow (Arrow(..)) import Control.Applicative @@ -22,7 +45,7 @@ import Data.Hashable import Data.List import Data.Monoid import Data.Foldable (Foldable(foldMap),toList) -import Data.Traversable (Traversable) +import Data.Traversable (Traversable(traverse,sequenceA)) import Bound import Prelude.Extras import GHC.Generics (Generic) @@ -34,119 +57,13 @@ import Flow.Vector import DNA --- | --- Untyped expression tree for compiling to DNA -data StepE a - = V a - -- ^ Untyped variable - | Pair (StepE a) (StepE a) - -- ^ 2-tuple. At the moment pair of kernel-region box] - - | List [StepE a] - -- ^ List of variables - - | SDom Int NewRegion - -- ^ Create domain - -- - -- * Domain ID - -- * Action to generate new region. - | SKern KernelBind [StepE a] [StepE a] - -- ^ Kernel call - -- - -- * Kernel description - -- * Parameters - -- * Output domain - | SSplit (StepE a) Int RegSplit (Scope () StepE a) - -- Split command - -- - -- * Parent domain - -- * Domain id of domain being split - -- * Split function - -- * Subexpression - | SDistribute (StepE a) (StepE a) - -- * Domain - -- * Steps - | SSeq (StepE a) (StepE a) - -- ^ Sequence two monadic actions - | SBind (StepE a) (Scope () StepE a) - -- ^ Monadic bind. We only introduce new variables in monadic context. - - | SActorGrp Int [StepE a] - -- ^ Corresponds to group of actor - -- - -- * Actor ID - -- * Input parameters - | SActorRecv - -- ^ Receive data from actors - - - | SYieldVec (StepE a) - -- ^ Yield vector - deriving (Show,Functor,Foldable,Traversable,Generic) -instance Show1 StepE - -{- --- | Provides foldable instance where we don't go down into --- split\/distribute combinators -newtype NoNested a = NoNested (StepE a) - -instance Foldable NoNested where - foldMap f (NoNested a) = case a of - V a -> f (NoNested a) - Pair a b -> foldMap f (NoNested a) <> foldMap f (NoNested b) - List xs -> mconcat $ map (foldMap f . NoNested) xs - SDom{} -> mempty - SKern _ xs ys -> mconcat $ map (foldMap f . NoNested) xs ++ map (foldMap f . NoNested) xs - SSplit{} -> mempty - SDistribute{} -> mempty - SSeq a b -> foldMap f (NoNested a) <> foldMap f (NoNested b) - SBind a b -> foldMap f (NoNested a) <> foldMap f (NoNested b) - SYieldVec a -> foldMap f (NoNested a) --} - --- | Newtype wrapper for function for splitting regions. Only used to --- get free Show instance for StepE -newtype RegSplit = RegSplit (Region -> IO [Region]) -newtype NewRegion = NewRegion (IO Region) - -instance Show RegSplit where - show _ = "RegSplit" -instance Show NewRegion where - show _ = "NewRegion" - --- | Variable name -data V - = KernVar Int - -- ^ @Vector ()@ produced by kernel. It's referenced by KernelID - | DomVar Int - -- ^ Region (referenced by DomainID) - | ChanVar Int - deriving (Show,Eq,Generic) - -instance Hashable V - - -instance Applicative StepE where - pure = V - (<*>) = ap -instance Monad StepE where - return = V - V a >>= f = f a - Pair a b >>= f = Pair (a >>= f) (b >>= f) - List xs >>= f = List (map (>>= f) xs) - SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) - SSplit a i r ss >>= f = SSplit (a >>= f) i r (ss >>>= f) - SDistribute a ss >>= f = SDistribute (a >>= f) (ss >>= f) - SSeq a b >>= f = SSeq (a >>= f) (b >>= f) - SBind e g >>= f = SBind (e >>= f) (g >>>= f) - SYieldVec e >>= f = SYieldVec (e >>= f) - - ---------------------------------------------------------------- -- Preprocessing of [Steps] +-- +-- We separate steps into actor which are in turn converted to +-- DNA expression ---------------------------------------------------------------- - -- | Tree of actors. data ActorTree a = ActorTree a (HM.HashMap Int (ActorTree a)) deriving (Show,Eq,Functor) @@ -157,7 +74,6 @@ walkActorTree b f (ActorTree a hm) where go a0 (ActorTree a' hmm) = ActorTree (f a0 a') (fmap (go a') hmm) - -- | Variables as used in Step definition data VV = KVar Int [Int] @@ -167,52 +83,27 @@ instance Hashable VV -- | Extended Step data type data ExtStep where - Step :: Step -> ExtStep - Call :: Typeable a => Domain a -> [VV] -> Int -> ExtStep - -- SplitDistr - -- :: (Typeable a) - -- => Domain a -- From distribute - -- -> Schedule - -- -> [ExtStep] - -- -> ExtStep - Expect :: [VV] -> ExtStep + Step :: Step -> ExtStep + Call :: Typeable a => Domain a -> [VV] -> Int -> ExtStep + Expect :: Int -> [(Maybe ReprI, VV)] -> ExtStep Yield :: [VV] -> ExtStep - Gather :: [VV] -> ExtStep -- | Actor type data ActorTy = SimpleActor - | DistrActor Int Int + | DistrActor Int Int -- Split/Distribute actor + | DistrVarActor [VV] [VV] -- Split/Distribute actor with variables deriving (Show) -- | Variables for actor definition data Vars = Vars - { varsUsed :: HS.HashSet VV - , varsProd :: HS.HashSet VV - , varsMissing :: HS.HashSet VV + { varsUsed :: HS.HashSet VV -- ^ Variables referenced in actor + , varsProd :: HS.HashSet VV -- ^ Variables defined in actor + , varsMissing :: HS.HashSet VV -- ^ Used variables which are not defined in actor } deriving (Show) -{- - - [Step] - - - - ActorTree $ [ExtStep] × How this actor invoлed - -Actor - = BaseActor - | SplitDistrActor - - - --} - - - - -- Compilation algo: -- -- 1. Separate actors @@ -228,15 +119,17 @@ makeActorTree steps $ fmap ((,) SimpleActor) $ go steps where + -- run :: Monad m => WriterT [(Int, ActorTree a)] m a -> m (ActorTree a) run m = do (a,pairs) <- runWriterT m return $ ActorTree a (HM.fromList pairs) - -- + -- Transform each step go :: [Step] -> WriterT [(Int, ActorTree (ActorTy, [ExtStep]))] (State Int) [ExtStep] go [] = return [] go (x:xs) = do x' <- case x of - (SplitStep dh [DistributeStep dh' sched ss]) -> do + -- + (SplitStep dh [DistributeStep dh' _sched ss]) -> do n <- get put $! n+1 let Just pdom = dhParent dh @@ -246,6 +139,7 @@ makeActorTree steps $ go ss tell [(n , child)] return (Call dh [] n) + -- _ -> return (Step x) xs' <- go xs return $ x' : xs' @@ -262,12 +156,12 @@ findInOut = (fmap . fmap) makeVars -- Add explicit data transfer commands addCommands :: ActorTree (ActorTy, (Vars,[ExtStep])) -> ActorTree (ActorTy, (Vars,[ExtStep])) addCommands - = fmap (\(_,_,a) -> (a)) + = fmap (\(_,_,a) -> a) . transform (Vars mempty mempty mempty) where -- Parameters: variables defined in parent and missing in child transform pvars (ActorTree (ty,(vars,steps)) children) - = ActorTree (params,retV,(ty,(vars,steps'''))) children'' + = ActorTree (params,retV, (ty',(vars,steps''))) children' where -- Parameters for current actor: -- * Variables generated by parent by not in child. @@ -278,28 +172,34 @@ addCommands retV = case ty of SimpleActor -> mempty DistrActor dhPar dhCh -> - (varsProd vars) + varsProd vars `HS.intersection` HS.map (changeDom dhPar dhCh) (varsMissing pvars) - + ty' = case ty of + SimpleActor -> SimpleActor + DistrActor{} -> DistrVarActor + (HS.toList params) + (HS.toList retV) -- Transform child actors recursively children' = transform vars <$> children - children'' = children' -- Reference parameter from children steps' = flip concatMap steps $ \case Call dh _ i -> let ActorTree (p,rv,_) _ = children' ! i in [ Call dh (HS.toList p) i - -- FIXME: Here we ignore wrong domain - , Expect $ HS.toList rv + -- FIXME: - Here we ignore wrong domain + , Expect i [ case v of + DVar{} -> (Nothing, v) + KVar kid _ -> ( getFirst $ mconcat $ map (findReprForK kid) steps + , v + ) + | v <- HS.toList rv + ] ] x -> [x] - -- Prepend expect parameters if it isn't done - steps'' | HS.null params = steps' - | otherwise = Expect (HS.toList params) : steps' - -- Append yield - steps''' | HS.null retV = steps'' - | otherwise = steps'' ++ [Yield $ HS.toList retV] - + appendY = case ty' of + DistrVarActor _ rv -> (++ [Yield rv]) + _ -> id + steps'' = appendY steps' changeDom :: Int -> Int -> VV -> VV @@ -315,17 +215,30 @@ collectReferencedVars = withExtStep collectReferencedVars' collectProducedVars :: ExtStep -> HS.HashSet VV collectProducedVars = withExtStep collectProducedVars' +findReprForK :: Int -> ExtStep -> First ReprI +findReprForK i = withExtStep (findReprForK' i) + + +withExtStep :: Monoid t => (Step -> t) -> ExtStep -> t withExtStep f = \case - Step s -> f s + Step s -> f s Call dh _ _ -> f (SplitStep dh []) - -- SplitDistr dh' sched steps - -- -> (f (DistributeStep dh' sched [])) - -- <> foldMap (withExtStep f) steps + _ -> mempty + +findReprForK' :: Int -> Step -> First ReprI +findReprForK' i = \case + KernelStep kb + | kernId kb == i -> First $ Just $ kernRepr kb + | otherwise -> mconcat $ map fromKDep $ kernDeps kb + _ -> mempty + where + fromKDep (KernelDep kid r) | i == kid = First $ Just r + | otherwise = mempty -- Collect variables referenced by step collectReferencedVars' :: Step -> HS.HashSet VV collectReferencedVars' = \case - DomainStep dh -> mempty + DomainStep _dh -> mempty KernelStep kb -> HS.fromList $ concat [ KVar kid (reprDomain repr) : (DVar <$> reprDomain repr) @@ -347,9 +260,79 @@ collectProducedVars' = \case ReprI repr -> HS.singleton $ KVar (kernId kb) (reprDomain repr) SplitStep dh ss -> (HS.singleton $ DVar $ dhId dh) <> foldMap collectProducedVars' ss - DistributeStep dh _ ss -> foldMap collectProducedVars' ss + DistributeStep _ _ ss -> foldMap collectProducedVars' ss + + + +---------------------------------------------------------------- +-- AST for DNA expression +---------------------------------------------------------------- + +-- | +-- Untyped expression tree for compiling to DNA +data StepE a + = V a + -- ^ Untyped variable + | Pair (StepE a) (StepE a) + -- ^ 2-tuple. At the moment pair of kernel-region box] + | List [StepE a] + -- ^ List of variables + + | SDom Int NewRegion + -- ^ Create domain + -- + -- * Domain ID + -- * Action to generate new region. + | SKern KernelBind [StepE a] [StepE a] + -- ^ Kernel call + -- + -- * Kernel description + -- * Parameters + -- * Output domain + | SSeq (StepE a) (StepE a) + -- ^ Sequence two monadic actions + | SBind (StepE a) (Scope () StepE a) + -- ^ Monadic bind. We only introduce new variables in monadic context. + + | SActorGrp Int [StepE a] + -- ^ Corresponds to group of actor + -- + -- * Actor ID + -- * Input parameters + | SActorRecvK ReprI (StepE a) + | SActorRecvD (StepE a) + -- ^ Receive data from actors + deriving (Show,Functor,Foldable,Traversable,Generic) +instance Show1 StepE + +-- | Newtype wrapper for function for splitting regions. Only used to +-- get free Show instance for StepE +newtype RegSplit = RegSplit (Region -> IO [Region]) +newtype NewRegion = NewRegion (IO Region) + +instance Show RegSplit where + show _ = "RegSplit" +instance Show NewRegion where + show _ = "NewRegion" + + +instance Applicative StepE where + pure = V + (<*>) = ap +instance Monad StepE where + return = V + V a >>= f = f a + Pair a b >>= f = Pair (a >>= f) (b >>= f) + List xs >>= f = List (map (>>= f) xs) + SDom i d >>= _ = SDom i d + SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) + SSeq a b >>= f = SSeq (a >>= f) (b >>= f) + SBind e g >>= f = SBind (e >>= f) (g >>>= f) + SActorGrp i xs >>= f = SActorGrp i (map (>>= f) xs) + SActorRecvK r a >>= f = SActorRecvK r (a >>= f) + SActorRecvD a >>= f = SActorRecvD (a >>= f) @@ -357,13 +340,45 @@ collectProducedVars' = \case -- Compilation to expression tree ---------------------------------------------------------------- -{- -data AnyDH = forall a. Typeable a => AnyDH (Domain a) -type DataMap = IM.IntMap (ReprI, Map.Map RegionBox (Vector ())) -type DomainMap = IM.IntMap (AnyDH, RegionBox) --} +-- | Variable name +data V + = KernVar Int + -- ^ @Vector ()@ produced by kernel. It's referenced by KernelID + | DomVar Int + -- ^ Region (referenced by DomainID) + | ChanVar Int + deriving (Show,Eq,Generic) +instance Hashable V + +data DnaActor + = MainActor (StepE V) + | RemoteActor (Scope () StepE V) -compileSteps :: [Step] -> StepE V + +compileProgram + :: ActorTree (ActorTy, (Vars,[ExtStep])) + -> (DnaActor, HM.HashMap Int DnaActor) +compileProgram atree@(ActorTree a _) + = (compile a, compile <$> flatten atree) + where + compile (ty,(_,steps)) = compileActor ty steps + -- Flatten tree + flatten :: ActorTree a -> HM.HashMap Int a + flatten (ActorTree _ hm) + = fmap (\(ActorTree a _) -> a) hm + <> mconcat (toList $ fmap flatten hm) + +compileActor :: ActorTy -> [ExtStep] -> DnaActor +compileActor ty steps = case ty of + SimpleActor -> MainActor prog + DistrVarActor [DVar i] _ -> RemoteActor $ abstract1 (DomVar i) prog + DistrVarActor [KVar i _] _ -> RemoteActor $ abstract1 (KernVar i) prog + DistrActor{} -> error "DistrActor should not appear there" + DistrVarActor{} -> error "DistrActorVar should have single var only" + where + prog = compileSteps steps + +compileSteps :: [ExtStep] -> StepE V compileSteps [] = error "compileSteps: empty list" compileSteps [x] = toStep $ singleStep x compileSteps (x:xs) = @@ -381,151 +396,48 @@ toStep = \case StepVal e _ -> e StepNoVal e -> e -singleStep :: Step -> StepRes +singleStep :: ExtStep -> StepRes singleStep = \case - DomainStep dh -> StepVal + ---------------------------------------- + -- Single step + Step s -> case s of + DomainStep dh -> StepVal (SDom (dhId dh) (NewRegion $ dhCreate dh)) (DomVar (dhId dh)) - KernelStep kb -> StepVal - (SKern kb - -- Parameters - [ Pair (V $ KernVar kid) - (List $ V . DomVar <$> reprDomain repr) - | KernelDep kid (ReprI repr) <- kernDeps kb - ] - -- Output domains - (kbDomList kb)) - (KernVar (kernId kb)) - DistributeStep dh _ steps -> - StepNoVal $ - SDistribute - (V $ DomVar (dhId dh)) - (compileSteps steps) - SplitStep dh steps -> - StepNoVal $ SSplit - (V $ DomVar (maybe (error "Domain doesn't have parent") dhId $ dhParent dh)) - (dhId dh) - (RegSplit $ dhRegion dh) - (abstract1 (DomVar (dhId dh)) $ compileSteps steps) + KernelStep kb -> StepVal + (SKern kb + -- Parameters + [ Pair (V $ KernVar kid) + (List $ V . DomVar <$> reprDomain repr) + | KernelDep kid (ReprI repr) <- kernDeps kb + ] + -- Output domains + (kbDomList kb)) + (KernVar (kernId kb)) + _ -> error "Other steps should not appear in transformed program" + ---------------------------------------- + -- Call actor + Call _ pars i -> StepVal + (SActorGrp i [ case p of + DVar n -> V (DomVar n) + KVar n _ -> V (error "A") + | p <- pars ]) + (ChanVar i) + -- Gather results from vector and build full vector from it. + Expect _ [(Nothing,DVar di)] -> undefined + Expect _ [(Just r, KVar ki _)] -> StepVal + ( SActorRecvK r (V $ KernVar ki)) + ( KernVar ki ) + Expect{} -> error "Do not support expecting more than 1 element" + -- Yield result + Yield [KVar ki _] -> let v = KernVar ki in StepVal (V v) v + Yield [DVar di] -> let v = DomVar di in StepVal (V v) v + Yield{} -> error "Can only yield single value" where kbDomList kb = case kernRepr kb of ReprI r -> V . DomVar <$> reprDomain r ----------------------------------------------------------------- --- AST transformations ----------------------------------------------------------------- - --- Algorithm outline: --- --- 1. Separate parallel parts into additional programs: --- --- [Step] → ActorTree ([Step + Extra commands]) --- --- 2. Determine input/output parameters for commands - - --- evalAST :: StepV V -> Maybe V --- evalAST = undefined - -{- --- | Rewrite AST using given rule until fixed point is reached -rewriteAST :: (StepE V -> Maybe (StepE V)) -> StepE V -> StepE V -rewriteAST rule ast = case loop ast of - Pair a b -> Pair (go a) (go b) - List xs -> List (map go xs) - SKern kb xs ys -> SKern kb (map go xs) (map go ys) - SSplit e did fun lam -> - let var = DomVar did - in SSplit e did fun (abstract1 var $ go $ instantiate1 var lam) - SDistribute a b -> SDistribute (go a) (go b) - SBind expr lam -> undefined - SSeq a b -> SSeq (go a) (go b) - SActorGrp n xs -> SActorGrp n (map go xs) - x -> x - where - -- Rewrite until fixed point is reached - loop a = case rule a of - Just a' -> loop a' - Nothing -> a - -- Recurse down and generate (optionally) value for the AST fragment - go = rewriteAST rule - recur ast' = case ast' of - V v -> (Just v, ast') - Pair a b -> (Nothing, Pair (go a) (go b)) - List xs -> (Nothing, List (map go xs)) - SKern kb xs ys -> ( Just (kernId kb) - , --} - -addYields :: Eq a => StepE a -> StepE a -addYields ast - = undefined - where - -- 1. - - -- List of free variables - freeVars = nub $ toList ast - -- freeVecs = [ i | KernVar i <- freeVars ] - -- Traverse AST and add yield operations for values yielded - trvDistr x = case x of - -- Go deeper - SSeq a b -> SSeq (trvDistr a) (trvDistr b) - SBind e lam -> SBind (trvDistr e) undefined - -- We only recognize split immediately followed by distribute - SSplit dh did f _ -> -- (SDistribute dd steps) -> - undefined - -- everything else passed unchanged - _ -> x - - - - - - --- Now we need to find out values which needed to be passed as parameters --- and received as results --- --- 1. Parameter: free var in child and --- 2. Result: free var in parent, defined in child --- --- To that end we build sets of free and defined vars both in child --- and parent - - --- We also need to merge vectors for each vector result. To that end --- we need to pass regions with buffers - - - - - - - - - - - - - -{- - --- | Generate actor definition for each actor. --- --- 1. We nonrecursively replace each split→distribute pair with actor --- call and generate map of such calls. Input/output parameters are --- not handled at this stage -separateActors :: StepE V -> (StepE V, HM.Int (StepE V)) -separateActors = undefined - --- | Get parameters which are needed for an actor -obtainParameters :: StepE V -> ??? -obtainParameters = undefined --} - - - - ---------------------------------------------------------------- -- Interpretation @@ -535,6 +447,14 @@ data Box = VReg RegionBox | VVec (Vector ()) +interpretAST + :: HM.HashMap Int (StepE V) -> StepE V -> DNA Box +interpretAST actorMap mainActor = case closed mainActor of + Nothing -> error "interpretAST: expression is not closed!" + Just e -> undefined + where + Just amap = sequenceA $ fmap closed actorMap + {- interpretAST :: StepE V -> DNA Box interpretAST e = case closed e of @@ -575,52 +495,74 @@ interpretAST e = case closed e of -- Pretty printer ---------------------------------------------------------------- + -- | Pretty print AST prettyprint :: Show a => StepE a -> Doc prettyprint = flip evalState varNames . ppr . fmap Right - where - varNames = map (:[]) ['a' .. 'z'] - pprList es = do ss <- mapM ppr es - return $ brackets $ hcat $ intersperse comma ss - ppr = \case - V (Left v) -> return $ text v - V (Right a) -> return $ text (show a) - Pair e g -> do se <- ppr e - sg <- ppr g - return $ parens $ se <> comma <> sg - List es -> pprList es - SDom i r -> return $ text (show r) <> text " " <> int i - SKern kb vars dom -> do - vs <- pprList vars - ds <- pprList dom - return $ text "Kernel call" $$ nest 2 - (vcat [ text (show kb), vs, ds ]) - SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) - SSplit e i _ steps -> do - v <- fresh - se <- ppr e - ss <- ppr $ instantiate1 (V $ Left v) steps - (v : rest) <- get - put rest - return $ (text "Split: " <> se <> text " to " <> int i <> text " λ " <> text v <> text " →") - $$ nest 2 ss - SDistribute e steps -> do - se <- ppr e - ss <- ppr steps - return $ (text "Distribute " <> se) $$ nest 2 ss - SBind e lam -> do - v <- fresh - se <- ppr e - sl <- ppr $ instantiate1 (V $ Left v) lam - return $ vcat - [ se <> text (" $ λ"++v++" →") - , nest 2 sl - ] - -- - SYieldVec v -> do - s <- ppr v - return $ text "YieldVec " <> s - fresh = do - v : rest <- get - put rest - return v + +-- | Pretty print AST +prettyprintLam :: Show a => Scope () StepE a -> Doc +prettyprintLam lam + = flip evalState varNames + $ do v <- fresh + doc <- ppr $ instantiate1 (V (Left v)) $ fmap Right lam + return $ vcat + [ text ("λ"++v++" →") + , nest 2 doc + ] + +varNames = map (:[]) ['a' .. 'z'] + + +pprList :: Show a => [StepE (Either String a)] -> State [String] Doc +pprList es = do ss <- mapM ppr es + return $ brackets $ hcat $ intersperse comma ss + +ppr :: Show a => StepE (Either String a) -> State [String] Doc +ppr = \case + V (Left v) -> return $ text v + V (Right a) -> return $ text (show a) + Pair e g -> do se <- ppr e + sg <- ppr g + return $ parens $ se <> comma <> sg + List es -> pprList es + SDom i r -> return $ text (show r) <> text " " <> int i + SKern kb vars dom -> do + vs <- pprList vars + ds <- pprList dom + return $ text "Kernel call" $$ nest 2 + (vcat [ text (show kb), vs, ds ]) + SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) + SBind e lam -> do + v <- fresh + se <- ppr e + sl <- ppr $ instantiate1 (V $ Left v) lam + return $ vcat + [ se <> text (" $ λ"++v++" →") + , nest 2 sl + ] + SActorGrp i vars -> do + xs <- pprList vars + return $ hcat [ text "Actor Grp " + , int i + , text " " + , xs + ] + SActorRecvK r v -> do + s <- ppr v + return $ hcat [ text "Actor recv K " + , text (show r) + , text " " + , s + ] + SActorRecvD v -> do + s <- ppr v + return $ hcat [ text "Actor recv D " + , s + ] + +fresh = do + v : rest <- get + put rest + return v + diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 801f16a4..714f46ca 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -117,12 +117,10 @@ dumpES ind (Call dh pars i) = do -- dumpES ind (SplitDistr dh' sched ss) = do -- dumpStep ind (DistributeStep dh' sched []) -- mapM_ (dumpES (ind++" ")) ss -dumpES ind (Expect vs) = - putStrLn $ ind ++ "Expect " ++ show vs +dumpES ind (Expect i vs) = + putStrLn $ ind ++ "Expect " ++ show i ++ " " ++ show vs dumpES ind (Yield vs) = putStrLn $ ind ++ "Yield " ++ show vs -dumpES ind (Gather vs) = - putStrLn $ ind ++ "Gather " ++ show vs dumpTreeWith :: (String -> a -> IO ()) -> ActorTree a -> IO () @@ -152,6 +150,7 @@ main = do let ast0@(ActorTree ss acts) = makeActorTree steps ast1 = findInOut ast0 ast2 = addCommands ast1 + ast3 = compileProgram ast2 putStrLn "\n-- Actor split -------------------------------------------------" dumpTreeWith (\off -> mapM_ (dumpES off) . snd) ast0 putStrLn "\n-- Used --------------------------------------------------------" @@ -162,17 +161,17 @@ main = do dumpTree $ fmap (varsMissing . fst . snd) ast1 -- putStrLn "\n-- Annotated ---------------------------------------------------" - dumpTreeWith (\off -> mapM_ (dumpES (off++"")) . snd . snd) ast2 - -- Find parameters and return values - -- let walk x f (ActorTree v hm) - -- = ActorTree x (fmap (go v) hm) - -- where - -- go a f (ActorTree vv hmm) = ActorTree (f a vv) (fmap (go vv) hmm) - -- return () - -- putStrLn "-- Param - -----------------------------------------------------" - -- let getp vPar vCh = ( varsProd vPar `HS.intersection` varsMissing vCh - -- , varsMissing vPar `HS.intersection` varsProd vCh - -- ) - -- dumpTree $ walkTree (mempty,mempty) getp vars - -- Find out what to pass as parameters - + dumpTreeWith (\off (ty,(_,as))-> do putStr off >> putStr ">> " >> print ty + mapM_ (dumpES off) as + ) ast2 + -- Dump AST + putStrLn "\n-- AST ---------------------------------------------------------" + let renderAST = \case + MainActor aa -> putStrLn $ render $ prettyprint aa + RemoteActor lam -> putStrLn $ render $ prettyprintLam lam + + case ast3 of + (a,hm) -> do renderAST a + forM_ (HM.toList hm) $ \(i,aa) -> do + putStrLn $ "== " ++ show i ++ " ================" + renderAST aa From 6ff4a72af0c33bf53a5e7ca1a5d8678d89650eb9 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 20 Nov 2015 14:46:47 +0300 Subject: [PATCH 10/15] Interpreter is complete (but not working) --- MS5/dna-flow/Flow/DnaCompiler.hs | 190 +++++++++++++++++++++---------- MS5/dna-flow/Flow/Internal.hs | 10 +- MS5/dna-flow/dna-flow.cabal | 1 + MS5/ms5.cabal | 3 +- MS5/programs/dotproduct-dna.hs | 9 ++ 5 files changed, 152 insertions(+), 61 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index eba6ee0a..3ef1cfe7 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} -- | -- Compilation @[Step] → AST@ module Flow.DnaCompiler ( @@ -30,6 +31,8 @@ module Flow.DnaCompiler ( -- ** Pretty-printing , prettyprint , prettyprintLam + -- * Interpretation + , interpretAST ) where import Control.Arrow (Arrow(..)) @@ -37,9 +40,12 @@ import Control.Applicative import Control.Monad import Control.Monad.State.Strict import Control.Monad.Writer +import Control.Distributed.Process (RemoteTable) +import Control.Distributed.Process.Closure (mkClosureValSingle,MkTDict) import qualified Data.HashMap.Strict as HM import Data.HashMap.Strict ((!)) import qualified Data.HashSet as HS +import qualified Data.Binary as Bin import Data.Typeable import Data.Hashable import Data.List @@ -56,6 +62,9 @@ import Flow.Internal import Flow.Vector import DNA +import Debug.Trace + + ---------------------------------------------------------------- -- Preprocessing of [Steps] @@ -186,7 +195,6 @@ addCommands steps' = flip concatMap steps $ \case Call dh _ i -> let ActorTree (p,rv,_) _ = children' ! i in [ Call dh (HS.toList p) i - -- FIXME: - Here we ignore wrong domain , Expect i [ case v of DVar{} -> (Nothing, v) KVar kid _ -> ( getFirst $ mconcat $ map (findReprForK kid) steps @@ -228,7 +236,7 @@ withExtStep f = \case findReprForK' :: Int -> Step -> First ReprI findReprForK' i = \case KernelStep kb - | kernId kb == i -> First $ Just $ kernRepr kb + | kernId kb == i -> First $ Just (kernRepr kb) | otherwise -> mconcat $ map fromKDep $ kernDeps kb _ -> mempty where @@ -290,6 +298,7 @@ data StepE a -- * Kernel description -- * Parameters -- * Output domain + | SSplit RegSplit (StepE a) | SSeq (StepE a) (StepE a) -- ^ Sequence two monadic actions @@ -301,7 +310,11 @@ data StepE a -- -- * Actor ID -- * Input parameters - | SActorRecvK ReprI (StepE a) + | SActorRecvK ReprI (StepE a) (StepE a) + -- + -- * Representation of resulting vector + -- * Channel variable + -- * Region of whole vector | SActorRecvD (StepE a) -- ^ Receive data from actors deriving (Show,Functor,Foldable,Traversable,Generic) @@ -327,12 +340,13 @@ instance Monad StepE where Pair a b >>= f = Pair (a >>= f) (b >>= f) List xs >>= f = List (map (>>= f) xs) SDom i d >>= _ = SDom i d + SSplit s e >>= f = SSplit s (e >>= f) SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) SSeq a b >>= f = SSeq (a >>= f) (b >>= f) SBind e g >>= f = SBind (e >>= f) (g >>>= f) - SActorGrp i xs >>= f = SActorGrp i (map (>>= f) xs) - SActorRecvK r a >>= f = SActorRecvK r (a >>= f) - SActorRecvD a >>= f = SActorRecvD (a >>= f) + SActorGrp i xs >>= f = SActorGrp i (map (>>= f) xs) + SActorRecvK r a b >>= f = SActorRecvK r (a >>= f) (b >>= f) + SActorRecvD a >>= f = SActorRecvD (a >>= f) @@ -385,10 +399,13 @@ compileSteps (x:xs) = let rest = compileSteps xs in case singleStep x of StepVal expr v -> expr `SBind` abstract1 v rest + Step2Val e1 v1 e2 v2 -> + e1 `SBind` abstract1 v1 (e2 `SBind` abstract1 v2 rest) StepNoVal expr -> expr `SSeq` rest data StepRes = StepVal (StepE V) V + | Step2Val (StepE V) V (StepE V) V | StepNoVal (StepE V) toStep :: StepRes -> StepE V @@ -417,17 +434,27 @@ singleStep = \case _ -> error "Other steps should not appear in transformed program" ---------------------------------------- -- Call actor - Call _ pars i -> StepVal - (SActorGrp i [ case p of - DVar n -> V (DomVar n) - KVar n _ -> V (error "A") - | p <- pars ]) - (ChanVar i) + Call dh pars i -> + let dhp = case dhParent dh of + Just d -> d + Nothing -> error "Parent??" + in Step2Val + (SSplit (RegSplit $ dhRegion dhp) (V $ DomVar $ dhId dhp)) + (DomVar $ dhId dh) + (SActorGrp i [ case p of + DVar n -> V (DomVar n) + KVar n _ -> V (error "A") + | p <- pars ]) + (ChanVar i) -- Gather results from vector and build full vector from it. - Expect _ [(Nothing,DVar di)] -> undefined - Expect _ [(Just r, KVar ki _)] -> StepVal - ( SActorRecvK r (V $ KernVar ki)) - ( KernVar ki ) + Expect _ [(Nothing,DVar di)] -> error "Expecting domain is not implemented" + Expect i [(Just r@(ReprI repr), KVar ki _)] -> + let [did] = reprDomain repr + in StepVal ( SActorRecvK r + (V $ ChanVar i) + (V $ DomVar did) + ) + ( KernVar ki ) Expect{} -> error "Do not support expecting more than 1 element" -- Yield result Yield [KVar ki _] -> let v = KernVar ki in StepVal (V v) v @@ -444,50 +471,91 @@ singleStep = \case ---------------------------------------------------------------- data Box - = VReg RegionBox - | VVec (Vector ()) + = VReg RegionBox + | VVec RegionBox (Vector ()) + | VChan (DNA.Group Box) + deriving (Typeable) + +instance Bin.Binary Box where + put = undefined + get = undefined interpretAST - :: HM.HashMap Int (StepE V) -> StepE V -> DNA Box + :: HM.HashMap Int DnaActor -> StepE V -> (RemoteTable -> RemoteTable, DNA Box) interpretAST actorMap mainActor = case closed mainActor of Nothing -> error "interpretAST: expression is not closed!" - Just e -> undefined - where - Just amap = sequenceA $ fmap closed actorMap - -{- -interpretAST :: StepE V -> DNA Box -interpretAST e = case closed e of - Just e' -> go e' - Nothing -> error "interpretAST: expression is not closed!" + Just e -> (rtable,go e) where go = \case - V{} -> error "Naked variable at the top level" + V a -> return a Pair{} -> error "Naked pair at the top level" - -- List{} -> error "Naked list at the top level" - -- Create new domain - SDom dom -> - DNA.kernel "dom" [] $ liftIO $ VReg <$> dom - -- Call kernel - {- + List{} -> error "Naked list at the top level" + -- Domains + SDom _ (NewRegion dom) -> + DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dom + SSplit (RegSplit split) reg -> + case toDom reg of + [r] -> do DNA.kernel "split" [] $ liftIO $ VReg <$> split r + _ -> error "Non unary domain!" + -- Kernel SKern kb deps dom -> - let toDom = \case - V (VReg d) -> d - V (VVec _) -> error "Vector where domain expected" - _ -> error "Only variables expected" - toParam = \case - Pair (V (VVec v)) (List p) -> (v, map toDom p) - _ -> error "Ill formed parameters" - xs = map toParam deps - out = map toDom dom - in DNA.kernel "kern" [] $ liftIO $ VVec <$> kernCode kb xs out --} + let xs = map toParam deps + out = toDom =<< dom + in DNA.kernel "kern" [] $ liftIO $ VVec out <$> kernCode kb xs out -- Monadic bind SBind expr lam -> let dnaE = go expr lamE = \a -> go $ instantiate1 (V a) lam in dnaE >>= lamE --} + SSeq e1 e2 -> go e1 >> go e2 + -- Actor spawning + SActorGrp actID [par] -> do + let regs = toDom par + n = length regs + (clos,_) = amap ! actID + logMessage $ show regs + sh <- startGroup (N n) (NNodes 1) $ return clos + grp <- delayGroup sh + return $ VChan grp + SActorGrp _ _ -> error "Only actor with one parameter are supported" + -- Receiving of parameters + SActorRecvK (ReprI repr) vCh vReg -> do + let ch = toGrp vCh + reg = toDom vReg + xs <- gather ch (flip (:)) [] + let pars = flip map xs $ \case + VVec v p -> (v,p) + _ -> error "Only vector expected!" + DNA.kernel "merge" [] $ liftIO $ do + Just vec <- reprMerge repr pars reg + return $ VVec reg vec + undefined + SActorRecvD{} -> error "Receiving of domains is not implemented" + -- + toDom = \case + V (VReg d) -> d + V VVec{} -> error "Vector where domain expected" + _ -> error "Only variables expected" + toParam = \case + Pair (V (VVec _ v)) (List p) -> (v, toDom =<< p) + _ -> error "Ill formed parameters" + toGrp = \case + V (VChan ch) -> ch + V _ -> error "Not a chan var" + _ -> error "Only variables expected" + -- + runActor :: DnaActor -> DNA.Actor Box Box + runActor = \case + MainActor a -> error "Not supported" + RemoteActor lam -> + let Just lam' = closed lam + in DNA.actor $ \x -> go (instantiate1 (V x) lam') + -- + Endo rtable = foldMap (Endo . snd) amap + amap = HM.mapWithKey (\i a -> let (clos,reg) = mkClosureValSingle ("DNA_NAME_" ++ show i) $ \_ -> a + in (clos (), reg) + ) + $ fmap runActor actorMap @@ -533,6 +601,12 @@ ppr = \case return $ text "Kernel call" $$ nest 2 (vcat [ text (show kb), vs, ds ]) SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) + SSplit _ e -> do + s <- ppr e + return $ hcat [ text "SSplit {" + , s + , text "}" + ] SBind e lam -> do v <- fresh se <- ppr e @@ -548,12 +622,14 @@ ppr = \case , text " " , xs ] - SActorRecvK r v -> do - s <- ppr v + SActorRecvK r vCh vReg -> do + sCh <- ppr vCh + sReg <- ppr vReg return $ hcat [ text "Actor recv K " - , text (show r) + , text $ " {"++(show r)++"} " + , sCh , text " " - , s + , sReg ] SActorRecvD v -> do s <- ppr v diff --git a/MS5/dna-flow/Flow/Internal.hs b/MS5/dna-flow/Flow/Internal.hs index c46faf07..30671137 100644 --- a/MS5/dna-flow/Flow/Internal.hs +++ b/MS5/dna-flow/Flow/Internal.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, TypeFamilies, RankNTypes, ScopedTypeVariables, TypeOperators, DeriveDataTypeable, TypeSynonymInstances, - FlexibleInstances, FlexibleContexts + FlexibleInstances, FlexibleContexts, DeriveGeneric #-} module Flow.Internal where @@ -11,8 +11,10 @@ import Data.Function ( on ) import Data.Hashable import Data.Int import Data.List ( sort ) +import Data.Binary (Binary) import qualified Data.HashMap.Strict as HM import Data.Typeable +import GHC.Generics (Generic) import Flow.Vector @@ -161,10 +163,12 @@ dhIsParent dh dh1 -- | Domains are just ranges for now. It is *very* likely that we are -- going to have to generalise this in some way. data Region = RangeRegion Range - deriving (Typeable, Eq, Ord, Show) + deriving (Typeable, Eq, Ord, Show, Generic) +instance Binary Region data Range = Range Int Int - deriving (Typeable, Eq, Ord, Show) + deriving (Typeable, Eq, Ord, Show, Generic) +instance Binary Range -- | Checks whether the second domain is a subset of the first domainSubset :: Region -> Region -> Bool diff --git a/MS5/dna-flow/dna-flow.cabal b/MS5/dna-flow/dna-flow.cabal index 3c9e20b7..21f69766 100644 --- a/MS5/dna-flow/dna-flow.cabal +++ b/MS5/dna-flow/dna-flow.cabal @@ -33,6 +33,7 @@ library bound >= 1.0.6, prelude-extras >= 0.4, pretty, + distributed-process >= 0.5.5, dna >= 0.5 Exposed-modules: Flow, Flow.Builder, diff --git a/MS5/ms5.cabal b/MS5/ms5.cabal index 8340542e..0c4f1100 100644 --- a/MS5/ms5.cabal +++ b/MS5/ms5.cabal @@ -38,7 +38,7 @@ executable dotproduct executable dotproduct-dna default-language: Haskell2010 - ghc-options: -O2 -Wall -threaded -rtsopts + ghc-options: -O2 -Wall -threaded -eventlog -rtsopts Hs-source-dirs: programs main-is: dotproduct-dna.hs build-depends: @@ -48,6 +48,7 @@ executable dotproduct-dna bound, pretty, dna, + unordered-containers, fixed-vector-hetero x-halide-sources: kernel/cpu/dotproduct/generate_f.cpp kernel/cpu/dotproduct/generate_g.cpp diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 714f46ca..7f805633 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -28,6 +28,8 @@ import Flow.DnaCompiler import Flow.Internal import Bound +import DNA (dnaRun,logMessage) + -- Data tags data Vec deriving Typeable data Sum deriving Typeable @@ -175,3 +177,10 @@ main = do forM_ (HM.toList hm) $ \(i,aa) -> do putStrLn $ "== " ++ show i ++ " ================" renderAST aa + -- Run program + case ast3 of + (MainActor dna, amap) -> + let (rtable,prog) = interpretAST amap dna + in dnaRun rtable $ do logMessage "START" + void prog + logMessage "END" From fd6a4ed2b3b0be62ceff581f33d570b297c612e8 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Tue, 24 Nov 2015 19:21:11 +0300 Subject: [PATCH 11/15] "Fix" merged code --- MS5/dna-flow/Flow/Internal.hs | 16 +++++++++++++--- MS5/dna-flow/Flow/Run.hs | 25 ++++++++++++------------- 2 files changed, 25 insertions(+), 16 deletions(-) diff --git a/MS5/dna-flow/Flow/Internal.hs b/MS5/dna-flow/Flow/Internal.hs index 2a140851..05301d71 100644 --- a/MS5/dna-flow/Flow/Internal.hs +++ b/MS5/dna-flow/Flow/Internal.hs @@ -11,7 +11,7 @@ import Data.Function ( on ) import Data.Hashable import Data.Int import Data.List ( sort, groupBy ) -import Data.Binary (Binary) +import Data.Binary (Binary(..)) import qualified Data.Map as Map import Data.Monoid import qualified Data.HashMap.Strict as HM @@ -167,6 +167,10 @@ data Domain a = Domain , dhFilterBox :: RegionBox -> Region -> Maybe Region } +instance Binary (Domain a) where + put _ = return () + get = return $ error "No sane Binary instance for Domain" + instance forall a. Typeable a => Show (Domain a) where showsPrec _ dh = shows (typeOf (undefined :: a)) . showString " domain " . shows (dhId dh) instance Eq (Domain a) where @@ -194,7 +198,7 @@ instance Eq DomainI where -- going to have to generalise this in some way. data Region = RangeRegion (Domain Range) Range | BinRegion (Domain Bins) Bins - deriving (Typeable, Eq, Ord, Show, Generic) + deriving (Typeable, Generic) instance Binary Region instance Show Region where @@ -218,10 +222,16 @@ instance Eq Region where data Range = Range Int Int deriving (Typeable, Eq, Ord, Generic) + +instance Binary Range instance Show Range where showsPrec _ (Range low high) = shows low . (':':) . shows high + data Bins = Bins (Map.Map (Double, Double) (Map.Map RegionBox Int)) - deriving (Typeable, Eq, Ord) + deriving (Typeable, Eq, Ord, Generic) + +instance Binary Bins + instance Show Bins where showsPrec _ (Bins bins) = showString "Bins" . flip (foldr f) (Map.toList bins) where f ((low, high), m) = (' ':) . shows low . (':':) . shows high . shows (Map.elems m) diff --git a/MS5/dna-flow/Flow/Run.hs b/MS5/dna-flow/Flow/Run.hs index 327d1d1d..248b6676 100644 --- a/MS5/dna-flow/Flow/Run.hs +++ b/MS5/dna-flow/Flow/Run.hs @@ -68,21 +68,20 @@ dumpStrategyDOT file strat = do hPutStrLn h "}" hClose h +dumpStep ind (DomainStep m_kid dh) + = putStrLn $ ind ++ "Domain " ++ show dh ++ + maybe "" (\kid -> " from kernel " ++ show kid) m_kid ++ + maybe "" (\dom -> " split from " ++ show dom) (dhParent dh) +dumpStep ind (KernelStep kb@KernelBind{kernRepr=ReprI rep}) + = putStrLn $ ind ++ "Over " ++ show (reprDomain rep) ++ " run " ++ show kb +dumpStep ind step@(DistributeStep did sched steps) + = do putStrLn $ ind ++ "Distribute " ++ show did ++ " using " ++ show sched ++ + " deps " ++ show (stepKernDeps step) + forM_ steps (dumpStep (" " ++ ind)) + dumpSteps :: Strategy a -> IO () dumpSteps strat = do - - let dump ind (DomainStep m_kid dh) - = putStrLn $ ind ++ "Domain " ++ show dh ++ - maybe "" (\kid -> " from kernel " ++ show kid) m_kid ++ - maybe "" (\dom -> " split from " ++ show dom) (dhParent dh) - dump ind (KernelStep kb@KernelBind{kernRepr=ReprI rep}) - = putStrLn $ ind ++ "Over " ++ show (reprDomain rep) ++ " run " ++ show kb - dump ind step@(DistributeStep did sched steps) - = do putStrLn $ ind ++ "Distribute " ++ show did ++ " using " ++ show sched ++ - " deps " ++ show (stepKernDeps step) - forM_ steps (dump (" " ++ ind)) - - forM_ (runStrategy (void strat)) (dump "") + forM_ (runStrategy (void strat)) (dumpStep "") data AnyDH = forall a. Typeable a => AnyDH (Domain a) From e9dc831e0be40abcda70b276ce8391e968d9e8ca Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Tue, 24 Nov 2015 19:41:20 +0300 Subject: [PATCH 12/15] Disable code ralted to split step --- MS5/dna-flow/Flow/DnaCompiler.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index 3ef1cfe7..137832d4 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -138,6 +138,7 @@ makeActorTree steps go (x:xs) = do x' <- case x of -- + {- (SplitStep dh [DistributeStep dh' _sched ss]) -> do n <- get put $! n+1 @@ -148,6 +149,7 @@ makeActorTree steps $ go ss tell [(n , child)] return (Call dh [] n) + -} -- _ -> return (Step x) xs' <- go xs @@ -230,7 +232,7 @@ findReprForK i = withExtStep (findReprForK' i) withExtStep :: Monoid t => (Step -> t) -> ExtStep -> t withExtStep f = \case Step s -> f s - Call dh _ _ -> f (SplitStep dh []) + -- Call dh _ _ -> f (SplitStep dh []) _ -> mempty findReprForK' :: Int -> Step -> First ReprI @@ -253,10 +255,10 @@ collectReferencedVars' = \case | KernelDep kid (ReprI repr) <- kernDeps kb ] -- singleton $ KernVar $ kernId kb - SplitStep dh ss -> - let Just parD = dhParent dh - in (HS.singleton $ DVar $ dhId parD) - <> foldMap collectReferencedVars' ss + -- SplitStep dh ss -> + -- let Just parD = dhParent dh + -- in (HS.singleton $ DVar $ dhId parD) + -- <> foldMap collectReferencedVars' ss DistributeStep dh _ ss -> (HS.singleton $ DVar $ dhId dh) <> foldMap collectReferencedVars' ss @@ -266,8 +268,8 @@ collectProducedVars' = \case DomainStep dh -> HS.singleton $ DVar $ dhId dh KernelStep kb -> case kernRepr kb of ReprI repr -> HS.singleton $ KVar (kernId kb) (reprDomain repr) - SplitStep dh ss -> (HS.singleton $ DVar $ dhId dh) - <> foldMap collectProducedVars' ss + -- SplitStep dh ss -> (HS.singleton $ DVar $ dhId dh) + -- <> foldMap collectProducedVars' ss DistributeStep _ _ ss -> foldMap collectProducedVars' ss From 741ee42677c8ddb3832263e0449d3b5b4da15927 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 25 Nov 2015 20:38:54 +0300 Subject: [PATCH 13/15] Restore everything except interpreter --- MS5/dna-flow/Flow/DnaCompiler.hs | 74 ++++++++++++++++---------------- MS5/programs/dotproduct-dna.hs | 14 +++--- 2 files changed, 43 insertions(+), 45 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index 137832d4..f96a795e 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -46,6 +46,7 @@ import qualified Data.HashMap.Strict as HM import Data.HashMap.Strict ((!)) import qualified Data.HashSet as HS import qualified Data.Binary as Bin +import qualified Data.Map as Map import Data.Typeable import Data.Hashable import Data.List @@ -138,18 +139,16 @@ makeActorTree steps go (x:xs) = do x' <- case x of -- - {- - (SplitStep dh [DistributeStep dh' _sched ss]) -> do + DistributeStep dh' _sched ss -> do n <- get put $! n+1 - let Just pdom = dhParent dh + let Just pdom = dhParent dh' child <- lift $ run $ fmap ((,) (DistrActor (dhId pdom) (dhId dh'))) $ go ss tell [(n , child)] - return (Call dh [] n) - -} + return (Call dh' [] n) -- _ -> return (Step x) xs' <- go xs @@ -248,28 +247,22 @@ findReprForK' i = \case -- Collect variables referenced by step collectReferencedVars' :: Step -> HS.HashSet VV collectReferencedVars' = \case - DomainStep _dh -> mempty + DomainStep (Just kid) _ -> HS.singleton (KVar kid []) + DomainStep _ _ -> mempty KernelStep kb -> HS.fromList $ concat [ KVar kid (reprDomain repr) : (DVar <$> reprDomain repr) | KernelDep kid (ReprI repr) <- kernDeps kb ] - -- singleton $ KernVar $ kernId kb - -- SplitStep dh ss -> - -- let Just parD = dhParent dh - -- in (HS.singleton $ DVar $ dhId parD) - -- <> foldMap collectReferencedVars' ss DistributeStep dh _ ss -> (HS.singleton $ DVar $ dhId dh) <> foldMap collectReferencedVars' ss -- Collect variables produced by step collectProducedVars' :: Step -> HS.HashSet VV collectProducedVars' = \case - DomainStep dh -> HS.singleton $ DVar $ dhId dh + DomainStep _ dh -> HS.singleton $ DVar $ dhId dh KernelStep kb -> case kernRepr kb of ReprI repr -> HS.singleton $ KVar (kernId kb) (reprDomain repr) - -- SplitStep dh ss -> (HS.singleton $ DVar $ dhId dh) - -- <> foldMap collectProducedVars' ss DistributeStep _ _ ss -> foldMap collectProducedVars' ss @@ -289,7 +282,7 @@ data StepE a -- ^ List of variables - | SDom Int NewRegion + | SDom Int (Maybe (StepE a)) NewRegion -- ^ Create domain -- -- * Domain ID @@ -341,7 +334,7 @@ instance Monad StepE where V a >>= f = f a Pair a b >>= f = Pair (a >>= f) (b >>= f) List xs >>= f = List (map (>>= f) xs) - SDom i d >>= _ = SDom i d + SDom i m d >>= f = SDom i ((>>= f) <$> m) d SSplit s e >>= f = SSplit s (e >>= f) SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) SSeq a b >>= f = SSeq (a >>= f) (b >>= f) @@ -420,9 +413,11 @@ singleStep = \case ---------------------------------------- -- Single step Step s -> case s of - DomainStep dh -> StepVal - (SDom (dhId dh) (NewRegion $ dhCreate dh)) - (DomVar (dhId dh)) + DomainStep mkid dh -> + let m = V . KernVar <$> mkid + in StepVal + (SDom (dhId dh) m (NewRegion $ dhCreate dh Map.empty)) -- FIXME + (DomVar (dhId dh)) KernelStep kb -> StepVal (SKern kb -- Parameters @@ -493,17 +488,17 @@ interpretAST actorMap mainActor = case closed mainActor of Pair{} -> error "Naked pair at the top level" List{} -> error "Naked list at the top level" -- Domains - SDom _ (NewRegion dom) -> - DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dom + -- SDom _ (NewRegion dom) -> + -- DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dom SSplit (RegSplit split) reg -> case toDom reg of [r] -> do DNA.kernel "split" [] $ liftIO $ VReg <$> split r _ -> error "Non unary domain!" -- Kernel - SKern kb deps dom -> - let xs = map toParam deps - out = toDom =<< dom - in DNA.kernel "kern" [] $ liftIO $ VVec out <$> kernCode kb xs out + -- SKern kb deps dom -> + -- let xs = map toParam deps + -- out = toDom =<< dom + -- in DNA.kernel "kern" [] $ liftIO $ VVec out <$> kernCode kb xs out -- Monadic bind SBind expr lam -> let dnaE = go expr @@ -521,18 +516,18 @@ interpretAST actorMap mainActor = case closed mainActor of return $ VChan grp SActorGrp _ _ -> error "Only actor with one parameter are supported" -- Receiving of parameters - SActorRecvK (ReprI repr) vCh vReg -> do - let ch = toGrp vCh - reg = toDom vReg - xs <- gather ch (flip (:)) [] - let pars = flip map xs $ \case - VVec v p -> (v,p) - _ -> error "Only vector expected!" - DNA.kernel "merge" [] $ liftIO $ do - Just vec <- reprMerge repr pars reg - return $ VVec reg vec - undefined - SActorRecvD{} -> error "Receiving of domains is not implemented" + -- SActorRecvK (ReprI repr) vCh vReg -> do + -- let ch = toGrp vCh + -- reg = toDom vReg + -- xs <- gather ch (flip (:)) [] + -- let pars = flip map xs $ \case + -- VVec v p -> (v,p) + -- _ -> error "Only vector expected!" + -- DNA.kernel "merge" [] $ liftIO $ do + -- Just vec <- reprMerge repr pars reg + -- return $ VVec reg vec + -- undefined + -- SActorRecvD{} -> error "Receiving of domains is not implemented" -- toDom = \case V (VReg d) -> d @@ -596,7 +591,10 @@ ppr = \case sg <- ppr g return $ parens $ se <> comma <> sg List es -> pprList es - SDom i r -> return $ text (show r) <> text " " <> int i + SDom i m r -> do ss <- case m of + Nothing -> return $ text "-" + Just v -> ppr v + return $ text (show r) <> text " " <> int i SKern kb vars dom -> do vs <- pprList vars ds <- pprList dom diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 7f805633..719b54f1 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -72,7 +72,7 @@ aKern size = halideKernel1 "a" (vecRepr size) sumRepr kern_sum foreign import ccall unsafe kern_sum :: HalideFun '[ VecRepr ] SumRepr printKern :: Flow Sum -> Kernel Sum -printKern = kernel "print" (sumRepr :. Z) NoRepr $ \case +printKern = mergingKernel "print" (sumRepr :. Z) NoRepr $ \case [(sv,_)]-> \_ -> do s <- peekVector (castVector sv :: Vector Float) 0 putStrLn $ "Sum: " ++ show s @@ -102,11 +102,11 @@ ddpStrat size = do dom <- makeRangeDomain 0 size -- Calculate ddp for the whole domain - split dom 10 $ \regs -> - distribute regs ParSchedule $ do - bind f (fKern regs) - bind g (gKern regs) - bind (pp f g) (ppKern regs f g) + regs <- split dom 10 + distribute regs ParSchedule $ do + bind f (fKern regs) + bind g (gKern regs) + bind (pp f g) (ppKern regs f g) bindRule a (aKern dom) calculate ddp void $ bindNew $ printKern ddp @@ -115,7 +115,7 @@ ddpStrat size = do dumpES ind (Step s) = dumpStep ind s dumpES ind (Call dh pars i) = do putStrLn $ ind ++ "Call " ++ show i ++ " " ++ show pars - dumpStep (ind ++ " ") $ SplitStep dh [] + -- dumpStep (ind ++ " ") $ SplitStep dh [] -- dumpES ind (SplitDistr dh' sched ss) = do -- dumpStep ind (DistributeStep dh' sched []) -- mapM_ (dumpES (ind++" ")) ss From 547ac1927ab1cf347fc9c30577df565648b744a5 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 25 Nov 2015 23:23:45 +0300 Subject: [PATCH 14/15] Kind of restore interpreter --- MS5/dna-flow/Flow/DnaCompiler.hs | 45 +++++++++++++++++--------------- MS5/dna-flow/Flow/Internal.hs | 6 ----- 2 files changed, 24 insertions(+), 27 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index f96a795e..e5afd417 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -481,24 +481,28 @@ interpretAST :: HM.HashMap Int DnaActor -> StepE V -> (RemoteTable -> RemoteTable, DNA Box) interpretAST actorMap mainActor = case closed mainActor of Nothing -> error "interpretAST: expression is not closed!" - Just e -> (rtable,go e) + Just e -> (rtable, go e) where go = \case V a -> return a Pair{} -> error "Naked pair at the top level" List{} -> error "Naked list at the top level" - -- Domains - -- SDom _ (NewRegion dom) -> - -- DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dom + -- Domains + SDom _ me (NewRegion dom) -> do + -- FIXME: SDom is not correctly handled + let m = case me of Nothing -> Map.empty + Just e -> error "FIXME: region lookup is not implemented" + DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dom SSplit (RegSplit split) reg -> case toDom reg of [r] -> do DNA.kernel "split" [] $ liftIO $ VReg <$> split r _ -> error "Non unary domain!" -- Kernel - -- SKern kb deps dom -> - -- let xs = map toParam deps - -- out = toDom =<< dom - -- in DNA.kernel "kern" [] $ liftIO $ VVec out <$> kernCode kb xs out + SKern kb deps dom -> do + let xs = map (Map.fromList . (:[]) . toParam) deps + out = toDom =<< dom + [v] <- DNA.kernel "kern" [] $ liftIO $ kernCode kb xs [out] -- FIXME: wrong + return $ VVec out v -- Monadic bind SBind expr lam -> let dnaE = go expr @@ -516,25 +520,24 @@ interpretAST actorMap mainActor = case closed mainActor of return $ VChan grp SActorGrp _ _ -> error "Only actor with one parameter are supported" -- Receiving of parameters - -- SActorRecvK (ReprI repr) vCh vReg -> do - -- let ch = toGrp vCh - -- reg = toDom vReg - -- xs <- gather ch (flip (:)) [] - -- let pars = flip map xs $ \case - -- VVec v p -> (v,p) - -- _ -> error "Only vector expected!" - -- DNA.kernel "merge" [] $ liftIO $ do - -- Just vec <- reprMerge repr pars reg - -- return $ VVec reg vec - -- undefined - -- SActorRecvD{} -> error "Receiving of domains is not implemented" + SActorRecvK (ReprI repr) vCh vReg -> do + let ch = toGrp vCh + reg = toDom vReg + xs <- gather ch (flip (:)) [] + let pars = flip map xs $ \case + VVec v p -> (v,p) + _ -> error "Only vector expected!" + DNA.kernel "merge" [] $ liftIO $ do + Just vec <- reprMerge repr (Map.fromList pars) reg + return $ VVec reg vec + SActorRecvD{} -> error "Receiving of domains is not implemented" -- toDom = \case V (VReg d) -> d V VVec{} -> error "Vector where domain expected" _ -> error "Only variables expected" toParam = \case - Pair (V (VVec _ v)) (List p) -> (v, toDom =<< p) + Pair (V (VVec _ v)) (List p) -> (toDom =<< p, v) _ -> error "Ill formed parameters" toGrp = \case V (VChan ch) -> ch diff --git a/MS5/dna-flow/Flow/Internal.hs b/MS5/dna-flow/Flow/Internal.hs index 05301d71..973676c7 100644 --- a/MS5/dna-flow/Flow/Internal.hs +++ b/MS5/dna-flow/Flow/Internal.hs @@ -167,10 +167,6 @@ data Domain a = Domain , dhFilterBox :: RegionBox -> Region -> Maybe Region } -instance Binary (Domain a) where - put _ = return () - get = return $ error "No sane Binary instance for Domain" - instance forall a. Typeable a => Show (Domain a) where showsPrec _ dh = shows (typeOf (undefined :: a)) . showString " domain " . shows (dhId dh) instance Eq (Domain a) where @@ -199,7 +195,6 @@ instance Eq DomainI where data Region = RangeRegion (Domain Range) Range | BinRegion (Domain Bins) Bins deriving (Typeable, Generic) -instance Binary Region instance Show Region where showsPrec _ (RangeRegion dom r) = showString "Region<" . shows (dhId dom) . ('>':) . shows r @@ -230,7 +225,6 @@ instance Show Range where data Bins = Bins (Map.Map (Double, Double) (Map.Map RegionBox Int)) deriving (Typeable, Eq, Ord, Generic) -instance Binary Bins instance Show Bins where showsPrec _ (Bins bins) = showString "Bins" . flip (foldr f) (Map.toList bins) From 2181846b01ea569084eb7edaabae411c2709cfe2 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Fri, 27 Nov 2015 17:17:41 +0300 Subject: [PATCH 15/15] Draft --- MS5/dna-flow/Flow/DnaCompiler.hs | 96 +++++++++++++++++--------------- MS5/dna-flow/Flow/Internal.hs | 2 +- MS5/ms5.cabal | 2 + MS5/programs/dotproduct-dna.hs | 15 ++++- 4 files changed, 66 insertions(+), 49 deletions(-) diff --git a/MS5/dna-flow/Flow/DnaCompiler.hs b/MS5/dna-flow/Flow/DnaCompiler.hs index e5afd417..43f71642 100644 --- a/MS5/dna-flow/Flow/DnaCompiler.hs +++ b/MS5/dna-flow/Flow/DnaCompiler.hs @@ -22,8 +22,6 @@ module Flow.DnaCompiler ( -- * Compilation to AST for DNA -- ** AST , StepE(..) - , RegSplit(..) - , NewRegion(..) -- ** Compilation , DnaActor(..) , V(..) @@ -45,7 +43,9 @@ import Control.Distributed.Process.Closure (mkClosureValSingle,MkTDict) import qualified Data.HashMap.Strict as HM import Data.HashMap.Strict ((!)) import qualified Data.HashSet as HS -import qualified Data.Binary as Bin +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin +import qualified Data.Binary.Put as Bin import qualified Data.Map as Map import Data.Typeable import Data.Hashable @@ -282,18 +282,18 @@ data StepE a -- ^ List of variables - | SDom Int (Maybe (StepE a)) NewRegion + | SDom (Maybe (StepE a)) AnyDH (Maybe (StepE a)) -- ^ Create domain -- - -- * Domain ID - -- * Action to generate new region. + -- * Region argument + -- * Wrapped domain + -- * Parent domain if any | SKern KernelBind [StepE a] [StepE a] -- ^ Kernel call -- -- * Kernel description -- * Parameters -- * Output domain - | SSplit RegSplit (StepE a) | SSeq (StepE a) (StepE a) -- ^ Sequence two monadic actions @@ -315,15 +315,12 @@ data StepE a deriving (Show,Functor,Foldable,Traversable,Generic) instance Show1 StepE --- | Newtype wrapper for function for splitting regions. Only used to --- get free Show instance for StepE -newtype RegSplit = RegSplit (Region -> IO [Region]) -newtype NewRegion = NewRegion (IO Region) -instance Show RegSplit where - show _ = "RegSplit" -instance Show NewRegion where - show _ = "NewRegion" +data AnyDH where + AnyDH :: Typeable a => Domain a -> AnyDH + +instance Show AnyDH where + show (AnyDH d) = show d instance Applicative StepE where @@ -334,8 +331,7 @@ instance Monad StepE where V a >>= f = f a Pair a b >>= f = Pair (a >>= f) (b >>= f) List xs >>= f = List (map (>>= f) xs) - SDom i m d >>= f = SDom i ((>>= f) <$> m) d - SSplit s e >>= f = SSplit s (e >>= f) + SDom a m b >>= f = SDom ((>>= f) <$> a) m ((>>= f) <$> b) SKern k xs ys >>= f = SKern k (map (>>= f) xs) (map (>>= f) ys) SSeq a b >>= f = SSeq (a >>= f) (b >>= f) SBind e g >>= f = SBind (e >>= f) (g >>>= f) @@ -416,7 +412,7 @@ singleStep = \case DomainStep mkid dh -> let m = V . KernVar <$> mkid in StepVal - (SDom (dhId dh) m (NewRegion $ dhCreate dh Map.empty)) -- FIXME + (SDom m (AnyDH dh) (V . DomVar . dhId <$> dhParent dh)) (DomVar (dhId dh)) KernelStep kb -> StepVal (SKern kb @@ -435,9 +431,9 @@ singleStep = \case let dhp = case dhParent dh of Just d -> d Nothing -> error "Parent??" - in Step2Val - (SSplit (RegSplit $ dhRegion dhp) (V $ DomVar $ dhId dhp)) - (DomVar $ dhId dh) + in StepVal + -- (SSplit (RegSplit $ dhRegion dhp) (V $ DomVar $ dhId dhp)) + -- (DomVar $ dhId dh) (SActorGrp i [ case p of DVar n -> V (DomVar n) KVar n _ -> V (error "A") @@ -474,29 +470,32 @@ data Box deriving (Typeable) instance Bin.Binary Box where - put = undefined - get = undefined + put = error "No put really!" + get = Bin.getWord8 >>= \case + 0 -> VReg <$> undefined -- Bin.get + 1 -> VVec <$> undefined <*> undefined + _ -> error "Bad tag!" + interpretAST :: HM.HashMap Int DnaActor -> StepE V -> (RemoteTable -> RemoteTable, DNA Box) interpretAST actorMap mainActor = case closed mainActor of Nothing -> error "interpretAST: expression is not closed!" - Just e -> (rtable, go e) + Just e -> (rtable, logMessage "START INTERPRETATION" >> go e) where go = \case V a -> return a Pair{} -> error "Naked pair at the top level" List{} -> error "Naked list at the top level" - -- Domains - SDom _ me (NewRegion dom) -> do - -- FIXME: SDom is not correctly handled - let m = case me of Nothing -> Map.empty - Just e -> error "FIXME: region lookup is not implemented" - DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dom - SSplit (RegSplit split) reg -> - case toDom reg of - [r] -> do DNA.kernel "split" [] $ liftIO $ VReg <$> split r - _ -> error "Non unary domain!" + -- Domains + SDom me (AnyDH dh) mpar -> do + logMessage $ "SDom: " ++ show dh + case mpar of + Nothing -> do let m = case me of Nothing -> Map.empty + Just e -> error "FIXME: region lookup is not implemented" + DNA.kernel "dom" [] $ liftIO $ VReg . pure <$> dhCreate dh m + Just par -> do rs <- DNA.kernel "split" [] $ liftIO $ mapM (dhRegion dh) (toDom par) + return $ VReg $ concat rs -- Kernel SKern kb deps dom -> do let xs = map (Map.fromList . (:[]) . toParam) deps @@ -511,11 +510,14 @@ interpretAST actorMap mainActor = case closed mainActor of SSeq e1 e2 -> go e1 >> go e2 -- Actor spawning SActorGrp actID [par] -> do + -- FIXME: only region is passed as parameter let regs = toDom par n = length regs (clos,_) = amap ! actID - logMessage $ show regs + logMessage $ "REGS: " ++ show regs sh <- startGroup (N n) (NNodes 1) $ return clos + let scatter _ xs = map (VReg . pure) xs + distributeWork regs scatter sh grp <- delayGroup sh return $ VChan grp SActorGrp _ _ -> error "Only actor with one parameter are supported" @@ -594,22 +596,26 @@ ppr = \case sg <- ppr g return $ parens $ se <> comma <> sg List es -> pprList es - SDom i m r -> do ss <- case m of - Nothing -> return $ text "-" - Just v -> ppr v - return $ text (show r) <> text " " <> int i + SDom v dh par -> do + sv <- maybe (return $ text "-") ppr v + spar <- maybe (return $ text "-") ppr v + return $ hcat [ text "SDom " + , sv + , text (show dh) + , spar + ] SKern kb vars dom -> do vs <- pprList vars ds <- pprList dom return $ text "Kernel call" $$ nest 2 (vcat [ text (show kb), vs, ds ]) SSeq e1 e2 -> liftM2 ($$) (ppr e1) (ppr e2) - SSplit _ e -> do - s <- ppr e - return $ hcat [ text "SSplit {" - , s - , text "}" - ] + -- SSplit _ e -> do + -- s <- ppr e + -- return $ hcat [ text "SSplit {" + -- , s + -- , text "}" + -- ] SBind e lam -> do v <- fresh se <- ppr e diff --git a/MS5/dna-flow/Flow/Internal.hs b/MS5/dna-flow/Flow/Internal.hs index 973676c7..99ee0bf6 100644 --- a/MS5/dna-flow/Flow/Internal.hs +++ b/MS5/dna-flow/Flow/Internal.hs @@ -193,7 +193,7 @@ instance Eq DomainI where -- | Domains are just ranges for now. It is *very* likely that we are -- going to have to generalise this in some way. data Region = RangeRegion (Domain Range) Range - | BinRegion (Domain Bins) Bins + | BinRegion (Domain Bins) Bins deriving (Typeable, Generic) instance Show Region where diff --git a/MS5/ms5.cabal b/MS5/ms5.cabal index cfd7fcbe..5dacaa61 100644 --- a/MS5/ms5.cabal +++ b/MS5/ms5.cabal @@ -47,7 +47,9 @@ executable dotproduct-dna mtl, bound, pretty, + distributed-process, dna, + containers, unordered-containers, fixed-vector-hetero x-halide-sources: kernel/cpu/dotproduct/generate_f.cpp diff --git a/MS5/programs/dotproduct-dna.hs b/MS5/programs/dotproduct-dna.hs index 719b54f1..94628f90 100644 --- a/MS5/programs/dotproduct-dna.hs +++ b/MS5/programs/dotproduct-dna.hs @@ -30,6 +30,11 @@ import Bound import DNA (dnaRun,logMessage) +import Data.Dynamic +import Unsafe.Coerce +import qualified Data.Map as Map +import Control.Distributed.Process.Node (initRemoteTable) + -- Data tags data Vec deriving Typeable data Sum deriving Typeable @@ -181,6 +186,10 @@ main = do case ast3 of (MainActor dna, amap) -> let (rtable,prog) = interpretAST amap dna - in dnaRun rtable $ do logMessage "START" - void prog - logMessage "END" + in do return () + -- let m = unsafeCoerce $ rtable initRemoteTable :: Map.Map String Dynamic + -- mapM_ print $ Map.toList $ fmap dynTypeRep m + dnaRun rtable $ do + logMessage "START" + void prog + logMessage "END"