packages feed

Paraiso 0.1.0.2 → 0.2.0.1

raw patch · 35 files changed

+474/−72 lines, 35 files

Files

Language/Paraiso/Annotation.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-} {-# OPTIONS -Wall #-} -- | 'Annotation' is a collection of 'Typeable's  -- with which you can annotate each OM node.@@ -8,10 +8,11 @@      Annotation, add, empty, map, set, weakSet, toList, toMaybe     ) where +import           Control.Monad import           Data.Dynamic import           Data.Maybe-import           Language.Paraiso.Prelude hiding (map, toList)-import qualified Language.Paraiso.Prelude as P (map)+import           Prelude hiding (map)+import qualified Prelude as P (map)  type Annotation = [Dynamic]
Language/Paraiso/Annotation/Allocation.hs view
@@ -1,17 +1,21 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# 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(..)+  Allocation(..), AllocationChoice(..)   ) where  import Data.Dynamic import Language.Paraiso.Prelude+import Prelude (Eq, Show)  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)++data AllocationChoice = AllocationChoice [Allocation]   deriving (Eq, Show, Typeable)
Language/Paraiso/Annotation/Balloon.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-} -- | An 'Annotation' that sets the execution priority of the  -- statements. Statements with 'Ballon's will be allocated@@ -11,6 +11,7 @@  import Data.Dynamic import Language.Paraiso.Prelude+import Prelude (Eq, Ord)  data (Ord a, Typeable a) => Balloon a     = Balloon a
Language/Paraiso/Annotation/Boundary.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, NoImplicitPrelude, StandaloneDeriving, +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, StandaloneDeriving,  UndecidableInstances #-} {-# OPTIONS -Wall #-}
Language/Paraiso/Annotation/Comment.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-} -- | An effectless 'Annotation' with a comment
Language/Paraiso/Annotation/Dependency.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-} -- | An 'Annotation' that describes the dependency of the nodes -- and labels certain group of Manifest nodes
Language/Paraiso/Annotation/Execution.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-} -- | An effectless 'Annotation' with a comment
+ Language/Paraiso/Annotation/SyncThreads.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# OPTIONS -Wall #-}+-- | An 'Annotation' that lets you call __syncthreads() before+-- or after a statement.++module Language.Paraiso.Annotation.SyncThreads (+  Timing(..)+  ) where++import Data.Dynamic+import Language.Paraiso.Prelude++data Timing = Pre | Post+      deriving (Eq, Ord, Typeable)
Language/Paraiso/Generator.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE  FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE CPP,  FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-} {-# OPTIONS -Wall #-} -- | a general code generator definition. module Language.Paraiso.Generator@@ -6,6 +6,7 @@       generate, generateIO     ) where +import           Control.Monad import qualified Language.Paraiso.Annotation            as Anot import qualified Language.Paraiso.Generator.Claris      as C import qualified Language.Paraiso.Generator.ClarisTrans as C@@ -20,6 +21,7 @@ import qualified Data.Text.IO                           as T import           System.Directory (createDirectoryIfMissing) import           System.FilePath  ((</>))+import           Prelude hiding ((++))   -- | Perform the code generation and returns the list of written
Language/Paraiso/Generator/Claris.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses,+{-# LANGUAGE CPP, DeriveDataTypeable, MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings, RankNTypes #-} {-# OPTIONS -Wall #-} -- | [CLARIS] C++-Like Abstract Representation of Intermediate Syntax.@@ -36,6 +36,7 @@ import qualified Data.Dynamic as Dyn import           Language.Paraiso.Name import           Language.Paraiso.Prelude+import NumericPrelude  -- | A Claris program. data Program
Language/Paraiso/Generator/ClarisTrans.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleContexts, ImpredicativeTypes,-MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings,+{-# LANGUAGE CPP, FlexibleContexts, ImpredicativeTypes, NoImplicitPrelude,+MultiParamTypeClasses, OverloadedStrings, RankNTypes #-}  {-# OPTIONS -Wall #-}@@ -9,6 +9,7 @@   headerFile, sourceFile, Context   ) where +import           Control.Monad  import qualified Data.Dynamic as Dyn import qualified Data.List as L import qualified Data.ListLike as LL@@ -16,6 +17,7 @@ import           Language.Paraiso.Generator.Claris import           Language.Paraiso.Name import           Language.Paraiso.Prelude+import           NumericPrelude hiding ((++))  class Translatable a where   translate :: Context -> a -> Text
Language/Paraiso/Generator/Native.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE CPP, KindSignatures #-} {-# OPTIONS -Wall #-} -- | informations for generating native codes. @@ -18,7 +18,7 @@       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)-    }+    } deriving (Show)  defaultSetup :: (Opt.Ready v g) => v g -> Setup v g defaultSetup sz
Language/Paraiso/Generator/OMTrans.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE  NoImplicitPrelude #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS -Wall #-}  module Language.Paraiso.Generator.OMTrans (@@ -26,7 +26,7 @@ import qualified Language.Paraiso.Optimization          as Opt import qualified Language.Paraiso.PiSystem              as Pi import           Language.Paraiso.Prelude-+import           NumericPrelude hiding ((++))   data Triplet v g
Language/Paraiso/Generator/Plan.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses, NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE CPP, FunctionalDependencies, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS -Wall #-}  -- | Taking the optimized OM as the input,@@ -24,6 +25,7 @@ import qualified Language.Paraiso.OM.Graph as OM import qualified Language.Paraiso.OM.Realm as Realm import           Language.Paraiso.Prelude+import           NumericPrelude hiding ((++))   -- | A data structure that contains all informations
Language/Paraiso/Generator/PlanTrans.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, ExistentialQuantification, NoImplicitPrelude, -OverloadedStrings, TupleSections #-}+{-# LANGUAGE CPP, DeriveDataTypeable, ExistentialQuantification, +NoImplicitPrelude, OverloadedStrings, TupleSections #-} {-# OPTIONS -Wall #-}  module Language.Paraiso.Generator.PlanTrans (@@ -14,12 +14,14 @@ import           Data.List (sortBy) import qualified Data.ListLike.String                as LL import           Data.ListLike.Text ()+import qualified Data.Foldable                       as F 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.Annotation.SyncThreads as Sync import qualified Language.Paraiso.Generator.Claris   as C import qualified Language.Paraiso.Generator.Native   as Native import qualified Language.Paraiso.Generator.Plan     as Plan@@ -29,7 +31,8 @@ import qualified Language.Paraiso.OM.Realm           as Realm import qualified Language.Paraiso.Optimization.Graph as Opt import           Language.Paraiso.Name-import           Language.Paraiso.Prelude+import           Language.Paraiso.Prelude hiding (Boolean(..))+import           NumericPrelude hiding ((++))   type AnAn = Anot.Annotation@@ -105,10 +108,10 @@   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+    size = F.toList $ Native.localSize setup+    memorySize = F.toList $ Native.localSize setup + Plan.lowerMargin plan + Plan.upperMargin plan+    lM = F.toList $ Plan.lowerMargin plan+    uM = F.toList $ Plan.upperMargin plan      makeMami alone label xs =        (if not alone then (finale label xs :) else id)  $@@ -236,6 +239,10 @@                 "lowerMargin = " ++ showT (Plan.lowerBoundary subker),                 "upperMargin = " ++ showT (Plan.upperBoundary subker)               ],+              C.RawStatement "{static bool fst = false;",+              C.StmtExpr $ C.FuncCallStd "if (fst) cudaFuncSetCacheConfig" +                 [mkVarExpr $ nameText cudaHelperName, mkVarExpr "cudaFuncCachePreferL1"],+              C.RawStatement "fst = true;}",               C.StmtExpr $ C.CudaFuncCallUsr cudaHelperName (C.toDyn gridDim) (C.toDyn blockDim) $               map takeRaw $                (V.toList $ Plan.labNodesIn subker) ++ (V.toList $ Plan.labNodesOut subker)@@ -331,8 +338,8 @@     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+    memorySize   = F.toList $ Native.localSize setup + Plan.lowerMargin plan + Plan.upperMargin plan+    boundarySize = F.toList $ Native.localSize setup + Plan.lowerMargin plan + Plan.upperMargin plan      - Plan.lowerBoundary subker - Plan.upperBoundary subker      codecDiv = @@ -373,6 +380,7 @@       Set.toList allIdxSet      buildExprs (idx, val@(DVal.DynValue r c)) = +      addSyncFunctions idx  $       map (\cursor ->              lhs cursor             (fst $ rhsAndRequest env idx cursor)@@ -389,6 +397,20 @@           else flip C.VarDefSub expr                 (C.Var (C.UnitType c) $ nodeNameCursored env idx cursor) +    addSyncFunctions :: FGL.Node -> [C.Statement] -> [C.Statement] +    addSyncFunctions idx = +      if realm /= Realm.Local ||+         Native.language setup /= Native.CUDA +         then id+         else foldl (.) id $ map adder anot+      where+        anot :: [Sync.Timing]+        anot =  (maybeToList $ FGL.lab graph idx) >>= (Anot.toList . OM.getA)+          +        adder :: Sync.Timing -> [C.Statement] -> [C.Statement]  +        adder Sync.Pre  = ([C.RawStatement "__syncthreads();"] ++ )+        adder Sync.Post = ( ++ [C.RawStatement "__syncthreads();"])+     -- lhsCursors :: (Opt.Ready v g) => V.Vector(Set.Set(v g))     lhsCursors = V.generate idxSize f       where @@ -501,7 +523,7 @@ cursorToText _ cursor = cursorT   where     cursorT :: T.Text-    cursorT = foldl1 connector $ compose (\i -> T.map sanitize $ showT (cursor ! i))+    cursorT = F.foldl1 connector $ compose (\i -> T.map sanitize $ showT (cursor ! i))     connector a b = a ++ "_" ++ b     sanitize c       | isDigit c = c
Language/Paraiso/Interval.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, IncoherentInstances #-}+{-# LANGUAGE CPP, 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:
Language/Paraiso/OM.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE  NoImplicitPrelude #-}+{-# LANGUAGE CPP,  NoImplicitPrelude #-} {-# OPTIONS -Wall #-} module Language.Paraiso.OM   (
Language/Paraiso/OM/Arithmetic.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS -Wall #-} module Language.Paraiso.OM.Arithmetic      (
Language/Paraiso/OM/Builder.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, RankNTypes, TypeSynonymInstances  #-}+{-# LANGUAGE CPP, FlexibleInstances, RankNTypes, TypeSynonymInstances  #-} {-# OPTIONS -Wall #-}  -- | A monadic library to build dataflow graphs for OM.
Language/Paraiso/OM/Builder/Boolean.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, NoImplicitPrelude, RankNTypes,+{-# LANGUAGE CPP, FlexibleInstances, RankNTypes,   TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -- | An extension module of building blocks. Contains booleans, comparison operations, branchings.
Language/Paraiso/OM/Builder/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, KindSignatures, NoImplicitPrelude, +{-# LANGUAGE CPP, FlexibleInstances, KindSignatures, NoImplicitPrelude,   PackageImports, RankNTypes, TypeSynonymInstances  #-} {-# OPTIONS -Wall #-} @@ -45,6 +45,7 @@ import           Language.Paraiso.OM.Value as Val import           Language.Paraiso.Prelude import qualified Prelude (Num(..), Fractional(..))+import           NumericPrelude hiding ((++))  -- | Create a 'Kernel' from a 'Builder' monad. buildKernel ::
Language/Paraiso/OM/PrettyPrint.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} {-# OPTIONS -Wall #-}  module Language.Paraiso.OM.PrettyPrint (@@ -23,6 +23,7 @@ import           Language.Paraiso.OM.Graph import           Language.Paraiso.Optimization.Graph    as Opt import           Language.Paraiso.Prelude+import           Prelude hiding ((++))  -- | pretty print the OM, neglecting any annotations. prettyPrint :: Opt.Ready v g => OM v g a -> T.Text
Language/Paraiso/OM/Realm.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, UndecidableInstances #-} {-# OPTIONS -Wall #-}  -- | The 'Realm' represents how the data reside in Orthotope Machines.
Language/Paraiso/Optimization.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, KindSignatures, -MultiParamTypeClasses, NoImplicitPrelude, RankNTypes+{-# LANGUAGE CPP, DeriveDataTypeable, KindSignatures, +MultiParamTypeClasses, RankNTypes  #-} {-# OPTIONS -Wall #-} @@ -53,7 +53,8 @@       _  -> optimize O0  data Level -  = O0 -- perform mandatory code analysis+  = Unoptimized -- even mandatory code analyses are not performed+  | O0 -- perform mandatory code analyses   | O1   | O2   | O3
Language/Paraiso/Optimization/BoundaryAnalysis.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-} {-# OPTIONS -Wall #-}  -- | The volume of mesh that contains the correct results shrinks as@@ -15,6 +15,7 @@  import qualified Algebra.Additive            as Additive import qualified Data.Graph.Inductive        as FGL+import           Data.Foldable (toList) import           Data.Maybe import           Data.Tensor.TypeLevel import           Data.Typeable@@ -27,7 +28,7 @@ import           Language.Paraiso.OM.Realm as Realm import           Language.Paraiso.PiSystem import           Language.Paraiso.Prelude-+import           NumericPrelude hiding ((++))  boundaryAnalysis :: (Vector v, Additive.C g, Ord g, Typeable g)                     => Graph v g Anot.Annotation -> Graph v g Anot.Annotation
Language/Paraiso/Optimization/DeadCodeElimination.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude, TupleSections #-}+{-# LANGUAGE CPP, DeriveDataTypeable, TupleSections #-} {-# OPTIONS -Wall #-} module Language.Paraiso.Optimization.DeadCodeElimination (   deadCodeElimination   ) where +import           Control.Applicative import qualified Data.Graph.Inductive                   as FGL import           Data.Maybe import qualified Data.Vector                            as V@@ -12,6 +13,7 @@ import           Language.Paraiso.Prelude import           Language.Paraiso.OM.Graph import           Language.Paraiso.Optimization.Graph+import           Prelude hiding ((++))  -- | an optimization that changes nothing. deadCodeElimination :: Optimization
Language/Paraiso/Optimization/DecideAllocation.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-}  -- | The choice of making each Orthotope Machine node Manifest or not@@ -17,7 +17,6 @@ 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@@ -33,13 +32,22 @@                   = Anot.set Alloc.Manifest       | (isGlobal || beforeShift || afterShift ) && False -- warehouse                   = Anot.weakSet Alloc.Delayed-      | otherwise = Anot.weakSet Alloc.Delayed+      | otherwise = Anot.weakSet Alloc.Delayed . setChoice         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++          setChoice +            | isValue   = Anot.set $ Alloc.AllocationChoice [Alloc.Delayed, Alloc.Manifest]+            | otherwise = id++          isValue  = case self0 of+            Just (NValue _ _) -> True+            _                 -> False+           isGlobal  = case self0 of             Just (NValue (DVal.DynValue Realm.Global _) _) -> True             _                                              -> False
Language/Paraiso/Optimization/DependencyAnalysis.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-}  -- | This module performs dependency analysis for generating subroutines. @@ -31,7 +31,6 @@ 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
Language/Paraiso/Optimization/Graph.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE  FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, -NoImplicitPrelude, RankNTypes, UndecidableInstances #-}+{-# LANGUAGE CPP,  FlexibleContexts, FlexibleInstances, KindSignatures, MultiParamTypeClasses, + RankNTypes, UndecidableInstances #-} {-# OPTIONS -Wall #-}  -- | Basic definitions for optimization @@ -19,7 +19,6 @@ 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
Language/Paraiso/Optimization/Identity.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, NoImplicitPrelude #-}+{-# LANGUAGE CPP, DeriveDataTypeable #-} {-# OPTIONS -Wall #-} module Language.Paraiso.Optimization.Identity (   identity
Language/Paraiso/Orthotope.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE CPP, TypeOperators #-}  {- |  In geometry, an 'Orthotope' (also called a hyperrectangle or a box) is   the generalization of a rectangle for higher dimensions, formally
Language/Paraiso/PiSystem.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators, FlexibleInstances, OverlappingInstances #-}+{-# LANGUAGE CPP, TypeOperators, FlexibleInstances, OverlappingInstances #-}  {- | In mathematics, a pi-system is a non-empty family of sets that is closed under finite intersections.  -}
Language/Paraiso/Prelude.hs view
@@ -1,34 +1,26 @@-{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction, RankNTypes #-}+{-# LANGUAGE CPP, NoImplicitPrelude, NoMonomorphismRestriction, RankNTypes #-} {-# OPTIONS -Wall #-} {-# OPTIONS_HADDOCK hide #-} -- | an extension of the standard Prelude for paraiso.  module Language.Paraiso.Prelude   (-   module Control.Applicative,-   module Control.Monad,-   module Data.Foldable,-   module Data.Traversable,-   module NumericPrelude,    Boolean(..),    Text, showT,     (++)) where-+{- 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++import NumericPrelude hiding ((++))  -- | An efficient String that is used thoroughout Paraiso modules. type Text = Text.Text
+ Language/Paraiso/Tuning/Genetic.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, NoImplicitPrelude, PackageImports #-}+{-# OPTIONS -Wall #-}+module Language.Paraiso.Tuning.Genetic+  (+   Genome, Species(..),+   makeSpecies,+   readGenome, overwriteGenome,+   mutate, cross, triangulate,+   generateIO+  ) where++import qualified "mtl" Control.Monad.State as State+import qualified Data.Graph.Inductive                   as FGL+import qualified Data.Vector as V+import           Data.Vector ((!))+import qualified Language.Paraiso.Annotation as Anot+import qualified Language.Paraiso.Annotation.Allocation as Alloc+import qualified Language.Paraiso.Annotation.SyncThreads as Sync+import qualified Language.Paraiso.Generator.Native as Native+import qualified Language.Paraiso.OM as OM+import qualified Language.Paraiso.OM.Graph as OM+import qualified Language.Paraiso.Optimization          as Opt+import           Language.Paraiso.Prelude hiding (Boolean(..))+import qualified Language.Paraiso.Generator as Gen  (generateIO) +import qualified Prelude as Prelude+import           NumericPrelude hiding ((++))+import           System.Random +import qualified Text.Read as Read++data Species v g = +  Species {+    setup   :: Native.Setup v g,+    machine :: OM.OM v g Anot.Annotation+  } deriving (Show)++makeSpecies :: Native.Setup v g -> OM.OM v g Anot.Annotation -> Species v g+makeSpecies = Species++generateIO :: (Opt.Ready v g) => Species v g -> IO [(FilePath, Text)]+generateIO (Species s om) = Gen.generateIO s om++newtype Genome = Genome [Bool] deriving (Eq)++instance Show Genome where+  show (Genome xs) = show $ toDNA xs++instance Read Genome where+  readPrec = fmap (Genome . fromDNA) Read.readPrec++toDNA :: [Bool] -> String+toDNA xss@(x:xs)+  | even $ length xss = 'C' : inner xss+  | not x             = 'A' : inner xs+  | otherwise         = 'T' : inner xs+  where+    inner [] = ""+    inner (x:y:xs) = inner1 x y : inner xs+    inner _ = error "parity conservation law is broken"++    inner1 False False = 'A'+    inner1 False True  = 'C'+    inner1 True  False = 'G'+    inner1 True  True  = 'T'++fromDNA :: String -> [Bool]+fromDNA xss@(x:xs) +  | x == 'C'  = inner xs+  | x == 'A'  = False : inner xs+  | x == 'T'  = True  : inner xs+  | otherwise = error "bad DNA"+  where+    inner = concat . map inner1+    inner1 :: Char -> [Bool]+    inner1 'A' = [False, False]+    inner1 'C' = [False, True ]+    inner1 'G' = [True , False]+    inner1 'T' = [True , True ]+    inner1 _   = error "bad DNA"++mutate :: Genome -> IO Genome+mutate original@(Genome xs) = do+  let oldVector = V.fromList xs+      n = length xs+      logN :: Double+      logN = log (fromIntegral n)+  -- 20% of the mutations are single point mutation+  logRand <- randomRIO (-0.2 * logN, logN)+  mutaCoin <- randomRIO (0, 1::Double)+  let randN :: Int+      randN = Prelude.max 1 $ ceiling $ exp logRand+      randRanges = V.replicate randN (0, n - 1)+      randUpd range = do+        idx <- randomRIO range+        let newVal+              -- 50% are negating mutations+              | mutaCoin < 0.5 || randN <= 1 = not $ oldVector ! idx+              -- 25% are all True mutation+              | mutaCoin < 0.75              = True+              -- other 25% are all False mutation+              | otherwise                    = False +        return (idx, newVal)+  randUpds <- V.mapM randUpd randRanges+  let pureMutant = Genome $ V.toList $ V.update oldVector randUpds+  if randN > 8+     then return pureMutant >>= cross original >>= cross original+     else return pureMutant++cross :: Genome -> Genome -> IO Genome+cross (Genome xs0) (Genome ys0) = do+  swapCoin <- randomRIO (0,1)+  let +    (xs,ys) = if swapCoin < (0.5::Double) then (xs0, ys0) else (ys0, xs0)+    n =  Prelude.max (length xs) (length ys)+    vx = V.fromList $ take n $ xs ++ repeat False+    vy = V.fromList $ take n $ ys ++ repeat False+    atLeast :: Int -> IO Int+    atLeast n = do+      coin <- randomRIO (0,1)+      if coin < (0.5 :: Double) +         then return n+         else atLeast (n+1)+  randN <- atLeast 1+  let randRanges = replicate randN (-1, n + 1)+  crossPoints <- mapM randomRIO randRanges+  let vz = V.generate n $ \i ->+           if odd $ length $ filter (<i) crossPoints then vx!i else vy!i+  return $ Genome $ V.toList $ vz++triangulate :: Genome -> Genome -> Genome -> IO Genome+triangulate (Genome base) (Genome left) (Genome right) = do+  return $ Genome $ zipWith3 f base left right+    where+      f b l r = if b/=l then l else r++readGenome :: Species v g -> Genome+readGenome spec =+  encode $ do+    let (x,y) = Native.cudaGridSize $ setup spec+    putInt 16 x+    putInt 16 y+    let om    = machine spec+        kerns = OM.kernels om+    V.mapM_ (putGraph . OM.dataflow) kerns++overwriteGenome :: (Opt.Ready v g) => Genome -> Species v g -> Species v g+overwriteGenome dna oldSpec = +  decode dna $ do+    -- load cuda grid topology from the genome+    x <- getInt 16+    y <- getInt 16+    let oldSetup = setup oldSpec+        oldOM = machine oldSpec+        oldKernels = OM.kernels oldOM+        oldFlags = OM.globalAnnotation $ OM.setup $ oldOM+    let overwriteKernel kern = do+                 let graph = OM.dataflow kern+                 newGraph <- overwriteGraph graph+                 return $ kern{OM.dataflow = newGraph}+    -- load manifesto from the genome+    newKernels <- V.mapM overwriteKernel oldKernels+    let newGrid = (x,y)+        newSetup = oldSetup {Native.cudaGridSize = newGrid}+        -- reset the optimization flag and cause the optimization again+        newFlags = Anot.set Opt.Unoptimized oldFlags+        newOM = oldOM +          { OM.kernels = newKernels, +            OM.setup   = (OM.setup oldOM){ OM.globalAnnotation = newFlags }+          }+    return $ Species newSetup (Opt.optimize Opt.O3 newOM)++++newtype Get a = Get { getGet :: State.State [Bool] a } deriving (Monad)+newtype Put a = Put { getPut :: State.State [Bool] a } deriving (Monad)++get :: Get Bool+get = Get $ do+  dat <- State.get+  case dat of+    (x:xs) -> do+      State.put xs+      return x+    _ -> return False -- When the data is depleted default to False++put :: Bool -> Put ()+put x = Put $ do+  xs <- State.get+  State.put $ x:xs++decode :: Genome -> Get a -> a+decode (Genome dna) m = State.evalState (getGet m) dna++encode :: Put a -> Genome +encode m = Genome $ reverse $ State.execState (getPut m) []++putInt :: Int -> Int -> Put ()+putInt bit n +  | bit <= 0  = return ()+  | n >= val  = do+    put True+    putInt (bit-1) (n-val)+  | otherwise = do+    put False+    putInt (bit-1) n+  where +    val :: Int+    val = 2^(fromIntegral $ bit-1)++getInt :: Int -> Get Int+getInt bit+  | bit <= 0  = return 0+  | otherwise = do+    x <- get+    y <- getInt (bit-1)+    return $ y + 2^(fromIntegral $ bit-1) * (if x then 1 else 0)++putGraph :: OM.Graph v g Anot.Annotation -> Put ()+putGraph graph = do+  V.mapM_ put focus+  V.mapM_ put2 focus2+  where+    focus = +      V.map (isManifest . OM.getA . snd) $+      V.filter (hasChoice . OM.getA . snd) idxNodes++    -- idxNodes :: V.Vector (FGL.Node, OM.Node v g a)+    idxNodes = V.fromList $ FGL.labNodes graph++    hasChoice :: Anot.Annotation -> Bool+    hasChoice anot = +      case Anot.toMaybe anot of+        Just (Alloc.AllocationChoice _) -> True+        _                               -> False++    isManifest :: Anot.Annotation -> Bool+    isManifest anot = +      case Anot.toMaybe anot of+        Just Alloc.Manifest -> True+        _                   -> False++    focus2 = +      V.map (getSyncBools . OM.getA . snd) $+      V.filter (isValue . snd) idxNodes++    isValue nd = case nd of+      OM.NValue _ _ -> True+      _             -> False++    getSyncBools :: Anot.Annotation -> (Bool, Bool)+    getSyncBools xs = let ys = Anot.toList xs in+      (Sync.Pre `elem` ys, Sync.Post `elem` ys)++    put2 (a,b) = put a >> put b++++overwriteGraph :: OM.Graph v g Anot.Annotation -> Get (OM.Graph v g Anot.Annotation)+overwriteGraph graph = do+  ovs  <- V.mapM getAt  focusIndices+  ovs2 <- V.mapM getAt2 focus2Indices  +  return $ overwrite ovs2 $ overwrite ovs graph+  where+    overwrite ovs = +      let updater :: V.Vector (Anot.Annotation -> Anot.Annotation)+          updater = +            flip V.update ovs $+            V.map (const id) idxNodes in+      OM.imap $ \idx anot -> updater ! idx $ anot++    getAt idx = do+      ret <- get+      return (idx, Anot.set $ if ret then Alloc.Manifest else Alloc.Delayed)++    getAt2 idx = do+      a <- get+      b <- get+      return (idx, (if a then Anot.set Sync.Pre else id) . (if b then Anot.set Sync.Post else id))++    focusIndices = +      V.map fst $+      V.filter (hasChoice . OM.getA . snd) idxNodes++    focus2Indices = +      V.map fst $+      V.filter (isValue . snd) idxNodes++    idxNodes = V.fromList $ FGL.labNodes graph++    hasChoice :: Anot.Annotation -> Bool+    hasChoice anot = +      case Anot.toMaybe anot of+        Just (Alloc.AllocationChoice _) -> True+        _                               -> False++    isManifest :: Anot.Annotation -> Bool+    isManifest anot = +      case Anot.toMaybe anot of+        Just Alloc.Manifest -> True+        _                   -> False++    isValue nd = case nd of+      OM.NValue _ _ -> True+      _             -> False++++{-+overwriteGraph :: OM.Graph v g Anot.Annotation -> Get (OM.Graph v g Anot.Annotation)+overwriteGraph graph = do+  ovs <- V.mapM getAt focusIndices+  return $ overwritten ovs+  where+    overwritten ovs = +      let newManifest ::  V.Vector (Maybe Alloc.Allocation)+          newManifest = +            flip V.update ovs $+            V.map (const Nothing) anots in+      flip OM.imap graph $ \idx anot -> +        case newManifest ! idx of+          Nothing -> anot+          Just x  -> Anot.set x anot++    getAt idx = do+      ret <- get+      return (idx, Just $ if ret then Alloc.Manifest else Alloc.Delayed)++    focusIndices = +      V.map fst $+      V.filter (hasChoice . snd) anots++    anots :: V.Vector (FGL.Node, Anot.Annotation)+    anots = V.fromList $ map (\(n, lab) -> (n, OM.getA lab)) $ FGL.labNodes graph+++    hasChoice :: Anot.Annotation -> Bool+    hasChoice anot = +      case Anot.toMaybe anot of+        Just (Alloc.AllocationChoice _) -> True+        _                               -> False++    isManifest :: Anot.Annotation -> Bool+    isManifest anot = +      case Anot.toMaybe anot of+        Just Alloc.Manifest -> True+        _                   -> False+++-}
Paraiso.cabal view
@@ -15,7 +15,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.1.0.2+Version:             0.2.0.1  -- A short (one-line) description of the package. Synopsis:            a code generator for partial differential equations solvers.@@ -88,6 +88,7 @@ Cabal-version:       >=1.10  + flag test   description: Build the executable to run unit tests   default: True@@ -102,6 +103,7 @@                        Language.Paraiso.Annotation.Comment                        Language.Paraiso.Annotation.Dependency                        Language.Paraiso.Annotation.Execution+                       Language.Paraiso.Annotation.SyncThreads                        Language.Paraiso.Failure                        Language.Paraiso.Generator                        Language.Paraiso.Generator.Claris@@ -133,7 +135,8 @@                        Language.Paraiso.Orthotope                        Language.Paraiso.PiSystem                        Language.Paraiso.Prelude-                          +                       Language.Paraiso.Tuning.Genetic+   -- Packages needed in order to build this package.   Build-depends:       base                  == 4.*,                        containers            >= 0.4.0  && < 0.5,@@ -155,7 +158,6 @@      -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools:         -   ghc-options:    -O3 -Wall   -fspec-constr-count=25  @@ -190,7 +192,6 @@                        HUnit,                        QuickCheck >= 2 && < 3     main-is: runtests.hs-         ghc-options:     -Wall -O3  -fspec-constr-count=25     Default-Language: Haskell2010