packages feed

llvm-extra 0.8.0.3 → 0.8.1

raw patch · 9 files changed

+581/−20 lines, 9 filesdep +enumsetdep +storable-enumdep +taggeddep ~llvm-tf

Dependencies added: enumset, storable-enum, tagged

Dependency ranges changed: llvm-tf

Files

+ Changes.md view
@@ -0,0 +1,6 @@+# Change log for the `llvm-extra` package++## 0.8.1++* `FastMath`: support for simplified arithmetic primitives+  under the assumption of the absence of corner cases.
llvm-extra.cabal view
@@ -1,5 +1,5 @@ Name:           llvm-extra-Version:        0.8.0.3+Version:        0.8.1 License:        BSD3 License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -58,6 +58,7 @@ Build-Type:     Simple Extra-Source-Files:   Makefile+  Changes.md   Problems.txt   x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs   x86/none/LLVM/Extra/ExtensionCheck/X86.hs@@ -75,7 +76,7 @@   default:     True  Source-Repository this-  Tag:         0.8.0.3+  Tag:         0.8.1   Type:        darcs   Location:    http://code.haskell.org/~thielema/llvm-extra/ @@ -87,12 +88,15 @@   Build-Depends:     -- llvm must be imported with restrictive version bounds,     -- because we import implicitly and unqualified-    llvm-tf >=3.1.1 && <3.2,+    llvm-tf >=3.1.2 && <3.2,     tfp >=1.0 && <1.1,     non-empty >=0.2.1 && <0.4,     containers >=0.1 && <0.7,+    enumset >=0.0.5 && <0.1,+    storable-enum >=0.0 && <0.1,     bool8 >=0.0 && <0.1,     transformers >=0.1.1 && <0.6,+    tagged >=0.7 && <0.9,     utility-ht >=0.0.11 && <0.1,     prelude-compat >=0.0 && <0.0.1 @@ -130,6 +134,7 @@     LLVM.Extra.Scalar     LLVM.Extra.Vector     LLVM.Extra.ScalarOrVector+    LLVM.Extra.FastMath     LLVM.Extra.Iterator     LLVM.Extra.Multi.Iterator     LLVM.Extra.Multi.Value
+ src/LLVM/Extra/FastMath.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module LLVM.Extra.FastMath where++import qualified LLVM.Extra.Multi.Value.Private as MV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Class as Class+import qualified LLVM.Core as LLVM+import LLVM.Util.Proxy (Proxy(Proxy))++import Foreign.Storable (Storable)++import qualified Control.Monad.HT as Monad+import Control.Applicative ((<$>))+++data NoNaNs          = NoNaNs          deriving (Show, Eq)+data NoInfs          = NoInfs          deriving (Show, Eq)+data NoSignedZeros   = NoSignedZeros   deriving (Show, Eq)+data AllowReciprocal = AllowReciprocal deriving (Show, Eq)+data Fast            = Fast            deriving (Show, Eq)+++class Flags flags where+   setFlags ::+      (LLVM.IsFloating a) =>+      Proxy flags -> Bool -> LLVM.Value a -> LLVM.CodeGenFunction r ()++instance Flags NoNaNs          where setFlags Proxy = LLVM.setHasNoNaNs+instance Flags NoInfs          where setFlags Proxy = LLVM.setHasNoInfs+instance Flags NoSignedZeros   where setFlags Proxy = LLVM.setHasNoSignedZeros+instance Flags AllowReciprocal where setFlags Proxy = LLVM.setHasAllowReciprocal+instance Flags Fast            where setFlags Proxy = LLVM.setFastMath++instance (Flags f0, Flags f1) => Flags (f0,f1) where+   setFlags p b v = setFlags (fst<$>p) b v >> setFlags (snd<$>p) b v++instance (Flags f0, Flags f1, Flags f2) => Flags (f0,f1,f2) where+   setFlags = setSplitFlags $ \(f0,f1,f2) -> (f0,(f1,f2))++instance (Flags f0, Flags f1, Flags f2, Flags f3) => Flags (f0,f1,f2,f3) where+   setFlags = setSplitFlags $ \(f0,f1,f2,f3) -> (f0,(f1,f2,f3))++instance+   (Flags f0, Flags f1, Flags f2, Flags f3, Flags f4) =>+      Flags (f0,f1,f2,f3,f4) where+   setFlags = setSplitFlags $ \(f0,f1,f2,f3,f4) -> (f0,(f1,f2,f3,f4))++setSplitFlags ::+   (Flags split, LLVM.IsFloating a) =>+   (flags -> split) ->+   Proxy flags -> Bool -> LLVM.Value a -> LLVM.CodeGenFunction r ()+setSplitFlags split p = setFlags (fmap split p)+++newtype Number flags a = Number {deconsNumber :: a}+   deriving (Eq, Ord, Show, Num, Fractional, Floating, Storable)++getNumber :: flags -> Number flags a -> a+getNumber _ (Number a) = a++instance MultiValue a => MV.C (Number flags a) where+   type Repr f (Number flags a) = MV.Repr f a+   cons = mvNumber . MV.cons . deconsNumber+   undef = mvNumber MV.undef+   zero = mvNumber MV.zero+   phis bb = fmap mvNumber . MV.phis bb . mvDenumber+   addPhis bb a b = MV.addPhis bb (mvDenumber a) (mvDenumber b)++mvNumber :: MV.T a -> MV.T (Number flags a)+mvNumber (MV.Cons a) = MV.Cons a++mvDenumber :: MV.T (Number flags a) -> MV.T a+mvDenumber (MV.Cons a) = MV.Cons a+++class MV.C a => MultiValue a where+   setMultiValueFlags ::+      (Flags flags) =>+      Proxy flags -> Bool -> MV.T (Number flags a) -> LLVM.CodeGenFunction r ()++instance MultiValue Float where+   setMultiValueFlags p b (MV.Cons a) = setFlags p b a++instance MultiValue Double where+   setMultiValueFlags p b (MV.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+   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))+liftNumberM f =+   attachMultiValueFlags . Monad.lift mvNumber . f . mvDenumber++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))+liftNumberM2 f a b =+   attachMultiValueFlags $ Monad.lift mvNumber $ f (mvDenumber a) (mvDenumber 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, MV.Decompose pa) => MV.Decompose (Number flags pa) where+   decompose (Number p) = Number . MV.decompose p . mvDenumber++type instance+   MV.Decomposed f (Number flags pa) = Number flags (MV.Decomposed f pa)+type instance+   MV.PatternTuple (Number flags pa) = Number flags (MV.PatternTuple pa)+++instance+   (Flags flags, MultiValue a, MV.IntegerConstant a) =>+      MV.IntegerConstant (Number flags a) where+   fromInteger' = mvNumber . MV.fromInteger'++instance+   (Flags flags, MultiValue a, MV.RationalConstant a) =>+      MV.RationalConstant (Number flags a) where+   fromRational' = mvNumber . MV.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++instance+   (Flags flags, MultiValue a, MV.PseudoRing a) =>+      MV.PseudoRing (Number flags a) where+   mul = liftNumberM2 MV.mul++instance+   (Flags flags, MultiValue a, MV.Field a) =>+      MV.Field (Number flags a) where+   fdiv = liftNumberM2 MV.fdiv++type instance MV.Scalar (Number flags a) = Number flags (MV.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++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++instance+   (Flags flags, MultiValue a, MV.Fraction a) =>+      MV.Fraction (Number flags a) where+   truncate = liftNumberM MV.truncate+   fraction = liftNumberM MV.fraction++instance+   (Flags flags, MultiValue a, MV.Algebraic a) =>+      MV.Algebraic (Number flags a) where+   sqrt = liftNumberM MV.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++instance+   (Flags flags, MultiValue a, MV.Select a) =>+      MV.Select (Number flags a) where+   select = liftNumberM2 . MV.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)++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)++++class Tuple a where+   setTupleFlags ::+      (Flags flags) => Proxy flags -> Bool -> a -> LLVM.CodeGenFunction r ()++instance (LLVM.IsFloating a) => Tuple (LLVM.Value a) where+   setTupleFlags = setFlags+++newtype Context flags a = Context a++proxyFromContext :: Context flags a -> Proxy flags+proxyFromContext (Context _) = Proxy++instance+   (Flags flags, Class.Zero a, Tuple a) =>+      Class.Zero (Context flags a) where+   zeroTuple = Context Class.zeroTuple++instance+   (Flags flags, Tuple a, A.Additive a) =>+      A.Additive (Context flags a) where+   zero = Context A.zero+   add = liftContext2 A.add+   sub = liftContext2 A.sub+   neg = liftContext A.neg++instance+   (Flags flags, A.PseudoRing a, Tuple a) =>+      A.PseudoRing (Context flags a) where+   mul = liftContext2 A.mul++type instance A.Scalar (Context flags a) = Context flags (A.Scalar a)++instance+   (Flags flags, A.PseudoModule v, Tuple v, A.Scalar v ~ a, Tuple a) =>+      A.PseudoModule (Context flags v) where+   scale = liftContext2 A.scale++instance+   (Flags flags, Tuple a, A.IntegerConstant a) =>+      A.IntegerConstant (Context flags a) where+   fromInteger' = Context . A.fromInteger'++instance+   (Flags flags, Tuple v, A.Field v) =>+      A.Field (Context flags v) where+   fdiv = liftContext2 A.fdiv++instance+   (Flags flags, Tuple a, A.RationalConstant a) =>+      A.RationalConstant (Context flags a) where+   fromRational' = Context . A.fromRational'++instance (Flags flags, Tuple a, A.Real a) => A.Real (Context flags a) where+   min = liftContext2 A.min+   max = liftContext2 A.max+   abs = liftContext A.abs+   signum = liftContext A.signum++instance+   (Flags flags, Tuple a, A.Fraction a) =>+      A.Fraction (Context flags a) where+   truncate = liftContext A.truncate+   fraction = liftContext A.fraction++instance+   (Flags flags, Tuple a, A.Comparison a) =>+      A.Comparison (Context flags a) where+   type CmpResult (Context flags a) = A.CmpResult a+   cmp p (Context x) (Context y) = A.cmp p x y++instance+   (Flags flags, Tuple a, A.FloatingComparison a) =>+      A.FloatingComparison (Context flags a) where+   fcmp p (Context x) (Context y) = A.fcmp p x y++instance+   (Flags flags, Tuple a, A.Algebraic a) =>+      A.Algebraic (Context flags a) where+   sqrt = liftContext A.sqrt++instance+   (Flags flags, Tuple a, A.Transcendental a) =>+      A.Transcendental (Context flags a) where+   pi = attachTupleFlags A.pi+   sin = liftContext A.sin+   cos = liftContext A.cos+   exp = liftContext A.exp+   log = liftContext A.log+   pow = liftContext2 A.pow+++attachTupleFlags ::+   (Flags flags, Tuple a) =>+   Id (LLVM.CodeGenFunction r (Context flags a))+attachTupleFlags act = do+   c@(Context x) <- act+   setTupleFlags (proxyFromContext c) True x+   return c++liftContext :: (Flags flags, Tuple b) =>+   (a -> LLVM.CodeGenFunction r b) ->+   Context flags a -> LLVM.CodeGenFunction r (Context flags b)+liftContext f (Context x) = attachTupleFlags (Context <$> f x)++liftContext2 :: (Flags flags, Tuple c) =>+   (a -> b -> LLVM.CodeGenFunction r c) ->+   Context flags a -> Context flags b ->+   LLVM.CodeGenFunction r (Context flags c)+liftContext2 f (Context x) = liftContext $ f x
src/LLVM/Extra/Iterator.hs view
@@ -91,7 +91,16 @@       (valueOf True)       (\running -> MaybeCont.guard running >> return (a, valueOf False)) +cons :: (Phi a, Class.Undefined a) => a -> T r a -> T r a+cons a0 (Cons s next) =+   Cons Maybe.nothing+      (fmap (mapSnd Maybe.just) .+       MaybeCont.fromMaybe .+       (\ms -> Maybe.run ms+         (return $ Maybe.just (a0,s))+         (MaybeCont.toMaybe . next))) + instance Functor (T r) where    fmap f (Cons s next) = Cons s (\s0 -> mapFst f <$> next s0) @@ -138,13 +147,12 @@                         (\a -> return (valueOf False, (Maybe.just a, s2)))))             (return . snd)) +takeWhileJust :: T r (Maybe.T a) -> T r a+takeWhileJust (Cons s next) =+   Cons s (FuncHT.mapFst MaybeCont.fromPlainMaybe <=< next)+ takeWhile :: (a -> CodeGenFunction r (Value Bool)) -> T r a -> T r a-takeWhile p (Cons s next) =-   Cons s-      (\s0 -> do-         (a,s1) <- next s0-         MaybeCont.guard =<< MaybeCont.lift (p a)-         return (a,s1))+takeWhile p = takeWhileJust . mapM (\a -> flip Maybe.fromBool a <$> p a)  {- | Attention:
src/LLVM/Extra/MaybeContinuation.hs view
@@ -89,13 +89,11 @@    m (return (valueOf False, undefTuple)) (return . (,) (valueOf True))  -fromMaybe ::-   (Phi z) =>-   CodeGenFunction r (Maybe.T a) -> T r z a-fromMaybe m = do-   Maybe.Cons b a <- lift m-   guard b-   return a+fromPlainMaybe :: (Phi z) => Maybe.T a -> T r z a+fromPlainMaybe (Maybe.Cons b a) = guard b >> return a++fromMaybe :: (Phi z) => CodeGenFunction r (Maybe.T a) -> T r z a+fromMaybe m = lift m >>= fromPlainMaybe  toMaybe ::    (Undefined a) =>
src/LLVM/Extra/MaybePrivate.hs view
@@ -104,3 +104,11 @@    (a -> b -> CodeGenFunction r c) ->    T a -> T b -> CodeGenFunction r (T c) liftM2 f ma mb = Monad.join $ fmap sequence $ lift2 f ma mb+++maybeArg ::+   (Phi b) =>+   b ->+   (a -> CodeGenFunction r (T b)) ->+   T a -> CodeGenFunction r (T b)+maybeArg undef f m = run m (return $ nothing undef) f
src/LLVM/Extra/Multi/Iterator.hs view
@@ -1,21 +1,31 @@+{-# 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.MaybePrivate as Maybe+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import LLVM.Extra.Class (undefTuple)  import qualified LLVM.Core as LLVM import LLVM.Core (CodeGenFunction)  import Control.Applicative (liftA2) -import Prelude hiding (take, takeWhile)+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@@ -37,3 +47,49 @@     MultiValue.IntegerConstant i) =>    MultiValue.T i -> Iter.T r a -> Iter.T r a take len xs = liftA2 const xs (countDown len)+++class 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.CmpResult w ~ Bool, 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 undefTuple (succMax to)) (Maybe.just from)++succMax ::+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.CmpResult w ~ Bool, 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 undefTuple) $+      fmap Maybe.just $ MultiValue.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.CmpResult w ~ Bool, 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
src/LLVM/Extra/Multi/Value/Memory.hs view
@@ -14,6 +14,7 @@ import Foreign.StablePtr (StablePtr, ) import Foreign.Ptr (Ptr, FunPtr, castPtr, ) +import Data.Tagged (Tagged) import Data.Complex (Complex, ) import Data.Word (Word8, Word16, Word32, Word64, ) import Data.Int (Int8, Int16, Int32, Int64, )@@ -179,6 +180,11 @@    MultiValue.T a -> CodeGenFunction r (Value (LLVM.Struct ())) composeUnit _ = return (LLVM.value $ LLVM.constStruct ()) ++instance (C a) => C (Tagged tag a) where+   type Struct (Tagged tag a) = Struct a+   decompose = fmap MultiValue.tag . decompose+   compose = compose . MultiValue.untag  instance (C a) => C (Complex a) where    type Struct (Complex a) = LLVM.Struct (Struct a, (Struct a, ()))
src/LLVM/Extra/Multi/Value/Private.hs view
@@ -26,8 +26,11 @@  import qualified Data.Tuple.HT as TupleHT import qualified Data.Tuple as Tuple+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), )@@ -36,6 +39,7 @@ import Data.Int (Int8, Int16, Int32, Int64, ) import Data.Bool8 (Bool8) +import qualified Prelude as P import Prelude (Float, Double, Integer, Rational, )  @@ -252,6 +256,59 @@ 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 f (Enum.T w e) = f w+   cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++toEnum ::+   (Repr LLVM.Value w ~ LLVM.Value w) =>+   T w -> T (Enum.T w e)+toEnum (Cons w) = Cons w++fromEnum ::+   (Repr LLVM.Value 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.CmpResult w ~ Bool) =>+   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 f (EnumBitSet.T w i) = f w+   cons = consPrimitive . EnumBitSet.decons+   undef = undefPrimitive+   zero = zeroPrimitive+   phis = phisPrimitive+   addPhis = addPhisPrimitive++ instance (C a) => C (Maybe a) where    type Repr f (Maybe a) = (f Bool, Repr f a)    cons Nothing = nothing@@ -406,6 +463,31 @@ unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)  +instance C a => C (Tagged tag a) where+   type Repr f (Tagged tag a) = Repr f a+   cons = tag . cons . unTagged+   undef = tag undef+   zero = tag zero+   phis bb = fmap tag . phis bb . untag+   addPhis bb a b = addPhis 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    type Repr f (Complex a) = Complex (Repr f a)    cons (a:+b) = consComplex (cons a) (cons b)@@ -512,7 +594,7 @@    type Composed () = ()    compose = cons -instance () => Decompose () where+instance Decompose () where    decompose () _ = ()  type instance Decomposed f () = ()@@ -564,6 +646,17 @@         (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)  +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)@@ -644,10 +737,16 @@ 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' @@ -720,6 +819,11 @@    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@@ -728,8 +832,8 @@  inc, dec ::    (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i)-inc x = add x (fromInteger' 1)-dec x = sub x (fromInteger' 1)+inc x = add x A.one+dec x = sub x A.one   class (Additive a) => PseudoRing a where@@ -746,6 +850,9 @@ 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 @@ -759,6 +866,9 @@ 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 @@ -766,6 +876,7 @@ 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@@ -777,6 +888,9 @@ 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 @@ -859,6 +973,12 @@    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@@ -878,6 +998,10 @@    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@@ -933,6 +1057,9 @@ 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 @@ -958,6 +1085,14 @@    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@@ -1003,6 +1138,9 @@             (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) @@ -1034,6 +1172,9 @@ 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@@ -1048,6 +1189,9 @@ 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 @@ -1087,7 +1231,15 @@    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@@ -1145,6 +1297,10 @@ 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 ::