packages feed

Paraiso 0.0.0.0 → 0.1.0.0

raw patch · 41 files changed

+2944/−1182 lines, 41 filesdep +HUnitdep +ListLikedep +QuickCheckdep −repadep ~base

Dependencies added: HUnit, ListLike, QuickCheck, listlike-instances, process, random, test-framework, test-framework-hunit, test-framework-quickcheck2, text, typelevel-tensor, vector

Dependencies removed: repa

Dependency ranges changed: base

Files

Language/Paraiso.hs view
@@ -1,7 +1,8 @@ {-# OPTIONS -Wall #-}  -- | Paraiso main module.--- I think adding this will expose source for run?+-- This module will export a starter-kit modules and functions in the future,+-- but is useless right now.  module Language.Paraiso (run) where
+ Language/Paraiso/Annotation.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+-- | 'Annotation' is a collection of 'Typeable's +-- with which you can annotate each OM node.++module Language.Paraiso.Annotation+    (+     Annotation, add, empty, map, set, weakSet, toList, toMaybe+    ) where++import           Data.Dynamic+import           Data.Maybe+import           Language.Paraiso.Prelude hiding (map, toList)+import qualified Language.Paraiso.Prelude as P (map)++type Annotation = [Dynamic]++-- | An empty collection.+empty :: Annotation+empty = []++-- | Add an annotation to a collection.+add :: (Typeable a) => a -> Annotation -> Annotation+add x ys = toDyn x : ys++-- | Remove all elements of type @a@ from the collection, and+--   set @x@ as the only member of the type in the collection.+set :: (Typeable a) => a -> Annotation -> Annotation+set x ys = toDyn x : filter ((/= typeOf x) . dynTypeRep) ys++-- | set @x@ as the only member of the type in the collection,+-- only if no annotation of the same type pre-exists.+weakSet :: (Typeable a) => a -> Annotation -> Annotation+weakSet x ys +  | any ((== typeOf x) . dynTypeRep) ys = ys+  | otherwise                           = toDyn x : ys++++-- | Extract all annotations of type @a@ from +-- the collection.+toList :: (Typeable a) => Annotation -> [a]+toList =  catMaybes . P.map fromDynamic++-- | Extract the first annotation of the given type,+-- if it exists.+toMaybe :: (Typeable a) => Annotation -> Maybe a+toMaybe = msum . P.map fromDynamic++-- | Map all annotations of type @a@ to type @b@,+-- while leaving the others untouched.+map :: (Typeable a, Typeable b) => (a->b) -> Annotation -> Annotation+map f = P.map (maybeApply f)++maybeApply :: (Typeable a, Typeable b) => (a->b) -> Dynamic -> Dynamic+maybeApply f x =+    case dynApply (toDyn f) x of+      Just y  -> y+      Nothing -> x
+ Language/Paraiso/Annotation/Allocation.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+-- | An 'Annotation' that selects whether the data should be +-- stored globally on memory or to be calculated.++module Language.Paraiso.Annotation.Allocation (+  Allocation(..)+  ) where++import Data.Dynamic+import Language.Paraiso.Prelude++data Allocation +  = Existing -- ^ This entity is already allocated as a static variable.+  | Manifest -- ^ Allocate additional memory for this entity. +  | Delayed  -- ^ Do not allocate, re-compute it whenever if needed.+  deriving (Eq, Show, Typeable)
+ Language/Paraiso/Annotation/Balloon.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+-- | An 'Annotation' that sets the execution priority of the +-- statements. Statements with 'Ballon's will be allocated+-- as fast as possible, and statements with negative ballons, +-- or @Stone@s, will be allocated as later as possible.++module Language.Paraiso.Annotation.Balloon (+  Balloon(..)+  ) where++import Data.Dynamic+import Language.Paraiso.Prelude++data (Ord a, Typeable a) => Balloon a+    = Balloon a+      deriving (Eq, Ord, Typeable)
+ Language/Paraiso/Annotation/Boundary.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, NoImplicitPrelude, StandaloneDeriving, +UndecidableInstances #-}+{-# OPTIONS -Wall #-}++-- | calculate the 'Valid' regions of the 'Orthotope' where all information needed to update +--   the region is available.++module Language.Paraiso.Annotation.Boundary+    (+     Valid(..), NearBoundary(..)+    ) where++import Data.Dynamic+import Language.Paraiso.Prelude+import Language.Paraiso.Interval+import Language.Paraiso.PiSystem++-- | a type that represents valid region of computation.+newtype Valid g = Valid [Interval (NearBoundary g)] deriving (Eq, Show, Typeable)+               +instance (Ord g) => PiSystem (Valid g) where                                                            +  empty = error "empty set is undefined for type Valid"+  null = const False+  intersection (Valid xs) (Valid ys)+    | length xs /= length ys = error "length mismatch in merging two Valid"+    | otherwise              = Valid $ zipWith intersection xs ys+                                                             +-- | the displacement around either side of the boundary.+data NearBoundary a = NegaInfinity | LowerBoundary a | UpperBoundary a | PosiInfinity+              deriving (Eq, Ord, Show, Typeable)+
+ Language/Paraiso/Annotation/Comment.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+-- | An effectless 'Annotation' with a comment ++module Language.Paraiso.Annotation.Comment+    (+     Comment(..)+    ) where++import Data.Dynamic+import Language.Paraiso.Prelude++data Comment = Comment Text+             deriving (Eq, Show, Typeable)
+ Language/Paraiso/Annotation/Dependency.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+-- | An 'Annotation' that describes the dependency of the nodes+-- and labels certain group of Manifest nodes+-- that can safely be accessed simultaneously++module Language.Paraiso.Annotation.Dependency (+  Direct(..),+  Calc(..),+  Indirect(..),+  KernelWriteGroup(..), +  OMWriteGroup(..)+  ) where+++import           Data.Dynamic+import qualified Data.Graph.Inductive as FGL+import qualified Data.Set as Set+import           Language.Paraiso.Prelude++-- | The list of Manifest or Existing nodes that this node directly depends on.+-- Y directly depends on X if you need to read X in subroutine you calculate Y+newtype Direct+  = Direct [FGL.Node]+  deriving (Eq, Show, Typeable)+           +-- | The list of Manifest or Existing nodes that this node indirectly depends on.+-- Y indirectly depends on X if you need to calculate X before you calculace Y+newtype Indirect+  = Indirect [FGL.Node]+  deriving (Eq, Show, Typeable)++-- | The list of All nodes that this node directly depends on.+-- Y directly depends on X if you need to calculate X in subroutine you calculate Y+newtype Calc+  = Calc (Set.Set FGL.Node)+  deriving (Eq, Show, Typeable)++++-- | Write grouping, continuously numbered from [0 ..] .+-- The numbering starts from 0 for each kerenel in a Orthotope Machine.+data KernelWriteGroup+  = KernelWriteGroup {getKernelGroupID :: Int}+  deriving (Eq, Show, Typeable)++-- | Write grouping, continuously numbered from [0 ..] .+-- The numbering is unique in one Orthotope Machine.+data OMWriteGroup+  = OMWriteGroup {getOMGroupID :: Int}+  deriving (Eq, Show, Typeable)+
Language/Paraiso/Generator.hs view
@@ -1,35 +1,65 @@-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}+{-# LANGUAGE  FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings #-} {-# OPTIONS -Wall #-} -- | a general code generator definition. module Language.Paraiso.Generator     (-     Generator(..), Symbolable(..)+      generate, generateIO     ) where -import qualified Algebra.Additive as Additive-import qualified Algebra.Ring as Ring-import Language.Paraiso.Failure-import Language.Paraiso.POM-import Language.Paraiso.Tensor (Vector)+import qualified Language.Paraiso.Annotation            as Anot+import qualified Language.Paraiso.Generator.Claris      as C+import qualified Language.Paraiso.Generator.ClarisTrans as C+import qualified Language.Paraiso.Generator.Native      as Native+import qualified Language.Paraiso.Generator.OMTrans     as OM+import qualified Language.Paraiso.Generator.PlanTrans   as Plan+import           Language.Paraiso.Name+import qualified Language.Paraiso.OM                    as OM+import qualified Language.Paraiso.Optimization          as Opt+import           Language.Paraiso.Prelude+import qualified Data.Text                              as T+import qualified Data.Text.IO                           as T+import           System.Directory (createDirectoryIfMissing)+import           System.FilePath  ((</>)) --- | The definition for code generator.-class Generator gen where-  -- | The data that is daughter of gen; describes the code generation strategy.-  data Strategy gen :: *-  -- | Code generation.-  generate :: (Vector v, Ring.C g, Additive.C (v g), Ord (v g), Symbolable gen g) =>-              gen                    -- ^The code generator.-           -> POM v g (Strategy gen) -- ^The 'POM' sourcecode, annotated with 'Strategy'.-           -> FilePath               -- ^The directory name under which the files are to be generated.-           -> IO ()                  -- ^The act of generation. --- | The translation of Haskell symbols to other languages.-class (Generator gen) => Symbolable gen a where-    -- | Failure handling version of symbol translation.-    symbolF :: (Failure StringException f) =>-               gen      -- ^The 'Generator'.-            -> a        -- ^A Haskell object to be translated.-            -> f String -- ^The translation result which may fail.-    -- | Pure version, which may emit runtime error.-    symbol :: gen -> a -> String-    symbol gen0 a0 = unsafePerformFailure (symbolF gen0 a0)+-- | Perform the code generation and returns the list of written+-- filepaths and their contents, for your interest.+generateIO :: (Opt.Ready v g) => Native.Setup v g -> OM.OM v g Anot.Annotation -> IO [(FilePath, Text)]+generateIO setup om = do+  let dir = Native.directory setup+  createDirectoryIfMissing True dir+  forM (generate setup om) $ \ (fn, con) -> do+    let absfn = dir </> fn+    T.writeFile absfn con+    return (absfn, con)++-- | Generate the (filename, content) list from a code generation+-- setup and a orthotope machine definition.+    +generate :: (Opt.Ready v g) => Native.Setup v g -> OM.OM v g Anot.Annotation -> [(FilePath, Text)]+generate setup om =  +  [ (headerFn, C.translate C.headerFile prog),+    (cppFn   , C.translate C.sourceFile prog)+  ]+  where+    prog0 = +      Plan.translate setup $+      OM.translate setup om++    tlm0  = C.topLevel prog0+    prog = prog0{C.topLevel = tlm}++    tlm = addIfMissing pragmaOnce $ addIfMissing myHeader $ tlm0++    pragmaOnce = C.Exclusive C.HeaderFile $ C.StmtPrpr $ C.PrprPragma "once"+    myHeader   = C.Exclusive C.SourceFile $ C.StmtPrpr $ C.PrprInclude C.Quotation2 $ T.pack headerFn++    addIfMissing x xs = if x `elem` xs then xs else x:xs++    headerFn :: FilePath+    headerFn  = nameStr prog ++ ".hpp"+    cppFn     = nameStr prog ++ "." ++ sourceExt+    sourceExt = case Native.language setup of+      Native.CPlusPlus -> "cpp"+      Native.CUDA      -> "cu"+
− Language/Paraiso/Generator/Allocation.hs 
@@ -1,3 +0,0 @@-{-# OPTIONS -Wall #-}-module Language.Paraiso.Generator.Allocation(Allocation(..)) where-data Allocation = Manifest | Delayed | Auto deriving (Eq, Show)
+ Language/Paraiso/Generator/Claris.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses,+NoImplicitPrelude, OverloadedStrings, RankNTypes #-}+{-# OPTIONS -Wall #-}+-- | [CLARIS] C++-Like Abstract Representation of Intermediate Syntax.+--+--  Claris connects the higher-level concepts to native languages with+--  capability to describe C++ syntax such as classes and+--  containers. Claris also have support for extension made by+--  C++-like languages such as CUDA qualifier and kernel call.+--+-- The design goal of Claris is to cover the necessity of the code+-- generation and to make it simple. Claris is not designed for+-- syntatic correctness, and it's possible to describe a Claris code+-- that will cause a compile error in C++.+-- +-- In Claris, variables, functions and classes are described in a+-- unified manner that supports both the declaration and definition.+-- From that information, the declarations and definitions are+-- generated at appropriate places.++module Language.Paraiso.Generator.Claris (      +  Program(..),++  FileType(..),+  Statement(..), +  Preprocessing(..), +  TypeRep(..), typeOf, toDyn,+  Class(..), MemberDef(..), AccessModifier(..),+  Function(..), function, +  Qualifier(..), +  Var(..), +  Expr(..), Parenthesis(..)+  ) where+++import qualified Data.Dynamic as Dyn+import           Language.Paraiso.Name+import           Language.Paraiso.Prelude++-- | A Claris program.+data Program +  = Program +    { progName :: Name, -- ^ the name of the program+      topLevel :: [Statement]  -- ^ the top-level elements of the program.+    } +  deriving (Show)+instance Nameable Program where name = progName++-- | C++ class descriptions are separated to two files+data FileType +  = HeaderFile+  | SourceFile +  deriving (Eq, Show)++-- | C++ top-level statements +data Statement +  = StmtPrpr Preprocessing       -- ^ Preprosessor directive+  | UsingNamespace Name          -- ^ Name space declaration+  | ClassDef Class               -- ^ Class definition+  | FuncDef Function             -- ^ Function definition+  | VarDef Var                   -- ^ variable definition as an expression +  | VarDefCon Var [Expr]         -- ^ define a variable and call a constructor+  | VarDefSub Var Expr           -- ^ define a variable and substitute a value+  | StmtExpr Expr                -- ^ Expression+  | StmtWhile Expr [Statement]   -- ^ While loop+  | StmtFor Statement Expr Expr +    [Statement]                  -- ^ For loop+  | StmtReturn Expr              -- ^ return +  | Exclusive FileType Statement -- ^ A statement that is included exclusively +                                 --   in either of the file type+  +  | RawStatement Text            -- ^ text directly embedded into source code+  | Comment Text                 -- ^ a comment+  deriving (Eq, Show)                    ++-- | Preprocessor directive +data Preprocessing+  = PrprInclude Parenthesis Text+  | PrprPragma Text+  deriving (Eq, Show)    ++-- | C++ class+data Class +  = Class +    { className :: Name,+      classMember :: [MemberDef]+    }+  deriving (Eq, Show)+instance Nameable Class where name = className++-- | C++ class member definition+data MemberDef +  = MemberFunc+    { memberAccess :: AccessModifier,+      inlined      :: Bool,+      memberFunc   :: Function+    }  -- ^ A member function+  | MemberVar +    { memberAccess :: AccessModifier, +      memberVar :: Var+    }-- ^ A member variable+  deriving (Eq, Show)++-- | C++ class member access modifier+data AccessModifier = Private | Protected | Public+  deriving (Eq, Show)++-- | C++ syntax for variable definition+++-- | C++ function definition+data Function +  = Function +    { funcName :: Name, +      funcType :: TypeRep,+      funcArgs :: [Var],+      funcBody :: [Statement], +      funcMemberInitializer :: [Expr]+    }+  deriving (Eq, Show)+instance Nameable Function where name = funcName++-- | A default function maker+function :: TypeRep -> Name ->  Function+function tr na = Function+  { funcName = na,+    funcType = tr,+    funcArgs = [],+    funcBody = [],+    funcMemberInitializer = []+  }++-- | description C++ type+data TypeRep +  = UnitType     Dyn.TypeRep -- ^ Types for simple objects+  | PtrOf        TypeRep     -- ^ Pointer type+  | RefOf        TypeRep     -- ^ Reference type+  | Const        TypeRep     -- ^ Constant type+  | TemplateType Text [TypeRep] -- ^ A template type+  | QualifiedType [Qualifier] TypeRep -- ^ Qualified type+  | ConstructorType                    +    -- ^ the type of mu which is returned from constructor / destructor  +  | UnknownType+    -- ^ the type of kuu that is detached from reincarnation+  deriving (Eq, Show)    ++-- | [CUDA extension] qualifiers to use accelerator+data Qualifier+  = CudaGlobal+  | CudaDevice+  | CudaHost+  | CudaShared+  | CudaConst+  deriving (Eq, Show)                        ++-- | C++ Variable definition+data Var = Var TypeRep Name deriving (Eq, Show)+instance Nameable Var where name (Var _ x) = x++-- | C++ Expression+data Expr+  = Imm Dyn.Dynamic -- ^ an immediate+  | VarExpr Var -- ^ an expression made of a variable+  | FuncCallUsr Name [Expr] -- ^ user function call+  | FuncCallStd Text [Expr] -- ^ builtin function call +  | CudaFuncCallUsr Name Expr Expr [Expr] -- ^ cuda function call with Grid topology+  | MemberAccess Expr Expr -- ^ access a member of an object+  | Op1Prefix Text Expr -- ^ prefix unary operator+  | Op1Postfix Text Expr -- ^ postfix unary operator+  | Op2Infix Text Expr Expr -- ^ infix binary operator+  | Op3Infix Text Text Expr Expr Expr -- ^ sandwiched trinity operator+  | ArrayAccess Expr Expr -- ^ access a component of an array+  | CommentExpr Text Expr -- ^ commented expr+  deriving (Show)++instance Eq Expr where+  (==)_ _= error "cannot compare Expr."++-- | make C++ type from Haskell objects+typeOf :: (Dyn.Typeable a) => a -> TypeRep+typeOf = UnitType . Dyn.typeOf++-- | make a C++ expression from Haskell objects+toDyn :: (Dyn.Typeable a) => a -> Expr+toDyn = Imm . Dyn.toDyn++-- | parentheses used in C+++data Parenthesis +  = Paren   -- ^ expression coupling, function call+  | Bracket -- ^ array access +  | Brace   -- ^ create a code block+  | Chevron -- ^ tepmplate type+  | Chevron2 -- ^ not used+  | Chevron3 -- ^ CUDA kernel call+  | Quotation  -- ^ character+  | Quotation2 -- ^ string+  | SlashStar  -- ^ comment+  deriving (Eq, Show)
+ Language/Paraiso/Generator/ClarisTrans.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE FlexibleContexts, ImpredicativeTypes,+MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings,+RankNTypes #-}++{-# OPTIONS -Wall #-}+module Language.Paraiso.Generator.ClarisTrans (      +  Translatable(..), paren, +  joinBy, joinEndBy, joinBeginBy, joinBeginEndBy, +  headerFile, sourceFile, Context+  ) where++import qualified Data.Dynamic as Dyn+import qualified Data.List as L+import qualified Data.ListLike as LL+import qualified Data.ListLike.String as LL+import           Language.Paraiso.Generator.Claris+import           Language.Paraiso.Name+import           Language.Paraiso.Prelude++class Translatable a where+  translate :: Context -> a -> Text++data Context +  = Context +    { fileType :: FileType,+      namespace :: [Namespace] -- inner scopes are in head of the list+    }+  deriving (Eq, Show)    +    +data Namespace = ClassSpace Class+  deriving (Eq, Show)+instance Nameable Namespace where +  name (ClassSpace x) = name x++headerFile :: Context+headerFile = Context {fileType = HeaderFile, namespace = []}++sourceFile :: Context+sourceFile = Context {fileType = SourceFile, namespace = []}+++instance Translatable Program where+  translate conf Program{topLevel = xs} = LL.unlines $ map (translate conf) xs++instance Translatable Statement where    +  translate conf stmt = case stmt of+    StmtPrpr   x            -> translate conf x ++ "\n"+    UsingNamespace x        -> "using namespace " ++ nameText x ++ ";"+    ClassDef  x             -> translate conf x +    FuncDef   x             -> translate conf x +    VarDef x                -> translate conf x ++ ";"    +    VarDefCon x args        -> translate conf x +++                               paren Paren (joinBy ", " $ map (translate conf) args) ++ ";"+    VarDefSub x rhs         -> translate conf x +++                               " = " ++ translate conf rhs  ++ ";"    +    StmtExpr x              -> translate conf x ++ ";"+    StmtReturn x            -> "return " ++ translate conf x ++ ";"+    StmtWhile test xs       -> "while" +      ++ paren Paren (translate conf test) +      ++ paren Brace (joinBeginEndBy "\n" $ map (translate conf) xs)+    StmtFor ini test inc xs -> "for" +      ++ paren Paren (joinBy " " [translate conf ini, translate conf test,";", translate conf inc]) +      ++ paren Brace (joinBeginEndBy "\n" $ map (translate conf) xs)+    Exclusive file stmt2    ->+      if file == fileType conf then translate conf stmt2 else ""+    RawStatement text       -> text+    Comment str             -> paren SlashStar str+      +instance Translatable Preprocessing where+  translate _ prpr = case prpr of+    PrprInclude par na -> "#include " ++ paren par na+    PrprPragma  str    -> "#pragma " ++ str++instance Translatable Class where+  translate conf me@(Class na membs) = if fileType conf == HeaderFile then classDecl else classDef+    where+      t :: Translatable a => a -> Text+      t = translate conf+      +      conf' = conf{namespace = ClassSpace me : namespace conf}+      +      classDecl = "class " ++ nameText na ++ +                  paren Brace (joinBeginEndBy "\n" $ map memberDecl membs) ++ ";"+      classDef  = joinBeginEndBy "\n" $ map memberDef membs+      +      memberDecl x = case x of+        MemberFunc ac inl f -> if inl +                               then t ac ++ " " ++ translate conf{ fileType = SourceFile } (FuncDef f)+                               else t ac ++ " " ++ t (FuncDef f)+        MemberVar  ac y -> t ac ++ " " ++ t (VarDef y)++      memberDef x = case x of+        MemberFunc _ inl f -> if inl then ""+                              else translate conf' (FuncDef f)+        MemberVar _ _ -> ""++instance Translatable AccessModifier where+  translate _ Private   = "private:"+  translate _ Protected = "protected:"+  translate _ Public    = "public:"+  +instance Translatable Function where+  translate conf f = ret+    where+      ret = if fileType conf == HeaderFile then funcDecl else funcDef+      funcDecl+        = LL.unwords+          [ translate conf (funcType f)+          , funcName'+          , paren Paren $ joinBy ", " $ map (translate conf) (funcArgs f)+          , ";"]+      funcDef +        = LL.unwords+          [ translate conf (funcType f)+          , funcName'+          , paren Paren $ joinBy ", " $ map (translate conf) (funcArgs f)+          , if null $ funcMemberInitializer f +            then ""+            else (": " ++) $ joinBy "," $ map (translate conf) $ funcMemberInitializer f +          , paren Brace $ joinBeginEndBy "\n" $ map (translate conf) $ funcBody f]+      funcName' = joinBy "::" $ reverse $ nameText f : map nameText (namespace conf)++instance Translatable TypeRep where+  translate conf trp = case trp of+    UnitType x         -> translate conf x+    PtrOf x            -> translate conf x ++ " *"+    RefOf x            -> translate conf x ++ " &"+    Const x            -> "const " ++ translate conf x +    TemplateType x ys  -> x ++ paren Chevron (joinBy ", " $ map (translate conf) ys) ++ " "+    QualifiedType qs x -> (joinEndBy " " $ map (translate conf) qs) ++ translate conf x+    ConstructorType    -> ""+    UnknownType        -> error "cannot translate unknown type."+  +instance Translatable Qualifier where  +  translate _ CudaGlobal = "__global__"+  translate _ CudaDevice = "__device__"+  translate _ CudaHost   = "__host__"+  translate _ CudaShared = "__shared__"+  translate _ CudaConst  = "__constant__"+++instance Translatable Dyn.TypeRep where  +  translate _ x = +    case msum $ map ($x) typeRepDB of+      Just str -> str+      Nothing  -> error $ "cannot translate Haskell type: " ++ show x++instance Translatable Dyn.Dynamic where  +  translate _ x = +    case msum $ map ($x) dynamicDB of+      Just str -> str+      Nothing  -> error $ "cannot translate value of Haskell type: " ++ show x++instance Translatable Var where+  translate conf (Var typ nam) = LL.unwords [translate conf typ, nameText nam]++instance Translatable Expr where+  translate conf expr = ret+    where+      pt  = paren Paren . translate conf+      t :: Translatable a => a -> Text+      t   = translate conf+      ret = case expr of+        Imm x                  -> t x+        VarExpr x              -> nameText x+        FuncCallUsr f args     -> (nameText f++) $ paren Paren $ joinBy ", " $ map t args+        FuncCallStd f args     -> (f++) $ paren Paren $ joinBy ", " $ map t args+        CudaFuncCallUsr  f numBlock numThread args +                               -> nameText f ++ paren Chevron3 (t numBlock ++ "," ++ t numThread) +++                                  (paren Paren $ joinBy ", " $ map t args)+        MemberAccess x y       -> pt x ++ "." ++ t y+        Op1Prefix op x         -> op ++ pt x+        Op1Postfix op x        -> pt x ++ op+        Op2Infix op x y        -> LL.unwords [pt x, op, pt y]+        Op3Infix op1 op2 x y z -> LL.unwords [pt x, op1, pt y, op2, pt z]+        ArrayAccess x y        -> pt x ++ paren Bracket (t y)+        CommentExpr str x      -> t x ++ " " ++ paren SlashStar str ++ " "+-- | The databeses for Haskell -> Cpp type name translations.+typeRepDB:: [Dyn.TypeRep -> Maybe Text]+typeRepDB = map fst symbolDB++-- | The databeses for Haskell -> Cpp immediate values translations.+dynamicDB:: [Dyn.Dynamic -> Maybe Text]+dynamicDB = map snd symbolDB++-- | The united database for translating Haskell types and immediate values to Cpp+symbolDB:: [(Dyn.TypeRep -> Maybe Text, Dyn.Dynamic -> Maybe Text)]+symbolDB = [ +  add "void"          (\() -> ""),+  add "bool"          (\x->if x then "true" else "false"),+  add "int"           (showT::Int->Text), +  add "long long int" (showT::Integer->Text), +  add "float"         ((++"f").showT::Float->Text), +  add "double"        (showT::Double->Text),+  add "std::string"   (showT::String->Text),+  add "std::string"   (showT::Text->Text)+       ]  +  where+    add ::  (Dyn.Typeable a) => Text -> (a->Text) +        -> (Dyn.TypeRep -> Maybe Text, Dyn.Dynamic -> Maybe Text)+    add = add' undefined+    add' :: (Dyn.Typeable a) => a -> Text -> (a->Text) +        -> (Dyn.TypeRep -> Maybe Text, Dyn.Dynamic -> Maybe Text)+    add' dummy typename f = +      (\tr -> if tr == Dyn.typeOf dummy then Just typename else Nothing,+       fmap f . Dyn.fromDynamic)+++-- | an parenthesizer for lazy person.+paren :: Parenthesis -> Text -> Text+paren p str = prefix ++ str ++ suffix+  where+    (prefix,suffix) = case p of+      Paren      -> ("(",")")+      Bracket    -> ("[","]")+      Brace      -> ("{","}")+      Chevron    -> ("<",">")+      Chevron2   -> ("<<",">>")+      Chevron3   -> ("<<<",">>>")+      Quotation  -> ("\'","\'")+      Quotation2 -> ("\"","\"")+      SlashStar  -> ("/*","*/")      ++joinBy :: Text -> [Text] -> Text+joinBy sep xs = LL.concat $ L.intersperse sep xs++joinEndBy :: Text -> [Text] -> Text+joinEndBy sep xs = joinBy sep xs ++ sep++joinBeginEndBy :: Text -> [Text] -> Text+joinBeginEndBy sep xs = sep ++ joinBy sep xs ++ sep++joinBeginBy :: Text -> [Text] -> Text+joinBeginBy sep xs = sep ++ joinBy sep xs ++
− Language/Paraiso/Generator/Cpp.hs 
@@ -1,677 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, -  MultiParamTypeClasses, NoImplicitPrelude,-  TypeFamilies #-}-{-# OPTIONS -Wall #-}--- | a generic code generator definition.-module Language.Paraiso.Generator.Cpp-    (-     module Language.Paraiso.Generator,-     Cpp(..), autoStrategy, decideStrategy-    ) where--import qualified Algebra.Additive as Additive-import qualified Algebra.Ring as Ring-import           Control.Monad.State (State)-import qualified Control.Monad.State as State-import           Data.Dynamic (Dynamic, Typeable, TypeRep, fromDynamic, typeOf)-import qualified Data.Graph.Inductive as FGL-import qualified Data.List as List-import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.Maybe (fromJust, listToMaybe)-import           Language.Paraiso.Failure -import           Language.Paraiso.Generator-import qualified Language.Paraiso.Generator.Allocation as Alloc-import qualified Language.Paraiso.OM.Arithmetic as A-import           Language.Paraiso.OM.DynValue as DVal-import           Language.Paraiso.OM.Graph-import           Language.Paraiso.OM.Realm (Realm(..))-import qualified Language.Paraiso.OM.Reduce as Reduce-import           Language.Paraiso.Prelude-import           Language.Paraiso.POM as POM-import           Language.Paraiso.Tensor-import           System.Directory (createDirectoryIfMissing)-import           System.FilePath  ((</>))---- | The c++ code generator.-data Cpp = Cpp deriving (Eq, Show)--autoStrategy :: Strategy Cpp-autoStrategy = CppStrategy Alloc.Auto--instance Generator Cpp where-  data Strategy Cpp = CppStrategy { -    allocStrategy :: Alloc.Allocation -                       } deriving (Eq, Show)-                                  -  generate _ pom0 path = do-    let -      pom1 = decideStrategy pom0-      members = makeMembers pom1-      headerFn = nameStr pom1 ++ ".hpp"-      cppFn = nameStr pom1 ++ ".cpp"-    createDirectoryIfMissing True path-    writeFile (path </> headerFn) $ genHeader members pom1-    writeFile (path </> cppFn) $ genCpp headerFn members pom1---{----                                                                -----}-{---- Translations of names, symbols, types and values               -----}-{----                                                                -----}--instance Symbolable Cpp Int where-  symbolF Cpp x = return (show x)--instance Symbolable Cpp Dynamic where-  symbolF Cpp dyn = let-    ret = msum $ map ($dyn) dynamicDB-   in case ret of-      Just str -> return str-      Nothing -> failure $ StringException $ -                 "Cpp cannot translate symbol of type: " ++ show dyn-  -instance Symbolable Cpp TypeRep where-  symbolF Cpp tr = let-    ret = msum $ map ($tr) typeRepDB-   in case ret of-      Just str -> return str-      Nothing -> failure $ StringException $ -                 "Cpp cannot translate type: " ++ show tr-  --instance Symbolable Cpp DVal.DynValue where-  symbolF Cpp dyn0 = do-    let-      container :: String -> String-      container = case DVal.realm dyn0 of-                    Global -> id-                    Local -> ("std::vector<"++).(++">")-    type0 <- symbolF Cpp $ DVal.typeRep dyn0-    return $ container type0--instance Symbolable Cpp Name where-  symbolF Cpp = return . nameStr-  --- | The databeses for Haskell -> Cpp immediate values translations.-dynamicDB:: [Dynamic -> Maybe String]-dynamicDB = map fst symbolDB---- | The databeses for Haskell -> Cpp type name translations.-typeRepDB:: [TypeRep -> Maybe String]-typeRepDB = map snd symbolDB--symbolDB:: [(Dynamic -> Maybe String, TypeRep -> Maybe String)]-symbolDB = [ -     add "bool" (\x->if x then "true" else "false"),-     add "int" (show::Int->String), -     add "long long int" (show::Integer->String), -     add "float" ((++"f").show::Float->String), -     add "double" (show::Double->String)-          ]  -  where-    add ::  (Typeable a) => String -> (a->String) -        -> (Dynamic -> Maybe String, TypeRep -> Maybe String)-    add = add' undefined-    add' :: (Typeable a) => a -> String -> (a->String) -        -> (Dynamic -> Maybe String, TypeRep -> Maybe String)-    add' dummy typename f = -      (fmap f . fromDynamic, -       \tr -> if tr==typeOf dummy then Just typename else Nothing)--{----                                                                -----}-{---- Make decisions on code generation strategies                   -----}-{----                                                                -----}--decideStrategy :: (Vector v, Ring.C g) => -                  POM v g (Strategy Cpp)-               -> POM v g (Strategy Cpp)-decideStrategy = POM.mapGraph dSGraph-  where-    dSGraph :: (Vector v, Ring.C g) => -               Graph v g (Strategy Cpp)-            -> Graph v g (Strategy Cpp)-    dSGraph graph = FGL.gmap -      (\(pre,n,lab,suc) -> (pre,n,fmap (modify graph n) lab,suc)) graph--    modify :: (Vector v, Ring.C g) => -              Graph v g (Strategy Cpp) -           -> FGL.Node-           -> Strategy Cpp-           -> Strategy Cpp-    modify graph n (CppStrategy alloc) = CppStrategy alloc'-      where-        alloc' = if alloc /= Alloc.Auto -                 then alloc-                 else decideAlloc graph n-    decideAlloc :: (Vector v, Ring.C g) => -                   Graph v g (Strategy Cpp) -                -> FGL.Node-                -> Alloc.Allocation-    decideAlloc graph n = -      if isGlobal || afterLoad || isStore -         || beforeReduce || afterReduce -         || (False &&( beforeShift && afterShift))-      then Alloc.Manifest-      else Alloc.Delayed-        where-          self0 = FGL.lab graph n-          pre0  = FGL.lab graph =<<(listToMaybe $ FGL.pre graph n) -          suc0  = FGL.lab graph =<<(listToMaybe $ FGL.suc graph n) -          isGlobal  = case self0 of-                        Just (NValue (DVal.DynValue Global _) _) -> True-                        _                                        -> False-          afterLoad = case pre0 of-                        Just (NInst (Load _) _) -> True-                        _                       -> False-          isStore   = case self0 of-                        Just (NInst (Store _) _) -> True-                        _                        -> False-          beforeReduce = case suc0 of-                        Just (NInst (Reduce _) _) -> True-                        _                         -> False-          afterReduce = case pre0 of-                        Just (NInst (Reduce _) _) -> True-                        _                         -> False--          beforeShift = case suc0 of-                        Just (NInst (Shift _) _) -> True-                        _                         -> False-          afterShift = case pre0 of-                        Just (NInst (Shift _) _) -> True-                        _                         -> False---{----                                                                -----}-{---- c++ class header generation                                    -----}-{----                                                                -----}---- | Access type of c++ class members-data AccessType = ReadWrite | ReadInit | ReadDepend String--data CMember = CMember {accessType :: AccessType, memberDV :: (Named DynValue)}--instance Nameable CMember where-  name = name . memberDV---sizeName :: Name-sizeName = Name "size"-sizeNameCall :: String-sizeNameCall = (++"()") . nameStr $ sizeName--sizeForAxis :: (Vector v) => Axis v -> Name-sizeForAxis axis = Name $ "size" ++ show (axisIndex axis)-sizeForAxisCall :: (Vector v) => Axis v -> String-sizeForAxisCall = (++"()") . nameStr . sizeForAxis-   ---            -fglNodeName :: FGL.Node -> Name    -fglNodeName n = Name $ "a" ++ show n---makeMembers :: (Vector v, Ring.C g) => POM v g a -> [CMember]-makeMembers pom =  [sizeMember] ++ sizeAMembers ++ map (CMember ReadWrite) vals -  where-    vals = staticValues $ POM.setup pom--    f :: (Vector v, Ring.C g) => POM v g a -> v CMember-    f _ = compose (\axis -> CMember ReadInit (Named (sizeForAxis axis) globalInt))--    sizeMember :: CMember-    sizeMember = CMember (ReadDepend $ "return " ++ prod ++ ";") (Named sizeName globalInt)-    globalInt = DynValue Global (typeOf (undefined::Int))--    sizeAMembers :: [CMember]-    sizeAMembers = foldMap (:[]) $ f pom-    -    prod :: String-    prod = concat $ List.intersperse " * " $ map (\m -> nameStr m ++ "()") sizeAMembers--genHeader :: (Vector v, Ring.C g) => [CMember] -> POM v g a -> String-genHeader members pom = unlines[-  commonInclude ,-  "class " ++ nameStr pom ++ "{",-  decStr,-  readerStr,-  writerStr,-  "public:",-  constructorStr,-  kernelStr,-  "};"-                ]-  where-    declare (Named name0 dyn0) =-      symbol Cpp dyn0 ++ " " ++ symbol Cpp name0 ++ "_;"-    decStr = unlines $ ("private:" :) $ concat $ -      (flip map) members $ -      (\mem -> case accessType mem of-                 ReadDepend _ -> []-                 _            -> [declare $ memberDV mem])--    reader (ref',code) (Named name0 dyn0) =-      let name1 = symbol Cpp name0 in-      "const " ++ symbol Cpp dyn0 ++ " " ++ ref' ++ name1 ++ "() const { " ++ code name1 ++" }"-    readerCode n = "return " ++ n ++ "_ ;"-    readerStr = unlines $ ("public:" :) $ concat $ -      (flip map) members $ -      (\(CMember at dv) -> case at of-                            ReadDepend s -> [reader ("" ,const s)    dv]-                            _            -> [reader ("&",readerCode) dv])--    writer (ref',code) (Named name0 dyn0) =-      let name1 = symbol Cpp name0 in-      symbol Cpp dyn0 ++ " " ++ ref' ++ name1 ++ "() { " ++ code name1 ++" }"-    writerCode n = "return " ++ n ++ "_ ;"-    writerStr = unlines $ ("public:" :) $ concat $ -      (flip map) members $ -      (\(CMember at dv) -> case at of-                            ReadWrite -> [writer ("&" ,writerCode) dv]-                            _         -> [])--    initializer (Named name0 _) = let name1 = symbol Cpp name0 in-      name1 ++ "_(" ++ name1 ++ ")"-    initializeIfLocal (Named name0 dyn0) = let name1 = symbol Cpp name0 in-      if DVal.realm dyn0 == Global-      then []-      else [name1 ++ "_(" ++ sizeNameCall ++ ")"]-    initializerStr = concat $ List.intersperse "," $ concat $-      (flip map) members $ -      (\(CMember at dv) -> case at of-                            ReadInit  -> [initializer dv]-                            ReadWrite -> initializeIfLocal dv-                            _         -> [])-    cArg (Named name0 dyn0) = let name1 = symbol Cpp name0 in-      symbol Cpp dyn0 ++ " " ++ name1-    cArgStr = concat $ List.intersperse "," $ concat $-      (flip map) members $ -      (\(CMember at dv) -> case at of-                            ReadInit -> [cArg dv]-                            _        -> [])-    constructorStr = nameStr pom ++ " ( " ++ cArgStr ++ " ): " -                     ++ initializerStr ++ "{}"-    -    kernelStr = unlines $ map (\kernel -> "void " ++ nameStr kernel ++ " ();") $-                kernels pom---commonInclude :: String-commonInclude = unlines[-                 "#include <algorithm>",                 -                 "#include <cmath>",-                 "#include <vector>",-                 ""-                ]--{----                                                                -----}-{---- c++ kernel generating tools                                    -----}-{----                                                                -----}---- | A representation for Addressed Single Static Assignment.-data Cursor v g = -  -- | node number and shift-  CurLocal  { cursorToFGLNode :: FGL.Node, cursorToShift :: (v g)} |-  -- | node number -  CurGlobal { cursorToFGLNode :: FGL.Node }-              deriving (Eq, Ord)--instance Show (Cursor v g) where-  show (CurLocal n _) = "/*L " ++ show n ++ "*/"-  show (CurGlobal n ) = "/*G " ++ show n ++ "*/"-  -                       -data Context  = -    CtxGlobal |-    CtxLocal  Name     -- ^The name of the indexing variable.-    deriving (Eq, Ord, Show)--type BindingMap v g= Map (Cursor v g) String-data BinderState v g = BinderState {  -  context     :: Context,-  graphCtx    :: Graph v g (Strategy Cpp),-  bindings    :: BindingMap v g-    }              deriving (Show)--type Binder v g a = State (BinderState v g) a- -data HandSide = LeftHand | RightHand deriving (Eq, Show)--paren :: String -> String-paren x =  "(" ++ x ++ ")"--arithRep :: A.Operator -> [String] -> String-arithRep op = let-    unary symb [x] = paren $ unwords [symb,x]-    unary symb _   = error $ symb ++ "is not a unary operator!"-    infx symb [x,y] = paren $ unwords [x,symb,y]-    infx symb _     = error $ symb ++ "is not a binary operator, can't be infix!"-    func symb xs = symb ++ paren (List.concat $ List.intersperse "," xs)-    err = error $ "unsupported operator : " ++ show op-    selectMaker [x,y,z] = paren $ unwords [x,"?",y,":",z]-    selectMaker _       = error "select requires exactly 3 arguments."-  in case op of-    A.Add -> infx "+"-    A.Sub -> infx "-"-    A.Neg -> unary "-"-    A.Mul -> infx "*" -    A.Div -> infx "/" -    A.Inv -> unary "1/"-    A.Not -> unary "!"-    A.And -> infx "&&" -    A.Or -> infx "||" -    A.EQ -> infx "==" -    A.NE -> infx "!=" -    A.LT -> infx "<" -    A.LE -> infx "<=" -    A.GT -> infx ">" -    A.GE -> infx ">=" -    A.Max -> func "max"-    A.Min -> func "min"-    A.Abs -> func "abs"-    A.Signum -> err-    A.Select -> selectMaker-    A.Ipow -> func "pow"-    A.Pow -> func "pow"-    A.Madd -> err-    A.Msub ->  err-    A.Nmadd ->  err-    A.Nmsub ->  err-    A.Sqrt  -> func "sqrt"-    A.Exp   -> func "exp"-    A.Log   -> func "log"-    A.Sin   -> func "sin"-    A.Cos   -> func "cos"-    A.Tan   -> func "tan"-    A.Asin  -> func "asin"-    A.Acos  -> func "acos"-    A.Atan  -> func "atan"-    A.Sincos ->  err-            ---runBinder :: (Additive.C (v g)) =>-  Graph v g (Strategy Cpp) -> FGL.Node -> (Cursor v g -> Binder v g ()) -> String-runBinder graph0 n0 binder = unlines $ header ++  [bindStr] ++ footer-  where -    rlm = lhsRealm graph0 n0-    bindStr = unlines $ Map.elems $ bindings state-    state = snd $ State.runState (binder iniCur) ini-    -    iniCur = case rlm of-               Global -> CurGlobal n0-               Local  -> CurLocal  n0 Additive.zero-    ini = BinderState {-            context  = case rlm of -                         Global -> CtxGlobal-                         Local  -> CtxLocal $ Name "i",-            graphCtx = graph0,-            bindings = Map.empty-          }-    -    (header,footer) = case context state of-      CtxGlobal -> ([],[])-      CtxLocal loopIndex -> ([loop (symbol Cpp loopIndex) ++ " {"], ["}"])-    loop i =-      "for (int " ++ i ++ " = 0 ; " -                  ++ i ++ " < " ++ symbol Cpp sizeName ++ "() ; " -                  ++  "++" ++ i ++ ")"---reduceBinder :: (Additive.C (v g), Ord (v g), Symbolable Cpp g, Vector v) =>-                Reduce.Operator-             -> FGL.Node-             -> FGL.Node-             -> Binder v g String-reduceBinder op nInst nSrc = do-  graph <- bindersGraph-  let-    reduceCursor = CurGlobal nInst-    reducerName  = "reduce_" ++ show nInst;-    srcNode      = fromJust $ FGL.lab graph nSrc-    srcType      = case srcNode of-                     NValue dyn0 _ -> dyn0{DVal.realm = Global}-                     NInst _ _     -> error "cannot reduce over NInst"-    srcCursor    = CurLocal nSrc Additive.zero-    fun          = arithRep $ Reduce.toArith op-    i            = "i"-  rhs0 <- withLocalContext (Name "0") $ rightHandSide srcCursor-  rhs  <- withLocalContext (Name  i ) $ rightHandSide srcCursor-  bindingModify $ Map.insert reduceCursor $ unlines[-                              symbol Cpp srcType ++ " " ++ reducerName ++ " = " ++ rhs0 ++ ";", -                              "for (int " ++ i ++ " = 1 ; " -                              ++ i ++ " < " ++ sizeNameCall ++ "; " -                              ++  "++" ++ i ++ ") {",-                              reducerName ++ " = "++ fun [reducerName,rhs] ++ ";",-                             "}"]-  return reducerName---lhsRealm :: Graph v g (Strategy Cpp) -> FGL.Node -> Realm -lhsRealm graph n = -  case fromJust $ FGL.lab graph n of     -    NValue dyn0 _ -> DVal.realm dyn0-    NInst inst  _ -> -      case inst of-        Store _ -> lhsRealm graph $ head $ FGL.pre graph n-        _       -> undefined---bindersGraph :: Binder v g (Graph v g (Strategy Cpp))-bindersGraph =  fmap graphCtx State.get--bindersContext :: Binder v g Context-bindersContext = fmap context State.get--bindersMap :: Binder v g (BindingMap v g)-bindersMap = fmap bindings State.get---bindingModify :: (BindingMap v g -> BindingMap v g) -> Binder v g ()-bindingModify f = do-  s <- State.get-  m <- bindersMap-  State.put s{bindings = f m}--cursorToNode :: (Cursor v g) -> Binder v g (Node v g (Strategy Cpp))-cursorToNode cur = do-  graph <- bindersGraph-  return $ fromJust $ FGL.lab graph $ cursorToFGLNode cur--withLocalContext :: Name -> Binder v g a -> Binder v g a-withLocalContext name0 binder0 = do-  state0 <- State.get-  ctx0 <- bindersContext-  State.put state0{context = CtxLocal name0}-  ret <- binder0-  state1 <- State.get-  State.put state1{context = ctx0}-  return ret---- | add @cursor@ in the current binding, if missing.-addBinding :: (Vector v, Symbolable Cpp g, Additive.C (v g), Ord (v g)) => -              Cursor v g-           -> Binder v g ()-addBinding cursor = do -  graph <- bindersGraph-  m <- bindersMap-  if Map.member cursor m-     then return ()-     else do-       lhs <- leftHandSide cursor-       let-         -- any Node that has well-defined LHS must have one and only one pre Node.-         preNode = head $ FGL.pre graph(cursorToFGLNode cursor)-         preCursor = cursor{cursorToFGLNode = preNode}-       rhs <- rightHandSide preCursor-       bindingModify $ Map.insert cursor (lhs ++ " = " ++ rhs ++ ";")---cursorToSymbol :: (Vector v, Symbolable Cpp g, Additive.C (v g), Ord (v g)) =>-                  HandSide-               -> Cursor v g -               -> Binder v g String-cursorToSymbol side cur = do-  node <- cursorToNode cur-  ctx  <- bindersContext    -  case (cur,ctx) of-    (CurGlobal _, _) -> return $ makeName0 True node undefined undefined-    (_,CtxGlobal   ) -> return $ makeName0 True node undefined undefined-    (_,CtxLocal i  ) -> do-             let axer = \(ax, shiftAmount) -> do-                          idxStr <- rhsLoadIndex ax-                          return (ax, (idxStr, shiftAmount))  -             axes3 <- traverse axer $ compose (\ax -> (ax, cursorToShift cur!ax))-             return $ makeName0 False node axes3 i-  where-    makeName0 isG node axes3 i0 = if isG then nameStr name0 else prefix ++ nameStr name0 ++ suffix i0-      where-        name0 = case node of-                  NValue _ _   -> fglNodeName $ cursorToFGLNode cur-                  NInst inst _ -> case inst of-                                    Store name1 -> Name $ (++ "()") $ nameStr name1-                                    Load  name1 -> Name $ (++ "()") $ nameStr name1-                                    _           -> error $ "this Inst does not have symbol" -        typeDelayed = case node of-                        NValue dyn0 _ -> symbol Cpp dyn0{DVal.realm = Global}-                        _             -> error "no type"-        alloc = allocStrategy $ getA node -        prefix = if side == LeftHand && alloc == Alloc.Delayed -                 then "const " ++ typeDelayed ++ " " else ""-        isManifest = case alloc of-                       Alloc.Delayed  -> case node of-                                           NValue _ _ -> False-                                           _          -> True-                       _              -> True-                         -        suffix i = if isManifest then "[" ++ shiftStr i ++ "]" -                                 else foldMap cppoku (cursorToShift cur)-        cppoku = (("_"++).(map (\c->if c=='-' then 'm' else c)).symbol Cpp)-        -        shiftStr i = if shift == Additive.zero -                   then nameStr i-                   else fst (mapAccumR shiftAccum "" allAxes)-        allAxes  = fmap fst axes3-        idxAxes  = fmap (fst.snd) axes3-        shift    = fmap (snd.snd) axes3-    -        shiftedAxis ax = paren$-          (paren $ unwords [idxAxes ! ax, "+", symbol Cpp (shift ! ax),"+",sizeForAxisCall ax])-          ++ "%" ++ sizeForAxisCall ax-    -        shiftAccum str ax = -          if (axisIndex ax::Int) == dimension allAxes - 1-          then (shiftedAxis ax, ())-          else (unwords [shiftedAxis ax, "+", sizeForAxisCall ax , "*", paren str], ())-    -leftHandSide :: (Vector v, Symbolable Cpp g, Additive.C (v g), Ord (v g)) =>-                Cursor v g -> Binder v g String-leftHandSide = cursorToSymbol LeftHand--rightHandSide :: (Vector v, Symbolable Cpp g, Additive.C (v g), Ord (v g)) =>-                 Cursor v g -> Binder v g String-rightHandSide cur = do-  node0  <- cursorToNode cur-  case node0 of-    NInst inst _ -> rhsInst inst cur-    NValue _ _   -> do -               when (allocStrategy (getA node0) == Alloc.Delayed) $ addBinding cur -               cursorToSymbol RightHand cur---rhsInst :: (Vector v, Symbolable Cpp g, Additive.C (v g), Ord (v g)) =>-           Inst v g -> Cursor v g -> Binder v g String-rhsInst inst cursor = do-  graph <- bindersGraph-  let -    curNode    = cursorToFGLNode cursor-    -- FGL indices of all the preceding nodes.-    preNodes   = map snd $ List.sort $ -                 map (\(node, l) -> (l,node)) $ -                 FGL.lpre graph(curNode)-    -- Cursors of all the preceding nodes with context inherited from cursor.-    preCursors = map (\n -> cursor{cursorToFGLNode = n}) preNodes-    headCursor = head preCursors-    headNode   = cursorToFGLNode headCursor-  case inst of-    Imm dyn0    -> return $ symbol Cpp dyn0-    Load   _    -> cursorToSymbol RightHand cursor-    Store  _    -> error "Store has no RHS!"-    Reduce op   -> reduceBinder op curNode headNode-    Broadcast   -> cursorToSymbol RightHand (CurGlobal $ head preNodes)-{-    -    Shift vec   -> cursorToSymbol RightHand headCursor-                   {cursorToShift = vec + cursorToShift headCursor}--}-    Shift vec   -> rightHandSide headCursor{cursorToShift = vec + cursorToShift headCursor}-    LoadIndex a -> rhsLoadIndex a-    Arith op    -> do-              xs <- mapM rightHandSide preCursors-              return $ arithRep op xs--rhsLoadIndex :: (Vector v, Symbolable Cpp g, Additive.C (v g), Ord (v g)) =>-                Axis v -> Binder v g String-rhsLoadIndex axis = do-  ctx <- bindersContext-  let-      loopVar = case ctx of-                  CtxGlobal  -> error "cannot load index in gloabl context"-                  CtxLocal i -> nameStr i-      axesSmaller = List.filter (\ax -> axisIndex ax < axisIndex axis) (allAxes axis)-      divs = paren $ unwords $ List.intersperse "/" $  loopVar : map sizeForAxisCall axesSmaller-      ret =  paren $ unwords $ [divs , "%" ,sizeForAxisCall axis]-      allAxes axis1 = foldMap (:[]) $ compose (\axis' -> head [axis', axis1])--  return ret--{----                                                                -----}-{---- c++ kernel generation                                          -----}-{----                                                                -----}---genCpp :: (Vector v, Ring.C g, Additive.C (v g), Ord (v g),  Symbolable Cpp g) =>-          String -> [CMember] -> POM v g (Strategy Cpp) -> String-genCpp headerFn _ pom = unlines [-  "#include \"" ++ headerFn ++ "\"",-  "using namespace std;",-  "",-  kernelsStr-                       ]-  where-    classPrefix = nameStr pom ++ "::"-    kernelsStr = unlines $ map (declareKernel classPrefix) $-                kernels pom---declareKernel :: (Vector v, Ring.C g, Additive.C (v g), Ord (v g), Symbolable Cpp g) => -                 String -> Kernel v g (Strategy Cpp)-> String-declareKernel classPrefix kern = unlines [-  "void " ++ classPrefix ++ nameStr kern ++ " () {",-  declareNodes labNodes,-  substituteNodes labNodes,-  "return;",-  "}"-                     ]-  where-    graph = dataflow kern-    labNodes = FGL.labNodes graph--    declareNodes = unlines . concat . map declareNode-    declareNode (n, node) = case node of-        NInst _ _  -> []-        NValue _ (CppStrategy Alloc.Delayed) -> []-        NValue dyn0 _ -> [declareVal (nameStr $ fglNodeName n) dyn0]-    declareVal name0 dyn0 = let-        x = if DVal.realm dyn0 == Local -          then "(" ++ symbol Cpp sizeName ++ "())"-          else ""-      in symbol Cpp dyn0 ++ " " ++ name0 ++ x ++ ";"-    substituteNodes = unlines. concat . map substituteNode-    substituteNode (n, node) = case allocStrategy $ getA node of-                                 Alloc.Manifest -> [genSub n]-                                 _              -> []-    genSub n = -      runBinder graph n addBinding--        -
+ Language/Paraiso/Generator/Native.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE KindSignatures #-}+{-# OPTIONS -Wall #-}+-- | informations for generating native codes.+++module Language.Paraiso.Generator.Native (+  Setup(..), defaultSetup,+  Language(..)+  ) where++import qualified Language.Paraiso.Optimization as Opt++-- | the setups that needed to generate the native codes.+data Setup (vector :: * -> *) (gauge :: *)+  = Setup +    { language  :: Language, -- ^ the preferred native language+      directory :: FilePath, -- ^ the directory on which programs are to be generated+      optLevel  :: Opt.Level, -- ^ the intensity of optimization+      localSize :: vector gauge, -- ^ the dimension of the physically meaningful region+      cudaGridSize :: (Int, Int) -- ^ CUDA grid x block size (will be variable of subkernel in the future)+    }++defaultSetup :: (Opt.Ready v g) => v g -> Setup v g+defaultSetup sz+  = Setup +  { language = CPlusPlus,+    directory = "./",+    optLevel = Opt.O3,+    localSize = sz,+    cudaGridSize = (128, 128)+  }++data Language+  = CPlusPlus +  | CUDA +  deriving (Eq, Show)+
+ Language/Paraiso/Generator/OMTrans.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE  NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}++module Language.Paraiso.Generator.OMTrans (+  translate+  ) where++import qualified Algebra.Additive                       as Additive+import qualified Data.Graph.Inductive                   as FGL+import           Data.Maybe (catMaybes)+import qualified Data.Set                               as Set+import           Data.Tensor.TypeLevel+import qualified Data.Vector                            as V+import qualified Language.Paraiso.Annotation            as Anot+import qualified Language.Paraiso.Annotation.Allocation as Alloc+import qualified Language.Paraiso.Annotation.Boundary   as Boundary+import qualified Language.Paraiso.Annotation.Dependency as Dep+import qualified Language.Paraiso.Generator.Plan        as Plan+import qualified Language.Paraiso.Generator.Native      as Native+import qualified Language.Paraiso.Interval              as Interval+import           Language.Paraiso.Name+import qualified Language.Paraiso.OM                    as OM+import qualified Language.Paraiso.OM.DynValue           as DVal+import qualified Language.Paraiso.OM.Graph              as OM+import qualified Language.Paraiso.OM.Realm              as Realm+import qualified Language.Paraiso.Optimization          as Opt+import qualified Language.Paraiso.PiSystem              as Pi+import           Language.Paraiso.Prelude++++data Triplet v g +  = Triplet+  { tKernelIdx :: Int,+    tNodeIdx   :: FGL.Node,+    tNode      :: OM.Node v g Anot.Annotation+  } deriving (Show)++translate :: (Opt.Ready v g) =>+  Native.Setup v g -> OM.OM v g Anot.Annotation -> Plan.Plan v g Anot.Annotation+translate setup omBeforeOptimize = ret+  where+    ret = Plan.Plan +      { Plan.planName   = name om,+        Plan.setup      = OM.setup om,+        Plan.kernels    = OM.kernels om,+        Plan.storages   = storages,+        Plan.subKernels = subKernels,+        Plan.lowerMargin = validToLower $ storageValidUnited om,  +        Plan.upperMargin = validToUpper $ storageValidUnited om  +      }++    om = Opt.optimize (Native.optLevel setup) omBeforeOptimize++    storages = staticRefs V.++ manifestRefs +    subKernels = V.generate subKernelSize generateSubKernel++    staticRefs = +      V.imap (\idx sVar -> +               Plan.StorageRef { +                 Plan.storageRefParent = ret,+                 Plan.storageIdx       = Plan.StaticRef idx,+                 Plan.storageDynValue  = namee sVar+               } ) $+      OM.staticValues $ OM.setup om++    manifestRefs = +      V.map (\(Triplet kidx idx nd) -> +              Plan.StorageRef {+                Plan.storageRefParent = ret,+                Plan.storageIdx       = Plan.ManifestRef kidx idx,+                Plan.storageDynValue  = getDynValue nd+              } ) $+      manifestNodes ++    manifestNodes = -- the vector of (kernelID, nodeID, node) of      +      V.concatMap findManifest $ -- elements marked as Manifest, found in+      V.concat . V.toList $ -- a monolithic vector of +      V.imap (\kidx lns     -- triplet (kernelID, nodeID, node) built from+        -> V.fromList $ flip map lns (\(idx, n) -> Triplet kidx idx n)) $+      V.map FGL.labNodes $ -- the vector of lists of (idx, OM.Node) of+      V.map OM.dataflow  $ -- the graphs contained in+      OM.kernels om        -- the kernels of the om++    findManifest (Triplet kidx idx nd) = +      case Anot.toMaybe $ OM.getA nd of+        Just Alloc.Manifest -> V.fromList [Triplet kidx idx nd]+        _                   -> V.empty++    omWriteGroup = +      flip V.map manifestNodes $+        \ tri@(Triplet _ _ nd) -> case Anot.toMaybe $ OM.getA nd of+          Just omg@(Dep.OMWriteGroup _) -> omg+          Nothing -> error $ "OMWriteGroup missing : " ++ show tri++    getRealm (OM.NValue dv _) = DVal.realm dv+    getRealm _                = error $ "invalid request for Realm; probably a non-Value node is marked as Manifest"+    getDynValue (OM.NValue dv _) = dv+    getDynValue _                = error $ "invalid request for DVal; probably a non-Value node is marked as Manifest"++++    validToLower valid = let Boundary.Valid xs = valid in+      compose $ \ax -> case Interval.lower (xs !! (axisIndex ax)) of+        Boundary.NegaInfinity    -> Additive.zero+        Boundary.LowerBoundary x -> x+        _                        -> error $ "wrong lower Margin! : " +    validToUpper valid = negate $ let Boundary.Valid xs = valid in+      compose $ \ax -> case Interval.upper (xs !! (axisIndex ax)) of+        Boundary.PosiInfinity    -> Additive.zero+        Boundary.UpperBoundary x -> x+        _                        -> error "wrong upper Margin!"++    -- the intersection of the valid area of all the store instructions found in the om.+    storageValidUnited :: (Opt.Ready v g) =>+                       OM.OM v g Anot.Annotation -> Boundary.Valid g+    storageValidUnited _ = +      foldl1 Pi.intersection $+      concat $+      map findStoreValid $+      concat . V.toList $ -- a flat list made from+      V.map (map snd . FGL.labNodes) $ -- the vector of lists of OM.Node of+      V.map OM.dataflow  $ -- the graphs contained in+      OM.kernels om        -- the kernels of the om+      where+        findStoreValid nd = case nd of+          OM.NValue _ _ -> []+          OM.NInst (OM.Store _) a -> Anot.toList a+          OM.NInst _ _ -> []+++    subKernelSize = +      (1 +) $ +      maximum $ +      (-1 :) $+      V.toList $+      V.map Dep.getOMGroupID $+      omWriteGroup+++    generateSubKernel groupIdx = +      mkSubKernel groupIdx $+      V.ifilter (\i _ -> omWriteGroup V.! i == Dep.OMWriteGroup groupIdx) $+      manifestNodes ++    mkSubKernel groupIdx myNodes =+      Plan.SubKernelRef +      { Plan.subKernelParent = ret,+        Plan.kernelIdx       = (tKernelIdx $ myNodes V.! 0),+        Plan.omWriteGroupIdx = groupIdx,+        Plan.outputIdxs      = V.map tNodeIdx myNodes,+        Plan.inputIdxs       = inputs ,+        Plan.calcIdxs        = calcs,+        Plan.subKernelRealm  = skRealm,+        Plan.lowerBoundary   = validToLower $ skValid om,+        Plan.upperBoundary   = validToUpper $ skValid om+      }+      where+        inputs :: V.Vector FGL.Node+        inputs =+          V.fromList $ Set.toList $+          Set.unions $+          map (\(Dep.Direct xs) -> Set.fromList xs) $+          depDirects+        depDirects :: [Dep.Direct]+        depDirects = +          catMaybes $+          V.toList $+          V.map (Anot.toMaybe . OM.getA . tNode) myNodes++        calcs :: V.Vector FGL.Node+        calcs = +          V.fromList $ Set.toList $ +          Set.unions $+          map (\(Dep.Calc xset) -> xset) $+          depCalcs+        depCalcs :: [Dep.Calc]+        depCalcs = +          catMaybes $+          V.toList $+          V.map (Anot.toMaybe . OM.getA . tNode) myNodes++        skRealm :: Realm.Realm+        skRealm = +          assertAllSame $+          map (getRealm . tNode) $+          V.toList myNodes++        skValid :: (Opt.Ready v g) => OM.OM v g Anot.Annotation -> Boundary.Valid g+        skValid _ =+          assertAllSame $+          concat $+          map (Anot.toList . OM.getA . tNode) $+          V.toList myNodes          ++-- | check if all the elements are the same and returns it+assertAllSame :: Eq a => [a] -> a+assertAllSame xs = case xs of+  []     -> error "no elements!"+  (x:ys) -> if all (==x) ys then x+            else error "elements are different. mismatch."++++{-++      -------------+    /               \       \\ *** Exception: Prelude.undefined //+  /     _,'      `._  \              ______+ /    ( (X) )  ( (X) ) \            | |-   - + |        (__/\__)      |           | | |   |+ \         |rt++|      /            | | |   |+  \        `----'     /             | | |  _| +    '               '               | | | |  \+  /                    \            | | | |   |+ |    |                  \          | | | |   |+ \    -'''''''~       -'''''''~     |_|-  |   |+  \ ___(`)(`)`))     (`.(`)(`)`))        /_____\++++++                                                   /+         -------------                                  .+       /               \                         /    /+     /                   \           ______         /+    /                     \         \ |-   -               _ -+    |                      |         \| | |   |        _ - +    \                     /        __  | | |   |     +     \   _ -- -- -- -- -- -- --  /    \\\ | |  _|                 _ .+       '                .          ,_  ||| | | |  \       __  ---+      /      -- -- -- -- -- -- --.__ ..  | | |   |+     |                   \            | | |   |+                    -'''''''~        /_|-  |   |+                   (`.(`)(`)`))          /_____\++++++++++     .       '+             |      '+       \           /+    ----\----|--- /+  /      \   |   /\     +-- __       ___      \               ______+/     --  /     \ - -- -- -- -- -- -| |-   - +|        |  ,          ,            | | |   |+ \        \_ \_  ,--- -- -- -- -- --| | |   |+  \                   /             | | |  _| +    '               '               | | | |  \+  /                    \            | | | |   |+ |    |                  \          | | | |   |+ \    -'''''''~       -'''''''~     |_|-  |   |+  \ ___(`)(`)`))     (`.(`)(`)`))        /_____\+++++++-}
+ Language/Paraiso/Generator/Plan.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings #-}+{-# OPTIONS -Wall #-}++-- | Taking the optimized OM as the input,+-- The 'Plan' summarizes and fixes the detail of the code generation,+-- such as amount of memory to be allocated,+-- the extra subroutines which does internal calculations,+-- and decisions on which part of calculation each subroutines make+-- etc.++module Language.Paraiso.Generator.Plan (+  Plan(..),++  SubKernelRef(..), StorageRef(..), StorageIdx(..),++  dataflow, labNodesIn, labNodesOut, labNodesCalc,+  storageType                  +  ) where++import qualified Data.Graph.Inductive as FGL+import qualified Data.Vector as V+import           Language.Paraiso.Name+import qualified Language.Paraiso.OM.DynValue as DVal+import qualified Language.Paraiso.OM.Graph as OM+import qualified Language.Paraiso.OM.Realm as Realm+import           Language.Paraiso.Prelude+++-- | A data structure that contains all informations+-- for code generation.+data Plan v g a+  = Plan +    { planName   :: Name, -- ^ name of the plan+      setup      :: OM.Setup v g a, -- ^ OM setup, includes all static variables+      storages   :: V.Vector (StorageRef v g a), -- ^ Newly allocated Manifest variables+      kernels    :: V.Vector (OM.Kernel v g a), -- ^ kernels+      subKernels :: V.Vector (SubKernelRef v g a), -- ^ +      lowerMargin :: v g,+      upperMargin :: v g+    }++instance Nameable (Plan v g a) where name = planName    ++-- | a data that holds referrence to the Plan it belongs to.+class Referrer a b | a->b where+  parent :: a -> b++-- | subroutines that executes portion of a calculations for certain kernel+data SubKernelRef v g a+  = SubKernelRef+    { subKernelParent :: Plan v g a,+      kernelIdx       :: Int,+      omWriteGroupIdx :: Int,      +      inputIdxs       :: V.Vector FGL.Node,+      calcIdxs        :: V.Vector FGL.Node,+      outputIdxs      :: V.Vector FGL.Node,+      subKernelRealm  :: Realm.Realm,+      lowerBoundary   :: v g,+      upperBoundary   :: v g+    }++instance Referrer (SubKernelRef v g a) (Plan v g a) where+  parent = subKernelParent+instance Nameable (SubKernelRef v g a) where+  name x = mkName $ nameText (parent x) ++ "_sub_" ++ showT (omWriteGroupIdx x)+instance Realm.Realmable (SubKernelRef v g a) where+  realm = subKernelRealm++-- | refers to a storage required in the plan+data StorageRef v g a+  = StorageRef+  { storageRefParent :: Plan v g a,+    storageIdx       :: StorageIdx,+    storageDynValue  :: DVal.DynValue+  }++data StorageIdx +  = StaticRef   Int -- ^ (StatigRef plan i) = i'th static variable in the plan+  | ManifestRef Int FGL.Node -- ^ (ManifestRef plan i j) = j'th node of the i'th kernel in the plan+  deriving (Eq, Show)++instance Referrer (StorageRef v g a) (Plan v g a) where+  parent = storageRefParent+instance Nameable (StorageRef v g a) where+  name x = mkName $ case storageIdx x of+    StaticRef i     -> "static_" ++ showT i ++ "_" +++                       nameText (OM.staticValues (setup $ parent x) V.! i)+    ManifestRef i j -> "manifest_"  ++ showT i ++ "_" ++ showT j+instance Realm.Realmable (StorageRef v g a) where+  realm x = let DVal.DynValue r _ = storageDynValue x in r++dataflow :: SubKernelRef v g a -> OM.Graph v g a+dataflow ref = OM.dataflow $ (kernels $ parent ref) V.! (kernelIdx ref)++-- | a list of inputs the subroutine needs.+labNodesIn :: SubKernelRef v g a -> V.Vector(FGL.LNode (OM.Node v g a))+labNodesIn ref = +  flip V.map (inputIdxs ref) $+  \idx -> case FGL.lab (dataflow ref) idx of+    Just x  -> (idx, x)+    Nothing -> error $ "node [" ++ show idx ++ "] does not exist in kernel [" ++ show (kernelIdx ref) ++ "]"++-- | all the caclulations performed in the subroutine.+labNodesCalc :: SubKernelRef v g a -> V.Vector(FGL.LNode (OM.Node v g a))+labNodesCalc ref = +  flip V.map (calcIdxs ref) $+  \idx -> case FGL.lab (dataflow ref) idx of+    Just x  -> (idx, x)+    Nothing -> error $ "node [" ++ show idx ++ "] does not exist in kernel [" ++ show (kernelIdx ref) ++ "]"++-- | a list of outputs the subroutine makes.+labNodesOut :: SubKernelRef v g a -> V.Vector(FGL.LNode (OM.Node v g a))+labNodesOut ref = +  flip V.map (outputIdxs ref) $+  \idx -> case FGL.lab (dataflow ref) idx of+    Just x  -> (idx, x)+    Nothing -> error $ "node [" ++ show idx ++ "] does not exist in kernel [" ++ show (kernelIdx ref) ++ "]"++-- | get the DynValue description for a storage referrence.  +storageType :: StorageRef v g a -> DVal.DynValue+storageType +  StorageRef {+    storageRefParent = p,+    storageIdx       = StaticRef i+    } = namee $ (OM.staticValues $ setup p) V.! i+storageType +  StorageRef {+    storageRefParent = p,+    storageIdx       = ManifestRef i j+    } = case FGL.lab (OM.dataflow $ kernels p V.! i) j of+    Just (OM.NValue x _) -> x+    Just _               -> error $ "node [" ++ show j ++ "] in kernel [" ++ show i ++ "] is not a Value node" +    Nothing              -> error $ "node [" ++ show j ++ "] does not exist in kernel [" ++ show i ++ "]"+
+ Language/Paraiso/Generator/PlanTrans.hs view
@@ -0,0 +1,583 @@+{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, NoImplicitPrelude, +OverloadedStrings, TupleSections #-}+{-# OPTIONS -Wall #-}++module Language.Paraiso.Generator.PlanTrans (+  translate+  ) where+++import qualified Algebra.Additive                    as Additive+import           Data.Char+import           Data.Dynamic+import qualified Data.Graph.Inductive                as FGL+import           Data.List (sortBy)+import qualified Data.ListLike.String                as LL+import           Data.ListLike.Text ()+import           Data.Maybe+import qualified Data.Set                            as Set+import           Data.Tensor.TypeLevel+import qualified Data.Text                           as T+import qualified Data.Vector                         as V+import qualified Language.Paraiso.Annotation         as Anot+import qualified Language.Paraiso.Generator.Claris   as C+import qualified Language.Paraiso.Generator.Native   as Native+import qualified Language.Paraiso.Generator.Plan     as Plan+import qualified Language.Paraiso.OM.Arithmetic      as Arith+import qualified Language.Paraiso.OM.DynValue        as DVal+import qualified Language.Paraiso.OM.Graph           as OM+import qualified Language.Paraiso.OM.Realm           as Realm+import qualified Language.Paraiso.Optimization.Graph as Opt+import           Language.Paraiso.Name+import           Language.Paraiso.Prelude+++type AnAn = Anot.Annotation+data Env v g = Env (Native.Setup v g) (Plan.Plan v g AnAn)++-- translate the plan to Claris+translate :: Opt.Ready v g => Native.Setup v g -> Plan.Plan v g AnAn -> C.Program+translate setup plan = +  C.Program +  { C.progName = name plan,+    C.topLevel = +      map include stlHeaders ++ +      library env ++ +      comments +++      subHelperFuncs ++ +      [ C.ClassDef $ C.Class (name plan) $+        storageVars ++ +        constructorDef ++ +        memberFuncForSize env +++        subMemberFuncs ++ memberFuncs +      ]+  }+  where+    env = Env setup plan+    comments = (:[]) $ C.Comment $ LL.unlines [ +      "",+      "lowerMargin = " ++ showT (Plan.lowerMargin plan),+      "upperMargin = " ++ showT (Plan.upperMargin plan)+      ]++    constructorDef = +      (:[]) $+      C.MemberFunc C.Public True $+      (C.function  C.ConstructorType (name plan))+      { C.funcMemberInitializer = -- allocate memory for storage members+           concat $+           flip map storageVars $ \memb -> case memb of+             C.MemberVar _ var -> +               [C.FuncCallUsr (name var) [C.FuncCallStd "memorySize" []]]+             _ -> []+      }++    memberFuncs = +      V.toList $ +      V.imap (\idx ker -> makeFunc env idx ker) $ +      Plan.kernels plan++    subHelperFuncs = concat $ V.toList $ V.map snd $ subKernelFuncs   +    subMemberFuncs = concat $ V.toList $ V.map fst $ subKernelFuncs   +    subKernelFuncs = V.map (makeSubFunc env) $ Plan.subKernels plan+++    include = C.Exclusive C.HeaderFile . C.StmtPrpr . C.PrprInclude C.Chevron+    stlHeaders = case Native.language setup of+      Native.CPlusPlus -> ["algorithm", "cmath", "vector"]+      Native.CUDA      -> ["thrust/device_vector.h", "thrust/host_vector.h", "thrust/functional.h", "thrust/extrema.h", "thrust/reduce.h"]++    storageVars = +      V.toList $+      V.map storageRefToMenber $+      Plan.storages plan+    storageRefToMenber stRef =  +      C.MemberVar  C.Public $ +      C.Var +        (mkCppType env $ Plan.storageType stRef) +        (name stRef) ++-- Generate member functions that returns the sizes of the mesh+memberFuncForSize :: Opt.Ready v g => Env v g -> [C.MemberDef]+memberFuncForSize env@(Env setup plan) = +  makeMami False  "size" size ++ +  makeMami True "lowerMargin" lM ++   +  makeMami True "upperMargin" uM ++   +  makeMami False  "memorySize" memorySize+  where+    size = toList $ Native.localSize setup+    memorySize = toList $ Native.localSize setup + Plan.lowerMargin plan + Plan.upperMargin plan+    lM = toList $ Plan.lowerMargin plan+    uM = toList $ Plan.upperMargin plan++    makeMami alone label xs = +      (if not alone then (finale label xs :) else id)  $+      map (\(i,x) -> tiro (label ++  show i) x) $+      zip [(0::Int)..] xs++    tiro str ret =+      C.MemberFunc C.Public True $+      (C.function (C.typeOf (size!!0)) $ mkName $ T.pack str) +      { C.funcBody = +        [ C.StmtReturn (C.toDyn ret)+        ]+      }++    finale str xs = tiro str (product xs)+++makeFunc :: Opt.Ready v g => Env v g -> Int -> OM.Kernel v g AnAn -> C.MemberDef+makeFunc env@(Env setup plan) kerIdx ker = C.MemberFunc C.Public False $ + (C.function tVoid (name ker)) + { C.funcBody = kernelCalls ++ storeInsts+ }+ where+   graph = OM.dataflow ker++   kernelCalls = +     V.toList $+     V.map (\subker -> callSubKer subker $ V.map findVar $ +                       Plan.inputIdxs subker V.++ Plan.outputIdxs subker) $+     V.filter ((== kerIdx) . Plan.kernelIdx) $+     Plan.subKernels plan+   callSubKer subker xs = +     C.StmtExpr $+     C.FuncCallUsr (name subker) (V.toList xs)++   storeInsts = +     map swapStmt $+     concatMap (\(idx, nd) -> case nd of+               OM.NInst (OM.Store (OM.StaticIdx statIdx))_ -> [(idx, statIdx)] +               _ -> []) $+     FGL.labNodes graph++   swapStmt (idx, statIdx) = +     let preIdx = head $ FGL.pre graph idx in+     case (filter ((Plan.StaticRef statIdx==) . Plan.storageIdx) $ V.toList $ Plan.storages plan,+           filter ((Plan.ManifestRef kerIdx preIdx==) . Plan.storageIdx) $ V.toList $ Plan.storages plan) of+       ([stRef],[maRef]) -> +         C.StmtExpr $ C.Op2Infix "="+         (C.VarExpr $ C.Var (mkCppType env $ Plan.storageType stRef) (name stRef) )+         (C.VarExpr $ C.Var C.UnknownType (name maRef) )+       _ -> error $ "mismatch in storage phase: " ++ show (idx, statIdx) +   findVar idx = +     let +       loadIdx = +         listToMaybe $+         concat $+         map (\jdx -> +               case FGL.lab graph jdx of+                 Just (OM.NInst (OM.Load (OM.StaticIdx statIdx))_)-> [Plan.StaticRef statIdx] +                 _                                                -> []) $+         FGL.pre graph idx+       match stIdx+         | stIdx == Plan.ManifestRef kerIdx idx = True+         | Just stIdx == loadIdx                = True+         | otherwise                            = False+       stRef = V.head $ V.filter ( match . Plan.storageIdx ) $ Plan.storages plan+     in C.VarExpr $ C.Var +        (mkCppType env $ Plan.storageType stRef) +        (name stRef) +++-- | Create a subKernel: a member function that performs a portion of+--   actual calculations. It may also generate some helper functions+--   called from the subKernel body.+makeSubFunc :: Opt.Ready v g +            => Env v g +            -> Plan.SubKernelRef v g AnAn +            -> ([C.MemberDef], [C.Statement])+makeSubFunc env@(Env setup plan) subker = +  case Native.language setup of+    Native.CPlusPlus -> cppSolution+    Native.CUDA      -> cudaSolution+  where+    rlm = Realm.realm subker +    +    cudaHelperName = mkName $ nameText subker ++ "_inner"+    +    cudaBodys = +      if rlm == Realm.Global +      then []+      else+        (:[]) $+        C.FuncDef $+        (C.function +         (C.QualifiedType [C.CudaGlobal] tVoid) +         cudaHelperName)+        { C.funcArgs = +           makeRawSubArg env True  (Plan.labNodesIn subker) +++           makeRawSubArg env False (Plan.labNodesOut subker),+          C.funcBody = +          [ C.Comment $ LL.unlines +            [ "",+              "lowerMargin = " ++ showT (Plan.lowerBoundary subker),+              "upperMargin = " ++ showT (Plan.upperBoundary subker)+            ]+          ] ++ loopMaker env rlm subker+        }+    +    (gridDim, blockDim) = Native.cudaGridSize setup+    +    cudaSolution = +      (,cudaBodys) $+      (:[]) $+      C.MemberFunc C.Public False $ +      (C.function tVoid (name subker))+      { C.funcArgs = +         makeSubArg env True (Plan.labNodesIn subker) +++         makeSubArg env False (Plan.labNodesOut subker),+        C.funcBody = +          if rlm == Realm.Global +          then loopMaker env rlm subker+          else+            [ C.Comment $ LL.unlines +              [ "",+                "lowerMargin = " ++ showT (Plan.lowerBoundary subker),+                "upperMargin = " ++ showT (Plan.upperBoundary subker)+              ],+              C.StmtExpr $ C.CudaFuncCallUsr cudaHelperName (C.toDyn gridDim) (C.toDyn blockDim) $+              map takeRaw $ +              (V.toList $ Plan.labNodesIn subker) ++ (V.toList $ Plan.labNodesOut subker)+            ] +      }++    takeRaw (idx, nd)= +      case nd of+        OM.NValue typ _ -> +          extractor typ $+          C.VarExpr $+          C.Var (mkCppType env typ) (nodeNameUniversal idx)+        _ -> error "NValue expected" ++    extractor typ = case Realm.realm typ of+      Realm.Local ->           +        C.FuncCallStd "thrust::raw_pointer_cast" .+        (:[]) .+        C.Op1Prefix "&*" .+        flip C.MemberAccess (C.FuncCallStd "begin" []) +      Realm.Global ->+        id++    cppSolution = +      (,[]) $+      (:[]) $+      C.MemberFunc C.Public False $ +      (C.function tVoid (name subker))+      { C.funcArgs = +         makeSubArg env True (Plan.labNodesIn subker) +++         makeSubArg env False (Plan.labNodesOut subker),+        C.funcBody = +          if rlm == Realm.Global +          then loopMaker env rlm subker+          else+            [ C.Comment $ LL.unlines +              [ "",+                "lowerMargin = " ++ showT (Plan.lowerBoundary subker),+                "upperMargin = " ++ showT (Plan.upperBoundary subker)+              ]+            ] ++ loopMaker env rlm subker+      }++    +    +-- | make a subroutine argument list.+makeSubArg :: Opt.Ready v g => Env v g -> Bool -> V.Vector (FGL.LNode (OM.Node v g AnAn)) -> [C.Var]+makeSubArg env isConst lnodes =+  let f = (if isConst then C.Const else id) . C.RefOf+  in+  map (\(idx,nd)-> case nd of+            OM.NValue typ _ -> C.Var (f $ mkCppType env typ) (nodeNameUniversal idx)+            _ -> error "NValue expected" ) $+  V.toList lnodes++-- | make a subroutine argument list, using raw pointers.+makeRawSubArg :: Opt.Ready v g => Env v g -> Bool -> V.Vector (FGL.LNode (OM.Node v g AnAn)) -> [C.Var]+makeRawSubArg env isConst lnodes =+  let f = (if isConst then C.Const else id) +  in+  map (\(idx,nd)-> case nd of+          OM.NValue typ _ -> +            C.Var (f $ mkCudaRawType env typ) (nodeNameUniversal idx)+          _ -> error "NValue expected" ) $+  V.toList lnodes+++++-- | implement the loop for each subroutine+loopMaker :: Opt.Ready v g => Env v g -> Realm.Realm -> Plan.SubKernelRef v g AnAn -> [C.Statement]+loopMaker env@(Env setup plan) realm subker = case realm of+  Realm.Local ->+    pragma +++    [ C.StmtFor +      (C.VarDefSub loopCounter loopBegin) +      (C.Op2Infix "<"  (C.VarExpr loopCounter) loopEnd)+      (C.Op2Infix "+=" (C.VarExpr loopCounter) loopStride) $+      [C.VarDefSub addrCounter codecAddr] +++      loopContent+    ]+  Realm.Global -> loopContent++  where+    pragma = +      if Native.language setup == Native.CPlusPlus +      then [C.StmtPrpr $ C.PrprPragma "omp parallel for"]+      else []+    (loopBegin, loopEnd, loopStride) = case Native.language setup of+      Native.CPlusPlus -> (intImm 0, C.toDyn (product boundarySize), intImm 1)+      Native.CUDA -> (loopBeginCuda, C.toDyn (product boundarySize), loopStrideCuda)      +    loopBeginCuda = mkVarExpr "blockIdx.x * blockDim.x + threadIdx.x"+    loopStrideCuda   = mkVarExpr "blockDim.x * gridDim.x"    +    +    loopCounter = C.Var tSizet (mkName "i")+    memorySize   = toList $ Native.localSize setup + Plan.lowerMargin plan + Plan.upperMargin plan+    boundarySize = toList $ Native.localSize setup + Plan.lowerMargin plan + Plan.upperMargin plan+     - Plan.lowerBoundary subker - Plan.upperBoundary subker++    codecDiv = +      [ if idx == 0 then (C.VarExpr loopCounter) else C.Op2Infix "/" (C.VarExpr loopCounter) (C.toDyn $ product $ take idx boundarySize) +      | idx <- [0..length boundarySize-1]]+    codecMod = +      [ if idx == length codecDiv-1 then x else C.Op2Infix "%" x (C.toDyn $ boundarySize !! idx)+      | (idx, x) <- zip [0..] codecDiv]+    codecModAdd = +      [ C.Op2Infix "+" x (C.toDyn $ Plan.lowerMargin plan ! (Axis idx))+      | (idx, x) <- zip [0..] codecMod]+    codecAddr = +      if memorySize == boundarySize +      then C.VarExpr loopCounter+      else foldl1 (C.Op2Infix "+")+           [ C.Op2Infix "*" x (C.toDyn $ product $ take idx  memorySize)+           | (idx, x) <- zip [0..] codecModAdd]+    codecLoadIndex =+      [ C.Op2Infix "-" x (C.toDyn  ((Plan.lowerMargin plan - Plan.lowerBoundary subker) ! (Axis idx) ))+      | (idx, x) <- zip [0..] codecMod]+    codecLoadSize =+      [ C.toDyn  (Native.localSize setup ! (Axis idx) )+      | (idx, _) <- zip [0..] codecMod]+    codecCursor cursor = +      (C.Op2Infix "+" (C.VarExpr addrCounter) (C.toDyn summa))+      where+        summa = sum $+          [ cursor ! (Axis idx) * product (take idx memorySize)+          | (idx, _) <- zip [0..] memorySize]+++    addrCounter = C.Var tSizet (mkName "addr_origin")++    loopContent = +      concat $+      map buildExprs $+      filterVal $+      Set.toList allIdxSet++    buildExprs (idx, val@(DVal.DynValue r c)) = +      map (\cursor -> +            lhs cursor+            (fst $ rhsAndRequest env idx cursor)+          ) $+      Set.toList $ lhsCursors V.! idx+      where+        lhs cursor expr = +          if Set.member idx outputIdxSet+          then C.StmtExpr $ flip (C.Op2Infix "=") expr $ case realm of+            Realm.Local ->+              (C.ArrayAccess (C.VarExpr $ C.Var (C.UnitType c) (nodeNameUniversal idx)) (C.VarExpr addrCounter)) +            Realm.Global ->+              C.VarExpr $ C.Var (C.UnitType c) (nodeNameUniversal idx)+          else flip C.VarDefSub expr +               (C.Var (C.UnitType c) $ nodeNameCursored env idx cursor)++    -- lhsCursors :: (Opt.Ready v g) => V.Vector(Set.Set(v g))+    lhsCursors = V.generate idxSize f+      where +        f idx+          | not (Set.member idx allIdxSet) = Set.empty+          | Set.member idx outputIdxSet    = Set.singleton Additive.zero+          | otherwise                      = lhsRequest idx++    -- lhsRequests :: FGL.Node -> (Set.Set (v g))+    lhsRequest idx =+      Set.fromList $+      map snd $+      filter ((==idx) . fst) $+      concat $ +      [snd $ rhsAndRequest env jdx cur| +       jdx <- Set.toList allIdxSet, +       jdx > idx,+       cur <- Set.toList $ lhsCursors V.! jdx+       ]++    -- rhsAndRequest :: (Opt.Ready v g) => Env v g -> FGL.Node -> v g -> (C.Expr,[(Int, v g)])+    rhsAndRequest env' idx cursor = +      let (idxInst,inst) = case preInst idx of+            found:_ -> found+            _       -> error $ "right hand side is not inst:" ++ show idx+          prepre = map fst $ sortBy (\x y -> compare (snd x) (snd y)) $ FGL.lpre graph idxInst+          isInput = Set.member idx inputIdxSet+          creatVar idx' = C.VarExpr $ C.Var C.UnknownType (nodeNameUniversal idx')+        in case inst of+      _ | isInput     -> case realm of+        Realm.Local -> (C.ArrayAccess (creatVar idx) (codecCursor cursor), [])+        Realm.Global -> (creatVar idx, [])+      OM.Imm dyn      -> (C.Imm dyn, [])+      OM.Arith op     -> (rhsArith env' op (map (nodeToRhs env' cursor) prepre),  +                      map (,cursor) prepre)+      OM.Shift v      -> case prepre of+        [pre1] -> (nodeToRhs env' cursor' pre1, [(pre1,cursor')]) where cursor' = cursor - v+        _      -> error $ "shift has not 1 pre!" ++ show idxInst ++  show prepre+      OM.LoadIndex ax -> (codecLoadIndex !! axisIndex ax, [])+      OM.LoadSize  ax -> (codecLoadSize  !! axisIndex ax, [])+      OM.Reduce op    -> let fname = T.pack ("reduce_" ++ map toLower (show op)) in+        (C.FuncCallStd fname (map creatVar prepre), [])+      OM.Broadcast    -> let fname = "broadcast" in+        (C.FuncCallStd fname (map creatVar prepre), [])+      _               -> (C.CommentExpr ("TODO : " ++ showT inst) (C.toDyn (42::Int)), [])++    nodeToRhs env' cursor idx = C.VarExpr $ C.Var C.UnknownType $ nodeNameCursored env' idx cursor+++    preVal  = filterVal  . FGL.pre graph+    preInst = filterInst . FGL.pre graph+    sucVal  = filterVal  . FGL.suc graph+    sucInst = filterInst . FGL.suc graph++    filterVal  = concat . map (\(i,(xs,ys))-> map(i,)xs) . shiwake+    filterInst = concat . map (\(i,(xs,ys))-> map(i,)ys) . shiwake+    shiwake indices = +      map (\idx -> (idx,) $ case FGL.lab graph idx of+              Just (OM.NValue dval _) -> ([dval], [])+              Just (OM.NInst  inst _) -> ([], [inst])+              Nothing                 -> error $ "not in graph:" ++ show idx) $+      indices ++    idxSize = FGL.noNodes graph++    allIdxSet = Set.unions [inputIdxSet, outputIdxSet, calcIdxSet]+    inputIdxSet  = Set.fromList $ V.toList $ Plan.inputIdxs  subker+    outputIdxSet = Set.fromList $ V.toList $ Plan.outputIdxs subker+    calcIdxSet = Set.fromList $ V.toList $ Plan.calcIdxs subker    ++    graph = Plan.dataflow subker++-- | convert a DynValue to C type representation+mkCppType :: Opt.Ready v g => Env v g -> DVal.DynValue -> C.TypeRep+mkCppType env x = case x of+  DVal.DynValue Realm.Global c -> C.UnitType c+  DVal.DynValue Realm.Local  c -> containerType env c          ++containerType :: Env v g -> TypeRep -> C.TypeRep+containerType (Env setup _) c = case Native.language setup of+  Native.CPlusPlus -> C.TemplateType "std::vector" [C.UnitType c]+  Native.CUDA      -> C.TemplateType "thrust::device_vector" [C.UnitType c]+++-- | convert a DynValue to raw-pointer type representation +--   for example used within CUDA kernel+mkCudaRawType :: Opt.Ready v g => Env v g -> DVal.DynValue -> C.TypeRep+mkCudaRawType env x = case x of+  DVal.DynValue Realm.Global c -> C.UnitType c+  DVal.DynValue Realm.Local  c -> containerRawType env c          ++containerRawType :: Env v g -> TypeRep -> C.TypeRep+containerRawType (Env setup _) c = case Native.language setup of+  Native.CPlusPlus -> C.PtrOf $ C.UnitType c+  Native.CUDA      -> C.PtrOf $ C.UnitType c++++-- | a universal naming rule for a node.+nodeNameUniversal :: FGL.Node -> Name+nodeNameUniversal idx = mkName $ "a" ++ showT idx++++nodeNameCursored :: Opt.Ready v g => Env v g ->  FGL.Node -> v g -> Name+nodeNameCursored env idx cursor = mkName $ "a" ++ showT idx ++ "_" ++ +                                cursorToText env cursor++cursorToText :: Opt.Ready v g => Env v g ->  v g -> T.Text+cursorToText _ cursor = cursorT+  where+    cursorT :: T.Text+    cursorT = foldl1 connector $ compose (\i -> T.map sanitize $ showT (cursor ! i))+    connector a b = a ++ "_" ++ b+    sanitize c+      | isDigit c = c+      | c == '-'  = 'm'+      | c == '.'  = 'd'+      | otherwise = 'k'++++-- | Utility Types+intImm :: Int -> C.Expr+intImm = C.toDyn++tInt :: C.TypeRep+tInt = C.typeOf (undefined :: Int)++tSizet :: C.TypeRep+tSizet = C.typeOf (undefined :: Int)++mkVarExpr :: Text -> C.Expr+mkVarExpr = C.VarExpr . C.Var C.UnknownType . mkName++tVoid :: C.TypeRep+tVoid = C.typeOf ()++tHostVecInt :: C.TypeRep+tHostVecInt = C.TemplateType "thrust::host_vector" [tInt]++tDeviceVecInt :: C.TypeRep+tDeviceVecInt = C.TemplateType "thrust::device_vector" [tInt]++rhsArith :: Opt.Ready v g => Env v g -> Arith.Operator -> [C.Expr] -> C.Expr+rhsArith (Env setup _) op argExpr = case (op, argExpr) of+  (Arith.Identity, [x]) ->  x+  (Arith.Add    , [x,y]) -> C.Op2Infix "+" x y+  (Arith.Sub    , [x,y]) -> C.Op2Infix "-" x y+  (Arith.Neg    , [x]) -> C.Op1Prefix "-" x +  (Arith.Mul    , [x,y]) -> C.Op2Infix "*" x y+  (Arith.Div    , [x,y]) -> C.Op2Infix "/" x y+  (Arith.Mod    , [x,y]) -> C.Op2Infix "%" x y  +  (Arith.Inv    , [x]) -> C.Op1Prefix "1/" x +  (Arith.Not    , [x]) -> C.Op1Prefix "!" x   +  (Arith.And    , [x,y]) -> C.Op2Infix "&&" x y  +  (Arith.Or     , [x,y]) -> C.Op2Infix "||" x y  +  (Arith.EQ     , [x,y]) -> C.Op2Infix "==" x y  +  (Arith.NE     , [x,y]) -> C.Op2Infix "!=" x y    +  (Arith.LT     , [x,y]) -> C.Op2Infix "<" x y    +  (Arith.LE     , [x,y]) -> C.Op2Infix "<=" x y    +  (Arith.GT     , [x,y]) -> C.Op2Infix ">" x y    +  (Arith.GE     , [x,y]) -> C.Op2Infix ">=" x y    +  (Arith.Select , [x,y,z]) -> C.Op3Infix "?" ":" x y z   +  (Arith.Max    , [x,y])  -> C.FuncCallStd (nmsp "std::max" "max") [x,y]+  (Arith.Min    , [x,y])  -> C.FuncCallStd (nmsp "std::min" "min") [x,y]+  (Arith.Abs    , [x])  -> C.FuncCallStd "abs" [x]+  (Arith.Sqrt   , [x])  -> C.FuncCallStd "sqrt" [x]+  (Arith.Exp    , [x])  -> C.FuncCallStd "exp" [x]+  (Arith.Log    , [x])  -> C.FuncCallStd "log" [x]+  (Arith.Sin    , [x])  -> C.FuncCallStd "sin" [x]+  (Arith.Cos    , [x])  -> C.FuncCallStd "cos" [x]+  (Arith.Tan    , [x])  -> C.FuncCallStd "tan" [x]+  (Arith.Asin   , [x])  -> C.FuncCallStd "asin" [x]+  (Arith.Acos   , [x])  -> C.FuncCallStd "acos" [x]+  (Arith.Atan   , [x])  -> C.FuncCallStd "atan" [x]+  (Arith.Atan2  , [x,y])  -> C.FuncCallStd "atan2" [x,y]+  _ -> C.FuncCallStd (T.map toLower $ showT op) argExpr+  where+    nmsp a b = case Native.language setup of+      Native.CPlusPlus -> a+      Native.CUDA      -> b++library :: Opt.Ready v g => Env v g -> [C.Statement]+library (Env setup _) = (:[]) $ C.Exclusive C.SourceFile $ C.RawStatement $ lib+  where+    lib = case Native.language setup of+      Native.CPlusPlus -> cpuLib+      Native.CUDA      -> gpuLib+    cpuLib = "template <class T> T broadcast (const T& x) {\n  return x;\n}\ntemplate <class T> T reduce_sum (const std::vector<T> &xs) {\n  T ret = 0;\n  for (int i = 0; i < xs.size(); ++i) ret+=xs[i];\n  return ret;\n}\ntemplate <class T> T reduce_min (const std::vector<T> &xs) {\n  T ret = xs[0];\n  for (int i = 1; i < xs.size(); ++i) ret=std::min(ret,xs[i]);\n  return ret;\n}\ntemplate <class T> T reduce_max (const std::vector<T> &xs) {\n  T ret = xs[0];\n  for (int i = 1; i < xs.size(); ++i) ret=std::max(ret,xs[i]);\n  return ret;\n}\n"++    gpuLib =  "template <class T>\n__device__ __host__\nT broadcast (const T& x) {\n  return x;\n}\ntemplate <class T> T reduce_sum (const std::vector<T> &xs) {\n  T ret = 0;\n  for (int i = 0; i < xs.size(); ++i) ret+=xs[i];\n  return ret;\n}\ntemplate <class T> T reduce_min (const std::vector<T> &xs) {\n  T ret = xs[0];\n  for (int i = 1; i < xs.size(); ++i) ret=std::min(ret,xs[i]);\n  return ret;\n}\ntemplate <class T> T reduce_max (const std::vector<T> &xs) {\n  T ret = xs[0];\n  for (int i = 1; i < xs.size(); ++i) ret=std::max(ret,xs[i]);\n  return ret;\n}\n" ++ "template <class T> T reduce_sum (const thrust::device_vector<T> &xs) {\n  return thrust::reduce(xs.begin(), xs.end(), 0, thrust::plus<T>());\n}\ntemplate <class T> T reduce_min (const thrust::device_vector<T> &xs) {\n  return *(thrust::min_element(xs.begin(), xs.end()));\n}\ntemplate <class T> T reduce_max (const thrust::device_vector<T> &xs) {\n  return *(thrust::max_element(xs.begin(), xs.end()));\n}\n\n"
Language/Paraiso/Interval.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable, IncoherentInstances #-} {- | an 'Interval' is a pair of 'lower' and 'upper',     representing some interval in ordered system.    The lower bound is inclusive and the upper bound is exclusive:@@ -11,7 +11,7 @@ module Language.Paraiso.Interval (                                   Interval(..)) where -+import Data.Typeable import Language.Paraiso.PiSystem as S import Prelude hiding (null) @@ -20,6 +20,7 @@     Empty |      -- | a non-empty interval.     Interval{lower::a, upper::a}+    deriving (Eq, Show, Typeable)  instance (Ord a) => PiSystem (Interval a) where   empty = Empty@@ -31,9 +32,6 @@     let l = max l1 l2; u = min u1 u2; ret = Interval l u in     if null ret then Empty else ret -deriving instance (Eq a) => Eq (Interval a)                          -deriving instance (Show a) => Show (Interval a)   -deriving instance (Read a) => Read (Interval a)
Language/Paraiso/Name.hs view
@@ -4,21 +4,30 @@ -- | name identifier. module Language.Paraiso.Name    (-   Name(..), Named(..),+   Name, Named(..), mkName,    Nameable(..), namee   ) where import Control.Monad+import Data.Text (Text, unpack)  -- | a name.-newtype Name = Name String deriving (Eq, Ord, Show, Read)+newtype Name = Name Text deriving (Eq, Ord, Show, Read) +-- | create a name from a 'Text'. +-- We do not export the constructor 'Name' for future extensibility.+mkName :: Text -> Name+mkName x = Name x+ -- | something that has name. class Nameable a where   -- | get its name.   name :: a -> Name+  -- | get its name as a 'Text'.+  nameText :: a -> Text+  nameText = (\(Name str) -> str) . name   -- | get its name as a 'String'.   nameStr :: a -> String-  nameStr = (\(Name str) -> str) . name+  nameStr = unpack . (\(Name str) -> str) . name  -- | 'Name' has 'Name'. 'Name' of 'Name' is 'Name' itself.  instance Nameable Name where
+ Language/Paraiso/OM.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE  NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+module Language.Paraiso.OM+  (+    OM(..), makeOM+  ) where++import qualified Data.Vector as V+import           Language.Paraiso.Name+import           Language.Paraiso.OM.Builder (Builder, buildKernel)+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.OM.DynValue (DynValue)+import           NumericPrelude++-- | POM is Primordial Orthotope Machine.+data OM vector gauge anot +  = OM +    { omName :: Name,+      setup :: Setup vector gauge anot,+      kernels :: V.Vector (Kernel vector gauge anot)+    } +      deriving (Show)++instance Nameable (OM v g a) where+  name = omName++-- | create a POM easily and consistently.+makeOM :: +  Name                          -- ^The machine name.+  -> a                          -- ^The annotation at the root level.+  -> [Named DynValue]           -- ^The list of static variables.+  -> [(Name, Builder v g a ())] -- ^The list of pair of the kernel name and its builder.+  -> OM v g a                   -- ^The result.+makeOM name0 a0 vars0 kerns +  = OM {+    omName  = name0,+    setup   = setup0,+    kernels = V.fromList $ map (\(n,b) -> buildKernel setup0 n b) kerns+  }+  where+    setup0 = Setup { staticValues = V.fromList vars0, globalAnnotation = a0 }
Language/Paraiso/OM/Arithmetic.hs view
@@ -17,11 +17,16 @@ arityO = snd.arity    data Operator = +  Identity |   Add |   Sub |   Neg |   Mul |    Div |+  --DivRm |   TODO +  --DivRp |  +  Mod |+  DivMod |   Inv |   Not |   And |@@ -54,16 +59,20 @@   Asin |   Acos |   Atan |+  Atan2 |     Sincos    deriving (P.Eq, P.Ord, P.Show, P.Read)  instance Arity Operator where   arity a = case a of+    Identity -> (1,1)     Add -> (2,1)     Sub -> (2,1)     Neg -> (1,1)     Mul -> (2,1)     Div -> (2,1)+    Mod -> (2,1)+    DivMod -> (2,2)         Inv -> (1,1)     Not -> (1,1)     And -> (2,1)@@ -94,5 +103,6 @@     Asin -> (1,1)     Acos -> (1,1)     Atan -> (1,1)+    Atan2 -> (2,1)     Sincos -> (1,2)
Language/Paraiso/OM/Builder.hs view
@@ -9,9 +9,13 @@     (      Builder, BuilderState(..),      BuilderOf,-     makeKernel,+     buildKernel,+           load, store, imm,-     reduce, broadcast, shift, loadIndex+     reduce, broadcast, shift, +     loadIndex, loadSize,+     annotate, (<?>),+     withAnnotation     ) where  import Language.Paraiso.OM.Builder.Internal
Language/Paraiso/OM/Builder/Boolean.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, RankNTypes,+  TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -- | An extension module of building blocks. Contains booleans, comparison operations, branchings.  module Language.Paraiso.OM.Builder.Boolean   (eq, ne, lt, le, gt, ge, select) where -import qualified Algebra.Ring as Ring import Data.Dynamic (Typeable, typeOf) import qualified Language.Paraiso.OM.Arithmetic as A import Language.Paraiso.OM.Builder.Internal@@ -13,16 +13,15 @@ import Language.Paraiso.OM.Graph import Language.Paraiso.OM.Realm as Realm import Language.Paraiso.OM.Value as Val-import Language.Paraiso.Tensor import NumericPrelude    -- | generate a binary operator that returns Bool results.-mkOp2B :: (Vector v, Ring.C g, TRealm r, Typeable c) => +mkOp2B :: (TRealm r, Typeable c) =>            A.Operator                   -- ^The operation to be performed-       -> (Builder v g (Value r c))    -- ^The first argument-       -> (Builder v g (Value r c))    -- ^The second argument-       -> (Builder v g (Value r Bool)) -- ^The result+       -> (Builder v g a (Value r c))    -- ^The first argument+       -> (Builder v g a (Value r c))    -- ^The second argument+       -> (Builder v g a (Value r Bool)) -- ^The result mkOp2B op builder1 builder2 = do   v1 <- builder1   v2 <- builder2@@ -30,33 +29,39 @@       r1 = Val.realm v1   n1 <- valueToNode v1   n2 <- valueToNode v2-  n0 <- addNode [n1, n2] (NInst (Arith op) ())-  n01 <- addNode [n0] (NValue (toDyn v1){typeRep = typeOf True} ())+  n0 <- addNodeE [n1, n2] $ NInst (Arith op) +  n01 <- addNodeE [n0]    $ NValue (toDyn v1){typeRep = typeOf True}    return $ FromNode r1 True n01  -eq, ne, lt, le, gt, ge :: (Vector v, Ring.C g, TRealm r, Typeable c) => -                          (Builder v g (Value r c)) -> (Builder v g (Value r c)) -> (Builder v g (Value r Bool))+type CompareOp =  (TRealm r, Typeable c) => +    (Builder v g a (Value r c)) -> (Builder v g a (Value r c)) -> (Builder v g a (Value r Bool))  -- | Equal+eq :: CompareOp eq = mkOp2B A.EQ -- | Not equal+ne :: CompareOp ne = mkOp2B A.NE -- | Less than+lt :: CompareOp lt = mkOp2B A.LT -- | Less than or equal to+le :: CompareOp le = mkOp2B A.LE -- | Greater than+gt :: CompareOp gt = mkOp2B A.GT -- | Greater than or equal to+ge :: CompareOp ge = mkOp2B A.GE  -- | selects either the second or the third argument based -select ::(Vector v, Ring.C g, TRealm r, Typeable c) => -         (Builder v g (Value r Bool)) -- ^The 'Bool' condition-      -> (Builder v g (Value r c))    -- ^The value chosen when the condition is 'True'-      -> (Builder v g (Value r c))    -- ^The value chosen when the condition is 'False'-      -> (Builder v g (Value r c))    -- ^The result+select ::(TRealm r, Typeable c) => +         (Builder v g a (Value r Bool)) -- ^The 'Bool' condition+      -> (Builder v g a (Value r c))    -- ^The value chosen when the condition is 'True'+      -> (Builder v g a (Value r c))    -- ^The value chosen when the condition is 'False'+      -> (Builder v g a (Value r c))    -- ^The result select builderB builder1 builder2 = do   vb <- builderB   v1 <- builder1@@ -64,8 +69,8 @@   nb <- valueToNode vb   n1 <- valueToNode v1   n2 <- valueToNode v2-  n0 <- addNode [nb, n1, n2] (NInst (Arith A.Select) ())-  n01 <- addNode [n0] (NValue (toDyn v1) ())+  n0 <- addNodeE [nb, n1, n2] $ NInst (Arith A.Select) +  n01 <- addNodeE [n0] $ NValue (toDyn v1)    let        r1 = Val.realm v1       c1 = Val.content v1
Language/Paraiso/OM/Builder/Internal.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, -  RankNTypes, TypeSynonymInstances  #-}+{-# LANGUAGE FlexibleInstances, KindSignatures, NoImplicitPrelude, +  PackageImports, RankNTypes, TypeSynonymInstances  #-} {-# OPTIONS -Wall #-}  -- | A monadic library to build dataflow graphs for OM. @@ -11,81 +11,92 @@     (      Builder, BuilderState(..),      B, BuilderOf,-     makeKernel, initState,-     modifyG, getG, freeNode, addNode, valueToNode, lookUpStatic,+     buildKernel, initState, +     modifyG, getG, freeNode, addNode, addNodeE, valueToNode, lookUpStatic,      load, store,      reduce, broadcast,-     shift, loadIndex,-     imm, mkOp1, mkOp2+     shift, loadIndex,loadSize,+     imm, mkOp1, mkOp2,+     annotate, (<?>),+     withAnnotation     ) where import qualified Algebra.Absolute as Absolute import qualified Algebra.Additive as Additive import qualified Algebra.Algebraic as Algebraic import qualified Algebra.Field as Field+import qualified Algebra.IntegralDomain as IntegralDomain  import qualified Algebra.Lattice as Lattice import qualified Algebra.Ring as Ring import qualified Algebra.Transcendental as Transcendental import qualified Algebra.ZeroTestable as ZeroTestable-import Control.Monad-import qualified Control.Monad.State as State+import           Control.Monad+import qualified "mtl" Control.Monad.State as State import qualified Data.Graph.Inductive as FGL-import Data.Dynamic (Typeable)+import           Data.Dynamic (Typeable) import qualified Data.Dynamic as Dynamic+import           Data.Tensor.TypeLevel+import qualified Data.Vector  as V+import           Language.Paraiso.Name import qualified Language.Paraiso.OM.Arithmetic as A-import Language.Paraiso.OM.DynValue as DVal-import Language.Paraiso.OM.Graph-import Language.Paraiso.OM.Realm as Realm-import Language.Paraiso.OM.Reduce as Reduce-import Language.Paraiso.OM.Value as Val-import Language.Paraiso.Prelude-import Language.Paraiso.Tensor+import           Language.Paraiso.OM.DynValue as DVal+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.OM.Realm as Realm+import           Language.Paraiso.OM.Reduce as Reduce+import           Language.Paraiso.OM.Value as Val+import           Language.Paraiso.Prelude import qualified Prelude (Num(..), Fractional(..)) -data BuilderState vector gauge = BuilderState -    { setup :: Setup vector gauge, -      target :: Graph vector gauge ()} deriving (Show)- -- | Create a 'Kernel' from a 'Builder' monad.-makeKernel :: (Vector v, Ring.C g) => -              Setup v g      -- ^The Orthotope machine setup.-           -> Name           -- ^The name of the kernel.-           -> Builder v g () -- ^The builder monad.-           -> Kernel v g ()  -- ^The created kernel.-makeKernel setup0 name0 builder0 = let+buildKernel :: +              Setup v g a      -- ^The Orthotope machine setup.+           -> Name             -- ^The name of the kernel.+           -> Builder v g a () -- ^The builder monad.+           -> Kernel v g a     -- ^The created kernel.+buildKernel setup0 name0 builder0 = let     state0 = initState setup0     graph = target $ snd $ State.runState builder0 state0   in Kernel{kernelName = name0, dataflow = graph}-       ++data BuilderState vector gauge anot = BuilderState +    { setup   :: Setup vector gauge anot, +      context :: BuilderContext anot,+      target  :: Graph vector gauge anot} deriving (Show)++data BuilderContext anot = +  BuilderContext +  { currentAnnotation :: anot } deriving (Show)+ -- | Create an initial state for 'Builder' monad from a OM 'Setup'.-initState :: Setup v g -> BuilderState v g+initState :: Setup v g a -> BuilderState v g a initState s = BuilderState {-                setup = s,-                target = FGL.empty+                setup   = s,+                context = BuilderContext{currentAnnotation = globalAnnotation s},+                target  = FGL.empty               }  -- | The 'Builder' monad is used to build 'Kernel's.-type Builder vector gauge val = -  State.State (BuilderState vector gauge) val-  +type Builder (vector :: * -> *) (gauge :: *) (anot :: *) (val :: *) = +  State.State (BuilderState vector gauge anot) val+ --  'Builder' needs to be an instance of 'Eq' to become an instance of  'Prelude.Num'  -instance Eq (Builder v g v2) where+instance Eq (Builder v g a ret) where   _ == _ = undefined --  'Builder' needs to be an instance of 'Show' to become an instance of  'Prelude.Num'  -instance Show (Builder v g v2) where+instance Show (Builder v g a ret) where   show _ = "<<REDACTED>>" -type B a = (Vector v, Ring.C g) => Builder v g a-type BuilderOf r c =  (Vector v, Ring.C g) => Builder v g (Value r c)+type B ret = forall (v :: * -> *) (g :: *) (a :: *). Builder v g a ret+type BuilderOf r c = forall (v :: * -> *) (g :: *) (a :: *).  Builder v g a (Value r c)  -- | Modify the dataflow graph stored in the 'Builder'.-modifyG :: (Vector v, Ring.C g) => -           (Graph v g () -> Graph v g ()) -- ^The graph modifying function.-               -> Builder v g ()          -- ^The state gets silently modified.+modifyG ::           +  (Graph v g a -> Graph v g a) -- ^The graph modifying function.+  -> Builder v g a ()                             -- ^The state gets silently modified. modifyG f = State.modify (\bs -> bs{target = f.target $ bs})  -- | Get the graph stored in the 'Builder'.-getG :: (Vector v, Ring.C g) => Builder v g (Graph v g ())+getG :: Builder v g a (Graph v g a) getG = fmap target State.get  -- | get the number of the next unoccupied 'FGL.Node' in the graph.@@ -93,18 +104,27 @@ freeNode = do   n <- fmap (FGL.noNodes) getG   return n-  + -- | add a node to the graph.-addNode :: (Vector v, Ring.C g) => -           [FGL.Node]     -- ^The list of dependent nodes. The order is recorded.-           -> Node v g () -- ^The new node to be added-           -> Builder v g FGL.Node+addNode :: +           [FGL.Node]             -- ^The list of dependent nodes. The order is recorded.+           -> Node v g a -- ^The new node to be added.+           -> Builder v g a FGL.Node addNode froms new = do   n <- freeNode   modifyG (([(EOrd i, froms !! i) | i <-[0..length froms - 1] ], n, new, []) FGL.&)   return n +-- | add a node to the graph with an empty Annotation.+addNodeE :: +           [FGL.Node]                             -- ^The list of dependent nodes. The order is recorded.+           -> (a -> Node v g a) -- ^The new node to be added, with Annotation missing.+           -> Builder v g a FGL.Node+addNodeE froms new' = do+  anot <- fmap (currentAnnotation . context) State.get+  addNode froms (new' anot) + -- | convert a 'Value' to a  valueToNode :: (TRealm r, Typeable c) => Value r c -> B FGL.Node valueToNode val = do@@ -114,24 +134,26 @@   case val of     FromNode _ _ n -> return n     FromImm _ _ -> do-             n0 <- addNode [] (NInst (Imm (Dynamic.toDyn con)) ())-             n1 <- addNode [n0] (NValue type0 ())+             n0 <- addNodeE []   $ NInst (Imm (Dynamic.toDyn con))+             n1 <- addNodeE [n0] $ NValue type0              return n1  -- | look up the 'Named' 'DynValue' with the correct name and type  -- is included in the 'staticValues' of the 'BuilderState'-lookUpStatic :: Named DynValue -> B ()+lookUpStatic :: Named DynValue -> B StaticIdx lookUpStatic (Named name0 type0)= do   st <- State.get    let-      vs :: [Named DynValue]+      vs :: V.Vector (Named DynValue)       vs = staticValues $ setup st-      matches = filter ((==name0).name) vs-      (Named _ type1) = head matches-  when (length matches == 0) $ fail ("no name found: " ++ nameStr name0)-  when (length matches > 1) $ fail ("multiple match found:" ++ nameStr name0)-  when (type0 /= type1) $ fail ("type mismatch; expected: " ++ show type1 ++ "; " +++      matches = V.filter (\(_,v)-> name v==name0) $ V.imap (\i v->(i,v)) vs+      (ret, Named _ type1) = if V.length matches /= 1 +                             then error (show (V.length matches)++" match found for '" ++ nameStr name0 ++ +                                         "' in " ++ show vs)+                             else V.head matches  +  when (type0 /= type1) $ error ("type mismatch; expected: " ++ show type1 ++ "; " ++                                 " actual: " ++ nameStr name0 ++ "::" ++ show type0)+  return $ StaticIdx ret  -- | Load from a static value. load :: (TRealm r, Typeable c) => @@ -143,86 +165,98 @@   let        type0 = mkDyn r0 c0       nv = Named name0 type0-  lookUpStatic nv-  n0 <- addNode [] (NInst (Load name0) ())-  n1 <- addNode [n0] (NValue type0 ())+  idx <- lookUpStatic nv+  n0 <- addNodeE []   $ NInst  (Load idx)+  n1 <- addNodeE [n0] $ NValue type0    return (FromNode r0 c0 n1)  -- | Store to a static value.-store :: (Vector v, Ring.C g, TRealm r, Typeable c) => +store :: (TRealm r, Typeable c) =>           Name                    -- ^The 'Name' of the static value to store.-      -> Builder v g (Value r c) -- ^The 'Value' to be stored.-      -> Builder v g ()          -- ^The result.+      -> Builder v g a (Value r c) -- ^The 'Value' to be stored.+      -> Builder v g a ()          -- ^The result. store name0 builder0 = do   val0 <- builder0   let        type0 = toDyn val0       nv = Named name0 type0-  lookUpStatic nv+  idx <- lookUpStatic nv   n0 <- valueToNode val0-  _ <- addNode [n0] (NInst (Store name0) ())+  _ <- addNodeE [n0] $ NInst (Store idx)    return ()   -- | Reduce over a 'TLocal' 'Value'  -- using the specified reduction 'Reduce.Operator' -- to make a 'TGlobal' 'Value'-reduce :: (Vector v, Ring.C g, Typeable c) => +reduce :: (Typeable c) =>            Reduce.Operator               -- ^The reduction 'Reduce.Operator'.-       -> Builder v g (Value TLocal c)  -- ^The 'TLocal' 'Value' to be reduced.-       -> Builder v g (Value TGlobal c) -- ^The 'TGlobal' 'Value' that holds the reduction result.+       -> Builder v g a (Value TLocal c)  -- ^The 'TLocal' 'Value' to be reduced.+       -> Builder v g a (Value TGlobal c) -- ^The 'TGlobal' 'Value' that holds the reduction result. reduce op builder1 = do    val1 <- builder1   let        c1 = Val.content val1       type2 = mkDyn TGlobal c1   n1 <- valueToNode val1-  n2 <- addNode [n1] (NInst (Reduce op) ())-  n3 <- addNode [n2] (NValue type2 ())+  n2 <- addNodeE [n1] $ NInst (Reduce op) +  n3 <- addNodeE [n2] $ NValue type2    return (FromNode TGlobal c1 n3)  -- | Broadcast a 'TGlobal' 'Value'  -- to make it a 'TLocal' 'Value'  -broadcast :: (Vector v, Ring.C g, Typeable c) => -             Builder v g (Value TGlobal c) -- ^The 'TGlobal' 'Value' to be broadcasted.-          -> Builder v g (Value TLocal c)  -- ^The 'TLocal' 'Value', all of them containing the global value.+broadcast :: (Typeable c) => +             Builder v g a (Value TGlobal c) -- ^The 'TGlobal' 'Value' to be broadcasted.+          -> Builder v g a (Value TLocal c)  -- ^The 'TLocal' 'Value', all of them containing the global value. broadcast builder1 = do    val1 <- builder1   let        c1 = Val.content val1       type2 = mkDyn TLocal c1   n1 <- valueToNode val1-  n2 <- addNode [n1] (NInst Broadcast ())-  n3 <- addNode [n2] (NValue type2 ())+  n2 <- addNodeE [n1] $ NInst Broadcast +  n3 <- addNodeE [n2] $ NValue type2    return (FromNode TLocal c1 n3)-  + -- | Shift a 'TLocal' 'Value' with a constant vector.-shift :: (Vector v, Ring.C g, Typeable c, Additive.C (v g)) => -         v g                          -- ^ The amount of shift  -      -> Builder v g (Value TLocal c) -- ^ The 'TLocal' Value to be shifted-      -> Builder v g (Value TLocal c) -- ^ The shifted 'TLocal' 'Value' as a result.+shift :: (Typeable c)+  => v g                            -- ^ The amount of shift  +  -> Builder v g a (Value TLocal c) -- ^ The 'TLocal' Value to be shifted+  -> Builder v g a (Value TLocal c) -- ^ The shifted 'TLocal' 'Value' as a result. shift vec builder1 = do   val1 <- builder1   let      type1 = toDyn val1     c1 = Val.content val1   n1 <- valueToNode val1-  n2 <- addNode [n1] (NInst (Shift (Additive.negate vec)) ())-  n3 <- addNode [n2] (NValue type1 ())+  n2 <- addNodeE [n1] $ NInst $ Shift vec+  n3 <- addNodeE [n2] $ NValue type1    return (FromNode TLocal c1 n3)  -- | Load the 'Axis' component of the mesh address, to a 'TLocal' 'Value'.-loadIndex :: (Vector v, Ring.C g, Typeable c) => +loadIndex :: (Typeable c) =>               c                            -- ^The 'Val.content' type.           -> Axis v                       -- ^ The axis for which index is required-          -> Builder v g (Value TLocal c) -- ^ The 'TLocal' 'Value' that contains the address as a result.+          -> Builder v g a (Value TLocal c) -- ^ The 'TLocal' 'Value' that contains the address as a result. loadIndex c0 axis = do   let type0 = mkDyn TLocal c0-  n0 <- addNode [] (NInst (LoadIndex axis) ())-  n1 <- addNode [n0] (NValue type0 ())+  n0 <- addNodeE []   $ NInst (LoadIndex axis)+  n1 <- addNodeE [n0] $ NValue type0    return (FromNode TLocal c0 n1) +-- | Load the 'Axis' component of the mesh size, to either a  'TGlobal' 'Value' or  'TLocal' 'Value'..+loadSize :: (TRealm r, Typeable c)+            => r                            -- ^ The 'TRealm'+            -> c                            -- ^The 'Val.content' type.+            -> Axis v                       -- ^ The axis for which the size is required+            -> Builder v g a (Value r c) -- ^ The 'TGlobal' 'Value' that contains the size of the mesh in that direction.+loadSize r0 c0 axis = do+  let type0 = mkDyn r0 c0+  n0 <- addNodeE []   $ NInst (LoadSize axis)+  n1 <- addNodeE [n0] $ NValue type0 +  return (FromNode r0 c0 n1) + -- | Create an immediate 'Value' from a Haskell concrete value.  -- 'TRealm' is type-inferred. imm :: (TRealm r, Typeable c) => @@ -231,26 +265,26 @@ imm c0 = return (FromImm unitTRealm c0)  -- | Make a unary operator-mkOp1 :: (Vector v, Ring.C g, TRealm r, Typeable c) => +mkOp1 :: (TRealm r, Typeable c) =>           A.Operator                -- ^The operator symbol-      -> (Builder v g (Value r c)) -- ^Input-      -> (Builder v g (Value r c)) -- ^Output              +      -> (Builder v g a (Value r c)) -- ^Input+      -> (Builder v g a (Value r c)) -- ^Output               mkOp1 op builder1 = do   v1 <- builder1   let        r1 = Val.realm v1       c1 = Val.content v1   n1 <- valueToNode v1-  n0 <- addNode [n1] (NInst (Arith op) ())-  n01 <- addNode [n0] (NValue (toDyn v1) ())+  n0 <-  addNodeE [n1] $ NInst (Arith op) +  n01 <- addNodeE [n0] $ NValue (toDyn v1)    return $ FromNode r1 c1 n01  -- | Make a binary operator-mkOp2 :: (Vector v, Ring.C g, TRealm r, Typeable c) => +mkOp2 :: (TRealm r, Typeable c) =>           A.Operator                -- ^The operator symbol -      -> (Builder v g (Value r c)) -- ^Input 1              -      -> (Builder v g (Value r c)) -- ^Input 2               -      -> (Builder v g (Value r c)) -- ^Output              +      -> (Builder v g a (Value r c)) -- ^Input 1              +      -> (Builder v g a (Value r c)) -- ^Input 2               +      -> (Builder v g a (Value r c)) -- ^Output               mkOp2 op builder1 builder2 = do   v1 <- builder1   v2 <- builder2@@ -259,28 +293,70 @@       c1 = Val.content v1   n1 <- valueToNode v1   n2 <- valueToNode v2-  n0 <- addNode [n1, n2] (NInst (Arith op) ())-  n01 <- addNode [n0] (NValue (toDyn v1) ())+  n0 <-  addNodeE [n1, n2] $ NInst (Arith op)+  n01 <- addNodeE [n0] $ NValue (toDyn v1)    return $ FromNode r1 c1 n01  +-- | Execute the builder under modifed annotation.+withAnnotation :: (a -> a) -> Builder v g a ret ->  Builder v g a ret+withAnnotation f builder1 = do+  stat0 <- State.get+  let curAnot0 = currentAnnotation (context stat0)+      curAnot1 = f curAnot0+  State.put $ stat0{ context = (context stat0){ currentAnnotation = curAnot1 } }+  ret <- builder1+  stat1 <- State.get+  State.put $ stat1{ context = (context stat1){ currentAnnotation = curAnot0} }+  return ret+++-- | Execute the builder, and annotate the very result with the givin function. +annotate :: (TRealm r, Typeable c) => (a -> a) -> Builder v g a (Value r c) ->  Builder v g a (Value r c)+annotate f builder1 = do+  v1 <- builder1+  n1 <- valueToNode v1+  let +    r1 = Val.realm v1+    c1 = Val.content v1+    annotator con@(ins, n2, node2, outs)+      | n1 /= n2  = con+      | otherwise = (ins, n2, fmap f node2, outs)+  stat0 <- State.get+  State.put $ stat0 {    +    target = FGL.gmap annotator (target stat0)+    }+  return $ FromNode r1 c1 n1 ++-- | (<?>) = annotate+infix 0 <?>+(<?>) :: (TRealm r, Typeable c) => (a -> a) -> Builder v g a (Value r c) ->  Builder v g a (Value r c)+(<?>) = annotate+ -- | Builder is Additive 'Additive.C'. -- You can use 'Additive.zero', 'Additive.+', 'Additive.-', 'Additive.negate'.-instance (Vector v, Ring.C g, TRealm r, Typeable c, Additive.C c) => Additive.C (Builder v g (Value r c)) where+instance (TRealm r, Typeable c, Additive.C c) => Additive.C (Builder v g a (Value r c)) where   zero = return $ FromImm unitTRealm Additive.zero   (+) = mkOp2 A.Add   (-) = mkOp2 A.Sub   negate = mkOp1 A.Neg-    + -- | Builder is Ring 'Ring.C'. -- You can use 'Ring.one', 'Ring.*'.-instance (Vector v, Ring.C g, TRealm r, Typeable c, Ring.C c) => Ring.C (Builder v g (Value r c)) where+instance (TRealm r, Typeable c, Ring.C c) => Ring.C (Builder v g a (Value r c)) where   one = return $ FromImm unitTRealm Ring.one   (*) = mkOp2 A.Mul   fromInteger = imm . fromInteger-  ++-- | Builder is Ring 'IntegralDomain.C'.+-- You can use div and mod.+instance (TRealm r, Typeable c, IntegralDomain.C c) => IntegralDomain.C (Builder v g a (Value r c)) where+  div = mkOp2 A.Div+  mod = mkOp2 A.Mod+  divMod = error "divmod is to be defined!"+ -- | you can convert GHC numeric immediates to 'Builder'.-instance (Vector v, Ring.C g, TRealm r, Typeable c, Ring.C c) => Prelude.Num (Builder v g (Value r c)) where  +instance (TRealm r, Typeable c, Ring.C c) => Prelude.Num (Builder v g a (Value r c)) where     (+) = (Additive.+)   (*) = (Ring.*)   (-) = (Additive.-)@@ -288,21 +364,21 @@   abs = undefined   signum = undefined   fromInteger = Ring.fromInteger-  + -- | Builder is Field 'Field.C'. You can use 'Field./', 'Field.recip'.-instance (Vector v, Ring.C g, TRealm r, Typeable c, Field.C c) => Field.C (Builder v g (Value r c)) where+instance (TRealm r, Typeable c, Field.C c) => Field.C (Builder v g a (Value r c)) where   (/) = mkOp2 A.Div   recip = mkOp1 A.Inv   fromRational' = imm . fromRational'  -- | you can convert GHC floating point immediates to 'Builder'.-instance (Vector v, Ring.C g, TRealm r, Typeable c, Field.C c, Prelude.Fractional c) => Prelude.Fractional (Builder v g (Value r c)) where  +instance (TRealm r, Typeable c, Field.C c, Prelude.Fractional c) => Prelude.Fractional (Builder v g a (Value r c)) where     (/) = (Field./)   recip = Field.recip   fromRational = imm . Prelude.fromRational  -- | Builder is 'Boolean'. You can use 'true', 'false', 'not', '&&', '||'.-instance (Vector v, Ring.C g, TRealm r) => Boolean (Builder v g (Value r Bool)) where  +instance (TRealm r) => Boolean (Builder v g a (Value r Bool)) where     true  = imm True   false = imm False   not   = mkOp1 A.Not@@ -310,27 +386,27 @@   (||)  = mkOp2 A.Or  -- | Builder is Algebraic 'Algebraic.C'. You can use 'Algebraic.sqrt' and so on.-instance (Vector v, Ring.C g, TRealm r, Typeable c, Algebraic.C c) => Algebraic.C (Builder v g (Value r c)) where+instance (TRealm r, Typeable c, Algebraic.C c) => Algebraic.C (Builder v g a (Value r c)) where   sqrt = mkOp1 A.Sqrt   x ^/ y = mkOp2 A.Pow x (fromRational' y)  -- | choose the larger or the smaller of the two.-instance (Vector v, Ring.C g, TRealm r, Typeable c) => Lattice.C (Builder v g (Value r c))+instance (TRealm r, Typeable c) => Lattice.C (Builder v g a (Value r c))     where       up = mkOp2 A.Max         dn = mkOp2 A.Min -instance (Vector v, Ring.C g, TRealm r, Typeable c) => ZeroTestable.C (Builder v g (Value r c))+instance (TRealm r, Typeable c) => ZeroTestable.C (Builder v g a (Value r c))     where       isZero _ = error "isZero undefined for builder."-      -instance (Vector v, Ring.C g, TRealm r, Typeable c, Ring.C c) => Absolute.C (Builder v g (Value r c))++instance (TRealm r, Typeable c, Ring.C c) => Absolute.C (Builder v g a (Value r c))     where       abs    = mkOp1 A.Abs       signum = mkOp1 A.Signum -instance (Vector v, Ring.C g, TRealm r, Typeable c,  Transcendental.C c) =>  -    Transcendental.C (Builder v g (Value r c)) where      +instance (TRealm r, Typeable c,  Transcendental.C c) =>  +    Transcendental.C (Builder v g a (Value r c)) where               pi = imm pi         exp = mkOp1 A.Exp         log = mkOp1 A.Log@@ -340,4 +416,3 @@         asin = mkOp1 A.Asin         acos = mkOp1 A.Acos         atan = mkOp1 A.Atan-
Language/Paraiso/OM/DynValue.hs view
@@ -1,7 +1,8 @@ {-# OPTIONS -Wall #-} --- | The 'Value' is flowing through the OM dataflow graph.--- 'Value' carries the type and homogeneity information about the dataflow.+-- | The 'DynValue' is stored in the OM dataflow graph type.+-- 'DynValue' carries the type and homogeneity information in value.+-- Therefore, 'DynValue' with various types can be stored in single container type such as graph.  module Language.Paraiso.OM.DynValue   (
Language/Paraiso/OM/Graph.hs view
@@ -1,69 +1,91 @@-{-# LANGUAGE ExistentialQuantification,  NoImplicitPrelude, -  StandaloneDeriving #-}+{-# +LANGUAGE ExistentialQuantification,  KindSignatures, +         NoImplicitPrelude, StandaloneDeriving #-} {-# OPTIONS -Wall #-} --- | all the components for constructing Orthotope Machine data flow draph.+-- | the components for constructing Orthotope Machine data flow draph.+--  Most components take three arguments: +--+-- [@vector :: * -> *@] The array dimension. It is a 'Vector' that+-- defines the dimension of the Orthotope on which the OM operates.+--+-- [@gauge :: *@] The array index. The combination @vector gauge@+-- needs to be an instance of 'Algebra.Additive.C' if you want to+-- perform @Shift@ operation.+-- +-- [@anot :: *@] The annotations put on each node. If you want to use+-- Annotation, @anot@ needs to be an instance of 'Data.Monoid'.++ module Language.Paraiso.OM.Graph     (-     Setup(..), Kernel(..), Graph, nmap, getA,-     Annotation(..),+     Setup(..), Kernel(..), Graph, nmap, imap, getA,      Node(..), Edge(..),+     StaticIdx(..),      Inst(..),-     module Language.Paraiso.Name     )where -import qualified Algebra.Ring as Ring-import Data.Dynamic+import           Data.Dynamic+import           Data.Tensor.TypeLevel+import qualified Data.Vector as V import qualified Data.Graph.Inductive as FGL-import Language.Paraiso.Name-import Language.Paraiso.OM.Arithmetic as A-import Language.Paraiso.OM.Reduce as R-import Language.Paraiso.OM.DynValue-import Language.Paraiso.Tensor-import NumericPrelude+import           Language.Paraiso.Name+import           Language.Paraiso.OM.Arithmetic as A+import           Language.Paraiso.OM.Reduce as R+import           Language.Paraiso.OM.DynValue+import           NumericPrelude   -- | An OM Setup, a set of information needed before you start building a 'Kernel'.--- It's basically a list of static orthotopes --- (its identifier, Realm and Type carried in the form of 'NamedValue')-data  (Vector vector, Ring.C gauge) => Setup vector gauge = +data Setup (vector :: * -> *) gauge anot =    Setup {-    staticValues :: [Named DynValue]+    -- | The list of static orthotopes +    --  (its identifier, Realm and Type carried in the form of 'NamedValue')+    staticValues :: V.Vector (Named DynValue), +    -- | The machine-global annotations+    globalAnnotation :: anot             } deriving (Eq, Show) --- | A 'Kernel' for OM does a bunch of calculations on OM.-data (Vector vector, Ring.C gauge) => Kernel vector gauge a = +-- | A 'Kernel' for OM perfor a block of calculations on OM.+data Kernel vector gauge anot =    Kernel {     kernelName :: Name,-    dataflow :: Graph vector gauge a+    dataflow :: Graph vector gauge anot   }              deriving (Show) -instance (Vector v, Ring.C g) => Nameable (Kernel v g a) where+instance Nameable (Kernel v g a) where   name = kernelName  --- | The dataflow graph for Orthotope Machine. a is an additional annotation.-type Graph vector gauge a = FGL.Gr (Node vector gauge a) Edge+-- | The dataflow graph for Orthotope Machine. anot is an additional annotation.+type Graph vector gauge anot = FGL.Gr (Node vector gauge anot) Edge  -- | Map the 'Graph' annotation from one type to another. Unfortunately we cannot make one data -- both the instances of 'FGL.Graph' and 'Functor', so 'nmap' is a standalone function.-nmap :: (Vector v, Ring.C g) => (a -> b) -> Graph v g a ->  Graph v g b-nmap f = let-    nmap' f0 (NValue x a0) = (NValue x $ f0 a0) -    nmap' f0 (NInst  x a0) = (NInst  x $ f0 a0) -  in FGL.nmap (nmap' f)+nmap :: (a -> b) -> Graph v g a ->  Graph v g b+nmap f = FGL.nmap (napply f)+  where+    napply f0 (NValue x a0) = (NValue x $ f0 a0) +    napply f0 (NInst  x a0) = (NInst  x $ f0 a0)   +-- | Map the 'Graph' annotation from one type to another, while referring to the node indices.+imap :: (FGL.Node -> a -> b) -> Graph v g a -> Graph v g b+imap f graph = FGL.mkGraph (map (\(i,a) -> (i, update i a)) $ FGL.labNodes graph) (FGL.labEdges graph)+  where+    update i (NValue x a0) = (NValue x $ f i a0) +    update i (NInst  x a0) = (NInst  x $ f i a0) + -- | The 'Node' for the dataflow 'Graph' of the Orthotope machine. -- The dataflow graph is a 2-part graph consisting of 'NValue' and 'NInst' nodes.-data Node vector gauge a = +data Node vector gauge anot =    -- | A value node. An 'NValue' node only connects to 'NInst' nodes.   -- An 'NValue' node has one and only one input edge, and has arbitrary number of output edges.-  NValue DynValue a |+  NValue DynValue anot |   -- | An instruction node. An 'NInst' node only connects to 'NValue' nodes.   -- The number of input and output edges an 'NValue' node has is specified by its 'Arity'.-  NInst (Inst vector gauge) a+  NInst (Inst vector gauge) anot         deriving (Show)  -- | The 'Edge' label for the dataflow 'Graph'. @@ -80,23 +102,26 @@   NValue _ x -> x   NInst  _ x -> x   ---instance (Vector v, Ring.C g) => Functor (Node v g) where+instance Functor (Node v g) where   fmap f (NValue x y) =  (NValue x (f y))     fmap f (NInst  x y) =  (NInst  x (f y))   -data Inst vector gauge = -  Imm Dynamic |-  Load Name |-  Store Name |-  Reduce R.Operator |-  Broadcast |-  Shift (vector gauge) |-  LoadIndex (Axis vector) |-  Arith A.Operator -        deriving (Show)+newtype StaticIdx = StaticIdx { fromStaticIdx :: Int}+instance Show StaticIdx where+  show (StaticIdx x) = "static[" ++ show x ++ "]" +data Inst vector gauge +  = Imm Dynamic +  | Load StaticIdx+  | Store StaticIdx+  | Reduce R.Operator +  | Broadcast +  | Shift (vector gauge) +  | LoadIndex (Axis vector) +  | LoadSize (Axis vector) +  | Arith A.Operator +  deriving (Show)+ instance Arity (Inst vector gauge) where   arity a = case a of     Imm _     -> (0,1)@@ -106,10 +131,7 @@     Broadcast -> (1,1)     Shift _   -> (1,1)     LoadIndex _ -> (0,1)+    LoadSize _ -> (0,1)         Arith op  -> arity op ---- | you can insert 'Annotation's to control the code generation processes.-data Annotation = Comment String | Balloon-                deriving (Eq, Ord, Read, Show)
+ Language/Paraiso/OM/PrettyPrint.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{-# OPTIONS -Wall #-}++module Language.Paraiso.OM.PrettyPrint (+  prettyPrint, prettyPrintA, prettyPrintA1+  ) where++import qualified Data.Graph.Inductive                   as FGL+import           Data.List (sort)+import qualified Data.Set                               as Set+import qualified Data.Text                              as T+import qualified Data.Vector                            as V+import qualified Data.ListLike.String                   as LL+import qualified Data.ListLike.Text ()+import qualified Language.Paraiso.Annotation            as Anot+import qualified Language.Paraiso.Annotation.Allocation as Alloc+import qualified Language.Paraiso.Annotation.Boundary   as Boundary+import qualified Language.Paraiso.Annotation.Dependency as Depend+import qualified Language.Paraiso.Annotation.Execution  as Exec+import           Language.Paraiso.Interval+import           Language.Paraiso.Name+import           Language.Paraiso.OM+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.Optimization.Graph    as Opt+import           Language.Paraiso.Prelude++-- | pretty print the OM, neglecting any annotations.+prettyPrint :: Opt.Ready v g => OM v g a -> T.Text+prettyPrint = prettyPrintA (const []) ++-- | pretty print the OM, using a default printing for annotation.+prettyPrintA1 :: Opt.Ready v g => OM v g Anot.Annotation -> T.Text+prettyPrintA1 om = prettyPrintA (ppAnot1 om) om++-- | pretty print the OM with your choice of prettyprinter for annotation.+prettyPrintA :: Opt.Ready v g => (a -> [T.Text]) -> OM v g a -> T.Text+prettyPrintA ppAnot om +  = LL.unlines +    [ "OM name: " ++ nameText om,+      "** Static Variables",+      staticList,+      "** Kernels",+      kernelList+    ]+  where+    staticList = LL.unlines $ V.toList $ V.map showT $ staticValues $ setup om+    kernelList = LL.unlines $ V.toList $ V.map ppKern $ kernels om++    ppKern kern = LL.unlines $ ["*** Kernel name: " ++ nameText kern] ++ concat (body (dataflow kern))+    body graph = map ppCon $ map (FGL.context graph) $ FGL.nodes graph++    ppCon (input, idx, nodeLabel, output) +      = LL.unwords+        [ showT idx, +          ppNode nodeLabel,+          ppEdges "<-" input,+          ppEdges "->" output+        ] : ppAnot (getA nodeLabel)++    ppNode n = case n of+      NValue x _ -> showT x+      NInst  x _ -> showT x++    ppEdges symbol xs +      | length xs == 0 = ""+      | otherwise      = LL.unwords $ symbol : map ppEdge (sort xs)+    ppEdge (e, i) = case e of+      EUnord -> showT i+      EOrd x -> "(" ++ showT x ++ ")" ++ showT i++++ppAnot1 :: Opt.Ready v g => OM v g Anot.Annotation -> Anot.Annotation -> [T.Text]+ppAnot1 om anots = map ("  "++) $ concat cands+  where+    cands = +      [ map showT ((Anot.toList anots) ::  [Alloc.Allocation])+      , map ppValid (toValidList om anots)      +      , map (("Depend."++) . showT) ((Anot.toList anots) ::  [Depend.Direct])+      , map (("Depend."++) . showT) ((Anot.toList anots) ::  [Depend.Indirect])+      , if ((Anot.toList anots) ::  [Alloc.Allocation]) == [Alloc.Manifest]+        then map (("Depend.Calc "++) . ppDC) ((Anot.toList anots) ::  [Depend.Calc])+        else []+      , map showT ((Anot.toList anots) ::  [Exec.Alive])+      , map showT ((Anot.toList anots) ::  [Depend.KernelWriteGroup])        +      , map showT ((Anot.toList anots) ::  [Depend.OMWriteGroup])                +      ]+      +    toValidList :: Opt.Ready v g => OM v g Anot.Annotation -> Anot.Annotation -> [Boundary.Valid g]      +    toValidList _ = Anot.toList+                   +    ppValid (Boundary.Valid xs) = LL.unwords $ map ppInterval xs+    ppInterval (Interval x y) +      = ppNB x ++ ".." ++ ppNB y+    ppInterval Empty = "[empty]" +    +    ppNB (Boundary.NegaInfinity)    = "[-inf"    +    ppNB (Boundary.LowerBoundary x) = "[" ++ showT x+    ppNB (Boundary.UpperBoundary x) = showT x ++ "]"+    ppNB (Boundary.PosiInfinity)    = "+inf]"+    +    ppDC (Depend.Calc s) = showT $ Set.toList s
Language/Paraiso/OM/Realm.hs view
@@ -35,5 +35,5 @@ -- | Realmable instances   instance Realmable Realm where   realm = id    -instance TRealm a => Realmable a where-  realm = tRealm+  +
Language/Paraiso/OM/Value.hs view
@@ -1,7 +1,8 @@ {-# OPTIONS -Wall #-}  -- | The 'Value' is flowing through the OM dataflow graph.--- 'Value' carries the type and homogeneity information about the dataflow.+-- 'Value' carries the type and homogeneity information about the dataflow as Type.+-- Therefore, operation between 'Value' with wrong type will raise type errors.  module Language.Paraiso.OM.Value   (@@ -28,8 +29,8 @@                          instance  (R.TRealm rea, Typeable con) => R.Realmable (Value rea con) where-  realm (FromNode r _ _) = R.realm r-  realm (FromImm r _) = R.realm r+  realm (FromNode r _ _) = R.tRealm r+  realm (FromImm r _) = R.tRealm r
+ Language/Paraiso/Optimization.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveDataTypeable, KindSignatures, +MultiParamTypeClasses, NoImplicitPrelude, RankNTypes+ #-}+{-# OPTIONS -Wall #-}++-- | tipycal optimization menu++module Language.Paraiso.Optimization (+  optimize,+  Level(..),+  Ready+  ) where++import           Data.Typeable+import qualified Language.Paraiso.Annotation as Anot+import           Language.Paraiso.OM (OM(..))+import           Language.Paraiso.OM.Graph (globalAnnotation)+import           Language.Paraiso.Optimization.BoundaryAnalysis+import           Language.Paraiso.Optimization.DeadCodeElimination+import           Language.Paraiso.Optimization.DecideAllocation+import           Language.Paraiso.Optimization.DependencyAnalysis+import           Language.Paraiso.Optimization.Graph+import           Language.Paraiso.Optimization.Identity+import           Language.Paraiso.Prelude++++optimize :: (Ready v g)            +            => Level +            -> OM v g Anot.Annotation +            -> OM v g Anot.Annotation+            +optimize level om = +  if (Just level > maybeOldLevel) +  then recordLevel $ optimizer om +  else om+  where+    maybeOldLevel = Anot.toMaybe $ globalAnnotation $ setup om+    +    recordLevel om = +      om+      { setup = (setup om)+        { globalAnnotation = Anot.set (level) $ globalAnnotation (setup om)+        }+      }++    optimizer = case level of+      O0 -> gmap identity . +            writeGrouping . +            gmap boundaryAnalysis . +            gmap decideAllocation . +            gmap deadCodeElimination +      _  -> optimize O0++data Level +  = O0 -- perform mandatory code analysis+  | O1+  | O2+  | O3+    deriving (Eq, Ord, Show, Typeable)
+ Language/Paraiso/Optimization/BoundaryAnalysis.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}++-- | The volume of mesh that contains the correct results shrinks as+-- the stencil calculation proceeds. This is because in stencil+-- calculation each mesh access to its neighbour meshes and for+-- boundary meshes it cannot be obtained.+--+-- boundaryAnalysis marks each node of the Orthotope Machine with the+-- region for which the computation result is Valid.++module Language.Paraiso.Optimization.BoundaryAnalysis (+  boundaryAnalysis+  ) where++import qualified Algebra.Additive            as Additive+import qualified Data.Graph.Inductive        as FGL+import           Data.Maybe+import           Data.Tensor.TypeLevel+import           Data.Typeable+import qualified Data.Vector                 as V+import qualified Language.Paraiso.Annotation as Anot+import           Language.Paraiso.Annotation.Boundary+import           Language.Paraiso.Interval+import           Language.Paraiso.OM.DynValue as DVal+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.OM.Realm as Realm+import           Language.Paraiso.PiSystem+import           Language.Paraiso.Prelude+++boundaryAnalysis :: (Vector v, Additive.C g, Ord g, Typeable g)+                    => Graph v g Anot.Annotation -> Graph v g Anot.Annotation+boundaryAnalysis graph = imap update graph +  where+    update :: FGL.Node -> Anot.Annotation -> Anot.Annotation+    update i a = Anot.set (anot i) a++    anot i = memoAnot V.! i++    memoAnot = V.generate (FGL.noNodes graph) calcAnot++    calcAnot i = case selfNode of+      NValue v _           -> if isGlobal v +                              then infinite+                              else preAnot+      NInst (Imm _)_       -> infinite+      NInst (Load _)_      -> full+      NInst (Store _)_     -> preAnot+      NInst (Reduce _)_    -> infinite+      NInst (Broadcast)_   -> infinite+      NInst (Shift v)_     -> full `intersection` shiftPreBy v +      NInst (LoadIndex _)_ -> infinite+      NInst (LoadSize _)_  -> infinite+      NInst (Arith _)_     -> mergedAnot+      where+        self0 = FGL.lab graph i++        selfNode = case self0 of   +          Just x -> x+          _      -> error $ "node[" ++ show i ++ "] disappeared"++        isGlobal v = case v of+          DVal.DynValue Realm.Global _ -> True+          _                            -> False++        -- data at all coordinates is valid that is stored in the array +        full = Valid $ toList $ fullValid graph+        -- data at arbitrary coordinates is valid including imaginary+        -- coordinates beyond the range of the array+        infinite = Valid $ toList $ infiniteValid graph++        -- the Valid region of the single preceding value+        preAnot = case FGL.pre graph i of         +          [i'] -> anot i'+          xs    -> error $ "node[" ++ show i ++ "] only 1 pre expected : actually " ++ show (length xs)++        -- intersection of the Valid regions of preceding nodes+        mergedAnot = case (FGL.pre graph i) of+          [] -> error $ "arith node[" ++ show i ++ "] has 0 pre"+          xs -> foldl1 intersection $ map anot $ xs++        --  shift the preceding Valid by a vector v+        shiftPreBy v = Valid $ +            zipWith shiftIntervalBy (toList v) ((\(Valid x)->x) preAnot)+        shiftIntervalBy x (Interval x1 x2) = Interval (add x x1) (add x x2)+        shiftIntervalBy _ Empty            = error "empty interval raised!"+        +        add x nby = case nby of+          NegaInfinity    -> NegaInfinity+          LowerBoundary y -> LowerBoundary $ x+y+          UpperBoundary y -> UpperBoundary $ x+y+          PosiInfinity    -> PosiInfinity++-- | data at all coordinates is valid that is stored in the array +fullValid :: (Vector v, Additive.C g) => Graph v g a -> v (Interval (NearBoundary g))+fullValid _ = compose (\_ -> Interval (LowerBoundary Additive.zero) (UpperBoundary Additive.zero))++-- | data at arbitrary coordinates is valid including imaginary+-- coordinates beyond the range of the array+infiniteValid :: (Vector v, Additive.C g, Typeable g) => Graph v g a -> v (Interval (NearBoundary g))+infiniteValid _ = compose (\_ -> Interval NegaInfinity PosiInfinity)
+ Language/Paraiso/Optimization/DeadCodeElimination.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TupleSections #-}+{-# OPTIONS -Wall #-}+module Language.Paraiso.Optimization.DeadCodeElimination (+  deadCodeElimination+  ) where++import qualified Data.Graph.Inductive                   as FGL+import           Data.Maybe+import qualified Data.Vector                            as V+import qualified Language.Paraiso.Annotation            as Anot+import qualified Language.Paraiso.Annotation.Execution  as Anot+import           Language.Paraiso.Prelude+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.Optimization.Graph++-- | an optimization that changes nothing.+deadCodeElimination :: Optimization+deadCodeElimination = removeDead . markDead++markDead :: Optimization+markDead graph = imap update graph +  where+    update :: FGL.Node -> Anot.Annotation -> Anot.Annotation+    update i a = Anot.set (Anot.Alive $ memoAlive V.! i) a +              +    memoAlive :: V.Vector Bool+    memoAlive = V.generate (FGL.noNodes graph) alive+    +    alive i = case FGL.lab graph i of+      Nothing -> error $ "node [" ++ show i ++ "] disappeared"+      Just x -> case x of+        NInst (Store _)_ -> True+        NInst (Load _)_ -> True+        _ -> or $ map (memoAlive V.!) $ FGL.suc graph i+    +removeDead :: Optimization    +removeDead graph = graph2+  +  where+    graph2 = FGL.mkGraph newNodes newEdges+      ++    newNodes = +      catMaybes $+      fmap (\(idx, lab) -> (,lab) <$> renumber idx) $ +      FGL.labNodes graph+    +    newEdges = +      catMaybes $+      fmap (\(iFrom, iTo, lab) -> (,,lab) <$> renumber iFrom <*> renumber iTo) $ +      FGL.labEdges graph+      +    renumber :: Int -> Maybe Int+    renumber = (oldToNew V.!)+    +    oldToNew :: V.Vector (Maybe FGL.Node)+    oldToNew = +      V.update (V.replicate (FGL.noNodes graph) (Nothing)) $+      V.imap (\newIdx oldIdx -> (oldIdx, Just newIdx)) $+      newToOld+    newToOld :: V.Vector FGL.Node+    newToOld = +      V.filter alive $ -- filter only alive nodes of+      V.generate (FGL.noNodes graph) id   -- all the node indices+    alive :: FGL.Node -> Bool+    alive i = case Anot.toMaybe $ getA $ fromJust $ FGL.lab graph i of+      Just (Anot.Alive x) -> x+      Nothing             -> error $ "please markDead before removeDead"
+ Language/Paraiso/Optimization/DecideAllocation.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}++-- | The choice of making each Orthotope Machine node Manifest or not+-- largely depends on the user or the automated tuning.  However, code+-- generators requires that nodes are Manifest at certain contexts.+--+-- decideAllocation makes sure that such nodes are marked as Manifest,+-- and also makes sure that every node is marked with at least some +-- Allocation.++module Language.Paraiso.Optimization.DecideAllocation (+  decideAllocation+  ) where++import qualified Data.Graph.Inductive                   as FGL+import           Data.Maybe +import qualified Language.Paraiso.Annotation            as Anot+import           Language.Paraiso.Annotation.Allocation as Alloc+import           Language.Paraiso.Prelude+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.OM.DynValue           as DVal+import           Language.Paraiso.OM.Realm              as Realm+import           Language.Paraiso.Optimization.Graph++decideAllocation :: Optimization+decideAllocation graph = imap update graph +  where+    update :: FGL.Node -> Anot.Annotation -> Anot.Annotation+    update i  +      | afterLoad = Anot.set Alloc.Existing+      | beforeStore || beforeReduce || afterReduce || beforeBroadcast || afterBroadcast+                  = Anot.set Alloc.Manifest+      | (isGlobal || beforeShift || afterShift ) && False -- warehouse+                  = Anot.weakSet Alloc.Delayed+      | otherwise = Anot.weakSet Alloc.Delayed+        where+          self0 = FGL.lab graph i+          pre0  = FGL.lab graph =<<(listToMaybe $ FGL.pre graph i) +          suc0  = FGL.lab graph =<<(listToMaybe $ FGL.suc graph i) +          pres  = catMaybes $ map (FGL.lab graph) $ FGL.pre graph i+          sucs  = catMaybes $ map (FGL.lab graph) $ FGL.suc graph i+          isGlobal  = case self0 of+            Just (NValue (DVal.DynValue Realm.Global _) _) -> True+            _                                              -> False+          afterLoad = case pre0 of+            Just (NInst (Load _) _)    -> True+            _                          -> False+          beforeStore  = +            or $+            flip map sucs $ \ nd -> case nd of+              (NInst (Store _) _)   -> True+              _                     -> False+          beforeReduce = +            or $+            flip map sucs $ \ nd -> case nd of+              (NInst (Reduce _) _)  -> True+              _                     -> False+          afterReduce = case pre0 of+            Just (NInst (Reduce _) _)  -> True+            _                          -> False+          beforeBroadcast =+            or $+            flip map sucs $ \ nd -> case nd of+              (NInst (Broadcast) _) -> True+              _                     -> False+          afterBroadcast = case pre0 of+            Just (NInst (Broadcast) _) -> True+            _                          -> False+          beforeShift = +            or $+            flip map sucs $ \ nd -> case nd of+              (NInst (Shift _) _)   -> True+              _                     -> False+          afterShift = case pre0 of+            Just (NInst (Shift _) _)   -> True+            _                          -> False++++
+ Language/Paraiso/Optimization/DependencyAnalysis.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}++-- | This module performs dependency analysis for generating subroutines. +--+-- 1. Direct dependency between Manifest/Existing nodes X and Y: the+-- subroutine that outputs Y needs to read X as input+--+-- 2. Indirect dependency between Manifest nodes X and Y: the+-- computation of Y requires that the computation of X is finished,+-- and therefore X and Y cannot be output by the same subroutine+--+-- 3. Calculation dependency between any node X and Manifest node Y:+-- in the subroutine you output Y you need to calculate X.+--+-- c.f. 'Language.Paraiso.Annotation.Dependency' ++module Language.Paraiso.Optimization.DependencyAnalysis (+  writeGrouping+  ) where++import qualified Data.Graph.Inductive                   as FGL+import qualified Data.Set                               as Set+import qualified Data.Vector                            as V+import qualified Language.Paraiso.Annotation            as Anot+import qualified Language.Paraiso.Annotation.Allocation as Alloc+import qualified Language.Paraiso.Annotation.Boundary   as Boundary+import qualified Language.Paraiso.Annotation.Dependency as Depend+import           Language.Paraiso.OM+import qualified Language.Paraiso.OM.DynValue           as DVal+import           Language.Paraiso.OM.Graph+import qualified Language.Paraiso.OM.Realm              as Realm+import qualified Language.Paraiso.Optimization.Graph    as Opt+import           Language.Paraiso.Prelude++-- | Give unique numbering to each groups in the entire OM +--   in preparation for code generation+writeGrouping :: Opt.Ready v g => OM v g Anot.Annotation -> OM v g Anot.Annotation+writeGrouping om0 = om { kernels = kernelsRet}+  where+    om = Opt.gmap dependencyAnalysis om0+    kernels0 = kernels om+    graphs0 = V.map dataflow $ kernels0+    graphsSize = V.length graphs0+    +    -- | how many kernel groups are included in i'th graph?+    groupCount = flip V.map graphs0+      (\graph -> (1+) $ maximum $ (-1 : ) $ concat $+                 map (map Depend.getKernelGroupID . a2k . getA) $ +                 map snd $ FGL.labNodes graph)+    +    a2k :: Anot.Annotation -> [Depend.KernelWriteGroup]+    a2k a = case Anot.toMaybe a of+      Just kwg -> [kwg]+      Nothing  -> [] -- non-manifest nodes does not contain Group+        +    graphsRet = V.generate graphsSize (\i -> renumber i $ graphs0 V.! i)+ +    kernelsRet = flip V.imap kernels0+      (\i kern -> kern { dataflow = graphsRet V.! i})+    +    renumber idx graph = +      let diff = V.sum$ V.take idx groupCount in+      flip nmap graph $+        Anot.map (Depend.OMWriteGroup . (diff+) . Depend.getKernelGroupID)+      +-- | dependency analysis+dependencyAnalysis :: Opt.Ready v g => Opt.OptimizationOf v g+dependencyAnalysis graph = imap update graph +  where+    update :: FGL.Node -> Anot.Annotation -> Anot.Annotation+    update i = setGroup i . (Anot.set $ calcList i) . (Anot.set $ dependencyList i) . (Anot.set $ indirectList i) +    +    dependencyList idx = -- a node wite index idx+      Depend.Direct $    -- depends directly+      V.toList $+      V.map fst $        -- on the nodes with jdx where+      V.filter snd $     -- 'True' is written at+      V.imap (\sidx dep -> (sidxToIdx V.! sidx, dep)) $+      dependMatrixWrite V.! idx -- dependMatrixWrite ! idx ! sidx+      -- where  staticIndexs jdx = sidx in+      +    indirectList idx =  -- a node wite index idx+      Depend.Indirect $ -- depends indirectly+      V.toList $+      V.map fst $       -- on the nodes with jdx where+      V.filter snd $    -- 'True' is written at+      V.imap (\sidx dep -> (sidxToIdx V.! sidx, dep)) $+      indirectMatrixWrite V.! idx -- dependMatrixWrite ! idx ! sidx+      -- where  staticIndexs jdx = sidx in++    calcList idx = -- a set of node idxs needed within subroutine that calculate node idx+      Depend.Calc $+      calcMatrixWrite V.! idx +++    setGroup idx = +      case idxToAlloc V.! idx of+        Alloc.Manifest -> Anot.set $ Depend.KernelWriteGroup (kernelGroup V.! idx)+        _              -> id+          +    -- Number of Strict Nodes+    sidxSize = V.length sidxToIdx+    -- Number of all nodes+    idxSize  = FGL.noNodes graph+++    -- group to which a Manifest node belongs+    kernelGroup :: V.Vector Int+    kernelGroup = V.generate idxSize inner+      where+        inner idx +          -- if there is no predecessor you are the first+          | length pres == 0        = 0+          -- you found someone else you can coexist with+          | not (null coGroups) = head coGroups+          -- there are predecessors, but you can't coexist with any of them+          | otherwise               = 1 + maximum (map (kernelGroup V.!) pres)+          where+            pres = takeWhile (<idx) manifestNodes+            existingGroups = Set.toList $ Set.fromList $ map (kernelGroup V.!) pres+            groupMember grp = filter ((==grp) . (kernelGroup V.!)) pres+            coGroups = filter (and . map (coexist idx) .  groupMember) existingGroups+    +    -- whether two nodes can be written simultaneously in one kernel.+    coexist :: FGL.Node -> FGL.Node -> Bool+    coexist idx jdx+      | (idxToAlloc V.! idx /= Alloc.Manifest || idxToAlloc V.! jdx /= Alloc.Manifest )+                   = error "coexistence not defined for non-Manifest nodes"+      | idx == jdx = True+      | idx <  jdx = coexist jdx idx+      | otherwise  = (not dependent') && sameShape+      where+        dependent' = indirectMatrixWrite V.! idx V.! (idxToSidx V.! jdx)+        sameShape  = +          (idxToRealm V.! idx) == (idxToRealm V.! jdx) &&+          (idxToValid V.! idx) == (idxToValid V.! jdx)+        +    -- the allocation setting of each node.+    idxToAlloc :: V.Vector Alloc.Allocation+    idxToAlloc = V.fromList $+      map (\(_, nd) -> f' $ Anot.toMaybe $ getA nd) $+      FGL.labNodes graph+      where+        f' (Just x) = x+        f' Nothing  = error "writeGrouping must be done after decideAllocation"++    -- the allocation setting of each node.+    -- the gauge for validness should copy the gauge of the graph.+    idxToValid = idxToValid' graph+    idxToValid' :: (Opt.Ready v g) => (Graph v g Anot.Annotation) -> V.Vector (Boundary.Valid g)+    idxToValid' _  = V.fromList $+      map (\(_, nd) -> f' $ Anot.toMaybe $ getA nd) $+      FGL.labNodes graph+      where+        f' (Just x) = x+        f' Nothing  = error "boundaryAnalysis must be done after decideAllocation"++    -- the OM node for each index+    idxToRealm :: V.Vector Realm.Realm+    idxToRealm = V.generate idxSize inner+      where+        inner idx = case FGL.lab graph idx of+          Just (NValue (DVal.DynValue r _)_) -> r+          Just _                             -> error "realm required for non-Value node"+          Nothing                            -> error "indexing mismatch"++    -- the list of indices of Manifest nodes in ascending order.+    manifestNodes :: [FGL.Node]+    manifestNodes = +      map fst $+      filter snd $+      map (\(idx, nd) -> (idx, (==Just Alloc.Manifest) $ Anot.toMaybe $ getA nd)) $+      FGL.labNodes graph++    -- map index of a StrictNode to the FGL node index +    sidxToIdx :: V.Vector Int+    sidxToIdx = +      V.map fst $ +      V.filter snd $ +      V.imap (\idx isStrict' -> (idx, isStrict')) $ +      isStrict +    -- map FGL node index to StrictNode index+    idxToSidx :: V.Vector Int+    idxToSidx = V.generate idxSize inner+      where+        inner idx =+          head $+          (++ [error $ show idx ++ " is not a Strict node"]) $+          V.toList $+          V.map fst $+          V.filter ((==idx) . snd) $+          V.imap (\sidx' idx' -> (sidx', idx')) $+          sidxToIdx++    isStrict :: V.Vector Bool+    isStrict = V.generate idxSize $ \idx ->+      case idxToAlloc V.! idx of+        Alloc.Manifest -> True+        Alloc.Existing -> True+        Alloc.Delayed  -> False++    -- (dependMatrix ! idx) = the list of sidx that is needed to create the value for this idx+    dependMatrixWrite :: V.Vector (V.Vector Bool)+    dependMatrixWrite = V.generate idxSize dependRowWrite++    -- (dependMatrix ! idx) = the list of sidx that is needed to refer to the idx+    dependMatrixRead :: V.Vector (V.Vector Bool)+    dependMatrixRead = V.generate idxSize dependRowRead++    -- everyone depends on its predecessors+    dependRowWrite idx = foldl mergeRow allFalseRow $ map (dependMatrixRead V.!) $ FGL.pre graph idx++    dependRowRead idx +      -- a strict node can be read by itself+      | isStrict V.! idx = V.map (==idx) sidxToIdx +      -- a non-manifest node depends on its predecessors+      | otherwise          = dependMatrixWrite V.! idx++    -- (indirectMatrix ! idx) = the list of sidx that is needed to create the value for this idx+    indirectMatrixWrite :: V.Vector (V.Vector Bool)+    indirectMatrixWrite = V.generate idxSize indirectRowWrite++    -- (indirectMatrix ! idx) = the list of sidx that is needed to refer to the idx+    indirectMatrixRead :: V.Vector (V.Vector Bool)+    indirectMatrixRead = V.generate idxSize indirectRowRead++    -- everyone indirects on its predecessors+    indirectRowWrite idx = foldl mergeRow allFalseRow $ map (indirectMatrixRead V.!) $ FGL.pre graph idx++    indirectRowRead idx +      -- add a strict node read to indirect dependency+      | isStrict V.! idx = (V.map (==idx) sidxToIdx) `mergeRow` (indirectMatrixWrite V.! idx)+      -- a non-manifest node indirects on its predecessors+      | otherwise          = indirectMatrixWrite V.! idx+++    allFalseRow = V.replicate sidxSize False+    mergeRow va vb+      | V.length va /= sidxSize = error "wrong size contamination in dependMatrix"+      | V.length vb /= sidxSize = error "wrong size contamination in dependMatrix" +      | otherwise               = V.zipWith (||) va vb+    +++    -- The every noe touched in the kernel to calculate the node+    calcMatrixRead :: V.Vector (Set.Set FGL.Node)+    calcMatrixRead = V.generate idxSize calcRowRead+    +    calcMatrixWrite :: V.Vector (Set.Set FGL.Node)+    calcMatrixWrite = V.generate idxSize calcRowWrite++    calcRowWrite idx = Set.unions $ map (calcMatrixRead V.!) $ FGL.pre graph idx+    +    calcRowRead idx+      -- strict nodes depends only on itself+      | isStrict V.! idx = Set.fromList [idx]+      -- a delayed node indirects on its predecessors+      | otherwise        = Set.union (Set.fromList [idx]) $ calcMatrixWrite V.! idx
+ Language/Paraiso/Optimization/Graph.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE  FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, +NoImplicitPrelude, RankNTypes, UndecidableInstances #-}+{-# OPTIONS -Wall #-}++-- | Basic definitions for optimization ++module Language.Paraiso.Optimization.Graph (+  Optimization, OptimizationEx, +  OptimizationOf, Ready,+  gmap+  ) where++import qualified Algebra.Additive        as Additive+import qualified Algebra.Ring            as Ring+import qualified Data.Tensor.TypeLevel   as Tensor+import           Data.Typeable+import qualified Data.Vector             as V+import           Language.Paraiso.Annotation (Annotation)+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.OM+import           Language.Paraiso.Prelude+import Prelude (Num)+++-- | (Ready v g) indicates that the pair (v, g) has all the instances +--   for the full optimizations to be serviced.+class (Tensor.Vector v, +       Num g,+       Ord g, +       Ring.C g, +       Show g,+       Typeable g,+       Additive.C (v g), +       Ord (v g), +       Show (v g)) +      => Ready (v :: * -> *) (g :: *)++instance (Tensor.Vector v, +          Num g,+          Ord g, +          Ring.C g, +          Show g,+          Typeable g,+          Additive.C (v g), +          Ord (v g), +          Show (v g)) +         => Ready (v :: * -> *) (g :: *)+++-- | the most frequent type of optimization is which +type Optimization   = forall (v :: * -> *) (g :: *). Graph v g Annotation -> Graph v g Annotation+type OptimizationEx = forall (v :: * -> *) (g :: *) (a :: *). OM v g a -> OM v g a+type OptimizationOf (v :: * -> *) (g :: *) = Graph v g Annotation -> Graph v g Annotation++-- | map the graph optimization to each dataflow graph of the kernel+gmap :: (Graph v g a -> Graph v g a) -> OM v g a -> OM v g a+gmap f om = +  om{ kernels = V.map (\k -> k{ dataflow = f $ dataflow k}) $ kernels om}+
+ Language/Paraiso/Optimization/Identity.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# OPTIONS -Wall #-}+module Language.Paraiso.Optimization.Identity (+  identity+  ) where++import qualified Data.Graph.Inductive        as FGL+import qualified Language.Paraiso.Annotation as Anot+import           Language.Paraiso.Prelude+import           Language.Paraiso.OM.Graph+import           Language.Paraiso.Optimization.Graph++-- | an optimization that changes nothing.+identity :: Optimization+identity graph = imap update graph +  where+    update :: FGL.Node -> Anot.Annotation -> Anot.Annotation+    update i a = const a i
Language/Paraiso/Orthotope.hs view
@@ -11,8 +11,8 @@   Orthotope1,Orthotope2,Orthotope3 ) where -import Language.Paraiso.Tensor-import Language.Paraiso.Interval+import           Data.Tensor.TypeLevel+import           Language.Paraiso.Interval
− Language/Paraiso/POM.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE  NoImplicitPrelude #-}-{-# OPTIONS -Wall #-}-module Language.Paraiso.POM-  (-   POM(..), makePOM, mapGraph-  ) where--import qualified Algebra.Ring as Ring-import qualified Control.Monad as Monad-import Language.Paraiso.OM.Builder (Builder, makeKernel)-import Language.Paraiso.OM.Graph-import Language.Paraiso.Tensor-import NumericPrelude---- | POM is Primordial Orthotope Machine.-data (Vector vector, Ring.C gauge) => POM vector gauge a = -  POM {-    pomName :: Name,-    setup :: Setup vector gauge,-    kernels :: [Kernel vector gauge a]-  } -    deriving (Show)--instance (Vector v, Ring.C g) => Nameable (POM v g a) where-  name = pomName--instance (Vector v, Ring.C g) => Monad.Functor (POM v g) where-  fmap = mapGraph . nmap ---- | modify each of the graphs in POM.-mapGraph :: (Vector v, Ring.C g) => -            (Graph v g a -> Graph v g b)-         -> POM v g a         -         -> POM v g b-mapGraph f pom = pom-                 { kernels = map -                   (\kern -> kern{dataflow = f $ dataflow kern}) $ -                   kernels pom}----- | create a POM easily and consistently.-makePOM :: (Vector v, Ring.C g) => -           Name                     -- ^The machine name.-        -> (Setup v g)              -- ^The machine configuration.-        -> [(Name, Builder v g ())] -- ^The list of pair of the kernel name and its builder.-        -> POM v g ()               -- ^The result.-makePOM name0 setup0 kerns = -  POM {-    pomName = name0,-    setup = setup0,-    kernels = map (\(n,b) -> makeKernel setup0 n b) kerns-  }-  ----
Language/Paraiso/PiSystem.hs view
@@ -2,11 +2,13 @@  {- | In mathematics, a pi-system is a non-empty family of sets that is closed under finite intersections.  -}-module Language.Paraiso.PiSystem (PiSystem(..)) where+module Language.Paraiso.PiSystem (+  PiSystem(..)+  ) where -import Prelude hiding (null) import qualified Data.Foldable as F-import Language.Paraiso.Tensor+import           Data.Tensor.TypeLevel+import           Prelude hiding (null)  class PiSystem a where   -- | an empty set.@@ -24,4 +26,3 @@   empty = compose $ const empty   null = F.any null   intersection a b = compose (\i -> component i a `intersection` component i b)-
Language/Paraiso/Prelude.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction, RankNTypes #-} {-# OPTIONS -Wall #-}-{- |-   Redefine some items from the standard Prelude.--}--+{-# OPTIONS_HADDOCK hide #-}+-- | an extension of the standard Prelude for paraiso.  module Language.Paraiso.Prelude   (@@ -13,22 +10,41 @@    module Data.Foldable,    module Data.Traversable,    module NumericPrelude,-   Boolean(..)) where+   Boolean(..),+   Text, showT, +   (++)) where -import Control.Monad hiding -    (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Data.Foldable-import Data.Traversable-import NumericPrelude hiding -    (not, (&&), (||), Monad, Functor, (*>),-     (>>=), (>>), return, fail, fmap, mapM, mapM_, sequence, sequence_, (=<<), foldl, foldl1, foldr, foldr1, and, or, any, all, sum, product, concat, concatMap, maximum, minimum, elem, notElem-    )-     import           Control.Applicative (Applicative(..), (<$>))+import           Control.Monad hiding +    (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import           Data.Foldable+import           Data.ListLike (append)+import           Data.ListLike.Text ()+import qualified Data.ListLike.Base (ListLike)+import qualified Data.Text as Text+import           Data.Traversable+import           NumericPrelude hiding +    (not, (&&), (||), Monad, Functor, (*>), (++),+     (>>=), (>>), return, fail, fmap, mapM, mapM_, sequence, sequence_, +     (=<<), foldl, foldl1, foldr, foldr1, and, or, any, all, sum, product, +     concat, concatMap, maximum, minimum, elem, notElem) import qualified NumericPrelude as Prelude +-- | An efficient String that is used thoroughout Paraiso modules.+type Text = Text.Text++showT :: Show a => a -> Text+showT = Text.pack . show+ infixr 3  && infixr 2  ||+infixr 5  ++++(++) :: forall full item .+        Data.ListLike.Base.ListLike full item =>+        full -> full -> full++(++) = append  class Boolean b where   true, false :: b
− Language/Paraiso/Tensor.hs 
@@ -1,160 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances,-  MultiParamTypeClasses, NoImplicitPrelude, StandaloneDeriving, -  TypeOperators, UndecidableInstances  #-} -{-# OPTIONS -Wall #-}--- | A tensor algebra library. Main ingredients are :--- --- 'Vec' and ':~' are data constructors for rank-1 tensor.--- This is essentially a touple of objects of the same type.--- --- 'Vector' is a class for rank-1 tensor.------ 'Axis' is an object for accessing the tensor components.--module Language.Paraiso.Tensor-    (-     (:~)(..), Vec(..), Axis(..), (!),-     Vector(..), VectorRing(..),-     contract,-     Vec0, Vec1, Vec2, Vec3, Vec4-    ) where--import qualified Algebra.Additive as Additive-import qualified Algebra.Ring as Ring-import           Language.Paraiso.Failure-import           Language.Paraiso.Prelude--infixl 9 !--- | a component operator.-(!) :: Vector v => v a -> Axis v -> a-v ! i  = component i v   ---- | data constructor for 0-dimensional tensor.-data Vec a = Vec -infixl 3 :~--- | data constructor for constructing n+1-dimensional tensor--- from n-dimensional tensor.-data n :~ a = (n a) :~ a--deriving instance (Eq a) => Eq (Vec a)-deriving instance (Eq a, Eq (n a)) => Eq (n :~ a)-deriving instance (Ord a) => Ord (Vec a)-deriving instance (Ord a, Ord (n a)) => Ord (n :~ a)-deriving instance (Show a) => Show (Vec a)-deriving instance (Show a, Show (n a)) => Show (n :~ a)-deriving instance (Read a) => Read (Vec a)-deriving instance (Read a, Read (n a)) => Read (n :~ a)--instance Foldable Vec where-  foldMap = foldMapDefault-instance Functor Vec where-  fmap = fmapDefault-instance Traversable Vec where-  traverse _ Vec = pure Vec -instance Applicative Vec where-  pure _  = Vec-  _ <*> _ = Vec--instance (Traversable n) => Foldable ((:~) n) where-  foldMap = foldMapDefault-instance (Traversable n) => Functor ((:~) n) where-  fmap = fmapDefault-instance (Traversable n) => Traversable ((:~) n) where-  traverse f (x :~ y) = (:~) <$> traverse f x <*> f y-instance (Applicative n, Traversable n) => Applicative ((:~) n) where-  pure x = pure x :~ x-  (vf :~ f) <*> (vx :~ x) = (vf <*> vx :~ f x)------ | An coordinate 'Axis' , labeled by an integer. --- Axis also carries v, the container type for its corresponding--- vector. Therefore, An axis of one type can access only vectors--- of a fixed dimension, but of arbitrary type.-newtype Axis v = Axis {axisIndex::Int} deriving (Eq,Ord,Show,Read)---- | An object that allows component-wise access.-class (Traversable v) => Vector v where-  -- | Get a component within f, a context which allows 'Failure'.-  componentF :: (Failure StringException f) => -                Axis v -- ^the axis of the component you want-                -> v a -- ^the target vector -                -> f a -- ^the component, obtained within a 'Failure' monad-                -  -- | Get a component. This computation may result in a runtime error,-  -- though, as long as the 'Axis' is generated from library functions-  -- such as 'compose', there will be no error.-  component :: Axis v -> v a -> a-  component axis vec = unsafePerformFailure $ componentF axis vec-  -- | The dimension of the vector.-  dimension :: v a -> Int-  -- | Create a 'Vector' from a function that maps -  -- axis to components.-  compose :: (Axis v -> a) -> v a-  -instance Vector Vec where-  componentF axis Vec -    = failureString $ "axis out of bound: " ++ show axis-  dimension _ = 0-  compose _ = Vec --instance (Vector v) => Vector ((:~) v) where-  componentF (Axis i) vx@(v :~ x) -    | i==dimension vx - 1 = return x-    | True                = componentF (Axis i) v-  dimension (v :~ _) = 1 + dimension v-  compose f = let-    xs = compose (\(Axis i)->f (Axis i)) in xs :~ f (Axis (dimension xs))---- | Vector whose components are additive is also additive.-instance (Additive.C a) => Additive.C (Vec a) where-  zero = compose $ const Additive.zero-  x+y  = compose (\i -> component i x + component i y)-  x-y  = compose (\i -> component i x - component i y)-  negate x = compose (\i -> negate $ component i x)-  -instance (Vector v, Additive.C a) => Additive.C ((:~) v a) where-  zero = compose $ const Additive.zero-  x+y  = compose (\i -> component i x + component i y)-  x-y  = compose (\i -> component i x - component i y)-  negate x = compose (\i -> negate $ component i x)---- | Tensor contraction. Create a 'Vector' from a function that maps --- axis to component, then sums over the axis and returns a-contract :: (Vector v, Additive.C a) => (Axis v -> a) -> a-contract f = foldl (+) Additive.zero (compose f)------ | 'VectorRing' is a 'Vector' whose components belongs to 'Ring.C', --- thus providing unit vectors.-class  (Vector v, Ring.C a) => VectorRing v a where-  -- | A vector where 'Axis'th component is unity but others are zero.-  unitVectorF :: (Failure StringException f) => Axis v -> f (v a)-  -- | pure but unsafe version means of obtaining a 'unitVector'-  unitVector :: Axis v -> v a-  unitVector = unsafePerformFailure . unitVectorF-    -instance (Ring.C a) => VectorRing Vec a where-  unitVectorF axis-      = failureString $ "axis out of bound: " ++ show axis--instance (Ring.C a, VectorRing v a, Additive.C (v a)) -    => VectorRing ((:~) v) a where-  unitVectorF axis@(Axis i) = ret-    where-      z = Additive.zero-      d = dimension z-      ret-        | i < 0 || i >= d   = failureString $ "axis out of bound: " ++ show axis-        | i == d-1          = return $ Additive.zero :~ Ring.one-        | 0 <= i && i < d-1 = liftM (:~ Additive.zero) $ unitVectorF (Axis i)-        | True              = return z -        -- this last guard never matches, but needed to infer the type of z.---- | Type synonyms-type Vec0 = Vec-type Vec1 = (:~) Vec0-type Vec2 = (:~) Vec1-type Vec3 = (:~) Vec2-type Vec4 = (:~) Vec3
Paraiso.cabal view
@@ -15,7 +15,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.0.0.0+Version:             0.1.0.0  -- A short (one-line) description of the package. Synopsis:            a code generator for partial differential equations solvers.@@ -36,37 +36,26 @@              > How to use 	     . -             The module "Language.Paraiso.OM.Builder" contains the @Builder@-             monad, its typeclass instance declarations and functions that can-             be used to build Paraiso programs. Reserved words are @load@,-             @store@, @imm@, @loadIndex@, @shift@, @reduce@ and @broadcast@.+             The module "Language.Paraiso.OM.Builder" contains the+             @Builder@ monad, its typeclass instance declarations and+             functions that can be used to build Paraiso+             programs. Reserved words are @load@, @store@, @imm@,+             @loadIndex@, @loadSize@, @shift@, @reduce@ and+             @broadcast@.               .--             "Language.Paraiso.Tensor" is the library for tensor calculus of+             Paraiso frontend uses "Data.Tensor.Typelevel"+             <http://hackage.haskell.org/package/typelevel-tensor>,+             the library for tensor calculus of 	     arbitrary rank and dimension. @Vector@ and @Axis@ are two main 	     concepts. The type @Vector@ represents rank-1 tensor, and tensors 	     of higher ranks are recursively defined as @Vector@ of 	     @Vector@s. With @Axis@ you can refer to the components of-	     @Vector@s, compose them, or contract them. Standalone usecases of-	     @Tensor@ library and other components of Paraiso are found in:-	     <https://github.com/nushio3/Paraiso/tree/master/attic>--             .--             * A document describing the current and the future designs :-             <https://github.com/nushio3/Paraiso/blob/master/paper/om.pdf> -             .--             * Sample programs written in Paraiso :-             <https://github.com/nushio3/Paraiso/tree/master/examples> +	     @Vector@s, compose them, or contract them. See the wiki for more detail:+             <http://www.paraiso-lang.org/wiki/>              .--             * The codes generated from the samples :-             <https://github.com/nushio3/Paraiso/tree/exampled/examples>+             * 0.1.0.0 /Binary/ : enhanced backend, code generator for OpenMP and CUDA              .--             * The wiki :-             <http://www.paraiso-lang.org/wiki/>+             * 0.0.0.0 /Atmosphere/ : code generator for single CPU  -- URL for the project homepage or repository. Homepage:            http://www.paraiso-lang.org/wiki/index.php/Main_Page@@ -96,49 +85,111 @@ -- Extra-source-files:    -- Constraint on the version of Cabal needed to build this package.-Cabal-version:       >=1.6+Cabal-version:       >=1.10  +flag test+  description: Build the executable to run unit tests+  default: True+ Library   -- Modules exported by the library.   Exposed-modules:     Language.Paraiso+                       Language.Paraiso.Annotation+                       Language.Paraiso.Annotation.Allocation+                       Language.Paraiso.Annotation.Balloon+                       Language.Paraiso.Annotation.Boundary+                       Language.Paraiso.Annotation.Comment+                       Language.Paraiso.Annotation.Dependency                        Language.Paraiso.Failure                        Language.Paraiso.Generator-                       Language.Paraiso.Generator.Allocation-                       Language.Paraiso.Generator.Cpp+                       Language.Paraiso.Generator.Claris+                       Language.Paraiso.Generator.ClarisTrans+                       Language.Paraiso.Generator.Native+                       Language.Paraiso.Generator.OMTrans+                       Language.Paraiso.Generator.Plan+                       Language.Paraiso.Generator.PlanTrans                        Language.Paraiso.Interval                        Language.Paraiso.Name        +                       Language.Paraiso.OM                        Language.Paraiso.OM.Arithmetic                        Language.Paraiso.OM.Builder                        Language.Paraiso.OM.Builder.Boolean                        Language.Paraiso.OM.Builder.Internal                        Language.Paraiso.OM.DynValue                        Language.Paraiso.OM.Graph+                       Language.Paraiso.OM.PrettyPrint                        Language.Paraiso.OM.Realm                        Language.Paraiso.OM.Reduce                        Language.Paraiso.OM.Value+                       Language.Paraiso.Optimization+                       Language.Paraiso.Optimization.BoundaryAnalysis+                       Language.Paraiso.Optimization.DeadCodeElimination+                       Language.Paraiso.Optimization.DecideAllocation+                       Language.Paraiso.Optimization.DependencyAnalysis+                       Language.Paraiso.Optimization.Graph+                       Language.Paraiso.Optimization.Identity                        Language.Paraiso.Orthotope                        Language.Paraiso.PiSystem-                       Language.Paraiso.POM                        Language.Paraiso.Prelude-                       Language.Paraiso.Tensor                              -- Packages needed in order to build this package.-  Build-depends:       base                  >= 4.3.1 && < 4.4,-                       containers            >= 0.4.0 && < 0.5,-                       control-monad-failure >= 0.7.0 && < 0.8,-                       directory             >= 1.1.0 && < 1.2,-                       filepath              >= 1.2.0 && < 1.3,-                       fgl                   >= 5.4.2 && < 5.5,-                       mtl                   >= 2.0.1 && < 2.1,-                       numeric-prelude       >= 0.2.1 && < 0.3,-                       repa                  >= 2.0.0 && < 2.1+  Build-depends:       base                  == 4.*,+                       containers            >= 0.4.0  && < 0.5,+                       control-monad-failure >= 0.7.0  && < 0.8,+                       directory             >= 1.1.0  && < 1.2,+                       filepath              >= 1.2.0  && < 1.3,+                       fgl                   >= 5.4.2  && < 5.5,+                       ListLike              >= 3.1.1  && < 3.2,+                       listlike-instances    >= 0.1    && < 0.2,+                       mtl                   >= 2.0.1  && < 2.1,+                       numeric-prelude       >= 0.2.1  && < 0.3,+                       process               >= 1.0.1  && < 1.0.2,+                       random                >= 1.0.0  && < 1.1,+                       text                  >= 0.11.1 && < 0.12,+                       typelevel-tensor      >= 0.1,+                       vector                >= 0.7.1  && < 0.7.2   -- Modules not exported by this package.   -- Other-modules:             -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools:         ++  ghc-options:    -O3 -Wall   -fspec-constr-count=25+++  Default-Language: Haskell2010+ source-repository head     type:     git     location: https://github.com/nushio3/Paraiso     ++test-suite runtests+    type: exitcode-stdio-1.0+    build-depends:     base                  == 4.*,+                       containers            >= 0.4.0  && < 0.5,+                       control-monad-failure >= 0.7.0  && < 0.8,+                       directory             >= 1.1.0  && < 1.2,+                       filepath              >= 1.2.0  && < 1.3,+                       fgl                   >= 5.4.2  && < 5.5,+                       ListLike              >= 3.1.1  && < 3.2,+                       listlike-instances    >= 0.1    && < 0.2,+                       mtl                   >= 2.0.1  && < 2.1,+                       numeric-prelude       >= 0.2.1  && < 0.3,+                       process               >= 1.0.1  && < 1.0.2,+                       random                >= 1.0.0  && < 1.1,+                       text                  >= 0.11.1 && < 0.12,+                       typelevel-tensor      >= 0.1,+                       vector                >= 0.7.1  && < 0.7.2,++                       test-framework,+                       test-framework-quickcheck2,+                       test-framework-hunit,+                       HUnit,+                       QuickCheck >= 2 && < 3+    main-is: runtests.hs+    +    ghc-options:     -Wall -O3  -fspec-constr-count=25+    Default-Language: Haskell2010+