diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,5 @@ +run-test: + runhaskell Setup configure --user --enable-tests + runhaskell Setup build + runhaskell Setup haddock + ./dist/build/knead-test/knead-test diff --git a/knead.cabal b/knead.cabal --- a/knead.cabal +++ b/knead.cabal @@ -1,12 +1,12 @@ Name: knead -Version: 0.2.3 +Version: 1.0.2 License: BSD3 License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann -Homepage: http://hub.darcs.net/thielema/knead/ +Homepage: https://hub.darcs.net/thielema/knead/ Category: Data Structures -Synopsis: Repa array processing using LLVM JIT +Synopsis: Repa-like array processing using LLVM JIT Description: This library processes arrays like @Repa@ and @Accelerate@, but it uses the just-in-time compiler of @LLVM@ @@ -15,7 +15,8 @@ that can be run without a GPU. You do not need to care about inlining and strictness annotations, because the LLVM code is by default inlined and strict. - The package is the basis for an LLVM backend for the @Accelerate@ framework. + The package is intended as the basis + for an LLVM backend for the @Accelerate@ framework. . Highlights: . @@ -42,50 +43,77 @@ . The name of the package is inspired by the visualization of typical operations like reshaping, collapsing a dimension and extruding another one. -Tested-With: GHC==7.4.2, GHC==7.8.4, GHC==8.0.1 -Cabal-Version: >=1.6 +Tested-With: GHC==8.4.4, GHC==8.6.5, GHC==8.10.7 +Tested-With: GHC==9.0.2, GHC==9.2.8, GHC==9.4.6 +Cabal-Version: >=1.10 Build-Type: Simple +Extra-Source-Files: + Makefile Source-Repository this - Tag: 0.2.3 + Tag: 1.0.2 Type: darcs - Location: http://hub.darcs.net/thielema/knead/ + Location: https://hub.darcs.net/thielema/knead/ Source-Repository head Type: darcs - Location: http://hub.darcs.net/thielema/knead/ + Location: https://hub.darcs.net/thielema/knead/ Library Build-Depends: - llvm-extra >=0.7.3 && <0.8, - llvm-tf >=3.1 && <3.2, + llvm-dsl >=0.2 && <0.3, + llvm-extra >=0.12.1 && <0.14, + llvm-tf >=9.0 && <21.1, tfp >=1.0 && <1.1, - storable-tuple >=0.0 && <0.1, - storable-record >=0.0.3 && <0.1, - transformers >=0.3 && <0.6, - utility-ht >=0.0.1 && <0.1, + comfort-array >=0.5 && <0.6, + fixed-length >=0.2.1 && <0.3, + storable-record >=0.0.5 && <0.1, + storable-enum >=0.0 && <0.1, + bool8 >=0.0 && <0.1, + transformers >=0.3 && <0.7, + tagged >=0.7 && <0.9, + utility-ht >=0.0.15 && <0.1, + prelude-compat >=0.0 && <0.0.1, base >=4 && <5 + Default-Language: Haskell98 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: - Data.Array.Knead.Index.Linear.Int - Data.Array.Knead.Index.Linear - Data.Array.Knead.Index.Nested.Shape + Data.Array.Knead.Shape + Data.Array.Knead.Shape.Cubic + Data.Array.Knead.Shape.Cubic.Int Data.Array.Knead.Expression - Data.Array.Knead.Parameter - Data.Array.Knead.Simple.Symbolic - Data.Array.Knead.Simple.ShapeDependent - Data.Array.Knead.Simple.Physical - Data.Array.Knead.Simple.Slice - Data.Array.Knead.Simple.Fold - Data.Array.Knead.Parameterized.Symbolic - Data.Array.Knead.Parameterized.Physical - Data.Array.Knead.Parameterized.Slice - Data.Array.Knead.Parameterized.Render + Data.Array.Knead.Symbolic + Data.Array.Knead.Symbolic.ShapeDependent + Data.Array.Knead.Symbolic.Physical + Data.Array.Knead.Symbolic.Slice + Data.Array.Knead.Symbolic.Fold + Data.Array.Knead.Symbolic.Render Other-Modules: - Data.Array.Knead.Simple.Private - Data.Array.Knead.Simple.PhysicalPrivate - Data.Array.Knead.Parameterized.Private - Data.Array.Knead.Parameterized.PhysicalHull + Data.Array.Knead.Symbolic.RenderAlt + Data.Array.Knead.Symbolic.Render.Basic + Data.Array.Knead.Symbolic.Render.Argument + Data.Array.Knead.Symbolic.Private + Data.Array.Knead.Symbolic.PhysicalParametric + Data.Array.Knead.Symbolic.PhysicalPrivate Data.Array.Knead.Code + Data.Array.Knead.Shape.Orphan + +Test-Suite knead-test + Type: exitcode-stdio-1.0 + Build-Depends: + QuickCheck >=2 && <3, + knead, + comfort-array, + llvm-extra, + llvm-tf, + tfp, + utility-ht, + base + Default-Language: Haskell98 + GHC-Options: -Wall + Hs-Source-Dirs: test + Main-Is: Main.hs + Other-Modules: + Test.Array diff --git a/src/Data/Array/Knead/Code.hs b/src/Data/Array/Knead/Code.hs --- a/src/Data/Array/Knead/Code.hs +++ b/src/Data/Array/Knead/Code.hs @@ -1,56 +1,24 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Data.Array.Knead.Code where -import qualified Data.Array.Knead.Index.Nested.Shape as Shape +import qualified Data.Array.Knead.Shape as Shape -import qualified LLVM.Extra.Multi.Value as MultiValue +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value as NiceValue -import qualified LLVM.ExecutionEngine as EE -import qualified LLVM.Util.Optimize as Opt import qualified LLVM.Core as LLVM -import Foreign.Ptr (Ptr, FunPtr, ) - -import Control.Monad (void, liftM2, when, ) -import Control.Applicative ((<$>), ) +import Foreign.Ptr (Ptr) -import Data.Functor.Compose (Compose(Compose)) +import Prelude2010 +import Prelude () getElementPtr :: - (Shape.C sh, Shape.Index sh ~ ix) => - MultiValue.T sh -> LLVM.Value (Ptr a) -> - MultiValue.T ix -> + (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) => + NiceValue.T sh -> LLVM.Value (Ptr a) -> + NiceValue.T ix -> LLVM.CodeGenFunction r (LLVM.Value (Ptr a)) -getElementPtr sh ptr ix = do - n <- Shape.flattenIndex sh ix - LLVM.getElementPtr ptr (n, ()) - - -compile :: String -> Exec funcs -> IO funcs -compile name (Compose bld) = do - LLVM.initializeNativeTarget - m <- LLVM.newModule - (funcs, mappings) <- - LLVM.defineModule m $ do - LLVM.setTarget LLVM.hostTriple - liftM2 (,) bld LLVM.getGlobalMappings - LLVM.writeBitcodeToFile (name ++ ".bc") m - when False $ do - void $ Opt.optimizeModule 3 m - LLVM.writeBitcodeToFile (name ++ "-opt.bc") m - EE.runEngineAccessWithModule m $ - EE.addGlobalMappings mappings >> funcs - - -type Exec = Compose LLVM.CodeGenModule EE.EngineAccess -type Importer f = FunPtr f -> f - -createFunction :: - (EE.ExecutionFunction f, LLVM.FunctionArgs f) => - Importer f -> String -> LLVM.FunctionCodeGen f -> Exec f -createFunction importer name f = - Compose $ - EE.getExecutionFunction importer - <$> - LLVM.createNamedFunction LLVM.ExternalLinkage name f +getElementPtr sh ptr ix = + flip Storable.advancePtr ptr =<< LLVM.bitcast =<< Shape.offset sh ix diff --git a/src/Data/Array/Knead/Expression.hs b/src/Data/Array/Knead/Expression.hs --- a/src/Data/Array/Knead/Expression.hs +++ b/src/Data/Array/Knead/Expression.hs @@ -1,463 +1,91 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Array.Knead.Expression where - -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Control as C -import qualified LLVM.Extra.Monad as LMonad -import qualified LLVM.Core as LLVM -import LLVM.Extra.Multi.Value (PatternTuple, Decomposed, Atom, atom, ) - -import qualified Control.Monad as Monad - -import qualified Data.Tuple.HT as TupleHT -import qualified Data.Tuple as Tuple -import Data.Complex (Complex((:+))) - -import Prelude - hiding (fst, snd, min, max, zip, unzip, zip3, unzip3, - curry, uncurry, pi, maybe) - - -newtype Exp a = Exp {unExp :: forall r. LLVM.CodeGenFunction r (MultiValue.T a)} - - -class Value val where - lift0 :: MultiValue.T a -> val a - lift1 :: - (MultiValue.T a -> MultiValue.T b) -> - val a -> val b - lift2 :: - (MultiValue.T a -> MultiValue.T b -> MultiValue.T c) -> - val a -> val b -> val c - lift3 :: - (MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> MultiValue.T d) -> - val a -> val b -> val c -> val d - lift4 :: - (MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> MultiValue.T d -> MultiValue.T e) -> - val a -> val b -> val c -> val d -> val e - -instance Value MultiValue.T where - lift0 = id - lift1 = id - lift2 = id - lift3 = id - lift4 = id - -instance Value Exp where - lift0 a = Exp (return a) - lift1 f (Exp a) = Exp (Monad.liftM f a) - lift2 f (Exp a) (Exp b) = Exp (Monad.liftM2 f a b) - lift3 f (Exp a) (Exp b) (Exp c) = Exp (Monad.liftM3 f a b c) - lift4 f (Exp a) (Exp b) (Exp c) (Exp d) = Exp (Monad.liftM4 f a b c d) - - -liftM :: - (forall r. - MultiValue.T a -> - LLVM.CodeGenFunction r (MultiValue.T b)) -> - (Exp a -> Exp b) -liftM f (Exp a) = Exp (f =<< a) - -liftM2 :: - (forall r. - MultiValue.T a -> MultiValue.T b -> - LLVM.CodeGenFunction r (MultiValue.T c)) -> - (Exp a -> Exp b -> Exp c) -liftM2 f (Exp a) (Exp b) = Exp (LMonad.liftR2 f a b) - -liftM3 :: - (forall r. - MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> - LLVM.CodeGenFunction r (MultiValue.T d)) -> - (Exp a -> Exp b -> Exp c -> Exp d) -liftM3 f (Exp a) (Exp b) (Exp c) = Exp (LMonad.liftR3 f a b c) - - -unliftM1 :: - (Exp a -> Exp b) -> - MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T b) -unliftM1 f ix = unExp (f (lift0 ix)) - -unliftM2 :: - (Exp a -> Exp b -> Exp c) -> - MultiValue.T a -> MultiValue.T b -> - LLVM.CodeGenFunction r (MultiValue.T c) -unliftM2 f ix jx = unExp (f (lift0 ix) (lift0 jx)) - -unliftM3 :: - (Exp a -> Exp b -> Exp c -> Exp d) -> - MultiValue.T a -> MultiValue.T b -> MultiValue.T c -> - LLVM.CodeGenFunction r (MultiValue.T d) -unliftM3 f ix jx kx = unExp (f (lift0 ix) (lift0 jx) (lift0 kx)) - - - -min :: (MultiValue.Real a) => Exp a -> Exp a -> Exp a -min = liftM2 A.min - -max :: (MultiValue.Real a) => Exp a -> Exp a -> Exp a -max = liftM2 A.max - - -zip :: (Value val) => val a -> val b -> val (a, b) -zip = lift2 MultiValue.zip - -zip3 :: (Value val) => val a -> val b -> val c -> val (a, b, c) -zip3 = lift3 MultiValue.zip3 - -zip4 :: (Value val) => val a -> val b -> val c -> val d -> val (a, b, c, d) -zip4 = lift4 MultiValue.zip4 - -unzip :: (Value val) => val (a, b) -> (val a, val b) -unzip ab = - (lift1 MultiValue.fst ab, lift1 MultiValue.snd ab) - -unzip3 :: (Value val) => val (a, b, c) -> (val a, val b, val c) -unzip3 abc = - (lift1 MultiValue.fst3 abc, - lift1 MultiValue.snd3 abc, - lift1 MultiValue.thd3 abc) - -unzip4 :: (Value val) => val (a, b, c, d) -> (val a, val b, val c, val d) -unzip4 abcd = - (lift1 (\(MultiValue.Cons (a,_,_,_)) -> MultiValue.Cons a) abcd, - lift1 (\(MultiValue.Cons (_,b,_,_)) -> MultiValue.Cons b) abcd, - lift1 (\(MultiValue.Cons (_,_,c,_)) -> MultiValue.Cons c) abcd, - lift1 (\(MultiValue.Cons (_,_,_,d)) -> MultiValue.Cons d) abcd) - - -fst :: (Value val) => val (a, b) -> val a -fst = lift1 MultiValue.fst - -snd :: (Value val) => val (a, b) -> val b -snd = lift1 MultiValue.snd - -mapFst :: (Exp a -> Exp b) -> Exp (a, c) -> Exp (b, c) -mapFst f = modify (atom, atom) $ TupleHT.mapFst f - -mapSnd :: (Exp b -> Exp c) -> Exp (a, b) -> Exp (a, c) -mapSnd f = modify (atom, atom) $ TupleHT.mapSnd f - -swap :: (Value val) => val (a, b) -> val (b, a) -swap = lift1 MultiValue.swap - -curry :: (Exp (a,b) -> c) -> (Exp a -> Exp b -> c) -curry f = Tuple.curry (f . Tuple.uncurry zip) - -uncurry :: (Exp a -> Exp b -> c) -> (Exp (a,b) -> c) -uncurry f = Tuple.uncurry f . unzip - - -fst3 :: (Value val) => val (a,b,c) -> val a -fst3 = lift1 MultiValue.fst3 - -snd3 :: (Value val) => val (a,b,c) -> val b -snd3 = lift1 MultiValue.snd3 - -thd3 :: (Value val) => val (a,b,c) -> val c -thd3 = lift1 MultiValue.thd3 - -mapFst3 :: (Exp a0 -> Exp a1) -> Exp (a0,b,c) -> Exp (a1,b,c) -mapFst3 f = modify (atom, atom, atom) $ TupleHT.mapFst3 f - -mapSnd3 :: (Exp b0 -> Exp b1) -> Exp (a,b0,c) -> Exp (a,b1,c) -mapSnd3 f = modify (atom, atom, atom) $ TupleHT.mapSnd3 f - -mapThd3 :: (Exp c0 -> Exp c1) -> Exp (a,b,c0) -> Exp (a,b,c1) -mapThd3 f = modify (atom, atom, atom) $ TupleHT.mapThd3 f - - -modifyMultiValue :: - (Value val, - MultiValue.Compose a, - MultiValue.Decompose pattern, - MultiValue.PatternTuple pattern ~ tuple) => - pattern -> - (Decomposed MultiValue.T pattern -> a) -> - val tuple -> val (MultiValue.Composed a) -modifyMultiValue p f = lift1 $ MultiValue.modify p f - -modifyMultiValue2 :: - (Value val, - MultiValue.Compose a, - MultiValue.Decompose patternA, - MultiValue.Decompose patternB, - MultiValue.PatternTuple patternA ~ tupleA, - MultiValue.PatternTuple patternB ~ tupleB) => - patternA -> - patternB -> - (Decomposed MultiValue.T patternA -> - Decomposed MultiValue.T patternB -> a) -> - val tupleA -> val tupleB -> val (MultiValue.Composed a) -modifyMultiValue2 pa pb f = lift2 $ MultiValue.modify2 pa pb f - -modifyMultiValueM :: - (MultiValue.Compose a, - MultiValue.Decompose pattern, - MultiValue.PatternTuple pattern ~ tuple) => - pattern -> - (forall r. - Decomposed MultiValue.T pattern -> - LLVM.CodeGenFunction r a) -> - Exp tuple -> Exp (MultiValue.Composed a) -modifyMultiValueM p f = liftM (MultiValue.modifyF p f) - -modifyMultiValueM2 :: - (MultiValue.Compose a, - MultiValue.Decompose patternA, - MultiValue.Decompose patternB, - MultiValue.PatternTuple patternA ~ tupleA, - MultiValue.PatternTuple patternB ~ tupleB) => - patternA -> - patternB -> - (forall r. - Decomposed MultiValue.T patternA -> - Decomposed MultiValue.T patternB -> - LLVM.CodeGenFunction r a) -> - Exp tupleA -> Exp tupleB -> Exp (MultiValue.Composed a) -modifyMultiValueM2 pa pb f = liftM2 (MultiValue.modifyF2 pa pb f) - - -class Compose multituple where - type Composed multituple - {- | - A nested 'zip'. - -} - compose :: multituple -> Exp (Composed multituple) - -class - (Composed (Decomposed Exp pattern) ~ PatternTuple pattern) => - Decompose pattern where - {- | - Analogous to 'MultiValue.decompose'. - -} - decompose :: pattern -> Exp (PatternTuple pattern) -> Decomposed Exp pattern - - -{- | -Analogus to 'MultiValue.modifyMultiValue'. --} -modify :: - (Compose a, Decompose pattern) => - pattern -> - (Decomposed Exp pattern -> a) -> - Exp (PatternTuple pattern) -> Exp (Composed a) -modify p f = compose . f . decompose p - -modify2 :: - (Compose a, Decompose patternA, Decompose patternB) => - patternA -> - patternB -> - (Decomposed Exp patternA -> Decomposed Exp patternB -> a) -> - Exp (PatternTuple patternA) -> Exp (PatternTuple patternB) -> Exp (Composed a) -modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b) - - - -instance Compose (Exp a) where - type Composed (Exp a) = a - compose = id - -instance Decompose (Atom a) where - decompose _ = id - - - -instance Compose () where - type Composed () = () - compose = cons - -instance Decompose () where - decompose _ _ = () - - -instance (Compose a, Compose b) => Compose (a,b) where - type Composed (a,b) = (Composed a, Composed b) - compose = Tuple.uncurry zip . TupleHT.mapPair (compose, compose) - -instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where - decompose (pa,pb) = - TupleHT.mapPair (decompose pa, decompose pb) . unzip - - -instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where - type Composed (a,b,c) = (Composed a, Composed b, Composed c) - compose = TupleHT.uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose) - -instance - (Decompose pa, Decompose pb, Decompose pc) => - Decompose (pa,pb,pc) where - decompose (pa,pb,pc) = - TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3 - - -instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where - type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d) - compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d) - -instance - (Decompose pa, Decompose pb, Decompose pc, Decompose pd) => - Decompose (pa,pb,pc,pd) where - decompose (pa,pb,pc,pd) x = - case unzip4 x of - (a,b,c,d) -> - (decompose pa a, decompose pb b, decompose pc c, decompose pd d) - - -instance (Compose a) => Compose (Complex a) where - type Composed (Complex a) = Complex (Composed a) - compose (r:+i) = consComplex (compose r) (compose i) - -instance (Decompose p) => Decompose (Complex p) where - decompose (pr:+pi) = - Tuple.uncurry (:+) . - TupleHT.mapPair (decompose pr, decompose pi) . deconsComplex - -{- | -You can construct complex numbers this way, -but they will not make you happy, -because the numeric operations require a RealFloat instance -that we could only provide with lots of undefined methods -(also in its superclasses). -You may either define your own arithmetic -or use the NumericPrelude type classes. --} -consComplex :: Exp a -> Exp a -> Exp (Complex a) -consComplex = lift2 MultiValue.consComplex - -deconsComplex :: Exp (Complex a) -> (Exp a, Exp a) -deconsComplex c = (lift1 MultiValue.realPart c, lift1 MultiValue.imagPart c) - - - -cons :: (MultiValue.C a) => a -> Exp a -cons = lift0 . MultiValue.cons - -unit :: Exp () -unit = cons () - -zero :: (MultiValue.C a) => Exp a -zero = lift0 MultiValue.zero - -add :: (MultiValue.Additive a) => Exp a -> Exp a -> Exp a -add = liftM2 MultiValue.add - -sub :: (MultiValue.Additive a) => Exp a -> Exp a -> Exp a -sub = liftM2 MultiValue.sub - -mul :: (MultiValue.PseudoRing a) => Exp a -> Exp a -> Exp a -mul = liftM2 MultiValue.mul - -sqr :: (MultiValue.PseudoRing a) => Exp a -> Exp a -sqr = liftM $ \x -> MultiValue.mul x x - -sqrt :: (MultiValue.Algebraic a) => Exp a -> Exp a -sqrt = liftM MultiValue.sqrt - -idiv :: (MultiValue.Integral a) => Exp a -> Exp a -> Exp a -idiv = liftM2 MultiValue.idiv - -irem :: (MultiValue.Integral a) => Exp a -> Exp a -> Exp a -irem = liftM2 MultiValue.irem - -shl :: (MultiValue.BitShift a) => Exp a -> Exp a -> Exp a -shl = liftM2 MultiValue.shl - -shr :: (MultiValue.BitShift a) => Exp a -> Exp a -> Exp a -shr = liftM2 MultiValue.shr - -fromInteger' :: (MultiValue.IntegerConstant a) => Integer -> Exp a -fromInteger' = lift0 . MultiValue.fromInteger' - -fromRational' :: (MultiValue.RationalConstant a) => Rational -> Exp a -fromRational' = lift0 . MultiValue.fromRational' - - -cmp :: - (MultiValue.Comparison a) => - LLVM.CmpPredicate -> Exp a -> Exp a -> Exp Bool -cmp ord = liftM2 $ MultiValue.cmp ord - -infix 4 ==*, /=*, <*, <=*, >*, >=* - -(==*), (/=*), (<*), (>=*), (>*), (<=*) :: - (MultiValue.Comparison a) => Exp a -> Exp a -> Exp Bool -(==*) = cmp LLVM.CmpEQ -(/=*) = cmp LLVM.CmpNE -(<*) = cmp LLVM.CmpLT -(>=*) = cmp LLVM.CmpGE -(>*) = cmp LLVM.CmpGT -(<=*) = cmp LLVM.CmpLE - - -true, false :: Exp Bool -true = cons True -false = cons False - -infixr 3 &&* -(&&*) :: Exp Bool -> Exp Bool -> Exp Bool -(&&*) = liftM2 MultiValue.and - -infixr 2 ||* -(||*) :: Exp Bool -> Exp Bool -> Exp Bool -(||*) = liftM2 MultiValue.or - -not :: Exp Bool -> Exp Bool -not = liftM MultiValue.inv - -{- | -Like 'ifThenElse' but computes both alternative expressions -and then uses LLVM's efficient @select@ instruction. --} -select :: (MultiValue.Select a) => Exp Bool -> Exp a -> Exp a -> Exp a -select = liftM3 MultiValue.select - -ifThenElse :: (MultiValue.C a) => Exp Bool -> Exp a -> Exp a -> Exp a -ifThenElse ec ex ey = - Exp (do - MultiValue.Cons c <- unExp ec - C.ifThenElse c (unExp ex) (unExp ey)) - - -complement :: (MultiValue.Logic a) => Exp a -> Exp a -complement = liftM MultiValue.inv - -infixl 7 .&.* -(.&.*) :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a -(.&.*) = liftM2 MultiValue.and - -infixl 5 .|.* -(.|.*) :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a -(.|.*) = liftM2 MultiValue.or - -infixl 6 `xor` -xor :: (MultiValue.Logic a) => Exp a -> Exp a -> Exp a -xor = liftM2 MultiValue.xor - - -toMaybe :: Exp Bool -> Exp a -> Exp (Maybe a) -toMaybe = lift2 MultiValue.toMaybe - -maybe :: (MultiValue.C b) => Exp b -> (Exp a -> Exp b) -> Exp (Maybe a) -> Exp b -maybe n j = liftM $ \m -> do - let (MultiValue.Cons b, a) = MultiValue.splitMaybe m - C.ifThenElse b (unliftM1 j a) (unExp n) - +module Data.Array.Knead.Expression ( + Exp, + Value, + lift0, + lift1, + lift2, + lift3, + lift4, + liftM, + liftM2, + liftM3, + unliftM1, + unliftM2, + unliftM3, + liftReprM, + liftReprM2, + liftReprM3, + zip, + zip3, + zip4, + unzip, + unzip3, + unzip4, + fst, + snd, + mapFst, + mapSnd, + mapPair, + swap, + curry, + uncurry, + fst3, + snd3, + thd3, + mapFst3, + mapSnd3, + mapThd3, + mapTriple, + tuple, + untuple, + modifyNiceValue, + modifyNiceValue2, + modifyNiceValueM, + modifyNiceValueM2, + Compose(..), + Decompose(..), + modify, + modify2, + consComplex, + deconsComplex, + cons, + unit, + zero, + add, + sub, + mul, + sqr, + sqrt, + idiv, + irem, + shl, + shr, + fromInteger', + fromRational', + boolPFrom8, + bool8FromP, + intFromBool8, + floatFromBool8, + fromFastMath, + toFastMath, + minBound, maxBound, + cmp, + (==*), (/=*), (<*), (>=*), (>*), (<=*), + min, max, + true, false, + (&&*), + (||*), + not, + select, + ifThenElse, + complement, + (.&.*), + (.|.*), + xor, + toMaybe, + maybe, + ) where -instance - (MultiValue.PseudoRing a, MultiValue.Real a, MultiValue.IntegerConstant a) => - Num (Exp a) where - fromInteger n = lift0 (MultiValue.fromInteger' n) - (+) = liftM2 MultiValue.add - (-) = liftM2 MultiValue.sub - negate = liftM MultiValue.neg - (*) = liftM2 MultiValue.mul - abs = liftM MultiValue.abs - signum = liftM MultiValue.signum +import LLVM.DSL.Expression -instance (MultiValue.Field a, MultiValue.Real a, MultiValue.RationalConstant a) => - Fractional (Exp a) where - fromRational n = lift0 (MultiValue.fromRational' n) - (/) = liftM2 MultiValue.fdiv +import Prelude () diff --git a/src/Data/Array/Knead/Index/Linear.hs b/src/Data/Array/Knead/Index/Linear.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Index/Linear.hs +++ /dev/null @@ -1,558 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Data.Array.Knead.Index.Linear ( - C(switch), - switchInt, - intersect, - value, - constant, - paramWith, - tunnel, - flattenIndex, - peek, - poke, - computeSize, - - Struct, - T(..), - Z(Z), z, - (:.)((:.)), - Shape, shape, - Index, index, - cons, (#:.), - head, - tail, - switchR, - loadMultiValue, - storeMultiValue, - ) where - -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Index.Linear.Int as Index - -import qualified Data.Array.Knead.Parameter as Param -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Control as C -import LLVM.Extra.Multi.Value (Atom, ) - -import qualified LLVM.Util.Loop as Loop -import qualified LLVM.Core as LLVM - -import qualified Foreign.Storable as St -import Foreign.Storable.FixedArray (sizeOfArray, ) -import Foreign.Marshal.Array (advancePtr, ) -import Foreign.Ptr (Ptr, castPtr, ) - -import Control.Monad (liftM2, ) -import Data.Word (Word32, ) - -import Prelude hiding (min, head, tail, ) - - -class C ix where - switch :: - f Z -> - (forall ix0 i. (C ix0, Index.Single i) => f (ix0 :. i)) -> - f ix - -instance C Z where - switch x _ = x - -instance (C ix0, Index.Single i) => C (ix0 :. i) where - switch _ x = x - - -newtype SwitchInt f ix i = SwitchInt {runSwitchInt :: f (ix :. i)} - -switchInt :: - (C ix) => - f Z -> - (forall ix0. (C ix0) => f (ix0 :. Index.Int)) -> - f ix -switchInt z0 cons0 = - switch z0 - (runSwitchInt $ Index.switchSingle (SwitchInt cons0)) - - -newtype Op2 tag sh = Op2 {runOp2 :: Exp (T tag sh) -> Exp (T tag sh) -> Exp (T tag sh)} - -intersect :: C sh => Exp (Shape sh) -> Exp (Shape sh) -> Exp (Shape sh) -intersect = - runOp2 $ - switchInt - (Op2 $ \z0 _ -> z0) - (Op2 $ - switchR $ \is i -> - switchR $ \js j -> - intersect is js #:. Expr.min i j) - - -_value :: (C sh, MultiValue.C sh) => sh -> Exp sh -_value = Expr.lift0 . MultiValue.cons - - -newtype MakeValue val tag sh = MakeValue {runMakeValue :: T tag sh -> val (T tag sh)} - -value :: (C sh, Expr.Value val) => T tag sh -> val (T tag sh) -value = - runMakeValue $ - switchInt - (MakeValue $ \(Cons Z) -> z) - (MakeValue $ \(Cons (t:.h)) -> - value (Cons t) #:. Expr.lift0 (MultiValue.cons h)) - -paramWith :: - (C sh, Expr.Value val) => - Param.T p (T tag sh) -> - (forall parameters. - (St.Storable parameters, - MultiValueMemory.C parameters) => - (p -> parameters) -> - (MultiValue.T parameters -> val (T tag sh)) -> - a) -> - a -paramWith p f = - case tunnel p of - Param.Tunnel get val -> f get (Expr.lift0 . val) - -tunnel :: (C sh) => Param.T p (T tag sh) -> Param.Tunnel p (T tag sh) -tunnel p = - case structFieldsPropF p of - StructFieldsProp -> Param.tunnel value p - - -data StructFieldsProp sh = LLVM.StructFields (Struct sh) => StructFieldsProp - -_structFieldsProp :: (C sh) => f sh -> StructFieldsProp sh -_structFieldsProp _p = structFieldsRec - -structFieldsPropF :: (C sh) => f (g sh) -> StructFieldsProp sh -structFieldsPropF _p = structFieldsRec - -withStructFieldsPropFF :: - (C sh) => (StructFieldsProp sh -> f (g (h sh))) -> f (g (h sh)) -withStructFieldsPropFF f = f structFieldsRec - -structFieldsRec :: (C sh) => StructFieldsProp sh -structFieldsRec = - switchInt - StructFieldsProp - (succStructFieldsProp structFieldsRec) - -succStructFieldsProp :: - StructFieldsProp sh -> StructFieldsProp (sh:.Index.Int) -succStructFieldsProp StructFieldsProp = StructFieldsProp - - -data Z = Z - deriving (Eq, Ord, Read, Show) - - -infixl 3 :., #:. - -data tail :. head = !tail :. !head - deriving (Eq, Ord, Read, Show) - - -newtype T tag sh = Cons {decons :: sh} - -data ShapeTag -data IndexTag - -type Shape = T ShapeTag -type Index = T IndexTag - -shape :: sh -> Shape sh -shape = Cons - -index :: ix -> Index ix -index = Cons - - -(#:.) :: (Expr.Value val) => val (T tag sh) -> val i -> val (T tag (sh:.i)) -(#:.) = cons - -cons :: (Expr.Value val) => val (T tag sh) -> val i -> val (T tag (sh:.i)) -cons = - Expr.lift2 $ - \(MultiValue.Cons t) (MultiValue.Cons h) -> - MultiValue.Cons (t,h) - -z :: (Expr.Value val) => val (T tag Z) -z = Expr.lift0 $ MultiValue.Cons () - -head :: (Expr.Value val) => val (T tag (sh:.i)) -> val i -head = Expr.lift1 $ \(MultiValue.Cons (_t,h)) -> MultiValue.Cons h - -tail :: (Expr.Value val) => val (T tag (sh:.i)) -> val (T tag sh) -tail = Expr.lift1 $ \(MultiValue.Cons (t,_h)) -> MultiValue.Cons t - -switchR :: - Expr.Value val => - (val (T tag sh) -> val i -> a) -> val (T tag (sh :. i)) -> a -switchR f ix = f (tail ix) (head ix) - - -instance (tag ~ ShapeTag, sh ~ Z) => Shape.Scalar (T tag sh) where - scalar = Expr.lift0 $ MultiValue.Cons () - zeroIndex _ = Expr.lift0 $ MultiValue.Cons () - - -type family PatternTuple pattern -type family Decomposed (f :: * -> *) tag pattern - -type instance PatternTuple (sh:.s) = - PatternTuple sh :. MultiValue.PatternTuple s - -type instance Decomposed f tag (sh:.s) = - Decomposed f tag sh :. MultiValue.Decomposed f s - -type instance PatternTuple (Atom sh) = sh - -type instance Decomposed f tag (Atom sh) = f (T tag sh) - - -class - (Expr.Composed (Decomposed Exp tag pattern) ~ T tag (PatternTuple pattern)) => - Decompose tag pattern where - decompose :: - T tag pattern -> Exp (T tag (PatternTuple pattern)) -> - Decomposed Exp tag pattern - -instance Decompose tag (Atom sh) where - decompose (Cons _atom) x = x - -instance (Decompose tag sh, Expr.Decompose s) => Decompose tag (sh :. s) where - decompose (Cons (psh:.ps)) x = - decompose (Cons psh) (tail x) :. Expr.decompose ps (head x) - - -type instance MultiValue.PatternTuple (T tag sh) = T tag (PatternTuple sh) - -type instance MultiValue.Decomposed f (T tag sh) = Decomposed f tag sh - - -type family Unwrap sh -type instance Unwrap (T tag sh) = sh - -type family Tag sh -type instance Tag (T tag sh) = tag - -instance - (Expr.Compose sh, - Expr.Composed sh ~ T (Tag (Expr.Composed sh)) (Unwrap (Expr.Composed sh)), - Expr.Compose s) => - Expr.Compose (sh :. s) where - type Composed (sh :. s) = - T (Tag (Expr.Composed sh)) - (Unwrap (Expr.Composed sh) :. Expr.Composed s) - compose (sh :. s) = cons (Expr.compose sh) (Expr.compose s) - -instance (Decompose tag sh) => Expr.Decompose (T tag sh) where - decompose = decompose - - - -instance (C sh) => St.Storable (T tag sh) where - sizeOf (Cons sh) = sizeOfArray (rank sh) (0::Word32) - alignment (Cons _sh) = St.alignment (0::Word32) - poke ptr = poke (castPtr ptr) . decons - peek = fmap Cons . peek . castPtr - - -type family Repr (f :: * -> *) sh -type instance Repr f Z = () -type instance Repr f (tail :. head) = (Repr f tail, MultiValue.Repr f head) - -instance (C sh) => MultiValue.C (T tag sh) where - type Repr f (T tag sh) = Repr f sh - cons = value - undef = constant $ MultiValue.undef - zero = constant $ MultiValue.zero - addPhis = addPhis - phis = phis - -instance (tag ~ ShapeTag, C sh) => Shape.C (T tag sh) where - type Index (T tag sh) = Index sh - size = fromIntegral . size . decons - sizeCode = computeSize - intersectCode = Expr.unliftM2 intersect - flattenIndexRec sh ix = - -- a joint implementation would not be more efficient - liftM2 (,) - (computeSize sh) - (flattenIndex sh ix) - loop = loop - - -type family Struct sh -type instance Struct Z = () -type instance Struct (sh :. Index.Int) = (Word32, Struct sh) - -instance - (C sh, LLVM.StructFields (Struct sh)) => - MultiValueMemory.C (T tag sh) where - type Struct (T tag sh) = LLVM.Struct (Struct sh) - load = loadMultiValue - store = storeMultiValue - -loadMultiValue :: - (C sh) => - LLVM.Value (Ptr (LLVM.Struct (Struct sh))) -> - LLVM.CodeGenFunction r (MultiValue.T (T tag sh)) -loadMultiValue ptr = - withStructFieldsPropFF $ \StructFieldsProp -> - load =<< castPtrValue ptr - -storeMultiValue :: - (C sh) => - MultiValue.T (T tag sh) -> - LLVM.Value (Ptr (LLVM.Struct (Struct sh))) -> LLVM.CodeGenFunction r () -storeMultiValue x ptr = - case structFieldsPropF x of - StructFieldsProp -> store x =<< castPtrValue ptr - - -newtype FlattenIndex r sh = - FlattenIndex { - runFlattenIndex :: - MultiValue.T (Shape sh) -> MultiValue.T (Index sh) -> - LLVM.CodeGenFunction r (LLVM.Value Word32) - } - -flattenIndex :: - (C sh) => - MultiValue.T (Shape sh) -> MultiValue.T (Index sh) -> - LLVM.CodeGenFunction r (LLVM.Value Word32) -flattenIndex = - runFlattenIndex $ - switchInt - (FlattenIndex $ \_zerosh _zeroix -> return A.zero) - (FlattenIndex $ - switchR $ \sh (MultiValue.Cons s) -> - switchR $ \ix (MultiValue.Cons i) -> - A.add i =<< A.mul s =<< flattenIndex sh ix) - - -newtype Rank sh = Rank {runRank :: sh -> Int} - -rank :: (C sh) => sh -> Int -rank = - runRank $ - switch - (Rank $ const 0) - (Rank $ succ . rank . (\(sh :. _s) -> sh)) - - -newtype Peek sh = Peek {runPeek :: Ptr Word32 -> IO sh} - -peek :: (C sh) => Ptr Word32 -> IO sh -peek = - runPeek $ - switchInt - (Peek $ const $ return Z) - (Peek $ \ptr -> do - h <- St.peek ptr - t <- peek $ advancePtr ptr 1 - return (t :. Index.Int h)) - - -newtype Poke sh = Poke {runPoke :: Ptr Word32 -> sh -> IO ()} - -poke :: (C sh) => Ptr Word32 -> sh -> IO () -poke = - runPoke $ - switchInt - (Poke $ const $ const $ return ()) - (Poke $ \ptr (sh :. Index.Int i) -> do - St.poke ptr i - poke (advancePtr ptr 1) sh) - - -castPtrValue :: - (LLVM.StructFields sh) => - LLVM.Value (Ptr (LLVM.Struct sh)) -> - LLVM.CodeGenFunction r (LLVM.Value (Ptr Word32)) -castPtrValue = LLVM.bitcast - -newtype Load r tag sh = - Load { - runLoad :: - LLVM.Value (Ptr Word32) -> - LLVM.CodeGenFunction r (MultiValue.T (T tag sh)) - } - -load :: - (C sh) => - LLVM.Value (Ptr Word32) -> - LLVM.CodeGenFunction r (MultiValue.T (T tag sh)) -load = - runLoad $ - switchInt - (Load $ const $ return z) - (Load $ \ptr -> do - h <- LLVM.load ptr - t <- load =<< A.advanceArrayElementPtr ptr - return (t #:. MultiValue.Cons h)) - - -newtype Store r tag sh = - Store { - runStore :: - MultiValue.T (T tag sh) -> - LLVM.Value (Ptr Word32) -> - LLVM.CodeGenFunction r () - } - -store :: - (C sh) => - MultiValue.T (T tag sh) -> - LLVM.Value (Ptr Word32) -> - LLVM.CodeGenFunction r () -store = - runStore $ - switchInt - (Store $ \_z _ptr -> return ()) - (Store $ switchR $ \sh (MultiValue.Cons k) ptr -> do - LLVM.store k ptr - store sh =<< A.advanceArrayElementPtr ptr) - - -newtype Size sh = - Size { - runSize :: sh -> Word32 - } - -size :: (C sh) => sh -> Word32 -size = - runSize $ - switchInt - (Size $ \_z -> 1) - (Size $ \(sh :. Index.Int k) -> k * size sh) - - -newtype ComputeSize r sh = - ComputeSize { - runComputeSize :: - MultiValue.T (Shape sh) -> - LLVM.CodeGenFunction r (LLVM.Value Word32) - } - -computeSize :: - (C sh) => - MultiValue.T (Shape sh) -> - LLVM.CodeGenFunction r (LLVM.Value Word32) -computeSize = - runComputeSize $ - switchInt - (ComputeSize $ \_z -> return A.one) - (ComputeSize $ switchR $ \sh (MultiValue.Cons k) -> - A.mul k =<< computeSize sh) - - -newtype - Constant val tag sh = - Constant {getConstant :: val Index.Int -> val (T tag sh)} - -constant :: (C sh, Expr.Value val) => val Index.Int -> val (T tag sh) -constant = - getConstant $ - switchInt - (Constant $ const z) - (Constant $ \x -> constant x #:. x) - - -newtype AddPhis r tag sh = - AddPhis { - runAddPhis :: - LLVM.BasicBlock -> - MultiValue.T (T tag sh) -> - MultiValue.T (T tag sh) -> - LLVM.CodeGenFunction r () - } - -addPhis :: - (C sh) => - LLVM.BasicBlock -> - MultiValue.T (T tag sh) -> - MultiValue.T (T tag sh) -> - LLVM.CodeGenFunction r () -addPhis = - runAddPhis $ - switchInt - (AddPhis $ \_ _ _ -> return ()) - (AddPhis $ \bb -> - switchR $ \hx tx -> - switchR $ \hy ty -> - MultiValue.addPhis bb tx ty >> - addPhis bb hx hy) - - -newtype Phis r tag sh = - Phis { - runPhis :: - LLVM.BasicBlock -> - MultiValue.T (T tag sh) -> - LLVM.CodeGenFunction r (MultiValue.T (T tag sh)) - } - -phis :: - (C sh) => - LLVM.BasicBlock -> - MultiValue.T (T tag sh) -> - LLVM.CodeGenFunction r (MultiValue.T (T tag sh)) -phis = - runPhis $ - switchInt - (Phis $ \_ -> return) - (Phis $ \bb -> - switchR $ \h t -> - liftM2 (#:.) - (phis bb h) - (MultiValue.phis bb t)) - - -newtype Loop r state sh = - Loop { - runLoop :: - (MultiValue.T (Index sh) -> - state -> - LLVM.CodeGenFunction r state) -> - MultiValue.T (Shape sh) -> - state -> - LLVM.CodeGenFunction r state - } - -loop :: - (C sh, Loop.Phi state) => - (MultiValue.T (Index sh) -> - state -> - LLVM.CodeGenFunction r state) -> - MultiValue.T (Shape sh) -> - state -> - LLVM.CodeGenFunction r state -loop = - runLoop $ - switchInt - (Loop $ \code _z -> code z) - (Loop $ \code -> switchR $ \sh (MultiValue.Cons n) -> - loop - (\ix ptrStart -> - fmap fst $ - C.fixedLengthLoop n (ptrStart, A.zero) $ \(ptr, k) -> - liftM2 (,) - (code (ix #:. MultiValue.Cons k) ptr) - (A.inc k)) - sh) diff --git a/src/Data/Array/Knead/Index/Linear/Int.hs b/src/Data/Array/Knead/Index/Linear/Int.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Index/Linear/Int.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Data.Array.Knead.Index.Linear.Int ( - Single(..), - Int(Int), cons, decons, - ) where - -import qualified Data.Array.Knead.Expression as Expr - -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Arithmetic as A - -import Data.Word (Word32, ) - -import Prelude hiding (Int, head, tail, ) - - -newtype Int = Int Word32 - -cons :: (Expr.Value val) => val Word32 -> val Int -cons = Expr.lift1 $ \(MultiValue.Cons x) -> MultiValue.Cons x - -decons :: (Expr.Value val) => val Int -> val Word32 -decons = Expr.lift1 $ \(MultiValue.Cons x) -> MultiValue.Cons x - - -class Single ix where - switchSingle :: f Int -> f ix - -instance Single Int where - switchSingle x = x - - -instance MultiValue.C Int where - type Repr f Int = f Word32 - cons (Int x) = MultiValue.consPrimitive x - undef = MultiValue.undefPrimitive - zero = MultiValue.zeroPrimitive - phis = MultiValue.phisPrimitive - addPhis = MultiValue.addPhisPrimitive - -instance MultiValue.Additive Int where - add = MultiValue.liftM2 A.add - sub = MultiValue.liftM2 A.sub - neg = MultiValue.liftM A.neg - -instance MultiValue.PseudoRing Int where - mul = MultiValue.liftM2 A.mul - -instance MultiValue.Real Int where - min = MultiValue.liftM2 A.min - max = MultiValue.liftM2 A.max - abs = MultiValue.liftM A.abs - signum = MultiValue.liftM A.signum - -instance MultiValue.IntegerConstant Int where - fromInteger' = cons . A.fromInteger' - -instance MultiValue.Comparison Int where - cmp mode = MultiValue.liftM2 $ A.cmp mode diff --git a/src/Data/Array/Knead/Index/Nested/Shape.hs b/src/Data/Array/Knead/Index/Nested/Shape.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Index/Nested/Shape.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} -module Data.Array.Knead.Index.Nested.Shape ( - C(..), - value, - paramWith, - load, - intersect, - flattenIndex, - - Range(..), - Shifted(..), - - Scalar(..), - ) where - -import qualified Data.Array.Knead.Expression as Expr -import qualified Data.Array.Knead.Parameter as Param -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiMem -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Control as C -import LLVM.Extra.Multi.Value (atom) -import LLVM.Extra.Monad (liftR2) - -import qualified LLVM.Util.Loop as Loop -import qualified LLVM.Core as LLVM - -import qualified Type.Data.Num.Decimal as TypeNum - -import Foreign.Storable - (Storable, sizeOf, alignment, poke, peek, pokeElemOff, peekElemOff) -import Foreign.Ptr (Ptr, castPtr) - -import Data.Word (Word8, Word16, Word32, Word64) -import Data.Int (Int8, Int16, Int32, Int64) - -import qualified Control.Monad.HT as Monad -import Control.Applicative ((<$>)) - - -value :: (C sh, Expr.Value val) => sh -> val sh -value = Expr.lift0 . MultiValue.cons - -paramWith :: - (Storable b, MultiMem.C b, Expr.Value val) => - Param.T p b -> - (forall parameters. - (Storable parameters, MultiMem.C parameters) => - (p -> parameters) -> - (MultiValue.T parameters -> val b) -> - a) -> - a -paramWith p f = - Param.withMulti p (\get val -> f get (Expr.lift0 . val)) - -load :: - (MultiMem.C sh) => - f sh -> LLVM.Value (Ptr (MultiMem.Struct sh)) -> - LLVM.CodeGenFunction r (MultiValue.T sh) -load _ = MultiMem.load - -intersect :: (C sh) => Exp sh -> Exp sh -> Exp sh -intersect = Expr.liftM2 intersectCode - -flattenIndex :: - (C sh) => - MultiValue.T sh -> MultiValue.T (Index sh) -> - LLVM.CodeGenFunction r (LLVM.Value Word32) -flattenIndex sh ix = - fmap snd $ flattenIndexRec sh ix - -class (MultiValue.C sh) => C sh where - type Index sh :: * - {- - It would be better to restrict zipWith to matching shapes - and turn shape intersection into a bound check. - -} - intersectCode :: - MultiValue.T sh -> MultiValue.T sh -> - LLVM.CodeGenFunction r (MultiValue.T sh) - sizeCode :: - MultiValue.T sh -> - LLVM.CodeGenFunction r (LLVM.Value Word32) - size :: sh -> Int - {- | - Result is @(size, flattenedIndex)@. - @size@ must equal the result of 'sizeCode'. - We use this for sharing intermediate results. - -} - flattenIndexRec :: - MultiValue.T sh -> MultiValue.T (Index sh) -> - LLVM.CodeGenFunction r (LLVM.Value Word32, LLVM.Value Word32) - loop :: - (Index sh ~ ix, Loop.Phi state) => - (MultiValue.T ix -> state -> LLVM.CodeGenFunction r state) -> - MultiValue.T sh -> state -> LLVM.CodeGenFunction r state - - -instance C () where - type Index () = () - intersectCode _ _ = return $ MultiValue.cons () - sizeCode _ = return A.one - size _ = 1 - flattenIndexRec _ _ = return (A.one, A.zero) - loop = id - - -class C sh => Scalar sh where - scalar :: (Expr.Value val) => val sh - zeroIndex :: (Expr.Value val) => f sh -> val (Index sh) - -instance Scalar () where - scalar = Expr.lift0 $ MultiValue.Cons () - zeroIndex _ = Expr.lift0 $ MultiValue.Cons () - - -loopPrimitive :: - (MultiValue.Repr LLVM.Value j ~ LLVM.Value j, - Num j, LLVM.IsConst j, LLVM.IsInteger j, - LLVM.CmpRet j, LLVM.CmpResult j ~ Bool, - MultiValue.Additive i, MultiValue.IntegerConstant i, - Loop.Phi state) => - (MultiValue.T i -> state -> LLVM.CodeGenFunction r state) -> - MultiValue.T j -> state -> LLVM.CodeGenFunction r state -loopPrimitive code (MultiValue.Cons n) ptrStart = - loopStart code n MultiValue.zero ptrStart - -loopStart :: - (Num j, LLVM.IsConst j, LLVM.IsInteger j, - LLVM.CmpRet j, LLVM.CmpResult j ~ Bool, - MultiValue.Additive i, MultiValue.IntegerConstant i, - Loop.Phi state) => - (MultiValue.T i -> state -> LLVM.CodeGenFunction r state) -> - LLVM.Value j -> - MultiValue.T i -> state -> LLVM.CodeGenFunction r state -loopStart code n start ptrStart = - fmap fst $ - C.fixedLengthLoop n (ptrStart, start) $ \(ptr, k) -> - Monad.lift2 (,) (code k ptr) (MultiValue.inc k) - -instance C Word32 where - type Index Word32 = Word32 - intersectCode = MultiValue.min - sizeCode (MultiValue.Cons n) = return n - size = fromIntegral - flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = return (n, i) - loop = loopPrimitive - -instance C Word64 where - type Index Word64 = Word64 - intersectCode = MultiValue.min - sizeCode (MultiValue.Cons n) = LLVM.trunc n - size = fromIntegral - flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = - Monad.lift2 (,) (LLVM.trunc n) (LLVM.trunc i) - loop = loopPrimitive - - -{- | -Array dimensions and indexes cannot be negative, -but computations in indices may temporarily yield negative values -or we want to add negative values to indices. - -Maybe we should better have type Index Word64 = Int64? --} -unsigned8 :: LLVM.Value Int8 -> LLVM.CodeGenFunction r (LLVM.Value Word8) -unsigned8 = LLVM.bitcast - -instance C Int8 where - type Index Int8 = Int8 - intersectCode = MultiValue.min - sizeCode (MultiValue.Cons n) = LLVM.ext =<< unsigned8 n - size = fromIntegral - flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = - Monad.lift2 (,) (LLVM.ext =<< unsigned8 n) (LLVM.ext =<< unsigned8 i) - loop = loopPrimitive - -unsigned16 :: LLVM.Value Int16 -> LLVM.CodeGenFunction r (LLVM.Value Word16) -unsigned16 = LLVM.bitcast - -instance C Int16 where - type Index Int16 = Int16 - intersectCode = MultiValue.min - sizeCode (MultiValue.Cons n) = LLVM.ext =<< unsigned16 n - size = fromIntegral - flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = - Monad.lift2 (,) (LLVM.ext =<< unsigned16 n) (LLVM.ext =<< unsigned16 i) - loop = loopPrimitive - -instance C Int32 where - type Index Int32 = Int32 - intersectCode = MultiValue.min - sizeCode (MultiValue.Cons n) = LLVM.bitcast n - size = fromIntegral - flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = - Monad.lift2 (,) (LLVM.bitcast n) (LLVM.bitcast i) - loop = loopPrimitive - -instance C Int64 where - type Index Int64 = Int64 - intersectCode = MultiValue.min - sizeCode (MultiValue.Cons n) = LLVM.trunc n - size = fromIntegral - flattenIndexRec (MultiValue.Cons n) (MultiValue.Cons i) = - Monad.lift2 (,) (LLVM.trunc n) (LLVM.trunc i) - loop = loopPrimitive - - -{- | -'Range' denotes an inclusive range like -those of the Haskell 98 standard @Array@ type from the @array@ package. -E.g. the shape type @(Range Int32, Range Int64)@ -is equivalent to the ix type @(Int32, Int64)@ for @Array@s. --} -data Range n = Range n n - -singletonRange :: n -> Range n -singletonRange n = Range n n - - -{-# INLINE castToElemPtr #-} -castToElemPtr :: Ptr (f a) -> Ptr a -castToElemPtr = castPtr - --- cf. sample-frame:Stereo -instance Storable n => Storable (Range n) where - {-# INLINE sizeOf #-} - {-# INLINE alignment #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - sizeOf ~(Range l r) = sizeOf l + mod (- sizeOf l) (alignment r) + sizeOf r - alignment ~(Range l _) = alignment l - poke p (Range l r) = - let q = castToElemPtr p - in poke q l >> pokeElemOff q 1 r - peek p = - let q = castToElemPtr p - in Monad.lift2 Range (peek q) (peekElemOff q 1) - - -class - (MultiValue.Additive n, MultiValue.Real n, MultiValue.IntegerConstant n) => - ToSize n where - toSize :: MultiValue.T n -> LLVM.CodeGenFunction r (LLVM.Value Word32) - -instance ToSize Word32 where toSize (MultiValue.Cons n) = LLVM.adapt n -instance ToSize Word64 where toSize (MultiValue.Cons n) = LLVM.adapt n -instance ToSize Int32 where toSize (MultiValue.Cons n) = LLVM.bitcast n -instance ToSize Int64 where toSize (MultiValue.Cons n) = LLVM.trunc n - -rangeSize :: - (ToSize n) => - Range (MultiValue.T n) -> LLVM.CodeGenFunction r (LLVM.Value Word32) -rangeSize (Range from to) = - toSize =<< MultiValue.inc =<< MultiValue.sub to from - -unzipRange :: MultiValue.T (Range n) -> Range (MultiValue.T n) -unzipRange (MultiValue.Cons (Range from to)) = - Range (MultiValue.Cons from) (MultiValue.Cons to) - -zipRange :: MultiValue.T n -> MultiValue.T n -> MultiValue.T (Range n) -zipRange (MultiValue.Cons from) (MultiValue.Cons to) = - MultiValue.Cons (Range from to) - -instance (MultiValue.C n) => MultiValue.C (Range n) where - type Repr f (Range n) = Range (MultiValue.Repr f n) - cons (Range from to) = zipRange (MultiValue.cons from) (MultiValue.cons to) - undef = MultiValue.compose $ singletonRange MultiValue.undef - zero = MultiValue.compose $ singletonRange MultiValue.zero - phis bb a = - case unzipRange a of - Range a0 a1 -> - Monad.lift2 zipRange (MultiValue.phis bb a0) (MultiValue.phis bb a1) - addPhis bb a b = - case (unzipRange a, unzipRange b) of - (Range a0 a1, Range b0 b1) -> - MultiValue.addPhis bb a0 b0 >> - MultiValue.addPhis bb a1 b1 - -type instance - MultiValue.Decomposed f (Range pn) = - Range (MultiValue.Decomposed f pn) -type instance - MultiValue.PatternTuple (Range pn) = - Range (MultiValue.PatternTuple pn) - -instance (MultiValue.Compose n) => MultiValue.Compose (Range n) where - type Composed (Range n) = Range (MultiValue.Composed n) - compose (Range from to) = - zipRange (MultiValue.compose from) (MultiValue.compose to) - -instance (MultiValue.Decompose pn) => MultiValue.Decompose (Range pn) where - decompose (Range pfrom pto) rng = - case unzipRange rng of - Range from to -> - Range - (MultiValue.decompose pfrom from) - (MultiValue.decompose pto to) - -instance (MultiMem.C n) => MultiMem.C (Range n) where - type Struct (Range n) = PairStruct n - decompose = fmap (uncurry zipRange) . decomposeGen - compose x = case unzipRange x of Range n m -> composeGen n m - -instance (Integral n, ToSize n) => C (Range n) where - type Index (Range n) = n - intersectCode = - MultiValue.modifyF2 (singletonRange atom) (singletonRange atom) $ - \(Range fromN toN) (Range fromM toM) -> - Monad.lift2 Range (MultiValue.max fromN fromM) (MultiValue.min toN toM) - sizeCode = rangeSize . unzipRange - size (Range from to) = fromIntegral $ to-from+1 - flattenIndexRec rngValue i = - case unzipRange rngValue of - rng@(Range from _to) -> - Monad.lift2 (,) (rangeSize rng) (toSize =<< MultiValue.sub i from) - loop code rngValue ptrStart = - case unzipRange rngValue of - rng@(Range from _to) -> do - {- - FIXME: rangeSize converts to Word32 which is overly restrictive here. - -} - n <- rangeSize rng - loopStart code n from ptrStart - - -{- | -'Shifted' denotes a range defined by the start index and the length. --} -data Shifted n = Shifted {shiftedOffset, shiftedSize :: n} - -singletonShifted :: n -> Shifted n -singletonShifted n = Shifted n n - - --- cf. sample-frame:Stereo -instance Storable n => Storable (Shifted n) where - {-# INLINE sizeOf #-} - {-# INLINE alignment #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - sizeOf ~(Shifted l n) = sizeOf l + mod (- sizeOf l) (alignment n) + sizeOf n - alignment ~(Shifted l _) = alignment l - poke p (Shifted l n) = - let q = castToElemPtr p - in poke q l >> pokeElemOff q 1 n - peek p = - let q = castToElemPtr p - in Monad.lift2 Shifted (peek q) (peekElemOff q 1) - - -unzipShifted :: MultiValue.T (Shifted n) -> Shifted (MultiValue.T n) -unzipShifted (MultiValue.Cons (Shifted from to)) = - Shifted (MultiValue.Cons from) (MultiValue.Cons to) - -zipShifted :: MultiValue.T n -> MultiValue.T n -> MultiValue.T (Shifted n) -zipShifted (MultiValue.Cons from) (MultiValue.Cons to) = - MultiValue.Cons (Shifted from to) - -instance (MultiValue.C n) => MultiValue.C (Shifted n) where - type Repr f (Shifted n) = Shifted (MultiValue.Repr f n) - cons (Shifted offset len) = - zipShifted (MultiValue.cons offset) (MultiValue.cons len) - undef = MultiValue.compose $ singletonShifted MultiValue.undef - zero = MultiValue.compose $ singletonShifted MultiValue.zero - phis bb a = - case unzipShifted a of - Shifted a0 a1 -> - Monad.lift2 zipShifted - (MultiValue.phis bb a0) (MultiValue.phis bb a1) - addPhis bb a b = - case (unzipShifted a, unzipShifted b) of - (Shifted a0 a1, Shifted b0 b1) -> - MultiValue.addPhis bb a0 b0 >> - MultiValue.addPhis bb a1 b1 - -type instance - MultiValue.Decomposed f (Shifted pn) = - Shifted (MultiValue.Decomposed f pn) -type instance - MultiValue.PatternTuple (Shifted pn) = - Shifted (MultiValue.PatternTuple pn) - -instance (MultiValue.Compose n) => MultiValue.Compose (Shifted n) where - type Composed (Shifted n) = Shifted (MultiValue.Composed n) - compose (Shifted offset len) = - zipShifted (MultiValue.compose offset) (MultiValue.compose len) - -instance (MultiValue.Decompose pn) => MultiValue.Decompose (Shifted pn) where - decompose (Shifted poffset plen) rng = - case unzipShifted rng of - Shifted offset len -> - Shifted - (MultiValue.decompose poffset offset) - (MultiValue.decompose plen len) - -instance (MultiMem.C n) => MultiMem.C (Shifted n) where - type Struct (Shifted n) = PairStruct n - decompose = fmap (uncurry zipShifted) . decomposeGen - compose x = case unzipShifted x of Shifted n m -> composeGen n m - -type PairStruct n = LLVM.Struct (MultiMem.Struct n, (MultiMem.Struct n, ())) - -decomposeGen :: - (MultiMem.C n) => - LLVM.Value (PairStruct n) -> - LLVM.CodeGenFunction r (MultiValue.T n, MultiValue.T n) -decomposeGen nm = - Monad.lift2 (,) - (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d0) - (MultiMem.decompose =<< LLVM.extractvalue nm TypeNum.d1) - -composeGen :: - (MultiMem.C n) => - MultiValue.T n -> MultiValue.T n -> - LLVM.CodeGenFunction r (LLVM.Value (PairStruct n)) -composeGen n m = do - sn <- MultiMem.compose n - sm <- MultiMem.compose m - rn <- LLVM.insertvalue (LLVM.value LLVM.undef) sn TypeNum.d0 - LLVM.insertvalue rn sm TypeNum.d1 - - -instance (Integral n, ToSize n) => C (Shifted n) where - type Index (Shifted n) = n - intersectCode = - MultiValue.modifyF2 (singletonShifted atom) (singletonShifted atom) $ - \(Shifted offsetN lenN) (Shifted offsetM lenM) -> do - offset <- MultiValue.max offsetN offsetM - endN <- MultiValue.add offsetN lenN - endM <- MultiValue.add offsetM lenM - end <- MultiValue.min endN endM - Shifted offset <$> MultiValue.sub end offset - sizeCode = toSize . shiftedSize . unzipShifted - size (Shifted _offset len) = fromIntegral len - flattenIndexRec shapeValue i = - case unzipShifted shapeValue of - Shifted offset len -> - Monad.lift2 (,) (toSize len) (toSize =<< MultiValue.sub i offset) - loop code rngValue ptrStart = - case unzipShifted rngValue of - Shifted from len -> do - n <- toSize len - loopStart code n from ptrStart - - - -instance (C n, C m) => C (n,m) where - type Index (n,m) = (Index n, Index m) - intersectCode a b = - case (MultiValue.unzip a, MultiValue.unzip b) of - ((an,am), (bn,bm)) -> - Monad.lift2 MultiValue.zip - (intersectCode an bn) - (intersectCode am bm) - sizeCode nm = - case MultiValue.unzip nm of - (n,m) -> liftR2 A.mul (sizeCode n) (sizeCode m) - size (n,m) = size n * size m - flattenIndexRec nm ij = - case (MultiValue.unzip nm, MultiValue.unzip ij) of - ((n,m), (i,j)) -> do - (ns, il) <- flattenIndexRec n i - (ms, jl) <- flattenIndexRec m j - Monad.lift2 (,) - (A.mul ns ms) - (A.add jl =<< A.mul ms il) - loop code nm = - case MultiValue.unzip nm of - (n,m) -> loop (\i -> loop (\j -> code (MultiValue.zip i j)) m) n - -instance (C n, C m, C l) => C (n,m,l) where - type Index (n,m,l) = (Index n, Index m, Index l) - intersectCode a b = - case (MultiValue.unzip3 a, MultiValue.unzip3 b) of - ((ai,aj,ak), (bi,bj,bk)) -> - Monad.lift3 MultiValue.zip3 - (intersectCode ai bi) - (intersectCode aj bj) - (intersectCode ak bk) - sizeCode nml = - case MultiValue.unzip3 nml of - (n,m,l) -> - liftR2 A.mul (sizeCode n) $ - liftR2 A.mul (sizeCode m) (sizeCode l) - size (n,m,l) = size n * size m * size l - flattenIndexRec nml ijk = - case (MultiValue.unzip3 nml, MultiValue.unzip3 ijk) of - ((n,m,l), (i,j,k)) -> do - (ns, il) <- flattenIndexRec n i - (ms, jl) <- flattenIndexRec m j - x0 <- A.add jl =<< A.mul ms il - (ls, kl) <- flattenIndexRec l k - x1 <- A.add kl =<< A.mul ls x0 - sz <- A.mul ns =<< A.mul ms ls - return (sz, x1) - loop code nml = - case MultiValue.unzip3 nml of - (n,m,l) -> - loop (\i -> loop (\j -> loop (\k -> - code (MultiValue.zip3 i j k)) - l) m) n diff --git a/src/Data/Array/Knead/Parameter.hs b/src/Data/Array/Knead/Parameter.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameter.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ExistentialQuantification #-} -module Data.Array.Knead.Parameter where - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Class as Class -import qualified LLVM.Extra.Memory as Memory -import Foreign.Storable.Tuple () -import Foreign.Storable (Storable, ) - -import qualified Control.Category as Cat -import qualified Control.Arrow as Arr -import qualified Control.Applicative as App -import Control.Applicative (pure, liftA2, ) - -import Data.Tuple.HT (mapFst, ) -import Data.Word (Word32, ) - - -{- | -This data type is for parameters of parameterized signal generators and causal processes. -It is better than using plain functions of type @p -> a@ -since it allows for numeric instances -and we can make explicit, -whether a parameter is constant. - -We recommend to use parameters for atomic types. -Although a parameter of type @T p (a,b)@ is possible, -it means that the whole parameter is variable -if only one of the pair elements is variable. -This way you may miss optimizations. --} -data T p a = - Constant a | - Variable (p -> a) - - -get :: T p a -> (p -> a) -get (Constant a) = const a -get (Variable f) = f - - -{- | -The call @value param v@ requires -that @v@ represents the same value as @valueTupleOf (get param p)@ for some @p@. -However @v@ might be the result of a load operation -and @param@ might be a constant. -In this case it is more efficient to use @valueTupleOf (get param undefined)@ -since the constant is translated to an LLVM constant -that allows for certain optimizations. - -This is the main function for taking advantage of a constant parameter -in low-level implementations. -For simplicity we do not omit constant parameters in the parameter struct -since this would mean to construct types at runtime and might become ugly. -Instead we just check using 'value' at the according places in LLVM code -whether a parameter is constant -and ignore the parameter from the struct in this case. -In many cases there will be no speed benefit -because the parameter will be loaded to a register anyway. -It can only lead to speed-up if subsequent optimizations -can precompute constant expressions. -Another example is 'drop' where a loop with constant loop count can be generated. -For small loop counts and simple loop bodies the loop might get unrolled. --} -valueTuple :: - (Class.MakeValueTuple tuple, Class.ValueTuple tuple ~ value) => - T p tuple -> value -> value -valueTuple = genericValue Class.valueTupleOf - -multiValue :: - (MultiValue.C a) => - T p a -> MultiValue.T a -> MultiValue.T a -multiValue = genericValue MultiValue.cons - -genericValue :: - (a -> value) -> - T p a -> value -> value -genericValue cons p v = - case p of - Constant a -> cons a - Variable _ -> v - - -{- | -This function provides specialised variants of 'get' and 'value', -that use the unit type for constants -and thus save space in parameter structures. --} -withTuple :: - (Storable tuple, Class.MakeValueTuple tuple, - Class.ValueTuple tuple ~ value, Memory.C value) => - T p tuple -> - (forall parameters. - (Storable parameters, - Class.MakeValueTuple parameters, - Memory.C (Class.ValueTuple parameters)) => - (p -> parameters) -> - (Class.ValueTuple parameters -> value) -> - a) -> - a -withTuple (Constant a) f = f (const ()) (\() -> Class.valueTupleOf a) -withTuple (Variable v) f = f v id - -withMulti :: - (Storable b, MultiValueMemory.C b) => - T p b -> - (forall parameters. - (Storable parameters, - MultiValueMemory.C parameters) => - (p -> parameters) -> - (MultiValue.T parameters -> MultiValue.T b) -> - a) -> - a -withMulti = with MultiValue.cons - -with :: - (Storable b, MultiValueMemory.C b) => - (b -> MultiValue.T b) -> - T p b -> - (forall parameters. - (Storable parameters, - MultiValueMemory.C parameters) => - (p -> parameters) -> - (MultiValue.T parameters -> MultiValue.T b) -> - a) -> - a -with cons p f = - case p of - Constant b -> f (const ()) (\_ -> cons b) - Variable v -> f v id - - -data Tunnel p a = - forall t. - (Storable t, MultiValueMemory.C t) => - Tunnel (p -> t) (MultiValue.T t -> MultiValue.T a) - -tunnel :: - (Storable a, MultiValueMemory.C a) => - (a -> MultiValue.T a) -> T p a -> Tunnel p a -tunnel cons p = - case p of - Constant b -> Tunnel (const ()) (\_ -> cons b) - Variable v -> Tunnel v id - - -word32 :: T p Int -> T p Word32 -word32 = fmap fromIntegral - - -infixl 0 $# - -($#) :: (T p a -> b) -> (a -> b) -($#) f a = f (pure a) - - -{- | -@.@ can be used for fetching a parameter from a super-parameter. --} -instance Cat.Category T where - id = Variable id - Constant f . _ = Constant f - Variable f . Constant a = Constant (f a) - Variable f . Variable g = Variable (f . g) - -{- | -@arr@ is useful for lifting parameter selectors to our parameter type -without relying on the constructor. --} -instance Arr.Arrow T where - arr = Variable - first f = Variable (mapFst (get f)) - - - -{- | -Useful for splitting @T p (a,b)@ into @T p a@ and @T p b@ -using @fmap fst@ and @fmap snd@. --} -instance Functor (T p) where - fmap f (Constant a) = Constant (f a) - fmap f (Variable g) = Variable (f . g) - -{- | -Useful for combining @T p a@ and @T p b@ to @T p (a,b)@ -using @liftA2 (,)@. -However, we do not recommend to do so -because the result parameter can only be constant -if both operands are constant. --} -instance App.Applicative (T p) where - pure a = Constant a - Constant f <*> Constant a = Constant (f a) - f <*> a = Variable (\p -> get f p (get a p)) - -instance Monad (T p) where - return = pure - Constant x >>= f = f x - Variable x >>= f = - Variable (\p -> get (f (x p)) p) - - -instance Num a => Num (T p a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = pure . fromInteger - -instance Fractional a => Fractional (T p a) where - (/) = liftA2 (/) - fromRational = pure . fromRational diff --git a/src/Data/Array/Knead/Parameterized/Physical.hs b/src/Data/Array/Knead/Parameterized/Physical.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameterized/Physical.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module Data.Array.Knead.Parameterized.Physical ( - Phys.Array, - Phys.shape, - Phys.fromList, - feed, - the, - render, - renderShape, - mapAccumL, - foldOuterL, - scatter, - scatterMaybe, - permute, - ) where - -import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHull -import qualified Data.Array.Knead.Parameterized.Private as Sym -import qualified Data.Array.Knead.Simple.Physical as Phys -import qualified Data.Array.Knead.Simple.Private as Core -import qualified Data.Array.Knead.Parameter as Param -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import qualified Data.Array.Knead.Code as Code -import Data.Array.Knead.Expression (Exp, unExp, ) -import Data.Array.Knead.Code (getElementPtr, compile, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Memory as Memory - -import qualified LLVM.Core as LLVM - -import Foreign.Marshal.Utils (with, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (Storable, peek, ) -import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr, ) -import Foreign.Ptr (FunPtr, Ptr, ) - -import Control.Exception (bracket, ) -import Control.Monad.HT ((<=<), ) -import Control.Applicative (liftA2, ) -import Data.Tuple.HT (mapFst, ) -import Data.Word (Word32, ) - - -feed :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - MultiValueMemory.C a) => - Param.T p (Phys.Array sh a) -> Sym.Array p sh a -feed arr = - Param.withMulti (fmap Phys.shape arr) $ \getShape valueShape -> - Sym.Array - (\p -> - case mapFst valueShape $ MultiValue.unzip p of - (sh, MultiValue.Cons ptr) -> - Core.Array (Expr.lift0 sh) $ - Memory.load <=< getElementPtr sh ptr) - (\p -> - case Phys.buffer $ Param.get arr p of - fptr -> - withForeignPtr fptr $ \ptr -> - return (fptr, (getShape p, MultiValueMemory.castStructPtr ptr))) - touchForeignPtr - - -type Importer f = FunPtr f -> f - -foreign import ccall safe "dynamic" callThe :: - Importer (Ptr param -> Ptr am -> IO ()) - - -the :: - (Shape.Scalar z, MultiValueMemory.C a, Storable a) => - Sym.Array p z a -> IO (p -> IO a) -the (Sym.Array arr create delete) = do - func <- - compile "the" $ - Code.createFunction callThe "eval" $ - \paramPtr resultPtr -> do - param <- Memory.load paramPtr - case arr param of - Core.Array z code -> - code (Shape.zeroIndex z) >>= flip Memory.store resultPtr - LLVM.ret () - return $ \p -> - bracket (create p) (delete . fst) $ \(_ctx, param) -> - with param $ \pptr -> - alloca $ \aptr -> - func (MultiValueMemory.castStructPtr pptr) (MultiValueMemory.castStructPtr aptr) >> - peek aptr - - -foreign import ccall safe "dynamic" callShaper :: - Importer (Ptr param -> Ptr shape -> IO Word32) - - -renderShape :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - Sym.Array p sh a -> IO (p -> IO (sh, Word32)) -renderShape (Sym.Array arr create delete) = do - fsh <- - compile "renderShape" $ - Code.createFunction callShaper "shape" $ - \paramPtr resultPtr -> do - param <- Memory.load paramPtr - case arr param of - Core.Array esh _code -> do - sh <- unExp esh - MultiValueMemory.store sh resultPtr - Shape.sizeCode sh >>= LLVM.ret - return $ \p -> - bracket (create p) (delete . fst) $ \(_ctx, param) -> - alloca $ \shptr -> - with param $ \pptr -> do - let lpptr = MultiValueMemory.castStructPtr pptr - let lshptr = MultiValueMemory.castStructPtr shptr - n <- fsh lpptr lshptr - sh <- peek shptr - return (sh, n) - - -render :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - Sym.Array p sh a -> IO (p -> IO (Phys.Array sh a)) -render = PhysHull.render . Sym.arrayHull - - -mapAccumL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - MultiValue.C acc, - Storable a, MultiValueMemory.C a, - Storable b, MultiValueMemory.C b) => - (Exp acc -> Exp a -> Exp (acc,b)) -> - Sym.Array p sh acc -> - Sym.Array p (sh, n) a -> - IO (p -> IO (Phys.Array (sh,n) b)) -mapAccumL f arrInit arrMap = - PhysHull.mapAccumL $ - liftA2 (PhysHull.MapAccumL f) - (Sym.arrayHull arrInit) - (Sym.arrayHull arrMap) - -foldOuterL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp b -> Exp a) -> - Sym.Array p sh a -> - Sym.Array p (n,sh) b -> - IO (p -> IO (Phys.Array sh a)) -foldOuterL f arrInit arrMap = - PhysHull.foldOuterL $ - liftA2 (PhysHull.FoldOuterL f) - (Sym.arrayHull arrInit) - (Sym.arrayHull arrMap) - -scatter :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array p sh1 a -> - Sym.Array p sh0 (ix1, a) -> IO (p -> IO (Phys.Array sh1 a)) -scatter accum arrBase arrMap = - PhysHull.scatter $ - liftA2 (PhysHull.Scatter accum) - (Sym.arrayHull arrBase) - (Sym.arrayHull arrMap) - -scatterMaybe :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array p sh1 a -> - Sym.Array p sh0 (Maybe (ix1, a)) -> IO (p -> IO (Phys.Array sh1 a)) -scatterMaybe accum arrBase arrMap = - PhysHull.scatterMaybe $ - liftA2 (PhysHull.ScatterMaybe accum) - (Sym.arrayHull arrBase) - (Sym.arrayHull arrMap) - -permute :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array p sh1 a -> - (Exp ix0 -> Exp ix1) -> - Sym.Array p sh0 a -> - IO (p -> IO (Phys.Array sh1 a)) -permute accum deflt ixmap input = - scatter accum deflt - (Core.mapWithIndex (Expr.lift2 MultiValue.zip . ixmap) input) diff --git a/src/Data/Array/Knead/Parameterized/PhysicalHull.hs b/src/Data/Array/Knead/Parameterized/PhysicalHull.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameterized/PhysicalHull.hs +++ /dev/null @@ -1,184 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module Data.Array.Knead.Parameterized.PhysicalHull ( - render, - Scatter(..), - scatter, - ScatterMaybe(..), - scatterMaybe, - MapAccumL(..), - mapAccumL, - FoldOuterL(..), - foldOuterL, - ) where - -import qualified Data.Array.Knead.Parameterized.Private as Sym -import qualified Data.Array.Knead.Simple.PhysicalPrivate as Priv -import qualified Data.Array.Knead.Simple.Physical as Phys -import qualified Data.Array.Knead.Simple.Private as Core -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Code as Code -import Data.Array.Knead.Expression (Exp, unExp, ) -import Data.Array.Knead.Code (compile, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Arithmetic as A - -import qualified LLVM.Core as LLVM - -import Foreign.Marshal.Utils (with, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (Storable, peek, ) -import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, ) -import Foreign.Ptr (FunPtr, Ptr, ) - -import Control.Exception (bracket, ) -import Control.Monad.HT (void, ) -import Control.Applicative (liftA2, ) -import Data.Word (Word32, ) - - -type Importer f = FunPtr f -> f - - -foreign import ccall safe "dynamic" callShaper :: - Importer (Ptr param -> Ptr shape -> IO Word32) - -foreign import ccall safe "dynamic" callFill :: - Importer (Ptr param -> Ptr shape -> Ptr am -> IO ()) - -materialize :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - String -> - (core -> Exp sh) -> - (core -> - LLVM.Value (Ptr (MultiValueMemory.Struct sh)) -> - LLVM.Value (Ptr (MultiValueMemory.Struct a)) -> - LLVM.CodeGenFunction () ()) -> - Sym.Hull p core -> IO (p -> IO (Phys.Array sh a)) -materialize name shape fill (Sym.Hull core create delete) = do - (fsh, farr) <- - compile name $ - liftA2 (,) - (Code.createFunction callShaper "shape" $ - \paramPtr resultPtr -> do - param <- Memory.load paramPtr - sh <- unExp $ shape $ core param - MultiValueMemory.store sh resultPtr - Shape.sizeCode sh >>= LLVM.ret) - (Code.createFunction callFill "fill" $ - \paramPtr shapePtr bufferPtr -> do - param <- Memory.load paramPtr - fill (core param) shapePtr bufferPtr - LLVM.ret ()) - - return $ \p -> - bracket (create p) (delete . fst) $ \(_ctx, param) -> - alloca $ \shptr -> - with param $ \paramPtr -> do - let paramMVPtr = MultiValueMemory.castStructPtr paramPtr - let shapeMVPtr = MultiValueMemory.castStructPtr shptr - n <- fsh paramMVPtr shapeMVPtr - fptr <- mallocForeignPtrArray (fromIntegral n) - withForeignPtr fptr $ - farr paramMVPtr shapeMVPtr . MultiValueMemory.castStructPtr - sh <- peek shptr - return (Phys.Array sh fptr) - - -render :: - (Shape.C sh, Shape.Index sh ~ ix, - Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - Sym.Hull p (Core.Array sh a) -> IO (p -> IO (Phys.Array sh a)) -render = - materialize "render" Core.shape - (\(Core.Array esh code) shapePtr bufferPtr -> do - let step ix p = do - flip Memory.store p =<< code ix - A.advanceArrayElementPtr p - sh <- Shape.load esh shapePtr - void $ Shape.loop step sh bufferPtr) - - -data Scatter sh0 sh1 a = - Scatter { - scatterAccum :: Exp a -> Exp a -> Exp a, - scatterInit :: Core.Array sh1 a, - scatterMap :: Core.Array sh0 (Shape.Index sh1, a) - } - -scatter :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - Sym.Hull p (Scatter sh0 sh1 a) -> IO (p -> IO (Phys.Array sh1 a)) -scatter = - materialize "scatter" - (Core.shape . scatterInit) - (\(Scatter accum arrInit arrMap) -> - Priv.scatter accum arrInit arrMap) - - - -data ScatterMaybe sh0 sh1 a = - ScatterMaybe { - scatterMaybeAccum :: Exp a -> Exp a -> Exp a, - scatterMaybeInit :: Core.Array sh1 a, - scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a)) - } - -scatterMaybe :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - Sym.Hull p (ScatterMaybe sh0 sh1 a) -> IO (p -> IO (Phys.Array sh1 a)) -scatterMaybe = - materialize "scatterMaybe" - (Core.shape . scatterMaybeInit) - (\(ScatterMaybe accum arrInit arrMap) -> - Priv.scatterMaybe accum arrInit arrMap) - - -data MapAccumL sh n acc a b = - MapAccumL { - mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b), - mapAccumLInit :: Core.Array sh acc, - mapAccumLMap :: Core.Array (sh, n) a - } - -mapAccumL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - MultiValue.C acc, - Storable a, MultiValueMemory.C a, - Storable b, MultiValueMemory.C b) => - Sym.Hull p (MapAccumL sh n acc a b) -> IO (p -> IO (Phys.Array (sh,n) b)) -mapAccumL = - materialize "mapAccumL" - (Core.shape . mapAccumLMap) - (\(MapAccumL f arrInit arrData) -> Priv.mapAccumL f arrInit arrData) - - -data FoldOuterL n sh a b = - FoldOuterL { - foldOuterLAccum :: Exp a -> Exp b -> Exp a, - foldOuterLInit :: Core.Array sh a, - foldOuterLMap :: Core.Array (n,sh) b - } - --- FIXME: check correct size of array of initial values -foldOuterL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - Storable a, MultiValueMemory.C a) => - Sym.Hull p (FoldOuterL n sh a b) -> IO (p -> IO (Phys.Array sh a)) -foldOuterL = - materialize "foldOuterL" - (Core.shape . foldOuterLInit) - (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData) diff --git a/src/Data/Array/Knead/Parameterized/Private.hs b/src/Data/Array/Knead/Parameterized/Private.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameterized/Private.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -module Data.Array.Knead.Parameterized.Private where - -import qualified Data.Array.Knead.Simple.Symbolic as Core - -import qualified Data.Array.Knead.Parameter as Param -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue - -import Foreign.Storable (Storable, ) - -import Control.Applicative (Applicative (pure, (<*>)), ) - -import Prelude hiding (id, map, zipWith, replicate, ) - - --- in principle we could define Array in terms of Hull and Core.Array -data Array p sh a = - forall parameter context. - (Storable parameter, MultiValueMemory.C parameter) => - Array { - core :: MultiValue.T parameter -> Core.Array sh a, - createContext :: p -> IO (context, parameter), - deleteContext :: context -> IO () - } - -instance Core.C (Array p) where - lift0 arr = Array (const arr) (createPlain (const ())) deletePlain - lift1 f (Array arr create delete) = Array (f . arr) create delete - lift2 f (Array arrA createA deleteA) (Array arrB createB deleteB) = - Array - (\p -> - case MultiValue.unzip p of - (paramA, paramB) -> f (arrA paramA) (arrB paramB)) - (combineCreate createA createB) - (combineDelete deleteA deleteB) - - -(!) :: - (Shape.C sh, Shape.Index sh ~ ix, - Storable ix, MultiValueMemory.C ix, - Shape.Scalar z) => - Array p sh a -> Param.T p ix -> Array p z a -(!) arr pix = - runHull $ - mapHullWithExp - (\ix carr -> Core.fromScalar $ carr Core.! ix) - (expParam pix) - (arrayHull arr) - - -fill :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - Param.T p sh -> Param.T p a -> Array p sh a -fill sh a = - Shape.paramWith sh $ \getSh valueSh -> - Param.withMulti a $ \getA valueA -> - Array - (\p -> - case MultiValue.unzip p of - (vsh, va) -> - Core.fill (valueSh vsh) (Expr.lift0 $ valueA va)) - (createPlain $ \p -> (getSh p, getA p)) - deletePlain - -gather :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, MultiValue.C a) => - Array p sh1 ix0 -> - Array p sh0 a -> - Array p sh1 a -gather = Core.gather - - -id :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, Shape.Index sh ~ ix) => - Param.T p sh -> Array p sh ix -id sh = - Shape.paramWith sh $ \getSh valueSh -> - Array - (Core.id . valueSh) - (createPlain getSh) - deletePlain - -map :: - (Shape.C sh, MultiValueMemory.C c, Storable c) => - (Exp c -> Exp a -> Exp b) -> - Param.T p c -> Array p sh a -> Array p sh b -map = lift Core.map - -mapWithIndex :: - (Shape.C sh, MultiValueMemory.C c, Storable c, Shape.Index sh ~ ix) => - (Exp c -> Exp ix -> Exp a -> Exp b) -> - Param.T p c -> Array p sh a -> Array p sh b -mapWithIndex = lift Core.mapWithIndex - - -fold1 :: - (Shape.C sh0, Shape.C sh1, - MultiValueMemory.C c, Storable c, MultiValue.C a) => - (Exp c -> Exp a -> Exp a -> Exp a) -> - Param.T p c -> Array p (sh0, sh1) a -> Array p sh0 a -fold1 = lift Core.fold1 - -fold1All :: - (Shape.C sh, Shape.Scalar z, - MultiValueMemory.C c, Storable c, MultiValue.C a) => - (Exp c -> Exp a -> Exp a -> Exp a) -> - Param.T p c -> Array p sh a -> Array p z a -fold1All = lift Core.fold1All - -lift :: - (Shape.C sh0, Shape.C sh1, - MultiValueMemory.C c, Storable c) => - (f -> Core.Array sh0 a -> Core.Array sh1 b) -> - (Exp c -> f) -> - Param.T p c -> Array p sh0 a -> Array p sh1 b -lift g f c arr = - runHull $ - mapHullWithExp - (\cexp -> g (f cexp)) - (expParam c) - (arrayHull arr) - - -data Hull p a = - forall parameter context. - (Storable parameter, MultiValueMemory.C parameter) => - Hull { - hullCore :: MultiValue.T parameter -> a, - hullCreateContext :: p -> IO (context, parameter), - hullDeleteContext :: context -> IO () - } - -instance Functor (Hull p) where - fmap f (Hull arr create delete) = Hull (f . arr) create delete - -instance Applicative (Hull p) where - pure a = Hull (const a) (const $ return ((),())) return - Hull arrA createA deleteA <*> Hull arrB createB deleteB = - Hull - (\p -> case MultiValue.unzip p of (a,b) -> arrA a $ arrB b) - (combineCreate createA createB) - (combineDelete deleteA deleteB) - -{- | -Equivalent to @liftA2 f (expHull p)@ but saves us an empty context. --} -mapHullWithExp :: - (Exp sl -> a -> b) -> - Param.Tunnel p sl -> Hull p a -> Hull p b -mapHullWithExp f tunnel (Hull arr create delete) = - case tunnel of - Param.Tunnel getSl valueSl -> - Hull - (\p -> - case MultiValue.unzip p of - (arrp, sl) -> f (Expr.lift0 $ valueSl sl) $ arr arrp) - (\p -> do - (ctx, param) <- create p - return (ctx, (param, getSl p))) - delete - -expHull :: Param.Tunnel p sl -> Hull p (Exp sl) -expHull tunnel = - case tunnel of - Param.Tunnel getSl valueSl -> - Hull - (Expr.lift0 . valueSl) - (\p -> return ((), getSl p)) - return - -arrayHull :: Array p sh a -> Hull p (Core.Array sh a) -arrayHull (Array arr create delete) = Hull arr create delete - -runHull :: Hull p (Core.Array sh a) -> Array p sh a -runHull (Hull arr create delete) = Array arr create delete - -extendHull :: (q -> p) -> Hull p a -> Hull q a -extendHull f (Hull arr create delete) = Hull arr (create . f) delete - - - -expParam :: - (Storable a, MultiValueMemory.C a) => Param.T p a -> Param.Tunnel p a -expParam = Param.tunnel MultiValue.cons - - - -createPlain :: (Monad m) => (p -> pl) -> p -> m ((), pl) -createPlain f p = return ((), f p) - -deletePlain :: (Monad m) => () -> m () -deletePlain () = return () - - -combineCreate :: - Monad m => - (p -> m (ctxA, paramA)) -> (p -> m (ctxB, paramB)) -> - p -> m ((ctxA, ctxB), (paramA, paramB)) -combineCreate createA createB p = do - (ctxA, paramA) <- createA p - (ctxB, paramB) <- createB p - return ((ctxA, ctxB), (paramA, paramB)) - -combineDelete :: - Monad m => - (ctxA -> m ()) -> (ctxB -> m ()) -> (ctxA, ctxB) -> m () -combineDelete deleteA deleteB (ctxA, ctxB) = do - deleteA ctxA - deleteB ctxB - - -extendParameter :: - (q -> p) -> Array p sh a -> Array q sh a -extendParameter f (Array arr create delete) = - Array arr (create . f) delete diff --git a/src/Data/Array/Knead/Parameterized/Render.hs b/src/Data/Array/Knead/Parameterized/Render.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameterized/Render.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{- | -Simplify running the @render@ function by handling passing of parameters. --} -module Data.Array.Knead.Parameterized.Render ( - run, - Scatter(..), - ScatterMaybe(..), - MapAccumL(..), - FoldOuterL(..), - ) where - -import qualified Data.Array.Knead.Parameterized.PhysicalHull as PhysHullP -import qualified Data.Array.Knead.Parameterized.Physical as PhysP -import qualified Data.Array.Knead.Parameterized.Private as Sym -import qualified Data.Array.Knead.Simple.Physical as Phys -import qualified Data.Array.Knead.Simple.Private as Core -import qualified Data.Array.Knead.Parameter as Param -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import Data.Array.Knead.Parameterized.PhysicalHull - (Scatter, ScatterMaybe, MapAccumL, FoldOuterL) -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue - -import Foreign.Storable (Storable, ) - -import Control.Arrow (arr, ) -import Control.Applicative (liftA2, liftA3, pure, (<*>), ) - -import Data.Tuple.HT (fst3, snd3, thd3, ) - - -class C f where - type Plain f - build :: Sym.Hull p f -> IO (p -> Plain f) - -instance - (MultiValueMemory.C sh, Storable sh, Shape.C sh, - MultiValueMemory.C a, Storable a) => - C (Core.Array sh a) where - type Plain (Core.Array sh a) = IO (Phys.Array sh a) - build = PhysHullP.render - -instance - (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0, - MultiValueMemory.C sh1, Storable sh1, Shape.C sh1, - MultiValueMemory.C a, Storable a) => - C (Scatter sh0 sh1 a) where - type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a) - build = PhysHullP.scatter - -instance - (MultiValueMemory.C sh0, Storable sh0, Shape.C sh0, - MultiValueMemory.C sh1, Storable sh1, Shape.C sh1, - MultiValueMemory.C a, Storable a) => - C (ScatterMaybe sh0 sh1 a) where - type Plain (ScatterMaybe sh0 sh1 a) = IO (Phys.Array sh1 a) - build = PhysHullP.scatterMaybe - -instance - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - MultiValue.C acc, - Storable a, MultiValueMemory.C a, - Storable b, MultiValueMemory.C b) => - C (MapAccumL sh n acc a b) where - type Plain (MapAccumL sh n acc a b) = IO (Phys.Array (sh,n) b) - build = PhysHullP.mapAccumL - -instance - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - Storable a, MultiValueMemory.C a, - Storable b, MultiValueMemory.C b) => - C (FoldOuterL n sh a b) where - type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a) - build = PhysHullP.foldOuterL - - -singleton :: Exp a -> Core.Array () a -singleton = Core.fromScalar - -instance (MultiValueMemory.C a, Storable a) => C (Exp a) where - type Plain (Exp a) = IO a - build = PhysP.the . Sym.runHull . fmap singleton - -instance (Argument arg, C func) => C (arg -> func) where - type Plain (arg -> func) = PlainArg arg -> Plain func - build f = fmap curry $ build $ Sym.extendHull fst f <*> buildArg (arr snd) - - -class Argument arg where - type PlainArg arg - buildArg :: Param.T p (PlainArg arg) -> Sym.Hull p arg - -instance - (MultiValueMemory.C sh, Storable sh, Shape.C sh, MultiValueMemory.C a) => - Argument (Core.Array sh a) where - type PlainArg (Core.Array sh a) = Phys.Array sh a - buildArg = Sym.arrayHull . PhysP.feed - -instance (MultiValueMemory.C a, Storable a) => Argument (Exp a) where - type PlainArg (Exp a) = a - buildArg = Sym.expHull . Sym.expParam - -instance (Argument a, Argument b) => Argument (a,b) where - type PlainArg (a,b) = (PlainArg a, PlainArg b) - buildArg p = liftA2 (,) (buildArg $ fmap fst p) (buildArg $ fmap snd p) - -instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where - type PlainArg (a,b,c) = (PlainArg a, PlainArg b, PlainArg c) - buildArg p = - liftA3 (,,) - (buildArg $ fmap fst3 p) (buildArg $ fmap snd3 p) (buildArg $ fmap thd3 p) - - -run :: (C f) => f -> IO (Plain f) -run f = fmap ($()) $ build $ pure f - - - -_example :: - (Storable x, MultiValueMemory.C x, - Shape.C sha, Storable sha, MultiValueMemory.C sha, MultiValueMemory.C a, - Shape.C shb, Storable shb, MultiValueMemory.C shb, MultiValueMemory.C b, - Shape.C shc, Storable shc, MultiValueMemory.C shc, MultiValueMemory.C c, - Storable c) => - (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) -> - IO (x -> Phys.Array sha a -> Phys.Array shb b -> IO (Phys.Array shc c)) -_example f = - fmap (\g -> curry $ curry g) $ - PhysP.render $ - Sym.runHull $ - pure f - <*> Sym.expHull (Sym.expParam $ arr (fst.fst)) - <*> Sym.arrayHull (PhysP.feed $ arr (snd.fst)) - <*> Sym.arrayHull (PhysP.feed $ arr snd) diff --git a/src/Data/Array/Knead/Parameterized/Slice.hs b/src/Data/Array/Knead/Parameterized/Slice.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameterized/Slice.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeOperators #-} -module Data.Array.Knead.Parameterized.Slice ( - T, - apply, - Linear, - passAny, - pass, - pick, - extrude, - (Core.$:.), - ) where - -import qualified Data.Array.Knead.Parameterized.Private as Priv -import Data.Array.Knead.Parameterized.Private (Array(Array), ) - -import qualified Data.Array.Knead.Simple.Slice as Slice -import qualified Data.Array.Knead.Simple.Private as Core - -import qualified Data.Array.Knead.Index.Linear as Linear -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Parameter as Param -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, ) -import Data.Array.Knead.Index.Linear ((:.), ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue - -import Foreign.Storable (Storable, ) - - -{- -This wrapper data type is pretty much the same as Parameterized.Array -but there seems to be no benefit from using the same data structure for it. --} -data T p sh0 sh1 = - forall parameter context. - (Storable parameter, MultiValueMemory.C parameter) => - Cons { - _core :: MultiValue.T parameter -> Slice.T sh0 sh1, - _createContext :: p -> IO (context, parameter), - _deleteContext :: context -> IO () - } - -apply :: - (Shape.C sh0, Shape.C sh1, MultiValue.C a) => - T p sh0 sh1 -> - Array p sh0 a -> - Array p sh1 a -apply (Cons slice createSlice deleteSlice) (Array arr createArr deleteArr) = - Array - (\p -> - case MultiValue.unzip p of - (paramSlice, paramArr) -> - Slice.apply (slice paramSlice) (arr paramArr)) - (Priv.combineCreate createSlice createArr) - (Priv.combineDelete deleteSlice deleteArr) - - -type Linear p sh0 sh1 = T p (Linear.Shape sh0) (Linear.Shape sh1) - - -passAny :: Linear p sh sh -passAny = - Cons (const Slice.passAny) (Priv.createPlain $ const ()) Priv.deletePlain - -pass :: - Linear p sh0 sh1 -> - Linear p (sh0:.i) (sh1:.i) -pass (Cons slice create delete) = Cons (Slice.pass . slice) create delete - -pick :: - (MultiValueMemory.C i, Storable i) => - Param.T p i -> - Linear p sh0 sh1 -> - Linear p (sh0:.i) sh1 -pick = lift Slice.pick - -extrude :: - (MultiValueMemory.C i, Storable i) => - Param.T p i -> - Linear p sh0 sh1 -> - Linear p sh0 (sh1:.i) -extrude = lift Slice.extrude - -lift :: - (MultiValueMemory.C i, Storable i) => - (Exp i -> Slice.Linear sh0 sh1 -> Slice.Linear sh2 sh3) -> - Param.T p i -> - Linear p sh0 sh1 -> Linear p sh2 sh3 -lift f i (Cons slice create delete) = - Param.withMulti i $ \getI valueI -> - Cons - (\p -> - case MultiValue.unzip p of - (slicep, ip) -> - f (Expr.lift0 (valueI ip)) (slice slicep)) - (\p -> do - (ctx, param) <- create p - return (ctx, (param, getI p))) - delete - -instance Core.Process (T p sh0 sh1) where diff --git a/src/Data/Array/Knead/Parameterized/Symbolic.hs b/src/Data/Array/Knead/Parameterized/Symbolic.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Parameterized/Symbolic.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GADTs #-} -module Data.Array.Knead.Parameterized.Symbolic ( - Array, - Exp, - Sym.extendParameter, - withExp, - withExp2, - withExp3, - (Sym.!), - Sym.fill, - gather, - backpermute, - Sym.id, - Sym.map, - zipWith, - Sym.fold1, - Sym.fold1All, - ) where - -import qualified Data.Array.Knead.Parameterized.Private as Sym -import qualified Data.Array.Knead.Simple.Symbolic as Core -import Data.Array.Knead.Parameterized.Private (Array, gather, ) - -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Parameter as Param -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue - -import Foreign.Storable (Storable, ) - -import Control.Applicative ((<*>), ) - -import Prelude (uncurry, ($), (.), ) - - -{- -fromScalar :: - (Storable a, MultiValueMemory.C a, MultiValue.C a) => - Param.T p a -> Array p Z a -fromScalar = Sym.fill (return Z) --} - - -backpermute :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - MultiValue.C a) => - Param.T p sh1 -> - (Exp ix1 -> Exp ix0) -> - Array p sh0 a -> - Array p sh1 a -backpermute sh1 f = gather (Core.map f (Sym.id sh1)) - - -zipWith :: - (Shape.C sh, MultiValueMemory.C d, Storable d) => - (Exp d -> Exp a -> Exp b -> Exp c) -> - Param.T p d -> Array p sh a -> Array p sh b -> Array p sh c -zipWith f d a b = - Sym.map (\di ab -> uncurry (f di) $ Expr.unzip ab) d $ Core.zip a b - - -withExp :: - (Storable x, MultiValueMemory.C x) => - (Exp x -> Core.Array shb b -> Core.Array sha a) -> - Param.T p x -> Array p shb b -> Array p sha a -withExp f x = - Sym.runHull . Sym.mapHullWithExp f (Sym.expParam x) . Sym.arrayHull - -withExp2 :: - (Storable x, MultiValueMemory.C x) => - (Exp x -> Core.Array sha a -> Core.Array shb b -> Core.Array shc c) -> - Param.T p x -> Array p sha a -> Array p shb b -> Array p shc c -withExp2 f x a b = - Sym.runHull $ - Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a) - <*> Sym.arrayHull b - -withExp3 :: - (Storable x, MultiValueMemory.C x) => - (Exp x -> Core.Array sha a -> - Core.Array shb b -> Core.Array shc c -> Core.Array shd d) -> - Param.T p x -> Array p sha a -> - Array p shb b -> Array p shc c -> Array p shd d -withExp3 f x a b c = - Sym.runHull $ - Sym.mapHullWithExp f (Sym.expParam x) (Sym.arrayHull a) - <*> Sym.arrayHull b - <*> Sym.arrayHull c diff --git a/src/Data/Array/Knead/Shape.hs b/src/Data/Array/Knead/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Shape.hs @@ -0,0 +1,388 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Array.Knead.Shape ( + C(..), Index, + Size, + value, + paramWith, + load, + intersect, + offset, + + ZeroBased(ZeroBased), zeroBased, zeroBasedSize, + + Range(Range), range, rangeFrom, rangeTo, + Shifted(Shifted), shifted, shiftedOffset, shiftedSize, + Cyclic(Cyclic), cyclic, cyclicSize, + + Enumeration(Enumeration), EnumBounded(..), + + Scalar(..), + Sequence(..), + ) where + +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Shape.Orphan + (zeroBased, zeroBasedSize, cyclic, cyclicSize, + singletonRange, unzipRange, singletonShifted, unzipShifted) +import Data.Array.Knead.Expression (Exp, ) + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape + (Index, ZeroBased, Range(Range), Shifted(Shifted), Cyclic, + Enumeration(Enumeration)) +import Data.Ix (Ix) + +import qualified LLVM.DSL.Parameter as Param + +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Nice.Iterator as IterNV +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Iterator as Iter +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Arithmetic as A +import LLVM.Extra.Nice.Value (atom) + +import qualified LLVM.Core as LLVM + +import qualified Data.Enum.Storable as Enum +import Data.Tagged (Tagged) +import Data.Tuple.HT (mapSnd) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64) + +import qualified Control.Monad.HT as Monad +import Control.Applicative ((<$>)) + +import Prelude2010 +import Prelude () + + +type Size = Word + +value :: (C sh, Expr.Value val) => sh -> val sh +value = Expr.lift0 . NiceValue.cons + +paramWith :: + (Marshal.C b) => + Param.T p b -> + (forall parameters. + (Marshal.C parameters) => + (p -> parameters) -> + (forall val. (Expr.Value val) => + NiceValue.T parameters -> val b) -> + a) -> + a +paramWith p f = + Param.withNice p (\get val -> f get (Expr.lift0 . val)) + +load :: + (Marshal.C sh) => + f sh -> LLVM.Value (LLVM.Ptr (Marshal.Struct sh)) -> + LLVM.CodeGenFunction r (NiceValue.T sh) +load _ = Memory.load + +intersect :: (C sh) => Exp sh -> Exp sh -> Exp sh +intersect = Expr.liftM2 intersectCode + +offset :: + (C sh) => + NiceValue.T sh -> NiceValue.T (Index sh) -> + LLVM.CodeGenFunction r (LLVM.Value Size) +offset sh ix = ($ ix) . snd =<< sizeOffset sh + +class (NiceValue.C sh, NiceValue.C (Index sh), Shape.Indexed sh) => C sh where + {- + It would be better to restrict zipWith to matching shapes + and turn shape intersection into a bound check. + -} + intersectCode :: + NiceValue.T sh -> NiceValue.T sh -> + LLVM.CodeGenFunction r (NiceValue.T sh) + size :: NiceValue.T sh -> LLVM.CodeGenFunction r (LLVM.Value Size) + {- | + Result is @(size, offset)@. + @size@ must equal the result of 'size'. + We use this for sharing intermediate results. + -} + sizeOffset :: + (Index sh ~ ix) => + NiceValue.T sh -> + LLVM.CodeGenFunction r + (LLVM.Value Size, + NiceValue.T ix -> LLVM.CodeGenFunction r (LLVM.Value Size)) + iterator :: (Index sh ~ ix) => NiceValue.T sh -> Iter.T r (NiceValue.T ix) + loop :: + (Index sh ~ ix, Tuple.Phi state) => + (NiceValue.T ix -> state -> LLVM.CodeGenFunction r state) -> + NiceValue.T sh -> state -> LLVM.CodeGenFunction r state + loop f sh = Iter.mapState_ f (iterator sh) + + +instance C () where + intersectCode _ _ = return $ NiceValue.cons () + size _ = return A.one + sizeOffset _ = return (A.one, \_ -> return A.zero) + iterator = Iter.singleton + loop = id + + +class C sh => Scalar sh where + scalar :: (Expr.Value val) => val sh + zeroIndex :: (Expr.Value val) => f sh -> val (Index sh) + +instance Scalar () where + scalar = Expr.lift0 $ NiceValue.Cons () + zeroIndex _ = Expr.lift0 $ NiceValue.Cons () + + +class + (C sh, + NiceValue.IntegerConstant (Index sh), + NiceValue.Additive (Index sh)) => + Sequence sh where + sequenceShapeFromIndex :: + NiceValue.T (Index sh) -> LLVM.CodeGenFunction r (NiceValue.T sh) + + +class + (NiceValue.Additive n, NiceValue.Real n, NiceValue.IntegerConstant n) => + ToSize n where + toSize :: NiceValue.T n -> LLVM.CodeGenFunction r (LLVM.Value Size) + +instance ToSize Word8 where toSize (NiceValue.Cons n) = LLVM.ext n +instance ToSize Word16 where toSize (NiceValue.Cons n) = LLVM.ext n +instance ToSize Word32 where toSize (NiceValue.Cons n) = LLVM.adapt n +instance ToSize Word64 where toSize (NiceValue.Cons n) = LLVM.adapt n +instance ToSize Word where toSize (NiceValue.Cons n) = LLVM.adapt n +instance ToSize Int8 where toSize (NiceValue.Cons n) = LLVM.zext n +instance ToSize Int16 where toSize (NiceValue.Cons n) = LLVM.zext n +instance ToSize Int32 where toSize (NiceValue.Cons n) = LLVM.zadapt n +instance ToSize Int64 where toSize (NiceValue.Cons n) = LLVM.zadapt n +instance ToSize Int where toSize (NiceValue.Cons n) = LLVM.zadapt n + + +{- | +Array dimensions and indexes cannot be negative, +but computations in indices may temporarily yield negative values +or we want to add negative values to indices. + +So maybe, we would better have type Index (ZeroBased Word64) = Int64. +This is not possible. +Maybe we need an additional ZeroBased type for unsigned array sizes. +-} +instance + (Integral n, ToSize n, NiceValue.Comparison n) => C (ZeroBased n) where + intersectCode sha shb = + zeroBased <$> NiceValue.min (zeroBasedSize sha) (zeroBasedSize shb) + size = toSize . zeroBasedSize + sizeOffset sh = Monad.lift2 (,) (toSize $ zeroBasedSize sh) (return toSize) + iterator sh = + IterNV.take (zeroBasedSize sh) $ + Iter.iterate NiceValue.inc NiceValue.zero + +instance + (Integral n, ToSize n, NiceValue.Comparison n) => + Sequence (ZeroBased n) where + sequenceShapeFromIndex = return . zeroBased + + +rangeSize :: + (ToSize n) => + Range (NiceValue.T n) -> LLVM.CodeGenFunction r (LLVM.Value Size) +rangeSize (Range from to) = + toSize =<< NiceValue.inc =<< NiceValue.sub to from + + +rangeFrom :: (Expr.Value val) => val (Range n) -> val n +rangeFrom = Expr.lift1 $ Shape.rangeFrom . unzipRange + +rangeTo :: (Expr.Value val) => val (Range n) -> val n +rangeTo = Expr.lift1 $ Shape.rangeTo . unzipRange + +range :: (Expr.Value val) => val n -> val n -> val (Range n) +range = + Expr.lift2 $ + \(NiceValue.Cons from) (NiceValue.Cons to) -> + NiceValue.Cons (Range from to) + +instance (Ix n, ToSize n, NiceValue.Comparison n) => C (Range n) where + intersectCode = + NiceValue.modifyF2 (singletonRange atom) (singletonRange atom) $ + \(Range fromN toN) (Range fromM toM) -> + Monad.lift2 Range (NiceValue.max fromN fromM) (NiceValue.min toN toM) + size = rangeSize . unzipRange + sizeOffset rngValue = + case unzipRange rngValue of + rng@(Range from _to) -> + Monad.lift2 (,) (rangeSize rng) + (return $ \i -> toSize =<< NiceValue.sub i from) + iterator rngValue = + case NiceValue.decompose (singletonRange atom) rngValue of + Range from to -> + IterNV.takeWhile (NiceValue.cmp LLVM.CmpGE to) $ + Iter.iterate NiceValue.inc from + + + +shiftedOffset :: (Expr.Value val) => val (Shifted n) -> val n +shiftedOffset = Expr.lift1 $ Shape.shiftedOffset . unzipShifted + +shiftedSize :: (Expr.Value val) => val (Shifted n) -> val n +shiftedSize = Expr.lift1 $ Shape.shiftedSize . unzipShifted + +shifted :: (Expr.Value val) => val n -> val n -> val (Shifted n) +shifted = + Expr.lift2 $ + \(NiceValue.Cons from) (NiceValue.Cons to) -> + NiceValue.Cons (Shifted from to) + + +instance (Integral n, ToSize n, NiceValue.Comparison n) => C (Shifted n) where + intersectCode = + NiceValue.modifyF2 (singletonShifted atom) (singletonShifted atom) $ + \(Shifted startN lenN) (Shifted startM lenM) -> do + start <- NiceValue.max startN startM + endN <- NiceValue.add startN lenN + endM <- NiceValue.add startM lenM + end <- NiceValue.min endN endM + Shifted start <$> NiceValue.sub end start + size = toSize . shiftedSize + sizeOffset shapeValue = + case unzipShifted shapeValue of + Shifted start len -> + Monad.lift2 (,) (toSize len) + (return $ \i -> toSize =<< NiceValue.sub i start) + iterator rngValue = + case NiceValue.decompose (singletonShifted atom) rngValue of + Shifted from len -> + IterNV.take len $ Iter.iterate NiceValue.inc from + + +instance + (Integral n, ToSize n, NiceValue.Comparison n) => C (Cyclic n) where + intersectCode sha shb = + cyclic <$> NiceValue.min (cyclicSize sha) (cyclicSize shb) + size = toSize . cyclicSize + sizeOffset sh = Monad.lift2 (,) (toSize $ cyclicSize sh) (return toSize) + iterator sh = + IterNV.take (cyclicSize sh) $ + Iter.iterate NiceValue.inc NiceValue.zero + + +class (IterNV.Enum enum, NiceValue.Bounded enum) => EnumBounded enum where + enumOffset :: NiceValue.T enum -> LLVM.CodeGenFunction r (LLVM.Value Size) + +instance + (ToSize w, NiceValue.Additive w, + LLVM.IsInteger w, SoV.IntegerConstant w, Num w, + NiceValue.Repr w ~ LLVM.Value w, + LLVM.CmpRet w, LLVM.IsPrimitive w, + Enum e, Bounded e) => + EnumBounded (Enum.T w e) where + enumOffset ix = + toSize =<< + NiceValue.sub + (NiceValue.fromEnum ix) + (NiceValue.fromEnum $ NiceValue.minBound `asTypeOf` ix) + +instance + (Enum enum, Bounded enum, EnumBounded enum) => C (Enumeration enum) where + intersectCode _sha shb = return shb + size = return . A.fromInteger' . toInteger . Shape.size . plainEnumeration + sizeOffset sh = do + sz <- size sh + return (sz, enumOffset) + iterator _ = IterNV.enumFromTo NiceValue.minBound NiceValue.maxBound + +plainEnumeration :: val (Enumeration enum) -> Enumeration enum +plainEnumeration _ = Enumeration + + +instance (C sh) => C (Tagged tag sh) where + intersectCode = NiceValue.liftTaggedM2 intersectCode + size = size . NiceValue.untag + sizeOffset = + fmap (mapSnd (. NiceValue.untag)) . sizeOffset . NiceValue.untag + iterator = fmap NiceValue.tag . iterator . NiceValue.untag + + +instance (C n, C m) => C (n,m) where + intersectCode a b = + case (NiceValue.unzip a, NiceValue.unzip b) of + ((an,am), (bn,bm)) -> + Monad.lift2 NiceValue.zip + (intersectCode an bn) + (intersectCode am bm) + size nm = + case NiceValue.unzip nm of + (n,m) -> Monad.liftJoin2 A.mul (size n) (size m) + sizeOffset nm = + case NiceValue.unzip nm of + (n,m) -> do + (ns, iOffset) <- sizeOffset n + (ms, jOffset) <- sizeOffset m + sz <- A.mul ns ms + return + (sz, + \ij -> + case NiceValue.unzip ij of + (i,j) -> do + il <- iOffset i + jl <- jOffset j + A.add jl =<< A.mul ms il) + iterator nm = + case NiceValue.unzip nm of + (n,m) -> + uncurry NiceValue.zip <$> + Iter.cartesian (iterator n) (iterator m) + loop code nm = + case NiceValue.unzip nm of + (n,m) -> loop (\i -> loop (\j -> code (NiceValue.zip i j)) m) n + +instance (C n, C m, C l) => C (n,m,l) where + intersectCode a b = + case (NiceValue.unzip3 a, NiceValue.unzip3 b) of + ((ai,aj,ak), (bi,bj,bk)) -> + Monad.lift3 NiceValue.zip3 + (intersectCode ai bi) + (intersectCode aj bj) + (intersectCode ak bk) + size nml = + case NiceValue.unzip3 nml of + (n,m,l) -> + Monad.liftJoin2 A.mul (size n) $ + Monad.liftJoin2 A.mul (size m) (size l) + sizeOffset nml = + case NiceValue.unzip3 nml of + (n,m,l) -> do + (ns, iOffset) <- sizeOffset n + (ms, jOffset) <- sizeOffset m + (ls, kOffset) <- sizeOffset l + sz <- A.mul ns =<< A.mul ms ls + return + (sz, + \ijk -> + case NiceValue.unzip3 ijk of + (i,j,k) -> do + il <- iOffset i + jl <- jOffset j + kl <- kOffset k + A.add kl =<< A.mul ls =<< A.add jl =<< A.mul ms il) + iterator nml = + case NiceValue.unzip3 nml of + (n,m,l) -> + fmap (\(a,(b,c)) -> NiceValue.zip3 a b c) $ + Iter.cartesian (iterator n) $ + Iter.cartesian (iterator m) (iterator l) + loop code nml = + case NiceValue.unzip3 nml of + (n,m,l) -> + loop (\i -> loop (\j -> loop (\k -> + code (NiceValue.zip3 i j k)) + l) m) n diff --git a/src/Data/Array/Knead/Shape/Cubic.hs b/src/Data/Array/Knead/Shape/Cubic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Shape/Cubic.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Array.Knead.Shape.Cubic ( + constant, + paramWith, + tunnel, + + T(..), + Z(Z), z, + (:.)((:.)), + Shape, + Index, + cons, (#:.), + head, + tail, + switchR, + ) where + +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Shape.Cubic.Int as Index + +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Expression (Exp, ) + +import qualified Data.Array.Comfort.Shape as ComfortShape +import Data.Array.Comfort.Shape (ZeroBased(ZeroBased)) + +import qualified LLVM.DSL.Parameter as Param + +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Nice.Iterator as IterNV +import qualified LLVM.Extra.Iterator as Iter +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Control as C +import LLVM.Extra.Nice.Value (Atom) + +import qualified LLVM.Core as LLVM + +import qualified Foreign.Storable as St +import Foreign.Storable.FixedArray (sizeOfArray, ) +import Foreign.Ptr (castPtr, ) + +import qualified Type.Data.Num.Decimal as Dec +import qualified Type.Data.Num.Unary as Unary +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import qualified Data.FixedLength as FixedLength +import Data.FixedLength ((!:)) + +import Control.Monad (liftM2, ) +import Control.Applicative (pure, (<$>), ) + +import Prelude hiding (min, head, tail, ) + + +newtype T tag rank = Cons {decons :: FixedLength.T rank Index.Int} + +data ShapeTag +data IndexTag + +type Shape = T ShapeTag +type Index = T IndexTag + + +paramWith :: + (Unary.Natural rank, + Dec.Natural (Dec.FromUnary rank), + Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) => + Param.T p (T tag rank) -> + (forall parameters. + (Marshal.C parameters) => + (p -> parameters) -> + (forall val. (Expr.Value val) => + NiceValue.T parameters -> val (T tag rank)) -> + a) -> + a +paramWith p f = + case tunnel p of + Param.Tunnel get val -> f get (Expr.lift0 . val) + +tunnel :: + (Unary.Natural rank, + Dec.Natural (Dec.FromUnary rank), + Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) => + Param.T p (T tag rank) -> Param.Tunnel p (T tag rank) +tunnel p = Param.tunnel NiceValue.cons p + + +data Z = Z + deriving (Eq, Ord, Read, Show) + + +infixl 3 :., #:. + +data tail :. head = !tail :. !head + deriving (Eq, Ord, Read, Show) + + +(#:.) :: + (Expr.Value val) => + val (T tag rank) -> val Index.Int -> val (T tag (Unary.Succ rank)) +(#:.) = cons + +cons :: + (Expr.Value val) => + val (T tag rank) -> val Index.Int -> val (T tag (Unary.Succ rank)) +cons = + Expr.lift2 $ + \(NiceValue.Cons t) (NiceValue.Cons h) -> NiceValue.Cons (h!:t) + +z :: (Expr.Value val) => val (T tag Unary.Zero) +z = Expr.lift0 $ NiceValue.Cons FixedLength.end + +head :: + (Expr.Value val, Unary.Natural rank) => + val (T tag (Unary.Succ rank)) -> val Index.Int +head = + Expr.lift1 $ \(NiceValue.Cons sh) -> NiceValue.Cons $ FixedLength.head sh + +tail :: + (Expr.Value val, Unary.Natural rank) => + val (T tag (Unary.Succ rank)) -> val (T tag rank) +tail = + Expr.lift1 $ \(NiceValue.Cons sh) -> NiceValue.Cons $ FixedLength.tail sh + +switchR :: + (Unary.Natural rank) => + Expr.Value val => + (val (T tag rank) -> val Index.Int -> a) -> + val (T tag (Unary.Succ rank)) -> a +switchR f ix = f (tail ix) (head ix) + + +rank :: T tag rank -> Proxy rank +rank (Cons _) = Proxy + + +instance (tag ~ ShapeTag, rank ~ Unary.Zero) => Shape.Scalar (T tag rank) where + scalar = Expr.lift0 $ NiceValue.Cons FixedLength.end + zeroIndex _ = Expr.lift0 $ NiceValue.Cons FixedLength.end + + +type family AtomRank sh +type instance AtomRank (Atom (T tag rank)) = rank +type instance AtomRank (sh:.s) = Unary.Succ (AtomRank s) + +type family AtomTag sh +type instance AtomTag (Atom (T tag rank)) = tag +type instance AtomTag (sh:.s) = AtomTag sh + +type instance NiceValue.PatternTuple (sh:.s) = + T (AtomTag sh) (Unary.Succ (AtomRank sh)) + +type instance NiceValue.Decomposed f (sh:.s) = + NiceValue.Decomposed f sh :. f Index.Int + +instance + (Expr.Decompose sh, Expr.Decompose s, + NiceValue.Decomposed Exp s ~ Exp Index.Int, + NiceValue.PatternTuple s ~ Index.Int, + NiceValue.PatternTuple sh ~ T (AtomTag sh) (AtomRank sh), + Unary.Natural (AtomRank sh)) => + Expr.Decompose (sh :. s) where + decompose (psh:.ps) x = + Expr.decompose psh (tail x) :. Expr.decompose ps (head x) + + +type family Rank sh +type instance Rank (T tag rank) = rank + +type family Tag sh +type instance Tag (T tag rank) = tag + +instance + (Expr.Compose sh, + Expr.Composed sh ~ T (Tag (Expr.Composed sh)) (Rank (Expr.Composed sh)), + Expr.Compose s, + Expr.Composed s ~ Index.Int) => + Expr.Compose (sh :. s) where + type Composed (sh :. s) = + T (Tag (Expr.Composed sh)) (Unary.Succ (Rank (Expr.Composed sh))) + compose (sh :. s) = cons (Expr.compose sh) (Expr.compose s) + + +instance (Unary.Natural rank) => St.Storable (T tag rank) where + sizeOf sh = sizeOfArray (Unary.integralFromProxy $ rank sh) (0::Shape.Size) + alignment (Cons _sh) = St.alignment (0::Shape.Size) + poke ptr = St.poke (castPtr ptr) . fmap (\(Index.Int i) -> i) . decons + peek = fmap (Cons . fmap Index.Int) . St.peek . castPtr + +instance + (Unary.Natural rank, + Dec.Natural (Dec.FromUnary rank), + Dec.Natural (Dec.FromUnary rank Dec.:*: LLVM.SizeOf Shape.Size)) => + Marshal.C (T tag rank) where + pack = LLVM.Array . map Marshal.pack . Fold.toList . decons + unpack (LLVM.Array sh) = Cons $ toFixedList $ map Marshal.unpack sh + +toFixedList :: (Unary.Natural n) => [a] -> FixedLength.T n a +toFixedList xs = snd $ Trav.mapAccumL (\(y:ys) () -> (ys,y)) xs (pure ()) + + +instance (Unary.Natural rank) => NiceValue.C (T tag rank) where + type Repr (T tag rank) = FixedLength.T rank (NiceValue.Repr Index.Int) + cons = NiceValue.Cons . fmap (\(Index.Int i) -> LLVM.valueOf i) . decons + undef = constant $ NiceValue.undef + zero = constant $ NiceValue.zero + addPhi bb (NiceValue.Cons a) (NiceValue.Cons b) = + Tuple.addPhiFoldable bb a b + phi bb (NiceValue.Cons a) = + fmap NiceValue.Cons . Tuple.phiTraversable bb $ a + +constant :: + (Unary.Natural rank) => NiceValue.T Index.Int -> NiceValue.T (T tag rank) +constant (NiceValue.Cons x) = NiceValue.Cons $ pure x + +instance + (tag ~ ShapeTag, Unary.Natural rank) => + ComfortShape.C (T tag rank) where + size = Fold.product . fmap (ComfortShape.size . shapeFromInt) . decons + +instance + (tag ~ ShapeTag, Unary.Natural rank) => + ComfortShape.Indexed (T tag rank) where + type Index (T tag rank) = Index rank + indices (Cons ix) = + map (Cons . fmap Index.Int) $ + Trav.mapM (ComfortShape.indices . shapeFromInt) ix + inBounds (Cons sh) (Cons ix) = + Fold.and $ + FixedLength.zipWith ComfortShape.inBounds + (shapeFromInt <$> sh) (indexFromInt <$> ix) + unifiedOffset (Cons sh) (Cons ix) = + Fold.foldlM + (\off (s,i) -> do + ioff <- ComfortShape.unifiedOffset s i + return $! off * ComfortShape.size s + ioff) + 0 $ + FixedLength.zipWith (,) (shapeFromInt <$> sh) (indexFromInt <$> ix) + +shapeFromInt :: Index.Int -> ZeroBased Shape.Size +shapeFromInt (Index.Int i) = ZeroBased i + +indexFromInt :: Index.Int -> Shape.Size +indexFromInt (Index.Int i) = i + + +instance (tag ~ ShapeTag, Unary.Natural rank) => Shape.C (T tag rank) where + size (NiceValue.Cons sh) = Fold.foldlM A.mul A.one sh + intersectCode (NiceValue.Cons sh0) (NiceValue.Cons sh1) = + fmap NiceValue.Cons $ Trav.sequence $ FixedLength.zipWith A.min sh0 sh1 + sizeOffset sh = + -- would a joint implementation be more efficient? + liftM2 (,) (Shape.size sh) (return $ offsetCode sh) + iterator = iterator + loop = loop + + +offsetCode :: + (Unary.Natural rank) => + NiceValue.T (Shape rank) -> NiceValue.T (Index rank) -> + LLVM.CodeGenFunction r (LLVM.Value Shape.Size) +offsetCode (NiceValue.Cons sh) (NiceValue.Cons ix) = + Fold.foldlM (\off (s,i) -> A.mul off s >>= A.add i) A.zero $ + FixedLength.zipWith (,) sh ix + + +newtype Iterator r rank = + Iterator { + runIterator :: + NiceValue.T (Shape rank) -> Iter.T r (NiceValue.T (Index rank)) + } + +iterator :: + (Unary.Natural rank) => + NiceValue.T (Shape rank) -> Iter.T r (NiceValue.T (Index rank)) +iterator = + runIterator $ + Unary.switchNat + (Iterator $ \ _z -> Iter.singleton z) + (Iterator $ switchR $ \sh n -> + fmap (\(ix,i) -> ix#:.i) $ + Iter.cartesian + (iterator sh) + (IterNV.takeWhile (NiceValue.cmp LLVM.CmpGT n) $ + Iter.iterate NiceValue.inc NiceValue.zero)) + + +newtype Loop r state rank = + Loop { + runLoop :: + (NiceValue.T (Index rank) -> + state -> + LLVM.CodeGenFunction r state) -> + NiceValue.T (Shape rank) -> + state -> + LLVM.CodeGenFunction r state + } + +loop :: + (Unary.Natural rank, Tuple.Phi state) => + (NiceValue.T (Index rank) -> + state -> + LLVM.CodeGenFunction r state) -> + NiceValue.T (Shape rank) -> + state -> + LLVM.CodeGenFunction r state +loop = + runLoop $ + Unary.switchNat + (Loop $ \code _z -> code z) + (Loop $ \code -> switchR $ \sh (NiceValue.Cons n) -> + loop + (\ix ptrStart -> + fmap fst $ + C.fixedLengthLoop n (ptrStart, A.zero) $ \(ptr, k) -> + liftM2 (,) + (code (ix #:. NiceValue.Cons k) ptr) + (A.inc k)) + sh) diff --git a/src/Data/Array/Knead/Shape/Cubic/Int.hs b/src/Data/Array/Knead/Shape/Cubic/Int.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Shape/Cubic/Int.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.Array.Knead.Shape.Cubic.Int ( + Single(..), + Int(Int), cons, decons, + ) where + +import qualified Data.Array.Knead.Expression as Expr + +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import Data.Word (Word) + +import Prelude hiding (Int, head, tail, ) + + +newtype Int = Int Word + +cons :: (Expr.Value val) => val Word -> val Int +cons = Expr.lift1 $ \(NiceValue.Cons x) -> NiceValue.Cons x + +decons :: (Expr.Value val) => val Int -> val Word +decons = Expr.lift1 $ \(NiceValue.Cons x) -> NiceValue.Cons x + + +class Single ix where + switchSingle :: f Int -> f ix + +instance Single Int where + switchSingle x = x + + +instance NiceValue.C Int where + type Repr Int = LLVM.Value Word + cons (Int x) = NiceValue.consPrimitive x + undef = NiceValue.undefPrimitive + zero = NiceValue.zeroPrimitive + phi = NiceValue.phiPrimitive + addPhi = NiceValue.addPhiPrimitive + +instance NiceValue.Additive Int where + add = NiceValue.liftM2 A.add + sub = NiceValue.liftM2 A.sub + neg = NiceValue.liftM A.neg + +instance NiceValue.PseudoRing Int where + mul = NiceValue.liftM2 A.mul + +instance NiceValue.Real Int where + min = NiceValue.liftM2 A.min + max = NiceValue.liftM2 A.max + abs = NiceValue.liftM A.abs + signum = NiceValue.liftM A.signum + +instance NiceValue.IntegerConstant Int where + fromInteger' = cons . A.fromInteger' + +instance NiceValue.Comparison Int where + cmp mode = NiceValue.liftM2 $ A.cmp mode + + +instance Marshal.C Int where + pack (Int i) = i + unpack = Int diff --git a/src/Data/Array/Knead/Shape/Orphan.hs b/src/Data/Array/Knead/Shape/Orphan.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Shape/Orphan.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Array.Knead.Shape.Orphan where + +import qualified Data.Array.Knead.Expression as Expr + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape + (ZeroBased(ZeroBased), Range(Range), Shifted(Shifted), + Cyclic(Cyclic), + Enumeration(Enumeration)) + +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Tuple as Tuple + +import qualified Control.Monad.HT as Monad +import Control.Applicative ((<$>)) + +import Prelude2010 +import Prelude () + + + +unzipZeroBased :: NiceValue.T (ZeroBased n) -> ZeroBased (NiceValue.T n) +unzipZeroBased (NiceValue.Cons (ZeroBased n)) = ZeroBased (NiceValue.Cons n) + +zeroBasedSize :: (Expr.Value val) => val (ZeroBased n) -> val n +zeroBasedSize = Expr.lift1 $ Shape.zeroBasedSize . unzipZeroBased + +zeroBased :: (Expr.Value val) => val n -> val (ZeroBased n) +zeroBased = Expr.lift1 $ \(NiceValue.Cons n) -> NiceValue.Cons (ZeroBased n) + +instance (Tuple.Undefined n) => Tuple.Undefined (ZeroBased n) where + undef = ZeroBased Tuple.undef + +instance (Tuple.Phi n) => Tuple.Phi (ZeroBased n) where + phi bb = fmap ZeroBased . Tuple.phi bb . Shape.zeroBasedSize + addPhi bb (Shape.ZeroBased a) (Shape.ZeroBased b) = Tuple.addPhi bb a b + +instance (Tuple.Value n) => Tuple.Value (ZeroBased n) where + type ValueOf (ZeroBased n) = ZeroBased (Tuple.ValueOf n) + valueOf (ZeroBased n) = ZeroBased $ Tuple.valueOf n + +instance (NiceValue.C n) => NiceValue.C (ZeroBased n) where + type Repr (ZeroBased n) = ZeroBased (NiceValue.Repr n) + cons (ZeroBased n) = zeroBased (NiceValue.cons n) + undef = zeroBased NiceValue.undef + zero = zeroBased NiceValue.zero + phi bb = Monad.lift zeroBased . NiceValue.phi bb . zeroBasedSize + addPhi bb a b = NiceValue.addPhi bb (zeroBasedSize a) (zeroBasedSize b) + +type instance + NiceValue.Decomposed f (ZeroBased pn) = + ZeroBased (NiceValue.Decomposed f pn) +type instance + NiceValue.PatternTuple (ZeroBased pn) = + ZeroBased (NiceValue.PatternTuple pn) + +instance (NiceValue.Compose n) => NiceValue.Compose (ZeroBased n) where + type Composed (ZeroBased n) = ZeroBased (NiceValue.Composed n) + compose (ZeroBased n) = zeroBased (NiceValue.compose n) + +instance (NiceValue.Decompose pn) => NiceValue.Decompose (ZeroBased pn) where + decompose (ZeroBased p) sh = + NiceValue.decompose p <$> unzipZeroBased sh + +instance (Expr.Compose n) => Expr.Compose (ZeroBased n) where + type Composed (ZeroBased n) = ZeroBased (Expr.Composed n) + compose (ZeroBased n) = Expr.lift1 zeroBased (Expr.compose n) + +instance (Expr.Decompose pn) => Expr.Decompose (ZeroBased pn) where + decompose (ZeroBased p) = ZeroBased . Expr.decompose p . zeroBasedSize + +instance (Memory.C n) => Memory.C (ZeroBased n) where + type Struct (ZeroBased n) = Memory.Struct n + compose = Memory.compose . Shape.zeroBasedSize + decompose = fmap ZeroBased . Memory.decompose + +instance (Marshal.C n) => Marshal.C (ZeroBased n) where + pack = Marshal.pack . Shape.zeroBasedSize + unpack = Shape.ZeroBased . Marshal.unpack + + + +singletonRange :: n -> Range n +singletonRange n = Range n n + +unzipRange :: NiceValue.T (Range n) -> Range (NiceValue.T n) +unzipRange (NiceValue.Cons (Range from to)) = + Range (NiceValue.Cons from) (NiceValue.Cons to) + +zipRange :: NiceValue.T n -> NiceValue.T n -> NiceValue.T (Range n) +zipRange (NiceValue.Cons from) (NiceValue.Cons to) = + NiceValue.Cons (Range from to) + +instance (Tuple.Undefined n) => Tuple.Undefined (Range n) where + undef = Range Tuple.undef Tuple.undef + +instance (Tuple.Value n) => Tuple.Value (Range n) where + type ValueOf (Range n) = Range (Tuple.ValueOf n) + valueOf (Range from to) = Range (Tuple.valueOf from) (Tuple.valueOf to) + +instance (NiceValue.C n) => NiceValue.C (Range n) where + type Repr (Range n) = Range (NiceValue.Repr n) + cons (Range from to) = zipRange (NiceValue.cons from) (NiceValue.cons to) + undef = NiceValue.compose $ singletonRange NiceValue.undef + zero = NiceValue.compose $ singletonRange NiceValue.zero + phi bb a = + case unzipRange a of + Range a0 a1 -> + Monad.lift2 zipRange (NiceValue.phi bb a0) (NiceValue.phi bb a1) + addPhi bb a b = + case (unzipRange a, unzipRange b) of + (Range a0 a1, Range b0 b1) -> + NiceValue.addPhi bb a0 b0 >> + NiceValue.addPhi bb a1 b1 + +type instance + NiceValue.Decomposed f (Range pn) = Range (NiceValue.Decomposed f pn) +type instance + NiceValue.PatternTuple (Range pn) = Range (NiceValue.PatternTuple pn) + +instance (NiceValue.Compose n) => NiceValue.Compose (Range n) where + type Composed (Range n) = Range (NiceValue.Composed n) + compose (Range from to) = + zipRange (NiceValue.compose from) (NiceValue.compose to) + +instance (NiceValue.Decompose pn) => NiceValue.Decompose (Range pn) where + decompose (Range pfrom pto) rng = + case unzipRange rng of + Range from to -> + Range + (NiceValue.decompose pfrom from) + (NiceValue.decompose pto to) + + + +singletonShifted :: n -> Shifted n +singletonShifted n = Shifted n n + +unzipShifted :: NiceValue.T (Shifted n) -> Shifted (NiceValue.T n) +unzipShifted (NiceValue.Cons (Shifted from to)) = + Shifted (NiceValue.Cons from) (NiceValue.Cons to) + +zipShifted :: NiceValue.T n -> NiceValue.T n -> NiceValue.T (Shifted n) +zipShifted (NiceValue.Cons from) (NiceValue.Cons to) = + NiceValue.Cons (Shifted from to) + +instance (Tuple.Undefined n) => Tuple.Undefined (Shifted n) where + undef = Shifted Tuple.undef Tuple.undef + +instance (Tuple.Value n) => Tuple.Value (Shifted n) where + type ValueOf (Shifted n) = Shifted (Tuple.ValueOf n) + valueOf (Shifted start len) = + Shifted (Tuple.valueOf start) (Tuple.valueOf len) + +instance (NiceValue.C n) => NiceValue.C (Shifted n) where + type Repr (Shifted n) = Shifted (NiceValue.Repr n) + cons (Shifted start len) = + zipShifted (NiceValue.cons start) (NiceValue.cons len) + undef = NiceValue.compose $ singletonShifted NiceValue.undef + zero = NiceValue.compose $ singletonShifted NiceValue.zero + phi bb a = + case unzipShifted a of + Shifted a0 a1 -> + Monad.lift2 zipShifted + (NiceValue.phi bb a0) (NiceValue.phi bb a1) + addPhi bb a b = + case (unzipShifted a, unzipShifted b) of + (Shifted a0 a1, Shifted b0 b1) -> + NiceValue.addPhi bb a0 b0 >> + NiceValue.addPhi bb a1 b1 + +type instance + NiceValue.Decomposed f (Shifted pn) = + Shifted (NiceValue.Decomposed f pn) +type instance + NiceValue.PatternTuple (Shifted pn) = + Shifted (NiceValue.PatternTuple pn) + +instance (NiceValue.Compose n) => NiceValue.Compose (Shifted n) where + type Composed (Shifted n) = Shifted (NiceValue.Composed n) + compose (Shifted start len) = + zipShifted (NiceValue.compose start) (NiceValue.compose len) + +instance (NiceValue.Decompose pn) => NiceValue.Decompose (Shifted pn) where + decompose (Shifted pstart plen) rng = + case unzipShifted rng of + Shifted start len -> + Shifted + (NiceValue.decompose pstart start) + (NiceValue.decompose plen len) + + + +unzipCyclic :: NiceValue.T (Cyclic n) -> Cyclic (NiceValue.T n) +unzipCyclic (NiceValue.Cons (Cyclic n)) = Cyclic (NiceValue.Cons n) + +cyclicSize :: (Expr.Value val) => val (Cyclic n) -> val n +cyclicSize = Expr.lift1 $ Shape.cyclicSize . unzipCyclic + +cyclic :: (Expr.Value val) => val n -> val (Cyclic n) +cyclic = Expr.lift1 $ \(NiceValue.Cons n) -> NiceValue.Cons (Cyclic n) + +instance (Tuple.Undefined n) => Tuple.Undefined (Cyclic n) where + undef = Cyclic Tuple.undef + +instance (Tuple.Phi n) => Tuple.Phi (Cyclic n) where + phi bb = fmap Cyclic . Tuple.phi bb . Shape.cyclicSize + addPhi bb (Shape.Cyclic a) (Shape.Cyclic b) = Tuple.addPhi bb a b + +instance (Tuple.Value n) => Tuple.Value (Cyclic n) where + type ValueOf (Cyclic n) = Cyclic (Tuple.ValueOf n) + valueOf (Cyclic n) = Cyclic $ Tuple.valueOf n + +instance (NiceValue.C n) => NiceValue.C (Cyclic n) where + type Repr (Cyclic n) = Cyclic (NiceValue.Repr n) + cons (Cyclic n) = cyclic (NiceValue.cons n) + undef = cyclic NiceValue.undef + zero = cyclic NiceValue.zero + phi bb = Monad.lift cyclic . NiceValue.phi bb . cyclicSize + addPhi bb a b = NiceValue.addPhi bb (cyclicSize a) (cyclicSize b) + +type instance + NiceValue.Decomposed f (Cyclic pn) = Cyclic (NiceValue.Decomposed f pn) +type instance + NiceValue.PatternTuple (Cyclic pn) = Cyclic (NiceValue.PatternTuple pn) + +instance (NiceValue.Compose n) => NiceValue.Compose (Cyclic n) where + type Composed (Cyclic n) = Cyclic (NiceValue.Composed n) + compose (Cyclic n) = cyclic (NiceValue.compose n) + +instance (NiceValue.Decompose pn) => NiceValue.Decompose (Cyclic pn) where + decompose (Cyclic p) sh = NiceValue.decompose p <$> unzipCyclic sh + +instance (Expr.Compose n) => Expr.Compose (Cyclic n) where + type Composed (Cyclic n) = Cyclic (Expr.Composed n) + compose (Cyclic n) = Expr.lift1 cyclic (Expr.compose n) + +instance (Expr.Decompose pn) => Expr.Decompose (Cyclic pn) where + decompose (Cyclic p) = Cyclic . Expr.decompose p . cyclicSize + +instance (Memory.C n) => Memory.C (Cyclic n) where + type Struct (Cyclic n) = Memory.Struct n + compose = Memory.compose . Shape.cyclicSize + decompose = fmap Cyclic . Memory.decompose + +instance (Marshal.C n) => Marshal.C (Cyclic n) where + pack = Marshal.pack . Shape.cyclicSize + unpack = Shape.Cyclic . Marshal.unpack + + + +instance (Enum enum, Bounded enum) => NiceValue.C (Enumeration enum) where + type Repr (Enumeration enum) = () + cons = NiceValue.consUnit + undef = NiceValue.undefUnit + zero = NiceValue.zeroUnit + phi = NiceValue.phiUnit + addPhi = NiceValue.addPhiUnit + +type instance NiceValue.Decomposed f (Enumeration enum) = Enumeration enum +type instance NiceValue.PatternTuple (Enumeration enum) = Enumeration enum + +instance + (Enum enum, Bounded enum) => NiceValue.Compose (Enumeration enum) where + type Composed (Enumeration enum) = Enumeration enum + compose = NiceValue.cons + +instance NiceValue.Decompose (Enumeration enum) where + decompose Enumeration _ = Enumeration + + +instance (Enum enum, Bounded enum) => Expr.Compose (Enumeration enum) where + type Composed (Enumeration enum) = Enumeration enum + compose = Expr.cons + +instance Expr.Decompose (Enumeration enum) where + decompose Enumeration _ = Enumeration diff --git a/src/Data/Array/Knead/Simple/Fold.hs b/src/Data/Array/Knead/Simple/Fold.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/Fold.hs +++ /dev/null @@ -1,94 +0,0 @@ -{- | -Reduce selected dimensions. -Alternatively you may reorder dimensions with 'ShapeDep.backpermute' -and fold once along multiple dimensions. --} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Data.Array.Knead.Simple.Fold ( - T, - Linear, - apply, - passAny, - pass, - fold, - (Core.$:.), - ) where - -import qualified Data.Array.Knead.Simple.Private as Core -import Data.Array.Knead.Simple.Private (Array(Array), Code, Val, ) - -import qualified Data.Array.Knead.Index.Linear as Linear -import qualified Data.Array.Knead.Index.Linear.Int as IndexInt -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, unExp, ) -import Data.Array.Knead.Index.Linear ((#:.), (:.)((:.)), ) - -import qualified LLVM.Extra.Multi.Value as MultiValue -import LLVM.Extra.Multi.Value (atom, ) - -import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, ) - - -data T sh0 sh1 a = - forall ix0 ix1. - (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) => - Cons - (Exp sh0 -> Exp sh1) - (forall r. Val sh0 -> (Val ix0 -> Code r a) -> (Val ix1 -> Code r a)) - - -apply :: - (Core.C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) => - T sh0 sh1 a -> - array sh0 a -> - array sh1 a -apply (Cons fsh reduce) = - Core.lift1 $ \(Array sh code) -> - Array (fsh sh) (\ix -> do sh0 <- unExp sh; reduce sh0 code ix) - - -type Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1) - -passAny :: Linear sh sh a -passAny = Cons id (const id) - -pass :: - Linear sh0 sh1 a -> - Linear (sh0:.i) (sh1:.i) a -pass (Cons fsh reduce) = - Cons - (Expr.modify (Linear.shape (atom:.atom)) $ \(sh:.s) -> fsh sh :. s) - (\sh code -> - Linear.switchR $ \jx j -> - reduce (Linear.tail sh) (\kx -> code (kx #:. j)) jx) - - -fold1CodeLinear :: - (MultiValue.C a) => - (Exp a -> Exp a -> Exp a) -> - Exp IndexInt.Int -> - (Val (Linear.Index (sh :. IndexInt.Int)) -> Code r a) -> - (Val (Linear.Index sh) -> Code r a) -fold1CodeLinear f nc code ix = - Core.fold1Code f (IndexInt.decons nc) - (\jx j -> code (jx #:. IndexInt.cons j)) - ix - -fold :: - (MultiValue.C a) => - (Exp a -> Exp a -> Exp a) -> - Linear sh0 sh1 a -> - Linear (sh0:.IndexInt.Int) sh1 a -fold f (Cons fsh reduce) = - Cons - (fsh . Linear.tail) - (\sh code jx -> - reduce (Linear.tail sh) - (fold1CodeLinear f (Expr.lift0 (Linear.head sh)) code) jx) - - -instance Core.Process (T sh0 sh1 a) where diff --git a/src/Data/Array/Knead/Simple/Physical.hs b/src/Data/Array/Knead/Simple/Physical.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/Physical.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module Data.Array.Knead.Simple.Physical ( - Array(Array, shape, buffer), -- data constructor intended for PhysicalParameterized - toList, - fromList, - vectorFromList, - with, - render, - scanl1, - mapAccumL, - scatter, - scatterMaybe, - permute, - ) where - -import qualified Data.Array.Knead.Simple.PhysicalPrivate as Priv -import qualified Data.Array.Knead.Simple.Private as Sym -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import qualified Data.Array.Knead.Code as Code -import Data.Array.Knead.Expression (Exp, unExp, ) -import Data.Array.Knead.Code (getElementPtr, compile, ) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Maybe as Maybe - -import qualified LLVM.Core as LLVM - -import Foreign.Marshal.Array (pokeArray, peekArray, ) -import Foreign.Marshal.Alloc (alloca, ) -import Foreign.Storable (Storable, peek, ) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, ) -import Foreign.Ptr (FunPtr, Ptr, ) - -import Control.Monad.HT (void, ) -import Control.Applicative (liftA2, (<$>), ) -import Data.Word (Word32, ) - -import Prelude hiding (scanl1, ) - - -data Array sh a = - Array { - shape :: sh, - buffer :: ForeignPtr a - } - - -toList :: - (Shape.C sh, Storable a) => - Array sh a -> IO [a] -toList (Array sh fptr) = - withForeignPtr fptr $ peekArray (Shape.size sh) - -fromList :: - (Shape.C sh, Storable a) => - sh -> [a] -> IO (Array sh a) -fromList sh xs = do - let size = Shape.size sh - fptr <- mallocForeignPtrArray size - withForeignPtr fptr $ - \ptr -> - pokeArray ptr $ - take size $ - xs ++ repeat (error "Array.Knead.Physical.fromList: list too short for shape") - return (Array sh fptr) - -vectorFromList :: - (Shape.C sh, Num sh, Storable a) => - [a] -> IO (Array sh a) -vectorFromList xs = do - let size = length xs - fptr <- mallocForeignPtrArray size - withForeignPtr fptr $ flip pokeArray xs - return (Array (fromIntegral size) fptr) - - -{- | -The symbolic array is only valid inside the enclosed action. --} -with :: - (Shape.C sh, MultiValueMemory.C a) => - (Sym.Array sh a -> IO b) -> - Array sh a -> IO b -with f (Array sh fptr) = - withForeignPtr fptr $ \ptr -> - f $ - Sym.Array - (Shape.value sh) - (\ix -> - Memory.load =<< - getElementPtr (Shape.value sh) - (LLVM.valueOf (MultiValueMemory.castStructPtr ptr)) ix) - - -type Importer f = FunPtr f -> f - -foreign import ccall safe "dynamic" callShaper :: - Importer (Ptr sh -> IO Word32) - -foreign import ccall safe "dynamic" callRenderer :: - Importer (Ptr sh -> Ptr am -> IO ()) - - -materialize :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a, MultiValueMemory.Struct a ~ am) => - String -> - Exp sh -> - (LLVM.Value (Ptr (MultiValueMemory.Struct sh)) -> - LLVM.Value (Ptr am) -> LLVM.CodeGenFunction () ()) -> - IO (Array sh a) -materialize name esh code = - alloca $ \shptr -> do - (fsh, farr) <- - compile name $ - liftA2 (,) - (Code.createFunction callShaper "shape" $ \ptr -> do - sh <- unExp esh - MultiValueMemory.store sh ptr - Shape.sizeCode sh >>= LLVM.ret) - (Code.createFunction callRenderer "fill" - (\paramPtr arrayPtr -> code paramPtr arrayPtr >> LLVM.ret ())) - let lshptr = MultiValueMemory.castStructPtr shptr - n <- fsh lshptr - fptr <- mallocForeignPtrArray (fromIntegral n) - withForeignPtr fptr $ farr lshptr . MultiValueMemory.castStructPtr - sh <- peek shptr - return (Array sh fptr) - -render :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - Sym.Array sh a -> IO (Array sh a) -render (Sym.Array esh code) = - materialize "render" esh $ \sptr ptr -> do - let step ix p = do - flip Memory.store p =<< code ix - A.advanceArrayElementPtr p - sh <- Shape.load esh sptr - void $ Shape.loop step sh ptr - -scanl1 :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array (sh, Word32) a -> IO (Array (sh, Word32) a) -scanl1 = scanl1Gen - -scanl1Gen :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array (sh, n) a -> IO (Array (sh, n) a) -scanl1Gen f (Sym.Array esh code) = - materialize "scanl1" esh $ \sptr ptr -> do - (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr - let step ix ptrStart = - fmap fst $ - (\body -> Shape.loop body n (ptrStart, Maybe.nothing)) $ - \k0 (ptr0, macc0) -> do - a <- code $ MultiValue.zip ix k0 - acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a) - Memory.store acc1 ptr0 - ptr1 <- A.advanceArrayElementPtr ptr0 - return (ptr1, Maybe.just acc1) - void $ Shape.loop step sh ptr - -mapAccumL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - MultiValue.C acc, - Storable x, MultiValueMemory.C x, - Storable y, MultiValueMemory.C y) => - (Exp acc -> Exp x -> Exp (acc,y)) -> - Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y) -mapAccumL f arrInit arrData = - materialize "mapAccumL" (Sym.shape arrData) $ - Priv.mapAccumL f arrInit arrData - -scatterMaybe :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array sh1 a -> - Sym.Array sh0 (Maybe (ix1, a)) -> IO (Array sh1 a) -scatterMaybe accum arrInit arrMap = - materialize "scatterMaybe" (Sym.shape arrInit) $ - Priv.scatterMaybe accum arrInit arrMap - -scatter :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array sh1 a -> - Sym.Array sh0 (ix1, a) -> IO (Array sh1 a) -scatter accum arrInit arrMap = - materialize "scatter" (Sym.shape arrInit) $ - Priv.scatter accum arrInit arrMap - -permute :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array sh1 a -> - (Exp ix0 -> Exp ix1) -> - Sym.Array sh0 a -> - IO (Array sh1 a) -permute accum deflt ixmap input = - scatter accum deflt - (Sym.mapWithIndex (Expr.lift2 MultiValue.zip . ixmap) input) diff --git a/src/Data/Array/Knead/Simple/PhysicalPrivate.hs b/src/Data/Array/Knead/Simple/PhysicalPrivate.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/PhysicalPrivate.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Data.Array.Knead.Simple.PhysicalPrivate where - -import qualified Data.Array.Knead.Simple.Private as Sym -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, unExp) -import Data.Array.Knead.Code (getElementPtr) - -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMemory -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Control as C -import qualified LLVM.Extra.Memory as Memory - -import qualified LLVM.Core as LLVM - -import Foreign.Storable (Storable, ) -import Foreign.Ptr (Ptr, ) - -import Control.Monad.HT (void, ) -import Control.Applicative ((<$>), ) - -import Data.Tuple.HT (mapSnd, ) - - - -mapAccumL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - MultiValue.C acc, - Storable x, MultiValueMemory.C x, - Storable y, MultiValueMemory.C y) => - (Exp acc -> Exp x -> Exp (acc,y)) -> - Sym.Array sh acc -> Sym.Array (sh, n) x -> - LLVM.Value (Ptr (MultiValueMemory.Struct (sh,n))) -> - LLVM.Value (Ptr (MultiValueMemory.Struct y)) -> - LLVM.CodeGenFunction r () -mapAccumL f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do - (sh, n) <- MultiValue.unzip <$> Shape.load esh sptr - let step ix ptrStart = do - accInit <- initCode ix - fmap fst $ - (\body -> Shape.loop body n (ptrStart, accInit)) $ - \k0 (ptr0, acc0) -> do - x <- code $ MultiValue.zip ix k0 - (acc1,y) <- MultiValue.unzip <$> Expr.unliftM2 f acc0 x - Memory.store y ptr0 - ptr1 <- A.advanceArrayElementPtr ptr0 - return (ptr1, acc1) - void $ Shape.loop step sh ptr - -foldOuterL :: - (Shape.C sh, Storable sh, MultiValueMemory.C sh, - Shape.C n, Storable n, MultiValueMemory.C n, - MultiValueMemory.C a) => - (Exp a -> Exp b -> Exp a) -> - Sym.Array sh a -> Sym.Array (n,sh) b -> - LLVM.Value (Ptr (MultiValueMemory.Struct sh)) -> - LLVM.Value (Ptr (MultiValueMemory.Struct a)) -> - LLVM.CodeGenFunction r () -foldOuterL f (Sym.Array _ initCode) (Sym.Array esh code) _sptr ptr = do - -- (n,sh) <- MultiValue.unzip <$> Shape.load esh sptr - (n,sh) <- MultiValue.unzip <$> unExp esh - let fillInit ix ptr0 = do - a <- initCode ix - Memory.store a ptr0 - A.advanceArrayElementPtr ptr0 - void $ Shape.loop fillInit sh ptr - - let step k ix ptr0 = do - b <- code $ MultiValue.zip k ix - a0 <- Memory.load ptr0 - a1 <- Expr.unliftM2 f a0 b - Memory.store a1 ptr0 - A.advanceArrayElementPtr ptr0 - void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n () - -scatterMaybe :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array sh1 a -> Sym.Array sh0 (Maybe (ix1, a)) -> - LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) -> - LLVM.Value (Ptr (MultiValueMemory.Struct a)) -> - LLVM.CodeGenFunction r () -scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) - sptr ptr = do - - let clear ix p = do - flip Memory.store p =<< codeInit ix - A.advanceArrayElementPtr p - sh <- Shape.load esh sptr - void $ Shape.loop clear sh ptr - - ish <- unExp eish - let fill ix () = do - (MultiValue.Cons c, (jx, a)) <- - mapSnd MultiValue.unzip . MultiValue.splitMaybe <$> codeMap ix - C.ifThen c () $ do - p <- getElementPtr sh ptr jx - flip Memory.store p - =<< Expr.unliftM2 (flip accum) a - =<< Memory.load p - Shape.loop fill ish () - -scatter :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Storable sh1, MultiValueMemory.C sh1, - Storable a, MultiValueMemory.C a) => - (Exp a -> Exp a -> Exp a) -> - Sym.Array sh1 a -> - Sym.Array sh0 (Shape.Index sh1, a) -> - LLVM.Value (Ptr (MultiValueMemory.Struct sh1)) -> - LLVM.Value (Ptr (MultiValueMemory.Struct a)) -> - LLVM.CodeGenFunction r () -scatter accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) sptr ptr = do - let clear ix p = do - flip Memory.store p =<< codeInit ix - A.advanceArrayElementPtr p - sh <- Shape.load esh sptr - void $ Shape.loop clear sh ptr - - ish <- unExp eish - let fill ix () = do - (jx, a) <- fmap MultiValue.unzip $ codeMap ix - p <- getElementPtr sh ptr jx - flip Memory.store p - =<< Expr.unliftM2 (flip accum) a - =<< Memory.load p - Shape.loop fill ish () diff --git a/src/Data/Array/Knead/Simple/Private.hs b/src/Data/Array/Knead/Simple/Private.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/Private.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Array.Knead.Simple.Private where - -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp(Exp), ) - -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Monad as Monad -import qualified LLVM.Extra.Maybe as Maybe -import qualified LLVM.Extra.Control as C -import qualified LLVM.Core as LLVM - -import qualified Control.Category as Cat -import Control.Monad ((<=<), ) - -import Prelude hiding (id, map, zipWith, replicate, ) - - -type Val = MultiValue.T -type Code r a = LLVM.CodeGenFunction r (Val a) - -data Array sh a = - Array (Exp sh) (forall r. Val (Shape.Index sh) -> Code r a) - -shape :: Array sh a -> Exp sh -shape (Array sh _) = sh - -(!) :: - (Shape.C sh, Shape.Index sh ~ ix) => - Array sh a -> Exp ix -> Exp a -(!) (Array _ code) (Exp ix) = Exp (code =<< ix) - -the :: (Shape.Scalar sh) => Array sh a -> Exp a -the (Array z code) = Exp (code $ Shape.zeroIndex z) - -fromScalar :: (Shape.Scalar sh) => Exp a -> Array sh a -fromScalar = fill Shape.scalar - - -fill :: Exp sh -> Exp a -> Array sh a -fill sh (Exp code) = Array sh (\_z -> code) - - -{- | -This class allows to implement functions without parameters -for both simple and parameterized arrays. --} -class C array where - lift0 :: Array sh a -> array sh a - lift1 :: (Array sha a -> Array shb b) -> array sha a -> array shb b - lift2 :: - (Array sha a -> Array shb b -> Array shc c) -> - array sha a -> array shb b -> array shc c - -instance C Array where - lift0 = Cat.id - lift1 = Cat.id - lift2 = Cat.id - - -gather :: - (C array, - Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - MultiValue.C a) => - array sh1 ix0 -> - array sh0 a -> - array sh1 a -gather = - lift2 $ \(Array sh1 f) (Array _sh0 code) -> - Array sh1 (code <=< f) - -backpermute2 :: - (C array, - Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Shape.C sh, Shape.Index sh ~ ix) => - Exp sh -> - (Exp ix -> Exp ix0) -> - (Exp ix -> Exp ix1) -> - (Exp a -> Exp b -> Exp c) -> - array sh0 a -> array sh1 b -> array sh c -backpermute2 sh projectIndex0 projectIndex1 f = - lift2 $ \(Array _sha codeA) (Array _shb codeB) -> - Array sh - (\ix -> - Monad.liftR2 (Expr.unliftM2 f) - (codeA =<< Expr.unliftM1 projectIndex0 ix) - (codeB =<< Expr.unliftM1 projectIndex1 ix)) - - -id :: - (Shape.C sh, Shape.Index sh ~ ix) => - Exp sh -> Array sh ix -id sh = Array sh return - -map :: - (C array, Shape.C sh) => - (Exp a -> Exp b) -> - array sh a -> array sh b -map f = - lift1 $ \(Array sh code) -> - Array sh (Expr.unliftM1 f <=< code) - -mapWithIndex :: - (C array, Shape.C sh, Shape.Index sh ~ ix) => - (Exp ix -> Exp a -> Exp b) -> - array sh a -> array sh b -mapWithIndex f = - lift1 $ \(Array sh code) -> - Array sh (\ix -> Expr.unliftM2 f ix =<< code ix) - - -fold1Code :: - (Shape.C sh1, Shape.Index sh1 ~ ix1, MultiValue.C a) => - (Exp a -> Exp a -> Exp a) -> - Exp sh1 -> - (Val ix0 -> Val ix1 -> Code r a) -> - (Val ix0 -> Code r a) -fold1Code f (Exp nc) code ix = do - n <- nc - fmap Maybe.fromJust $ - Shape.loop - (\i0 macc0 -> do - a <- code ix i0 - acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a) - return $ Maybe.just acc1) - n Maybe.nothing - -fold1 :: - (C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) => - (Exp a -> Exp a -> Exp a) -> - array (sh0, sh1) a -> array sh0 a -fold1 f = - lift1 $ \(Array shs code) -> - case Expr.unzip shs of - (sh, s) -> Array sh $ fold1Code f s $ MultiValue.curry code - - -fold1All :: - (Shape.C sh, MultiValue.C a) => - (Exp a -> Exp a -> Exp a) -> - Array sh a -> Array () a -fold1All f (Array esh code) = - fold1 f $ - Array - (Expr.lift1 (MultiValue.zip (MultiValue.Cons ())) esh) - (code . MultiValue.snd) - - -{- -'Shape.loop' does not support an early exit. -I wished the LLVM optimizer would rewrite the loop accordingly. -Unfortunately, it does not. --} -findAllCode :: - (Shape.C sh, Shape.Index sh ~ ix, MultiValue.C a) => - (Exp a -> Exp Bool) -> - Exp sh -> - (Val ix -> Code r a) -> - Code r (Maybe a) -findAllCode p (Exp sh) code = do - n <- sh - finalFound <- - Shape.loop - (\i found -> - C.ifThenElse (Maybe.isJust found) - (return found) - (do - a <- code i - MultiValue.Cons b <- Expr.unliftM1 p a - return $ Maybe.fromBool b a)) - n Maybe.nothing - Maybe.run finalFound - (return MultiValue.nothing) - (return . MultiValue.just) - -{- | -In principle this can be implemented using fold1All -but this one should have short-cut semantics. -Currently it has not! :-( -@All@ means that it scans all dimensions -but it does not mean that it finds all occurrences. -If you want to get the index of the found element, -please decorate the array elements with their indices before calling 'findAll'. --} -findAll :: - (Shape.C sh, MultiValue.C a) => - (Exp a -> Exp Bool) -> - Array sh a -> Exp (Maybe a) -findAll p (Array sh code) = Exp (findAllCode p sh code) - - -class Process proc where - - -infixl 3 $:. - -{- | -Use this for combining several dimension manipulators. -E.g. - -> apply (passAny $:. pick 3 $:. pass $:. replicate 10) array - -The constraint @(Process proc0, Process proc1)@ is a bit weak. -We like to enforce that the type constructor like @Slice.T@ -is the same in @proc0@ and @proc1@, and only the parameters differ. -Currently this coherence is achieved, -because we only provide functions of type @proc0 -> proc1@ with this condition. --} -($:.) :: (Process proc0, Process proc1) => proc0 -> (proc0 -> proc1) -> proc1 -($:.) = flip ($) diff --git a/src/Data/Array/Knead/Simple/ShapeDependent.hs b/src/Data/Array/Knead/Simple/ShapeDependent.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/ShapeDependent.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Data.Array.Knead.Simple.ShapeDependent where - -import qualified Data.Array.Knead.Simple.Private as Core -import Data.Array.Knead.Simple.Private (Array(Array), ) - -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Monad as Monad - -import Control.Monad ((<=<), ) - - -shape :: (Core.C array, Shape.C sh, Shape.Scalar z) => array sh a -> array z sh -shape = Core.lift1 $ Core.fromScalar . Core.shape - -backpermute :: - (Core.C array, - Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1) => - (Exp sh0 -> Exp sh1) -> - (Exp ix1 -> Exp ix0) -> - array sh0 a -> - array sh1 a -backpermute createShape projectIndex = - Core.lift1 $ \(Array sh code) -> - Array (createShape sh) - (code <=< Expr.unliftM1 projectIndex) - -{- | -This is between 'backpermute' and 'backpermute2'. -You can access the shapes of two arrays, -but only the content of one of them. -This is necessary if the second array contributes only a virtual dimension. --} -backpermuteExtra :: - (Core.C array, - Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Shape.C sh, Shape.Index sh ~ ix) => - (Exp sh0 -> Exp sh1 -> Exp sh) -> - (Exp ix -> Exp ix0) -> - array sh0 a -> array sh1 b -> array sh a -backpermuteExtra newShape projectIndex = - Core.lift2 $ \(Array sh0 code) (Array sh1 _code) -> - Array (newShape sh0 sh1) - (\ix -> code =<< Expr.unliftM1 projectIndex ix) - -backpermute2 :: - (Core.C array, - Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - Shape.C sh, Shape.Index sh ~ ix) => - (Exp sh0 -> Exp sh1 -> Exp sh) -> - (Exp ix -> Exp ix0) -> - (Exp ix -> Exp ix1) -> - (Exp a -> Exp b -> Exp c) -> - array sh0 a -> array sh1 b -> array sh c -backpermute2 combineShape projectIndex0 projectIndex1 f = - Core.lift2 $ \(Array sha codeA) (Array shb codeB) -> - Array (combineShape sha shb) - (\ix -> - Monad.liftR2 (Expr.unliftM2 f) - (codeA =<< Expr.unliftM1 projectIndex0 ix) - (codeB =<< Expr.unliftM1 projectIndex1 ix)) - -fill :: - (Core.C array) => - (Exp sh0 -> Exp sh1) -> Exp b -> - array sh0 a -> array sh1 b -fill fsh a = - Core.lift1 $ \arr -> - Core.fill (fsh $ Core.shape arr) a diff --git a/src/Data/Array/Knead/Simple/Slice.hs b/src/Data/Array/Knead/Simple/Slice.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/Slice.hs +++ /dev/null @@ -1,192 +0,0 @@ -{- | -Generate and apply index maps. -This unifies the @replicate@ and @slice@ functions of the @accelerate@ package. -However the structure of slicing and replicating cannot depend on parameters. -If you need that, you must use 'ShapeDep.backpermute' and friends. --} -{- -Some notes on the design choice: - -Instead of the shallow embedding implemented by the 'T' type, -we could maintain a symbolic representation of the Slice and Replicate pattern, -like the accelerate package does. -We actually used that representation in former versions. -It has however some drawbacks: - -* We need additional type functions that map from the pattern - to the source and the target shape and we need a proof, - that the images of these type functions are actually shapes. - This worked already, but was rather cumbersome. - -* We need a way to store and pass this pattern through the Parameter handler. - This yields new problems: - We need a wrapper type for wrapping Index, Shape, Slice, Replicate, Fold patterns. - Then the question is whether we use one Wrap type with a phantom parameter - or whether we define a Wrap type for every pattern type. - That is, the options are to write either - - > Wrap Shape (Z:.Int:.Int) - - or - - > Shape (Z:.Int:.Int) - - The first one seems to save us many duplicate instances of - Storable, MultiValue etc. - and it allows us easily to reuse the (:.) for all kinds of patterns. - However, we need a way to restrict the element type of the (:.)-list elements. - We can define that using variable ConstraintKinds, - but e.g. we are not able to add a Storable superclass constraint - to the instance Storable (Wrap constr). - That is, we are left with the second option - and had to define a lot of similar Storable, MultiValue instances. --} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Data.Array.Knead.Simple.Slice ( - T, - Linear, - apply, - passAny, - pass, - pick, - pickFst, - pickSnd, - extrude, - extrudeFst, - extrudeSnd, - transpose, - (Core.$:.), - - id, - first, - second, - compose, - ) where - -import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep -import qualified Data.Array.Knead.Simple.Private as Core - -import qualified Data.Array.Knead.Index.Linear as Linear -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Index.Linear ((#:.), (:.)((:.)), ) -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value as MultiValue -import LLVM.Extra.Multi.Value (atom, ) - -import qualified Prelude as P -import Prelude hiding (id, zipWith, zipWith3, zip, zip3, replicate, ) - - - -{- -This data type is almost identical to Core.Array. -The only difference is, -that the shape @sh1@ in T can depend on another shape @sh0@. --} -data T sh0 sh1 = - forall ix0 ix1. - (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) => - Cons - (Exp sh0 -> Exp sh1) - (Exp ix1 -> Exp ix0) - -{- | -This is essentially a 'ShapeDep.backpermute'. --} -apply :: - (Core.C array, Shape.C sh0, Shape.C sh1, MultiValue.C a) => - T sh0 sh1 -> - array sh0 a -> - array sh1 a -apply (Cons fsh fix) = - ShapeDep.backpermute fsh fix - - -pickFst :: Exp (Shape.Index n) -> T (n,sh) sh -pickFst i = Cons Expr.snd (Expr.zip i) - -pickSnd :: Exp (Shape.Index n) -> T (sh,n) sh -pickSnd i = Cons Expr.fst (flip Expr.zip i) - -{- | -Extrusion has the potential to do duplicate work. -Only use it to add dimensions of size 1, e.g. numeric 1 or unit @()@ -or to duplicate slices of physical arrays. --} -extrudeFst :: Exp n -> T sh (n,sh) -extrudeFst n = Cons (Expr.zip n) Expr.snd - -extrudeSnd :: Exp n -> T sh (sh,n) -extrudeSnd n = Cons (flip Expr.zip n) Expr.fst - -transpose :: T (sh0,sh1) (sh1,sh0) -transpose = Cons Expr.swap Expr.swap - - --- Arrow combinators - -id :: T sh sh -id = Cons P.id P.id - -first :: T sh0 sh1 -> T (sh0,sh) (sh1,sh) -first (Cons fsh fix) = Cons (Expr.mapFst fsh) (Expr.mapFst fix) - -second :: T sh0 sh1 -> T (sh,sh0) (sh,sh1) -second (Cons fsh fix) = Cons (Expr.mapSnd fsh) (Expr.mapSnd fix) - -infixr 1 `compose` - -compose :: T sh0 sh1 -> T sh1 sh2 -> T sh0 sh2 -compose (Cons fshA fixA) (Cons fshB fixB) = Cons (fshB . fshA) (fixA . fixB) - - -type Linear sh0 sh1 = T (Linear.Shape sh0) (Linear.Shape sh1) - -{- | -Like @Any@ in @accelerate@. --} -passAny :: Linear sh sh -passAny = Cons P.id P.id - -{- | -Like @All@ in @accelerate@. --} -pass :: - Linear sh0 sh1 -> - Linear (sh0:.i) (sh1:.i) -pass (Cons fsh fix) = - Cons - (Expr.modify (Linear.shape (atom:.atom)) $ \(sh:.s) -> fsh sh :. s) - (Expr.modify (Linear.index (atom:.atom)) $ \(ix:.i) -> fix ix :. i) - -{- | -Like @Int@ in @accelerate/slice@. --} -pick :: - Exp i -> - Linear sh0 sh1 -> - Linear (sh0:.i) sh1 -pick i (Cons fsh fix) = - Cons - (fsh . Linear.tail) - (\ix -> fix ix #:. i) - -{- | -Like @Int@ in @accelerate/replicate@. --} -extrude :: - Exp i -> - Linear sh0 sh1 -> - Linear sh0 (sh1:.i) -extrude n (Cons fsh fix) = - Cons - (\sh -> fsh sh #:. n) - (fix . Linear.tail) - - -instance Core.Process (T sh0 sh1) where diff --git a/src/Data/Array/Knead/Simple/Symbolic.hs b/src/Data/Array/Knead/Simple/Symbolic.hs deleted file mode 100644 --- a/src/Data/Array/Knead/Simple/Symbolic.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GADTs #-} -module Data.Array.Knead.Simple.Symbolic ( - Core.Array, - Core.C(..), - Exp, - shape, - (Core.!), - Core.the, - Core.fromScalar, - Core.fill, - gather, - backpermute, - Core.backpermute2, - Core.id, - Core.map, - Core.mapWithIndex, - zipWith, - zipWith3, - zipWith4, - zip, - zip3, - zip4, - fold1, - fold1All, - Core.findAll, - ) where - -import qualified Data.Array.Knead.Simple.ShapeDependent as ShapeDep -import qualified Data.Array.Knead.Simple.Private as Core -import Data.Array.Knead.Simple.Private (Array, shape, fold1, gather, ) - -import qualified Data.Array.Knead.Index.Nested.Shape as Shape -import qualified Data.Array.Knead.Expression as Expr -import Data.Array.Knead.Expression (Exp, ) - -import qualified LLVM.Extra.Multi.Value as MultiValue - -import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, ) - - -backpermute :: - (Shape.C sh0, Shape.Index sh0 ~ ix0, - Shape.C sh1, Shape.Index sh1 ~ ix1, - MultiValue.C a) => - Exp sh1 -> - (Exp ix1 -> Exp ix0) -> - Array sh0 a -> - Array sh1 a -backpermute sh1 f = gather (Core.map f (Core.id sh1)) - -zipWith :: - (Core.C array, Shape.C sh) => - (Exp a -> Exp b -> Exp c) -> - array sh a -> array sh b -> array sh c -zipWith = ShapeDep.backpermute2 Shape.intersect id id - -zipWith3 :: - (Core.C array, Shape.C sh) => - (Exp a -> Exp b -> Exp c -> Exp d) -> - array sh a -> array sh b -> array sh c -> array sh d -zipWith3 f a b c = - zipWith (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c - -zipWith4 :: - (Core.C array, Shape.C sh) => - (Exp a -> Exp b -> Exp c -> Exp d -> Exp e) -> - array sh a -> array sh b -> array sh c -> array sh d -> array sh e -zipWith4 f a b c d = - zipWith3 (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c d - - -zip :: - (Core.C array, Shape.C sh) => - array sh a -> array sh b -> array sh (a,b) -zip = zipWith (Expr.lift2 MultiValue.zip) - -zip3 :: - (Core.C array, Shape.C sh) => - array sh a -> array sh b -> array sh c -> array sh (a,b,c) -zip3 = zipWith3 (Expr.lift3 MultiValue.zip3) - -zip4 :: - (Core.C array, Shape.C sh) => - array sh a -> array sh b -> array sh c -> array sh d -> - array sh (a,b,c,d) -zip4 = zipWith4 (Expr.lift4 MultiValue.zip4) - - -fold1All :: - (Core.C array, Shape.C sh, Shape.Scalar z, MultiValue.C a) => - (Exp a -> Exp a -> Exp a) -> - array sh a -> array z a -fold1All f = - Core.lift1 $ \arr -> - fold1 f $ - backpermute - (Expr.lift2 MultiValue.zip Shape.scalar (shape arr)) - (Expr.lift1 MultiValue.snd) - arr diff --git a/src/Data/Array/Knead/Symbolic.hs b/src/Data/Array/Knead/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +module Data.Array.Knead.Symbolic ( + Core.Array, + Core.C(..), + Exp, + fix, + shape, + (Core.!), + Core.the, + Core.fromScalar, + Core.fill, + gather, + backpermute, + Core.backpermute2, + Core.id, + Core.map, + Core.mapWithIndex, + zipWith, + zipWith3, + zipWith4, + zip, + zip3, + zip4, + Core.fold1, + Core.fold1All, + Core.findAll, + ) where + +import qualified Data.Array.Knead.Symbolic.ShapeDependent as ShapeDep +import qualified Data.Array.Knead.Symbolic.Private as Core +import Data.Array.Knead.Symbolic.Private (Array, shape, gather, ) + +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Expression (Exp, ) + +import qualified LLVM.Extra.Nice.Value as NiceValue + +import Data.Function.HT (Id) + +import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, ) + + +fix :: Id (Array sh a) +fix = id + +backpermute :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + NiceValue.C a) => + Exp sh1 -> + (Exp ix1 -> Exp ix0) -> + Array sh0 a -> + Array sh1 a +backpermute sh1 f = gather (Core.map f (Core.id sh1)) + +zipWith :: + (Core.C array, Shape.C sh) => + (Exp a -> Exp b -> Exp c) -> + array sh a -> array sh b -> array sh c +zipWith = ShapeDep.backpermute2 Shape.intersect id id + +zipWith3 :: + (Core.C array, Shape.C sh) => + (Exp a -> Exp b -> Exp c -> Exp d) -> + array sh a -> array sh b -> array sh c -> array sh d +zipWith3 f a b c = + zipWith (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c + +zipWith4 :: + (Core.C array, Shape.C sh) => + (Exp a -> Exp b -> Exp c -> Exp d -> Exp e) -> + array sh a -> array sh b -> array sh c -> array sh d -> array sh e +zipWith4 f a b c d = + zipWith3 (\ab -> uncurry f (Expr.unzip ab)) (zipWith Expr.zip a b) c d + + +zip :: + (Core.C array, Shape.C sh) => + array sh a -> array sh b -> array sh (a,b) +zip = zipWith (Expr.lift2 NiceValue.zip) + +zip3 :: + (Core.C array, Shape.C sh) => + array sh a -> array sh b -> array sh c -> array sh (a,b,c) +zip3 = zipWith3 (Expr.lift3 NiceValue.zip3) + +zip4 :: + (Core.C array, Shape.C sh) => + array sh a -> array sh b -> array sh c -> array sh d -> + array sh (a,b,c,d) +zip4 = zipWith4 (Expr.lift4 NiceValue.zip4) diff --git a/src/Data/Array/Knead/Symbolic/Fold.hs b/src/Data/Array/Knead/Symbolic/Fold.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Fold.hs @@ -0,0 +1,98 @@ +{- | +Reduce selected dimensions. +Alternatively you may reorder dimensions with 'ShapeDep.backpermute' +and fold once along multiple dimensions. +-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Array.Knead.Symbolic.Fold ( + T, + Cubic, + apply, + passAny, + pass, + fold, + (Core.$:.), + ) where + +import qualified Data.Array.Knead.Symbolic.Private as Core +import Data.Array.Knead.Symbolic.Private (Array(Array), Code, Val, ) + +import qualified Data.Array.Knead.Shape.Cubic.Int as Index +import qualified Data.Array.Knead.Shape.Cubic as Cubic +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Shape.Cubic ((#:.), (:.)((:.)), ) + +import LLVM.DSL.Expression (Exp, unExp) + +import qualified LLVM.Extra.Nice.Value as NiceValue +import LLVM.Extra.Nice.Value (atom, ) + +import qualified Type.Data.Num.Unary as Unary + +import Prelude hiding (zipWith, zipWith3, zip, zip3, replicate, ) + + +data T sh0 sh1 a = + forall ix0 ix1. + (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) => + Cons + (Exp sh0 -> Exp sh1) + (forall r. Val sh0 -> (Val ix0 -> Code r a) -> (Val ix1 -> Code r a)) + + +apply :: + (Core.C array, Shape.C sh0, Shape.C sh1, NiceValue.C a) => + T sh0 sh1 a -> + array sh0 a -> + array sh1 a +apply (Cons fsh reduce) = + Core.lift1 $ \(Array sh code) -> + Array (fsh sh) (\ix -> do sh0 <- unExp sh; reduce sh0 code ix) + + +type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1) + +passAny :: Cubic rank rank a +passAny = Cons id (const id) + +pass :: + (Unary.Natural rank0, Unary.Natural rank1, NiceValue.C a) => + Cubic rank0 rank1 a -> + Cubic (Unary.Succ rank0) (Unary.Succ rank1) a +pass (Cons fsh reduce) = + Cons + (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s) + (\sh code -> + Cubic.switchR $ \jx j -> + reduce (Cubic.tail sh) (\kx -> code (kx #:. j)) jx) + + +fold1CodeLinear :: + (Unary.Natural rank, NiceValue.C a) => + (Exp a -> Exp a -> Exp a) -> + Exp Index.Int -> + (Val (Cubic.Index (Unary.Succ rank)) -> Code r a) -> + (Val (Cubic.Index rank) -> Code r a) +fold1CodeLinear f nc code ix = + Core.fold1Code f + (Expr.lift1 (NiceValue.compose . Shape.ZeroBased) $ Index.decons nc) + (\j -> code (ix #:. Index.cons j)) + +fold :: + (Unary.Natural rank0, Unary.Natural rank1, NiceValue.C a) => + (Exp a -> Exp a -> Exp a) -> + Cubic rank0 rank1 a -> + Cubic (Unary.Succ rank0) rank1 a +fold f (Cons fsh reduce) = + Cons + (fsh . Cubic.tail) + (\sh code jx -> + reduce (Cubic.tail sh) + (fold1CodeLinear f (Expr.lift0 (Cubic.head sh)) code) jx) + + +instance Core.Process (T sh0 sh1 a) where diff --git a/src/Data/Array/Knead/Symbolic/Physical.hs b/src/Data/Array/Knead/Symbolic/Physical.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Physical.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Data.Array.Knead.Symbolic.Physical ( + Array, + shape, + toList, + fromList, + vectorFromList, + with, + render, + scanl1, + mapAccumLSimple, + scatter, + scatterMaybe, + permute, + ) where + +import qualified Data.Array.Knead.Symbolic.PhysicalPrivate as Priv +import qualified Data.Array.Knead.Symbolic.Private as Sym +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Symbolic.PhysicalPrivate (MarshalPtr) +import Data.Array.Knead.Code (getElementPtr) + +import qualified LLVM.DSL.Execution as Code +import LLVM.DSL.Expression (Exp, unExp) + +import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArray +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as ComfortShape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Maybe as Maybe + +import qualified LLVM.Core as LLVM + +import Foreign.Storable (Storable, ) +import Foreign.ForeignPtr (withForeignPtr, mallocForeignPtrArray, ) +import Foreign.Ptr (FunPtr, Ptr, ) + +import Control.Monad.HT (void, (<=<), ) +import Control.Applicative (liftA2, (<$>), ) + +import Prelude2010 hiding (scanl1) +import Prelude () + + +shape :: Array sh a -> sh +shape = Array.shape + +toList :: + (Shape.C sh, Storable a) => + Array sh a -> IO [a] +toList = MutArray.toList <=< MutArray.unsafeThaw + +fromList :: + (Shape.C sh, Storable a) => + sh -> [a] -> IO (Array sh a) +fromList sh = MutArray.unsafeFreeze <=< MutArray.fromList sh + +vectorFromList :: + (Num n, Storable a) => + [a] -> IO (Array (ComfortShape.ZeroBased n) a) +vectorFromList xs = + Array.mapShape (\(Shape.ZeroBased n) -> Shape.ZeroBased $ fromIntegral n) <$> + (MutArray.unsafeFreeze =<< MutArray.vectorFromList xs) + + +{- | +The symbolic array is only valid inside the enclosed action. +-} +with :: + (Shape.C sh, Storable.C a) => + (Sym.Array sh a -> IO b) -> + Array sh a -> IO b +with f (Array sh fptr) = + withForeignPtr fptr $ \ptr -> + f $ + Sym.Array + (Shape.value sh) + (\ix -> + Storable.load =<< + getElementPtr (Shape.value sh) (LLVM.valueOf ptr) ix) + + +type Importer f = FunPtr f -> f + +foreign import ccall safe "dynamic" callShaper :: + Importer (LLVM.Ptr sh -> IO Shape.Size) + +foreign import ccall safe "dynamic" callRenderer :: + Importer (LLVM.Ptr sh -> Ptr a -> IO ()) + + +materialize :: + (Shape.C sh, Marshal.C sh, Storable.C a) => + String -> + Exp sh -> + (LLVM.Value (MarshalPtr sh) -> + LLVM.Value (Ptr a) -> LLVM.CodeGenFunction () ()) -> + IO (Array sh a) +materialize name esh code = + Marshal.alloca $ \lshptr -> do + (fsh, farr) <- + Code.compile name $ + liftA2 (,) + (Code.createFunction callShaper "shape" $ \ptr -> do + sh <- unExp esh + Memory.store sh ptr + Shape.size sh) + (Code.createFunction callRenderer "fill" code) + n <- fsh lshptr + fptr <- mallocForeignPtrArray (fromIntegral n) + withForeignPtr fptr $ farr lshptr + sh <- Marshal.peek lshptr + return (Array sh fptr) + +render :: + (Shape.C sh, Marshal.C sh, Storable.C a) => + Sym.Array sh a -> IO (Array sh a) +render (Sym.Array esh code) = + materialize "render" esh $ \sptr ptr -> do + let step ix p = flip Storable.storeNext p =<< code ix + sh <- Shape.load esh sptr + void $ Shape.loop step sh ptr + +scanl1 :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + Storable.C a, NiceValue.C a) => + (Exp a -> Exp a -> Exp a) -> + Sym.Array (sh, n) a -> IO (Array (sh, n) a) +scanl1 f (Sym.Array esh code) = + materialize "scanl1" esh $ \sptr ptr -> do + (sh, n) <- NiceValue.unzip <$> Shape.load esh sptr + let step ix ptrStart = + fmap fst $ + (\body -> Shape.loop body n (ptrStart, Maybe.nothing)) $ + \k0 (ptr0, macc0) -> do + a <- code $ NiceValue.zip ix k0 + acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a) + ptr1 <- Storable.storeNext acc1 ptr0 + return (ptr1, Maybe.just acc1) + void $ Shape.loop step sh ptr + +mapAccumLSimple :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, Storable.C x, Storable.C y) => + (Exp acc -> Exp x -> Exp (acc,y)) -> + Sym.Array sh acc -> Sym.Array (sh, n) x -> IO (Array (sh, n) y) +mapAccumLSimple f arrInit arrData = + materialize "mapAccumLSimple" (Sym.shape arrData) $ + Priv.mapAccumLSimple f arrInit arrData + +scatterMaybe :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1, + Storable.C a) => + (Exp a -> Exp a -> Exp a) -> + Sym.Array sh1 a -> + Sym.Array sh0 (Maybe (ix1, a)) -> IO (Array sh1 a) +scatterMaybe accum arrInit arrMap = + materialize "scatterMaybe" (Sym.shape arrInit) $ + Priv.scatterMaybe accum arrInit arrMap + +scatter :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1, + Storable.C a) => + (Exp a -> Exp a -> Exp a) -> + Sym.Array sh1 a -> + Sym.Array sh0 (ix1, a) -> IO (Array sh1 a) +scatter accum arrInit arrMap = + materialize "scatter" (Sym.shape arrInit) $ + Priv.scatter accum arrInit arrMap + +permute :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1, + Storable.C a) => + (Exp a -> Exp a -> Exp a) -> + Sym.Array sh1 a -> + (Exp ix0 -> Exp ix1) -> + Sym.Array sh0 a -> + IO (Array sh1 a) +permute accum deflt ixmap input = + scatter accum deflt + (Sym.mapWithIndex (Expr.lift2 NiceValue.zip . ixmap) input) diff --git a/src/Data/Array/Knead/Symbolic/PhysicalParametric.hs b/src/Data/Array/Knead/Symbolic/PhysicalParametric.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/PhysicalParametric.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Data.Array.Knead.Symbolic.PhysicalParametric ( + the, + theMarshal, + render, + MapFilter(..), + mapFilter, + FilterOuter(..), + filterOuter, + Scatter(..), + scatter, + ScatterMaybe(..), + scatterMaybe, + MapAccumLSimple(..), + mapAccumLSimple, + MapAccumLSequence(..), + mapAccumLSequence, + MapAccumL(..), + mapAccumL, + FoldOuterL(..), + foldOuterL, + AddDimension(..), + addDimension, + + Parametric, + Rendered, + ) where + +import qualified Data.Array.Knead.Symbolic.PhysicalPrivate as Priv +import qualified Data.Array.Knead.Symbolic.Private as Core +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Symbolic.PhysicalPrivate (MarshalPtr) + +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) + +import qualified LLVM.DSL.Execution as Code +import LLVM.DSL.Expression (Exp(Exp), unExp) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import Foreign.Marshal.Array (allocaArray, ) +import Foreign.Marshal.Alloc (alloca, ) +import Foreign.Storable (Storable, peek, peekElemOff, ) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, ) +import Foreign.Ptr (FunPtr, Ptr, ) + +import Control.Exception (finally) +import Control.Monad.HT (void, ) +import Control.Applicative (liftA2, ) + + +mallocArray :: (Storable a) => Shape.Size -> IO (ForeignPtr a) +mallocArray = mallocForeignPtrArray . fromIntegral + + +type Importer f = FunPtr f -> f + + + + +type Parametric p a = Exp p -> a +type Rendered p a = IO (p, IO ()) -> IO a + +withManagedParam :: Monad m => (p -> IO a) -> m (Rendered p a) +withManagedParam act = + return $ \create -> do + (param, final) <- create + finally (act param) final + + + +foreign import ccall safe "dynamic" callThe :: + Importer (LLVM.Ptr param -> Ptr a -> IO ()) + +the :: + (Marshal.C p, Shape.Scalar z, Storable.C a) => + Parametric p (Core.Array z a) -> IO (Rendered p a) +the arr = do + func <- + Code.compile "the" $ + Code.createFunction callThe "eval" $ + \paramPtr resultPtr -> do + case arr $ Exp (Memory.load paramPtr) of + Core.Array z code -> + code (Shape.zeroIndex z) >>= + flip Storable.store resultPtr + withManagedParam $ \param -> + Marshal.with param $ \pptr -> + alloca $ \aptr -> func pptr aptr >> peek aptr + +foreign import ccall safe "dynamic" callTheMarshal :: + Importer (LLVM.Ptr param -> LLVM.Ptr a -> IO ()) + +theMarshal :: + (Marshal.C p, Shape.Scalar z, Marshal.C a) => + Parametric p (Core.Array z a) -> IO (Rendered p a) +theMarshal arr = do + func <- + Code.compile "the-marshal" $ + Code.createFunction callTheMarshal "eval" $ + \paramPtr resultPtr -> do + case arr $ Exp (Memory.load paramPtr) of + Core.Array z code -> + code (Shape.zeroIndex z) >>= + flip Memory.store resultPtr + withManagedParam $ \param -> + Marshal.with param $ \pptr -> + Marshal.alloca $ \aptr -> + func pptr aptr >> + Marshal.peek aptr + + + + +foreign import ccall safe "dynamic" callShaper :: + Importer (LLVM.Ptr param -> LLVM.Ptr shape -> IO Shape.Size) + +foreign import ccall safe "dynamic" callFill :: + Importer (LLVM.Ptr param -> LLVM.Ptr shape -> Ptr a -> IO ()) + + +{- +Attention: +The 'fill' function may alter the shape. +An example is 'mapFilter'. +-} +materialize :: + (Shape.C sh, Marshal.C sh, Marshal.C p, Storable.C a) => + String -> + (core -> Exp sh) -> + (core -> + LLVM.Value (MarshalPtr sh) -> LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction () ()) -> + Parametric p core -> IO (Rendered p (Array sh a)) +materialize name shape fill core = do + (fsh, farr) <- + Code.compile name $ + liftA2 (,) + (Code.createFunction callShaper "shape" $ + \paramPtr resultPtr -> do + sh <- unExp $ shape $ core $ Exp (Memory.load paramPtr) + Memory.store sh resultPtr + Shape.size sh) + (Code.createFunction callFill "fill" $ + \paramPtr shapePtr bufferPtr -> + fill (core $ Exp (Memory.load paramPtr)) shapePtr bufferPtr) + + withManagedParam $ \param -> + Marshal.alloca $ \shptr -> + Marshal.with param $ \paramPtr -> do + fptr <- mallocArray =<< fsh paramPtr shptr + withForeignPtr fptr $ farr paramPtr shptr + sh <- Marshal.peek shptr + return (Array sh fptr) + + +foreign import ccall safe "dynamic" callFillExpArray :: + Importer (LLVM.Ptr param -> Ptr final -> LLVM.Ptr shape -> Ptr a -> IO ()) + + +materializeExpArray :: + (Shape.C sh, Marshal.C sh, Marshal.C p, Storable.C a, Storable.C b) => + String -> + (core -> Exp sh) -> + (core -> + LLVM.Value (Ptr b) -> + LLVM.Value (MarshalPtr sh) -> + LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction () ()) -> + Parametric p core -> IO (Rendered p (b, Array sh a)) +materializeExpArray name shape fill core = do + (fsh, farr) <- + Code.compile name $ + liftA2 (,) + (Code.createFunction callShaper "shape" $ + \paramPtr resultPtr -> do + sh <- unExp $ shape $ core $ Exp (Memory.load paramPtr) + Memory.store sh resultPtr + Shape.size sh) + (Code.createFunction callFillExpArray "fill" $ + \paramPtr finalPtr shapePtr bufferPtr -> + fill + (core $ Exp (Memory.load paramPtr)) + finalPtr shapePtr bufferPtr) + + withManagedParam $ \param -> + Marshal.alloca $ \shptr -> + alloca $ \finalPtr -> + Marshal.with param $ \paramPtr -> do + fptr <- mallocArray =<< fsh paramPtr shptr + withForeignPtr fptr $ farr paramPtr finalPtr shptr + sh <- Marshal.peek shptr + final <- peek finalPtr + return (final, Array sh fptr) + + +foreign import ccall safe "dynamic" callShaper2 :: + Importer + (LLVM.Ptr param -> + LLVM.Ptr shapeA -> LLVM.Ptr shapeB -> Ptr Shape.Size -> IO ()) + +foreign import ccall safe "dynamic" callFill2 :: + Importer + (LLVM.Ptr param -> + LLVM.Ptr shapeA -> Ptr a -> LLVM.Ptr shapeB -> Ptr b -> IO ()) + + +materialize2 :: + (Shape.C sha, Marshal.C sha, + Shape.C shb, Marshal.C shb, + Marshal.C p, Storable.C a, Storable.C b) => + String -> + (core -> Exp (sha,shb)) -> + (core -> + (LLVM.Value (MarshalPtr sha), LLVM.Value (Ptr a)) -> + (LLVM.Value (MarshalPtr shb), LLVM.Value (Ptr b)) -> + LLVM.CodeGenFunction () ()) -> + Parametric p core -> IO (Rendered p (Array sha a, Array shb b)) +materialize2 name shape fill core = do + (fsh, farr) <- + Code.compile name $ + liftA2 (,) + (Code.createFunction callShaper2 "shape" $ + \paramPtr shapeAPtr shapeBPtr sizesPtr -> do + (sha,shb) <- + fmap NiceValue.unzip $ unExp $ + shape $ core $ Exp (Memory.load paramPtr) + Memory.store sha shapeAPtr + Memory.store shb shapeBPtr + sizeAPtr <- LLVM.bitcast sizesPtr + flip LLVM.store sizeAPtr =<< Shape.size sha + sizeBPtr <- A.advanceArrayElementPtr sizeAPtr + flip LLVM.store sizeBPtr =<< Shape.size shb) + (Code.createFunction callFill2 "fill" $ + \paramPtr shapeAPtr bufferAPtr shapeBPtr bufferBPtr -> + fill + (core $ Exp (Memory.load paramPtr)) + (shapeAPtr, bufferAPtr) (shapeBPtr, bufferBPtr)) + + withManagedParam $ \param -> + Marshal.alloca $ \shaPtr -> + Marshal.alloca $ \shbPtr -> + allocaArray 2 $ \sizesPtr -> + Marshal.with param $ \paramPtr -> do + fsh paramPtr shaPtr shbPtr sizesPtr + afptr <- mallocArray =<< peekElemOff sizesPtr 0 + bfptr <- mallocArray =<< peekElemOff sizesPtr 1 + withForeignPtr afptr $ \aptr -> + withForeignPtr bfptr $ \bptr -> + farr paramPtr shaPtr aptr shbPtr bptr + sha <- Marshal.peek shaPtr + shb <- Marshal.peek shbPtr + return (Array sha afptr, Array shb bfptr) + + +render :: + (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh, + Marshal.C p, Storable.C a) => + Parametric p (Core.Array sh a) -> IO (Rendered p (Array sh a)) +render = + materialize "render" Core.shape + (\(Core.Array esh code) shapePtr bufferPtr -> do + let step ix p = flip Storable.storeNext p =<< code ix + sh <- Shape.load esh shapePtr + void $ Shape.loop step sh bufferPtr) + + +data Scatter sh0 sh1 a = + Scatter { + scatterAccum :: Exp a -> Exp a -> Exp a, + scatterInit :: Core.Array sh1 a, + scatterMap :: Core.Array sh0 (Shape.Index sh1, a) + } + +scatter :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1, + Marshal.C p, Storable.C a) => + Parametric p (Scatter sh0 sh1 a) -> IO (Rendered p (Array sh1 a)) +scatter = + materialize "scatter" + (Core.shape . scatterInit) + (\(Scatter accum arrInit arrMap) -> + Priv.scatter accum arrInit arrMap) + + + +data ScatterMaybe sh0 sh1 a = + ScatterMaybe { + scatterMaybeAccum :: Exp a -> Exp a -> Exp a, + scatterMaybeInit :: Core.Array sh1 a, + scatterMaybeMap :: Core.Array sh0 (Maybe (Shape.Index sh1, a)) + } + +scatterMaybe :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, Marshal.C sh1, + Marshal.C p, Storable.C a) => + Parametric p (ScatterMaybe sh0 sh1 a) -> IO (Rendered p (Array sh1 a)) +scatterMaybe = + materialize "scatterMaybe" + (Core.shape . scatterMaybeInit) + (\(ScatterMaybe accum arrInit arrMap) -> + Priv.scatterMaybe accum arrInit arrMap) + + +data MapAccumLSimple sh n acc a b = + MapAccumLSimple { + mapAccumLSimpleAccum :: Exp acc -> Exp a -> Exp (acc,b), + mapAccumLSimpleInit :: Core.Array sh acc, + mapAccumLSimpleArray :: Core.Array (sh, n) a + } + +mapAccumLSimple :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, Marshal.C p, Storable.C a, Storable.C b) => + Parametric p (MapAccumLSimple sh n acc a b) -> + IO (Rendered p (Array (sh,n) b)) +mapAccumLSimple = + materialize "mapAccumLSimple" + (Core.shape . mapAccumLSimpleArray) + (\(MapAccumLSimple f arrInit arrData) -> + Priv.mapAccumLSimple f arrInit arrData) + + +data MapAccumLSequence n acc final a b = + MapAccumLSequence { + mapAccumLSequenceAccum :: Exp acc -> Exp a -> Exp (acc,b), + mapAccumLSequenceFinal :: Exp acc -> Exp final, + mapAccumLSequenceInit :: Exp acc, + mapAccumLSequenceArray :: Core.Array n a + } + +-- FIXME: check correct size of array of initial values +mapAccumLSequence :: + (Shape.C n, Marshal.C n, NiceValue.C acc, Storable.C final, + Marshal.C p, Storable.C a, Storable.C b) => + Parametric p (MapAccumLSequence n acc final a b) -> + IO (Rendered p (final, Array n b)) +mapAccumLSequence = + materializeExpArray "mapAccumLSequence" + (Core.shape . mapAccumLSequenceArray) + (\(MapAccumLSequence f final expInit arr) -> + Priv.mapAccumLSequence f final expInit arr) + + +data MapAccumL sh n acc final a b = + MapAccumL { + mapAccumLAccum :: Exp acc -> Exp a -> Exp (acc,b), + mapAccumLFinal :: Exp acc -> Exp final, + mapAccumLInit :: Core.Array sh acc, + mapAccumLArray :: Core.Array (sh, n) a + } + +-- FIXME: check correct size of array of initial values +mapAccumL :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, Storable.C final, + Marshal.C p, Storable.C a, Storable.C b) => + Parametric p (MapAccumL sh n acc final a b) -> + IO (Rendered p (Array sh final, Array (sh,n) b)) +mapAccumL = + materialize2 "mapAccumL" + (\core -> + Expr.zip + (Core.shape $ mapAccumLInit core) + (Core.shape $ mapAccumLArray core)) + (\(MapAccumL f final arrInit arrData) -> + Priv.mapAccumL f final arrInit arrData) + + +data FoldOuterL n sh a b = + FoldOuterL { + foldOuterLAccum :: Exp a -> Exp b -> Exp a, + foldOuterLInit :: Core.Array sh a, + foldOuterLArray :: Core.Array (n,sh) b + } + +-- FIXME: check correct size of array of initial values +foldOuterL :: + (Shape.C n, Marshal.C n, + Shape.C sh, Marshal.C sh, + Marshal.C p, Storable.C a) => + Parametric p (FoldOuterL n sh a b) -> IO (Rendered p (Array sh a)) +foldOuterL = + materialize "foldOuterL" + (Core.shape . foldOuterLInit) + (\(FoldOuterL f arrInit arrData) -> Priv.foldOuterL f arrInit arrData) + + +data MapFilter n a b = + MapFilter { + mapFilterMap :: Exp a -> Exp b, + mapFilterPredicate :: Exp a -> Exp Bool, + mapFilterArray :: Core.Array n a + } + +mapFilter :: + (Shape.Sequence n, Marshal.C n, Marshal.C p, Storable.C b) => + Parametric p (MapFilter n a b) -> IO (Rendered p (Array n b)) +mapFilter = + materialize "mapFilter" + (Core.shape . mapFilterArray) + (\(MapFilter f p arr) shapePtr bufferPtr -> + flip Memory.store shapePtr + =<< Priv.mapFilter f p arr shapePtr bufferPtr) + + +data FilterOuter n sh a = + FilterOuter { + filterOuterPredicate :: Core.Array n Bool, + filterOuterArray :: Core.Array (n,sh) a + } + +-- FIXME: check correct size of row selection array +filterOuter :: + (Shape.Sequence n, Marshal.C n, + Shape.C sh, Marshal.C sh, + Marshal.C p, Storable.C a) => + Parametric p (FilterOuter n sh a) -> IO (Rendered p (Array (n,sh) a)) +filterOuter = + materialize "filterOuter" + (Core.shape . filterOuterArray) + (\(FilterOuter p arr) shapePtr bufferPtr -> + flip Memory.store shapePtr + =<< Priv.filterOuter p arr shapePtr bufferPtr) + + +data AddDimension sh n a b = + AddDimension { + addDimensionSize :: Exp n, + addDimensionSelect :: Exp (Shape.Index n) -> Exp a -> Exp b, + addDimensionArray :: Core.Array sh a + } + +addDimension :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + Marshal.C p, Storable.C b) => + Parametric p (AddDimension sh n a b) -> IO (Rendered p (Array (sh,n) b)) +addDimension = + materialize "addDimension" + (\r -> Expr.zip (Core.shape (addDimensionArray r)) (addDimensionSize r)) + (\(AddDimension n select arr) -> Priv.addDimension n select arr) diff --git a/src/Data/Array/Knead/Symbolic/PhysicalPrivate.hs b/src/Data/Array/Knead/Symbolic/PhysicalPrivate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/PhysicalPrivate.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Array.Knead.Symbolic.PhysicalPrivate where + +import qualified Data.Array.Knead.Symbolic.Private as Sym +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Code (getElementPtr) + +import LLVM.DSL.Expression (Exp, unExp) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Control as C + +import qualified LLVM.Core as LLVM + +import Foreign.Ptr (Ptr, ) + +import qualified Control.Applicative.HT as App +import Control.Monad.HT (void, ) +import Control.Applicative ((<$>), ) + +import Data.Tuple.HT (mapSnd, ) + +import Prelude2010 +import Prelude () + + + +type MarshalPtr a = LLVM.Ptr (Marshal.Struct a) + +writeArray :: + (Shape.C sh, Shape.Index sh ~ ix, Storable.C a) => + NiceValue.T sh -> + (NiceValue.T ix -> LLVM.CodeGenFunction r (NiceValue.T a)) -> + LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction r (LLVM.Value (Ptr a)) +writeArray sh code ptr = do + let clear ix p = flip Storable.storeNext p =<< code ix + Shape.loop clear sh ptr + + +mapAccumLLoop :: + (NiceValue.C acc, Storable.C b, + Shape.C sh, Shape.Index sh ~ ix) => + (NiceValue.T ix -> LLVM.CodeGenFunction r (NiceValue.T a)) -> + (Exp acc -> Exp a -> Exp (acc, b)) -> + NiceValue.T sh -> + LLVM.Value (Ptr b) -> NiceValue.T acc -> + LLVM.CodeGenFunction r (LLVM.Value (Ptr b), NiceValue.T acc) +mapAccumLLoop code f n yPtr accInit = do + let step k0 (ptr0, acc0) = do + x <- code k0 + (acc1,y) <- NiceValue.unzip <$> Expr.unliftM2 f acc0 x + ptr1 <- Storable.storeNext y ptr0 + return (ptr1, acc1) + Shape.loop step n (yPtr, accInit) + +mapAccumLSimple :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, + Storable.C x, + Storable.C y) => + (Exp acc -> Exp x -> Exp (acc,y)) -> + Sym.Array sh acc -> Sym.Array (sh, n) x -> + LLVM.Value (MarshalPtr (sh,n)) -> + LLVM.Value (Ptr y) -> + LLVM.CodeGenFunction r () +mapAccumLSimple f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do + (sh, n) <- NiceValue.unzip <$> Shape.load esh sptr + let step ix ptrStart = do + accInit <- initCode ix + fst <$> mapAccumLLoop (code . NiceValue.zip ix) f n ptrStart accInit + void $ Shape.loop step sh ptr + +mapAccumLSequence :: + (Shape.C n, Marshal.C n, + NiceValue.C acc, Storable.C final, + Storable.C x, + Storable.C y) => + (Exp acc -> Exp x -> Exp (acc,y)) -> + (Exp acc -> Exp final) -> + Exp acc -> Sym.Array n x -> + LLVM.Value (Ptr final) -> + LLVM.Value (MarshalPtr n) -> + LLVM.Value (Ptr y) -> + LLVM.CodeGenFunction r () +mapAccumLSequence f final initExp (Sym.Array esh code) accPtr sptr yPtr = do + n <- Shape.load esh sptr + accInit <- unExp initExp + accExit <- snd <$> mapAccumLLoop code f n yPtr accInit + flip Storable.store accPtr =<< Expr.unliftM1 final accExit + +mapAccumL :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, Storable.C final, + Storable.C x, + Storable.C y) => + (Exp acc -> Exp x -> Exp (acc,y)) -> + (Exp acc -> Exp final) -> + Sym.Array sh acc -> Sym.Array (sh, n) x -> + (LLVM.Value (MarshalPtr sh), LLVM.Value (Ptr final)) -> + (LLVM.Value (MarshalPtr (sh,n)), LLVM.Value (Ptr y)) -> + LLVM.CodeGenFunction r () +mapAccumL f final (Sym.Array _ initCode) (Sym.Array esh code) + (_, accPtr) (sptr, yPtr) = do + (sh, n) <- NiceValue.unzip <$> Shape.load esh sptr + let step ix (accPtr0, yPtrStart) = do + accInit <- initCode ix + (ptrStop, accExit) <- + mapAccumLLoop (code . NiceValue.zip ix) f n yPtrStart accInit + accPtr1 <- + flip Storable.storeNext accPtr0 + =<< Expr.unliftM1 final accExit + return (accPtr1, ptrStop) + void $ Shape.loop step sh (accPtr,yPtr) + +foldOuterL :: + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + Storable.C a) => + (Exp a -> Exp b -> Exp a) -> + Sym.Array sh a -> Sym.Array (n,sh) b -> + LLVM.Value (MarshalPtr sh) -> + LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction r () +foldOuterL f (Sym.Array _ initCode) (Sym.Array esh code) sptr ptr = do + sh <- Shape.load (Expr.snd esh) sptr + n <- NiceValue.fst <$> unExp esh + void $ writeArray sh initCode ptr + + let step k ix ptr0 = do + b <- code $ NiceValue.zip k ix + a0 <- Storable.load ptr0 + a1 <- Expr.unliftM2 f a0 b + Storable.storeNext a1 ptr0 + void $ Shape.loop (\k () -> void $ Shape.loop (step k) sh ptr) n () + +{- | +We need a scalar Shape type @n@. +Scalar Shape types could be distinguished from other Shape types +by the fact that you can convert any Index into a Shape. +-} +mapFilter :: + (Shape.Sequence n, Marshal.C n, + Storable.C b) => + (Exp a -> Exp b) -> + (Exp a -> Exp Bool) -> + Sym.Array n a -> + LLVM.Value (MarshalPtr n) -> + LLVM.Value (Ptr b) -> + LLVM.CodeGenFunction r (NiceValue.T n) +mapFilter f p (Sym.Array esh code) sptr ptr = do + n <- Shape.load esh sptr + let step ix (dstPtr,dstIx) = do + a <- code ix + NiceValue.Cons c <- Expr.unliftM1 p a + C.ifThen c (dstPtr,dstIx) + (App.lift2 (,) + (flip Storable.storeNext dstPtr =<< Expr.unliftM1 f a) + (NiceValue.inc dstIx)) + Shape.sequenceShapeFromIndex . snd + =<< Shape.loop step n (ptr, NiceValue.zero) + +filterOuter :: + (Shape.Sequence n, Marshal.C n, + Shape.C sh, Marshal.C sh, + Storable.C a) => + Sym.Array n Bool -> + Sym.Array (n,sh) a -> + LLVM.Value (MarshalPtr (n,sh)) -> + LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction r (NiceValue.T (n,sh)) +filterOuter (Sym.Array _eish selectCode) (Sym.Array esh code) sptr ptr = do + (n,sh) <- NiceValue.unzip <$> Shape.load esh sptr + let step k (dstPtr0,dstK) = do + NiceValue.Cons c <- selectCode k + C.ifThen c (dstPtr0,dstK) + (do + dstPtr1 <- writeArray sh (code . NiceValue.zip k) dstPtr0 + (,) dstPtr1 <$> NiceValue.inc dstK) + finalN <- + Shape.sequenceShapeFromIndex . snd + =<< Shape.loop step n (ptr, NiceValue.zero) + return $ NiceValue.zip finalN sh + + +scatterMaybe :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + Marshal.C sh1, + Storable.C a) => + (Exp a -> Exp a -> Exp a) -> + Sym.Array sh1 a -> Sym.Array sh0 (Maybe (ix1, a)) -> + LLVM.Value (MarshalPtr sh1) -> + LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction r () +scatterMaybe accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) + sptr ptr = do + + sh <- Shape.load esh sptr + void $ writeArray sh codeInit ptr + + ish <- unExp eish + let fill ix () = do + (NiceValue.Cons c, (jx, a)) <- + mapSnd NiceValue.unzip . NiceValue.splitMaybe <$> codeMap ix + C.ifThen c () $ do + p <- getElementPtr sh ptr jx + flip Storable.store p + =<< Expr.unliftM2 (flip accum) a + =<< Storable.load p + Shape.loop fill ish () + +scatter :: + (Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + Marshal.C sh1, + Storable.C a) => + (Exp a -> Exp a -> Exp a) -> + Sym.Array sh1 a -> + Sym.Array sh0 (Shape.Index sh1, a) -> + LLVM.Value (MarshalPtr sh1) -> + LLVM.Value (Ptr a) -> + LLVM.CodeGenFunction r () +scatter accum (Sym.Array esh codeInit) (Sym.Array eish codeMap) sptr ptr = do + sh <- Shape.load esh sptr + void $ writeArray sh codeInit ptr + + ish <- unExp eish + let fill ix () = do + (jx, a) <- NiceValue.unzip <$> codeMap ix + p <- getElementPtr sh ptr jx + flip Storable.store p + =<< Expr.unliftM2 (flip accum) a + =<< Storable.load p + Shape.loop fill ish () + +addDimension :: + (Shape.C n, Marshal.C n, Shape.Index n ~ k, + Shape.C sh, Marshal.C sh, + Storable.C b) => + Exp n -> + (Exp k -> Exp a -> Exp b) -> + Sym.Array sh a -> + LLVM.Value (MarshalPtr (sh,n)) -> + LLVM.Value (Ptr b) -> + LLVM.CodeGenFunction r () +addDimension en select (Sym.Array esh code) sptr ptr = do + (sh,n) <- NiceValue.unzip <$> Shape.load (Expr.zip esh en) sptr + + let fill ix ptr0 = do + a <- code ix + writeArray n (\k -> Expr.unliftM2 select k a) ptr0 + void $ Shape.loop fill sh ptr diff --git a/src/Data/Array/Knead/Symbolic/Private.hs b/src/Data/Array/Knead/Symbolic/Private.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Private.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Array.Knead.Symbolic.Private where + +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr + +import LLVM.DSL.Expression (Exp(Exp)) + +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Iterator as Iter +import qualified LLVM.Extra.Maybe as Maybe +import qualified LLVM.Core as LLVM + +import qualified Control.Category as Cat +import qualified Control.Monad.HT as Monad +import Control.Monad ((<=<), ) + +import Prelude hiding (id, map, zipWith, replicate, ) + + +type Val = NiceValue.T +type Code r a = LLVM.CodeGenFunction r (Val a) + +data Array sh a = + Array (Exp sh) (forall r. Val (Shape.Index sh) -> Code r a) + +shape :: Array sh a -> Exp sh +shape (Array sh _) = sh + +(!) :: + (Shape.C sh, Shape.Index sh ~ ix) => + Array sh a -> Exp ix -> Exp a +(!) (Array _ code) (Exp ix) = Exp (code =<< ix) + +the :: (Shape.Scalar sh) => Array sh a -> Exp a +the (Array z code) = Exp (code $ Shape.zeroIndex z) + +fromScalar :: (Shape.Scalar sh) => Exp a -> Array sh a +fromScalar = fill Shape.scalar + + +fill :: Exp sh -> Exp a -> Array sh a +fill sh (Exp code) = Array sh (\_z -> code) + + +{- | +This class allows to implement functions without parameters +for both simple and parameterized arrays. +-} +class C array where + lift0 :: Array sh a -> array sh a + lift1 :: (Array sha a -> Array shb b) -> array sha a -> array shb b + lift2 :: + (Array sha a -> Array shb b -> Array shc c) -> + array sha a -> array shb b -> array shc c + +instance C Array where + lift0 = Cat.id + lift1 = Cat.id + lift2 = Cat.id + + +gather :: + (C array, + Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + NiceValue.C a) => + array sh1 ix0 -> + array sh0 a -> + array sh1 a +gather = + lift2 $ \(Array sh1 f) (Array _sh0 code) -> + Array sh1 (code <=< f) + +backpermute2 :: + (C array, + Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + Shape.C sh, Shape.Index sh ~ ix) => + Exp sh -> + (Exp ix -> Exp ix0) -> + (Exp ix -> Exp ix1) -> + (Exp a -> Exp b -> Exp c) -> + array sh0 a -> array sh1 b -> array sh c +backpermute2 sh projectIndex0 projectIndex1 f = + lift2 $ \(Array _sha codeA) (Array _shb codeB) -> + Array sh + (\ix -> + Monad.liftJoin2 (Expr.unliftM2 f) + (codeA =<< Expr.unliftM1 projectIndex0 ix) + (codeB =<< Expr.unliftM1 projectIndex1 ix)) + + +id :: + (C array, Shape.C sh, Shape.Index sh ~ ix) => + Exp sh -> array sh ix +id sh = lift0 $ Array sh return + +map :: + (C array, Shape.C sh) => + (Exp a -> Exp b) -> + array sh a -> array sh b +map f = + lift1 $ \(Array sh code) -> + Array sh (Expr.unliftM1 f <=< code) + +mapWithIndex :: + (C array, Shape.C sh, Shape.Index sh ~ ix) => + (Exp ix -> Exp a -> Exp b) -> + array sh a -> array sh b +mapWithIndex f = + lift1 $ \(Array sh code) -> + Array sh (\ix -> Expr.unliftM2 f ix =<< code ix) + + +fold1Code :: + (Shape.C sh, Shape.Index sh ~ ix, NiceValue.C a) => + (Exp a -> Exp a -> Exp a) -> + Exp sh -> + (Val ix -> Code r a) -> + Code r a +fold1Code f (Exp nc) code = do + n <- nc + fmap Maybe.fromJust $ + Shape.loop + (\i0 macc0 -> do + a <- code i0 + acc1 <- Maybe.run macc0 (return a) (flip (Expr.unliftM2 f) a) + return $ Maybe.just acc1) + n Maybe.nothing + +fold1 :: + (C array, Shape.C sh0, Shape.C sh1, NiceValue.C a) => + (Exp a -> Exp a -> Exp a) -> + array (sh0, sh1) a -> array sh0 a +fold1 f = + lift1 $ \(Array shs code) -> + case Expr.unzip shs of + (sh, s) -> Array sh $ fold1Code f s . NiceValue.curry code + + +fold1All :: + (Shape.C sh, NiceValue.C a) => + (Exp a -> Exp a -> Exp a) -> + Array sh a -> Exp a +fold1All f (Array sh code) = Exp (fold1Code f sh code) + + +findAllCode :: + (Shape.C sh, Shape.Index sh ~ ix, NiceValue.C a) => + (Exp a -> Exp Bool) -> + Exp sh -> + (Val ix -> Code r a) -> + Code r (Maybe a) +findAllCode p (Exp sh) code = do + n <- sh + finalFound <- + Iter.mapWhileState_ + (\a _found -> do + NiceValue.Cons b <- Expr.unliftM1 p a + notb <- LLVM.inv b + return (notb, Maybe.fromBool b a)) + (Iter.mapM code $ Shape.iterator n) + Maybe.nothing + Maybe.run finalFound + (return NiceValue.nothing) + (return . NiceValue.just) + +{- | +In principle this can be implemented using fold1All +but it has a short-cut semantics. +@All@ means that it scans all dimensions +but it does not mean that it finds all occurrences. +If you want to get the index of the found element, +please decorate the array elements with their indices before calling 'findAll'. +-} +findAll :: + (Shape.C sh, NiceValue.C a) => + (Exp a -> Exp Bool) -> + Array sh a -> Exp (Maybe a) +findAll p (Array sh code) = Exp (findAllCode p sh code) + + +class Process proc where + + +infixl 3 $:. + +{- | +Use this for combining several dimension manipulators. +E.g. + +> apply (passAny $:. pick 3 $:. pass $:. replicate 10) array + +The constraint @(Process proc0, Process proc1)@ is a bit weak. +We like to enforce that the type constructor like @Slice.T@ +is the same in @proc0@ and @proc1@, and only the parameters differ. +Currently this coherence is achieved, +because we only provide functions of type @proc0 -> proc1@ with this condition. +-} +($:.) :: (Process proc0, Process proc1) => proc0 -> (proc0 -> proc1) -> proc1 +($:.) = flip ($) diff --git a/src/Data/Array/Knead/Symbolic/Render.hs b/src/Data/Array/Knead/Symbolic/Render.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Render.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE TypeFamilies #-} +{- | +Apply operations on symbolic arrays to physical ones. +-} +module Data.Array.Knead.Symbolic.Render ( + run, + MarshalExp(..), + MapFilter(..), + FilterOuter(..), + Scatter(..), + ScatterMaybe(..), + MapAccumLSimple(..), + MapAccumLSequence(..), + MapAccumL(..), + FoldOuterL(..), + AddDimension(..), + ) where + +import qualified Data.Array.Knead.Symbolic.Render.Basic as Render +import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg +import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP +import qualified Data.Array.Knead.Symbolic.Physical as Phys +import qualified Data.Array.Knead.Symbolic.Private as Core +import qualified Data.Array.Knead.Shape as Shape +import Data.Array.Knead.Symbolic.PhysicalParametric + (MapFilter, FilterOuter, + MapAccumLSimple, MapAccumLSequence, MapAccumL, FoldOuterL, + Scatter, ScatterMaybe, AddDimension) + +import qualified LLVM.DSL.Render.Run as Run +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue + +import Prelude2010 +import Prelude () + + + +class C f where + type Plain f + function :: (Marshal.C p) => Run.T IO p f (Plain f) + +instance + (Marshal.C sh, Shape.C sh, Storable.C a) => + C (Core.Array sh a) where + type Plain (Core.Array sh a) = IO (Phys.Array sh a) + function = Run.Cons PhysP.render + +instance + (Shape.Sequence n, Marshal.C n, + Storable.C b, NiceValue.C b) => + C (MapFilter n a b) where + type Plain (MapFilter n a b) = IO (Phys.Array n b) + function = Run.Cons PhysP.mapFilter + +instance + (Shape.Sequence n, Marshal.C n, + Shape.C sh, Marshal.C sh, + Storable.C a, NiceValue.C a) => + C (FilterOuter n sh a) where + type Plain (FilterOuter n sh a) = IO (Phys.Array (n,sh) a) + function = Run.Cons PhysP.filterOuter + +instance + (Shape.C sh0, Marshal.C sh0, + Shape.C sh1, Marshal.C sh1, + Storable.C a, NiceValue.C a) => + C (Scatter sh0 sh1 a) where + type Plain (Scatter sh0 sh1 a) = IO (Phys.Array sh1 a) + function = Run.Cons PhysP.scatter + +instance + (Shape.C sh0, Marshal.C sh0, + Shape.C sh1, Marshal.C sh1, + Storable.C a, NiceValue.C a) => + C (ScatterMaybe sh0 sh1 a) where + type Plain (ScatterMaybe sh0 sh1 a) = IO (Phys.Array sh1 a) + function = Run.Cons PhysP.scatterMaybe + +instance + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, + Storable.C a, NiceValue.C a, + Storable.C b, NiceValue.C b) => + C (MapAccumLSimple sh n acc a b) where + type Plain (MapAccumLSimple sh n acc a b) = IO (Phys.Array (sh,n) b) + function = Run.Cons PhysP.mapAccumLSimple + +instance + (Shape.C n, Marshal.C n, + NiceValue.C acc, + Storable.C final, NiceValue.C final, + Storable.C a, NiceValue.C a, + Storable.C b, NiceValue.C b) => + C (MapAccumLSequence n acc final a b) where + type Plain (MapAccumLSequence n acc final a b) = IO (final, Phys.Array n b) + function = Run.Cons PhysP.mapAccumLSequence + +instance + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + NiceValue.C acc, + Storable.C final, NiceValue.C final, + Storable.C a, NiceValue.C a, + Storable.C b, NiceValue.C b) => + C (MapAccumL sh n acc final a b) where + type Plain (MapAccumL sh n acc final a b) = + IO (Phys.Array sh final, Phys.Array (sh,n) b) + function = Run.Cons PhysP.mapAccumL + +instance + (Shape.C n, Marshal.C n, + Shape.C sh, Marshal.C sh, + Storable.C a, NiceValue.C a, + Storable.C b, NiceValue.C b) => + C (FoldOuterL n sh a b) where + type Plain (FoldOuterL n sh a b) = IO (Phys.Array sh a) + function = Run.Cons PhysP.foldOuterL + +instance + (Shape.C sh, Marshal.C sh, + Shape.C n, Marshal.C n, + Storable.C b, NiceValue.C b) => + C (AddDimension sh n a b) where + type Plain (AddDimension sh n a b) = IO (Phys.Array (sh,n) b) + function = Run.Cons PhysP.addDimension + + +instance (Storable.C a, NiceValue.C a) => C (Exp a) where + type Plain (Exp a) = IO a + function = Render.storable + +newtype MarshalExp a = MarshalExp {getMarshalExp :: Exp a} + +instance (Marshal.C a) => C (MarshalExp a) where + type Plain (MarshalExp a) = IO a + function = Run.premapDSL getMarshalExp Render.marshal + +instance (Argument arg, C func) => C (arg -> func) where + type Plain (arg -> func) = PlainArg arg -> Plain func + function = argument Render.*-> function + + +class Argument a where + type PlainArg a + argument :: Arg.T (PlainArg a) a + +instance Argument () where + type PlainArg () = () + argument = Arg.unit + +instance + (Shape.C sh, Marshal.C sh, Storable.C a) => + Argument (Core.Array sh a) where + type PlainArg (Core.Array sh a) = Phys.Array sh a + argument = Arg.array + +instance (Marshal.C a) => Argument (Exp a) where + type PlainArg (Exp a) = a + argument = Arg.primitive + +instance (Argument a, Argument b) => Argument (a,b) where + type PlainArg (a,b) = (PlainArg a, PlainArg b) + argument = Arg.pair argument argument + +instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where + type PlainArg (a,b,c) = (PlainArg a, PlainArg b, PlainArg c) + argument = Arg.triple argument argument argument + + + +run :: (C f) => f -> IO (Plain f) +run = Render.run function diff --git a/src/Data/Array/Knead/Symbolic/Render/Argument.hs b/src/Data/Array/Knead/Symbolic/Render/Argument.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Render/Argument.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +module Data.Array.Knead.Symbolic.Render.Argument ( + Arg.T(Arg.Cons), + Arg.unit, + Arg.primitive, + Arg.pair, + Arg.triple, + array, + ) where + +import qualified Data.Array.Knead.Symbolic.Physical as Phys +import qualified Data.Array.Knead.Symbolic.Private as Core +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Code (getElementPtr) + +import qualified Data.Array.Comfort.Storable.Unchecked as Array + +import qualified LLVM.DSL.Render.Argument as Arg +import LLVM.DSL.Expression (unExp) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue + +import Foreign.ForeignPtr (withForeignPtr, touchForeignPtr) + +import Prelude2010 +import Prelude () + + + +array :: + (Shape.C sh, Marshal.C sh, Storable.C a) => + Arg.T (Phys.Array sh a) (Core.Array sh a) +array = + Arg.Cons + (Expr.uncurry $ \esh eptr -> + Core.Array esh + (\ix -> do + sh <- unExp esh + NiceValue.Cons ptr <- unExp eptr + Storable.load =<< getElementPtr sh ptr ix)) + (\(Array.Array sh fptr) -> + withForeignPtr fptr $ \ptr -> + return ((sh, ptr), touchForeignPtr fptr)) diff --git a/src/Data/Array/Knead/Symbolic/Render/Basic.hs b/src/Data/Array/Knead/Symbolic/Render/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Render/Basic.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +{- | +Apply operations on symbolic arrays to physical ones. + +This is an approach with no pre-defined direction of type dependencies. +-} +module Data.Array.Knead.Symbolic.Render.Basic ( + run, + (*->), + + storable, + marshal, + array, + scatter, + ) where + +import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg +import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP +import qualified Data.Array.Knead.Symbolic.Physical as Phys +import qualified Data.Array.Knead.Symbolic.Private as Core +import qualified Data.Array.Knead.Shape as Shape + +import qualified Data.Array.Comfort.Storable.Unchecked as Array + +import qualified LLVM.DSL.Render.Run as Run +import LLVM.DSL.Render.Run (run, (*->)) +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal + +import Prelude2010 +import Prelude () + + + +_example1raw :: + (Marshal.C sh, Shape.C sh, Marshal.C z, Marshal.C a, Storable.C b) => + Run.T IO z (Exp a -> Core.Array sh b) (a -> IO (Phys.Array sh b)) +_example1raw = Arg.primitive *-> array + +_example2raw :: + (Marshal.C sh, Shape.C sh, + Marshal.C z, Marshal.C a, Marshal.C b, Storable.C c) => + Run.T IO z + (Exp a -> Exp b -> Core.Array sh c) + (a -> b -> IO (Phys.Array sh c)) +_example2raw = Arg.primitive *-> Arg.primitive *-> array + + +_example2 :: + (Marshal.C sh, Shape.C sh, + Marshal.C a, Marshal.C b, Storable.C c) => + (Exp a -> Exp b -> Core.Array sh c) -> + IO (a -> b -> IO (Phys.Array sh c)) +_example2 = run (Arg.primitive *-> Arg.primitive *-> array) + +_example2exp :: + (Marshal.C a, Marshal.C b, Storable.C c) => + (Exp a -> Exp b -> Exp c) -> + IO (a -> b -> IO c) +_example2exp = run (Arg.primitive *-> Arg.primitive *-> storable) + +_example2marshal :: + (Marshal.C a, Marshal.C b, Marshal.C c) => + (Exp a -> Exp b -> Exp c) -> + IO (a -> b -> IO c) +_example2marshal = run (Arg.primitive *-> Arg.primitive *-> marshal) + +_example2scatter :: + (Shape.C sh0, Shape.C sh1, Marshal.C sh1, + Marshal.C a, Marshal.C b, Storable.C c) => + (Exp a -> Exp b -> PhysP.Scatter sh0 sh1 c) -> + IO (a -> b -> IO (Array.Array sh1 c)) +_example2scatter = run (Arg.primitive *-> Arg.primitive *-> scatter) + + + + +singleton :: Exp a -> Core.Array () a +singleton = Core.fromScalar + +storable :: (Marshal.C p, Storable.C a) => Run.T IO p (Exp a) (IO a) +storable = Run.Cons $ PhysP.the . fmap singleton + +marshal :: (Marshal.C p, Marshal.C a) => Run.T IO p (Exp a) (IO a) +marshal = Run.Cons $ PhysP.theMarshal . fmap singleton + +array :: + (Shape.C sh, Shape.Index sh ~ ix, Marshal.C sh, + Marshal.C p, Storable.C a) => + Run.T IO p (Core.Array sh a) (IO (Phys.Array sh a)) +array = Run.Cons PhysP.render + + +scatter :: + (Shape.C sh0, Shape.C sh1, Marshal.C sh1, Marshal.C p, Storable.C a) => + Run.T IO p (PhysP.Scatter sh0 sh1 a) (IO (Array.Array sh1 a)) +scatter = Run.Cons PhysP.scatter diff --git a/src/Data/Array/Knead/Symbolic/RenderAlt.hs b/src/Data/Array/Knead/Symbolic/RenderAlt.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/RenderAlt.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE TypeFamilies #-} +{- | +Apply operations on symbolic arrays to physical ones. + +In contrast to the "Data.Array.Knead.Symbolic.Render" module, +here we map from Haskell types to LLVM ones. +This is analogous to "Synthesizer.LLVM.Generator.Render". +-} +module Data.Array.Knead.Symbolic.RenderAlt ( + run, + MarshalValue(..), + ) where + +import qualified Data.Array.Knead.Symbolic.Render.Basic as Render +import qualified Data.Array.Knead.Symbolic.Render.Argument as Arg +import qualified Data.Array.Knead.Symbolic.PhysicalParametric as PhysP +import qualified Data.Array.Knead.Symbolic.Physical as Phys +import qualified Data.Array.Knead.Symbolic.Private as Core +import qualified Data.Array.Knead.Shape as Shape + +import qualified LLVM.DSL.Render.Run as Run +import LLVM.DSL.Expression (Exp) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal + +import Data.Word (Word, Word32) + +import Prelude2010 +import Prelude () + + + +class C f where + type DSL f + function :: (Marshal.C p) => Run.T IO p (DSL f) f + +instance (C_IO a) => C (IO a) where + type DSL (IO a) = DSL_IO a + function = buildIO + + +class C_IO f where + type DSL_IO f + buildIO :: (Marshal.C p) => Run.T IO p (DSL_IO f) (IO f) + +instance + (Marshal.C sh, Shape.C sh, Storable.C a) => + C_IO (Phys.Array sh a) where + type DSL_IO (Phys.Array sh a) = Core.Array sh a + buildIO = Run.Cons PhysP.render + + +instance C_IO Float where + type DSL_IO Float = Exp Float + buildIO = Render.storable + +instance C_IO Word32 where + type DSL_IO Word32 = Exp Word32 + buildIO = Render.storable + +newtype MarshalValue a = MarshalValue {getMarshalValue :: a} + +instance (Marshal.C a) => C_IO (MarshalValue a) where + type DSL_IO (MarshalValue a) = Exp a + buildIO = Run.postmapPlain (fmap MarshalValue) Render.marshal + + +instance (Argument arg, C func) => C (arg -> func) where + type DSL (arg -> func) = DSLArg arg -> DSL func + function = argument Render.*-> function + + + +class Argument a where + type DSLArg a + argument :: Arg.T a (DSLArg a) + +instance Argument () where + type DSLArg () = () + argument = Arg.unit + +instance + (Shape.C sh, Marshal.C sh, Storable.C a) => + Argument (Phys.Array sh a) where + type DSLArg (Phys.Array sh a) = Core.Array sh a + argument = Arg.array + + +instance Argument Float where + type DSLArg Float = Exp Float + argument = Arg.primitive + +instance Argument Int where + type DSLArg Int = Exp Int + argument = Arg.primitive + +instance Argument Word where + type DSLArg Word = Exp Word + argument = Arg.primitive + +instance Argument Word32 where + type DSLArg Word32 = Exp Word32 + argument = Arg.primitive + +instance (Argument a, Argument b) => Argument (a,b) where + type DSLArg (a,b) = (DSLArg a, DSLArg b) + argument = Arg.pair argument argument + +instance (Argument a, Argument b, Argument c) => Argument (a,b,c) where + type DSLArg (a,b,c) = (DSLArg a, DSLArg b, DSLArg c) + argument = Arg.triple argument argument argument + + + +run :: (C f) => DSL f -> IO f +run = Render.run function diff --git a/src/Data/Array/Knead/Symbolic/ShapeDependent.hs b/src/Data/Array/Knead/Symbolic/ShapeDependent.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/ShapeDependent.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Array.Knead.Symbolic.ShapeDependent where + +import qualified Data.Array.Knead.Symbolic.Private as Core +import Data.Array.Knead.Symbolic.Private (Array(Array), ) + +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Expression (Exp, ) + +import qualified Control.Monad.HT as Monad +import Control.Monad ((<=<), ) + + +shape :: (Core.C array, Shape.C sh, Shape.Scalar z) => array sh a -> array z sh +shape = Core.lift1 $ Core.fromScalar . Core.shape + +backpermute :: + (Core.C array, + Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1) => + (Exp sh0 -> Exp sh1) -> + (Exp ix1 -> Exp ix0) -> + array sh0 a -> + array sh1 a +backpermute createShape projectIndex = + Core.lift1 $ \(Array sh code) -> + Array (createShape sh) + (code <=< Expr.unliftM1 projectIndex) + +{- | +This is between 'backpermute' and 'backpermute2'. +You can access the shapes of two arrays, +but only the content of one of them. +This is necessary if the second array contributes only a virtual dimension. +-} +backpermuteExtra :: + (Core.C array, + Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + Shape.C sh, Shape.Index sh ~ ix) => + (Exp sh0 -> Exp sh1 -> Exp sh) -> + (Exp ix -> Exp ix0) -> + array sh0 a -> array sh1 b -> array sh a +backpermuteExtra newShape projectIndex = + Core.lift2 $ \(Array sh0 code) (Array sh1 _code) -> + Array (newShape sh0 sh1) + (\ix -> code =<< Expr.unliftM1 projectIndex ix) + +backpermute2 :: + (Core.C array, + Shape.C sh0, Shape.Index sh0 ~ ix0, + Shape.C sh1, Shape.Index sh1 ~ ix1, + Shape.C sh, Shape.Index sh ~ ix) => + (Exp sh0 -> Exp sh1 -> Exp sh) -> + (Exp ix -> Exp ix0) -> + (Exp ix -> Exp ix1) -> + (Exp a -> Exp b -> Exp c) -> + array sh0 a -> array sh1 b -> array sh c +backpermute2 combineShape projectIndex0 projectIndex1 f = + Core.lift2 $ \(Array sha codeA) (Array shb codeB) -> + Array (combineShape sha shb) + (\ix -> + Monad.liftJoin2 (Expr.unliftM2 f) + (codeA =<< Expr.unliftM1 projectIndex0 ix) + (codeB =<< Expr.unliftM1 projectIndex1 ix)) + +fill :: + (Core.C array) => + (Exp sh0 -> Exp sh1) -> Exp b -> + array sh0 a -> array sh1 b +fill fsh a = + Core.lift1 $ \arr -> + Core.fill (fsh $ Core.shape arr) a diff --git a/src/Data/Array/Knead/Symbolic/Slice.hs b/src/Data/Array/Knead/Symbolic/Slice.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Knead/Symbolic/Slice.hs @@ -0,0 +1,198 @@ +{- | +Generate and apply index maps. +This unifies the @replicate@ and @slice@ functions of the @accelerate@ package. +However the structure of slicing and replicating cannot depend on parameters. +If you need that, you must use 'ShapeDep.backpermute' and friends. +-} +{- +Some notes on the design choice: + +Instead of the shallow embedding implemented by the 'T' type, +we could maintain a symbolic representation of the Slice and Replicate pattern, +like the accelerate package does. +We actually used that representation in former versions. +It has however some drawbacks: + +* We need additional type functions that map from the pattern + to the source and the target shape and we need a proof, + that the images of these type functions are actually shapes. + This worked already, but was rather cumbersome. + +* We need a way to store and pass this pattern through the Parameter handler. + This yields new problems: + We need a wrapper type for wrapping Index, Shape, Slice, Replicate, Fold patterns. + Then the question is whether we use one Wrap type with a phantom parameter + or whether we define a Wrap type for every pattern type. + That is, the options are to write either + + > Wrap Shape (Z:.Int:.Int) + + or + + > Shape (Z:.Int:.Int) + + The first one seems to save us many duplicate instances of + Storable, NiceValue etc. + and it allows us easily to reuse the (:.) for all kinds of patterns. + However, we need a way to restrict the element type of the (:.)-list elements. + We can define that using variable ConstraintKinds, + but e.g. we are not able to add a Storable superclass constraint + to the instance Storable (Wrap constr). + That is, we are left with the second option + and had to define a lot of similar Storable, NiceValue instances. +-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Data.Array.Knead.Symbolic.Slice ( + T, + Cubic, + apply, + passAny, + pass, + pick, + pickFst, + pickSnd, + extrude, + extrudeFst, + extrudeSnd, + transpose, + (Core.$:.), + + id, + first, + second, + compose, + ) where + +import qualified Data.Array.Knead.Symbolic.ShapeDependent as ShapeDep +import qualified Data.Array.Knead.Symbolic.Private as Core + +import qualified Data.Array.Knead.Shape.Cubic.Int as Index +import qualified Data.Array.Knead.Shape.Cubic as Cubic +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Knead.Expression as Expr +import Data.Array.Knead.Shape.Cubic ((#:.), (:.)((:.)), ) +import Data.Array.Knead.Expression (Exp, ) + +import qualified LLVM.Extra.Nice.Value as NiceValue +import LLVM.Extra.Nice.Value (atom, ) + +import qualified Type.Data.Num.Unary as Unary + +import qualified Prelude as P +import Prelude hiding (id, zipWith, zipWith3, zip, zip3, replicate, ) + + + +{- +This data type is almost identical to Core.Array. +The only difference is, +that the shape @sh1@ in T can depend on another shape @sh0@. +-} +data T sh0 sh1 = + forall ix0 ix1. + (Shape.Index sh0 ~ ix0, Shape.Index sh1 ~ ix1) => + Cons + (Exp sh0 -> Exp sh1) + (Exp ix1 -> Exp ix0) + +{- | +This is essentially a 'ShapeDep.backpermute'. +-} +apply :: + (Core.C array, Shape.C sh0, Shape.C sh1, NiceValue.C a) => + T sh0 sh1 -> + array sh0 a -> + array sh1 a +apply (Cons fsh fix) = + ShapeDep.backpermute fsh fix + + +pickFst :: Exp (Shape.Index n) -> T (n,sh) sh +pickFst i = Cons Expr.snd (Expr.zip i) + +pickSnd :: Exp (Shape.Index n) -> T (sh,n) sh +pickSnd i = Cons Expr.fst (flip Expr.zip i) + +{- | +Extrusion has the potential to do duplicate work. +Only use it to add dimensions of size 1, e.g. numeric 1 or unit @()@ +or to duplicate slices of physical arrays. +-} +extrudeFst :: Exp n -> T sh (n,sh) +extrudeFst n = Cons (Expr.zip n) Expr.snd + +extrudeSnd :: Exp n -> T sh (sh,n) +extrudeSnd n = Cons (flip Expr.zip n) Expr.fst + +transpose :: T (sh0,sh1) (sh1,sh0) +transpose = Cons Expr.swap Expr.swap + + +-- Arrow combinators + +id :: T sh sh +id = Cons P.id P.id + +first :: T sh0 sh1 -> T (sh0,sh) (sh1,sh) +first (Cons fsh fix) = Cons (Expr.mapFst fsh) (Expr.mapFst fix) + +second :: T sh0 sh1 -> T (sh,sh0) (sh,sh1) +second (Cons fsh fix) = Cons (Expr.mapSnd fsh) (Expr.mapSnd fix) + +infixr 1 `compose` + +compose :: T sh0 sh1 -> T sh1 sh2 -> T sh0 sh2 +compose (Cons fshA fixA) (Cons fshB fixB) = Cons (fshB . fshA) (fixA . fixB) + + +type Cubic rank0 rank1 = T (Cubic.Shape rank0) (Cubic.Shape rank1) + +{- | +Like @Any@ in @accelerate@. +-} +passAny :: Cubic rank rank +passAny = Cons P.id P.id + +{- | +Like @All@ in @accelerate@. +-} +pass :: + (Unary.Natural rank0, Unary.Natural rank1) => + Cubic rank0 rank1 -> + Cubic (Unary.Succ rank0) (Unary.Succ rank1) +pass (Cons fsh fix) = + Cons + (Expr.modify (atom:.atom) $ \(sh:.s) -> fsh sh :. s) + (Expr.modify (atom:.atom) $ \(ix:.i) -> fix ix :. i) + +{- | +Like @Int@ in @accelerate/slice@. +-} +pick :: + (Unary.Natural rank0, Unary.Natural rank1) => + Exp Index.Int -> + Cubic rank0 rank1 -> + Cubic (Unary.Succ rank0) rank1 +pick i (Cons fsh fix) = + Cons + (fsh . Cubic.tail) + (\ix -> fix ix #:. i) + +{- | +Like @Int@ in @accelerate/replicate@. +-} +extrude :: + (Unary.Natural rank0, Unary.Natural rank1) => + Exp Index.Int -> + Cubic rank0 rank1 -> + Cubic rank0 (Unary.Succ rank1) +extrude n (Cons fsh fix) = + Cons + (\sh -> fsh sh #:. n) + (fix . Cubic.tail) + + +instance Core.Process (T sh0 sh1) where diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import qualified Test.Array as Array + +import qualified LLVM.Core as LLVM + +import Data.Tuple.HT (mapFst) + +import qualified Test.QuickCheck as QC + + +main :: IO () +main = do + LLVM.initializeNativeTarget + + mapM_ (\(msg,prop) -> putStr (msg++": ") >> prop >>= QC.quickCheck) $ + map (mapFst ("Array."++)) Array.tests ++ + [] diff --git a/test/Test/Array.hs b/test/Test/Array.hs new file mode 100644 --- /dev/null +++ b/test/Test/Array.hs @@ -0,0 +1,101 @@ +module Test.Array where + +import qualified Data.Array.Knead.Symbolic.Render as Render +import qualified Data.Array.Knead.Symbolic as Symb +import qualified Data.Array.Knead.Symbolic.Slice as Slice +import qualified Data.Array.Knead.Expression as Expr +import qualified Data.Array.Knead.Shape as Shape +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as ComfortShape +import Data.Array.Comfort.Storable (Array) + +import qualified LLVM.Extra.Nice.Value.Storable as Storable +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value as NiceValue + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Foreign.Storable (Storable) + +import qualified Data.List.HT as ListHT +import Data.Int (Int32, Int64) + +import Control.Applicative ((<$>)) + +import qualified Test.QuickCheck.Monadic as QCMon +import qualified Test.QuickCheck as QC + + +type Dim = ComfortShape.ZeroBased Int64 +type Dim2 = (Dim, Dim) + +genArray :: (QC.Arbitrary a, Storable a) => QC.Gen (Array Dim2 a) +genArray = do + m <- QC.choose (1,10) + n <- QC.choose (1,10) + let shape = (Shape.ZeroBased m, Shape.ZeroBased n) + Array.fromList shape <$> QC.vector (ComfortShape.size shape) + + +rowSumSymb :: + (Shape.C sh0, Shape.C sh1, NiceValue.Additive a) => + Symb.Array (sh0,sh1) a -> Symb.Array sh0 a +rowSumSymb = Symb.fold1 Expr.add + +columnSumSymb :: + (Shape.C sh0, Shape.C sh1, NiceValue.Additive a) => + Symb.Array (sh0,sh1) a -> Symb.Array sh1 a +columnSumSymb = Symb.fold1 Expr.add . Slice.apply Slice.transpose + + +getRows :: + (ComfortShape.C sh0, ComfortShape.C sh1, Storable a) => + Array (sh0,sh1) a -> [[a]] +getRows x = + ListHT.sliceVertical + (ComfortShape.size $ snd $ Array.shape x) + (Array.toList x) + +rowPred :: + (Num a, Eq a, Storable a, + ComfortShape.C sh0, ComfortShape.C sh1) => + Array (sh0, sh1) a -> Array sh0 a -> Bool +rowPred x y = Array.toList y == map sum (getRows x) + +columnPred :: + (Num a, Eq a, Storable a, + ComfortShape.C sh0, ComfortShape.C sh1) => + Array (sh0, sh1) a -> Array sh1 a -> Bool +columnPred x y = Array.toList y == foldl1 (zipWith (+)) (getRows x) + +run :: + (Shape.C sh0, Marshal.C sh0, Show sh0, + Shape.C sh1, Marshal.C sh1, Show sh1, + Show a, Num a, Eq a, Storable.C a) => + QC.Gen (Array sh0 a) -> + (Symb.Array sh0 a -> Symb.Array sh1 a) -> + (Array sh0 a -> Array sh1 a -> Bool) -> + IO QC.Property +run qcgen code predicate = do + act <- Render.run code + return $ QC.forAll qcgen $ \x -> + QCMon.monadicIO $ do + y <- QCMon.run $ act x + QCMon.assert $ predicate x y + + +tests :: [(String, IO QC.Property)] +tests = + ("rowSum", + run (genArray :: QC.Gen (Array Dim2 Int32)) rowSumSymb rowPred) : + ("columnSum", + run (genArray :: QC.Gen (Array Dim2 Int32)) columnSumSymb columnPred) : + ("rowSumV3", + run (genArray :: QC.Gen (Array Dim2 (LLVM.Vector TypeNum.D3 Int32))) + rowSumSymb rowPred) : + ("columnSumV3", + run (genArray :: QC.Gen (Array Dim2 (LLVM.Vector TypeNum.D3 Int32))) + columnSumSymb columnPred) : + []