diff --git a/Language/Paraiso.hs b/Language/Paraiso.hs --- a/Language/Paraiso.hs +++ b/Language/Paraiso.hs @@ -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 diff --git a/Language/Paraiso/Annotation.hs b/Language/Paraiso/Annotation.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Annotation.hs @@ -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 diff --git a/Language/Paraiso/Annotation/Allocation.hs b/Language/Paraiso/Annotation/Allocation.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Annotation/Allocation.hs @@ -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) diff --git a/Language/Paraiso/Annotation/Balloon.hs b/Language/Paraiso/Annotation/Balloon.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Annotation/Balloon.hs @@ -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) diff --git a/Language/Paraiso/Annotation/Boundary.hs b/Language/Paraiso/Annotation/Boundary.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Annotation/Boundary.hs @@ -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) + diff --git a/Language/Paraiso/Annotation/Comment.hs b/Language/Paraiso/Annotation/Comment.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Annotation/Comment.hs @@ -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) diff --git a/Language/Paraiso/Annotation/Dependency.hs b/Language/Paraiso/Annotation/Dependency.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Annotation/Dependency.hs @@ -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) + diff --git a/Language/Paraiso/Generator.hs b/Language/Paraiso/Generator.hs --- a/Language/Paraiso/Generator.hs +++ b/Language/Paraiso/Generator.hs @@ -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" + diff --git a/Language/Paraiso/Generator/Allocation.hs b/Language/Paraiso/Generator/Allocation.hs deleted file mode 100644 --- a/Language/Paraiso/Generator/Allocation.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# OPTIONS -Wall #-} -module Language.Paraiso.Generator.Allocation(Allocation(..)) where -data Allocation = Manifest | Delayed | Auto deriving (Eq, Show) diff --git a/Language/Paraiso/Generator/Claris.hs b/Language/Paraiso/Generator/Claris.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Generator/Claris.hs @@ -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) diff --git a/Language/Paraiso/Generator/ClarisTrans.hs b/Language/Paraiso/Generator/ClarisTrans.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Generator/ClarisTrans.hs @@ -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 + + diff --git a/Language/Paraiso/Generator/Cpp.hs b/Language/Paraiso/Generator/Cpp.hs deleted file mode 100644 --- a/Language/Paraiso/Generator/Cpp.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "" - ] - -{---- -----} -{---- 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 - - - diff --git a/Language/Paraiso/Generator/Native.hs b/Language/Paraiso/Generator/Native.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Generator/Native.hs @@ -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) + diff --git a/Language/Paraiso/Generator/OMTrans.hs b/Language/Paraiso/Generator/OMTrans.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Generator/OMTrans.hs @@ -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++| / | | | | + \ `----' / | | | _| + ' ' | | | | \ + / \ | | | | | + | | \ | | | | | + \ -'''''''~ -'''''''~ |_|- | | + \ ___(`)(`)`)) (`.(`)(`)`)) /_____\ + + + + + + / + ------------- . + / \ / / + / \ ______ / + / \ \ |- - _ - + | | \| | | | _ - + \ / __ | | | | + \ _ -- -- -- -- -- -- -- / \\\ | | _| _ . + ' . ,_ ||| | | | \ __ --- + / -- -- -- -- -- -- --.__ .. | | | | + | \ | | | | + -'''''''~ /_|- | | + (`.(`)(`)`)) /_____\ + + + + + + + + + + . ' + | ' + \ / + ----\----|--- / + / \ | /\ +-- __ ___ \ ______ +/ -- / \ - -- -- -- -- -- -| |- - +| | , , | | | | + \ \_ \_ ,--- -- -- -- -- --| | | | + \ / | | | _| + ' ' | | | | \ + / \ | | | | | + | | \ | | | | | + \ -'''''''~ -'''''''~ |_|- | | + \ ___(`)(`)`)) (`.(`)(`)`)) /_____\ + + + + + + +-} diff --git a/Language/Paraiso/Generator/Plan.hs b/Language/Paraiso/Generator/Plan.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Generator/Plan.hs @@ -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 ++ "]" + diff --git a/Language/Paraiso/Generator/PlanTrans.hs b/Language/Paraiso/Generator/PlanTrans.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Generator/PlanTrans.hs @@ -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 T broadcast (const T& x) {\n return x;\n}\ntemplate T reduce_sum (const std::vector &xs) {\n T ret = 0;\n for (int i = 0; i < xs.size(); ++i) ret+=xs[i];\n return ret;\n}\ntemplate T reduce_min (const std::vector &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 T reduce_max (const std::vector &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 \n__device__ __host__\nT broadcast (const T& x) {\n return x;\n}\ntemplate T reduce_sum (const std::vector &xs) {\n T ret = 0;\n for (int i = 0; i < xs.size(); ++i) ret+=xs[i];\n return ret;\n}\ntemplate T reduce_min (const std::vector &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 T reduce_max (const std::vector &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 T reduce_sum (const thrust::device_vector &xs) {\n return thrust::reduce(xs.begin(), xs.end(), 0, thrust::plus());\n}\ntemplate T reduce_min (const thrust::device_vector &xs) {\n return *(thrust::min_element(xs.begin(), xs.end()));\n}\ntemplate T reduce_max (const thrust::device_vector &xs) {\n return *(thrust::max_element(xs.begin(), xs.end()));\n}\n\n" diff --git a/Language/Paraiso/Interval.hs b/Language/Paraiso/Interval.hs --- a/Language/Paraiso/Interval.hs +++ b/Language/Paraiso/Interval.hs @@ -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) diff --git a/Language/Paraiso/Name.hs b/Language/Paraiso/Name.hs --- a/Language/Paraiso/Name.hs +++ b/Language/Paraiso/Name.hs @@ -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 diff --git a/Language/Paraiso/OM.hs b/Language/Paraiso/OM.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/OM.hs @@ -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 } diff --git a/Language/Paraiso/OM/Arithmetic.hs b/Language/Paraiso/OM/Arithmetic.hs --- a/Language/Paraiso/OM/Arithmetic.hs +++ b/Language/Paraiso/OM/Arithmetic.hs @@ -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) diff --git a/Language/Paraiso/OM/Builder.hs b/Language/Paraiso/OM/Builder.hs --- a/Language/Paraiso/OM/Builder.hs +++ b/Language/Paraiso/OM/Builder.hs @@ -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 diff --git a/Language/Paraiso/OM/Builder/Boolean.hs b/Language/Paraiso/OM/Builder/Boolean.hs --- a/Language/Paraiso/OM/Builder/Boolean.hs +++ b/Language/Paraiso/OM/Builder/Boolean.hs @@ -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 diff --git a/Language/Paraiso/OM/Builder/Internal.hs b/Language/Paraiso/OM/Builder/Internal.hs --- a/Language/Paraiso/OM/Builder/Internal.hs +++ b/Language/Paraiso/OM/Builder/Internal.hs @@ -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 _ = "<>" -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 - diff --git a/Language/Paraiso/OM/DynValue.hs b/Language/Paraiso/OM/DynValue.hs --- a/Language/Paraiso/OM/DynValue.hs +++ b/Language/Paraiso/OM/DynValue.hs @@ -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 ( diff --git a/Language/Paraiso/OM/Graph.hs b/Language/Paraiso/OM/Graph.hs --- a/Language/Paraiso/OM/Graph.hs +++ b/Language/Paraiso/OM/Graph.hs @@ -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) diff --git a/Language/Paraiso/OM/PrettyPrint.hs b/Language/Paraiso/OM/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/OM/PrettyPrint.hs @@ -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 diff --git a/Language/Paraiso/OM/Realm.hs b/Language/Paraiso/OM/Realm.hs --- a/Language/Paraiso/OM/Realm.hs +++ b/Language/Paraiso/OM/Realm.hs @@ -35,5 +35,5 @@ -- | Realmable instances instance Realmable Realm where realm = id -instance TRealm a => Realmable a where - realm = tRealm + + diff --git a/Language/Paraiso/OM/Value.hs b/Language/Paraiso/OM/Value.hs --- a/Language/Paraiso/OM/Value.hs +++ b/Language/Paraiso/OM/Value.hs @@ -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 diff --git a/Language/Paraiso/Optimization.hs b/Language/Paraiso/Optimization.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization.hs @@ -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) diff --git a/Language/Paraiso/Optimization/BoundaryAnalysis.hs b/Language/Paraiso/Optimization/BoundaryAnalysis.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization/BoundaryAnalysis.hs @@ -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) diff --git a/Language/Paraiso/Optimization/DeadCodeElimination.hs b/Language/Paraiso/Optimization/DeadCodeElimination.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization/DeadCodeElimination.hs @@ -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" diff --git a/Language/Paraiso/Optimization/DecideAllocation.hs b/Language/Paraiso/Optimization/DecideAllocation.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization/DecideAllocation.hs @@ -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 + + + + diff --git a/Language/Paraiso/Optimization/DependencyAnalysis.hs b/Language/Paraiso/Optimization/DependencyAnalysis.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization/DependencyAnalysis.hs @@ -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 ( 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 diff --git a/Language/Paraiso/Optimization/Graph.hs b/Language/Paraiso/Optimization/Graph.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization/Graph.hs @@ -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} + diff --git a/Language/Paraiso/Optimization/Identity.hs b/Language/Paraiso/Optimization/Identity.hs new file mode 100644 --- /dev/null +++ b/Language/Paraiso/Optimization/Identity.hs @@ -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 diff --git a/Language/Paraiso/Orthotope.hs b/Language/Paraiso/Orthotope.hs --- a/Language/Paraiso/Orthotope.hs +++ b/Language/Paraiso/Orthotope.hs @@ -11,8 +11,8 @@ Orthotope1,Orthotope2,Orthotope3 ) where -import Language.Paraiso.Tensor -import Language.Paraiso.Interval +import Data.Tensor.TypeLevel +import Language.Paraiso.Interval diff --git a/Language/Paraiso/POM.hs b/Language/Paraiso/POM.hs deleted file mode 100644 --- a/Language/Paraiso/POM.hs +++ /dev/null @@ -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 - } - - - - - diff --git a/Language/Paraiso/PiSystem.hs b/Language/Paraiso/PiSystem.hs --- a/Language/Paraiso/PiSystem.hs +++ b/Language/Paraiso/PiSystem.hs @@ -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) - diff --git a/Language/Paraiso/Prelude.hs b/Language/Paraiso/Prelude.hs --- a/Language/Paraiso/Prelude.hs +++ b/Language/Paraiso/Prelude.hs @@ -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 diff --git a/Language/Paraiso/Tensor.hs b/Language/Paraiso/Tensor.hs deleted file mode 100644 --- a/Language/Paraiso/Tensor.hs +++ /dev/null @@ -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 diff --git a/Paraiso.cabal b/Paraiso.cabal --- a/Paraiso.cabal +++ b/Paraiso.cabal @@ -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" + , + 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: - - - . - - * A document describing the current and the future designs : - - . - - * Sample programs written in Paraiso : - + @Vector@s, compose them, or contract them. See the wiki for more detail: + . - - * The codes generated from the samples : - + * 0.1.0.0 /Binary/ : enhanced backend, code generator for OpenMP and CUDA . - - * The 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 +