diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -1,5 +1,12 @@ # Change log for the `llvm-extra` package +## 0.12.1 + +* `Multi.Value` -> `Nice.Value` + + The `Multi.Value` name was misleading. + `Multi.Value` retained for compatibility for now. + ## 0.11 * `Memory`: turn methods `load` and `store` into top-level functions diff --git a/llvm-extra.cabal b/llvm-extra.cabal --- a/llvm-extra.cabal +++ b/llvm-extra.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: llvm-extra -Version: 0.12.0.1 +Version: 0.12.1 License: BSD-3-Clause License-File: LICENSE Author: Henning Thielemann @@ -38,7 +38,7 @@ . * more functional loop construction using "LLVM.Extra.Iterator" . - * complex Haskell values mapped to LLVM values in "LLVM.Extra.Multi.Value" + * complex Haskell values mapped to LLVM values in "LLVM.Extra.Nice.Value" . * advanced vector operations such as sum of all vector elements, cumulative sum, @@ -61,7 +61,7 @@ default: False Source-Repository this - Tag: 0.12.0.1 + Tag: 0.12.1 Type: darcs Location: http://code.haskell.org/~thielema/llvm-extra/ @@ -110,6 +110,15 @@ LLVM.Extra.ScalarOrVector LLVM.Extra.FastMath LLVM.Extra.Iterator + LLVM.Extra.Nice.Iterator + LLVM.Extra.Nice.Value + LLVM.Extra.Nice.Value.Vector + LLVM.Extra.Nice.Value.Marshal + LLVM.Extra.Nice.Value.Storable + LLVM.Extra.Nice.Vector + LLVM.Extra.Nice.Vector.Instance + LLVM.Extra.Nice.Class + -- retained for compatibility LLVM.Extra.Multi.Iterator LLVM.Extra.Multi.Value LLVM.Extra.Multi.Value.Vector @@ -124,8 +133,8 @@ LLVM.Extra.TuplePrivate LLVM.Extra.MaybePrivate LLVM.Extra.EitherPrivate - LLVM.Extra.Multi.Value.Private - LLVM.Extra.Multi.Value.Array + LLVM.Extra.Nice.Value.Private + LLVM.Extra.Nice.Value.Array Library private Build-Depends: diff --git a/src/LLVM/Extra/FastMath.hs b/src/LLVM/Extra/FastMath.hs --- a/src/LLVM/Extra/FastMath.hs +++ b/src/LLVM/Extra/FastMath.hs @@ -12,17 +12,25 @@ Number(Number, deconsNumber), getNumber, + nvNumber, + nvDenumber, mvNumber, mvDenumber, - MultiValue(setMultiValueFlags), + NiceValue(setMultiValueFlags, setNiceValueFlags), + attachNiceValueFlags, attachMultiValueFlags, liftNumberM, liftNumberM2, + nvecNumber, + nvecDenumber, mvecNumber, mvecDenumber, - MultiVector(setMultiVectorFlags), + NiceVector(setMultiVectorFlags, setNiceVectorFlags), + attachNiceVectorFlags, + liftNiceVectorM, + liftNiceVectorM2, attachMultiVectorFlags, liftMultiVectorM, liftMultiVectorM2, @@ -34,8 +42,8 @@ liftContext2, ) where -import qualified LLVM.Extra.Multi.Vector as MultiVector -import qualified LLVM.Extra.Multi.Value.Private as MV +import qualified LLVM.Extra.Nice.Vector as NiceVector +import qualified LLVM.Extra.Nice.Value.Private as Nice import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Core as LLVM @@ -92,289 +100,324 @@ getNumber :: flags -> Number flags a -> a getNumber _ (Number a) = a -instance MultiValue a => MV.C (Number flags a) where - type Repr (Number flags a) = MV.Repr a - cons = mvNumber . MV.cons . deconsNumber - undef = mvNumber MV.undef - zero = mvNumber MV.zero - phi bb = fmap mvNumber . MV.phi bb . mvDenumber - addPhi bb a b = MV.addPhi bb (mvDenumber a) (mvDenumber b) +instance NiceValue a => Nice.C (Number flags a) where + type Repr (Number flags a) = Nice.Repr a + cons = nvNumber . Nice.cons . deconsNumber + undef = nvNumber Nice.undef + zero = nvNumber Nice.zero + phi bb = fmap nvNumber . Nice.phi bb . nvDenumber + addPhi bb a b = Nice.addPhi bb (nvDenumber a) (nvDenumber b) -mvNumber :: MV.T a -> MV.T (Number flags a) -mvNumber (MV.Cons a) = MV.Cons a +nvNumber :: Nice.T a -> Nice.T (Number flags a) +nvNumber (Nice.Cons a) = Nice.Cons a -mvDenumber :: MV.T (Number flags a) -> MV.T a -mvDenumber (MV.Cons a) = MV.Cons a +nvDenumber :: Nice.T (Number flags a) -> Nice.T a +nvDenumber (Nice.Cons a) = Nice.Cons a +{-# DEPRECATED mvNumber "Use nvNumber instead" #-} +mvNumber :: Nice.T a -> Nice.T (Number flags a) +mvNumber (Nice.Cons a) = Nice.Cons a -class MV.C a => MultiValue a where - setMultiValueFlags :: +{-# DEPRECATED mvDenumber "Use nvDenumber instead" #-} +mvDenumber :: Nice.T (Number flags a) -> Nice.T a +mvDenumber (Nice.Cons a) = Nice.Cons a + + +{-# DEPRECATED setMultiValueFlags "use setNiceValueFlags instead" #-} +class Nice.C a => NiceValue a where + {-# MINIMAL setNiceValueFlags | setMultiValueFlags #-} + setNiceValueFlags, setMultiValueFlags :: (Flags flags) => - Proxy flags -> Bool -> MV.T (Number flags a) -> LLVM.CodeGenFunction r () + Proxy flags -> Bool -> Nice.T (Number flags a) -> + LLVM.CodeGenFunction r () + setNiceValueFlags = setMultiValueFlags + setMultiValueFlags = setNiceValueFlags -instance MultiValue Float where - setMultiValueFlags p b (MV.Cons a) = setFlags p b a +instance NiceValue Float where + setNiceValueFlags p b (Nice.Cons a) = setFlags p b a -instance MultiValue Double where - setMultiValueFlags p b (MV.Cons a) = setFlags p b a +instance NiceValue Double where + setNiceValueFlags p b (Nice.Cons a) = setFlags p b a type Id a = a -> a -attachMultiValueFlags :: - (Flags flags, MultiValue a) => - Id (LLVM.CodeGenFunction r (MV.T (Number flags a))) -attachMultiValueFlags act = do +{-# DEPRECATED attachMultiValueFlags "Use attachNiceValueFlags instead." #-} +attachMultiValueFlags, attachNiceValueFlags :: + (Flags flags, NiceValue a) => + Id (LLVM.CodeGenFunction r (Nice.T (Number flags a))) +attachMultiValueFlags = attachNiceValueFlags +attachNiceValueFlags act = do mv <- act setMultiValueFlags Proxy True mv return mv liftNumberM :: - (m ~ LLVM.CodeGenFunction r, Flags flags, MultiValue b) => - (MV.T a -> m (MV.T b)) -> - MV.T (Number flags a) -> m (MV.T (Number flags b)) + (m ~ LLVM.CodeGenFunction r, Flags flags, NiceValue b) => + (Nice.T a -> m (Nice.T b)) -> + Nice.T (Number flags a) -> m (Nice.T (Number flags b)) liftNumberM f = - attachMultiValueFlags . Monad.lift mvNumber . f . mvDenumber + attachMultiValueFlags . Monad.lift nvNumber . f . nvDenumber liftNumberM2 :: - (m ~ LLVM.CodeGenFunction r, Flags flags, MultiValue c) => - (MV.T a -> MV.T b -> m (MV.T c)) -> - MV.T (Number flags a) -> MV.T (Number flags b) -> m (MV.T (Number flags c)) + (m ~ LLVM.CodeGenFunction r, Flags flags, NiceValue c) => + (Nice.T a -> Nice.T b -> m (Nice.T c)) -> + Nice.T (Number flags a) -> Nice.T (Number flags b) -> + m (Nice.T (Number flags c)) liftNumberM2 f a b = - attachMultiValueFlags $ Monad.lift mvNumber $ f (mvDenumber a) (mvDenumber b) + attachMultiValueFlags $ Monad.lift nvNumber $ f (nvDenumber a) (nvDenumber b) -instance (Flags flags, MV.Compose a) => MV.Compose (Number flags a) where - type Composed (Number flags a) = Number flags (MV.Composed a) - compose = mvNumber . MV.compose . deconsNumber +instance (Flags flags, Nice.Compose a) => Nice.Compose (Number flags a) where + type Composed (Number flags a) = Number flags (Nice.Composed a) + compose = nvNumber . Nice.compose . deconsNumber -instance (Flags flags, MV.Decompose pa) => MV.Decompose (Number flags pa) where - decompose (Number p) = Number . MV.decompose p . mvDenumber +instance + (Flags flags, Nice.Decompose pa) => Nice.Decompose (Number flags pa) where + decompose (Number p) = Number . Nice.decompose p . nvDenumber type instance - MV.Decomposed f (Number flags pa) = Number flags (MV.Decomposed f pa) + Nice.Decomposed f (Number flags pa) = Number flags (Nice.Decomposed f pa) type instance - MV.PatternTuple (Number flags pa) = Number flags (MV.PatternTuple pa) + Nice.PatternTuple (Number flags pa) = Number flags (Nice.PatternTuple pa) instance - (Flags flags, MultiValue a, MV.IntegerConstant a) => - MV.IntegerConstant (Number flags a) where - fromInteger' = mvNumber . MV.fromInteger' + (Flags flags, NiceValue a, Nice.IntegerConstant a) => + Nice.IntegerConstant (Number flags a) where + fromInteger' = nvNumber . Nice.fromInteger' instance - (Flags flags, MultiValue a, MV.RationalConstant a) => - MV.RationalConstant (Number flags a) where - fromRational' = mvNumber . MV.fromRational' + (Flags flags, NiceValue a, Nice.RationalConstant a) => + Nice.RationalConstant (Number flags a) where + fromRational' = nvNumber . Nice.fromRational' instance - (Flags flags, MultiValue a, MV.Additive a) => - MV.Additive (Number flags a) where - add = liftNumberM2 MV.add - sub = liftNumberM2 MV.sub - neg = liftNumberM MV.neg + (Flags flags, NiceValue a, Nice.Additive a) => + Nice.Additive (Number flags a) where + add = liftNumberM2 Nice.add + sub = liftNumberM2 Nice.sub + neg = liftNumberM Nice.neg instance - (Flags flags, MultiValue a, MV.PseudoRing a) => - MV.PseudoRing (Number flags a) where - mul = liftNumberM2 MV.mul + (Flags flags, NiceValue a, Nice.PseudoRing a) => + Nice.PseudoRing (Number flags a) where + mul = liftNumberM2 Nice.mul instance - (Flags flags, MultiValue a, MV.Field a) => - MV.Field (Number flags a) where - fdiv = liftNumberM2 MV.fdiv + (Flags flags, NiceValue a, Nice.Field a) => + Nice.Field (Number flags a) where + fdiv = liftNumberM2 Nice.fdiv -type instance MV.Scalar (Number flags a) = Number flags (MV.Scalar a) +type instance Nice.Scalar (Number flags a) = Number flags (Nice.Scalar a) instance - (Flags flags, MultiValue a, a ~ MV.Scalar v, - MultiValue v, MV.PseudoModule v) => - MV.PseudoModule (Number flags v) where - scale = liftNumberM2 MV.scale + (Flags flags, NiceValue a, a ~ Nice.Scalar v, + NiceValue v, Nice.PseudoModule v) => + Nice.PseudoModule (Number flags v) where + scale = liftNumberM2 Nice.scale instance - (Flags flags, MultiValue a, MV.Real a) => - MV.Real (Number flags a) where - min = liftNumberM2 MV.min - max = liftNumberM2 MV.max - abs = liftNumberM MV.abs - signum = liftNumberM MV.signum + (Flags flags, NiceValue a, Nice.Real a) => + Nice.Real (Number flags a) where + min = liftNumberM2 Nice.min + max = liftNumberM2 Nice.max + abs = liftNumberM Nice.abs + signum = liftNumberM Nice.signum instance - (Flags flags, MultiValue a, MV.Fraction a) => - MV.Fraction (Number flags a) where - truncate = liftNumberM MV.truncate - fraction = liftNumberM MV.fraction + (Flags flags, NiceValue a, Nice.Fraction a) => + Nice.Fraction (Number flags a) where + truncate = liftNumberM Nice.truncate + fraction = liftNumberM Nice.fraction instance - (Flags flags, MultiValue a, MV.Algebraic a) => - MV.Algebraic (Number flags a) where - sqrt = liftNumberM MV.sqrt + (Flags flags, NiceValue a, Nice.Algebraic a) => + Nice.Algebraic (Number flags a) where + sqrt = liftNumberM Nice.sqrt instance - (Flags flags, MultiValue a, MV.Transcendental a) => - MV.Transcendental (Number flags a) where - pi = fmap mvNumber MV.pi - sin = liftNumberM MV.sin - cos = liftNumberM MV.cos - exp = liftNumberM MV.exp - log = liftNumberM MV.log - pow = liftNumberM2 MV.pow + (Flags flags, NiceValue a, Nice.Transcendental a) => + Nice.Transcendental (Number flags a) where + pi = fmap nvNumber Nice.pi + sin = liftNumberM Nice.sin + cos = liftNumberM Nice.cos + exp = liftNumberM Nice.exp + log = liftNumberM Nice.log + pow = liftNumberM2 Nice.pow instance - (Flags flags, MultiValue a, MV.Select a) => - MV.Select (Number flags a) where - select = liftNumberM2 . MV.select + (Flags flags, NiceValue a, Nice.Select a) => + Nice.Select (Number flags a) where + select = liftNumberM2 . Nice.select instance - (Flags flags, MultiValue a, MV.Comparison a) => - MV.Comparison (Number flags a) where - cmp p a b = MV.cmp p (mvDenumber a) (mvDenumber b) + (Flags flags, NiceValue a, Nice.Comparison a) => + Nice.Comparison (Number flags a) where + cmp p a b = Nice.cmp p (nvDenumber a) (nvDenumber b) instance - (Flags flags, MultiValue a, MV.FloatingComparison a) => - MV.FloatingComparison (Number flags a) where - fcmp p a b = MV.fcmp p (mvDenumber a) (mvDenumber b) + (Flags flags, NiceValue a, Nice.FloatingComparison a) => + Nice.FloatingComparison (Number flags a) where + fcmp p a b = Nice.fcmp p (nvDenumber a) (nvDenumber b) -mvecNumber :: MultiVector.T n a -> MultiVector.T n (Number flags a) -mvecNumber (MultiVector.Cons v) = MultiVector.Cons v +nvecNumber :: NiceVector.T n a -> NiceVector.T n (Number flags a) +nvecNumber (NiceVector.Cons v) = NiceVector.Cons v -mvecDenumber :: MultiVector.T n (Number flags a) -> MultiVector.T n a -mvecDenumber (MultiVector.Cons v) = MultiVector.Cons v +nvecDenumber :: NiceVector.T n (Number flags a) -> NiceVector.T n a +nvecDenumber (NiceVector.Cons v) = NiceVector.Cons v -class (MultiValue a, MultiVector.C a) => MultiVector a where - setMultiVectorFlags :: +{-# DEPRECATED mvecNumber "Use nvecNumber instead" #-} +mvecNumber :: NiceVector.T n a -> NiceVector.T n (Number flags a) +mvecNumber (NiceVector.Cons v) = NiceVector.Cons v + +{-# DEPRECATED mvecDenumber "Use nvecDenumber instead" #-} +mvecDenumber :: NiceVector.T n (Number flags a) -> NiceVector.T n a +mvecDenumber (NiceVector.Cons v) = NiceVector.Cons v + +{-# DEPRECATED setMultiVectorFlags "use setNiceVectorFlags instead" #-} +class (NiceValue a, NiceVector.C a) => NiceVector a where + {-# MINIMAL setNiceVectorFlags | setMultiVectorFlags #-} + setNiceVectorFlags, setMultiVectorFlags :: (Flags flags, LLVM.Positive n) => Proxy flags -> Bool -> - MultiVector.T n (Number flags a) -> LLVM.CodeGenFunction r () + NiceVector.T n (Number flags a) -> LLVM.CodeGenFunction r () + setNiceVectorFlags = setMultiVectorFlags + setMultiVectorFlags = setNiceVectorFlags -instance MultiVector Float where +instance NiceVector Float where setMultiVectorFlags p b = - setFlags p b . MultiVector.deconsPrim . mvecDenumber + setFlags p b . NiceVector.deconsPrim . nvecDenumber -instance MultiVector Double where +instance NiceVector Double where setMultiVectorFlags p b = - setFlags p b . MultiVector.deconsPrim . mvecDenumber + setFlags p b . NiceVector.deconsPrim . nvecDenumber -attachMultiVectorFlags :: - (LLVM.Positive n, Flags flags, MultiVector a) => - Id (LLVM.CodeGenFunction r (MultiVector.T n (Number flags a))) -attachMultiVectorFlags act = do +{-# DEPRECATED attachMultiVectorFlags "Use attachNiceVectorFlags instead." #-} +attachNiceVectorFlags, attachMultiVectorFlags :: + (LLVM.Positive n, Flags flags, NiceVector a) => + Id (LLVM.CodeGenFunction r (NiceVector.T n (Number flags a))) +attachMultiVectorFlags = attachNiceVectorFlags +attachNiceVectorFlags act = do mv <- act setMultiVectorFlags Proxy True mv return mv -liftMultiVectorM :: - (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, MultiVector b) => - (MultiVector.T n a -> m (MultiVector.T n b)) -> - MultiVector.T n (Number flags a) -> m (MultiVector.T n (Number flags b)) -liftMultiVectorM f = - attachMultiVectorFlags . Monad.lift mvecNumber . f . mvecDenumber +{-# DEPRECATED liftMultiVectorM "Use liftNiceVectorM instead." #-} +liftNiceVectorM, liftMultiVectorM :: + (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, NiceVector b) => + (NiceVector.T n a -> m (NiceVector.T n b)) -> + NiceVector.T n (Number flags a) -> m (NiceVector.T n (Number flags b)) +liftMultiVectorM = liftNiceVectorM +liftNiceVectorM f = + attachMultiVectorFlags . Monad.lift nvecNumber . f . nvecDenumber -liftMultiVectorM2 :: - (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, MultiVector c) => - (MultiVector.T n a -> MultiVector.T n b -> m (MultiVector.T n c)) -> - MultiVector.T n (Number flags a) -> MultiVector.T n (Number flags b) -> - m (MultiVector.T n (Number flags c)) -liftMultiVectorM2 f a b = +{-# DEPRECATED liftMultiVectorM2 "Use liftNiceVectorM2 instead." #-} +liftNiceVectorM2, liftMultiVectorM2 :: + (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, NiceVector c) => + (NiceVector.T n a -> NiceVector.T n b -> m (NiceVector.T n c)) -> + NiceVector.T n (Number flags a) -> NiceVector.T n (Number flags b) -> + m (NiceVector.T n (Number flags c)) +liftMultiVectorM2 = liftNiceVectorM2 +liftNiceVectorM2 f a b = attachMultiVectorFlags $ - Monad.lift mvecNumber $ f (mvecDenumber a) (mvecDenumber b) + Monad.lift nvecNumber $ f (nvecDenumber a) (nvecDenumber b) -instance (Flags flags, MultiVector a) => MultiVector.C (Number flags a) where - type Repr n (Number flags a) = MultiVector.Repr n a - cons = mvecNumber . MultiVector.cons . fmap deconsNumber - undef = mvecNumber MultiVector.undef - zero = mvecNumber MultiVector.zero - phi bb = fmap mvecNumber . MultiVector.phi bb . mvecDenumber - addPhi bb a b = MultiVector.addPhi bb (mvecDenumber a) (mvecDenumber b) +instance (Flags flags, NiceVector a) => NiceVector.C (Number flags a) where + type Repr n (Number flags a) = NiceVector.Repr n a + cons = nvecNumber . NiceVector.cons . fmap deconsNumber + undef = nvecNumber NiceVector.undef + zero = nvecNumber NiceVector.zero + phi bb = fmap nvecNumber . NiceVector.phi bb . nvecDenumber + addPhi bb a b = NiceVector.addPhi bb (nvecDenumber a) (nvecDenumber b) shuffle ks a b = - fmap mvecNumber $ MultiVector.shuffle ks (mvecDenumber a) (mvecDenumber b) - extract k = fmap mvNumber . MultiVector.extract k . mvecDenumber + fmap nvecNumber $ NiceVector.shuffle ks (nvecDenumber a) (nvecDenumber b) + extract k = fmap nvNumber . NiceVector.extract k . nvecDenumber insert k x = - fmap mvecNumber . MultiVector.insert k (mvDenumber x) . mvecDenumber + fmap nvecNumber . NiceVector.insert k (nvDenumber x) . nvecDenumber instance - (Flags flags, MultiVector a, MultiVector.IntegerConstant a) => - MultiVector.IntegerConstant (Number flags a) where - fromInteger' = mvecNumber . MultiVector.fromInteger' + (Flags flags, NiceVector a, NiceVector.IntegerConstant a) => + NiceVector.IntegerConstant (Number flags a) where + fromInteger' = nvecNumber . NiceVector.fromInteger' instance - (Flags flags, MultiVector a, MultiVector.RationalConstant a) => - MultiVector.RationalConstant (Number flags a) where - fromRational' = mvecNumber . MultiVector.fromRational' + (Flags flags, NiceVector a, NiceVector.RationalConstant a) => + NiceVector.RationalConstant (Number flags a) where + fromRational' = nvecNumber . NiceVector.fromRational' instance - (Flags flags, MultiVector a, MultiVector.Additive a) => - MultiVector.Additive (Number flags a) where - add = liftMultiVectorM2 MultiVector.add - sub = liftMultiVectorM2 MultiVector.sub - neg = liftMultiVectorM MultiVector.neg + (Flags flags, NiceVector a, NiceVector.Additive a) => + NiceVector.Additive (Number flags a) where + add = liftNiceVectorM2 NiceVector.add + sub = liftNiceVectorM2 NiceVector.sub + neg = liftNiceVectorM NiceVector.neg instance - (Flags flags, MultiVector a, MultiVector.PseudoRing a) => - MultiVector.PseudoRing (Number flags a) where - mul = liftMultiVectorM2 MultiVector.mul + (Flags flags, NiceVector a, NiceVector.PseudoRing a) => + NiceVector.PseudoRing (Number flags a) where + mul = liftNiceVectorM2 NiceVector.mul instance - (Flags flags, MultiVector a, MultiVector.Field a) => - MultiVector.Field (Number flags a) where - fdiv = liftMultiVectorM2 MultiVector.fdiv + (Flags flags, NiceVector a, NiceVector.Field a) => + NiceVector.Field (Number flags a) where + fdiv = liftNiceVectorM2 NiceVector.fdiv {- -type instance MultiValue.Scalar (Number flags a) = - Number flags (MultiValue.Scalar a) +type instance NiceValue.Scalar (Number flags a) = + Number flags (NiceValue.Scalar a) instance - (Flags flags, MultiVector a, MultiVector.PseudoModule a) => - MultiVector.PseudoModule (Number flags a) where - scale = liftMultiVectorM2 MultiVector.mul + (Flags flags, NiceVector a, NiceVector.PseudoModule a) => + NiceVector.PseudoModule (Number flags a) where + scale = liftNiceVectorM2 NiceVector.mul -} instance - (Flags flags, MultiVector a, MultiVector.Real a) => - MultiVector.Real (Number flags a) where - min = liftMultiVectorM2 MultiVector.min - max = liftMultiVectorM2 MultiVector.max - abs = liftMultiVectorM MultiVector.abs - signum = liftMultiVectorM MultiVector.signum + (Flags flags, NiceVector a, NiceVector.Real a) => + NiceVector.Real (Number flags a) where + min = liftNiceVectorM2 NiceVector.min + max = liftNiceVectorM2 NiceVector.max + abs = liftNiceVectorM NiceVector.abs + signum = liftNiceVectorM NiceVector.signum instance - (Flags flags, MultiVector a, MultiVector.Fraction a) => - MultiVector.Fraction (Number flags a) where - truncate = liftMultiVectorM MultiVector.truncate - fraction = liftMultiVectorM MultiVector.fraction + (Flags flags, NiceVector a, NiceVector.Fraction a) => + NiceVector.Fraction (Number flags a) where + truncate = liftNiceVectorM NiceVector.truncate + fraction = liftNiceVectorM NiceVector.fraction instance - (Flags flags, MultiVector a, MultiVector.Algebraic a) => - MultiVector.Algebraic (Number flags a) where - sqrt = liftMultiVectorM MultiVector.sqrt + (Flags flags, NiceVector a, NiceVector.Algebraic a) => + NiceVector.Algebraic (Number flags a) where + sqrt = liftNiceVectorM NiceVector.sqrt instance - (Flags flags, MultiVector a, MultiVector.Transcendental a) => - MultiVector.Transcendental (Number flags a) where - pi = fmap mvecNumber MultiVector.pi - sin = liftMultiVectorM MultiVector.sin - cos = liftMultiVectorM MultiVector.cos - exp = liftMultiVectorM MultiVector.exp - log = liftMultiVectorM MultiVector.log - pow = liftMultiVectorM2 MultiVector.pow + (Flags flags, NiceVector a, NiceVector.Transcendental a) => + NiceVector.Transcendental (Number flags a) where + pi = fmap nvecNumber NiceVector.pi + sin = liftNiceVectorM NiceVector.sin + cos = liftNiceVectorM NiceVector.cos + exp = liftNiceVectorM NiceVector.exp + log = liftNiceVectorM NiceVector.log + pow = liftNiceVectorM2 NiceVector.pow instance - (Flags flags, MultiVector a, MultiVector.Select a) => - MultiVector.Select (Number flags a) where - select = liftMultiVectorM2 . MultiVector.select + (Flags flags, NiceVector a, NiceVector.Select a) => + NiceVector.Select (Number flags a) where + select = liftNiceVectorM2 . NiceVector.select instance - (Flags flags, MultiVector a, MultiVector.Comparison a) => - MultiVector.Comparison (Number flags a) where - cmp p a b = MultiVector.cmp p (mvecDenumber a) (mvecDenumber b) + (Flags flags, NiceVector a, NiceVector.Comparison a) => + NiceVector.Comparison (Number flags a) where + cmp p a b = NiceVector.cmp p (nvecDenumber a) (nvecDenumber b) instance - (Flags flags, MultiVector a, MultiVector.FloatingComparison a) => - MultiVector.FloatingComparison (Number flags a) where - fcmp p a b = MultiVector.fcmp p (mvecDenumber a) (mvecDenumber b) + (Flags flags, NiceVector a, NiceVector.FloatingComparison a) => + NiceVector.FloatingComparison (Number flags a) where + fcmp p a b = NiceVector.fcmp p (nvecDenumber a) (nvecDenumber b) diff --git a/src/LLVM/Extra/Memory.hs b/src/LLVM/Extra/Memory.hs --- a/src/LLVM/Extra/Memory.hs +++ b/src/LLVM/Extra/Memory.hs @@ -12,8 +12,8 @@ loadNewtype, storeNewtype, decomposeNewtype, composeNewtype, ) where -import qualified LLVM.Extra.Multi.Vector as MultiVector -import qualified LLVM.Extra.Multi.Value.Private as MultiValue +import qualified LLVM.Extra.Nice.Vector as NiceVector +import qualified LLVM.Extra.Nice.Value.Private as NiceValue import qualified LLVM.Extra.Scalar as Scalar import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Struct as Struct @@ -365,26 +365,26 @@ -- redundant IsType and IsSized constraints required for loopy instance instance - (IsType (Struct (MultiValue.Repr a)), - IsSized (Struct (MultiValue.Repr a)), - MultiValue.C a, C (MultiValue.Repr a)) => - C (MultiValue.T a) where - type Struct (MultiValue.T a) = Struct (MultiValue.Repr a) - load = fmap MultiValue.Cons . load - store (MultiValue.Cons a) = store a - decompose = fmap MultiValue.Cons . decompose - compose (MultiValue.Cons a) = compose a + (IsType (Struct (NiceValue.Repr a)), + IsSized (Struct (NiceValue.Repr a)), + NiceValue.C a, C (NiceValue.Repr a)) => + C (NiceValue.T a) where + type Struct (NiceValue.T a) = Struct (NiceValue.Repr a) + load = fmap NiceValue.Cons . load + store (NiceValue.Cons a) = store a + decompose = fmap NiceValue.Cons . decompose + compose (NiceValue.Cons a) = compose a instance - (IsType (Struct (MultiVector.Repr n a)), - IsSized (Struct (MultiVector.Repr n a)), - TypeNum.Positive n, MultiVector.C a, C (MultiVector.Repr n a)) => - C (MultiVector.T n a) where - type Struct (MultiVector.T n a) = Struct (MultiVector.Repr n a) - load = fmap MultiVector.Cons . load - store (MultiVector.Cons a) = store a - decompose = fmap MultiVector.Cons . decompose - compose (MultiVector.Cons a) = compose a + (IsType (Struct (NiceVector.Repr n a)), + IsSized (Struct (NiceVector.Repr n a)), + TypeNum.Positive n, NiceVector.C a, C (NiceVector.Repr n a)) => + C (NiceVector.T n a) where + type Struct (NiceVector.T n a) = Struct (NiceVector.Repr n a) + load = fmap NiceVector.Cons . load + store (NiceVector.Cons a) = store a + decompose = fmap NiceVector.Cons . decompose + compose (NiceVector.Cons a) = compose a diff --git a/src/LLVM/Extra/Multi/Class.hs b/src/LLVM/Extra/Multi/Class.hs --- a/src/LLVM/Extra/Multi/Class.hs +++ b/src/LLVM/Extra/Multi/Class.hs @@ -1,170 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module LLVM.Extra.Multi.Class where - -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Multi.Vector as MultiVector -import qualified LLVM.Extra.Arithmetic as A - -import qualified LLVM.Core as LLVM - -import qualified Type.Data.Num.Decimal as TypeNum - - -class C value where - type Size value - switch :: - f MultiValue.T -> - f (MultiVector.T (Size value)) -> - f value - -instance C MultiValue.T where - type Size MultiValue.T = TypeNum.D1 - switch x _ = x - -instance (TypeNum.Positive n) => C (MultiVector.T n) where - type Size (MultiVector.T n) = n - switch _ x = x - - -newtype Const a value = Const {getConst :: value a} - -undef :: - (C value, Size value ~ n, TypeNum.Positive n, MultiVector.C a) => - value a -undef = - getConst $ - switch - (Const MultiValue.undef) - (Const MultiVector.undef) - -zero :: - (C value, Size value ~ n, TypeNum.Positive n, MultiVector.C a) => - value a -zero = - getConst $ - switch - (Const MultiValue.zero) - (Const MultiVector.zero) - - -newtype - Op0 r a value = - Op0 {runOp0 :: LLVM.CodeGenFunction r (value a)} - -newtype - Op1 r a b value = - Op1 {runOp1 :: value a -> LLVM.CodeGenFunction r (value b)} - -newtype - Op2 r a b c value = - Op2 {runOp2 :: value a -> value b -> LLVM.CodeGenFunction r (value c)} - -add, sub :: - (TypeNum.Positive n, MultiVector.Additive a, - n ~ Size value, C value) => - value a -> value a -> LLVM.CodeGenFunction r (value a) -add = runOp2 $ switch (Op2 A.add) (Op2 A.add) -sub = runOp2 $ switch (Op2 A.sub) (Op2 A.sub) - -neg :: - (TypeNum.Positive n, MultiVector.Additive a, - n ~ Size value, C value) => - value a -> LLVM.CodeGenFunction r (value a) -neg = runOp1 $ switch (Op1 A.neg) (Op1 A.neg) - - -mul :: - (TypeNum.Positive n, MultiVector.PseudoRing a, - n ~ Size value, C value) => - value a -> value a -> LLVM.CodeGenFunction r (value a) -mul = runOp2 $ switch (Op2 A.mul) (Op2 A.mul) -fdiv :: - (TypeNum.Positive n, MultiVector.Field a, - n ~ Size value, C value) => - value a -> value a -> LLVM.CodeGenFunction r (value a) -fdiv = runOp2 $ switch (Op2 A.fdiv) (Op2 A.fdiv) - -scale :: - (TypeNum.Positive n, MultiVector.PseudoModule v, - n ~ Size value, C value) => - value (MultiValue.Scalar v) -> value v -> LLVM.CodeGenFunction r (value v) -scale = runOp2 $ switch (Op2 A.scale) (Op2 A.scale) - -min, max :: - (TypeNum.Positive n, MultiVector.Real a, - n ~ Size value, C value) => - value a -> value a -> LLVM.CodeGenFunction r (value a) -min = runOp2 $ switch (Op2 A.min) (Op2 A.min) -max = runOp2 $ switch (Op2 A.max) (Op2 A.max) - -abs, signum :: - (TypeNum.Positive n, MultiVector.Real a, - n ~ Size value, C value) => - value a -> LLVM.CodeGenFunction r (value a) -abs = runOp1 $ switch (Op1 A.abs) (Op1 A.abs) -signum = runOp1 $ switch (Op1 A.signum) (Op1 A.signum) - -truncate, fraction :: - (TypeNum.Positive n, MultiVector.Fraction a, - n ~ Size value, C value) => - value a -> LLVM.CodeGenFunction r (value a) -truncate = runOp1 $ switch (Op1 A.truncate) (Op1 A.truncate) -fraction = runOp1 $ switch (Op1 A.fraction) (Op1 A.fraction) - -sqrt :: - (TypeNum.Positive n, MultiVector.Algebraic a, - n ~ Size value, C value) => - value a -> LLVM.CodeGenFunction r (value a) -sqrt = runOp1 $ switch (Op1 A.sqrt) (Op1 A.sqrt) - -pi :: - (TypeNum.Positive n, MultiVector.Transcendental a, - n ~ Size value, C value) => - LLVM.CodeGenFunction r (value a) -pi = runOp0 $ switch (Op0 A.pi) (Op0 A.pi) - -sin, cos, exp, log :: - (TypeNum.Positive n, MultiVector.Transcendental a, - n ~ Size value, C value) => - value a -> LLVM.CodeGenFunction r (value a) -sin = runOp1 $ switch (Op1 A.sin) (Op1 A.sin) -cos = runOp1 $ switch (Op1 A.cos) (Op1 A.cos) -exp = runOp1 $ switch (Op1 A.exp) (Op1 A.exp) -log = runOp1 $ switch (Op1 A.log) (Op1 A.log) - -pow :: - (TypeNum.Positive n, MultiVector.Transcendental a, - n ~ Size value, C value) => - value a -> value a -> LLVM.CodeGenFunction r (value a) -pow = runOp2 $ switch (Op2 A.pow) (Op2 A.pow) - - -cmp :: - (TypeNum.Positive n, MultiVector.Comparison a, - n ~ Size value, C value) => - LLVM.CmpPredicate -> - value a -> value a -> LLVM.CodeGenFunction r (value Bool) -cmp p = runOp2 $ switch (Op2 $ A.cmp p) (Op2 $ A.cmp p) - -fcmp :: - (TypeNum.Positive n, MultiVector.FloatingComparison a, - n ~ Size value, C value) => - LLVM.FPPredicate -> - value a -> value a -> LLVM.CodeGenFunction r (value Bool) -fcmp p = runOp2 $ switch (Op2 $ A.fcmp p) (Op2 $ A.fcmp p) - - -and, or, xor :: - (TypeNum.Positive n, MultiVector.Logic a, - n ~ Size value, C value) => - value a -> value a -> LLVM.CodeGenFunction r (value a) -and = runOp2 $ switch (Op2 A.and) (Op2 A.and) -or = runOp2 $ switch (Op2 A.or) (Op2 A.or) -xor = runOp2 $ switch (Op2 A.xor) (Op2 A.xor) +module LLVM.Extra.Multi.Class + {-# DEPRECATED "Use LLVM.Extra.Nice.Class instead." #-} + (module LLVM.Extra.Nice.Class) where -inv :: - (TypeNum.Positive n, MultiVector.Logic a, - n ~ Size value, C value) => - value a -> LLVM.CodeGenFunction r (value a) -inv = runOp1 $ switch (Op1 A.inv) (Op1 A.inv) +import LLVM.Extra.Nice.Class diff --git a/src/LLVM/Extra/Multi/Iterator.hs b/src/LLVM/Extra/Multi/Iterator.hs --- a/src/LLVM/Extra/Multi/Iterator.hs +++ b/src/LLVM/Extra/Multi/Iterator.hs @@ -1,95 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -module LLVM.Extra.Multi.Iterator ( - takeWhile, - countDown, - take, - Enum(..), - ) where - -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.Iterator as Iter -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Tuple as Tuple -import qualified LLVM.Extra.MaybePrivate as Maybe -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Control as C - -import qualified LLVM.Core as LLVM -import LLVM.Core (CodeGenFunction) - -import Control.Applicative (liftA2) - -import qualified Data.Enum.Storable as Enum - -import qualified Prelude as P -import Prelude hiding (take, takeWhile, Enum, enumFrom, enumFromTo) - - - -takeWhile :: - (a -> CodeGenFunction r (MultiValue.T Bool)) -> - Iter.T r a -> Iter.T r a -takeWhile p = Iter.takeWhile (fmap unpackBool . p) - -unpackBool :: MultiValue.T Bool -> LLVM.Value Bool -unpackBool (MultiValue.Cons b) = b - -countDown :: - (MultiValue.Additive i, MultiValue.Comparison i, - MultiValue.IntegerConstant i) => - MultiValue.T i -> Iter.T r (MultiValue.T i) -countDown len = - takeWhile (MultiValue.cmp LLVM.CmpLT MultiValue.zero) $ - Iter.iterate MultiValue.dec len - -take :: - (MultiValue.Additive i, MultiValue.Comparison i, - MultiValue.IntegerConstant i) => - MultiValue.T i -> Iter.T r a -> Iter.T r a -take len xs = liftA2 const xs (countDown len) - - -class (MultiValue.C a) => Enum a where - succ, pred :: MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T a) - enumFrom :: MultiValue.T a -> Iter.T r (MultiValue.T a) - enumFromTo :: MultiValue.T a -> MultiValue.T a -> Iter.T r (MultiValue.T a) - -instance - (LLVM.IsInteger w, SoV.IntegerConstant w, Num w, - LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) => - Enum (Enum.T w e) where - succ = MultiValue.succ - pred = MultiValue.pred - enumFrom = Iter.iterate MultiValue.succ - {- | - More complicated than 'enumFromToSimple' - but works also for e.g. [0 .. (0xFFFF::Word16)]. - -} - enumFromTo from to = - Iter.takeWhileJust $ - Iter.iterate (Maybe.maybeArg Tuple.undef (succMax to)) (Maybe.just from) - -succMax :: - (LLVM.IsInteger w, SoV.IntegerConstant w, Num w, - LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) => - MultiValue.T (Enum.T w e) -> - MultiValue.T (Enum.T w e) -> - LLVM.CodeGenFunction r (Maybe.T (MultiValue.T (Enum.T w e))) -succMax to e = do - MultiValue.Cons less <- MultiValue.cmpEnum A.CmpLT e to - C.ifThen less (Maybe.nothing Tuple.undef) $ - fmap Maybe.just $ MultiValue.succ e +module LLVM.Extra.Multi.Iterator + {-# DEPRECATED "Use LLVM.Extra.Nice.Iterator instead." #-} + (module LLVM.Extra.Nice.Iterator) where -{- | -Warning: For [0 .. (0xFFFF::Word16)] -it would compute an undefined @0xFFFF+1@. -In modulo arithmetic it would enter an infinite loop. --} -_enumFromToSimple :: - (LLVM.IsInteger w, SoV.IntegerConstant w, Num w, - LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) => - MultiValue.T (Enum.T w e) -> - MultiValue.T (Enum.T w e) -> - Iter.T r (MultiValue.T (Enum.T w e)) -_enumFromToSimple from to = - takeWhile (MultiValue.cmpEnum LLVM.CmpGE to) $ enumFrom from +import LLVM.Extra.Nice.Iterator diff --git a/src/LLVM/Extra/Multi/Value.hs b/src/LLVM/Extra/Multi/Value.hs --- a/src/LLVM/Extra/Multi/Value.hs +++ b/src/LLVM/Extra/Multi/Value.hs @@ -1,8 +1,5 @@ -module LLVM.Extra.Multi.Value ( - module LLVM.Extra.Multi.Value.Private, - Array(..), withArraySize, extractArrayValue, insertArrayValue, - ) where +module LLVM.Extra.Multi.Value + {-# DEPRECATED "Use LLVM.Extra.Nice.Value instead." #-} + (module LLVM.Extra.Nice.Value) where -import LLVM.Extra.Multi.Vector.Instance () -import LLVM.Extra.Multi.Value.Array -import LLVM.Extra.Multi.Value.Private +import LLVM.Extra.Nice.Value diff --git a/src/LLVM/Extra/Multi/Value/Array.hs b/src/LLVM/Extra/Multi/Value/Array.hs deleted file mode 100644 --- a/src/LLVM/Extra/Multi/Value/Array.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -module LLVM.Extra.Multi.Value.Array where - -import qualified LLVM.Extra.Memory as Memory -import qualified LLVM.Extra.Multi.Value.Marshal as Marshal -import qualified LLVM.Extra.Multi.Value.Private as MultiValue -import LLVM.Extra.Multi.Value.Private (Repr) - -import qualified LLVM.Core as LLVM - -import qualified Type.Data.Num.Decimal as TypeNum -import qualified Type.Data.Num.Decimal.Number as Dec -import Type.Base.Proxy (Proxy(Proxy)) - -import Control.Applicative (Applicative(pure, (<*>))) - -import qualified Data.Traversable as Trav -import qualified Data.Foldable as Fold -import Data.Functor.Identity (Identity(Identity, runIdentity)) -import Data.Functor ((<$>)) - -import Prelude2010 -import Prelude () - - - -newtype Array n a = Array [a] - deriving (Eq, Show) - -instance (Dec.Integer n) => Functor (Array n) where - fmap f (Array xs) = Array (map f xs) - -instance (Dec.Integer n) => Applicative (Array n) where - pure x = - runIdentity $ withArraySize $ - \n -> Identity $ Array $ replicate (Dec.integralFromProxy n) x - Array fs <*> Array xs = Array $ zipWith id fs xs - -instance (Dec.Integer n) => Fold.Foldable (Array n) where - foldMap f (Array xs) = Fold.foldMap f xs - -instance (Dec.Integer n) => Trav.Traversable (Array n) where - traverse f (Array xs) = Array <$> Trav.traverse f xs - -withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a) -withArraySize f = f Proxy - - -instance (TypeNum.Natural n, Marshal.C a) => MultiValue.C (Array n a) where - type Repr (Array n a) = LLVM.Value (LLVM.Array n (Marshal.Struct a)) - cons (Array xs) = MultiValue.consPrimitive $ LLVM.Array $ map Marshal.pack xs - undef = MultiValue.undefPrimitive - zero = MultiValue.zeroPrimitive - phi = MultiValue.phiPrimitive - addPhi = MultiValue.addPhiPrimitive - -instance - (TypeNum.Natural n, Marshal.C a, - Dec.Natural (n Dec.:*: LLVM.SizeOf (Marshal.Struct a))) => - Marshal.C (Array n a) where - pack (Array xs) = LLVM.Array $ map Marshal.pack xs - unpack (LLVM.Array xs) = Array $ map Marshal.unpack xs - -extractArrayValue :: - (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) => - i -> MultiValue.T (Array n a) -> - LLVM.CodeGenFunction r (MultiValue.T a) -extractArrayValue i (MultiValue.Cons arr) = - MultiValue.Cons <$> (Memory.decompose =<< LLVM.extractvalue arr i) - -insertArrayValue :: - (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) => - i -> MultiValue.T a -> MultiValue.T (Array n a) -> - LLVM.CodeGenFunction r (MultiValue.T (Array n a)) -insertArrayValue i (MultiValue.Cons a) (MultiValue.Cons arr) = - MultiValue.Cons <$> (flip (LLVM.insertvalue arr) i =<< Memory.compose a) diff --git a/src/LLVM/Extra/Multi/Value/Marshal.hs b/src/LLVM/Extra/Multi/Value/Marshal.hs --- a/src/LLVM/Extra/Multi/Value/Marshal.hs +++ b/src/LLVM/Extra/Multi/Value/Marshal.hs @@ -1,221 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{- | -Transfer values between Haskell and JIT generated code -in an LLVM-compatible format. -E.g. 'Bool' is stored as 'i1' and occupies a byte, -@'Vector' n 'Bool'@ is stored as a bit vector, -@'Vector' n 'Word8'@ is stored in an order depending on machine endianess, -and Haskell tuples are stored as LLVM structs. --} -module LLVM.Extra.Multi.Value.Marshal ( - C(..), - Struct, - peek, - poke, - - VectorStruct, - Vector(..), - - with, - EE.alloca, - ) where - -import qualified LLVM.Extra.Multi.Vector as MultiVector -import qualified LLVM.Extra.Multi.Value.Private as MultiValue -import qualified LLVM.Extra.Memory as Memory -import LLVM.Extra.Multi.Vector.Instance () - -import qualified LLVM.ExecutionEngine as EE -import qualified LLVM.Core as LLVM - -import qualified Type.Data.Num.Decimal as TypeNum - -import qualified Control.Functor.HT as FuncHT -import Control.Applicative (liftA2, liftA3, (<$>)) - -import Foreign.Storable (Storable) -import Foreign.StablePtr (StablePtr) -import Foreign.Ptr (FunPtr, Ptr) - -import Data.Complex (Complex((:+))) -import Data.Word (Word8, Word16, Word32, Word64, Word) -import Data.Int (Int8, Int16, Int32, Int64) - - - -peek :: - (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> IO a -peek ptr = unpack <$> EE.peek ptr - -poke :: - (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO () -poke ptr = EE.poke ptr . pack - - -type Struct a = Memory.Struct (MultiValue.Repr a) - -class - (MultiValue.C a, Memory.C (MultiValue.Repr a), - EE.Marshal (Struct a), LLVM.IsConst (Struct a)) => - C a where - pack :: a -> Struct a - unpack :: Struct a -> a - -instance C Bool where pack = id; unpack = id -instance C Float where pack = id; unpack = id -instance C Double where pack = id; unpack = id -instance C Word where pack = id; unpack = id -instance C Word8 where pack = id; unpack = id -instance C Word16 where pack = id; unpack = id -instance C Word32 where pack = id; unpack = id -instance C Word64 where pack = id; unpack = id -instance C Int where pack = id; unpack = id -instance C Int8 where pack = id; unpack = id -instance C Int16 where pack = id; unpack = id -instance C Int32 where pack = id; unpack = id -instance C Int64 where pack = id; unpack = id - -instance (Storable a) => C (Ptr a) where pack = id; unpack = id -instance (LLVM.IsType a) => C (LLVM.Ptr a) where pack = id; unpack = id -instance (LLVM.IsFunction a) => C (FunPtr a) where pack = id; unpack = id -instance C (StablePtr a) where pack = id; unpack = id - -instance C () where - pack = LLVM.Struct - unpack (LLVM.Struct unit) = unit - -instance (C a, C b) => C (a,b) where - pack (a,b) = LLVM.consStruct (pack a) (pack b) - unpack = LLVM.uncurryStruct $ \a b -> (unpack a, unpack b) - -instance (C a, C b, C c) => C (a,b,c) where - pack (a,b,c) = LLVM.consStruct (pack a) (pack b) (pack c) - unpack = LLVM.uncurryStruct $ \a b c -> (unpack a, unpack b, unpack c) - -instance (C a, C b, C c, C d) => C (a,b,c,d) where - pack (a,b,c,d) = LLVM.consStruct (pack a) (pack b) (pack c) (pack d) - unpack = - LLVM.uncurryStruct $ \a b c d -> (unpack a, unpack b, unpack c, unpack d) - - -instance (C a) => C (Complex a) where - pack (a:+b) = LLVM.consStruct (pack a) (pack b) - unpack = LLVM.uncurryStruct $ \a b -> unpack a :+ unpack b - - - -type VectorStruct n a = Memory.Struct (MultiVector.Repr n a) - -class - (TypeNum.Positive n, C a, - MultiVector.C a, Memory.C (MultiVector.Repr n a), - EE.Marshal (VectorStruct n a), - LLVM.IsConst (VectorStruct n a)) => - Vector n a where - packVector :: LLVM.Vector n a -> VectorStruct n a - unpackVector :: VectorStruct n a -> LLVM.Vector n a - -instance (TypeNum.Positive n, Vector n a) => C (LLVM.Vector n a) where - pack = packVector; unpack = unpackVector - - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) => - Vector n Bool where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) => - Vector n Float where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) => - Vector n Double where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) => - Vector n Word where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) => - Vector n Word8 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) => - Vector n Word16 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) => - Vector n Word32 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) => - Vector n Word64 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) => - Vector n Int where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) => - Vector n Int8 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) => - Vector n Int16 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) => - Vector n Int32 where - packVector = id - unpackVector = id - -instance - (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) => - Vector n Int64 where - packVector = id - unpackVector = id - -instance (Vector n a, Vector n b) => Vector n (a,b) where - packVector x = - case FuncHT.unzip x of - (a,b) -> LLVM.consStruct (packVector a) (packVector b) - unpackVector = LLVM.uncurryStruct $ \a b -> - liftA2 (,) (unpackVector a) (unpackVector b) - -instance (Vector n a, Vector n b, Vector n c) => Vector n (a,b,c) where - packVector x = - case FuncHT.unzip3 x of - (a,b,c) -> LLVM.consStruct (packVector a) (packVector b) (packVector c) - unpackVector = LLVM.uncurryStruct $ \a b c -> - liftA3 (,,) (unpackVector a) (unpackVector b) (unpackVector c) - +module LLVM.Extra.Multi.Value.Marshal + {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Marshal instead." #-} + (module LLVM.Extra.Nice.Value.Marshal) where -with :: (C a) => a -> (LLVM.Ptr (Struct a) -> IO b) -> IO b -with a act = EE.alloca $ \ptr -> poke ptr a >> act ptr +import LLVM.Extra.Nice.Value.Marshal diff --git a/src/LLVM/Extra/Multi/Value/Private.hs b/src/LLVM/Extra/Multi/Value/Private.hs deleted file mode 100644 --- a/src/LLVM/Extra/Multi/Value/Private.hs +++ /dev/null @@ -1,1491 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module LLVM.Extra.Multi.Value.Private where - -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Control as C -import qualified LLVM.Extra.Tuple as Tuple -import qualified LLVM.Extra.Struct as Struct - -import qualified LLVM.ExecutionEngine as EE -import qualified LLVM.Core as LLVM -import LLVM.Core (WordN, IntN, ) - -import qualified Type.Data.Num.Decimal.Number as Dec - -import qualified Foreign.Storable.Record.Tuple as StoreTuple -import Foreign.StablePtr (StablePtr, ) -import Foreign.Ptr (Ptr, FunPtr, ) - -import qualified Control.Monad.HT as Monad -import qualified Control.Functor.HT as FuncHT -import Control.Monad (Monad, return, fmap, (>>), ) -import Data.Functor (Functor, ) - -import qualified Data.Tuple.HT as TupleHT -import qualified Data.Tuple as Tup -import qualified Data.EnumBitSet as EnumBitSet -import qualified Data.Enum.Storable as Enum -import qualified Data.Bool8 as Bool8 -import Data.Complex (Complex((:+))) -import Data.Tagged (Tagged(Tagged, unTagged)) -import Data.Function (id, (.), ($), ) -import Data.Maybe (Maybe(Nothing,Just), ) -import Data.Bool (Bool(False,True), ) -import Data.Word (Word8, Word16, Word32, Word64, Word) -import Data.Int (Int8, Int16, Int32, Int64, Int) -import Data.Bool8 (Bool8) - -import qualified Prelude as P -import Prelude (Float, Double, Integer, Rational, ) - - -newtype T a = Cons (Repr a) - - -class C a where - type Repr a - cons :: a -> T a - undef :: T a - zero :: T a - phi :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) - addPhi :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () - -instance C Bool where - type Repr Bool = LLVM.Value Bool - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Float where - type Repr Float = LLVM.Value Float - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Double where - type Repr Double = LLVM.Value Double - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Word where - type Repr Word = LLVM.Value Word - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Word8 where - type Repr Word8 = LLVM.Value Word8 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Word16 where - type Repr Word16 = LLVM.Value Word16 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Word32 where - type Repr Word32 = LLVM.Value Word32 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Word64 where - type Repr Word64 = LLVM.Value Word64 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance (Dec.Positive n) => C (LLVM.WordN n) where - type Repr (LLVM.WordN n) = LLVM.Value (LLVM.WordN n) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Int where - type Repr Int = LLVM.Value Int - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Int8 where - type Repr Int8 = LLVM.Value Int8 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Int16 where - type Repr Int16 = LLVM.Value Int16 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Int32 where - type Repr Int32 = LLVM.Value Int32 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C Int64 where - type Repr Int64 = LLVM.Value Int64 - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance (Dec.Positive n) => C (LLVM.IntN n) where - type Repr (LLVM.IntN n) = LLVM.Value (LLVM.IntN n) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance (LLVM.IsType a) => C (LLVM.Ptr a) where - type Repr (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C (Ptr a) where - type Repr (Ptr a) = LLVM.Value (Ptr a) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance (LLVM.IsFunction a) => C (FunPtr a) where - type Repr (FunPtr a) = LLVM.Value (FunPtr a) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -instance C (StablePtr a) where - type Repr (StablePtr a) = LLVM.Value (StablePtr a) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - - -cast :: (Repr a ~ Repr b) => T a -> T b -cast (Cons a) = Cons a - - -consPrimitive :: - (LLVM.IsConst al, LLVM.Value al ~ Repr a) => - al -> T a -consPrimitive = Cons . LLVM.valueOf - -undefPrimitive, zeroPrimitive :: - (LLVM.IsType al, LLVM.Value al ~ Repr a) => - T a -undefPrimitive = Cons $ LLVM.value LLVM.undef -zeroPrimitive = Cons $ LLVM.value LLVM.zero - -phiPrimitive :: - (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) => - LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) -phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a - -addPhiPrimitive :: - (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) => - LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () -addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b - - -consTuple :: (Tuple.Value a, Repr a ~ Tuple.ValueOf a) => a -> T a -consTuple = Cons . Tuple.valueOf - -undefTuple :: (Repr a ~ al, Tuple.Undefined al) => T a -undefTuple = Cons Tuple.undef - -zeroTuple :: (Repr a ~ al, Tuple.Zero al) => T a -zeroTuple = Cons Tuple.zero - -phiTuple :: - (Repr a ~ al, Tuple.Phi al) => - LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) -phiTuple bb (Cons a) = fmap Cons $ Tuple.phi bb a - -addPhiTuple :: - (Repr a ~ al, Tuple.Phi al) => - LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () -addPhiTuple bb (Cons a) (Cons b) = Tuple.addPhi bb a b - - -instance C () where - type Repr () = () - cons = consUnit - undef = undefUnit - zero = zeroUnit - phi = phiUnit - addPhi = addPhiUnit - -consUnit :: (Repr a ~ ()) => a -> T a -consUnit _ = Cons () - -undefUnit :: (Repr a ~ ()) => T a -undefUnit = Cons () - -zeroUnit :: (Repr a ~ ()) => T a -zeroUnit = Cons () - -phiUnit :: - (Repr a ~ ()) => - LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) -phiUnit _bb (Cons ()) = return $ Cons () - -addPhiUnit :: - (Repr a ~ ()) => - LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () -addPhiUnit _bb (Cons ()) (Cons ()) = return () - - -instance C Bool8 where - type Repr Bool8 = LLVM.Value Bool - cons = consPrimitive . Bool8.toBool - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -boolPFrom8 :: T Bool8 -> T Bool -boolPFrom8 (Cons b) = Cons b - -bool8FromP :: T Bool -> T Bool8 -bool8FromP (Cons b) = Cons b - -intFromBool8 :: (NativeInteger i ir) => T Bool8 -> LLVM.CodeGenFunction r (T i) -intFromBool8 = liftM LLVM.zadapt - -floatFromBool8 :: - (NativeFloating a ar) => T Bool8 -> LLVM.CodeGenFunction r (T a) -floatFromBool8 = liftM LLVM.uitofp - - -instance - (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e) => - C (Enum.T w e) where - type Repr (Enum.T w e) = LLVM.Value w - cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - -toEnum :: - (Repr w ~ LLVM.Value w) => - T w -> T (Enum.T w e) -toEnum (Cons w) = Cons w - -fromEnum :: - (Repr w ~ LLVM.Value w) => - T (Enum.T w e) -> T w -fromEnum (Cons w) = Cons w - -succ, pred :: - (LLVM.IsArithmetic w, SoV.IntegerConstant w) => - T (Enum.T w e) -> LLVM.CodeGenFunction r (T (Enum.T w e)) -succ = liftM $ \w -> A.add w A.one -pred = liftM $ \w -> A.sub w A.one - --- cannot be an instance of 'Comparison' because there is no 'Real' instance -cmpEnum :: - (LLVM.CmpRet w, LLVM.IsPrimitive w) => - LLVM.CmpPredicate -> T (Enum.T w a) -> T (Enum.T w a) -> - LLVM.CodeGenFunction r (T Bool) -cmpEnum = liftM2 . LLVM.cmp - - -class (C a) => Bounded a where - minBound, maxBound :: T a - -instance - (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e, P.Bounded e) => - Bounded (Enum.T w e) where - minBound = cons P.minBound - maxBound = cons P.maxBound - - -instance (LLVM.IsInteger w, LLVM.IsConst w) => C (EnumBitSet.T w i) where - type Repr (EnumBitSet.T w i) = LLVM.Value w - cons = consPrimitive . EnumBitSet.decons - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - - -instance (C a) => C (Maybe a) where - type Repr (Maybe a) = (LLVM.Value Bool, Repr a) - cons Nothing = nothing - cons (Just a) = just $ cons a - undef = toMaybe undef undef - zero = toMaybe (cons False) zero - phi bb ma = - case splitMaybe ma of - (b,a) -> Monad.lift2 toMaybe (phi bb b) (phi bb a) - addPhi bb x y = - case (splitMaybe x, splitMaybe y) of - ((xb,xa), (yb,ya)) -> - addPhi bb xb yb >> - addPhi bb xa ya - -splitMaybe :: T (Maybe a) -> (T Bool, T a) -splitMaybe (Cons (b,a)) = (Cons b, Cons a) - -toMaybe :: T Bool -> T a -> T (Maybe a) -toMaybe (Cons b) (Cons a) = Cons (b,a) - -nothing :: (C a) => T (Maybe a) -nothing = toMaybe (cons False) undef - -just :: T a -> T (Maybe a) -just = toMaybe (cons True) - - -instance (C a, C b) => C (a,b) where - type Repr (a, b) = (Repr a, Repr b) - cons (a,b) = zip (cons a) (cons b) - undef = zip undef undef - zero = zip zero zero - phi bb a = - case unzip a of - (a0,a1) -> - Monad.lift2 zip (phi bb a0) (phi bb a1) - addPhi bb a b = - case (unzip a, unzip b) of - ((a0,a1), (b0,b1)) -> - addPhi bb a0 b0 >> - addPhi bb a1 b1 - -instance (C a, C b, C c) => C (a,b,c) where - type Repr (a, b, c) = (Repr a, Repr b, Repr c) - cons (a,b,c) = zip3 (cons a) (cons b) (cons c) - undef = zip3 undef undef undef - zero = zip3 zero zero zero - phi bb a = - case unzip3 a of - (a0,a1,a2) -> - Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2) - addPhi bb a b = - case (unzip3 a, unzip3 b) of - ((a0,a1,a2), (b0,b1,b2)) -> - addPhi bb a0 b0 >> - addPhi bb a1 b1 >> - addPhi bb a2 b2 - -instance (C a, C b, C c, C d) => C (a,b,c,d) where - type Repr (a, b, c, d) = (Repr a, Repr b, Repr c, Repr d) - cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d) - undef = zip4 undef undef undef undef - zero = zip4 zero zero zero zero - phi bb a = - case unzip4 a of - (a0,a1,a2,a3) -> - Monad.lift4 zip4 (phi bb a0) (phi bb a1) (phi bb a2) (phi bb a3) - addPhi bb a b = - case (unzip4 a, unzip4 b) of - ((a0,a1,a2,a3), (b0,b1,b2,b3)) -> - addPhi bb a0 b0 >> - addPhi bb a1 b1 >> - addPhi bb a2 b2 >> - addPhi bb a3 b3 - - -fst :: T (a,b) -> T a -fst (Cons (a,_b)) = Cons a - -snd :: T (a,b) -> T b -snd (Cons (_a,b)) = Cons b - -curry :: (T (a,b) -> c) -> (T a -> T b -> c) -curry f a b = f $ zip a b - -uncurry :: (T a -> T b -> c) -> (T (a,b) -> c) -uncurry f = Tup.uncurry f . unzip - - -mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b) -mapFst f = Tup.uncurry zip . TupleHT.mapFst f . unzip - -mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1) -mapSnd f = Tup.uncurry zip . TupleHT.mapSnd f . unzip - -mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b)) -mapFstF f = fmap (Tup.uncurry zip) . FuncHT.mapFst f . unzip - -mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1)) -mapSndF f = fmap (Tup.uncurry zip) . FuncHT.mapSnd f . unzip - -swap :: T (a,b) -> T (b,a) -swap = Tup.uncurry zip . TupleHT.swap . unzip - - -fst3 :: T (a,b,c) -> T a -fst3 (Cons (a,_b,_c)) = Cons a - -snd3 :: T (a,b,c) -> T b -snd3 (Cons (_a,b,_c)) = Cons b - -thd3 :: T (a,b,c) -> T c -thd3 (Cons (_a,_b,c)) = Cons c - -curry3 :: (T (a,b,c) -> d) -> (T a -> T b -> T c -> d) -curry3 f a b c = f $ zip3 a b c - -uncurry3 :: (T a -> T b -> T c -> d) -> (T (a,b,c) -> d) -uncurry3 f = TupleHT.uncurry3 f . unzip3 - - -mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c) -mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3 - -mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c) -mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3 - -mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1) -mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3 - -mapFst3F :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b,c) -> f (T (a1,b,c)) -mapFst3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapFst3 f . unzip3 - -mapSnd3F :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0,c) -> f (T (a,b1,c)) -mapSnd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapSnd3 f . unzip3 - -mapThd3F :: (Functor f) => (T c0 -> f (T c1)) -> T (a,b,c0) -> f (T (a,b,c1)) -mapThd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapThd3 f . unzip3 - - -zip :: T a -> T b -> T (a,b) -zip (Cons a) (Cons b) = Cons (a,b) - -zip3 :: T a -> T b -> T c -> T (a,b,c) -zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c) - -zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d) -zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d) - -unzip :: T (a,b) -> (T a, T b) -unzip (Cons (a,b)) = (Cons a, Cons b) - -unzip3 :: T (a,b,c) -> (T a, T b, T c) -unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c) - -unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d) -unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d) - - -instance (C tuple) => C (StoreTuple.Tuple tuple) where - type Repr (StoreTuple.Tuple tuple) = Repr tuple - cons = tuple . cons . StoreTuple.getTuple - undef = tuple undef - zero = tuple zero - phi bb = fmap tuple . phi bb . untuple - addPhi bb a b = addPhi bb (untuple a) (untuple b) - -tuple :: T tuple -> T (StoreTuple.Tuple tuple) -tuple (Cons a) = Cons a - -untuple :: T (StoreTuple.Tuple tuple) -> T tuple -untuple (Cons a) = Cons a - - -class Struct struct where - consStruct :: (Struct.T struct ~ a) => a -> T a - undefStruct :: (Struct.T struct ~ a) => T a - zeroStruct :: (Struct.T struct ~ a) => T a - phiStruct :: (Struct.T struct ~ a) => - LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) - addPhiStruct :: (Struct.T struct ~ a) => - LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () - -instance (Struct struct) => C (Struct.T struct) where - type Repr (Struct.T struct) = Struct.T (Repr struct) - cons = consStruct - undef = undefStruct - zero = zeroStruct - phi = phiStruct - addPhi = addPhiStruct - -instance Struct () where - consStruct unit = Cons unit - undefStruct = Cons (Struct.Cons ()) - zeroStruct = Cons (Struct.Cons ()) - phiStruct _bb = return - addPhiStruct _bb _a _b = return () - -structCons :: T a -> T (Struct.T as) -> T (Struct.T (a,as)) -structCons (Cons b) (Cons (Struct.Cons bs)) = Cons (Struct.Cons (b,bs)) - -structUncons :: T (Struct.T (a,as)) -> (T a, T (Struct.T as)) -structUncons (Cons (Struct.Cons (b,bs))) = (Cons b, Cons (Struct.Cons bs)) - -instance (C a, Struct as) => Struct (a,as) where - consStruct (Struct.Cons (a,as)) = - structCons (cons a) (consStruct (Struct.Cons as)) - undefStruct = structCons undef undefStruct - zeroStruct = structCons zero zeroStruct - phiStruct bb at = - case structUncons at of - (a,as) -> Monad.lift2 structCons (phi bb a) (phiStruct bb as) - addPhiStruct bb at bt = - case (structUncons at, structUncons bt) of - ((a,as), (b,bs)) -> addPhi bb a b >> addPhiStruct bb as bs - - -instance (LLVM.IsConst a, LLVM.IsFirstClass a) => C (EE.Stored a) where - type Repr (EE.Stored a) = LLVM.Value a - cons = Cons . LLVM.valueOf . EE.getStored - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - - -instance C a => C (Tagged tag a) where - type Repr (Tagged tag a) = Repr a - cons = tag . cons . unTagged - undef = tag undef - zero = tag zero - phi bb = fmap tag . phi bb . untag - addPhi bb a b = addPhi bb (untag a) (untag b) - -tag :: T a -> T (Tagged tag a) -tag = cast - -untag :: T (Tagged tag a) -> T a -untag = cast - -liftTaggedM :: - (Monad m) => (T a -> m (T b)) -> T (Tagged tag a) -> m (T (Tagged tag b)) -liftTaggedM f = Monad.lift tag . f . untag - -liftTaggedM2 :: - (Monad m) => - (T a -> T b -> m (T c)) -> - T (Tagged tag a) -> T (Tagged tag b) -> m (T (Tagged tag c)) -liftTaggedM2 f a b = Monad.lift tag $ f (untag a) (untag b) - - -instance (C a) => C (Complex a) where - type Repr (Complex a) = Complex (Repr a) - cons (a:+b) = consComplex (cons a) (cons b) - undef = consComplex undef undef - zero = consComplex zero zero - phi bb a = - case deconsComplex a of - (a0,a1) -> - Monad.lift2 consComplex (phi bb a0) (phi bb a1) - addPhi bb a b = - case (deconsComplex a, deconsComplex b) of - ((a0,a1), (b0,b1)) -> - addPhi bb a0 b0 >> - addPhi bb a1 b1 - -consComplex :: T a -> T a -> T (Complex a) -consComplex (Cons a) (Cons b) = Cons (a:+b) - -deconsComplex :: T (Complex a) -> (T a, T a) -deconsComplex (Cons (a:+b)) = (Cons a, Cons b) - - - -class Compose multituple where - type Composed multituple - {- | - A nested 'zip'. - -} - compose :: multituple -> T (Composed multituple) - -class - (Composed (Decomposed T pattern) ~ PatternTuple pattern) => - Decompose pattern where - {- | - A nested 'unzip'. - Since it is not obvious how deep to decompose nested tuples, - you must provide a pattern of the decomposed tuple. - E.g. - - > f :: MultiValue ((a,b),(c,d)) -> - > ((MultiValue a, MultiValue b), MultiValue (c,d)) - > f = decompose ((atom,atom),atom) - -} - decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern - -type family Decomposed (f :: * -> *) pattern -type family PatternTuple pattern - - -{- | -A combination of 'compose' and 'decompose' -that let you operate on tuple multivalues as Haskell tuples. --} -modify :: - (Compose a, Decompose pattern) => - pattern -> - (Decomposed T pattern -> a) -> - T (PatternTuple pattern) -> T (Composed a) -modify p f = compose . f . decompose p - -modify2 :: - (Compose a, Decompose patternA, Decompose patternB) => - patternA -> - patternB -> - (Decomposed T patternA -> Decomposed T patternB -> a) -> - T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a) -modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b) - -modifyF :: - (Compose a, Decompose pattern, Functor f) => - pattern -> - (Decomposed T pattern -> f a) -> - T (PatternTuple pattern) -> f (T (Composed a)) -modifyF p f = fmap compose . f . decompose p - -modifyF2 :: - (Compose a, Decompose patternA, Decompose patternB, - Functor f) => - patternA -> - patternB -> - (Decomposed T patternA -> Decomposed T patternB -> f a) -> - T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a)) -modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b) - - - -instance Compose (T a) where - type Composed (T a) = a - compose = id - -instance Decompose (Atom a) where - decompose _ = id - -type instance Decomposed f (Atom a) = f a -type instance PatternTuple (Atom a) = a - -data Atom a = Atom - -atom :: Atom a -atom = Atom - - -instance Compose () where - type Composed () = () - compose = cons - -instance Decompose () where - decompose () _ = () - -type instance Decomposed f () = () -type instance PatternTuple () = () - - -instance (Compose a, Compose b) => Compose (a,b) where - type Composed (a,b) = (Composed a, Composed b) - compose = Tup.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 - -type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb) -type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb) - - -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 - -type instance Decomposed f (pa,pb,pc) = - (Decomposed f pa, Decomposed f pb, Decomposed f pc) -type instance PatternTuple (pa,pb,pc) = - (PatternTuple pa, PatternTuple pb, PatternTuple pc) - - -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) -type instance Decomposed f (pa,pb,pc,pd) = - (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd) -type instance PatternTuple (pa,pb,pc,pd) = - (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd) - - -instance (Compose tuple) => Compose (StoreTuple.Tuple tuple) where - type Composed (StoreTuple.Tuple tuple) = StoreTuple.Tuple (Composed tuple) - compose = tuple . compose . StoreTuple.getTuple - -instance (Decompose p) => Decompose (StoreTuple.Tuple p) where - decompose (StoreTuple.Tuple p) = StoreTuple.Tuple . decompose p . untuple - -type instance Decomposed f (StoreTuple.Tuple p) = - StoreTuple.Tuple (Decomposed f p) -type instance PatternTuple (StoreTuple.Tuple p) = - StoreTuple.Tuple (PatternTuple p) - - -instance (Compose a) => Compose (Tagged tag a) where - type Composed (Tagged tag a) = Tagged tag (Composed a) - compose = tag . compose . unTagged - -instance (Decompose pa) => Decompose (Tagged tag pa) where - decompose (Tagged p) = Tagged . decompose p . untag - -type instance Decomposed f (Tagged tag pa) = Tagged tag (Decomposed f pa) -type instance PatternTuple (Tagged tag pa) = Tagged tag (PatternTuple pa) - - -instance (Compose a) => Compose (Complex a) where - type Composed (Complex a) = Complex (Composed a) - compose (a:+b) = consComplex (compose a) (compose b) - -instance (Decompose pa) => Decompose (Complex pa) where - decompose (pa:+pb) = - Tup.uncurry (:+) . - TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex - -type instance Decomposed f (Complex pa) = Complex (Decomposed f pa) -type instance PatternTuple (Complex pa) = Complex (PatternTuple pa) - -realPart, imagPart :: T (Complex a) -> T a -realPart (Cons (a:+_)) = Cons a -imagPart (Cons (_:+b)) = Cons b - - - -lift1 :: (Repr a -> Repr b) -> T a -> T b -lift1 f (Cons a) = Cons $ f a - -liftM0 :: - (Monad m) => - m (Repr a) -> - m (T a) -liftM0 f = Monad.lift Cons f - -liftM :: - (Monad m) => - (Repr a -> m (Repr b)) -> - T a -> m (T b) -liftM f (Cons a) = Monad.lift Cons $ f a - -liftM2 :: - (Monad m) => - (Repr a -> Repr b -> m (Repr c)) -> - T a -> T b -> m (T c) -liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b - -liftM3 :: - (Monad m) => - (Repr a -> Repr b -> Repr c -> - m (Repr d)) -> - T a -> T b -> T c -> m (T d) -liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c - - -instance (C a) => Tuple.Zero (T a) where - zero = zero - -instance (C a) => Tuple.Undefined (T a) where - undef = undef - -instance (C a) => Tuple.Phi (T a) where - phi = phi - addPhi = addPhi - - -class (C a) => IntegerConstant a where - fromInteger' :: Integer -> T a - -class (IntegerConstant a) => RationalConstant a where - fromRational' :: Rational -> T a - -instance IntegerConstant Float where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger - -instance IntegerConstant Word where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger - -instance IntegerConstant Int where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger - -instance (Dec.Positive n) => IntegerConstant (WordN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger -instance (Dec.Positive n) => IntegerConstant (IntN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger - -instance IntegerConstant a => IntegerConstant (Tagged tag a) where - fromInteger' = tag . fromInteger' - -instance RationalConstant Float where fromRational' = Cons . LLVM.value . SoV.constFromRational -instance RationalConstant Double where fromRational' = Cons . LLVM.value . SoV.constFromRational - -instance RationalConstant a => RationalConstant (Tagged tag a) where - fromRational' = tag . fromRational' - - -instance (IntegerConstant a) => A.IntegerConstant (T a) where - fromInteger' = fromInteger' - -instance (RationalConstant a) => A.RationalConstant (T a) where - fromRational' = fromRational' - - -class (C a) => Additive a where - add :: T a -> T a -> LLVM.CodeGenFunction r (T a) - sub :: T a -> T a -> LLVM.CodeGenFunction r (T a) - neg :: T a -> LLVM.CodeGenFunction r (T a) - -instance Additive Float where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Double where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Word where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Word8 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Word16 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Word32 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Word64 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Int where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Int8 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Int16 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Int32 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive Int64 where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance (Dec.Positive n) => Additive (WordN n) where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance (Dec.Positive n) => Additive (IntN n) where - add = liftM2 LLVM.add - sub = liftM2 LLVM.sub - neg = liftM LLVM.neg - -instance Additive a => Additive (Tagged tag a) where - add = liftTaggedM2 add - sub = liftTaggedM2 sub - neg = liftTaggedM neg - -instance (Additive a) => A.Additive (T a) where - zero = zero - add = add - sub = sub - neg = neg - -inc, dec :: - (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i) -inc x = add x A.one -dec x = sub x A.one - - -class (Additive a) => PseudoRing a where - mul :: T a -> T a -> LLVM.CodeGenFunction r (T a) - -instance PseudoRing Float where mul = liftM2 LLVM.mul -instance PseudoRing Double where mul = liftM2 LLVM.mul -instance PseudoRing Word where mul = liftM2 LLVM.mul -instance PseudoRing Word8 where mul = liftM2 LLVM.mul -instance PseudoRing Word16 where mul = liftM2 LLVM.mul -instance PseudoRing Word32 where mul = liftM2 LLVM.mul -instance PseudoRing Word64 where mul = liftM2 LLVM.mul -instance PseudoRing Int where mul = liftM2 LLVM.mul -instance PseudoRing Int8 where mul = liftM2 LLVM.mul -instance PseudoRing Int16 where mul = liftM2 LLVM.mul -instance PseudoRing Int32 where mul = liftM2 LLVM.mul -instance PseudoRing Int64 where mul = liftM2 LLVM.mul - -instance (PseudoRing a) => PseudoRing (Tagged tag a) where - mul = liftTaggedM2 mul - -instance (PseudoRing a) => A.PseudoRing (T a) where - mul = mul - - -class (PseudoRing a) => Field a where - fdiv :: T a -> T a -> LLVM.CodeGenFunction r (T a) - -instance Field Float where - fdiv = liftM2 LLVM.fdiv - -instance Field Double where - fdiv = liftM2 LLVM.fdiv - -instance (Field a) => Field (Tagged tag a) where - fdiv = liftTaggedM2 fdiv - -instance (Field a) => A.Field (T a) where - fdiv = fdiv - - -type family Scalar vector -type instance Scalar Float = Float -type instance Scalar Double = Double -type instance Scalar (Tagged tag a) = Tagged tag (Scalar a) -type instance A.Scalar (T a) = T (Scalar a) - -class (PseudoRing (Scalar v), Additive v) => PseudoModule v where - scale :: T (Scalar v) -> T v -> LLVM.CodeGenFunction r (T v) - -instance PseudoModule Float where - scale = liftM2 A.mul - -instance PseudoModule Double where - scale = liftM2 A.mul - -instance (PseudoModule a) => PseudoModule (Tagged tag a) where - scale = liftTaggedM2 scale - -instance (PseudoModule a) => A.PseudoModule (T a) where - scale = scale - - -class (Additive a) => Real a where - min :: T a -> T a -> LLVM.CodeGenFunction r (T a) - max :: T a -> T a -> LLVM.CodeGenFunction r (T a) - abs :: T a -> LLVM.CodeGenFunction r (T a) - signum :: T a -> LLVM.CodeGenFunction r (T a) - -instance Real Float where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Double where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word8 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word16 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word32 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word64 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int8 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int16 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int32 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int64 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance (Dec.Positive n) => Real (WordN n) where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance (Dec.Positive n) => Real (IntN n) where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance (Real a) => Real (Tagged tag a) where - min = liftTaggedM2 min - max = liftTaggedM2 max - abs = liftTaggedM abs - signum = liftTaggedM signum - -instance (Real a) => A.Real (T a) where - min = min - max = max - abs = abs - signum = signum - - -class (Real a) => Fraction a where - truncate :: T a -> LLVM.CodeGenFunction r (T a) - fraction :: T a -> LLVM.CodeGenFunction r (T a) - -instance Fraction Float where - truncate = liftM A.truncate - fraction = liftM A.fraction - -instance Fraction Double where - truncate = liftM A.truncate - fraction = liftM A.fraction - -instance (Fraction a) => Fraction (Tagged tag a) where - truncate = liftTaggedM truncate - fraction = liftTaggedM fraction - -instance (Fraction a) => A.Fraction (T a) where - truncate = truncate - fraction = fraction - - -class - (Repr i ~ LLVM.Value ir, - LLVM.IsInteger ir, SoV.IntegerConstant ir, - LLVM.CmpRet ir, LLVM.IsPrimitive ir) => - NativeInteger i ir where - -instance NativeInteger Word Word where -instance NativeInteger Word8 Word8 where -instance NativeInteger Word16 Word16 where -instance NativeInteger Word32 Word32 where -instance NativeInteger Word64 Word64 where - -instance NativeInteger Int Int where -instance NativeInteger Int8 Int8 where -instance NativeInteger Int16 Int16 where -instance NativeInteger Int32 Int32 where -instance NativeInteger Int64 Int64 where - -instance NativeInteger a a => NativeInteger (Tagged tag a) a where - - -class - (Repr a ~ LLVM.Value ar, - LLVM.IsFloating ar, SoV.RationalConstant ar, - LLVM.CmpRet ar, LLVM.IsPrimitive ar) => - NativeFloating a ar where - -instance NativeFloating Float Float where -instance NativeFloating Double Double where - - -truncateToInt, floorToInt, ceilingToInt, roundToIntFast :: - (NativeInteger i ir, NativeFloating a ar) => - T a -> LLVM.CodeGenFunction r (T i) -truncateToInt = liftM SoV.truncateToInt -floorToInt = liftM SoV.floorToInt -ceilingToInt = liftM SoV.ceilingToInt -roundToIntFast = liftM SoV.roundToIntFast - -splitFractionToInt :: - (NativeInteger i ir, NativeFloating a ar) => - T a -> LLVM.CodeGenFunction r (T (i,a)) -splitFractionToInt = liftM SoV.splitFractionToInt - - -class Field a => Algebraic a where - sqrt :: T a -> LLVM.CodeGenFunction r (T a) - -instance Algebraic Float where - sqrt = liftM A.sqrt - -instance Algebraic Double where - sqrt = liftM A.sqrt - -instance (Algebraic a) => Algebraic (Tagged tag a) where - sqrt = liftTaggedM sqrt - -instance (Algebraic a) => A.Algebraic (T a) where - sqrt = sqrt - - -class Algebraic a => Transcendental a where - pi :: LLVM.CodeGenFunction r (T a) - sin, cos, exp, log :: T a -> LLVM.CodeGenFunction r (T a) - pow :: T a -> T a -> LLVM.CodeGenFunction r (T a) - -instance Transcendental Float where - pi = liftM0 A.pi - sin = liftM A.sin - cos = liftM A.cos - exp = liftM A.exp - log = liftM A.log - pow = liftM2 A.pow - -instance Transcendental Double where - pi = liftM0 A.pi - sin = liftM A.sin - cos = liftM A.cos - exp = liftM A.exp - log = liftM A.log - pow = liftM2 A.pow - -instance (Transcendental a) => Transcendental (Tagged tag a) where - pi = fmap tag pi - sin = liftTaggedM sin - cos = liftTaggedM cos - exp = liftTaggedM exp - log = liftTaggedM log - pow = liftTaggedM2 pow - -instance (Transcendental a) => A.Transcendental (T a) where - pi = pi - sin = sin - cos = cos - exp = exp - log = log - pow = pow - - - -class (C a) => Select a where - select :: - T Bool -> T a -> T a -> - LLVM.CodeGenFunction r (T a) - -instance Select Bool where select = liftM3 LLVM.select -instance Select Bool8 where select = liftM3 LLVM.select -instance Select Float where select = liftM3 LLVM.select -instance Select Double where select = liftM3 LLVM.select -instance Select Word where select = liftM3 LLVM.select -instance Select Word8 where select = liftM3 LLVM.select -instance Select Word16 where select = liftM3 LLVM.select -instance Select Word32 where select = liftM3 LLVM.select -instance Select Word64 where select = liftM3 LLVM.select -instance Select Int where select = liftM3 LLVM.select -instance Select Int8 where select = liftM3 LLVM.select -instance Select Int16 where select = liftM3 LLVM.select -instance Select Int32 where select = liftM3 LLVM.select -instance Select Int64 where select = liftM3 LLVM.select - -instance (Select a, Select b) => Select (a,b) where - select b = - modifyF2 (atom,atom) (atom,atom) $ - \(a0,b0) (a1,b1) -> - Monad.lift2 (,) - (select b a0 a1) - (select b b0 b1) - -instance (Select a, Select b, Select c) => Select (a,b,c) where - select b = - modifyF2 (atom,atom,atom) (atom,atom,atom) $ - \(a0,b0,c0) (a1,b1,c1) -> - Monad.lift3 (,,) - (select b a0 a1) - (select b b0 b1) - (select b c0 c1) - -instance (Select a) => Select (Tagged tag a) where - select = liftTaggedM2 . select - -instance (Select a) => C.Select (T a) where - select b = select (Cons b) - - - -class (Real a) => Comparison a where - {- | - It must hold - - > max x y == do gt <- cmp CmpGT x y; select gt x y - -} - cmp :: - LLVM.CmpPredicate -> T a -> T a -> - LLVM.CodeGenFunction r (T Bool) - -instance Comparison Float where cmp = liftM2 . LLVM.cmp -instance Comparison Double where cmp = liftM2 . LLVM.cmp - -instance Comparison Int where cmp = liftM2 . LLVM.cmp -instance Comparison Int8 where cmp = liftM2 . LLVM.cmp -instance Comparison Int16 where cmp = liftM2 . LLVM.cmp -instance Comparison Int32 where cmp = liftM2 . LLVM.cmp -instance Comparison Int64 where cmp = liftM2 . LLVM.cmp - -instance Comparison Word where cmp = liftM2 . LLVM.cmp -instance Comparison Word8 where cmp = liftM2 . LLVM.cmp -instance Comparison Word16 where cmp = liftM2 . LLVM.cmp -instance Comparison Word32 where cmp = liftM2 . LLVM.cmp -instance Comparison Word64 where cmp = liftM2 . LLVM.cmp - -instance (Dec.Positive n) => Comparison (IntN n) where cmp = liftM2 . LLVM.cmp -instance (Dec.Positive n) => Comparison (WordN n) where cmp = liftM2 . LLVM.cmp - -instance (Comparison a) => Comparison (Tagged tag a) where - cmp p a b = cmp p (untag a) (untag b) - -instance (Comparison a) => A.Comparison (T a) where - type CmpResult (T a) = T Bool - cmp = cmp - - - -class (Comparison a) => FloatingComparison a where - fcmp :: - LLVM.FPPredicate -> T a -> T a -> - LLVM.CodeGenFunction r (T Bool) - -instance FloatingComparison Float where - fcmp = liftM2 . LLVM.fcmp - -instance (FloatingComparison a) => FloatingComparison (Tagged tag a) where - fcmp p a b = fcmp p (untag a) (untag b) - -instance (FloatingComparison a) => A.FloatingComparison (T a) where - fcmp = fcmp - - - -class (C a) => Logic a where - and :: T a -> T a -> LLVM.CodeGenFunction r (T a) - or :: T a -> T a -> LLVM.CodeGenFunction r (T a) - xor :: T a -> T a -> LLVM.CodeGenFunction r (T a) - inv :: T a -> LLVM.CodeGenFunction r (T a) - -instance Logic Bool where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Bool8 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word8 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word16 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word32 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word64 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance (Dec.Positive n) => Logic (WordN n) where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance (LLVM.IsInteger w, LLVM.IsConst w) => Logic (EnumBitSet.T w i) where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic a => Logic (Tagged tag a) where - and = liftTaggedM2 and; or = liftTaggedM2 or - xor = liftTaggedM2 xor; inv = liftTaggedM inv - - -instance Logic a => A.Logic (T a) where - and = and - or = or - xor = xor - inv = inv - - - -class BitShift a where - shl :: T a -> T a -> LLVM.CodeGenFunction r (T a) - shr :: T a -> T a -> LLVM.CodeGenFunction r (T a) - -instance BitShift Word where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word8 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word16 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word32 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word64 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Int where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int8 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int16 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int32 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int64 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - - - -class (PseudoRing a) => Integral a where - idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a) - irem :: T a -> T a -> LLVM.CodeGenFunction r (T a) - -instance Integral Word where - idiv = liftM2 LLVM.idiv - irem = liftM2 LLVM.irem - -instance Integral Word32 where - idiv = liftM2 LLVM.idiv - irem = liftM2 LLVM.irem - -instance Integral Word64 where - idiv = liftM2 LLVM.idiv - irem = liftM2 LLVM.irem - -instance Integral Int where - idiv = liftM2 LLVM.idiv - irem = liftM2 LLVM.irem - -instance Integral Int32 where - idiv = liftM2 LLVM.idiv - irem = liftM2 LLVM.irem - -instance Integral Int64 where - idiv = liftM2 LLVM.idiv - irem = liftM2 LLVM.irem - -instance (Integral a) => Integral (Tagged tag a) where - idiv = liftTaggedM2 idiv - irem = liftTaggedM2 irem - - -fromIntegral :: - (NativeInteger i ir, NativeFloating a ar) => - T i -> LLVM.CodeGenFunction r (T a) -fromIntegral = liftM LLVM.inttofp diff --git a/src/LLVM/Extra/Multi/Value/Storable.hs b/src/LLVM/Extra/Multi/Value/Storable.hs --- a/src/LLVM/Extra/Multi/Value/Storable.hs +++ b/src/LLVM/Extra/Multi/Value/Storable.hs @@ -1,417 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module LLVM.Extra.Multi.Value.Storable ( - -- * Basic class - C(load, store), - storeNext, - modify, - - -- * Classes for tuples and vectors - Tuple(..), - Vector(..), - TupleVector(..), - - -- * Standard method implementations - loadTraversable, - loadApplicative, - storeFoldable, - - -- * Pointer handling - Storable.advancePtr, - Storable.incrementPtr, - Storable.decrementPtr, - - -- * Loops over Storable arrays - Array.arrayLoop, - Array.arrayLoop2, - Array.arrayLoopMaybeCont, - Array.arrayLoopMaybeCont2, - ) where - -import qualified LLVM.Extra.Storable.Private as Storable -import qualified LLVM.Extra.Storable.Array as Array -import LLVM.Extra.Storable.Private - (BytePtr, advancePtrStatic, incPtrState, incrementPtr, update, - castFromBytePtr, castToBytePtr, - runElements, elementOffset, castElementPtr, - assemblePrimitive, disassemblePrimitive, proxyFromElement3) - -import qualified LLVM.Extra.Multi.Vector as MultiVector -import qualified LLVM.Extra.Multi.Value as MultiValue -import qualified LLVM.Extra.ArithmeticPrivate as A - -import qualified LLVM.ExecutionEngine as EE -import qualified LLVM.Util.Proxy as LP -import qualified LLVM.Core as LLVM -import LLVM.Core (CodeGenFunction, Value) - -import qualified Type.Data.Num.Decimal as TypeNum - -import qualified Control.Monad.Trans.Class as MT -import qualified Control.Monad.Trans.Reader as MR -import qualified Control.Monad.Trans.State as MS -import qualified Control.Applicative.HT as App -import qualified Control.Functor.HT as FuncHT -import Control.Monad (foldM, replicateM, replicateM_, (<=<)) -import Control.Applicative (Applicative, pure, (<$>)) - -import qualified Foreign.Storable.Record.Tuple as StoreTuple -import qualified Foreign.Storable as Store -import Foreign.Ptr (Ptr) - -import qualified Data.NonEmpty.Class as NonEmptyC -import qualified Data.Traversable as Trav -import qualified Data.Foldable as Fold -import Data.Orphans () -import Data.Tuple.HT (uncurry3) -import Data.Complex (Complex) -import Data.Word (Word8, Word16, Word32, Word64, Word) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Bool8 (Bool8) - - - -class (Store.Storable a, MultiValue.C a) => C a where - {- - Not all Storable types have a compatible LLVM type, - or even more, one LLVM type that is compatible on all platforms. - -} - load :: Value (Ptr a) -> CodeGenFunction r (MultiValue.T a) - store :: MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r () - -storeNext :: - (C a, Value (Ptr a) ~ ptr) => MultiValue.T a -> ptr -> CodeGenFunction r ptr -storeNext a ptr = store a ptr >> incrementPtr ptr - -modify :: - (C a, MultiValue.T a ~ al) => - (al -> CodeGenFunction r al) -> - Value (Ptr a) -> CodeGenFunction r () -modify f ptr = flip store ptr =<< f =<< load ptr - - -instance - (EE.Marshal a, LLVM.IsConst a, LLVM.IsFirstClass a) => - C (EE.Stored a) where - load = fmap MultiValue.Cons . LLVM.load <=< castFromStoredPtr - store (MultiValue.Cons a) = LLVM.store a <=< castFromStoredPtr - -castFromStoredPtr :: - (LLVM.IsType a) => - Value (Ptr (EE.Stored a)) -> CodeGenFunction r (Value (LLVM.Ptr a)) -castFromStoredPtr = LLVM.bitcast - - -loadPrimitive :: - (LLVM.Storable a, MultiValue.Repr a ~ LLVM.Value a) => - Value (Ptr a) -> CodeGenFunction r (MultiValue.T a) -loadPrimitive ptr = fmap MultiValue.Cons $ LLVM.load =<< LLVM.bitcast ptr - -storePrimitive :: - (LLVM.Storable a, MultiValue.Repr a ~ LLVM.Value a) => - MultiValue.T a -> Value (Ptr a) -> CodeGenFunction r () -storePrimitive (MultiValue.Cons a) ptr = LLVM.store a =<< LLVM.bitcast ptr - -instance C Float where - load = loadPrimitive; store = storePrimitive - -instance C Double where - load = loadPrimitive; store = storePrimitive - -instance C Word where - load = loadPrimitive; store = storePrimitive - -instance C Word8 where - load = loadPrimitive; store = storePrimitive - -instance C Word16 where - load = loadPrimitive; store = storePrimitive - -instance C Word32 where - load = loadPrimitive; store = storePrimitive - -instance C Word64 where - load = loadPrimitive; store = storePrimitive - -instance C Int where - load = loadPrimitive; store = storePrimitive - -instance C Int8 where - load = loadPrimitive; store = storePrimitive - -instance C Int16 where - load = loadPrimitive; store = storePrimitive - -instance C Int32 where - load = loadPrimitive; store = storePrimitive - -instance C Int64 where - load = loadPrimitive; store = storePrimitive - -{- | -Not very efficient implementation -because we want to adapt to @sizeOf Bool@ dynamically. -Unfortunately, LLVM-9's optimizer does not recognize the instruction pattern. -Better use 'Bool8' for booleans. --} -instance C Bool where - load ptr = do - bytePtr <- castToBytePtr ptr - bytes <- - flip MS.evalStateT bytePtr $ - replicateM (Store.sizeOf (False :: Bool)) - (MT.lift . LLVM.load =<< incPtrState) - let zero = LLVM.valueOf 0 - mask <- foldM A.or zero bytes - MultiValue.Cons <$> A.cmp LLVM.CmpNE mask zero - store (MultiValue.Cons b) ptr = do - bytePtr <- castToBytePtr ptr - byte <- LLVM.sext b - flip MS.evalStateT bytePtr $ - replicateM_ (Store.sizeOf (False :: Bool)) - (MT.lift . LLVM.store byte =<< incPtrState) - -instance C Bool8 where - load ptr = - fmap MultiValue.Cons $ - A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr - store (MultiValue.Cons b) ptr = do - byte <- LLVM.zext b - LLVM.store byte =<< castToBytePtr ptr - -instance (C a) => C (Complex a) where - load = loadApplicative; store = storeFoldable - - - -instance (Tuple tuple) => C (StoreTuple.Tuple tuple) where - load ptr = MultiValue.tuple <$> loadTuple ptr - store = storeTuple . MultiValue.untuple - -class (StoreTuple.Storable tuple, MultiValue.C tuple) => Tuple tuple where - loadTuple :: - Value (Ptr (StoreTuple.Tuple tuple)) -> - CodeGenFunction r (MultiValue.T tuple) - storeTuple :: - MultiValue.T tuple -> - Value (Ptr (StoreTuple.Tuple tuple)) -> - CodeGenFunction r () - -instance (C a, C b) => Tuple (a,b) where - loadTuple ptr = - runElements ptr $ fmap (uncurry MultiValue.zip) $ - App.mapPair (loadElement, loadElement) $ - FuncHT.unzip $ proxyFromElement3 ptr - storeTuple = MultiValue.uncurry $ \a b ptr -> - case FuncHT.unzip $ proxyFromElement3 ptr of - (pa,pb) -> runElements ptr $ storeElement pa a >> storeElement pb b - -instance (C a, C b, C c) => Tuple (a,b,c) where - loadTuple ptr = - runElements ptr $ fmap (uncurry3 MultiValue.zip3) $ - App.mapTriple (loadElement, loadElement, loadElement) $ - FuncHT.unzip3 $ proxyFromElement3 ptr - storeTuple = MultiValue.uncurry3 $ \a b c ptr -> - case FuncHT.unzip3 $ proxyFromElement3 ptr of - (pa,pb,pc) -> - runElements ptr $ - storeElement pa a >> storeElement pb b >> storeElement pc c - -loadElement :: - (C a) => - LP.Proxy a -> - MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (MultiValue.T a) -loadElement proxy = - MT.lift . MT.lift . load =<< elementPtr proxy - -storeElement :: - (C a) => - LP.Proxy a -> MultiValue.T a -> - MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) () -storeElement proxy a = - MT.lift . MT.lift . store a =<< elementPtr proxy - -elementPtr :: - (C a) => - LP.Proxy a -> - MR.ReaderT BytePtr - (MS.StateT Int (CodeGenFunction r)) (LLVM.Value (Ptr a)) -elementPtr proxy = do - ptr <- MR.ask - MT.lift $ do - offset <- elementOffset proxy - MT.lift $ castFromBytePtr =<< LLVM.getElementPtr ptr (offset, ()) - - -instance - (TypeNum.Positive n, Vector a) => - C (LLVM.Vector n a) where - load ptr = - fmap MultiValue.Cons $ - assembleVector (proxyFromElement3 ptr) =<< loadApplicativeRepr ptr - store (MultiValue.Cons a) ptr = - flip storeFoldableRepr ptr - =<< disassembleVector (proxyFromElement3 ptr) a - -class (C a, MultiVector.C a) => Vector a where - assembleVector :: - (TypeNum.Positive n) => - LP.Proxy a -> LLVM.Vector n (MultiValue.Repr a) -> - CodeGenFunction r (MultiVector.Repr n a) - disassembleVector :: - (TypeNum.Positive n) => - LP.Proxy a -> MultiVector.Repr n a -> - CodeGenFunction r (LLVM.Vector n (MultiValue.Repr a)) - -instance Vector Float where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Double where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Word where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Word8 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Word16 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Word32 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Word64 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Int where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Int8 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Int16 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Int32 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Int64 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Bool where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - -instance Vector Bool8 where - assembleVector LP.Proxy = assemblePrimitive - disassembleVector LP.Proxy = disassemblePrimitive - - -instance - (Tuple tuple, TupleVector tuple) => - Vector (StoreTuple.Tuple tuple) where - assembleVector = deinterleave . fmap StoreTuple.getTuple - disassembleVector = interleave . fmap StoreTuple.getTuple - - -class (MultiVector.C a) => TupleVector a where - deinterleave :: - (TypeNum.Positive n) => - LP.Proxy a -> LLVM.Vector n (MultiValue.Repr a) -> - CodeGenFunction r (MultiVector.Repr n a) - interleave :: - (TypeNum.Positive n) => - LP.Proxy a -> MultiVector.Repr n a -> - CodeGenFunction r (LLVM.Vector n (MultiValue.Repr a)) - -instance (Vector a, Vector b) => TupleVector (a,b) where - deinterleave = FuncHT.uncurry $ \pa pb -> FuncHT.uncurry $ \a b -> - App.lift2 (,) (assembleVector pa a) (assembleVector pb b) - interleave = FuncHT.uncurry $ \pa pb (a,b) -> - App.lift2 (App.lift2 (,)) - (disassembleVector pa a) (disassembleVector pb b) - -instance (Vector a, Vector b, Vector c) => TupleVector (a,b,c) where - deinterleave = FuncHT.uncurry3 $ \pa pb pc -> FuncHT.uncurry3 $ \a b c -> - App.lift3 (,,) - (assembleVector pa a) - (assembleVector pb b) - (assembleVector pc c) - interleave = FuncHT.uncurry3 $ \pa pb pc (a,b,c) -> - App.lift3 (App.lift3 (,,)) - (disassembleVector pa a) - (disassembleVector pb b) - (disassembleVector pc c) - - -{- -instance Storable () available since base-4.9/GHC-8.0. -Before we need Data.Orphans. --} -instance C () where - load _ptr = return $ MultiValue.Cons () - store (MultiValue.Cons ()) _ptr = return () - - -loadTraversable :: - (NonEmptyC.Repeat f, Trav.Traversable f, - C a, MultiValue.Repr fa ~ f (MultiValue.Repr a)) => - Value (Ptr (f a)) -> CodeGenFunction r (MultiValue.T fa) -loadTraversable = - (MS.evalStateT $ fmap MultiValue.Cons $ - Trav.sequence $ NonEmptyC.repeat $ loadState) - <=< castElementPtr - -loadApplicative :: - (Applicative f, Trav.Traversable f, - C a, MultiValue.Repr fa ~ f (MultiValue.Repr a)) => - Value (Ptr (f a)) -> CodeGenFunction r (MultiValue.T fa) -loadApplicative = fmap MultiValue.Cons . loadApplicativeRepr - -loadApplicativeRepr :: - (Applicative f, Trav.Traversable f, C a) => - Value (Ptr (f a)) -> CodeGenFunction r (f (MultiValue.Repr a)) -loadApplicativeRepr = - (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr - -loadState :: - (C a, MultiValue.Repr a ~ al) => - MS.StateT (Value (Ptr a)) (CodeGenFunction r) al -loadState = - MT.lift . fmap (\(MultiValue.Cons a) -> a) . load =<< advancePtrState - - -storeFoldable :: - (Fold.Foldable f, C a, MultiValue.Repr fa ~ f (MultiValue.Repr a)) => - MultiValue.T fa -> Value (Ptr (f a)) -> CodeGenFunction r () -storeFoldable (MultiValue.Cons xs) = storeFoldableRepr xs - -storeFoldableRepr :: - (Fold.Foldable f, C a) => - f (MultiValue.Repr a) -> Value (Ptr (f a)) -> CodeGenFunction r () -storeFoldableRepr xs = - MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr - -storeState :: - (C a, MultiValue.Repr a ~ al) => - al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) () -storeState a = MT.lift . store (MultiValue.Cons a) =<< advancePtrState - +module LLVM.Extra.Multi.Value.Storable + {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Storable instead." #-} + (module LLVM.Extra.Nice.Value.Storable) where -advancePtrState :: - (C a, Value (Ptr a) ~ ptr) => - MS.StateT ptr (CodeGenFunction r) ptr -advancePtrState = update $ advancePtrStatic 1 +import LLVM.Extra.Nice.Value.Storable diff --git a/src/LLVM/Extra/Multi/Value/Vector.hs b/src/LLVM/Extra/Multi/Value/Vector.hs --- a/src/LLVM/Extra/Multi/Value/Vector.hs +++ b/src/LLVM/Extra/Multi/Value/Vector.hs @@ -1,239 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module LLVM.Extra.Multi.Value.Vector ( - cons, - fst, snd, - fst3, snd3, thd3, - zip, zip3, - unzip, unzip3, - - swap, - mapFst, mapSnd, - mapFst3, mapSnd3, mapThd3, - - extract, insert, - replicate, - iterate, - dissect, - dissect1, - select, - cmp, - take, takeRev, - - NativeInteger, - NativeFloating, - fromIntegral, - truncateToInt, - splitFractionToInt, - ) where - -import qualified LLVM.Extra.Multi.Vector.Instance as Inst -import qualified LLVM.Extra.Multi.Vector as MultiVector -import qualified LLVM.Extra.Multi.Value.Private as MultiValue -import qualified LLVM.Extra.ScalarOrVector as SoV -import LLVM.Extra.Multi.Vector.Instance (MVVector) - -import qualified LLVM.Core as LLVM - -import qualified Type.Data.Num.Decimal as TypeNum - - -import qualified Data.NonEmpty as NonEmpty -import qualified Data.Tuple.HT as TupleHT -import qualified Data.Tuple as Tuple -import Data.Word (Word8, Word16, Word32, Word64, Word) -import Data.Int (Int8, Int16, Int32, Int64, Int) - -import Prelude (Float, Double, Bool, fmap, (.)) - - -cons :: - (TypeNum.Positive n, MultiVector.C a) => - LLVM.Vector n a -> MVVector n a -cons = Inst.toMultiValue . MultiVector.cons - -fst :: MVVector n (a,b) -> MVVector n a -fst = MultiValue.lift1 Tuple.fst - -snd :: MVVector n (a,b) -> MVVector n b -snd = MultiValue.lift1 Tuple.snd - -swap :: MVVector n (a,b) -> MVVector n (b,a) -swap = MultiValue.lift1 TupleHT.swap - -mapFst :: - (MVVector n a0 -> MVVector n a1) -> - MVVector n (a0,b) -> MVVector n (a1,b) -mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip - -mapSnd :: - (MVVector n b0 -> MVVector n b1) -> - MVVector n (a,b0) -> MVVector n (a,b1) -mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip - - -fst3 :: MVVector n (a,b,c) -> MVVector n a -fst3 = MultiValue.lift1 TupleHT.fst3 - -snd3 :: MVVector n (a,b,c) -> MVVector n b -snd3 = MultiValue.lift1 TupleHT.snd3 - -thd3 :: MVVector n (a,b,c) -> MVVector n c -thd3 = MultiValue.lift1 TupleHT.thd3 - -mapFst3 :: - (MVVector n a0 -> MVVector n a1) -> - MVVector n (a0,b,c) -> MVVector n (a1,b,c) -mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3 - -mapSnd3 :: - (MVVector n b0 -> MVVector n b1) -> - MVVector n (a,b0,c) -> MVVector n (a,b1,c) -mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3 - -mapThd3 :: - (MVVector n c0 -> MVVector n c1) -> - MVVector n (a,b,c0) -> MVVector n (a,b,c1) -mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3 - - -zip :: MVVector n a -> MVVector n b -> MVVector n (a,b) -zip (MultiValue.Cons a) (MultiValue.Cons b) = MultiValue.Cons (a,b) - -zip3 :: MVVector n a -> MVVector n b -> MVVector n c -> MVVector n (a,b,c) -zip3 (MultiValue.Cons a) (MultiValue.Cons b) (MultiValue.Cons c) = - MultiValue.Cons (a,b,c) - -unzip :: MVVector n (a,b) -> (MVVector n a, MVVector n b) -unzip (MultiValue.Cons (a,b)) = (MultiValue.Cons a, MultiValue.Cons b) - -unzip3 :: MVVector n (a,b,c) -> (MVVector n a, MVVector n b, MVVector n c) -unzip3 (MultiValue.Cons (a,b,c)) = - (MultiValue.Cons a, MultiValue.Cons b, MultiValue.Cons c) - - -extract :: - (TypeNum.Positive n, MultiVector.C a) => - LLVM.Value Word32 -> MVVector n a -> - LLVM.CodeGenFunction r (MultiValue.T a) -extract k v = MultiVector.extract k (Inst.fromMultiValue v) - -insert :: - (TypeNum.Positive n, MultiVector.C a) => - LLVM.Value Word32 -> MultiValue.T a -> - MVVector n a -> LLVM.CodeGenFunction r (MVVector n a) -insert k a = Inst.liftMultiValueM (MultiVector.insert k a) - - -replicate :: - (TypeNum.Positive n, MultiVector.C a) => - MultiValue.T a -> LLVM.CodeGenFunction r (MVVector n a) -replicate = fmap Inst.toMultiValue . MultiVector.replicate - -iterate :: - (TypeNum.Positive n, MultiVector.C a) => - (MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T a)) -> - MultiValue.T a -> LLVM.CodeGenFunction r (MVVector n a) -iterate f = fmap Inst.toMultiValue . MultiVector.iterate f - -take :: - (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) => - MVVector n a -> LLVM.CodeGenFunction r (MVVector m a) -take = Inst.liftMultiValueM MultiVector.take - -takeRev :: - (TypeNum.Positive n, TypeNum.Positive m, MultiVector.C a) => - MVVector n a -> LLVM.CodeGenFunction r (MVVector m a) -takeRev = Inst.liftMultiValueM MultiVector.takeRev - - -dissect :: - (TypeNum.Positive n, MultiVector.C a) => - MVVector n a -> LLVM.CodeGenFunction r [MultiValue.T a] -dissect = MultiVector.dissect . Inst.fromMultiValue - -dissect1 :: - (TypeNum.Positive n, MultiVector.C a) => - MVVector n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (MultiValue.T a)) -dissect1 = MultiVector.dissect1 . Inst.fromMultiValue - -select :: - (TypeNum.Positive n, MultiVector.Select a) => - MVVector n Bool -> - MVVector n a -> MVVector n a -> - LLVM.CodeGenFunction r (MVVector n a) -select = Inst.liftMultiValueM3 MultiVector.select - -cmp :: - (TypeNum.Positive n, MultiVector.Comparison a) => - LLVM.CmpPredicate -> - MVVector n a -> MVVector n a -> - LLVM.CodeGenFunction r (MVVector n Bool) -cmp = Inst.liftMultiValueM2 . MultiVector.cmp - - -{- -ToDo: make this a super-class of MultiValue.NativeInteger -problem: we need MultiValue.Repr, which provokes an import cycle -maybe we should break the cycle using a ConstraintKind, -i.e. define class NativeIntegerVec in MultiValue, -and define NativeInteger = MultiValue.NativeIntegerVec here -and export only MultiValueVec.NativeInteger constraint synonym. --} -class - (MultiValue.Repr i ~ LLVM.Value ir, - LLVM.CmpRet ir, LLVM.IsInteger ir, SoV.IntegerConstant ir) => - NativeInteger i ir where - -instance NativeInteger Word Word where -instance NativeInteger Word8 Word8 where -instance NativeInteger Word16 Word16 where -instance NativeInteger Word32 Word32 where -instance NativeInteger Word64 Word64 where - -instance NativeInteger Int Int where -instance NativeInteger Int8 Int8 where -instance NativeInteger Int16 Int16 where -instance NativeInteger Int32 Int32 where -instance NativeInteger Int64 Int64 where - -instance - (TypeNum.Positive n, n ~ m, - MultiVector.NativeInteger n i ir, - MultiValue.NativeInteger i ir) => - NativeInteger (LLVM.Vector n i) (LLVM.Vector m ir) where - - -class - (MultiValue.Repr a ~ LLVM.Value ar, - LLVM.CmpRet ar, SoV.RationalConstant ar, LLVM.IsFloating ar) => - NativeFloating a ar where - -instance NativeFloating Float Float where -instance NativeFloating Double Double where - -instance - (TypeNum.Positive n, n ~ m, - MultiVector.NativeFloating n a ar, - MultiValue.NativeFloating a ar) => - NativeFloating (LLVM.Vector n a) (LLVM.Vector m ar) where - -fromIntegral :: - (NativeInteger i ir, NativeFloating a ar, - LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => - MultiValue.T i -> LLVM.CodeGenFunction r (MultiValue.T a) -fromIntegral = MultiValue.liftM LLVM.inttofp - - -truncateToInt :: - (NativeInteger i ir, NativeFloating a ar, - LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => - MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T i) -truncateToInt = MultiValue.liftM LLVM.fptoint +module LLVM.Extra.Multi.Value.Vector + {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Vector instead." #-} + (module LLVM.Extra.Nice.Value.Vector) where -splitFractionToInt :: - (NativeInteger i ir, NativeFloating a ar, - LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => - MultiValue.T a -> LLVM.CodeGenFunction r (MultiValue.T (i,a)) -splitFractionToInt = MultiValue.liftM SoV.splitFractionToInt +import LLVM.Extra.Nice.Value.Vector diff --git a/src/LLVM/Extra/Multi/Vector.hs b/src/LLVM/Extra/Multi/Vector.hs --- a/src/LLVM/Extra/Multi/Vector.hs +++ b/src/LLVM/Extra/Multi/Vector.hs @@ -1,1306 +1,5 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -module LLVM.Extra.Multi.Vector ( - T(Cons), consPrim, deconsPrim, - C(..), - Value, - map, - zip, zip3, unzip, unzip3, - replicate, - iterate, - take, - takeRev, - - sum, - dotProduct, - cumulate, - cumulate1, - - lift1, - - modify, - assemble, - dissect, - dissectList, - - assemble1, - dissect1, - dissectList1, - - assembleFromVector, - - reverse, - rotateUp, - rotateDown, - shiftUp, - shiftDown, - shiftUpMultiZero, - shiftDownMultiZero, - shiftUpMultiUndef, - shiftDownMultiUndef, - - undefPrimitive, - shufflePrimitive, - extractPrimitive, - insertPrimitive, - - shuffleMatchTraversable, - insertTraversable, - extractTraversable, - - IntegerConstant(..), - RationalConstant(..), - Additive(..), - PseudoRing(..), - Field(..), - scale, - PseudoModule(..), - Real(..), - Fraction(..), - NativeInteger, NativeFloating, fromIntegral, - Algebraic(..), - Transcendental(..), - FloatingComparison(..), - Select(..), - Comparison(..), - Logic(..), - BitShift(..), - ) where - -import qualified LLVM.Extra.Multi.Value.Private as MultiValue -import qualified LLVM.Extra.ScalarOrVector as SoV -import qualified LLVM.Extra.Arithmetic as A -import qualified LLVM.Extra.Tuple as Tuple - -import qualified LLVM.Core as LLVM -import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, ) - -import qualified Type.Data.Num.Decimal as TypeNum - -import qualified Foreign.Storable.Record.Tuple as StoreTuple - -import qualified Data.Traversable as Trav -import qualified Data.NonEmpty.Class as NonEmptyC -import qualified Data.NonEmpty as NonEmpty -import qualified Data.List as List -import qualified Data.Bool8 as Bool8 -import Data.Traversable (mapM, sequence, ) -import Data.Foldable (foldlM) -import Data.NonEmpty ((!:), ) -import Data.Function (flip, (.), ($), ) -import Data.Tuple (snd, ) -import Data.Maybe (maybe, ) -import Data.Ord ((<), ) -import Data.Word (Word8, Word16, Word32, Word64, Word) -import Data.Int (Int8, Int16, Int32, Int64, ) -import Data.Bool8 (Bool8) -import Data.Bool (Bool, ) - -import qualified Control.Monad.HT as Monad -import qualified Control.Applicative as App -import qualified Control.Functor.HT as FuncHT -import Control.Monad.HT ((<=<), ) -import Control.Monad (Monad, join, fmap, return, (>>), (=<<)) -import Control.Applicative (liftA2, (<$>)) - -import qualified Prelude as P -import Prelude - (Float, Double, Integer, Int, Rational, asTypeOf, (-), (+), (*), error) - - -newtype T n a = Cons (Repr n a) - -type Value n a = LLVM.Value (LLVM.Vector n a) - - -consPrim :: (Repr n a ~ Value n ar) => Value n ar -> T n a -consPrim = Cons - -deconsPrim :: (Repr n a ~ Value n ar) => T n a -> Value n ar -deconsPrim (Cons a) = a - - -instance (TypeNum.Positive n, C a) => Tuple.Undefined (T n a) where - undef = undef - -instance (TypeNum.Positive n, C a) => Tuple.Zero (T n a) where - zero = zero - -instance (TypeNum.Positive n, C a) => Tuple.Phi (T n a) where - phi = phi - addPhi = addPhi - - -sizeS :: TypeNum.Positive n => T n a -> TypeNum.Singleton n -sizeS _ = TypeNum.singleton - -size :: (TypeNum.Positive n, P.Integral i) => T n a -> i -size = TypeNum.integralFromSingleton . sizeS - -last :: - (TypeNum.Positive n, C a) => - T n a -> CodeGenFunction r (MultiValue.T a) -last x = extract (valueOf (size x - 1)) x - - -zip :: T n a -> T n b -> T n (a,b) -zip (Cons a) (Cons b) = Cons (a,b) - -zip3 :: T n a -> T n b -> T n c -> T n (a,b,c) -zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c) - -unzip :: T n (a,b) -> (T n a, T n b) -unzip (Cons (a,b)) = (Cons a, Cons b) - -unzip3 :: T n (a,b,c) -> (T n a, T n b, T n c) -unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c) - - -class (MultiValue.C a) => C a where - type Repr n a - cons :: (TypeNum.Positive n) => LLVM.Vector n a -> T n a - undef :: (TypeNum.Positive n) => T n a - zero :: (TypeNum.Positive n) => T n a - phi :: - (TypeNum.Positive n) => - LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a) - addPhi :: - (TypeNum.Positive n) => - LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r () - - shuffle :: - (TypeNum.Positive n, TypeNum.Positive m) => - LLVM.ConstValue (LLVM.Vector m Word32) -> T n a -> T n a -> - CodeGenFunction r (T m a) - extract :: - (TypeNum.Positive n) => - LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a) - insert :: - (TypeNum.Positive n) => - LLVM.Value Word32 -> MultiValue.T a -> - T n a -> CodeGenFunction r (T n a) - -instance C Bool where - type Repr n Bool = LLVM.Value (LLVM.Vector n Bool) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Bool8 where - type Repr n Bool8 = LLVM.Value (LLVM.Vector n Bool) - cons = consPrimitive . fmap Bool8.toBool - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Float where - type Repr n Float = LLVM.Value (LLVM.Vector n Float) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Double where - type Repr n Double = LLVM.Value (LLVM.Vector n Double) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Int where - type Repr n Int = LLVM.Value (LLVM.Vector n Int) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Int8 where - type Repr n Int8 = LLVM.Value (LLVM.Vector n Int8) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Int16 where - type Repr n Int16 = LLVM.Value (LLVM.Vector n Int16) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Int32 where - type Repr n Int32 = LLVM.Value (LLVM.Vector n Int32) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Int64 where - type Repr n Int64 = LLVM.Value (LLVM.Vector n Int64) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Word where - type Repr n Word = LLVM.Value (LLVM.Vector n Word) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Word8 where - type Repr n Word8 = LLVM.Value (LLVM.Vector n Word8) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Word16 where - type Repr n Word16 = LLVM.Value (LLVM.Vector n Word16) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Word32 where - type Repr n Word32 = LLVM.Value (LLVM.Vector n Word32) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -instance C Word64 where - type Repr n Word64 = LLVM.Value (LLVM.Vector n Word64) - cons = consPrimitive - undef = undefPrimitive - zero = zeroPrimitive - phi = phiPrimitive - addPhi = addPhiPrimitive - shuffle = shufflePrimitive - extract = extractPrimitive - insert = insertPrimitive - -consPrimitive :: - (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al, - Repr n a ~ Value n al) => - LLVM.Vector n al -> T n a -consPrimitive = Cons . LLVM.valueOf - -undefPrimitive :: - (TypeNum.Positive n, IsPrimitive al, - Repr n a ~ Value n al) => - T n a -undefPrimitive = Cons $ LLVM.value LLVM.undef - -zeroPrimitive :: - (TypeNum.Positive n, IsPrimitive al, - Repr n a ~ Value n al) => - T n a -zeroPrimitive = Cons $ LLVM.value LLVM.zero - -phiPrimitive :: - (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) => - LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a) -phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a - -addPhiPrimitive :: - (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) => - LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r () -addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b - - -shufflePrimitive :: - (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al, - MultiValue.Repr a ~ LLVM.Value al, - Repr n a ~ Value n al, - Repr m a ~ Value m al) => - LLVM.ConstValue (LLVM.Vector m Word32) -> - T n a -> T n a -> CodeGenFunction r (T m a) -shufflePrimitive k (Cons u) (Cons v) = - fmap Cons $ LLVM.shufflevector u v k - -extractPrimitive :: - (TypeNum.Positive n, IsPrimitive al, - MultiValue.Repr a ~ LLVM.Value al, - Repr n a ~ Value n al) => - LLVM.Value Word32 -> T n a -> CodeGenFunction r (MultiValue.T a) -extractPrimitive k (Cons v) = - fmap MultiValue.Cons $ LLVM.extractelement v k - -insertPrimitive :: - (TypeNum.Positive n, IsPrimitive al, - MultiValue.Repr a ~ LLVM.Value al, - Repr n a ~ Value n al) => - LLVM.Value Word32 -> - MultiValue.T a -> T n a -> CodeGenFunction r (T n a) -insertPrimitive k (MultiValue.Cons a) (Cons v) = - fmap Cons $ LLVM.insertelement v a k - - -instance (C a, C b) => C (a,b) where - type Repr n (a,b) = (Repr n a, Repr n b) - cons v = case FuncHT.unzip v of (a,b) -> zip (cons a) (cons b) - undef = zip undef undef - zero = zip zero zero - - phi bb a = - case unzip a of - (a0,a1) -> - Monad.lift2 zip (phi bb a0) (phi bb a1) - addPhi bb a b = - case (unzip a, unzip b) of - ((a0,a1), (b0,b1)) -> - addPhi bb a0 b0 >> - addPhi bb a1 b1 - - shuffle is u v = - case (unzip u, unzip v) of - ((u0,u1), (v0,v1)) -> - Monad.lift2 zip - (shuffle is u0 v0) - (shuffle is u1 v1) - - extract k v = - case unzip v of - (v0,v1) -> - Monad.lift2 MultiValue.zip - (extract k v0) - (extract k v1) - - insert k a v = - case (MultiValue.unzip a, unzip v) of - ((a0,a1), (v0,v1)) -> - Monad.lift2 zip - (insert k a0 v0) - (insert k a1 v1) - - -instance (C a, C b, C c) => C (a,b,c) where - type Repr n (a,b,c) = (Repr n a, Repr n b, Repr n c) - cons v = case FuncHT.unzip3 v of (a,b,c) -> zip3 (cons a) (cons b) (cons c) - undef = zip3 undef undef undef - zero = zip3 zero zero zero - - phi bb a = - case unzip3 a of - (a0,a1,a2) -> - Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2) - addPhi bb a b = - case (unzip3 a, unzip3 b) of - ((a0,a1,a2), (b0,b1,b2)) -> - addPhi bb a0 b0 >> - addPhi bb a1 b1 >> - addPhi bb a2 b2 - - shuffle is u v = - case (unzip3 u, unzip3 v) of - ((u0,u1,u2), (v0,v1,v2)) -> - Monad.lift3 zip3 - (shuffle is u0 v0) - (shuffle is u1 v1) - (shuffle is u2 v2) - - extract k v = - case unzip3 v of - (v0,v1,v2) -> - Monad.lift3 MultiValue.zip3 - (extract k v0) - (extract k v1) - (extract k v2) - - insert k a v = - case (MultiValue.unzip3 a, unzip3 v) of - ((a0,a1,a2), (v0,v1,v2)) -> - Monad.lift3 zip3 - (insert k a0 v0) - (insert k a1 v1) - (insert k a2 v2) - - -instance (C tuple) => C (StoreTuple.Tuple tuple) where - type Repr n (StoreTuple.Tuple tuple) = Repr n tuple - cons = tuple . cons . fmap StoreTuple.getTuple - undef = tuple undef - zero = tuple zero - phi bb = fmap tuple . phi bb . untuple - addPhi bb a b = addPhi bb (untuple a) (untuple b) - shuffle is u v = tuple <$> shuffle is (untuple u) (untuple v) - extract k v = MultiValue.tuple <$> extract k (untuple v) - insert k a v = tuple <$> insert k (MultiValue.untuple a) (untuple v) - -tuple :: T n tuple -> T n (StoreTuple.Tuple tuple) -tuple (Cons a) = Cons a - -untuple :: T n (StoreTuple.Tuple tuple) -> T n tuple -untuple (Cons a) = Cons a - - -class (MultiValue.IntegerConstant a, C a) => IntegerConstant a where - fromInteger' :: (TypeNum.Positive n) => Integer -> T n a - -class - (MultiValue.RationalConstant a, IntegerConstant a) => - RationalConstant a where - fromRational' :: (TypeNum.Positive n) => Rational -> T n a - -instance IntegerConstant Float where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Double where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Word where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Word8 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Word64 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Int where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Int8 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Int16 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Int32 where fromInteger' = fromIntegerPrimitive -instance IntegerConstant Int64 where fromInteger' = fromIntegerPrimitive - -fromIntegerPrimitive :: - (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a, - Repr n a ~ Value n a) => - Integer -> T n a -fromIntegerPrimitive = Cons . LLVM.value . SoV.constFromInteger - -instance RationalConstant Float where fromRational' = fromRationalPrimitive -instance RationalConstant Double where fromRational' = fromRationalPrimitive - -fromRationalPrimitive :: - (TypeNum.Positive n, IsPrimitive a, SoV.RationalConstant a, - Repr n a ~ Value n a) => - Rational -> T n a -fromRationalPrimitive = Cons . LLVM.value . SoV.constFromRational - -instance - (TypeNum.Positive n, IntegerConstant a) => - A.IntegerConstant (T n a) where - fromInteger' = fromInteger' - -instance - (TypeNum.Positive n, RationalConstant a) => - A.RationalConstant (T n a) where - fromRational' = fromRational' - - -modify :: - (TypeNum.Positive n, C a) => - LLVM.Value Word32 -> - (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) -> - (T n a -> CodeGenFunction r (T n a)) -modify k f v = - flip (insert k) v =<< f =<< extract k v - - -assemble :: - (TypeNum.Positive n, C a) => - [MultiValue.T a] -> CodeGenFunction r (T n a) -assemble = - foldlM (\v (k,x) -> insert (valueOf k) x v) undef . - List.zip [0..] - -dissect :: - (TypeNum.Positive n, C a) => - T n a -> LLVM.CodeGenFunction r [MultiValue.T a] -dissect = sequence . dissectList - -dissectList :: - (TypeNum.Positive n, C a) => - T n a -> [LLVM.CodeGenFunction r (MultiValue.T a)] -dissectList x = - List.map - (flip extract x . LLVM.valueOf) - (List.take (size x) [0..]) - - -assemble1 :: - (TypeNum.Positive n, C a) => - NonEmpty.T [] (MultiValue.T a) -> CodeGenFunction r (T n a) -assemble1 = assemble . NonEmpty.flatten - -dissect1 :: - (TypeNum.Positive n, C a) => - T n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (MultiValue.T a)) -dissect1 = sequence . dissectList1 - -dissectList1 :: - (TypeNum.Positive n, C a) => - T n a -> NonEmpty.T [] (LLVM.CodeGenFunction r (MultiValue.T a)) -dissectList1 x = - fmap - (flip extract x . LLVM.valueOf) - (0 !: List.take (size x - 1) [1 ..]) - - -assembleFromVector :: - (TypeNum.Positive n, C a) => - LLVM.Vector n (MultiValue.T a) -> CodeGenFunction r (T n a) -assembleFromVector = - fmap snd . - foldlM (\(k,v) x -> (,) (k+1) <$> insert (valueOf k) x v) (0,undef) - - -map :: - (TypeNum.Positive n, C a, C b) => - (MultiValue.T a -> CodeGenFunction r (MultiValue.T b)) -> - (T n a -> CodeGenFunction r (T n b)) -map f = assemble <=< mapM f <=< dissect - - -singleton :: (C a) => MultiValue.T a -> CodeGenFunction r (T TypeNum.D1 a) -singleton x = insert (LLVM.value LLVM.zero) x undef - -replicate :: - (TypeNum.Positive n, C a) => - MultiValue.T a -> CodeGenFunction r (T n a) -replicate x = do - single <- singleton x - shuffle (constCyclicVector $ NonEmpty.singleton 0) single undef - -iterate :: - (TypeNum.Positive n, C a) => - (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) -> - MultiValue.T a -> CodeGenFunction r (T n a) -iterate f x = fmap snd $ iterateCore f x Tuple.undef - -iterateCore :: - (TypeNum.Positive n, C a) => - (MultiValue.T a -> CodeGenFunction r (MultiValue.T a)) -> - MultiValue.T a -> T n a -> - CodeGenFunction r (MultiValue.T a, T n a) -iterateCore f x0 v0 = - foldlM - (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v)) - (x0,v0) - (List.take (size v0) [0..]) - - -sum :: - (TypeNum.Positive n, Additive a) => - T n a -> CodeGenFunction r (MultiValue.T a) -sum = - NonEmpty.foldBalanced (\x y -> join $ liftA2 MultiValue.add x y) . - dissectList1 - -dotProduct :: - (TypeNum.Positive n, PseudoRing a) => - T n a -> T n a -> CodeGenFunction r (MultiValue.T a) -dotProduct x y = sum =<< mul x y - - -cumulate :: - (TypeNum.Positive n, Additive a) => - MultiValue.T a -> T n a -> - CodeGenFunction r (MultiValue.T a, T n a) -cumulate a x0 = do - (b,x1) <- shiftUp a x0 - y <- cumulate1 x1 - z <- A.add b =<< last y - return (z,y) - -{- | -Needs (log n) vector additions --} -cumulate1 :: - (TypeNum.Positive n, Additive a) => - T n a -> CodeGenFunction r (T n a) -cumulate1 x = - foldlM - (\y k -> A.add y =<< shiftUpMultiZero k y) - x - (List.takeWhile (< size x) $ List.iterate (2*) 1) - - --- * re-ordering of elements - -constCyclicVector :: - (LLVM.IsConst a, TypeNum.Positive n) => - NonEmpty.T [] a -> LLVM.ConstValue (LLVM.Vector n a) -constCyclicVector = - LLVM.constCyclicVector . fmap LLVM.constOf - -shuffleMatch :: - (TypeNum.Positive n, C a) => - LLVM.ConstValue (LLVM.Vector n Word32) -> T n a -> - CodeGenFunction r (T n a) -shuffleMatch k v = shuffle k v undef - -{- | -Rotate one element towards the higher elements. - -I don't want to call it rotateLeft or rotateRight, -because there is no prefered layout for the vector elements. -In Intel's instruction manual vector -elements are indexed like the bits, -that is from right to left. -However, when working with Haskell list and enumeration syntax, -the start index is left. --} -rotateUp :: - (TypeNum.Positive n, C a) => - T n a -> CodeGenFunction r (T n a) -rotateUp x = - shuffleMatch (constCyclicVector $ (size x - 1) !: [0..]) x - -rotateDown :: - (TypeNum.Positive n, C a) => - T n a -> CodeGenFunction r (T n a) -rotateDown x = - shuffleMatch - (constCyclicVector $ - NonEmpty.snoc (List.take (size x - 1) [1..]) 0) x - -reverse :: - (TypeNum.Positive n, C a) => - T n a -> CodeGenFunction r (T n a) -reverse x = - shuffleMatch - (constCyclicVector $ - maybe (error "vector size must be positive") NonEmpty.reverse $ - NonEmpty.fetch $ - List.take (size x) [0..]) - x - -take :: - (TypeNum.Positive n, TypeNum.Positive m, C a) => - T n a -> CodeGenFunction r (T m a) -take u = shuffle (constCyclicVector $ NonEmptyC.iterate (1+) 0) u undef - -takeRev :: - (TypeNum.Positive n, TypeNum.Positive m, C a) => - T n a -> CodeGenFunction r (T m a) -takeRev u = do - let v0 = zero - v <- - shuffle - (constCyclicVector $ NonEmptyC.iterate (1+) (size u - size v0)) - u undef - return $ v `asTypeOf` v0 - -shiftUp :: - (TypeNum.Positive n, C a) => - MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a) -shiftUp x0 x = do - y <- - shuffleMatch - (LLVM.constCyclicVector $ LLVM.undef !: List.map LLVM.constOf [0..]) x - Monad.lift2 (,) (last x) (insert (value LLVM.zero) x0 y) - -shiftDown :: - (TypeNum.Positive n, C a) => - MultiValue.T a -> T n a -> CodeGenFunction r (MultiValue.T a, T n a) -shiftDown x0 x = do - y <- - shuffleMatch - (LLVM.constCyclicVector $ - NonEmpty.snoc - (List.map LLVM.constOf $ List.take (size x - 1) [1..]) - LLVM.undef) x - Monad.lift2 (,) - (extract (value LLVM.zero) x) - (insert (LLVM.valueOf (size x - 1)) x0 y) - -shiftUpMultiIndices :: - (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32) -shiftUpMultiIndices n sizev = - constCyclicVector $ fmap P.fromIntegral $ - NonEmpty.appendLeft (List.replicate n sizev) (NonEmptyC.iterate (1+) 0) - -shiftDownMultiIndices :: - (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32) -shiftDownMultiIndices n sizev = - constCyclicVector $ fmap P.fromIntegral $ - NonEmpty.appendLeft - (List.takeWhile (< sizev) $ List.iterate (1+) n) - (NonEmptyC.repeat sizev) - -shiftUpMultiZero :: - (TypeNum.Positive n, C a) => - Int -> T n a -> LLVM.CodeGenFunction r (T n a) -shiftUpMultiZero n v = - shuffle (shiftUpMultiIndices n (size v)) v zero - -shiftDownMultiZero :: - (TypeNum.Positive n, C a) => - Int -> T n a -> LLVM.CodeGenFunction r (T n a) -shiftDownMultiZero n v = - shuffle (shiftDownMultiIndices n (size v)) v zero - -shiftUpMultiUndef :: - (TypeNum.Positive n, C a) => - Int -> T n a -> LLVM.CodeGenFunction r (T n a) -shiftUpMultiUndef n v = - shuffle (shiftUpMultiIndices n (size v)) v undef - -shiftDownMultiUndef :: - (TypeNum.Positive n, C a) => - Int -> T n a -> LLVM.CodeGenFunction r (T n a) -shiftDownMultiUndef n v = - shuffle (shiftDownMultiIndices n (size v)) v undef - - --- * method implementations based on Traversable - -shuffleMatchTraversable :: - (TypeNum.Positive n, C a, Trav.Traversable f) => - LLVM.ConstValue (LLVM.Vector n Word32) -> - f (T n a) -> CodeGenFunction r (f (T n a)) -shuffleMatchTraversable is v = - Trav.mapM (shuffleMatch is) v - -insertTraversable :: - (TypeNum.Positive n, C a, Trav.Traversable f, App.Applicative f) => - LLVM.Value Word32 -> f (MultiValue.T a) -> - f (T n a) -> CodeGenFunction r (f (T n a)) -insertTraversable n a v = - Trav.sequence (liftA2 (insert n) a v) - -extractTraversable :: - (TypeNum.Positive n, C a, Trav.Traversable f) => - LLVM.Value Word32 -> f (T n a) -> - CodeGenFunction r (f (MultiValue.T a)) -extractTraversable n v = - Trav.mapM (extract n) v - - - -lift1 :: (Repr n a -> Repr n b) -> T n a -> T n b -lift1 f (Cons a) = Cons $ f a - -_liftM0 :: - (Monad m) => - m (Repr n a) -> - m (T n a) -_liftM0 f = Monad.lift Cons f - -liftM0 :: - (Monad m, - Repr n a ~ Value n ar) => - m (Value n ar) -> - m (T n a) -liftM0 f = Monad.lift consPrim f - -liftM :: - (Monad m, - Repr n a ~ Value n ar, - Repr n b ~ Value n br) => - (Value n ar -> m (Value n br)) -> - T n a -> m (T n b) -liftM f a = Monad.lift consPrim $ f (deconsPrim a) - -liftM2 :: - (Monad m, - Repr n a ~ Value n ar, - Repr n b ~ Value n br, - Repr n c ~ Value n cr) => - (Value n ar -> Value n br -> m (Value n cr)) -> - T n a -> T n b -> m (T n c) -liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) - -liftM3 :: - (Monad m, - Repr n a ~ Value n ar, - Repr n b ~ Value n br, - Repr n c ~ Value n cr, - Repr n d ~ Value n dr) => - (Value n ar -> Value n br -> Value n cr -> m (Value n dr)) -> - T n a -> T n b -> T n c -> m (T n d) -liftM3 f a b c = - Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) (deconsPrim c) - - - -class (MultiValue.Additive a, C a) => Additive a where - add :: - (TypeNum.Positive n) => - T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - sub :: - (TypeNum.Positive n) => - T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - neg :: - (TypeNum.Positive n) => - T n a -> LLVM.CodeGenFunction r (T n a) - -instance Additive Float where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Double where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Int where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Int8 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Int16 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Int32 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Int64 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Word where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Word8 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Word16 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Word32 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance Additive Word64 where - add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg - -instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where - zero = zero - add = add - sub = sub - neg = neg - - -class (MultiValue.PseudoRing a, Additive a) => PseudoRing a where - mul :: - (TypeNum.Positive n) => - T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - -instance PseudoRing Float where - mul = liftM2 LLVM.mul - -instance PseudoRing Double where - mul = liftM2 LLVM.mul - -instance (TypeNum.Positive n, PseudoRing a) => A.PseudoRing (T n a) where - mul = mul - - -class (MultiValue.Field a, PseudoRing a) => Field a where - fdiv :: - (TypeNum.Positive n) => - T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - -instance Field Float where - fdiv = liftM2 LLVM.fdiv - -instance Field Double where - fdiv = liftM2 LLVM.fdiv - -instance (TypeNum.Positive n, Field a) => A.Field (T n a) where - fdiv = fdiv - - -scale :: - (TypeNum.Positive n, PseudoRing a) => - MultiValue.T a -> T n a -> LLVM.CodeGenFunction r (T n a) -scale a v = flip mul v =<< replicate a - - -type instance A.Scalar (T n a) = T n (MultiValue.Scalar a) - -class - (MultiValue.PseudoModule v, PseudoRing (MultiValue.Scalar v), Additive v) => - PseudoModule v where - scaleMulti :: - (TypeNum.Positive n) => - T n (MultiValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v) - -instance PseudoModule Float where - scaleMulti = liftM2 A.mul - -instance PseudoModule Double where - scaleMulti = liftM2 A.mul - -instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where - scale = scaleMulti - - -class (MultiValue.Real a, Additive a) => Real a where - min :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - max :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - abs :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - signum :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - -instance Real Float where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Double where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word8 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word16 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word32 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Word64 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int8 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int16 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int32 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - -instance Real Int64 where - min = liftM2 A.min - max = liftM2 A.max - abs = liftM A.abs - signum = liftM A.signum - - -instance (TypeNum.Positive n, Real a) => A.Real (T n a) where - min = min - max = max - abs = abs - signum = signum - - -class (MultiValue.Fraction a, Real a) => Fraction a where - truncate :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - fraction :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - -instance Fraction Float where - truncate = liftM A.truncate - fraction = liftM A.fraction - -instance Fraction Double where - truncate = liftM A.truncate - fraction = liftM A.fraction - -instance (TypeNum.Positive n, Fraction a) => A.Fraction (T n a) where - truncate = truncate - fraction = fraction - - -class - (TypeNum.Positive n, Repr n i ~ Value n ir, - MultiValue.NativeInteger i ir, IsPrimitive ir, LLVM.IsInteger ir) => - NativeInteger n i ir where - -instance (TypeNum.Positive n) => NativeInteger n Word Word where -instance (TypeNum.Positive n) => NativeInteger n Word8 Word8 where -instance (TypeNum.Positive n) => NativeInteger n Word16 Word16 where -instance (TypeNum.Positive n) => NativeInteger n Word32 Word32 where -instance (TypeNum.Positive n) => NativeInteger n Word64 Word64 where - -instance (TypeNum.Positive n) => NativeInteger n Int Int where -instance (TypeNum.Positive n) => NativeInteger n Int8 Int8 where -instance (TypeNum.Positive n) => NativeInteger n Int16 Int16 where -instance (TypeNum.Positive n) => NativeInteger n Int32 Int32 where -instance (TypeNum.Positive n) => NativeInteger n Int64 Int64 where - -class - (TypeNum.Positive n, Repr n a ~ Value n ar, - MultiValue.NativeFloating a ar, IsPrimitive ar, LLVM.IsFloating ar) => - NativeFloating n a ar where - -instance (TypeNum.Positive n) => NativeFloating n Float Float where -instance (TypeNum.Positive n) => NativeFloating n Double Double where - -fromIntegral :: - (NativeInteger n i ir, NativeFloating n a ar) => - T n i -> LLVM.CodeGenFunction r (T n a) -fromIntegral = liftM LLVM.inttofp - - -class (MultiValue.Algebraic a, Field a) => Algebraic a where - sqrt :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - -instance Algebraic Float where - sqrt = liftM A.sqrt - -instance Algebraic Double where - sqrt = liftM A.sqrt - -instance (TypeNum.Positive n, Algebraic a) => A.Algebraic (T n a) where - sqrt = sqrt - - -class (MultiValue.Transcendental a, Algebraic a) => Transcendental a where - pi :: (TypeNum.Positive n) => LLVM.CodeGenFunction r (T n a) - sin, cos, exp, log :: - (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - pow :: - (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - -instance Transcendental Float where - pi = liftM0 A.pi - sin = liftM A.sin - cos = liftM A.cos - exp = liftM A.exp - log = liftM A.log - pow = liftM2 A.pow - -instance Transcendental Double where - pi = liftM0 A.pi - sin = liftM A.sin - cos = liftM A.cos - exp = liftM A.exp - log = liftM A.log - pow = liftM2 A.pow - -instance (TypeNum.Positive n, Transcendental a) => A.Transcendental (T n a) where - pi = pi - sin = sin - cos = cos - exp = exp - log = log - pow = pow - - - -class (MultiValue.Select a, C a) => Select a where - select :: - (TypeNum.Positive n) => - T n Bool -> T n a -> T n a -> - LLVM.CodeGenFunction r (T n a) - -instance Select Float where select = liftM3 LLVM.select -instance Select Double where select = liftM3 LLVM.select -instance Select Bool where select = liftM3 LLVM.select -instance Select Word where select = liftM3 LLVM.select -instance Select Word8 where select = liftM3 LLVM.select -instance Select Word16 where select = liftM3 LLVM.select -instance Select Word32 where select = liftM3 LLVM.select -instance Select Word64 where select = liftM3 LLVM.select -instance Select Int where select = liftM3 LLVM.select -instance Select Int8 where select = liftM3 LLVM.select -instance Select Int16 where select = liftM3 LLVM.select -instance Select Int32 where select = liftM3 LLVM.select -instance Select Int64 where select = liftM3 LLVM.select - -instance (Select a, Select b) => Select (a,b) where - select x y0 y1 = - case (unzip y0, unzip y1) of - ((a0,b0), (a1,b1)) -> - Monad.lift2 zip - (select x a0 a1) - (select x b0 b1) - -instance (Select a, Select b, Select c) => Select (a,b,c) where - select x y0 y1 = - case (unzip3 y0, unzip3 y1) of - ((a0,b0,c0), (a1,b1,c1)) -> - Monad.lift3 zip3 - (select x a0 a1) - (select x b0 b1) - (select x c0 c1) - - - -class (MultiValue.Comparison a, Real a) => Comparison a where - cmp :: - (TypeNum.Positive n) => - LLVM.CmpPredicate -> T n a -> T n a -> - LLVM.CodeGenFunction r (T n Bool) - -instance Comparison Float where cmp = liftM2 . LLVM.cmp -instance Comparison Double where cmp = liftM2 . LLVM.cmp -instance Comparison Word where cmp = liftM2 . LLVM.cmp -instance Comparison Word8 where cmp = liftM2 . LLVM.cmp -instance Comparison Word16 where cmp = liftM2 . LLVM.cmp -instance Comparison Word32 where cmp = liftM2 . LLVM.cmp -instance Comparison Word64 where cmp = liftM2 . LLVM.cmp -instance Comparison Int where cmp = liftM2 . LLVM.cmp -instance Comparison Int8 where cmp = liftM2 . LLVM.cmp -instance Comparison Int16 where cmp = liftM2 . LLVM.cmp -instance Comparison Int32 where cmp = liftM2 . LLVM.cmp -instance Comparison Int64 where cmp = liftM2 . LLVM.cmp - -instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where - type CmpResult (T n a) = T n Bool - cmp = cmp - - - -class - (MultiValue.FloatingComparison a, Comparison a) => - FloatingComparison a where - fcmp :: - (TypeNum.Positive n) => - LLVM.FPPredicate -> T n a -> T n a -> - LLVM.CodeGenFunction r (T n Bool) - -instance FloatingComparison Float where - fcmp = liftM2 . LLVM.fcmp - -instance - (TypeNum.Positive n, FloatingComparison a) => - A.FloatingComparison (T n a) where - fcmp = fcmp - - - -class (MultiValue.Logic a, C a) => Logic a where - and, or, xor :: - (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - inv :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) - -instance Logic Bool where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word8 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word16 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word32 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - -instance Logic Word64 where - and = liftM2 LLVM.and; or = liftM2 LLVM.or - xor = liftM2 LLVM.xor; inv = liftM LLVM.inv - - -instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where - and = and - or = or - xor = xor - inv = inv - - - -class (MultiValue.BitShift a, C a) => BitShift a where - shl :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - shr :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) - -instance BitShift Word where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word8 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word16 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word32 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Word64 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr - -instance BitShift Int where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int8 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int16 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int32 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr - -instance BitShift Int64 where - shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr +module LLVM.Extra.Multi.Vector + {-# DEPRECATED "Use LLVM.Extra.Nice.Vector instead." #-} + (module LLVM.Extra.Nice.Vector) where + +import LLVM.Extra.Nice.Vector diff --git a/src/LLVM/Extra/Multi/Vector/Instance.hs b/src/LLVM/Extra/Multi/Vector/Instance.hs --- a/src/LLVM/Extra/Multi/Vector/Instance.hs +++ b/src/LLVM/Extra/Multi/Vector/Instance.hs @@ -1,106 +1,36 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module LLVM.Extra.Multi.Vector.Instance where - -import qualified LLVM.Extra.Multi.Vector as Vector -import qualified LLVM.Extra.Multi.Value.Private as MultiValue -import LLVM.Extra.Multi.Value.Private (Repr, ) - -import qualified LLVM.Core as LLVM - -import qualified Type.Data.Num.Decimal as TypeNum +module LLVM.Extra.Multi.Vector.Instance + {-# DEPRECATED "Use LLVM.Extra.Nice.Vector.Instance instead." #-} + where -import Data.Functor ((<$>), ) +import qualified LLVM.Extra.Nice.Vector.Instance as Inst +import qualified LLVM.Extra.Nice.Vector as Vector import Prelude2010 import Prelude () -type MVVector n a = MultiValue.T (LLVM.Vector n a) +type MVVector n a = Inst.NVVector n a toMultiValue :: Vector.T n a -> MVVector n a -toMultiValue (Vector.Cons x) = MultiValue.Cons x +toMultiValue = Inst.toNiceValue fromMultiValue :: MVVector n a -> Vector.T n a -fromMultiValue (MultiValue.Cons x) = Vector.Cons x +fromMultiValue = Inst.fromNiceValue liftMultiValueM :: (Functor f) => (Vector.T n a -> f (Vector.T m b)) -> (MVVector n a -> f (MVVector m b)) -liftMultiValueM f a = - toMultiValue <$> f (fromMultiValue a) +liftMultiValueM = Inst.liftNiceValueM liftMultiValueM2 :: (Functor f) => (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) -> (MVVector n a -> MVVector m b -> f (MVVector k c)) -liftMultiValueM2 f a b = - toMultiValue <$> f (fromMultiValue a) (fromMultiValue b) +liftMultiValueM2 = Inst.liftNiceValueM2 liftMultiValueM3 :: (Functor f) => (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) -> (MVVector n a -> MVVector m b -> MVVector m c -> f (MVVector k d)) -liftMultiValueM3 f a b c = - toMultiValue <$> f (fromMultiValue a) (fromMultiValue b) (fromMultiValue c) - -instance - (TypeNum.Positive n, Vector.C a) => - MultiValue.C (LLVM.Vector n a) where - type Repr (LLVM.Vector n a) = Vector.Repr n a - cons = toMultiValue . Vector.cons - undef = toMultiValue Vector.undef - zero = toMultiValue Vector.zero - phi = liftMultiValueM . Vector.phi - addPhi bb x y = Vector.addPhi bb (fromMultiValue x) (fromMultiValue y) - -instance - (TypeNum.Positive n, Vector.IntegerConstant a) => - MultiValue.IntegerConstant (LLVM.Vector n a) where - fromInteger' = toMultiValue . Vector.fromInteger' - -instance - (TypeNum.Positive n, Vector.RationalConstant a) => - MultiValue.RationalConstant (LLVM.Vector n a) where - fromRational' = toMultiValue . Vector.fromRational' - -instance - (TypeNum.Positive n, Vector.Additive a) => - MultiValue.Additive (LLVM.Vector n a) where - add = liftMultiValueM2 Vector.add - sub = liftMultiValueM2 Vector.sub - neg = liftMultiValueM Vector.neg - -instance - (TypeNum.Positive n, Vector.PseudoRing a) => - MultiValue.PseudoRing (LLVM.Vector n a) where - mul = liftMultiValueM2 Vector.mul - -instance - (TypeNum.Positive n, Vector.Real a) => - MultiValue.Real (LLVM.Vector n a) where - min = liftMultiValueM2 Vector.min - max = liftMultiValueM2 Vector.max - abs = liftMultiValueM Vector.abs - signum = liftMultiValueM Vector.signum - -instance - (TypeNum.Positive n, Vector.Fraction a) => - MultiValue.Fraction (LLVM.Vector n a) where - truncate = liftMultiValueM Vector.truncate - fraction = liftMultiValueM Vector.fraction - -instance - (TypeNum.Positive n, Vector.Logic a) => - MultiValue.Logic (LLVM.Vector n a) where - and = liftMultiValueM2 Vector.and - or = liftMultiValueM2 Vector.or - xor = liftMultiValueM2 Vector.xor - inv = liftMultiValueM Vector.inv - -instance - (TypeNum.Positive n, Vector.BitShift a) => - MultiValue.BitShift (LLVM.Vector n a) where - shl = liftMultiValueM2 Vector.shl - shr = liftMultiValueM2 Vector.shr +liftMultiValueM3 = Inst.liftNiceValueM3 diff --git a/src/LLVM/Extra/Nice/Class.hs b/src/LLVM/Extra/Nice/Class.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Class.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module LLVM.Extra.Nice.Class where + +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Nice.Vector as NiceVector +import qualified LLVM.Extra.Arithmetic as A + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + + +class C value where + type Size value + switch :: + f NiceValue.T -> + f (NiceVector.T (Size value)) -> + f value + +instance C NiceValue.T where + type Size NiceValue.T = TypeNum.D1 + switch x _ = x + +instance (TypeNum.Positive n) => C (NiceVector.T n) where + type Size (NiceVector.T n) = n + switch _ x = x + + +newtype Const a value = Const {getConst :: value a} + +undef :: + (C value, Size value ~ n, TypeNum.Positive n, NiceVector.C a) => + value a +undef = + getConst $ + switch + (Const NiceValue.undef) + (Const NiceVector.undef) + +zero :: + (C value, Size value ~ n, TypeNum.Positive n, NiceVector.C a) => + value a +zero = + getConst $ + switch + (Const NiceValue.zero) + (Const NiceVector.zero) + + +newtype + Op0 r a value = + Op0 {runOp0 :: LLVM.CodeGenFunction r (value a)} + +newtype + Op1 r a b value = + Op1 {runOp1 :: value a -> LLVM.CodeGenFunction r (value b)} + +newtype + Op2 r a b c value = + Op2 {runOp2 :: value a -> value b -> LLVM.CodeGenFunction r (value c)} + +add, sub :: + (TypeNum.Positive n, NiceVector.Additive a, + n ~ Size value, C value) => + value a -> value a -> LLVM.CodeGenFunction r (value a) +add = runOp2 $ switch (Op2 A.add) (Op2 A.add) +sub = runOp2 $ switch (Op2 A.sub) (Op2 A.sub) + +neg :: + (TypeNum.Positive n, NiceVector.Additive a, + n ~ Size value, C value) => + value a -> LLVM.CodeGenFunction r (value a) +neg = runOp1 $ switch (Op1 A.neg) (Op1 A.neg) + + +mul :: + (TypeNum.Positive n, NiceVector.PseudoRing a, + n ~ Size value, C value) => + value a -> value a -> LLVM.CodeGenFunction r (value a) +mul = runOp2 $ switch (Op2 A.mul) (Op2 A.mul) +fdiv :: + (TypeNum.Positive n, NiceVector.Field a, + n ~ Size value, C value) => + value a -> value a -> LLVM.CodeGenFunction r (value a) +fdiv = runOp2 $ switch (Op2 A.fdiv) (Op2 A.fdiv) + +scale :: + (TypeNum.Positive n, NiceVector.PseudoModule v, + n ~ Size value, C value) => + value (NiceValue.Scalar v) -> value v -> LLVM.CodeGenFunction r (value v) +scale = runOp2 $ switch (Op2 A.scale) (Op2 A.scale) + +min, max :: + (TypeNum.Positive n, NiceVector.Real a, + n ~ Size value, C value) => + value a -> value a -> LLVM.CodeGenFunction r (value a) +min = runOp2 $ switch (Op2 A.min) (Op2 A.min) +max = runOp2 $ switch (Op2 A.max) (Op2 A.max) + +abs, signum :: + (TypeNum.Positive n, NiceVector.Real a, + n ~ Size value, C value) => + value a -> LLVM.CodeGenFunction r (value a) +abs = runOp1 $ switch (Op1 A.abs) (Op1 A.abs) +signum = runOp1 $ switch (Op1 A.signum) (Op1 A.signum) + +truncate, fraction :: + (TypeNum.Positive n, NiceVector.Fraction a, + n ~ Size value, C value) => + value a -> LLVM.CodeGenFunction r (value a) +truncate = runOp1 $ switch (Op1 A.truncate) (Op1 A.truncate) +fraction = runOp1 $ switch (Op1 A.fraction) (Op1 A.fraction) + +sqrt :: + (TypeNum.Positive n, NiceVector.Algebraic a, + n ~ Size value, C value) => + value a -> LLVM.CodeGenFunction r (value a) +sqrt = runOp1 $ switch (Op1 A.sqrt) (Op1 A.sqrt) + +pi :: + (TypeNum.Positive n, NiceVector.Transcendental a, + n ~ Size value, C value) => + LLVM.CodeGenFunction r (value a) +pi = runOp0 $ switch (Op0 A.pi) (Op0 A.pi) + +sin, cos, exp, log :: + (TypeNum.Positive n, NiceVector.Transcendental a, + n ~ Size value, C value) => + value a -> LLVM.CodeGenFunction r (value a) +sin = runOp1 $ switch (Op1 A.sin) (Op1 A.sin) +cos = runOp1 $ switch (Op1 A.cos) (Op1 A.cos) +exp = runOp1 $ switch (Op1 A.exp) (Op1 A.exp) +log = runOp1 $ switch (Op1 A.log) (Op1 A.log) + +pow :: + (TypeNum.Positive n, NiceVector.Transcendental a, + n ~ Size value, C value) => + value a -> value a -> LLVM.CodeGenFunction r (value a) +pow = runOp2 $ switch (Op2 A.pow) (Op2 A.pow) + + +cmp :: + (TypeNum.Positive n, NiceVector.Comparison a, + n ~ Size value, C value) => + LLVM.CmpPredicate -> + value a -> value a -> LLVM.CodeGenFunction r (value Bool) +cmp p = runOp2 $ switch (Op2 $ A.cmp p) (Op2 $ A.cmp p) + +fcmp :: + (TypeNum.Positive n, NiceVector.FloatingComparison a, + n ~ Size value, C value) => + LLVM.FPPredicate -> + value a -> value a -> LLVM.CodeGenFunction r (value Bool) +fcmp p = runOp2 $ switch (Op2 $ A.fcmp p) (Op2 $ A.fcmp p) + + +and, or, xor :: + (TypeNum.Positive n, NiceVector.Logic a, + n ~ Size value, C value) => + value a -> value a -> LLVM.CodeGenFunction r (value a) +and = runOp2 $ switch (Op2 A.and) (Op2 A.and) +or = runOp2 $ switch (Op2 A.or) (Op2 A.or) +xor = runOp2 $ switch (Op2 A.xor) (Op2 A.xor) + +inv :: + (TypeNum.Positive n, NiceVector.Logic a, + n ~ Size value, C value) => + value a -> LLVM.CodeGenFunction r (value a) +inv = runOp1 $ switch (Op1 A.inv) (Op1 A.inv) diff --git a/src/LLVM/Extra/Nice/Iterator.hs b/src/LLVM/Extra/Nice/Iterator.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Iterator.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE TypeFamilies #-} +module LLVM.Extra.Nice.Iterator ( + takeWhile, + countDown, + take, + Enum(..), + ) where + +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.Iterator as Iter +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.MaybePrivate as Maybe +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as C + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction) + +import Control.Applicative (liftA2) + +import qualified Data.Enum.Storable as Enum + +import qualified Prelude as P +import Prelude hiding (take, takeWhile, Enum, enumFrom, enumFromTo) + + + +takeWhile :: + (a -> CodeGenFunction r (NiceValue.T Bool)) -> + Iter.T r a -> Iter.T r a +takeWhile p = Iter.takeWhile (fmap unpackBool . p) + +unpackBool :: NiceValue.T Bool -> LLVM.Value Bool +unpackBool (NiceValue.Cons b) = b + +countDown :: + (NiceValue.Additive i, NiceValue.Comparison i, + NiceValue.IntegerConstant i) => + NiceValue.T i -> Iter.T r (NiceValue.T i) +countDown len = + takeWhile (NiceValue.cmp LLVM.CmpLT NiceValue.zero) $ + Iter.iterate NiceValue.dec len + +take :: + (NiceValue.Additive i, NiceValue.Comparison i, + NiceValue.IntegerConstant i) => + NiceValue.T i -> Iter.T r a -> Iter.T r a +take len xs = liftA2 const xs (countDown len) + + +class (NiceValue.C a) => Enum a where + succ, pred :: NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a) + enumFrom :: NiceValue.T a -> Iter.T r (NiceValue.T a) + enumFromTo :: NiceValue.T a -> NiceValue.T a -> Iter.T r (NiceValue.T a) + +instance + (LLVM.IsInteger w, SoV.IntegerConstant w, Num w, + LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) => + Enum (Enum.T w e) where + succ = NiceValue.succ + pred = NiceValue.pred + enumFrom = Iter.iterate NiceValue.succ + {- | + More complicated than 'enumFromToSimple' + but works also for e.g. [0 .. (0xFFFF::Word16)]. + -} + enumFromTo from to = + Iter.takeWhileJust $ + Iter.iterate (Maybe.maybeArg Tuple.undef (succMax to)) (Maybe.just from) + +succMax :: + (LLVM.IsInteger w, SoV.IntegerConstant w, Num w, + LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) => + NiceValue.T (Enum.T w e) -> + NiceValue.T (Enum.T w e) -> + LLVM.CodeGenFunction r (Maybe.T (NiceValue.T (Enum.T w e))) +succMax to e = do + NiceValue.Cons less <- NiceValue.cmpEnum A.CmpLT e to + C.ifThen less (Maybe.nothing Tuple.undef) $ + fmap Maybe.just $ NiceValue.succ e + +{- | +Warning: For [0 .. (0xFFFF::Word16)] +it would compute an undefined @0xFFFF+1@. +In modulo arithmetic it would enter an infinite loop. +-} +_enumFromToSimple :: + (LLVM.IsInteger w, SoV.IntegerConstant w, Num w, + LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) => + NiceValue.T (Enum.T w e) -> + NiceValue.T (Enum.T w e) -> + Iter.T r (NiceValue.T (Enum.T w e)) +_enumFromToSimple from to = + takeWhile (NiceValue.cmpEnum LLVM.CmpGE to) $ enumFrom from diff --git a/src/LLVM/Extra/Nice/Value.hs b/src/LLVM/Extra/Nice/Value.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Value.hs @@ -0,0 +1,8 @@ +module LLVM.Extra.Nice.Value ( + module LLVM.Extra.Nice.Value.Private, + Array(..), withArraySize, extractArrayValue, insertArrayValue, + ) where + +import LLVM.Extra.Nice.Vector.Instance () +import LLVM.Extra.Nice.Value.Array +import LLVM.Extra.Nice.Value.Private diff --git a/src/LLVM/Extra/Nice/Value/Array.hs b/src/LLVM/Extra/Nice/Value/Array.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Value/Array.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module LLVM.Extra.Nice.Value.Array where + +import qualified LLVM.Extra.Memory as Memory +import qualified LLVM.Extra.Nice.Value.Marshal as Marshal +import qualified LLVM.Extra.Nice.Value.Private as NiceValue +import LLVM.Extra.Nice.Value.Private (Repr) + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum +import qualified Type.Data.Num.Decimal.Number as Dec +import Type.Base.Proxy (Proxy(Proxy)) + +import Control.Applicative (Applicative(pure, (<*>))) + +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import Data.Functor.Identity (Identity(Identity, runIdentity)) +import Data.Functor ((<$>)) + +import Prelude2010 +import Prelude () + + + +newtype Array n a = Array [a] + deriving (Eq, Show) + +instance (Dec.Integer n) => Functor (Array n) where + fmap f (Array xs) = Array (map f xs) + +instance (Dec.Integer n) => Applicative (Array n) where + pure x = + runIdentity $ withArraySize $ + \n -> Identity $ Array $ replicate (Dec.integralFromProxy n) x + Array fs <*> Array xs = Array $ zipWith id fs xs + +instance (Dec.Integer n) => Fold.Foldable (Array n) where + foldMap f (Array xs) = Fold.foldMap f xs + +instance (Dec.Integer n) => Trav.Traversable (Array n) where + traverse f (Array xs) = Array <$> Trav.traverse f xs + +withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a) +withArraySize f = f Proxy + + +instance (TypeNum.Natural n, Marshal.C a) => NiceValue.C (Array n a) where + type Repr (Array n a) = LLVM.Value (LLVM.Array n (Marshal.Struct a)) + cons (Array xs) = NiceValue.consPrimitive $ LLVM.Array $ map Marshal.pack xs + undef = NiceValue.undefPrimitive + zero = NiceValue.zeroPrimitive + phi = NiceValue.phiPrimitive + addPhi = NiceValue.addPhiPrimitive + +instance + (TypeNum.Natural n, Marshal.C a, + Dec.Natural (n Dec.:*: LLVM.SizeOf (Marshal.Struct a))) => + Marshal.C (Array n a) where + pack (Array xs) = LLVM.Array $ map Marshal.pack xs + unpack (LLVM.Array xs) = Array $ map Marshal.unpack xs + +extractArrayValue :: + (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) => + i -> NiceValue.T (Array n a) -> + LLVM.CodeGenFunction r (NiceValue.T a) +extractArrayValue i (NiceValue.Cons arr) = + NiceValue.Cons <$> (Memory.decompose =<< LLVM.extractvalue arr i) + +insertArrayValue :: + (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) => + i -> NiceValue.T a -> NiceValue.T (Array n a) -> + LLVM.CodeGenFunction r (NiceValue.T (Array n a)) +insertArrayValue i (NiceValue.Cons a) (NiceValue.Cons arr) = + NiceValue.Cons <$> (flip (LLVM.insertvalue arr) i =<< Memory.compose a) diff --git a/src/LLVM/Extra/Nice/Value/Marshal.hs b/src/LLVM/Extra/Nice/Value/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Value/Marshal.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{- | +Transfer values between Haskell and JIT generated code +in an LLVM-compatible format. +E.g. 'Bool' is stored as 'i1' and occupies a byte, +@'Vector' n 'Bool'@ is stored as a bit vector, +@'Vector' n 'Word8'@ is stored in an order depending on machine endianess, +and Haskell tuples are stored as LLVM structs. +-} +module LLVM.Extra.Nice.Value.Marshal ( + C(..), + Struct, + peek, + poke, + + VectorStruct, + Vector(..), + + with, + EE.alloca, + ) where + +import qualified LLVM.Extra.Nice.Vector as NiceVector +import qualified LLVM.Extra.Nice.Value.Private as NiceValue +import qualified LLVM.Extra.Memory as Memory +import LLVM.Extra.Nice.Vector.Instance () + +import qualified LLVM.ExecutionEngine as EE +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Control.Functor.HT as FuncHT +import Control.Applicative (liftA2, liftA3, (<$>)) + +import Foreign.Storable (Storable) +import Foreign.StablePtr (StablePtr) +import Foreign.Ptr (FunPtr, Ptr) + +import Data.Complex (Complex((:+))) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64) + + + +peek :: + (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> IO a +peek ptr = unpack <$> EE.peek ptr + +poke :: + (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO () +poke ptr = EE.poke ptr . pack + + +type Struct a = Memory.Struct (NiceValue.Repr a) + +class + (NiceValue.C a, Memory.C (NiceValue.Repr a), + EE.Marshal (Struct a), LLVM.IsConst (Struct a)) => + C a where + pack :: a -> Struct a + unpack :: Struct a -> a + +instance C Bool where pack = id; unpack = id +instance C Float where pack = id; unpack = id +instance C Double where pack = id; unpack = id +instance C Word where pack = id; unpack = id +instance C Word8 where pack = id; unpack = id +instance C Word16 where pack = id; unpack = id +instance C Word32 where pack = id; unpack = id +instance C Word64 where pack = id; unpack = id +instance C Int where pack = id; unpack = id +instance C Int8 where pack = id; unpack = id +instance C Int16 where pack = id; unpack = id +instance C Int32 where pack = id; unpack = id +instance C Int64 where pack = id; unpack = id + +instance (Storable a) => C (Ptr a) where pack = id; unpack = id +instance (LLVM.IsType a) => C (LLVM.Ptr a) where pack = id; unpack = id +instance (LLVM.IsFunction a) => C (FunPtr a) where pack = id; unpack = id +instance C (StablePtr a) where pack = id; unpack = id + +instance C () where + pack = LLVM.Struct + unpack (LLVM.Struct unit) = unit + +instance (C a, C b) => C (a,b) where + pack (a,b) = LLVM.consStruct (pack a) (pack b) + unpack = LLVM.uncurryStruct $ \a b -> (unpack a, unpack b) + +instance (C a, C b, C c) => C (a,b,c) where + pack (a,b,c) = LLVM.consStruct (pack a) (pack b) (pack c) + unpack = LLVM.uncurryStruct $ \a b c -> (unpack a, unpack b, unpack c) + +instance (C a, C b, C c, C d) => C (a,b,c,d) where + pack (a,b,c,d) = LLVM.consStruct (pack a) (pack b) (pack c) (pack d) + unpack = + LLVM.uncurryStruct $ \a b c d -> (unpack a, unpack b, unpack c, unpack d) + + +instance (C a) => C (Complex a) where + pack (a:+b) = LLVM.consStruct (pack a) (pack b) + unpack = LLVM.uncurryStruct $ \a b -> unpack a :+ unpack b + + + +type VectorStruct n a = Memory.Struct (NiceVector.Repr n a) + +class + (TypeNum.Positive n, C a, + NiceVector.C a, Memory.C (NiceVector.Repr n a), + EE.Marshal (VectorStruct n a), + LLVM.IsConst (VectorStruct n a)) => + Vector n a where + packVector :: LLVM.Vector n a -> VectorStruct n a + unpackVector :: VectorStruct n a -> LLVM.Vector n a + +instance (TypeNum.Positive n, Vector n a) => C (LLVM.Vector n a) where + pack = packVector; unpack = unpackVector + + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) => + Vector n Bool where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) => + Vector n Float where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) => + Vector n Double where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) => + Vector n Word where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) => + Vector n Word8 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) => + Vector n Word16 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) => + Vector n Word32 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) => + Vector n Word64 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) => + Vector n Int where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) => + Vector n Int8 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) => + Vector n Int16 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) => + Vector n Int32 where + packVector = id + unpackVector = id + +instance + (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) => + Vector n Int64 where + packVector = id + unpackVector = id + +instance (Vector n a, Vector n b) => Vector n (a,b) where + packVector x = + case FuncHT.unzip x of + (a,b) -> LLVM.consStruct (packVector a) (packVector b) + unpackVector = LLVM.uncurryStruct $ \a b -> + liftA2 (,) (unpackVector a) (unpackVector b) + +instance (Vector n a, Vector n b, Vector n c) => Vector n (a,b,c) where + packVector x = + case FuncHT.unzip3 x of + (a,b,c) -> LLVM.consStruct (packVector a) (packVector b) (packVector c) + unpackVector = LLVM.uncurryStruct $ \a b c -> + liftA3 (,,) (unpackVector a) (unpackVector b) (unpackVector c) + + +with :: (C a) => a -> (LLVM.Ptr (Struct a) -> IO b) -> IO b +with a act = EE.alloca $ \ptr -> poke ptr a >> act ptr diff --git a/src/LLVM/Extra/Nice/Value/Private.hs b/src/LLVM/Extra/Nice/Value/Private.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Value/Private.hs @@ -0,0 +1,1491 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module LLVM.Extra.Nice.Value.Private where + +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Control as C +import qualified LLVM.Extra.Tuple as Tuple +import qualified LLVM.Extra.Struct as Struct + +import qualified LLVM.ExecutionEngine as EE +import qualified LLVM.Core as LLVM +import LLVM.Core (WordN, IntN, ) + +import qualified Type.Data.Num.Decimal.Number as Dec + +import qualified Foreign.Storable.Record.Tuple as StoreTuple +import Foreign.StablePtr (StablePtr, ) +import Foreign.Ptr (Ptr, FunPtr, ) + +import qualified Control.Monad.HT as Monad +import qualified Control.Functor.HT as FuncHT +import Control.Monad (Monad, return, fmap, (>>), ) +import Data.Functor (Functor, ) + +import qualified Data.Tuple.HT as TupleHT +import qualified Data.Tuple as Tup +import qualified Data.EnumBitSet as EnumBitSet +import qualified Data.Enum.Storable as Enum +import qualified Data.Bool8 as Bool8 +import Data.Complex (Complex((:+))) +import Data.Tagged (Tagged(Tagged, unTagged)) +import Data.Function (id, (.), ($), ) +import Data.Maybe (Maybe(Nothing,Just), ) +import Data.Bool (Bool(False,True), ) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64, Int) +import Data.Bool8 (Bool8) + +import qualified Prelude as P +import Prelude (Float, Double, Integer, Rational, ) + + +newtype T a = Cons (Repr a) + + +class C a where + type Repr a + cons :: a -> T a + undef :: T a + zero :: T a + phi :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) + addPhi :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () + +instance C Bool where + type Repr Bool = LLVM.Value Bool + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Float where + type Repr Float = LLVM.Value Float + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Double where + type Repr Double = LLVM.Value Double + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Word where + type Repr Word = LLVM.Value Word + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Word8 where + type Repr Word8 = LLVM.Value Word8 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Word16 where + type Repr Word16 = LLVM.Value Word16 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Word32 where + type Repr Word32 = LLVM.Value Word32 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Word64 where + type Repr Word64 = LLVM.Value Word64 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance (Dec.Positive n) => C (LLVM.WordN n) where + type Repr (LLVM.WordN n) = LLVM.Value (LLVM.WordN n) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Int where + type Repr Int = LLVM.Value Int + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Int8 where + type Repr Int8 = LLVM.Value Int8 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Int16 where + type Repr Int16 = LLVM.Value Int16 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Int32 where + type Repr Int32 = LLVM.Value Int32 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C Int64 where + type Repr Int64 = LLVM.Value Int64 + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance (Dec.Positive n) => C (LLVM.IntN n) where + type Repr (LLVM.IntN n) = LLVM.Value (LLVM.IntN n) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance (LLVM.IsType a) => C (LLVM.Ptr a) where + type Repr (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C (Ptr a) where + type Repr (Ptr a) = LLVM.Value (Ptr a) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance (LLVM.IsFunction a) => C (FunPtr a) where + type Repr (FunPtr a) = LLVM.Value (FunPtr a) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +instance C (StablePtr a) where + type Repr (StablePtr a) = LLVM.Value (StablePtr a) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + + +cast :: (Repr a ~ Repr b) => T a -> T b +cast (Cons a) = Cons a + + +consPrimitive :: + (LLVM.IsConst al, LLVM.Value al ~ Repr a) => + al -> T a +consPrimitive = Cons . LLVM.valueOf + +undefPrimitive, zeroPrimitive :: + (LLVM.IsType al, LLVM.Value al ~ Repr a) => + T a +undefPrimitive = Cons $ LLVM.value LLVM.undef +zeroPrimitive = Cons $ LLVM.value LLVM.zero + +phiPrimitive :: + (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) => + LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) +phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a + +addPhiPrimitive :: + (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) => + LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () +addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b + + +consTuple :: (Tuple.Value a, Repr a ~ Tuple.ValueOf a) => a -> T a +consTuple = Cons . Tuple.valueOf + +undefTuple :: (Repr a ~ al, Tuple.Undefined al) => T a +undefTuple = Cons Tuple.undef + +zeroTuple :: (Repr a ~ al, Tuple.Zero al) => T a +zeroTuple = Cons Tuple.zero + +phiTuple :: + (Repr a ~ al, Tuple.Phi al) => + LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) +phiTuple bb (Cons a) = fmap Cons $ Tuple.phi bb a + +addPhiTuple :: + (Repr a ~ al, Tuple.Phi al) => + LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () +addPhiTuple bb (Cons a) (Cons b) = Tuple.addPhi bb a b + + +instance C () where + type Repr () = () + cons = consUnit + undef = undefUnit + zero = zeroUnit + phi = phiUnit + addPhi = addPhiUnit + +consUnit :: (Repr a ~ ()) => a -> T a +consUnit _ = Cons () + +undefUnit :: (Repr a ~ ()) => T a +undefUnit = Cons () + +zeroUnit :: (Repr a ~ ()) => T a +zeroUnit = Cons () + +phiUnit :: + (Repr a ~ ()) => + LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) +phiUnit _bb (Cons ()) = return $ Cons () + +addPhiUnit :: + (Repr a ~ ()) => + LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () +addPhiUnit _bb (Cons ()) (Cons ()) = return () + + +instance C Bool8 where + type Repr Bool8 = LLVM.Value Bool + cons = consPrimitive . Bool8.toBool + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +boolPFrom8 :: T Bool8 -> T Bool +boolPFrom8 (Cons b) = Cons b + +bool8FromP :: T Bool -> T Bool8 +bool8FromP (Cons b) = Cons b + +intFromBool8 :: (NativeInteger i ir) => T Bool8 -> LLVM.CodeGenFunction r (T i) +intFromBool8 = liftM LLVM.zadapt + +floatFromBool8 :: + (NativeFloating a ar) => T Bool8 -> LLVM.CodeGenFunction r (T a) +floatFromBool8 = liftM LLVM.uitofp + + +instance + (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e) => + C (Enum.T w e) where + type Repr (Enum.T w e) = LLVM.Value w + cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + +toEnum :: + (Repr w ~ LLVM.Value w) => + T w -> T (Enum.T w e) +toEnum (Cons w) = Cons w + +fromEnum :: + (Repr w ~ LLVM.Value w) => + T (Enum.T w e) -> T w +fromEnum (Cons w) = Cons w + +succ, pred :: + (LLVM.IsArithmetic w, SoV.IntegerConstant w) => + T (Enum.T w e) -> LLVM.CodeGenFunction r (T (Enum.T w e)) +succ = liftM $ \w -> A.add w A.one +pred = liftM $ \w -> A.sub w A.one + +-- cannot be an instance of 'Comparison' because there is no 'Real' instance +cmpEnum :: + (LLVM.CmpRet w, LLVM.IsPrimitive w) => + LLVM.CmpPredicate -> T (Enum.T w a) -> T (Enum.T w a) -> + LLVM.CodeGenFunction r (T Bool) +cmpEnum = liftM2 . LLVM.cmp + + +class (C a) => Bounded a where + minBound, maxBound :: T a + +instance + (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e, P.Bounded e) => + Bounded (Enum.T w e) where + minBound = cons P.minBound + maxBound = cons P.maxBound + + +instance (LLVM.IsInteger w, LLVM.IsConst w) => C (EnumBitSet.T w i) where + type Repr (EnumBitSet.T w i) = LLVM.Value w + cons = consPrimitive . EnumBitSet.decons + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + + +instance (C a) => C (Maybe a) where + type Repr (Maybe a) = (LLVM.Value Bool, Repr a) + cons Nothing = nothing + cons (Just a) = just $ cons a + undef = toMaybe undef undef + zero = toMaybe (cons False) zero + phi bb ma = + case splitMaybe ma of + (b,a) -> Monad.lift2 toMaybe (phi bb b) (phi bb a) + addPhi bb x y = + case (splitMaybe x, splitMaybe y) of + ((xb,xa), (yb,ya)) -> + addPhi bb xb yb >> + addPhi bb xa ya + +splitMaybe :: T (Maybe a) -> (T Bool, T a) +splitMaybe (Cons (b,a)) = (Cons b, Cons a) + +toMaybe :: T Bool -> T a -> T (Maybe a) +toMaybe (Cons b) (Cons a) = Cons (b,a) + +nothing :: (C a) => T (Maybe a) +nothing = toMaybe (cons False) undef + +just :: T a -> T (Maybe a) +just = toMaybe (cons True) + + +instance (C a, C b) => C (a,b) where + type Repr (a, b) = (Repr a, Repr b) + cons (a,b) = zip (cons a) (cons b) + undef = zip undef undef + zero = zip zero zero + phi bb a = + case unzip a of + (a0,a1) -> + Monad.lift2 zip (phi bb a0) (phi bb a1) + addPhi bb a b = + case (unzip a, unzip b) of + ((a0,a1), (b0,b1)) -> + addPhi bb a0 b0 >> + addPhi bb a1 b1 + +instance (C a, C b, C c) => C (a,b,c) where + type Repr (a, b, c) = (Repr a, Repr b, Repr c) + cons (a,b,c) = zip3 (cons a) (cons b) (cons c) + undef = zip3 undef undef undef + zero = zip3 zero zero zero + phi bb a = + case unzip3 a of + (a0,a1,a2) -> + Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2) + addPhi bb a b = + case (unzip3 a, unzip3 b) of + ((a0,a1,a2), (b0,b1,b2)) -> + addPhi bb a0 b0 >> + addPhi bb a1 b1 >> + addPhi bb a2 b2 + +instance (C a, C b, C c, C d) => C (a,b,c,d) where + type Repr (a, b, c, d) = (Repr a, Repr b, Repr c, Repr d) + cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d) + undef = zip4 undef undef undef undef + zero = zip4 zero zero zero zero + phi bb a = + case unzip4 a of + (a0,a1,a2,a3) -> + Monad.lift4 zip4 (phi bb a0) (phi bb a1) (phi bb a2) (phi bb a3) + addPhi bb a b = + case (unzip4 a, unzip4 b) of + ((a0,a1,a2,a3), (b0,b1,b2,b3)) -> + addPhi bb a0 b0 >> + addPhi bb a1 b1 >> + addPhi bb a2 b2 >> + addPhi bb a3 b3 + + +fst :: T (a,b) -> T a +fst (Cons (a,_b)) = Cons a + +snd :: T (a,b) -> T b +snd (Cons (_a,b)) = Cons b + +curry :: (T (a,b) -> c) -> (T a -> T b -> c) +curry f a b = f $ zip a b + +uncurry :: (T a -> T b -> c) -> (T (a,b) -> c) +uncurry f = Tup.uncurry f . unzip + + +mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b) +mapFst f = Tup.uncurry zip . TupleHT.mapFst f . unzip + +mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1) +mapSnd f = Tup.uncurry zip . TupleHT.mapSnd f . unzip + +mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b)) +mapFstF f = fmap (Tup.uncurry zip) . FuncHT.mapFst f . unzip + +mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1)) +mapSndF f = fmap (Tup.uncurry zip) . FuncHT.mapSnd f . unzip + +swap :: T (a,b) -> T (b,a) +swap = Tup.uncurry zip . TupleHT.swap . unzip + + +fst3 :: T (a,b,c) -> T a +fst3 (Cons (a,_b,_c)) = Cons a + +snd3 :: T (a,b,c) -> T b +snd3 (Cons (_a,b,_c)) = Cons b + +thd3 :: T (a,b,c) -> T c +thd3 (Cons (_a,_b,c)) = Cons c + +curry3 :: (T (a,b,c) -> d) -> (T a -> T b -> T c -> d) +curry3 f a b c = f $ zip3 a b c + +uncurry3 :: (T a -> T b -> T c -> d) -> (T (a,b,c) -> d) +uncurry3 f = TupleHT.uncurry3 f . unzip3 + + +mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c) +mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3 + +mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c) +mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3 + +mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1) +mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3 + +mapFst3F :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b,c) -> f (T (a1,b,c)) +mapFst3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapFst3 f . unzip3 + +mapSnd3F :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0,c) -> f (T (a,b1,c)) +mapSnd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapSnd3 f . unzip3 + +mapThd3F :: (Functor f) => (T c0 -> f (T c1)) -> T (a,b,c0) -> f (T (a,b,c1)) +mapThd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapThd3 f . unzip3 + + +zip :: T a -> T b -> T (a,b) +zip (Cons a) (Cons b) = Cons (a,b) + +zip3 :: T a -> T b -> T c -> T (a,b,c) +zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c) + +zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d) +zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d) + +unzip :: T (a,b) -> (T a, T b) +unzip (Cons (a,b)) = (Cons a, Cons b) + +unzip3 :: T (a,b,c) -> (T a, T b, T c) +unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c) + +unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d) +unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d) + + +instance (C tuple) => C (StoreTuple.Tuple tuple) where + type Repr (StoreTuple.Tuple tuple) = Repr tuple + cons = tuple . cons . StoreTuple.getTuple + undef = tuple undef + zero = tuple zero + phi bb = fmap tuple . phi bb . untuple + addPhi bb a b = addPhi bb (untuple a) (untuple b) + +tuple :: T tuple -> T (StoreTuple.Tuple tuple) +tuple (Cons a) = Cons a + +untuple :: T (StoreTuple.Tuple tuple) -> T tuple +untuple (Cons a) = Cons a + + +class Struct struct where + consStruct :: (Struct.T struct ~ a) => a -> T a + undefStruct :: (Struct.T struct ~ a) => T a + zeroStruct :: (Struct.T struct ~ a) => T a + phiStruct :: (Struct.T struct ~ a) => + LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a) + addPhiStruct :: (Struct.T struct ~ a) => + LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r () + +instance (Struct struct) => C (Struct.T struct) where + type Repr (Struct.T struct) = Struct.T (Repr struct) + cons = consStruct + undef = undefStruct + zero = zeroStruct + phi = phiStruct + addPhi = addPhiStruct + +instance Struct () where + consStruct unit = Cons unit + undefStruct = Cons (Struct.Cons ()) + zeroStruct = Cons (Struct.Cons ()) + phiStruct _bb = return + addPhiStruct _bb _a _b = return () + +structCons :: T a -> T (Struct.T as) -> T (Struct.T (a,as)) +structCons (Cons b) (Cons (Struct.Cons bs)) = Cons (Struct.Cons (b,bs)) + +structUncons :: T (Struct.T (a,as)) -> (T a, T (Struct.T as)) +structUncons (Cons (Struct.Cons (b,bs))) = (Cons b, Cons (Struct.Cons bs)) + +instance (C a, Struct as) => Struct (a,as) where + consStruct (Struct.Cons (a,as)) = + structCons (cons a) (consStruct (Struct.Cons as)) + undefStruct = structCons undef undefStruct + zeroStruct = structCons zero zeroStruct + phiStruct bb at = + case structUncons at of + (a,as) -> Monad.lift2 structCons (phi bb a) (phiStruct bb as) + addPhiStruct bb at bt = + case (structUncons at, structUncons bt) of + ((a,as), (b,bs)) -> addPhi bb a b >> addPhiStruct bb as bs + + +instance (LLVM.IsConst a, LLVM.IsFirstClass a) => C (EE.Stored a) where + type Repr (EE.Stored a) = LLVM.Value a + cons = Cons . LLVM.valueOf . EE.getStored + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + + +instance C a => C (Tagged tag a) where + type Repr (Tagged tag a) = Repr a + cons = tag . cons . unTagged + undef = tag undef + zero = tag zero + phi bb = fmap tag . phi bb . untag + addPhi bb a b = addPhi bb (untag a) (untag b) + +tag :: T a -> T (Tagged tag a) +tag = cast + +untag :: T (Tagged tag a) -> T a +untag = cast + +liftTaggedM :: + (Monad m) => (T a -> m (T b)) -> T (Tagged tag a) -> m (T (Tagged tag b)) +liftTaggedM f = Monad.lift tag . f . untag + +liftTaggedM2 :: + (Monad m) => + (T a -> T b -> m (T c)) -> + T (Tagged tag a) -> T (Tagged tag b) -> m (T (Tagged tag c)) +liftTaggedM2 f a b = Monad.lift tag $ f (untag a) (untag b) + + +instance (C a) => C (Complex a) where + type Repr (Complex a) = Complex (Repr a) + cons (a:+b) = consComplex (cons a) (cons b) + undef = consComplex undef undef + zero = consComplex zero zero + phi bb a = + case deconsComplex a of + (a0,a1) -> + Monad.lift2 consComplex (phi bb a0) (phi bb a1) + addPhi bb a b = + case (deconsComplex a, deconsComplex b) of + ((a0,a1), (b0,b1)) -> + addPhi bb a0 b0 >> + addPhi bb a1 b1 + +consComplex :: T a -> T a -> T (Complex a) +consComplex (Cons a) (Cons b) = Cons (a:+b) + +deconsComplex :: T (Complex a) -> (T a, T a) +deconsComplex (Cons (a:+b)) = (Cons a, Cons b) + + + +class Compose nicetuple where + type Composed nicetuple + {- | + A nested 'zip'. + -} + compose :: nicetuple -> T (Composed nicetuple) + +class + (Composed (Decomposed T pattern) ~ PatternTuple pattern) => + Decompose pattern where + {- | + A nested 'unzip'. + Since it is not obvious how deep to decompose nested tuples, + you must provide a pattern of the decomposed tuple. + E.g. + + > f :: NiceValue ((a,b),(c,d)) -> + > ((NiceValue a, NiceValue b), NiceValue (c,d)) + > f = decompose ((atom,atom),atom) + -} + decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern + +type family Decomposed (f :: * -> *) pattern +type family PatternTuple pattern + + +{- | +A combination of 'compose' and 'decompose' +that let you operate on tuple NiceValues as Haskell tuples. +-} +modify :: + (Compose a, Decompose pattern) => + pattern -> + (Decomposed T pattern -> a) -> + T (PatternTuple pattern) -> T (Composed a) +modify p f = compose . f . decompose p + +modify2 :: + (Compose a, Decompose patternA, Decompose patternB) => + patternA -> + patternB -> + (Decomposed T patternA -> Decomposed T patternB -> a) -> + T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a) +modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b) + +modifyF :: + (Compose a, Decompose pattern, Functor f) => + pattern -> + (Decomposed T pattern -> f a) -> + T (PatternTuple pattern) -> f (T (Composed a)) +modifyF p f = fmap compose . f . decompose p + +modifyF2 :: + (Compose a, Decompose patternA, Decompose patternB, + Functor f) => + patternA -> + patternB -> + (Decomposed T patternA -> Decomposed T patternB -> f a) -> + T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a)) +modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b) + + + +instance Compose (T a) where + type Composed (T a) = a + compose = id + +instance Decompose (Atom a) where + decompose _ = id + +type instance Decomposed f (Atom a) = f a +type instance PatternTuple (Atom a) = a + +data Atom a = Atom + +atom :: Atom a +atom = Atom + + +instance Compose () where + type Composed () = () + compose = cons + +instance Decompose () where + decompose () _ = () + +type instance Decomposed f () = () +type instance PatternTuple () = () + + +instance (Compose a, Compose b) => Compose (a,b) where + type Composed (a,b) = (Composed a, Composed b) + compose = Tup.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 + +type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb) +type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb) + + +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 + +type instance Decomposed f (pa,pb,pc) = + (Decomposed f pa, Decomposed f pb, Decomposed f pc) +type instance PatternTuple (pa,pb,pc) = + (PatternTuple pa, PatternTuple pb, PatternTuple pc) + + +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) +type instance Decomposed f (pa,pb,pc,pd) = + (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd) +type instance PatternTuple (pa,pb,pc,pd) = + (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd) + + +instance (Compose tuple) => Compose (StoreTuple.Tuple tuple) where + type Composed (StoreTuple.Tuple tuple) = StoreTuple.Tuple (Composed tuple) + compose = tuple . compose . StoreTuple.getTuple + +instance (Decompose p) => Decompose (StoreTuple.Tuple p) where + decompose (StoreTuple.Tuple p) = StoreTuple.Tuple . decompose p . untuple + +type instance Decomposed f (StoreTuple.Tuple p) = + StoreTuple.Tuple (Decomposed f p) +type instance PatternTuple (StoreTuple.Tuple p) = + StoreTuple.Tuple (PatternTuple p) + + +instance (Compose a) => Compose (Tagged tag a) where + type Composed (Tagged tag a) = Tagged tag (Composed a) + compose = tag . compose . unTagged + +instance (Decompose pa) => Decompose (Tagged tag pa) where + decompose (Tagged p) = Tagged . decompose p . untag + +type instance Decomposed f (Tagged tag pa) = Tagged tag (Decomposed f pa) +type instance PatternTuple (Tagged tag pa) = Tagged tag (PatternTuple pa) + + +instance (Compose a) => Compose (Complex a) where + type Composed (Complex a) = Complex (Composed a) + compose (a:+b) = consComplex (compose a) (compose b) + +instance (Decompose pa) => Decompose (Complex pa) where + decompose (pa:+pb) = + Tup.uncurry (:+) . + TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex + +type instance Decomposed f (Complex pa) = Complex (Decomposed f pa) +type instance PatternTuple (Complex pa) = Complex (PatternTuple pa) + +realPart, imagPart :: T (Complex a) -> T a +realPart (Cons (a:+_)) = Cons a +imagPart (Cons (_:+b)) = Cons b + + + +lift1 :: (Repr a -> Repr b) -> T a -> T b +lift1 f (Cons a) = Cons $ f a + +liftM0 :: + (Monad m) => + m (Repr a) -> + m (T a) +liftM0 f = Monad.lift Cons f + +liftM :: + (Monad m) => + (Repr a -> m (Repr b)) -> + T a -> m (T b) +liftM f (Cons a) = Monad.lift Cons $ f a + +liftM2 :: + (Monad m) => + (Repr a -> Repr b -> m (Repr c)) -> + T a -> T b -> m (T c) +liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b + +liftM3 :: + (Monad m) => + (Repr a -> Repr b -> Repr c -> + m (Repr d)) -> + T a -> T b -> T c -> m (T d) +liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c + + +instance (C a) => Tuple.Zero (T a) where + zero = zero + +instance (C a) => Tuple.Undefined (T a) where + undef = undef + +instance (C a) => Tuple.Phi (T a) where + phi = phi + addPhi = addPhi + + +class (C a) => IntegerConstant a where + fromInteger' :: Integer -> T a + +class (IntegerConstant a) => RationalConstant a where + fromRational' :: Rational -> T a + +instance IntegerConstant Float where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger + +instance IntegerConstant Word where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger + +instance IntegerConstant Int where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger + +instance (Dec.Positive n) => IntegerConstant (WordN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger +instance (Dec.Positive n) => IntegerConstant (IntN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger + +instance IntegerConstant a => IntegerConstant (Tagged tag a) where + fromInteger' = tag . fromInteger' + +instance RationalConstant Float where fromRational' = Cons . LLVM.value . SoV.constFromRational +instance RationalConstant Double where fromRational' = Cons . LLVM.value . SoV.constFromRational + +instance RationalConstant a => RationalConstant (Tagged tag a) where + fromRational' = tag . fromRational' + + +instance (IntegerConstant a) => A.IntegerConstant (T a) where + fromInteger' = fromInteger' + +instance (RationalConstant a) => A.RationalConstant (T a) where + fromRational' = fromRational' + + +class (C a) => Additive a where + add :: T a -> T a -> LLVM.CodeGenFunction r (T a) + sub :: T a -> T a -> LLVM.CodeGenFunction r (T a) + neg :: T a -> LLVM.CodeGenFunction r (T a) + +instance Additive Float where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Double where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Word where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Word8 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Word16 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Word32 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Word64 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Int where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Int8 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Int16 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Int32 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive Int64 where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance (Dec.Positive n) => Additive (WordN n) where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance (Dec.Positive n) => Additive (IntN n) where + add = liftM2 LLVM.add + sub = liftM2 LLVM.sub + neg = liftM LLVM.neg + +instance Additive a => Additive (Tagged tag a) where + add = liftTaggedM2 add + sub = liftTaggedM2 sub + neg = liftTaggedM neg + +instance (Additive a) => A.Additive (T a) where + zero = zero + add = add + sub = sub + neg = neg + +inc, dec :: + (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i) +inc x = add x A.one +dec x = sub x A.one + + +class (Additive a) => PseudoRing a where + mul :: T a -> T a -> LLVM.CodeGenFunction r (T a) + +instance PseudoRing Float where mul = liftM2 LLVM.mul +instance PseudoRing Double where mul = liftM2 LLVM.mul +instance PseudoRing Word where mul = liftM2 LLVM.mul +instance PseudoRing Word8 where mul = liftM2 LLVM.mul +instance PseudoRing Word16 where mul = liftM2 LLVM.mul +instance PseudoRing Word32 where mul = liftM2 LLVM.mul +instance PseudoRing Word64 where mul = liftM2 LLVM.mul +instance PseudoRing Int where mul = liftM2 LLVM.mul +instance PseudoRing Int8 where mul = liftM2 LLVM.mul +instance PseudoRing Int16 where mul = liftM2 LLVM.mul +instance PseudoRing Int32 where mul = liftM2 LLVM.mul +instance PseudoRing Int64 where mul = liftM2 LLVM.mul + +instance (PseudoRing a) => PseudoRing (Tagged tag a) where + mul = liftTaggedM2 mul + +instance (PseudoRing a) => A.PseudoRing (T a) where + mul = mul + + +class (PseudoRing a) => Field a where + fdiv :: T a -> T a -> LLVM.CodeGenFunction r (T a) + +instance Field Float where + fdiv = liftM2 LLVM.fdiv + +instance Field Double where + fdiv = liftM2 LLVM.fdiv + +instance (Field a) => Field (Tagged tag a) where + fdiv = liftTaggedM2 fdiv + +instance (Field a) => A.Field (T a) where + fdiv = fdiv + + +type family Scalar vector +type instance Scalar Float = Float +type instance Scalar Double = Double +type instance Scalar (Tagged tag a) = Tagged tag (Scalar a) +type instance A.Scalar (T a) = T (Scalar a) + +class (PseudoRing (Scalar v), Additive v) => PseudoModule v where + scale :: T (Scalar v) -> T v -> LLVM.CodeGenFunction r (T v) + +instance PseudoModule Float where + scale = liftM2 A.mul + +instance PseudoModule Double where + scale = liftM2 A.mul + +instance (PseudoModule a) => PseudoModule (Tagged tag a) where + scale = liftTaggedM2 scale + +instance (PseudoModule a) => A.PseudoModule (T a) where + scale = scale + + +class (Additive a) => Real a where + min :: T a -> T a -> LLVM.CodeGenFunction r (T a) + max :: T a -> T a -> LLVM.CodeGenFunction r (T a) + abs :: T a -> LLVM.CodeGenFunction r (T a) + signum :: T a -> LLVM.CodeGenFunction r (T a) + +instance Real Float where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Double where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word8 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word16 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word32 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word64 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int8 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int16 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int32 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int64 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance (Dec.Positive n) => Real (WordN n) where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance (Dec.Positive n) => Real (IntN n) where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance (Real a) => Real (Tagged tag a) where + min = liftTaggedM2 min + max = liftTaggedM2 max + abs = liftTaggedM abs + signum = liftTaggedM signum + +instance (Real a) => A.Real (T a) where + min = min + max = max + abs = abs + signum = signum + + +class (Real a) => Fraction a where + truncate :: T a -> LLVM.CodeGenFunction r (T a) + fraction :: T a -> LLVM.CodeGenFunction r (T a) + +instance Fraction Float where + truncate = liftM A.truncate + fraction = liftM A.fraction + +instance Fraction Double where + truncate = liftM A.truncate + fraction = liftM A.fraction + +instance (Fraction a) => Fraction (Tagged tag a) where + truncate = liftTaggedM truncate + fraction = liftTaggedM fraction + +instance (Fraction a) => A.Fraction (T a) where + truncate = truncate + fraction = fraction + + +class + (Repr i ~ LLVM.Value ir, + LLVM.IsInteger ir, SoV.IntegerConstant ir, + LLVM.CmpRet ir, LLVM.IsPrimitive ir) => + NativeInteger i ir where + +instance NativeInteger Word Word where +instance NativeInteger Word8 Word8 where +instance NativeInteger Word16 Word16 where +instance NativeInteger Word32 Word32 where +instance NativeInteger Word64 Word64 where + +instance NativeInteger Int Int where +instance NativeInteger Int8 Int8 where +instance NativeInteger Int16 Int16 where +instance NativeInteger Int32 Int32 where +instance NativeInteger Int64 Int64 where + +instance NativeInteger a a => NativeInteger (Tagged tag a) a where + + +class + (Repr a ~ LLVM.Value ar, + LLVM.IsFloating ar, SoV.RationalConstant ar, + LLVM.CmpRet ar, LLVM.IsPrimitive ar) => + NativeFloating a ar where + +instance NativeFloating Float Float where +instance NativeFloating Double Double where + + +truncateToInt, floorToInt, ceilingToInt, roundToIntFast :: + (NativeInteger i ir, NativeFloating a ar) => + T a -> LLVM.CodeGenFunction r (T i) +truncateToInt = liftM SoV.truncateToInt +floorToInt = liftM SoV.floorToInt +ceilingToInt = liftM SoV.ceilingToInt +roundToIntFast = liftM SoV.roundToIntFast + +splitFractionToInt :: + (NativeInteger i ir, NativeFloating a ar) => + T a -> LLVM.CodeGenFunction r (T (i,a)) +splitFractionToInt = liftM SoV.splitFractionToInt + + +class Field a => Algebraic a where + sqrt :: T a -> LLVM.CodeGenFunction r (T a) + +instance Algebraic Float where + sqrt = liftM A.sqrt + +instance Algebraic Double where + sqrt = liftM A.sqrt + +instance (Algebraic a) => Algebraic (Tagged tag a) where + sqrt = liftTaggedM sqrt + +instance (Algebraic a) => A.Algebraic (T a) where + sqrt = sqrt + + +class Algebraic a => Transcendental a where + pi :: LLVM.CodeGenFunction r (T a) + sin, cos, exp, log :: T a -> LLVM.CodeGenFunction r (T a) + pow :: T a -> T a -> LLVM.CodeGenFunction r (T a) + +instance Transcendental Float where + pi = liftM0 A.pi + sin = liftM A.sin + cos = liftM A.cos + exp = liftM A.exp + log = liftM A.log + pow = liftM2 A.pow + +instance Transcendental Double where + pi = liftM0 A.pi + sin = liftM A.sin + cos = liftM A.cos + exp = liftM A.exp + log = liftM A.log + pow = liftM2 A.pow + +instance (Transcendental a) => Transcendental (Tagged tag a) where + pi = fmap tag pi + sin = liftTaggedM sin + cos = liftTaggedM cos + exp = liftTaggedM exp + log = liftTaggedM log + pow = liftTaggedM2 pow + +instance (Transcendental a) => A.Transcendental (T a) where + pi = pi + sin = sin + cos = cos + exp = exp + log = log + pow = pow + + + +class (C a) => Select a where + select :: + T Bool -> T a -> T a -> + LLVM.CodeGenFunction r (T a) + +instance Select Bool where select = liftM3 LLVM.select +instance Select Bool8 where select = liftM3 LLVM.select +instance Select Float where select = liftM3 LLVM.select +instance Select Double where select = liftM3 LLVM.select +instance Select Word where select = liftM3 LLVM.select +instance Select Word8 where select = liftM3 LLVM.select +instance Select Word16 where select = liftM3 LLVM.select +instance Select Word32 where select = liftM3 LLVM.select +instance Select Word64 where select = liftM3 LLVM.select +instance Select Int where select = liftM3 LLVM.select +instance Select Int8 where select = liftM3 LLVM.select +instance Select Int16 where select = liftM3 LLVM.select +instance Select Int32 where select = liftM3 LLVM.select +instance Select Int64 where select = liftM3 LLVM.select + +instance (Select a, Select b) => Select (a,b) where + select b = + modifyF2 (atom,atom) (atom,atom) $ + \(a0,b0) (a1,b1) -> + Monad.lift2 (,) + (select b a0 a1) + (select b b0 b1) + +instance (Select a, Select b, Select c) => Select (a,b,c) where + select b = + modifyF2 (atom,atom,atom) (atom,atom,atom) $ + \(a0,b0,c0) (a1,b1,c1) -> + Monad.lift3 (,,) + (select b a0 a1) + (select b b0 b1) + (select b c0 c1) + +instance (Select a) => Select (Tagged tag a) where + select = liftTaggedM2 . select + +instance (Select a) => C.Select (T a) where + select b = select (Cons b) + + + +class (Real a) => Comparison a where + {- | + It must hold + + > max x y == do gt <- cmp CmpGT x y; select gt x y + -} + cmp :: + LLVM.CmpPredicate -> T a -> T a -> + LLVM.CodeGenFunction r (T Bool) + +instance Comparison Float where cmp = liftM2 . LLVM.cmp +instance Comparison Double where cmp = liftM2 . LLVM.cmp + +instance Comparison Int where cmp = liftM2 . LLVM.cmp +instance Comparison Int8 where cmp = liftM2 . LLVM.cmp +instance Comparison Int16 where cmp = liftM2 . LLVM.cmp +instance Comparison Int32 where cmp = liftM2 . LLVM.cmp +instance Comparison Int64 where cmp = liftM2 . LLVM.cmp + +instance Comparison Word where cmp = liftM2 . LLVM.cmp +instance Comparison Word8 where cmp = liftM2 . LLVM.cmp +instance Comparison Word16 where cmp = liftM2 . LLVM.cmp +instance Comparison Word32 where cmp = liftM2 . LLVM.cmp +instance Comparison Word64 where cmp = liftM2 . LLVM.cmp + +instance (Dec.Positive n) => Comparison (IntN n) where cmp = liftM2 . LLVM.cmp +instance (Dec.Positive n) => Comparison (WordN n) where cmp = liftM2 . LLVM.cmp + +instance (Comparison a) => Comparison (Tagged tag a) where + cmp p a b = cmp p (untag a) (untag b) + +instance (Comparison a) => A.Comparison (T a) where + type CmpResult (T a) = T Bool + cmp = cmp + + + +class (Comparison a) => FloatingComparison a where + fcmp :: + LLVM.FPPredicate -> T a -> T a -> + LLVM.CodeGenFunction r (T Bool) + +instance FloatingComparison Float where + fcmp = liftM2 . LLVM.fcmp + +instance (FloatingComparison a) => FloatingComparison (Tagged tag a) where + fcmp p a b = fcmp p (untag a) (untag b) + +instance (FloatingComparison a) => A.FloatingComparison (T a) where + fcmp = fcmp + + + +class (C a) => Logic a where + and :: T a -> T a -> LLVM.CodeGenFunction r (T a) + or :: T a -> T a -> LLVM.CodeGenFunction r (T a) + xor :: T a -> T a -> LLVM.CodeGenFunction r (T a) + inv :: T a -> LLVM.CodeGenFunction r (T a) + +instance Logic Bool where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Bool8 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word8 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word16 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word32 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word64 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance (Dec.Positive n) => Logic (WordN n) where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance (LLVM.IsInteger w, LLVM.IsConst w) => Logic (EnumBitSet.T w i) where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic a => Logic (Tagged tag a) where + and = liftTaggedM2 and; or = liftTaggedM2 or + xor = liftTaggedM2 xor; inv = liftTaggedM inv + + +instance Logic a => A.Logic (T a) where + and = and + or = or + xor = xor + inv = inv + + + +class BitShift a where + shl :: T a -> T a -> LLVM.CodeGenFunction r (T a) + shr :: T a -> T a -> LLVM.CodeGenFunction r (T a) + +instance BitShift Word where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word8 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word16 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word32 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word64 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Int where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int8 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int16 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int32 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int64 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + + + +class (PseudoRing a) => Integral a where + idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a) + irem :: T a -> T a -> LLVM.CodeGenFunction r (T a) + +instance Integral Word where + idiv = liftM2 LLVM.idiv + irem = liftM2 LLVM.irem + +instance Integral Word32 where + idiv = liftM2 LLVM.idiv + irem = liftM2 LLVM.irem + +instance Integral Word64 where + idiv = liftM2 LLVM.idiv + irem = liftM2 LLVM.irem + +instance Integral Int where + idiv = liftM2 LLVM.idiv + irem = liftM2 LLVM.irem + +instance Integral Int32 where + idiv = liftM2 LLVM.idiv + irem = liftM2 LLVM.irem + +instance Integral Int64 where + idiv = liftM2 LLVM.idiv + irem = liftM2 LLVM.irem + +instance (Integral a) => Integral (Tagged tag a) where + idiv = liftTaggedM2 idiv + irem = liftTaggedM2 irem + + +fromIntegral :: + (NativeInteger i ir, NativeFloating a ar) => + T i -> LLVM.CodeGenFunction r (T a) +fromIntegral = liftM LLVM.inttofp diff --git a/src/LLVM/Extra/Nice/Value/Storable.hs b/src/LLVM/Extra/Nice/Value/Storable.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Value/Storable.hs @@ -0,0 +1,417 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module LLVM.Extra.Nice.Value.Storable ( + -- * Basic class + C(load, store), + storeNext, + modify, + + -- * Classes for tuples and vectors + Tuple(..), + Vector(..), + TupleVector(..), + + -- * Standard method implementations + loadTraversable, + loadApplicative, + storeFoldable, + + -- * Pointer handling + Storable.advancePtr, + Storable.incrementPtr, + Storable.decrementPtr, + + -- * Loops over Storable arrays + Array.arrayLoop, + Array.arrayLoop2, + Array.arrayLoopMaybeCont, + Array.arrayLoopMaybeCont2, + ) where + +import qualified LLVM.Extra.Storable.Private as Storable +import qualified LLVM.Extra.Storable.Array as Array +import LLVM.Extra.Storable.Private + (BytePtr, advancePtrStatic, incPtrState, incrementPtr, update, + castFromBytePtr, castToBytePtr, + runElements, elementOffset, castElementPtr, + assemblePrimitive, disassemblePrimitive, proxyFromElement3) + +import qualified LLVM.Extra.Nice.Vector as NiceVector +import qualified LLVM.Extra.Nice.Value as NiceValue +import qualified LLVM.Extra.ArithmeticPrivate as A + +import qualified LLVM.ExecutionEngine as EE +import qualified LLVM.Util.Proxy as LP +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, Value) + +import qualified Type.Data.Num.Decimal as TypeNum + +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.Reader as MR +import qualified Control.Monad.Trans.State as MS +import qualified Control.Applicative.HT as App +import qualified Control.Functor.HT as FuncHT +import Control.Monad (foldM, replicateM, replicateM_, (<=<)) +import Control.Applicative (Applicative, pure, (<$>)) + +import qualified Foreign.Storable.Record.Tuple as StoreTuple +import qualified Foreign.Storable as Store +import Foreign.Ptr (Ptr) + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import Data.Orphans () +import Data.Tuple.HT (uncurry3) +import Data.Complex (Complex) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Bool8 (Bool8) + + + +class (Store.Storable a, NiceValue.C a) => C a where + {- + Not all Storable types have a compatible LLVM type, + or even more, one LLVM type that is compatible on all platforms. + -} + load :: Value (Ptr a) -> CodeGenFunction r (NiceValue.T a) + store :: NiceValue.T a -> Value (Ptr a) -> CodeGenFunction r () + +storeNext :: + (C a, Value (Ptr a) ~ ptr) => NiceValue.T a -> ptr -> CodeGenFunction r ptr +storeNext a ptr = store a ptr >> incrementPtr ptr + +modify :: + (C a, NiceValue.T a ~ al) => + (al -> CodeGenFunction r al) -> + Value (Ptr a) -> CodeGenFunction r () +modify f ptr = flip store ptr =<< f =<< load ptr + + +instance + (EE.Marshal a, LLVM.IsConst a, LLVM.IsFirstClass a) => + C (EE.Stored a) where + load = fmap NiceValue.Cons . LLVM.load <=< castFromStoredPtr + store (NiceValue.Cons a) = LLVM.store a <=< castFromStoredPtr + +castFromStoredPtr :: + (LLVM.IsType a) => + Value (Ptr (EE.Stored a)) -> CodeGenFunction r (Value (LLVM.Ptr a)) +castFromStoredPtr = LLVM.bitcast + + +loadPrimitive :: + (LLVM.Storable a, NiceValue.Repr a ~ LLVM.Value a) => + Value (Ptr a) -> CodeGenFunction r (NiceValue.T a) +loadPrimitive ptr = fmap NiceValue.Cons $ LLVM.load =<< LLVM.bitcast ptr + +storePrimitive :: + (LLVM.Storable a, NiceValue.Repr a ~ LLVM.Value a) => + NiceValue.T a -> Value (Ptr a) -> CodeGenFunction r () +storePrimitive (NiceValue.Cons a) ptr = LLVM.store a =<< LLVM.bitcast ptr + +instance C Float where + load = loadPrimitive; store = storePrimitive + +instance C Double where + load = loadPrimitive; store = storePrimitive + +instance C Word where + load = loadPrimitive; store = storePrimitive + +instance C Word8 where + load = loadPrimitive; store = storePrimitive + +instance C Word16 where + load = loadPrimitive; store = storePrimitive + +instance C Word32 where + load = loadPrimitive; store = storePrimitive + +instance C Word64 where + load = loadPrimitive; store = storePrimitive + +instance C Int where + load = loadPrimitive; store = storePrimitive + +instance C Int8 where + load = loadPrimitive; store = storePrimitive + +instance C Int16 where + load = loadPrimitive; store = storePrimitive + +instance C Int32 where + load = loadPrimitive; store = storePrimitive + +instance C Int64 where + load = loadPrimitive; store = storePrimitive + +{- | +Not very efficient implementation +because we want to adapt to @sizeOf Bool@ dynamically. +Unfortunately, LLVM-9's optimizer does not recognize the instruction pattern. +Better use 'Bool8' for booleans. +-} +instance C Bool where + load ptr = do + bytePtr <- castToBytePtr ptr + bytes <- + flip MS.evalStateT bytePtr $ + replicateM (Store.sizeOf (False :: Bool)) + (MT.lift . LLVM.load =<< incPtrState) + let zero = LLVM.valueOf 0 + mask <- foldM A.or zero bytes + NiceValue.Cons <$> A.cmp LLVM.CmpNE mask zero + store (NiceValue.Cons b) ptr = do + bytePtr <- castToBytePtr ptr + byte <- LLVM.sext b + flip MS.evalStateT bytePtr $ + replicateM_ (Store.sizeOf (False :: Bool)) + (MT.lift . LLVM.store byte =<< incPtrState) + +instance C Bool8 where + load ptr = + fmap NiceValue.Cons $ + A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr + store (NiceValue.Cons b) ptr = do + byte <- LLVM.zext b + LLVM.store byte =<< castToBytePtr ptr + +instance (C a) => C (Complex a) where + load = loadApplicative; store = storeFoldable + + + +instance (Tuple tuple) => C (StoreTuple.Tuple tuple) where + load ptr = NiceValue.tuple <$> loadTuple ptr + store = storeTuple . NiceValue.untuple + +class (StoreTuple.Storable tuple, NiceValue.C tuple) => Tuple tuple where + loadTuple :: + Value (Ptr (StoreTuple.Tuple tuple)) -> + CodeGenFunction r (NiceValue.T tuple) + storeTuple :: + NiceValue.T tuple -> + Value (Ptr (StoreTuple.Tuple tuple)) -> + CodeGenFunction r () + +instance (C a, C b) => Tuple (a,b) where + loadTuple ptr = + runElements ptr $ fmap (uncurry NiceValue.zip) $ + App.mapPair (loadElement, loadElement) $ + FuncHT.unzip $ proxyFromElement3 ptr + storeTuple = NiceValue.uncurry $ \a b ptr -> + case FuncHT.unzip $ proxyFromElement3 ptr of + (pa,pb) -> runElements ptr $ storeElement pa a >> storeElement pb b + +instance (C a, C b, C c) => Tuple (a,b,c) where + loadTuple ptr = + runElements ptr $ fmap (uncurry3 NiceValue.zip3) $ + App.mapTriple (loadElement, loadElement, loadElement) $ + FuncHT.unzip3 $ proxyFromElement3 ptr + storeTuple = NiceValue.uncurry3 $ \a b c ptr -> + case FuncHT.unzip3 $ proxyFromElement3 ptr of + (pa,pb,pc) -> + runElements ptr $ + storeElement pa a >> storeElement pb b >> storeElement pc c + +loadElement :: + (C a) => + LP.Proxy a -> + MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (NiceValue.T a) +loadElement proxy = + MT.lift . MT.lift . load =<< elementPtr proxy + +storeElement :: + (C a) => + LP.Proxy a -> NiceValue.T a -> + MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) () +storeElement proxy a = + MT.lift . MT.lift . store a =<< elementPtr proxy + +elementPtr :: + (C a) => + LP.Proxy a -> + MR.ReaderT BytePtr + (MS.StateT Int (CodeGenFunction r)) (LLVM.Value (Ptr a)) +elementPtr proxy = do + ptr <- MR.ask + MT.lift $ do + offset <- elementOffset proxy + MT.lift $ castFromBytePtr =<< LLVM.getElementPtr ptr (offset, ()) + + +instance + (TypeNum.Positive n, Vector a) => + C (LLVM.Vector n a) where + load ptr = + fmap NiceValue.Cons $ + assembleVector (proxyFromElement3 ptr) =<< loadApplicativeRepr ptr + store (NiceValue.Cons a) ptr = + flip storeFoldableRepr ptr + =<< disassembleVector (proxyFromElement3 ptr) a + +class (C a, NiceVector.C a) => Vector a where + assembleVector :: + (TypeNum.Positive n) => + LP.Proxy a -> LLVM.Vector n (NiceValue.Repr a) -> + CodeGenFunction r (NiceVector.Repr n a) + disassembleVector :: + (TypeNum.Positive n) => + LP.Proxy a -> NiceVector.Repr n a -> + CodeGenFunction r (LLVM.Vector n (NiceValue.Repr a)) + +instance Vector Float where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Double where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Word where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Word8 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Word16 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Word32 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Word64 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Int where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Int8 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Int16 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Int32 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Int64 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Bool where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + +instance Vector Bool8 where + assembleVector LP.Proxy = assemblePrimitive + disassembleVector LP.Proxy = disassemblePrimitive + + +instance + (Tuple tuple, TupleVector tuple) => + Vector (StoreTuple.Tuple tuple) where + assembleVector = deinterleave . fmap StoreTuple.getTuple + disassembleVector = interleave . fmap StoreTuple.getTuple + + +class (NiceVector.C a) => TupleVector a where + deinterleave :: + (TypeNum.Positive n) => + LP.Proxy a -> LLVM.Vector n (NiceValue.Repr a) -> + CodeGenFunction r (NiceVector.Repr n a) + interleave :: + (TypeNum.Positive n) => + LP.Proxy a -> NiceVector.Repr n a -> + CodeGenFunction r (LLVM.Vector n (NiceValue.Repr a)) + +instance (Vector a, Vector b) => TupleVector (a,b) where + deinterleave = FuncHT.uncurry $ \pa pb -> FuncHT.uncurry $ \a b -> + App.lift2 (,) (assembleVector pa a) (assembleVector pb b) + interleave = FuncHT.uncurry $ \pa pb (a,b) -> + App.lift2 (App.lift2 (,)) + (disassembleVector pa a) (disassembleVector pb b) + +instance (Vector a, Vector b, Vector c) => TupleVector (a,b,c) where + deinterleave = FuncHT.uncurry3 $ \pa pb pc -> FuncHT.uncurry3 $ \a b c -> + App.lift3 (,,) + (assembleVector pa a) + (assembleVector pb b) + (assembleVector pc c) + interleave = FuncHT.uncurry3 $ \pa pb pc (a,b,c) -> + App.lift3 (App.lift3 (,,)) + (disassembleVector pa a) + (disassembleVector pb b) + (disassembleVector pc c) + + +{- +instance Storable () available since base-4.9/GHC-8.0. +Before we need Data.Orphans. +-} +instance C () where + load _ptr = return $ NiceValue.Cons () + store (NiceValue.Cons ()) _ptr = return () + + +loadTraversable :: + (NonEmptyC.Repeat f, Trav.Traversable f, + C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) => + Value (Ptr (f a)) -> CodeGenFunction r (NiceValue.T fa) +loadTraversable = + (MS.evalStateT $ fmap NiceValue.Cons $ + Trav.sequence $ NonEmptyC.repeat $ loadState) + <=< castElementPtr + +loadApplicative :: + (Applicative f, Trav.Traversable f, + C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) => + Value (Ptr (f a)) -> CodeGenFunction r (NiceValue.T fa) +loadApplicative = fmap NiceValue.Cons . loadApplicativeRepr + +loadApplicativeRepr :: + (Applicative f, Trav.Traversable f, C a) => + Value (Ptr (f a)) -> CodeGenFunction r (f (NiceValue.Repr a)) +loadApplicativeRepr = + (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr + +loadState :: + (C a, NiceValue.Repr a ~ al) => + MS.StateT (Value (Ptr a)) (CodeGenFunction r) al +loadState = + MT.lift . fmap (\(NiceValue.Cons a) -> a) . load =<< advancePtrState + + +storeFoldable :: + (Fold.Foldable f, C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) => + NiceValue.T fa -> Value (Ptr (f a)) -> CodeGenFunction r () +storeFoldable (NiceValue.Cons xs) = storeFoldableRepr xs + +storeFoldableRepr :: + (Fold.Foldable f, C a) => + f (NiceValue.Repr a) -> Value (Ptr (f a)) -> CodeGenFunction r () +storeFoldableRepr xs = + MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr + +storeState :: + (C a, NiceValue.Repr a ~ al) => + al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) () +storeState a = MT.lift . store (NiceValue.Cons a) =<< advancePtrState + + +advancePtrState :: + (C a, Value (Ptr a) ~ ptr) => + MS.StateT ptr (CodeGenFunction r) ptr +advancePtrState = update $ advancePtrStatic 1 diff --git a/src/LLVM/Extra/Nice/Value/Vector.hs b/src/LLVM/Extra/Nice/Value/Vector.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Value/Vector.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module LLVM.Extra.Nice.Value.Vector ( + cons, + fst, snd, + fst3, snd3, thd3, + zip, zip3, + unzip, unzip3, + + swap, + mapFst, mapSnd, + mapFst3, mapSnd3, mapThd3, + + extract, insert, + replicate, + iterate, + dissect, + dissect1, + select, + cmp, + take, takeRev, + + NativeInteger, + NativeFloating, + fromIntegral, + truncateToInt, + splitFractionToInt, + ) where + +import qualified LLVM.Extra.Nice.Vector.Instance as Inst +import qualified LLVM.Extra.Nice.Vector as NiceVector +import qualified LLVM.Extra.Nice.Value.Private as NiceValue +import qualified LLVM.Extra.ScalarOrVector as SoV +import LLVM.Extra.Nice.Vector.Instance (NVVector) + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Tuple.HT as TupleHT +import qualified Data.Tuple as Tuple +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64, Int) + +import Prelude (Float, Double, Bool, fmap, (.)) + + +cons :: + (TypeNum.Positive n, NiceVector.C a) => + LLVM.Vector n a -> NVVector n a +cons = Inst.toNiceValue . NiceVector.cons + +fst :: NVVector n (a,b) -> NVVector n a +fst = NiceValue.lift1 Tuple.fst + +snd :: NVVector n (a,b) -> NVVector n b +snd = NiceValue.lift1 Tuple.snd + +swap :: NVVector n (a,b) -> NVVector n (b,a) +swap = NiceValue.lift1 TupleHT.swap + +mapFst :: + (NVVector n a0 -> NVVector n a1) -> + NVVector n (a0,b) -> NVVector n (a1,b) +mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip + +mapSnd :: + (NVVector n b0 -> NVVector n b1) -> + NVVector n (a,b0) -> NVVector n (a,b1) +mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip + + +fst3 :: NVVector n (a,b,c) -> NVVector n a +fst3 = NiceValue.lift1 TupleHT.fst3 + +snd3 :: NVVector n (a,b,c) -> NVVector n b +snd3 = NiceValue.lift1 TupleHT.snd3 + +thd3 :: NVVector n (a,b,c) -> NVVector n c +thd3 = NiceValue.lift1 TupleHT.thd3 + +mapFst3 :: + (NVVector n a0 -> NVVector n a1) -> + NVVector n (a0,b,c) -> NVVector n (a1,b,c) +mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3 + +mapSnd3 :: + (NVVector n b0 -> NVVector n b1) -> + NVVector n (a,b0,c) -> NVVector n (a,b1,c) +mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3 + +mapThd3 :: + (NVVector n c0 -> NVVector n c1) -> + NVVector n (a,b,c0) -> NVVector n (a,b,c1) +mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3 + + +zip :: NVVector n a -> NVVector n b -> NVVector n (a,b) +zip (NiceValue.Cons a) (NiceValue.Cons b) = NiceValue.Cons (a,b) + +zip3 :: NVVector n a -> NVVector n b -> NVVector n c -> NVVector n (a,b,c) +zip3 (NiceValue.Cons a) (NiceValue.Cons b) (NiceValue.Cons c) = + NiceValue.Cons (a,b,c) + +unzip :: NVVector n (a,b) -> (NVVector n a, NVVector n b) +unzip (NiceValue.Cons (a,b)) = (NiceValue.Cons a, NiceValue.Cons b) + +unzip3 :: NVVector n (a,b,c) -> (NVVector n a, NVVector n b, NVVector n c) +unzip3 (NiceValue.Cons (a,b,c)) = + (NiceValue.Cons a, NiceValue.Cons b, NiceValue.Cons c) + + +extract :: + (TypeNum.Positive n, NiceVector.C a) => + LLVM.Value Word32 -> NVVector n a -> + LLVM.CodeGenFunction r (NiceValue.T a) +extract k v = NiceVector.extract k (Inst.fromNiceValue v) + +insert :: + (TypeNum.Positive n, NiceVector.C a) => + LLVM.Value Word32 -> NiceValue.T a -> + NVVector n a -> LLVM.CodeGenFunction r (NVVector n a) +insert k a = Inst.liftNiceValueM (NiceVector.insert k a) + + +replicate :: + (TypeNum.Positive n, NiceVector.C a) => + NiceValue.T a -> LLVM.CodeGenFunction r (NVVector n a) +replicate = fmap Inst.toNiceValue . NiceVector.replicate + +iterate :: + (TypeNum.Positive n, NiceVector.C a) => + (NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a)) -> + NiceValue.T a -> LLVM.CodeGenFunction r (NVVector n a) +iterate f = fmap Inst.toNiceValue . NiceVector.iterate f + +take :: + (TypeNum.Positive n, TypeNum.Positive m, NiceVector.C a) => + NVVector n a -> LLVM.CodeGenFunction r (NVVector m a) +take = Inst.liftNiceValueM NiceVector.take + +takeRev :: + (TypeNum.Positive n, TypeNum.Positive m, NiceVector.C a) => + NVVector n a -> LLVM.CodeGenFunction r (NVVector m a) +takeRev = Inst.liftNiceValueM NiceVector.takeRev + + +dissect :: + (TypeNum.Positive n, NiceVector.C a) => + NVVector n a -> LLVM.CodeGenFunction r [NiceValue.T a] +dissect = NiceVector.dissect . Inst.fromNiceValue + +dissect1 :: + (TypeNum.Positive n, NiceVector.C a) => + NVVector n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a)) +dissect1 = NiceVector.dissect1 . Inst.fromNiceValue + +select :: + (TypeNum.Positive n, NiceVector.Select a) => + NVVector n Bool -> + NVVector n a -> NVVector n a -> + LLVM.CodeGenFunction r (NVVector n a) +select = Inst.liftNiceValueM3 NiceVector.select + +cmp :: + (TypeNum.Positive n, NiceVector.Comparison a) => + LLVM.CmpPredicate -> + NVVector n a -> NVVector n a -> + LLVM.CodeGenFunction r (NVVector n Bool) +cmp = Inst.liftNiceValueM2 . NiceVector.cmp + + +{- +ToDo: make this a super-class of NiceValue.NativeInteger +problem: we need NiceValue.Repr, which provokes an import cycle +maybe we should break the cycle using a ConstraintKind, +i.e. define class NativeIntegerVec in NiceValue, +and define NativeInteger = NiceValue.NativeIntegerVec here +and export only NiceValueVec.NativeInteger constraint synonym. +-} +class + (NiceValue.Repr i ~ LLVM.Value ir, + LLVM.CmpRet ir, LLVM.IsInteger ir, SoV.IntegerConstant ir) => + NativeInteger i ir where + +instance NativeInteger Word Word where +instance NativeInteger Word8 Word8 where +instance NativeInteger Word16 Word16 where +instance NativeInteger Word32 Word32 where +instance NativeInteger Word64 Word64 where + +instance NativeInteger Int Int where +instance NativeInteger Int8 Int8 where +instance NativeInteger Int16 Int16 where +instance NativeInteger Int32 Int32 where +instance NativeInteger Int64 Int64 where + +instance + (TypeNum.Positive n, n ~ m, + NiceVector.NativeInteger n i ir, + NiceValue.NativeInteger i ir) => + NativeInteger (LLVM.Vector n i) (LLVM.Vector m ir) where + + +class + (NiceValue.Repr a ~ LLVM.Value ar, + LLVM.CmpRet ar, SoV.RationalConstant ar, LLVM.IsFloating ar) => + NativeFloating a ar where + +instance NativeFloating Float Float where +instance NativeFloating Double Double where + +instance + (TypeNum.Positive n, n ~ m, + NiceVector.NativeFloating n a ar, + NiceValue.NativeFloating a ar) => + NativeFloating (LLVM.Vector n a) (LLVM.Vector m ar) where + +fromIntegral :: + (NativeInteger i ir, NativeFloating a ar, + LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => + NiceValue.T i -> LLVM.CodeGenFunction r (NiceValue.T a) +fromIntegral = NiceValue.liftM LLVM.inttofp + + +truncateToInt :: + (NativeInteger i ir, NativeFloating a ar, + LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => + NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T i) +truncateToInt = NiceValue.liftM LLVM.fptoint + +splitFractionToInt :: + (NativeInteger i ir, NativeFloating a ar, + LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) => + NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T (i,a)) +splitFractionToInt = NiceValue.liftM SoV.splitFractionToInt diff --git a/src/LLVM/Extra/Nice/Vector.hs b/src/LLVM/Extra/Nice/Vector.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Vector.hs @@ -0,0 +1,1346 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module LLVM.Extra.Nice.Vector ( + T(Cons), consPrim, deconsPrim, + C(..), + Value, + map, + zip, zip3, unzip, unzip3, + replicate, + iterate, + take, + takeRev, + + sum, + dotProduct, + cumulate, + cumulate1, + + lift1, + + modify, + assemble, + dissect, + dissectList, + + assemble1, + dissect1, + dissectList1, + + assembleFromVector, + consVarArg, + + reverse, + rotateUp, + rotateDown, + shiftUp, + shiftDown, + shiftUpMultiZero, + shiftDownMultiZero, + shiftUpMultiUndef, + shiftDownMultiUndef, + + undefPrimitive, + shufflePrimitive, + extractPrimitive, + insertPrimitive, + + shuffleMatchTraversable, + insertTraversable, + extractTraversable, + + IntegerConstant(..), + RationalConstant(..), + Additive(..), + PseudoRing(..), + Field(..), + scale, + PseudoModule(..), + Real(..), + Fraction(..), + NativeInteger, NativeFloating, fromIntegral, + Algebraic(..), + Transcendental(..), + FloatingComparison(..), + Select(..), + Comparison(..), + Logic(..), + BitShift(..), + ) where + +import qualified LLVM.Extra.Nice.Value.Private as NiceValue +import qualified LLVM.Extra.ScalarOrVector as SoV +import qualified LLVM.Extra.Arithmetic as A +import qualified LLVM.Extra.Tuple as Tuple + +import qualified LLVM.Core as LLVM +import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, ) + +import qualified Type.Data.Num.Decimal as TypeNum +import qualified Type.Data.Num.Decimal as Dec +import qualified Type.Data.Num.Unary as Unary + +import qualified Foreign.Storable.Record.Tuple as StoreTuple + +import qualified Data.Traversable as Trav +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List as List +import qualified Data.Bool8 as Bool8 +import Data.Traversable (mapM, sequence, ) +import Data.Foldable (foldlM) +import Data.NonEmpty ((!:), ) +import Data.Function (flip, (.), ($), ) +import Data.Tuple (snd, ) +import Data.Maybe (maybe, ) +import Data.Ord ((<), ) +import Data.Word (Word8, Word16, Word32, Word64, Word) +import Data.Int (Int8, Int16, Int32, Int64, ) +import Data.Bool8 (Bool8) +import Data.Bool (Bool, ) + +import qualified Control.Monad.HT as Monad +import qualified Control.Applicative as App +import qualified Control.Functor.HT as FuncHT +import Control.Monad.HT ((<=<), ) +import Control.Monad (Monad, join, fmap, return, (>>), (=<<)) +import Control.Applicative (liftA2, (<$>)) + +import qualified Prelude as P +import Prelude + (Float, Double, Integer, Int, Rational, asTypeOf, (-), (+), (*), error) + + +newtype T n a = Cons (Repr n a) + +type Value n a = LLVM.Value (LLVM.Vector n a) + + +consPrim :: (Repr n a ~ Value n ar) => Value n ar -> T n a +consPrim = Cons + +deconsPrim :: (Repr n a ~ Value n ar) => T n a -> Value n ar +deconsPrim (Cons a) = a + + +instance (TypeNum.Positive n, C a) => Tuple.Undefined (T n a) where + undef = undef + +instance (TypeNum.Positive n, C a) => Tuple.Zero (T n a) where + zero = zero + +instance (TypeNum.Positive n, C a) => Tuple.Phi (T n a) where + phi = phi + addPhi = addPhi + + +sizeS :: TypeNum.Positive n => T n a -> TypeNum.Singleton n +sizeS _ = TypeNum.singleton + +size :: (TypeNum.Positive n, P.Integral i) => T n a -> i +size = TypeNum.integralFromSingleton . sizeS + +last :: + (TypeNum.Positive n, C a) => + T n a -> CodeGenFunction r (NiceValue.T a) +last x = extract (valueOf (size x - 1)) x + + +zip :: T n a -> T n b -> T n (a,b) +zip (Cons a) (Cons b) = Cons (a,b) + +zip3 :: T n a -> T n b -> T n c -> T n (a,b,c) +zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c) + +unzip :: T n (a,b) -> (T n a, T n b) +unzip (Cons (a,b)) = (Cons a, Cons b) + +unzip3 :: T n (a,b,c) -> (T n a, T n b, T n c) +unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c) + + +class (NiceValue.C a) => C a where + type Repr n a + cons :: (TypeNum.Positive n) => LLVM.Vector n a -> T n a + undef :: (TypeNum.Positive n) => T n a + zero :: (TypeNum.Positive n) => T n a + phi :: + (TypeNum.Positive n) => + LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a) + addPhi :: + (TypeNum.Positive n) => + LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r () + + shuffle :: + (TypeNum.Positive n, TypeNum.Positive m) => + LLVM.ConstValue (LLVM.Vector m Word32) -> T n a -> T n a -> + CodeGenFunction r (T m a) + extract :: + (TypeNum.Positive n) => + LLVM.Value Word32 -> T n a -> CodeGenFunction r (NiceValue.T a) + insert :: + (TypeNum.Positive n) => + LLVM.Value Word32 -> NiceValue.T a -> + T n a -> CodeGenFunction r (T n a) + +instance C Bool where + type Repr n Bool = LLVM.Value (LLVM.Vector n Bool) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Bool8 where + type Repr n Bool8 = LLVM.Value (LLVM.Vector n Bool) + cons = consPrimitive . fmap Bool8.toBool + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Float where + type Repr n Float = LLVM.Value (LLVM.Vector n Float) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Double where + type Repr n Double = LLVM.Value (LLVM.Vector n Double) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Int where + type Repr n Int = LLVM.Value (LLVM.Vector n Int) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Int8 where + type Repr n Int8 = LLVM.Value (LLVM.Vector n Int8) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Int16 where + type Repr n Int16 = LLVM.Value (LLVM.Vector n Int16) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Int32 where + type Repr n Int32 = LLVM.Value (LLVM.Vector n Int32) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Int64 where + type Repr n Int64 = LLVM.Value (LLVM.Vector n Int64) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Word where + type Repr n Word = LLVM.Value (LLVM.Vector n Word) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Word8 where + type Repr n Word8 = LLVM.Value (LLVM.Vector n Word8) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Word16 where + type Repr n Word16 = LLVM.Value (LLVM.Vector n Word16) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Word32 where + type Repr n Word32 = LLVM.Value (LLVM.Vector n Word32) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +instance C Word64 where + type Repr n Word64 = LLVM.Value (LLVM.Vector n Word64) + cons = consPrimitive + undef = undefPrimitive + zero = zeroPrimitive + phi = phiPrimitive + addPhi = addPhiPrimitive + shuffle = shufflePrimitive + extract = extractPrimitive + insert = insertPrimitive + +consPrimitive :: + (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al, + Repr n a ~ Value n al) => + LLVM.Vector n al -> T n a +consPrimitive = Cons . LLVM.valueOf + +undefPrimitive :: + (TypeNum.Positive n, IsPrimitive al, + Repr n a ~ Value n al) => + T n a +undefPrimitive = Cons $ LLVM.value LLVM.undef + +zeroPrimitive :: + (TypeNum.Positive n, IsPrimitive al, + Repr n a ~ Value n al) => + T n a +zeroPrimitive = Cons $ LLVM.value LLVM.zero + +phiPrimitive :: + (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) => + LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a) +phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a + +addPhiPrimitive :: + (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) => + LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r () +addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b + + +shufflePrimitive :: + (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al, + NiceValue.Repr a ~ LLVM.Value al, + Repr n a ~ Value n al, + Repr m a ~ Value m al) => + LLVM.ConstValue (LLVM.Vector m Word32) -> + T n a -> T n a -> CodeGenFunction r (T m a) +shufflePrimitive k (Cons u) (Cons v) = + fmap Cons $ LLVM.shufflevector u v k + +extractPrimitive :: + (TypeNum.Positive n, IsPrimitive al, + NiceValue.Repr a ~ LLVM.Value al, + Repr n a ~ Value n al) => + LLVM.Value Word32 -> T n a -> CodeGenFunction r (NiceValue.T a) +extractPrimitive k (Cons v) = + fmap NiceValue.Cons $ LLVM.extractelement v k + +insertPrimitive :: + (TypeNum.Positive n, IsPrimitive al, + NiceValue.Repr a ~ LLVM.Value al, + Repr n a ~ Value n al) => + LLVM.Value Word32 -> + NiceValue.T a -> T n a -> CodeGenFunction r (T n a) +insertPrimitive k (NiceValue.Cons a) (Cons v) = + fmap Cons $ LLVM.insertelement v a k + + +instance (C a, C b) => C (a,b) where + type Repr n (a,b) = (Repr n a, Repr n b) + cons v = case FuncHT.unzip v of (a,b) -> zip (cons a) (cons b) + undef = zip undef undef + zero = zip zero zero + + phi bb a = + case unzip a of + (a0,a1) -> + Monad.lift2 zip (phi bb a0) (phi bb a1) + addPhi bb a b = + case (unzip a, unzip b) of + ((a0,a1), (b0,b1)) -> + addPhi bb a0 b0 >> + addPhi bb a1 b1 + + shuffle is u v = + case (unzip u, unzip v) of + ((u0,u1), (v0,v1)) -> + Monad.lift2 zip + (shuffle is u0 v0) + (shuffle is u1 v1) + + extract k v = + case unzip v of + (v0,v1) -> + Monad.lift2 NiceValue.zip + (extract k v0) + (extract k v1) + + insert k a v = + case (NiceValue.unzip a, unzip v) of + ((a0,a1), (v0,v1)) -> + Monad.lift2 zip + (insert k a0 v0) + (insert k a1 v1) + + +instance (C a, C b, C c) => C (a,b,c) where + type Repr n (a,b,c) = (Repr n a, Repr n b, Repr n c) + cons v = case FuncHT.unzip3 v of (a,b,c) -> zip3 (cons a) (cons b) (cons c) + undef = zip3 undef undef undef + zero = zip3 zero zero zero + + phi bb a = + case unzip3 a of + (a0,a1,a2) -> + Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2) + addPhi bb a b = + case (unzip3 a, unzip3 b) of + ((a0,a1,a2), (b0,b1,b2)) -> + addPhi bb a0 b0 >> + addPhi bb a1 b1 >> + addPhi bb a2 b2 + + shuffle is u v = + case (unzip3 u, unzip3 v) of + ((u0,u1,u2), (v0,v1,v2)) -> + Monad.lift3 zip3 + (shuffle is u0 v0) + (shuffle is u1 v1) + (shuffle is u2 v2) + + extract k v = + case unzip3 v of + (v0,v1,v2) -> + Monad.lift3 NiceValue.zip3 + (extract k v0) + (extract k v1) + (extract k v2) + + insert k a v = + case (NiceValue.unzip3 a, unzip3 v) of + ((a0,a1,a2), (v0,v1,v2)) -> + Monad.lift3 zip3 + (insert k a0 v0) + (insert k a1 v1) + (insert k a2 v2) + + +instance (C tuple) => C (StoreTuple.Tuple tuple) where + type Repr n (StoreTuple.Tuple tuple) = Repr n tuple + cons = tuple . cons . fmap StoreTuple.getTuple + undef = tuple undef + zero = tuple zero + phi bb = fmap tuple . phi bb . untuple + addPhi bb a b = addPhi bb (untuple a) (untuple b) + shuffle is u v = tuple <$> shuffle is (untuple u) (untuple v) + extract k v = NiceValue.tuple <$> extract k (untuple v) + insert k a v = tuple <$> insert k (NiceValue.untuple a) (untuple v) + +tuple :: T n tuple -> T n (StoreTuple.Tuple tuple) +tuple (Cons a) = Cons a + +untuple :: T n (StoreTuple.Tuple tuple) -> T n tuple +untuple (Cons a) = Cons a + + +class (NiceValue.IntegerConstant a, C a) => IntegerConstant a where + fromInteger' :: (TypeNum.Positive n) => Integer -> T n a + +class + (NiceValue.RationalConstant a, IntegerConstant a) => + RationalConstant a where + fromRational' :: (TypeNum.Positive n) => Rational -> T n a + +instance IntegerConstant Float where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Double where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Word where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Word8 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Word64 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Int where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Int8 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Int16 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Int32 where fromInteger' = fromIntegerPrimitive +instance IntegerConstant Int64 where fromInteger' = fromIntegerPrimitive + +fromIntegerPrimitive :: + (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a, + Repr n a ~ Value n a) => + Integer -> T n a +fromIntegerPrimitive = Cons . LLVM.value . SoV.constFromInteger + +instance RationalConstant Float where fromRational' = fromRationalPrimitive +instance RationalConstant Double where fromRational' = fromRationalPrimitive + +fromRationalPrimitive :: + (TypeNum.Positive n, IsPrimitive a, SoV.RationalConstant a, + Repr n a ~ Value n a) => + Rational -> T n a +fromRationalPrimitive = Cons . LLVM.value . SoV.constFromRational + +instance + (TypeNum.Positive n, IntegerConstant a) => + A.IntegerConstant (T n a) where + fromInteger' = fromInteger' + +instance + (TypeNum.Positive n, RationalConstant a) => + A.RationalConstant (T n a) where + fromRational' = fromRational' + + +modify :: + (TypeNum.Positive n, C a) => + LLVM.Value Word32 -> + (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) -> + (T n a -> CodeGenFunction r (T n a)) +modify k f v = + flip (insert k) v =<< f =<< extract k v + + +assemble :: + (TypeNum.Positive n, C a) => + [NiceValue.T a] -> CodeGenFunction r (T n a) +assemble = + foldlM (\v (k,x) -> insert (valueOf k) x v) undef . + List.zip [0..] + +dissect :: + (TypeNum.Positive n, C a) => + T n a -> LLVM.CodeGenFunction r [NiceValue.T a] +dissect = sequence . dissectList + +dissectList :: + (TypeNum.Positive n, C a) => + T n a -> [LLVM.CodeGenFunction r (NiceValue.T a)] +dissectList x = + List.map + (flip extract x . LLVM.valueOf) + (List.take (size x) [0..]) + + +assemble1 :: + (TypeNum.Positive n, C a) => + NonEmpty.T [] (NiceValue.T a) -> CodeGenFunction r (T n a) +assemble1 = assemble . NonEmpty.flatten + +dissect1 :: + (TypeNum.Positive n, C a) => + T n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a)) +dissect1 = sequence . dissectList1 + +dissectList1 :: + (TypeNum.Positive n, C a) => + T n a -> NonEmpty.T [] (LLVM.CodeGenFunction r (NiceValue.T a)) +dissectList1 x = + fmap + (flip extract x . LLVM.valueOf) + (0 !: List.take (size x - 1) [1 ..]) + + +assembleFromVector :: + (TypeNum.Positive n, C a) => + LLVM.Vector n (NiceValue.T a) -> CodeGenFunction r (T n a) +assembleFromVector = + fmap snd . + foldlM (\(k,v) x -> (,) (k+1) <$> insert (valueOf k) x v) (0,undef) + + +type family VectorSize v +type instance VectorSize (T n a) = n + +type family VectorElement v +type instance VectorElement (T n a) = a + +class + (Dec.Positive n, C a, ResultRet f ~ r, + VectorSize (ResultVector f) ~ n, VectorElement (ResultVector f) ~ a) => + Cons r n a f where + type NumberOfArguments f + type ResultRet f + type ResultVector f + consAux :: Word32 -> CodeGenFunction r (T n a) -> f + +instance + (Dec.Positive n, C a, r0 ~ r, T n a ~ v) => + Cons r0 n a (CodeGenFunction r v) where + type NumberOfArguments (CodeGenFunction r v) = Unary.Zero + type ResultRet (CodeGenFunction r v) = r + type ResultVector (CodeGenFunction r v) = v + consAux _ mv = mv + +instance (NiceValue.T a ~ arg, Cons r n a f) => Cons r n a (arg -> f) where + type NumberOfArguments (arg -> f) = Unary.Succ (NumberOfArguments f) + type ResultRet (arg -> f) = ResultRet f + type ResultVector (arg -> f) = ResultVector f + consAux k mv x = consAux (k+1) (insert (LLVM.valueOf k) x =<< mv) + +consVarArg :: + (Cons r n a f, NumberOfArguments f ~ u, + u ~ Dec.ToUnary n, Dec.FromUnary u ~ n, Dec.Natural n) => + f +consVarArg = consAux 0 (return undef) + + + +map :: + (TypeNum.Positive n, C a, C b) => + (NiceValue.T a -> CodeGenFunction r (NiceValue.T b)) -> + (T n a -> CodeGenFunction r (T n b)) +map f = assemble <=< mapM f <=< dissect + + +singleton :: (C a) => NiceValue.T a -> CodeGenFunction r (T TypeNum.D1 a) +singleton x = insert (LLVM.value LLVM.zero) x undef + +replicate :: + (TypeNum.Positive n, C a) => + NiceValue.T a -> CodeGenFunction r (T n a) +replicate x = do + single <- singleton x + shuffle (constCyclicVector $ NonEmpty.singleton 0) single undef + +iterate :: + (TypeNum.Positive n, C a) => + (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) -> + NiceValue.T a -> CodeGenFunction r (T n a) +iterate f x = fmap snd $ iterateCore f x Tuple.undef + +iterateCore :: + (TypeNum.Positive n, C a) => + (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) -> + NiceValue.T a -> T n a -> + CodeGenFunction r (NiceValue.T a, T n a) +iterateCore f x0 v0 = + foldlM + (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v)) + (x0,v0) + (List.take (size v0) [0..]) + + +sum :: + (TypeNum.Positive n, Additive a) => + T n a -> CodeGenFunction r (NiceValue.T a) +sum = + NonEmpty.foldBalanced (\x y -> join $ liftA2 NiceValue.add x y) . + dissectList1 + +dotProduct :: + (TypeNum.Positive n, PseudoRing a) => + T n a -> T n a -> CodeGenFunction r (NiceValue.T a) +dotProduct x y = sum =<< mul x y + + +cumulate :: + (TypeNum.Positive n, Additive a) => + NiceValue.T a -> T n a -> + CodeGenFunction r (NiceValue.T a, T n a) +cumulate a x0 = do + (b,x1) <- shiftUp a x0 + y <- cumulate1 x1 + z <- A.add b =<< last y + return (z,y) + +{- | +Needs (log n) vector additions +-} +cumulate1 :: + (TypeNum.Positive n, Additive a) => + T n a -> CodeGenFunction r (T n a) +cumulate1 x = + foldlM + (\y k -> A.add y =<< shiftUpMultiZero k y) + x + (List.takeWhile (< size x) $ List.iterate (2*) 1) + + +-- * re-ordering of elements + +constCyclicVector :: + (LLVM.IsConst a, TypeNum.Positive n) => + NonEmpty.T [] a -> LLVM.ConstValue (LLVM.Vector n a) +constCyclicVector = + LLVM.constCyclicVector . fmap LLVM.constOf + +shuffleMatch :: + (TypeNum.Positive n, C a) => + LLVM.ConstValue (LLVM.Vector n Word32) -> T n a -> + CodeGenFunction r (T n a) +shuffleMatch k v = shuffle k v undef + +{- | +Rotate one element towards the higher elements. + +I don't want to call it rotateLeft or rotateRight, +because there is no prefered layout for the vector elements. +In Intel's instruction manual vector +elements are indexed like the bits, +that is from right to left. +However, when working with Haskell list and enumeration syntax, +the start index is left. +-} +rotateUp :: + (TypeNum.Positive n, C a) => + T n a -> CodeGenFunction r (T n a) +rotateUp x = + shuffleMatch (constCyclicVector $ (size x - 1) !: [0..]) x + +rotateDown :: + (TypeNum.Positive n, C a) => + T n a -> CodeGenFunction r (T n a) +rotateDown x = + shuffleMatch + (constCyclicVector $ + NonEmpty.snoc (List.take (size x - 1) [1..]) 0) x + +reverse :: + (TypeNum.Positive n, C a) => + T n a -> CodeGenFunction r (T n a) +reverse x = + shuffleMatch + (constCyclicVector $ + maybe (error "vector size must be positive") NonEmpty.reverse $ + NonEmpty.fetch $ + List.take (size x) [0..]) + x + +take :: + (TypeNum.Positive n, TypeNum.Positive m, C a) => + T n a -> CodeGenFunction r (T m a) +take u = shuffle (constCyclicVector $ NonEmptyC.iterate (1+) 0) u undef + +takeRev :: + (TypeNum.Positive n, TypeNum.Positive m, C a) => + T n a -> CodeGenFunction r (T m a) +takeRev u = do + let v0 = zero + v <- + shuffle + (constCyclicVector $ NonEmptyC.iterate (1+) (size u - size v0)) + u undef + return $ v `asTypeOf` v0 + +shiftUp :: + (TypeNum.Positive n, C a) => + NiceValue.T a -> T n a -> CodeGenFunction r (NiceValue.T a, T n a) +shiftUp x0 x = do + y <- + shuffleMatch + (LLVM.constCyclicVector $ LLVM.undef !: List.map LLVM.constOf [0..]) x + Monad.lift2 (,) (last x) (insert (value LLVM.zero) x0 y) + +shiftDown :: + (TypeNum.Positive n, C a) => + NiceValue.T a -> T n a -> CodeGenFunction r (NiceValue.T a, T n a) +shiftDown x0 x = do + y <- + shuffleMatch + (LLVM.constCyclicVector $ + NonEmpty.snoc + (List.map LLVM.constOf $ List.take (size x - 1) [1..]) + LLVM.undef) x + Monad.lift2 (,) + (extract (value LLVM.zero) x) + (insert (LLVM.valueOf (size x - 1)) x0 y) + +shiftUpMultiIndices :: + (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32) +shiftUpMultiIndices n sizev = + constCyclicVector $ fmap P.fromIntegral $ + NonEmpty.appendLeft (List.replicate n sizev) (NonEmptyC.iterate (1+) 0) + +shiftDownMultiIndices :: + (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32) +shiftDownMultiIndices n sizev = + constCyclicVector $ fmap P.fromIntegral $ + NonEmpty.appendLeft + (List.takeWhile (< sizev) $ List.iterate (1+) n) + (NonEmptyC.repeat sizev) + +shiftUpMultiZero :: + (TypeNum.Positive n, C a) => + Int -> T n a -> LLVM.CodeGenFunction r (T n a) +shiftUpMultiZero n v = + shuffle (shiftUpMultiIndices n (size v)) v zero + +shiftDownMultiZero :: + (TypeNum.Positive n, C a) => + Int -> T n a -> LLVM.CodeGenFunction r (T n a) +shiftDownMultiZero n v = + shuffle (shiftDownMultiIndices n (size v)) v zero + +shiftUpMultiUndef :: + (TypeNum.Positive n, C a) => + Int -> T n a -> LLVM.CodeGenFunction r (T n a) +shiftUpMultiUndef n v = + shuffle (shiftUpMultiIndices n (size v)) v undef + +shiftDownMultiUndef :: + (TypeNum.Positive n, C a) => + Int -> T n a -> LLVM.CodeGenFunction r (T n a) +shiftDownMultiUndef n v = + shuffle (shiftDownMultiIndices n (size v)) v undef + + +-- * method implementations based on Traversable + +shuffleMatchTraversable :: + (TypeNum.Positive n, C a, Trav.Traversable f) => + LLVM.ConstValue (LLVM.Vector n Word32) -> + f (T n a) -> CodeGenFunction r (f (T n a)) +shuffleMatchTraversable is v = + Trav.mapM (shuffleMatch is) v + +insertTraversable :: + (TypeNum.Positive n, C a, Trav.Traversable f, App.Applicative f) => + LLVM.Value Word32 -> f (NiceValue.T a) -> + f (T n a) -> CodeGenFunction r (f (T n a)) +insertTraversable n a v = + Trav.sequence (liftA2 (insert n) a v) + +extractTraversable :: + (TypeNum.Positive n, C a, Trav.Traversable f) => + LLVM.Value Word32 -> f (T n a) -> + CodeGenFunction r (f (NiceValue.T a)) +extractTraversable n v = + Trav.mapM (extract n) v + + + +lift1 :: (Repr n a -> Repr n b) -> T n a -> T n b +lift1 f (Cons a) = Cons $ f a + +_liftM0 :: + (Monad m) => + m (Repr n a) -> + m (T n a) +_liftM0 f = Monad.lift Cons f + +liftM0 :: + (Monad m, + Repr n a ~ Value n ar) => + m (Value n ar) -> + m (T n a) +liftM0 f = Monad.lift consPrim f + +liftM :: + (Monad m, + Repr n a ~ Value n ar, + Repr n b ~ Value n br) => + (Value n ar -> m (Value n br)) -> + T n a -> m (T n b) +liftM f a = Monad.lift consPrim $ f (deconsPrim a) + +liftM2 :: + (Monad m, + Repr n a ~ Value n ar, + Repr n b ~ Value n br, + Repr n c ~ Value n cr) => + (Value n ar -> Value n br -> m (Value n cr)) -> + T n a -> T n b -> m (T n c) +liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) + +liftM3 :: + (Monad m, + Repr n a ~ Value n ar, + Repr n b ~ Value n br, + Repr n c ~ Value n cr, + Repr n d ~ Value n dr) => + (Value n ar -> Value n br -> Value n cr -> m (Value n dr)) -> + T n a -> T n b -> T n c -> m (T n d) +liftM3 f a b c = + Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) (deconsPrim c) + + + +class (NiceValue.Additive a, C a) => Additive a where + add :: + (TypeNum.Positive n) => + T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + sub :: + (TypeNum.Positive n) => + T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + neg :: + (TypeNum.Positive n) => + T n a -> LLVM.CodeGenFunction r (T n a) + +instance Additive Float where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Double where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Int where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Int8 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Int16 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Int32 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Int64 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Word where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Word8 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Word16 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Word32 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance Additive Word64 where + add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg + +instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where + zero = zero + add = add + sub = sub + neg = neg + + +class (NiceValue.PseudoRing a, Additive a) => PseudoRing a where + mul :: + (TypeNum.Positive n) => + T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + +instance PseudoRing Float where + mul = liftM2 LLVM.mul + +instance PseudoRing Double where + mul = liftM2 LLVM.mul + +instance (TypeNum.Positive n, PseudoRing a) => A.PseudoRing (T n a) where + mul = mul + + +class (NiceValue.Field a, PseudoRing a) => Field a where + fdiv :: + (TypeNum.Positive n) => + T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + +instance Field Float where + fdiv = liftM2 LLVM.fdiv + +instance Field Double where + fdiv = liftM2 LLVM.fdiv + +instance (TypeNum.Positive n, Field a) => A.Field (T n a) where + fdiv = fdiv + + +scale :: + (TypeNum.Positive n, PseudoRing a) => + NiceValue.T a -> T n a -> LLVM.CodeGenFunction r (T n a) +scale a v = flip mul v =<< replicate a + + +type instance A.Scalar (T n a) = T n (NiceValue.Scalar a) + +class + (NiceValue.PseudoModule v, PseudoRing (NiceValue.Scalar v), Additive v) => + PseudoModule v where + scaleMulti :: + (TypeNum.Positive n) => + T n (NiceValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v) + +instance PseudoModule Float where + scaleMulti = liftM2 A.mul + +instance PseudoModule Double where + scaleMulti = liftM2 A.mul + +instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where + scale = scaleMulti + + +class (NiceValue.Real a, Additive a) => Real a where + min :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + max :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + abs :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + signum :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + +instance Real Float where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Double where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word8 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word16 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word32 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Word64 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int8 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int16 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int32 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + +instance Real Int64 where + min = liftM2 A.min + max = liftM2 A.max + abs = liftM A.abs + signum = liftM A.signum + + +instance (TypeNum.Positive n, Real a) => A.Real (T n a) where + min = min + max = max + abs = abs + signum = signum + + +class (NiceValue.Fraction a, Real a) => Fraction a where + truncate :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + fraction :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + +instance Fraction Float where + truncate = liftM A.truncate + fraction = liftM A.fraction + +instance Fraction Double where + truncate = liftM A.truncate + fraction = liftM A.fraction + +instance (TypeNum.Positive n, Fraction a) => A.Fraction (T n a) where + truncate = truncate + fraction = fraction + + +class + (TypeNum.Positive n, Repr n i ~ Value n ir, + NiceValue.NativeInteger i ir, IsPrimitive ir, LLVM.IsInteger ir) => + NativeInteger n i ir where + +instance (TypeNum.Positive n) => NativeInteger n Word Word where +instance (TypeNum.Positive n) => NativeInteger n Word8 Word8 where +instance (TypeNum.Positive n) => NativeInteger n Word16 Word16 where +instance (TypeNum.Positive n) => NativeInteger n Word32 Word32 where +instance (TypeNum.Positive n) => NativeInteger n Word64 Word64 where + +instance (TypeNum.Positive n) => NativeInteger n Int Int where +instance (TypeNum.Positive n) => NativeInteger n Int8 Int8 where +instance (TypeNum.Positive n) => NativeInteger n Int16 Int16 where +instance (TypeNum.Positive n) => NativeInteger n Int32 Int32 where +instance (TypeNum.Positive n) => NativeInteger n Int64 Int64 where + +class + (TypeNum.Positive n, Repr n a ~ Value n ar, + NiceValue.NativeFloating a ar, IsPrimitive ar, LLVM.IsFloating ar) => + NativeFloating n a ar where + +instance (TypeNum.Positive n) => NativeFloating n Float Float where +instance (TypeNum.Positive n) => NativeFloating n Double Double where + +fromIntegral :: + (NativeInteger n i ir, NativeFloating n a ar) => + T n i -> LLVM.CodeGenFunction r (T n a) +fromIntegral = liftM LLVM.inttofp + + +class (NiceValue.Algebraic a, Field a) => Algebraic a where + sqrt :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + +instance Algebraic Float where + sqrt = liftM A.sqrt + +instance Algebraic Double where + sqrt = liftM A.sqrt + +instance (TypeNum.Positive n, Algebraic a) => A.Algebraic (T n a) where + sqrt = sqrt + + +class (NiceValue.Transcendental a, Algebraic a) => Transcendental a where + pi :: (TypeNum.Positive n) => LLVM.CodeGenFunction r (T n a) + sin, cos, exp, log :: + (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + pow :: + (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + +instance Transcendental Float where + pi = liftM0 A.pi + sin = liftM A.sin + cos = liftM A.cos + exp = liftM A.exp + log = liftM A.log + pow = liftM2 A.pow + +instance Transcendental Double where + pi = liftM0 A.pi + sin = liftM A.sin + cos = liftM A.cos + exp = liftM A.exp + log = liftM A.log + pow = liftM2 A.pow + +instance (TypeNum.Positive n, Transcendental a) => A.Transcendental (T n a) where + pi = pi + sin = sin + cos = cos + exp = exp + log = log + pow = pow + + + +class (NiceValue.Select a, C a) => Select a where + select :: + (TypeNum.Positive n) => + T n Bool -> T n a -> T n a -> + LLVM.CodeGenFunction r (T n a) + +instance Select Float where select = liftM3 LLVM.select +instance Select Double where select = liftM3 LLVM.select +instance Select Bool where select = liftM3 LLVM.select +instance Select Word where select = liftM3 LLVM.select +instance Select Word8 where select = liftM3 LLVM.select +instance Select Word16 where select = liftM3 LLVM.select +instance Select Word32 where select = liftM3 LLVM.select +instance Select Word64 where select = liftM3 LLVM.select +instance Select Int where select = liftM3 LLVM.select +instance Select Int8 where select = liftM3 LLVM.select +instance Select Int16 where select = liftM3 LLVM.select +instance Select Int32 where select = liftM3 LLVM.select +instance Select Int64 where select = liftM3 LLVM.select + +instance (Select a, Select b) => Select (a,b) where + select x y0 y1 = + case (unzip y0, unzip y1) of + ((a0,b0), (a1,b1)) -> + Monad.lift2 zip + (select x a0 a1) + (select x b0 b1) + +instance (Select a, Select b, Select c) => Select (a,b,c) where + select x y0 y1 = + case (unzip3 y0, unzip3 y1) of + ((a0,b0,c0), (a1,b1,c1)) -> + Monad.lift3 zip3 + (select x a0 a1) + (select x b0 b1) + (select x c0 c1) + + + +class (NiceValue.Comparison a, Real a) => Comparison a where + cmp :: + (TypeNum.Positive n) => + LLVM.CmpPredicate -> T n a -> T n a -> + LLVM.CodeGenFunction r (T n Bool) + +instance Comparison Float where cmp = liftM2 . LLVM.cmp +instance Comparison Double where cmp = liftM2 . LLVM.cmp +instance Comparison Word where cmp = liftM2 . LLVM.cmp +instance Comparison Word8 where cmp = liftM2 . LLVM.cmp +instance Comparison Word16 where cmp = liftM2 . LLVM.cmp +instance Comparison Word32 where cmp = liftM2 . LLVM.cmp +instance Comparison Word64 where cmp = liftM2 . LLVM.cmp +instance Comparison Int where cmp = liftM2 . LLVM.cmp +instance Comparison Int8 where cmp = liftM2 . LLVM.cmp +instance Comparison Int16 where cmp = liftM2 . LLVM.cmp +instance Comparison Int32 where cmp = liftM2 . LLVM.cmp +instance Comparison Int64 where cmp = liftM2 . LLVM.cmp + +instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where + type CmpResult (T n a) = T n Bool + cmp = cmp + + + +class + (NiceValue.FloatingComparison a, Comparison a) => + FloatingComparison a where + fcmp :: + (TypeNum.Positive n) => + LLVM.FPPredicate -> T n a -> T n a -> + LLVM.CodeGenFunction r (T n Bool) + +instance FloatingComparison Float where + fcmp = liftM2 . LLVM.fcmp + +instance + (TypeNum.Positive n, FloatingComparison a) => + A.FloatingComparison (T n a) where + fcmp = fcmp + + + +class (NiceValue.Logic a, C a) => Logic a where + and, or, xor :: + (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + inv :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a) + +instance Logic Bool where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word8 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word16 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word32 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + +instance Logic Word64 where + and = liftM2 LLVM.and; or = liftM2 LLVM.or + xor = liftM2 LLVM.xor; inv = liftM LLVM.inv + + +instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where + and = and + or = or + xor = xor + inv = inv + + + +class (NiceValue.BitShift a, C a) => BitShift a where + shl :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + shr :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a) + +instance BitShift Word where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word8 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word16 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word32 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Word64 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr + +instance BitShift Int where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int8 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int16 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int32 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr + +instance BitShift Int64 where + shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr diff --git a/src/LLVM/Extra/Nice/Vector/Instance.hs b/src/LLVM/Extra/Nice/Vector/Instance.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Extra/Nice/Vector/Instance.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module LLVM.Extra.Nice.Vector.Instance where + +import qualified LLVM.Extra.Nice.Vector as Vector +import qualified LLVM.Extra.Nice.Value.Private as NiceValue +import LLVM.Extra.Nice.Value.Private (Repr, ) + +import qualified LLVM.Core as LLVM + +import qualified Type.Data.Num.Decimal as TypeNum + +import Data.Functor ((<$>), ) + +import Prelude2010 +import Prelude () + + +type NVVector n a = NiceValue.T (LLVM.Vector n a) + +toNiceValue :: Vector.T n a -> NVVector n a +toNiceValue (Vector.Cons x) = NiceValue.Cons x + +fromNiceValue :: NVVector n a -> Vector.T n a +fromNiceValue (NiceValue.Cons x) = Vector.Cons x + +liftNiceValueM :: + (Functor f) => + (Vector.T n a -> f (Vector.T m b)) -> + (NVVector n a -> f (NVVector m b)) +liftNiceValueM f a = + toNiceValue <$> f (fromNiceValue a) + +liftNiceValueM2 :: + (Functor f) => + (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) -> + (NVVector n a -> NVVector m b -> f (NVVector k c)) +liftNiceValueM2 f a b = + toNiceValue <$> f (fromNiceValue a) (fromNiceValue b) + +liftNiceValueM3 :: + (Functor f) => + (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) -> + (NVVector n a -> NVVector m b -> NVVector m c -> f (NVVector k d)) +liftNiceValueM3 f a b c = + toNiceValue <$> f (fromNiceValue a) (fromNiceValue b) (fromNiceValue c) + +instance + (TypeNum.Positive n, Vector.C a) => + NiceValue.C (LLVM.Vector n a) where + type Repr (LLVM.Vector n a) = Vector.Repr n a + cons = toNiceValue . Vector.cons + undef = toNiceValue Vector.undef + zero = toNiceValue Vector.zero + phi = liftNiceValueM . Vector.phi + addPhi bb x y = Vector.addPhi bb (fromNiceValue x) (fromNiceValue y) + +instance + (TypeNum.Positive n, Vector.IntegerConstant a) => + NiceValue.IntegerConstant (LLVM.Vector n a) where + fromInteger' = toNiceValue . Vector.fromInteger' + +instance + (TypeNum.Positive n, Vector.RationalConstant a) => + NiceValue.RationalConstant (LLVM.Vector n a) where + fromRational' = toNiceValue . Vector.fromRational' + +instance + (TypeNum.Positive n, Vector.Additive a) => + NiceValue.Additive (LLVM.Vector n a) where + add = liftNiceValueM2 Vector.add + sub = liftNiceValueM2 Vector.sub + neg = liftNiceValueM Vector.neg + +instance + (TypeNum.Positive n, Vector.PseudoRing a) => + NiceValue.PseudoRing (LLVM.Vector n a) where + mul = liftNiceValueM2 Vector.mul + +instance + (TypeNum.Positive n, Vector.Real a) => + NiceValue.Real (LLVM.Vector n a) where + min = liftNiceValueM2 Vector.min + max = liftNiceValueM2 Vector.max + abs = liftNiceValueM Vector.abs + signum = liftNiceValueM Vector.signum + +instance + (TypeNum.Positive n, Vector.Fraction a) => + NiceValue.Fraction (LLVM.Vector n a) where + truncate = liftNiceValueM Vector.truncate + fraction = liftNiceValueM Vector.fraction + +instance + (TypeNum.Positive n, Vector.Logic a) => + NiceValue.Logic (LLVM.Vector n a) where + and = liftNiceValueM2 Vector.and + or = liftNiceValueM2 Vector.or + xor = liftNiceValueM2 Vector.xor + inv = liftNiceValueM Vector.inv + +instance + (TypeNum.Positive n, Vector.BitShift a) => + NiceValue.BitShift (LLVM.Vector n a) where + shl = liftNiceValueM2 Vector.shl + shr = liftNiceValueM2 Vector.shr diff --git a/src/LLVM/Extra/Struct.hs b/src/LLVM/Extra/Struct.hs --- a/src/LLVM/Extra/Struct.hs +++ b/src/LLVM/Extra/Struct.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {- | In contrast to 'LLVM.Struct' it allows to store high-level values -and thus allows to implement arbitrary-sized tuples of MultiValue's. +and thus allows to implement arbitrary-sized tuples of NiceValue's. -} module LLVM.Extra.Struct where