{-# LANGUAGE TypeFamilies #-} {-# 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.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 -- 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 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 {- | 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 = 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 {- | 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