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.MaybePrivate as Maybe
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.Tuple.HT (uncurry3, )
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 (Tuple.ValueOf a)
class C a where
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
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Float where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Double where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Word where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Word8 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Word16 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Word32 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Word64 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance (Dec.Positive n) => C (LLVM.WordN n) where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Int where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Int8 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Int16 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Int32 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C Int64 where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance (Dec.Positive n) => C (LLVM.IntN n) where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance (LLVM.IsType a) => C (LLVM.Ptr a) where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C (Ptr a) where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance (LLVM.IsFunction a) => C (FunPtr a) where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance C (StablePtr a) where
cons = consPrimitive
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
consPrimitive ::
(LLVM.IsConst al, LLVM.Value al ~ Tuple.ValueOf a) =>
al -> T a
consPrimitive = Cons . LLVM.valueOf
undefPrimitive, zeroPrimitive ::
(LLVM.IsType al, LLVM.Value al ~ Tuple.ValueOf a) =>
T a
undefPrimitive = Cons $ LLVM.value LLVM.undef
zeroPrimitive = Cons $ LLVM.value LLVM.zero
phiPrimitive ::
(LLVM.IsFirstClass al, LLVM.Value al ~ Tuple.ValueOf 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 ~ Tuple.ValueOf 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) =>
a -> T a
consTuple = Cons . Tuple.valueOf
undefTuple ::
(Tuple.Value a, Tuple.ValueOf a ~ al, Tuple.Undefined al) =>
T a
undefTuple = Cons Tuple.undef
zeroTuple ::
(Tuple.Value a, Tuple.ValueOf a ~ al, Tuple.Zero al) =>
T a
zeroTuple = Cons Tuple.zero
phiTuple ::
(Tuple.Value a, Tuple.ValueOf 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 ::
(Tuple.Value a, Tuple.ValueOf 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
cons = consUnit
undef = undefUnit
zero = zeroUnit
phi = phiUnit
addPhi = addPhiUnit
consUnit :: (Tuple.ValueOf a ~ ()) => a -> T a
consUnit _ = Cons ()
undefUnit :: (Tuple.ValueOf a ~ ()) => T a
undefUnit = Cons ()
zeroUnit :: (Tuple.ValueOf a ~ ()) => T a
zeroUnit = Cons ()
phiUnit ::
(Tuple.ValueOf a ~ ()) =>
LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)
phiUnit _bb (Cons ()) = return $ Cons ()
addPhiUnit ::
(Tuple.ValueOf a ~ ()) =>
LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()
addPhiUnit _bb (Cons ()) (Cons ()) = return ()
instance C Bool8 where
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
cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
toEnum ::
(Tuple.ValueOf w ~ LLVM.Value w) =>
T w -> T (Enum.T w e)
toEnum (Cons w) = Cons w
fromEnum ::
(Tuple.ValueOf 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
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
cons = consPrimitive . EnumBitSet.decons
undef = undefPrimitive
zero = zeroPrimitive
phi = phiPrimitive
addPhi = addPhiPrimitive
instance (C a) => C (Maybe a) where
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 (Maybe.Cons b a)) = (Cons b, Cons a)
toMaybe :: T Bool -> T a -> T (Maybe a)
toMaybe (Cons b) (Cons a) = Cons (Maybe.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
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
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
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
mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)
mapFst3 f = uncurry3 zip3 . TupleHT.mapFst3 f . unzip3
mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)
mapSnd3 f = uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3
mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)
mapThd3 f = 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 (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 (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 (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
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
instance C a => C (Tagged tag a) where
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 (Cons a) = Cons a
untag :: T (Tagged tag a) -> T a
untag (Cons a) = Cons a
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
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
compose :: multituple -> T (Composed multituple)
class
(Composed (Decomposed T pattern) ~ PatternTuple pattern) =>
Decompose pattern where
decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern
type family Decomposed (f :: * -> *) pattern
type family PatternTuple pattern
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 = 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 :: (Tuple.ValueOf a -> Tuple.ValueOf b) -> T a -> T b
lift1 f (Cons a) = Cons $ f a
liftM0 ::
(Monad m) =>
m (Tuple.ValueOf a) ->
m (T a)
liftM0 f = Monad.lift Cons f
liftM ::
(Monad m) =>
(Tuple.ValueOf a -> m (Tuple.ValueOf b)) ->
T a -> m (T b)
liftM f (Cons a) = Monad.lift Cons $ f a
liftM2 ::
(Monad m) =>
(Tuple.ValueOf a -> Tuple.ValueOf b -> m (Tuple.ValueOf c)) ->
T a -> T b -> m (T c)
liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b
liftM3 ::
(Monad m) =>
(Tuple.ValueOf a -> Tuple.ValueOf b -> Tuple.ValueOf c ->
m (Tuple.ValueOf 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
(Tuple.ValueOf 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
(Tuple.ValueOf 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
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