packages feed

llvm-extra (empty) → 0.13

raw patch · 53 files changed

Files

+ Changes.md view
@@ -0,0 +1,48 @@+# Change log for the `llvm-extra` package++## 0.12.1++* `Multi.Value` -> `Nice.Value`++  The `Multi.Value` name was misleading.+  `Multi.Value` retained for compatibility for now.++## 0.11++* `Memory`: turn methods `load` and `store` into top-level functions+  based on `decompose` and `compose`.+  Deriving `decompose` and `compose` from `load` and `store`, respectively,+  requires `alloca` which will blast your stack when used in a loop.++## 0.10++* `Storable`: We do not support storing tuple types directly anymore.+  This would require the `storable-tuple` package.+  That package ships orphan `Storable` instances+  with a memory layout that does not match your system's ABI.+  Instead, we support the `Tuple` wrapper from `storable-record`.++* `Memory`: Attention!+  Memory layout is no longer compatible with `Foreign.Storable`.+  E.g. `Bool` now takes 1 byte space like LLVM does,+  but no longer 4 byte like `Foreign.Storable`.+  A `Foreign.Storable`-compliant layout+  is provided by `LLVM.Extra.Storable` now.++* `Marshal`: Now based on `Memory.load` and `Memory.store`.+  Does not need `Proxy` anymore.++* `Class` -> `Tuple`,+  `Tuple.Vector` class added.+  Pro: `valueOf vector` is no longer restricted to `IsPrimitive` elements.+  Cons: type inference works less well than before++## 0.9++* `Extension`: Move to new package `llvm-extension`.+  We now implement advanced instructions using generic LLVM intrinsics.++## 0.8.1++* `FastMath`: support for simplified arithmetic primitives+  under the assumption of the absence of corner cases.
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2010, Henning Thielemann++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * The names of contributors may not be used to endorse or promote+      products derived from this software without specific prior+      written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Makefile view
@@ -0,0 +1,36 @@+.PHONY:	sharedobj++testbuild:+	runhaskell Setup.lhs configure --user -fbuildExamples --enable-tests+	runhaskell Setup.lhs build+#	runhaskell Setup.lhs haddock+	./dist/build/llvm-extra-test/llvm-extra-test++llvmversion = 2.6++sharedobj:	libLLVM.so++libLLVM.so:	libLLVM.so.$(llvmversion)+	ln -s $< $@++libLLVM.so.%:+	for src in `llvm-config --libdir`/libLLVM*.a; do ar -x $$src ; done+	gcc -shared -Wl,-soname,$@ -o $@ *.o+#	gcc -shared -Wl,-soname,$@ -o $@ `llvm-config --libdir`/LLVM*.o *.o+	rm *.o++%.s:	%.bc+	llc  $<++# This would lead to a cycle with llvm-as.+# %.ll:	%.bc+#	llvm-dis -f $<++%-dis.ll:	%.bc+	llvm-dis -o $@ -f $<++%.bc:	%.ll+	llvm-as -f $<++%-opt.bc:	%.bc+	opt -O3 < $< > $@
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ llvm-extra.cabal view
@@ -0,0 +1,193 @@+Cabal-Version:  2.2+Name:           llvm-extra+Version:        0.13+License:        BSD-3-Clause+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+Homepage:       https://wiki.haskell.org/LLVM+Category:       Compilers/Interpreters, Code Generation+Synopsis:       Utility functions for the llvm interface+Description:+  The Low-Level Virtual-Machine is a compiler back-end with optimizer.+  You may also call it a high-level portable assembler.+  This package provides various utility functions+  for the Haskell interface to LLVM, for example:+  .+  * arithmetic operations with more general types+    but better type inference than the @llvm@ interface+    in "LLVM.Extra.Arithmetic",+  .+  * a type class for loading and storing sets of values with one command (macro)+    in "LLVM.Extra.Memory",+  .+  * storing and reading Haskell values in an LLVM compatible format+    in "LLVM.Extra.Marshal",+  .+  * LLVM functions for loading and storing values in Haskell's @Storable@ format+    in "LLVM.Extra.Storable",+  .+  * support value tuples and instance declarations of LLVM classes+    in "LLVM.Extra.Tuple",+  .+  * handling of termination by a custom monad on top of @CodeGenFunction@+    in "LLVM.Extra.MaybeContinuation"+  .+  * various kinds of loops (while) and condition structures (if-then-else)+    in "LLVM.Extra.Control"+  .+  * more functional loop construction using "LLVM.Extra.Iterator"+  .+  * complex Haskell values mapped to LLVM values in "LLVM.Extra.Nice.Value"+  .+  * advanced vector operations+    such as sum of all vector elements, cumulative sum,+    floor, non-negative fraction, absolute value+    in "LLVM.Extra.Vector"+  .+  * type classes for handling scalar and vector operations+    in a uniform way+    in "LLVM.Extra.ScalarOrVector"+Stability:      Experimental+Tested-With:    GHC==7.0.4, GHC==7.4.2, GHC==7.8.4+Tested-With:    GHC==8.4.4, GHC==8.6.5, GHC==8.8.1+Build-Type:     Simple+Extra-Source-Files:+  Makefile++Extra-Doc-Files:+  Changes.md++Flag buildExamples+  description: Build example executables+  default:     False++Source-Repository this+  Tag:         0.13+  Type:        darcs+  Location:    http://code.haskell.org/~thielema/llvm-extra/++Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/~thielema/llvm-extra/++Library+  Build-Depends:+    private,+    llvm-tf >=12.1 && <21.1,+    tfp >=1.0 && <1.1,+    non-empty >=0.2.1 && <0.4,+    fixed-length >=0.2.1 && <0.3,+    containers >=0.1 && <0.8,+    enumset >=0.0.5 && <0.2,+    storable-record >=0.0.5 && <0.1,+    storable-enum >=0.0 && <0.1,+    bool8 >=0.0 && <0.1,+    transformers >=0.1.1 && <0.7,+    tagged >=0.7 && <0.9,+    utility-ht >=0.0.15 && <0.1,+    prelude-compat >=0.0 && <0.0.1,+    base-orphans >= 0.5 && <1,+    base >=3 && <5++  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-source-dirs: src+  Exposed-Modules:+    LLVM.Extra.Arithmetic+    LLVM.Extra.Monad+    LLVM.Extra.Memory+    LLVM.Extra.Marshal+    LLVM.Extra.Storable+    LLVM.Extra.Maybe+    LLVM.Extra.MaybeContinuation+    LLVM.Extra.Either+    LLVM.Extra.Tuple+    LLVM.Extra.Struct+    LLVM.Extra.Control+    LLVM.Extra.Function+    LLVM.Extra.Array+    LLVM.Extra.Scalar+    LLVM.Extra.Vector+    LLVM.Extra.ScalarOrVector+    LLVM.Extra.FastMath+    LLVM.Extra.Iterator+    LLVM.Extra.Nice.Iterator+    LLVM.Extra.Nice.Value+    LLVM.Extra.Nice.Value.Vector+    LLVM.Extra.Nice.Value.Marshal+    LLVM.Extra.Nice.Value.Storable+    LLVM.Extra.Nice.Vector+    LLVM.Extra.Nice.Vector.Instance+    LLVM.Extra.Nice.Class+    -- retained for compatibility+    LLVM.Extra.Multi.Iterator+    LLVM.Extra.Multi.Value+    LLVM.Extra.Multi.Value.Vector+    LLVM.Extra.Multi.Value.Marshal+    LLVM.Extra.Multi.Value.Storable+    LLVM.Extra.Multi.Vector+    LLVM.Extra.Multi.Vector.Instance+    LLVM.Extra.Multi.Class+  Other-Modules:+    LLVM.Extra.Storable.Array+    LLVM.Extra.Storable.Private+    LLVM.Extra.TuplePrivate+    LLVM.Extra.MaybePrivate+    LLVM.Extra.EitherPrivate+    LLVM.Extra.Nice.Value.Private+    LLVM.Extra.Nice.Value.Array++Library private+  Build-Depends:+    llvm-tf,+    tfp,+    non-empty,+    utility-ht,+    base >=3 && <5++  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-source-dirs: private+  Exposed-Modules:+    LLVM.Extra.ScalarOrVectorPrivate+    LLVM.Extra.ArithmeticPrivate++Executable tone-llvm+  If flag(buildExamples)+    Build-Depends:+      llvm-extra,+      llvm-tf,+      tfp,+      non-empty,+      containers >=0.1 && <0.8,+      transformers,+      utility-ht >=0.0.1 && <0.1,+      base >=3 && <5+  Else+    Buildable: False+  Default-Language: Haskell98+  GHC-Options: -Wall+  Main-Is: src/Array.hs++Test-Suite llvm-extra-test+  Type: exitcode-stdio-1.0+  Build-Depends:+    doctest-exitcode-stdio >=0.0 && <0.1,+    QuickCheck >=2.11 && <3,+    private,+    llvm-extra,+    llvm-tf,+    tfp,+    storable-record,+    utility-ht >=0.0.1 && <0.1,+    transformers,+    base >=3 && <5+  Default-Language: Haskell98+  GHC-Options: -Wall+  Hs-Source-Dirs: test+  Main-Is: Main.hs+  Other-Modules:+    Test.Storable+    Test.Vector+    LLVM.Extra.VectorAlt
+ private/LLVM/Extra/ArithmeticPrivate.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.ArithmeticPrivate where++import qualified LLVM.Util.Intrinsic as Intrinsic++import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, valueOf, Value,+    CmpPredicate(CmpLE, CmpGE), FPPredicate, CmpRet, CmpResult,+    IsConst, IsPrimitive, IsArithmetic, IsInteger, IsFloating,+    getElementPtr, )++import Data.Word (Word32, )+import Data.Int (Int32, )++import Prelude hiding (and, or, sqrt, sin, cos, exp, log, abs, min, max, )+++add ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+add = LLVM.add++sub ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+sub = LLVM.sub+++inc ::+   (IsArithmetic a, IsConst a, Num a) =>+   Value a -> CodeGenFunction r (Value a)+inc x = add x (valueOf 1)++dec ::+   (IsArithmetic a, IsConst a, Num a) =>+   Value a -> CodeGenFunction r (Value a)+dec x = sub x (valueOf 1)++advanceArrayElementPtr ::+   (LLVM.IsType a) =>+   Value (LLVM.Ptr a) ->+   CodeGenFunction r (Value (LLVM.Ptr a))+advanceArrayElementPtr p =+   getElementPtr p (valueOf 1 :: Value Word32, ())++decreaseArrayElementPtr ::+   (LLVM.IsType a) =>+   Value (LLVM.Ptr a) ->+   CodeGenFunction r (Value (LLVM.Ptr a))+decreaseArrayElementPtr p =+   getElementPtr p (valueOf (-1) :: Value Int32, ())++++mul ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+mul = LLVM.mul+++{- |+This would also work for vectors,+but LLVM-3.1 crashes when actually doing this.+-}+min :: (CmpRet a) => Value a -> Value a -> CodeGenFunction r (Value a)+min = cmpSelect (cmp CmpLE)++max :: (CmpRet a) => Value a -> Value a -> CodeGenFunction r (Value a)+max = cmpSelect (cmp CmpGE)++abs :: (IsArithmetic a, CmpRet a) =>+   Value a -> CodeGenFunction r (Value a)+abs x = do+   b <- cmp LLVM.CmpGE x (LLVM.value LLVM.zero)+   LLVM.select b x =<< LLVM.neg x+++signumGen ::+   (CmpRet a, IsPrimitive a) =>+   Value a -> Value a ->+   Value a -> CodeGenFunction r (Value a)+signumGen minusOne one x = do+   let zero = LLVM.value LLVM.zero+   negative <- cmp LLVM.CmpLT x zero+   positive <- cmp LLVM.CmpGT x zero+   LLVM.select negative minusOne+      =<< LLVM.select positive one zero++signum ::+   (Num a, CmpRet a, IsConst a, IsPrimitive a) =>+   Value a -> CodeGenFunction r (Value a)+signum = signumGen (LLVM.valueOf (-1)) (LLVM.valueOf 1)+++cmpSelect ::+   (CmpRet a) =>+   (Value a -> Value a -> CodeGenFunction r (Value (CmpResult a))) ->+   (Value a -> Value a -> CodeGenFunction r (Value a))+cmpSelect f x y =+   f x y >>= \b -> LLVM.select b x y+++fcmp ::+   (IsFloating a, CmpRet a, CmpResult a ~ b) =>+   FPPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+fcmp = LLVM.fcmp++cmp ::+   (CmpRet a, CmpResult a ~ b) =>+   CmpPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+cmp = LLVM.cmp++++and ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+and = LLVM.and++or ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+or = LLVM.or+++fraction :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+fraction x = sub x =<< Intrinsic.floor x
+ private/LLVM/Extra/ScalarOrVectorPrivate.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.ScalarOrVectorPrivate where++import qualified LLVM.Extra.ArithmeticPrivate as A++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal (D1)++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, ConstValue, valueOf,+    CmpRet, ShapeOf,+    Vector, WordN, IntN, FP128,+    IsConst, IsInteger, CodeGenFunction)++import qualified Data.NonEmpty as NonEmpty+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)++import Prelude hiding (replicate)+++type family Scalar vector++type instance Scalar Float  = Float+type instance Scalar Double = Double+type instance Scalar FP128  = FP128+type instance Scalar Bool   = Bool+type instance Scalar Int    = Int+type instance Scalar Int8   = Int8+type instance Scalar Int16  = Int16+type instance Scalar Int32  = Int32+type instance Scalar Int64  = Int64+type instance Scalar Word   = Word+type instance Scalar Word8  = Word8+type instance Scalar Word16 = Word16+type instance Scalar Word32 = Word32+type instance Scalar Word64 = Word64+type instance Scalar (IntN  d) = IntN  d+type instance Scalar (WordN d) = WordN d+type instance Scalar (Vector n a) = a+++class Replicate vector where+   -- | an alternative is using the 'Vector.Constant' vector type+   replicate :: Value (Scalar vector) -> CodeGenFunction r (Value vector)+   replicateConst :: ConstValue (Scalar vector) -> ConstValue vector++instance Replicate Float  where replicate = return; replicateConst = id;+instance Replicate Double where replicate = return; replicateConst = id;+instance Replicate FP128  where replicate = return; replicateConst = id;+instance Replicate Bool   where replicate = return; replicateConst = id;+instance Replicate Int    where replicate = return; replicateConst = id;+instance Replicate Int8   where replicate = return; replicateConst = id;+instance Replicate Int16  where replicate = return; replicateConst = id;+instance Replicate Int32  where replicate = return; replicateConst = id;+instance Replicate Int64  where replicate = return; replicateConst = id;+instance Replicate Word   where replicate = return; replicateConst = id;+instance Replicate Word8  where replicate = return; replicateConst = id;+instance Replicate Word16 where replicate = return; replicateConst = id;+instance Replicate Word32 where replicate = return; replicateConst = id;+instance Replicate Word64 where replicate = return; replicateConst = id;+instance Replicate (IntN  d) where replicate = return; replicateConst = id;+instance Replicate (WordN d) where replicate = return; replicateConst = id;+instance+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+      Replicate (Vector n a) where+   replicate x = do+      v <- singleton x+      LLVM.shufflevector v (LLVM.value LLVM.undef) LLVM.zero+   replicateConst x = LLVM.constCyclicVector $ NonEmpty.Cons x []++singleton ::+   (LLVM.IsPrimitive a) =>+   Value a -> CodeGenFunction r (Value (Vector D1 a))+singleton x =+   LLVM.insertelement (LLVM.value LLVM.undef) x (valueOf 0)+++uaddSat, usubSat ::+   (IsInteger v, CmpRet v, Replicate v, Scalar v ~ a, IsConst a, Bounded a) =>+   Value v -> Value v -> CodeGenFunction r (Value v)+uaddSat x y = do+   z <- A.add x y+   wrong <- A.cmp LLVM.CmpLT z x+   maxBnd <- replicate $ valueOf maxBound+   LLVM.select wrong maxBnd z+usubSat x y = do+   z <- A.sub x y+   wrong <- A.cmp LLVM.CmpGT z x+   LLVM.select wrong (LLVM.value LLVM.zero) z++saddSat, ssubSat ::+   (IsInteger v, CmpRet v, Replicate v, ShapeOf v ~ shape,+    LLVM.ShapedType shape Bool ~ bv, ShapeOf bv ~ shape, CmpRet bv,+    Scalar v ~ a, IsConst a, Bounded a) =>+   Value v -> Value v -> CodeGenFunction r (Value v)++saddSat x y = do+   z <- A.add x y+   nonNegX <- A.cmp LLVM.CmpGE x $ LLVM.value LLVM.zero+   nonNegY <- A.cmp LLVM.CmpGE y $ LLVM.value LLVM.zero+   distinctSign <- A.cmp LLVM.CmpNE nonNegX nonNegY+   overflow <- A.cmp LLVM.CmpLT z x+   underflow <- A.cmp LLVM.CmpGT z x+   maxBnd <- replicate $ valueOf maxBound+   minBnd <- replicate $ valueOf minBound+   maxSat <- LLVM.select overflow maxBnd z+   minSat <- LLVM.select underflow minBnd z+   saturated <- LLVM.select nonNegX maxSat minSat+   LLVM.select distinctSign z saturated++ssubSat x y = do+   z <- A.sub x y+   nonNegX <- A.cmp LLVM.CmpGE x $ LLVM.value LLVM.zero+   nonNegY <- A.cmp LLVM.CmpGE y $ LLVM.value LLVM.zero+   sameSign <- A.cmp LLVM.CmpEQ nonNegX nonNegY+   overflow <- A.cmp LLVM.CmpLT z x+   underflow <- A.cmp LLVM.CmpGT z x+   maxBnd <- replicate $ valueOf maxBound+   minBnd <- replicate $ valueOf minBound+   maxSat <- LLVM.select overflow maxBnd z+   minSat <- LLVM.select underflow minBnd z+   saturated <- LLVM.select nonNegX maxSat minSat+   LLVM.select sameSign z saturated++saddSatLogical ::+   (IsInteger v, CmpRet v, Replicate v, ShapeOf v ~ shape,+    LLVM.ShapedType shape Bool ~ bv, ShapeOf bv ~ shape, CmpRet bv,+    IsInteger bv,+    Scalar v ~ a, IsConst a, Bounded a) =>+   Value v -> Value v -> CodeGenFunction r (Value v)+saddSatLogical x y = do+   z <- A.add x y+   nonNegX <- A.cmp LLVM.CmpGE x $ LLVM.value LLVM.zero+   nonNegY <- A.cmp LLVM.CmpGE y $ LLVM.value LLVM.zero+   distinctSign <- A.cmp LLVM.CmpNE nonNegX nonNegY+   minBnd <- replicate $ valueOf minBound+   maxBnd <- replicate $ valueOf maxBound+   bounds <- LLVM.select nonNegX maxBnd minBnd+   overflow <- A.cmp LLVM.CmpLT z y+   underflow <- A.cmp LLVM.CmpGT z y+   xflow <- LLVM.select nonNegX overflow underflow+   correctSum <- A.or distinctSign xflow+   LLVM.select correctSum z bounds
+ src/Array.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Main where++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Vector as Vector++import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Arithmetic as A+import LLVM.Extra.Storable (arrayLoop, store)+import LLVM.Extra.Control (ret)++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM+import LLVM.ExecutionEngine (simpleFunction, )+import LLVM.Core+         (Value, valueOf, value, constOf, undef, zero, add, sub, mul, frem,+          createFunction, Function, Linkage(ExternalLinkage),+          CodeGenModule, CodeGenFunction,+          Vector, extractelement, insertelement, shufflevector, )+import qualified System.IO as IO++import Type.Data.Num.Decimal(D4, )+import Data.Word (Word32, )+import qualified Foreign.Storable as St+import Foreign.Marshal.Array (allocaArray, )+import Foreign.Ptr (FunPtr, Ptr, )++import qualified Data.Empty as Empty+import Data.NonEmpty ((!:), )++import Control.Monad.Trans.State (StateT(StateT), runStateT)+import Control.Monad.HT ((<=<))+import Control.Monad (liftM2)+import Control.Applicative (liftA2)++++type Vec = LLVM.ConstValue (Vector D4 Float)++constVec ::+   Float -> CodeGenFunction r (Value (Vector D4 Float))+constVec x =+   return $ valueOf $ LLVM.consVector x x x x++constVecInsert ::+   Float -> CodeGenFunction r (Value (Vector D4 Float))+constVecInsert x' =+   let x = valueOf x'+   in  foldr+          (\n mv v -> insertelement v x (valueOf n) >>= mv)+          return+          [0..3]+          (value (undef :: Vec))++{-+This implementation cannot make use of vector operations,+because 'frem' is only available in the FPU.+-}+fractionVector0 ::+   Value (Vector D4 Float) -> CodeGenFunction r (Value (Vector D4 Float))+fractionVector0 x =+   frem x =<< constVec 1+++{-+This call++    fill (fromIntegral len) ptr+       (LLVM.consVector 0.01003 0.01001 0.00999 0.00997) >>++would not work, because Vector is not of type Generic.+-}+mChorusVectorArg ::+  CodeGenModule (Function (Word32 -> Ptr Float -> Vector D4 Float -> IO Float))+mChorusVectorArg =+  createFunction ExternalLinkage $ \ size ptr freq -> do+    const1 <- constVec 1+    const2 <- constVec 2+    s <- arrayLoop size ptr (value (zero :: Vec)) $ \ ptri phase -> do+      y <- sub const1 =<< mul const2 phase+      s0 <- extractelement y (valueOf 0)+      s1 <- extractelement y (valueOf 1)+      s2 <- extractelement y (valueOf 2)+      s3 <- extractelement y (valueOf 3)+      s01 <- add s0 s1+      s23 <- add s2 s3+      s0123 <- add s01 s23+      flip store ptri =<< A.mul (valueOf 0.25) s0123+      Vector.fraction =<< add phase freq+    ss <- extractelement s (valueOf 0)+    ret (ss :: Value Float)+++{- |+differing vector sizes are allowed according to documentation,+but not supported by C++ library of LLVM-2.5++mixReduceSize :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float)+mixReduceSize y = do+    y01 <- shufflevector y (value undef) (LLVM.constVector [constOf 0, constOf 1])+    y23 <- shufflevector y (value undef) (LLVM.constVector [constOf 2, constOf 3])+    z <- add+       (y01 :: Value (Vector D2 Float))+       (y23 :: Value (Vector D2 Float))+    s0 <- extractelement z (valueOf 0)+    s1 <- extractelement z (valueOf 1)+    A.mul (valueOf 0.25) =<< add s0 s1+-}++mixScalar :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float)+mixScalar y = do+    y0 <- extractelement y (valueOf 0)+    y1 <- extractelement y (valueOf 1)+    y2 <- extractelement y (valueOf 2)+    y3 <- extractelement y (valueOf 3)+    s0 <- A.add y0 y1+    s1 <- A.add y2 y3+    A.mul (valueOf 0.25) =<< A.add s0 s1++{-+Here we do use consistently Vectors of size 4.+Since we declare the upper floats as undefined+the code is efficient.+-}+mixGeneric :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float)+mixGeneric y = do+    -- that is translated to movhlps+    y23 <-+       shufflevector y (value undef)+          (LLVM.constVector $ constOf 2 !: constOf 3 !: undef !: undef !: Empty.Cons)+    z <- A.add y y23+    s0 <- extractelement z (valueOf 0)+    s1 <- extractelement z (valueOf 1)+    A.mul (valueOf 0.25) =<< A.add s0 s1+++mChorusVector ::+  CodeGenModule+    (Function+      (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float))+mChorusVector =+  createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do+    freq <- Vector.assemble [f0,f1,f2,f3]+    const1 <- constVec 1+    const2 <- constVec (-2)+    s <- arrayLoop size ptr (value (zero :: Vec)) $ \ ptri phase -> do+      flip store ptri =<< mixGeneric =<< add const1 =<< mul const2 phase+      Vector.fraction =<< A.add phase freq+    ss <- extractelement s (valueOf 0)+    ret ss++mChorusVectorIterator ::+  CodeGenModule+    (Function+      (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float))+mChorusVectorIterator =+  createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do+    freq <- Vector.assemble [f0,f1,f2,f3]+    const1 <- constVec 1+    const2 <- constVec (-2)+    Iter.mapM_ id $ Iter.take size $+      liftA2+        (\ptri phase ->+          flip store ptri =<< mixGeneric =<< add const1 =<< mul const2 phase)+        (Iter.storableArrayPtrs ptr)+        (Iter.iterate (Vector.fraction <=< A.add freq) (value (zero :: Vec)))+    ret (value zero :: Value Float)+++waveSaw :: Value Float -> CodeGenFunction r (Value Float)+waveSaw t =+  A.sub (valueOf 1) =<<+  A.mul (valueOf 2) t++osciSaw ::+  Value Float -> Value Float -> CodeGenFunction r (Value Float, Value Float)+osciSaw freq phase =+  liftM2 (,) (waveSaw phase) (SoV.incPhase freq phase)++mChorus ::+  CodeGenModule+    (Function+      (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float))+mChorus =+  createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do+    s <- arrayLoop size ptr Tuple.zero $+         \ ptri ((phase0, phase1), (phase2, phase3)) -> do+      (y0, phase0') <- osciSaw f0 phase0+      (y1, phase1') <- osciSaw f1 phase1+      (y2, phase2') <- osciSaw f2 phase2+      (y3, phase3') <- osciSaw f3 phase3+      y01 <- A.add y0 y1+      y23 <- A.add y2 y3+      y0123 <- A.add y01 y23+      flip store ptri =<< A.mul (valueOf 0.25) y0123+      return ((phase0', phase1'), (phase2', phase3'))+    ret (fst (fst s) :: Value Float)+++sawOsciAction ::+  Value Float ->+  StateT (Value Float) (CodeGenFunction r) (Value Float)+sawOsciAction freq =+  StateT $ osciSaw freq++{-+(***) :: StateT s m a -> StateT t m b -> StateT (s,t) m (a,b)+(***) sta stb =+  StateT $ \(s0,t0) ->+  do (a,s1) <- runStateT sta s0+     (b,t1) <- runStateT stb t0+     return ((a,b), (s1,t1))+-}++(=+=) ::+  StateT s (CodeGenFunction r) (Value Float) ->+  StateT t (CodeGenFunction r) (Value Float) ->+  StateT (s,t) (CodeGenFunction r) (Value Float)+(=+=) sta stb =+  StateT $ \(s0,t0) ->+  do (a,s1) <- runStateT sta s0+     (b,t1) <- runStateT stb t0+     c <- add a b+     return (c, (s1,t1))++mChorusMonadic ::+  CodeGenModule+    (Function+      (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float))+mChorusMonadic =+  createFunction ExternalLinkage $ \ size ptr f0 f1 f2 f3 -> do+    s <- arrayLoop size ptr Tuple.zero $+         \ ptri phases -> do+      (y, phases') <-+         flip runStateT phases $+            (sawOsciAction f0 =+= sawOsciAction f1) =+=+            (sawOsciAction f2 =+= sawOsciAction f3)+      flip store ptri =<< A.mul (valueOf 0.25) y+      return phases'+    ret (fst (fst s))+++type Importer func = FunPtr func -> func++generateFunction ::+  EE.ExecutionFunction f =>+  Importer f -> CodeGenModule (Function f) -> IO f+generateFunction imprt code = do+  m <- LLVM.newModule+  fill <- do+    func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> code+    EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func+  LLVM.writeBitcodeToFile "array.bc" m+  return fill+++foreign import ccall safe "dynamic" derefChorusPtr ::+  Importer+    (Word32 -> Ptr Float -> Float -> Float -> Float -> Float -> IO Float)++renderChorus :: IO ()+renderChorus = do+  fill <- generateFunction derefChorusPtr mChorusVectorIterator+  IO.withFile "speedtest.f32" IO.WriteMode $ \h ->+    let len = 10000000+    in  allocaArray len $ \ ptr ->+          fill (fromIntegral len) ptr 0.01003 0.01001 0.00999 0.00997 >>+          IO.hPutBuf h ptr (len*St.sizeOf(undefined::Float))+++mSaw :: CodeGenModule (Function (Word32 -> Ptr Float -> Float -> IO Float))+mSaw =+  createFunction ExternalLinkage $ \ size ptr freq -> do+    s <- arrayLoop size ptr (valueOf 0) $ \ ptri phase -> do+      (y, phase') <- osciSaw freq phase+      store y ptri+      return phase'+    ret (s :: Value Float)++foreign import ccall safe "dynamic" derefSawPtr ::+  Importer (Word32 -> Ptr Float -> Float -> IO Float)++renderSaw :: IO ()+renderSaw = do+  fill <- generateFunction derefSawPtr mSaw+  IO.withFile "speedtest.f32" IO.WriteMode $ \h ->+    let len = 10000000+    in  allocaArray len $ \ ptr ->+          fill (fromIntegral len) ptr 0.01 >>+          IO.hPutBuf h ptr (len*St.sizeOf(undefined::Float))+++mRamp :: CodeGenModule (Function (Word32 -> Ptr Float -> Float -> IO Float))+mRamp =+  createFunction ExternalLinkage $ \ size ptr slope -> do+    s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do+      store y ptri+      add slope y+    ret (s :: Value Float)++renderRamp :: IO ()+renderRamp = do+  fill <- simpleFunction mRamp+  IO.withFile "speedtest.f32" IO.WriteMode $ \h ->+    let len = 10000000+    in  allocaArray len $ \ ptr ->+          fill (fromIntegral len) ptr (recip $ fromIntegral len) >>+          IO.hPutBuf h ptr (len*St.sizeOf(undefined::Float))++main :: IO ()+main = do+   LLVM.initializeNativeTarget+   renderChorus
+ src/LLVM/Extra/Arithmetic.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Arithmetic (+   -- * arithmetic: generalized and improved type inference+   Additive (zero, add, sub, neg), one, inc, dec,+   PseudoRing (mul), square,+   Scalar,+   PseudoModule (scale),+   Field (fdiv),+   IntegerConstant(fromInteger'),+   RationalConstant(fromRational'),+   idiv, irem,+   FloatingComparison(fcmp), Comparison(cmp),+   CmpResult, LLVM.CmpPredicate(..),+   Logic (and, or, xor, inv),+   Real (min, max, abs, signum),+   Fraction (truncate, fraction),+   signedFraction, addToPhase, incPhase,+   -- * pointer arithmetic+   advanceArrayElementPtr,+   decreaseArrayElementPtr,+   -- * transcendental functions+   Algebraic (sqrt),+   Transcendental (pi, sin, cos, exp, log, pow),+   exp2, log2, log10,+   ) where++import qualified LLVM.Util.Intrinsic as Intrinsic+import LLVM.Extra.ArithmeticPrivate+   (inc, dec, advanceArrayElementPtr, decreaseArrayElementPtr, )++import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, value, Value, ConstValue,+    IsInteger, IsFloating, IsArithmetic)++import Control.Monad (liftM2, liftM3, )++import Prelude hiding+   (Real, and, or, sqrt, sin, cos, exp, log, abs, min, max, truncate, )++++{- |+This and the following type classes+are intended for arithmetic operations on wrappers around LLVM types.+E.g. you might define a fixed point fraction type by++> newtype Fixed = Fixed Int32++and then use the same methods for floating point and fixed point arithmetic.++In contrast to the arithmetic methods in the @llvm@ wrapper,+in our methods the types of operands and result match.+Advantage: Type inference determines most of the types automatically.+Disadvantage: You cannot use constant values directly,+but you have to convert them all to 'Value'.+-}+class (Tuple.Zero a) => Additive a where+   zero :: a+   add :: a -> a -> CodeGenFunction r a+   sub :: a -> a -> CodeGenFunction r a+   neg :: a -> CodeGenFunction r a++instance (IsArithmetic a) => Additive (Value a) where+   zero = LLVM.value LLVM.zero+   add = LLVM.add+   sub = LLVM.sub+   neg = LLVM.neg++instance (IsInteger a) => Additive (ConstValue a) where+   zero = LLVM.zero+   add = LLVM.iadd+   sub = LLVM.isub+   neg = LLVM.isub LLVM.zero++instance (Additive a, Additive b) => Additive (a,b) where+   zero = (zero, zero)+   add (x0,x1) (y0,y1) =+      liftM2 (,) (add x0 y0) (add x1 y1)+   sub (x0,x1) (y0,y1) =+      liftM2 (,) (sub x0 y0) (sub x1 y1)+   neg (x0,x1) =+      liftM2 (,) (neg x0)    (neg x1)++instance (Additive a, Additive b, Additive c) => Additive (a,b,c) where+   zero = (zero, zero, zero)+   add (x0,x1,x2) (y0,y1,y2) =+      liftM3 (,,) (add x0 y0) (add x1 y1) (add x2 y2)+   sub (x0,x1,x2) (y0,y1,y2) =+      liftM3 (,,) (sub x0 y0) (sub x1 y1) (sub x2 y2)+   neg (x0,x1,x2) =+      liftM3 (,,) (neg x0)    (neg x1)    (neg x2)+++class (Additive a) => PseudoRing a where+   mul :: a -> a -> CodeGenFunction r a++instance (IsArithmetic v) => PseudoRing (Value v) where+   mul = LLVM.mul+++type family Scalar vector+type instance Scalar (Value a) = Value (SoV.Scalar a)+type instance Scalar (ConstValue a) = ConstValue (SoV.Scalar a)++class (PseudoRing (Scalar v), Additive v) => PseudoModule v where+   scale :: Scalar v -> v -> CodeGenFunction r v++instance (SoV.PseudoModule v) => PseudoModule (Value v) where+   scale = SoV.scale+++class IntegerConstant a where+   fromInteger' :: Integer -> a++instance SoV.IntegerConstant a => IntegerConstant (ConstValue a) where+   fromInteger' = SoV.constFromInteger++instance SoV.IntegerConstant a => IntegerConstant (Value a) where+   fromInteger' = value . SoV.constFromInteger+++one :: (IntegerConstant a) => a+one = fromInteger' 1+++{-+more general alternative to 'inc',+but you may not like the resulting type constraints+-}+_inc ::+   (PseudoRing a, IntegerConstant a) =>+   a -> CodeGenFunction r a+_inc x = add x one++_dec ::+   (PseudoRing a, IntegerConstant a) =>+   a -> CodeGenFunction r a+_dec x = sub x one+++square ::+   (PseudoRing a) =>+   a -> CodeGenFunction r a+square x = mul x x+++class (PseudoRing a) => Field a where+   fdiv :: a -> a -> CodeGenFunction r a++instance (LLVM.IsFloating v) => Field (Value v) where+   fdiv = LLVM.fdiv+++class (IntegerConstant a) => RationalConstant a where+   fromRational' :: Rational -> a++instance SoV.RationalConstant a => RationalConstant (ConstValue a) where+   fromRational' = SoV.constFromRational++instance SoV.RationalConstant a => RationalConstant (Value a) where+   fromRational' = value . SoV.constFromRational++++{- |+In Haskell terms this is a 'quot'.+-}+idiv ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+idiv = LLVM.idiv++irem ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+irem = LLVM.irem++++class (Additive a) => Real a where+   min :: a -> a -> CodeGenFunction r a+   max :: a -> a -> CodeGenFunction r a+   abs :: a -> CodeGenFunction r a+   signum :: a -> CodeGenFunction r a++instance (SoV.Real a) => Real (Value a) where+   min = SoV.min+   max = SoV.max+   abs = SoV.abs+   signum = SoV.signum+++class (Real a) => Fraction a where+   truncate :: a -> CodeGenFunction r a+   fraction :: a -> CodeGenFunction r a++instance (SoV.Fraction a) => Fraction (Value a) where+   truncate = SoV.truncate+   fraction = SoV.fraction++signedFraction ::+   (Fraction a) =>+   a -> CodeGenFunction r a+signedFraction x =+   sub x =<< truncate x++addToPhase ::+   (Fraction a) =>+   a -> a -> CodeGenFunction r a+addToPhase d p =+   fraction =<< add d p++{- |+both increment and phase must be non-negative+-}+incPhase ::+   (Fraction a) =>+   a -> a -> CodeGenFunction r a+incPhase d p =+   signedFraction =<< add d p+++class Comparison a where+   type CmpResult a+   cmp :: LLVM.CmpPredicate -> a -> a -> CodeGenFunction r (CmpResult a)++instance (LLVM.CmpRet a) => Comparison (Value a) where+   type CmpResult (Value a) = Value (LLVM.CmpResult a)+   cmp = LLVM.cmp+++class (Comparison a) => FloatingComparison a where+   fcmp :: LLVM.FPPredicate -> a -> a -> CodeGenFunction r (CmpResult a)++instance (IsFloating a, LLVM.CmpRet a) => FloatingComparison (Value a) where+   fcmp = LLVM.fcmp++++class Logic a where+   and :: a -> a -> CodeGenFunction r a+   or :: a -> a -> CodeGenFunction r a+   xor :: a -> a -> CodeGenFunction r a+   inv :: a -> CodeGenFunction r a++instance (LLVM.IsInteger a) => Logic (Value a) where+   and = LLVM.and+   or = LLVM.or+   xor = LLVM.xor+   inv = LLVM.inv++++class Field a => Algebraic a where+   sqrt :: a -> CodeGenFunction r a++instance (IsFloating a) => Algebraic (Value a) where+   sqrt = Intrinsic.call1 "sqrt"+++class Algebraic a => Transcendental a where+   pi :: CodeGenFunction r a+   sin, cos, exp, log :: a -> CodeGenFunction r a+   pow :: a -> a -> CodeGenFunction r a++instance (IsFloating a, SoV.TranscendentalConstant a) => Transcendental (Value a) where+   pi = return $ value SoV.constPi+   sin = Intrinsic.call1 "sin"+   cos = Intrinsic.call1 "cos"+   exp = Intrinsic.call1 "exp"+   log = Intrinsic.call1 "log"+   pow = Intrinsic.call2 "pow"+++exp2 :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+exp2 = Intrinsic.call1 "exp2"++log2 :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+log2 = Intrinsic.call1 "log2"++log10 :: (IsFloating a) => Value a -> CodeGenFunction r (Value a)+log10 = Intrinsic.call1 "log10"
+ src/LLVM/Extra/Array.hs view
@@ -0,0 +1,72 @@+module LLVM.Extra.Array (+   size,+   assemble,+   extractAll,+   map,+   ) where++import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, Array, CodeGenFunction, )++import qualified Type.Data.Num.Decimal as TypeNum+import Control.Monad.HT ((<=<), )+import Control.Monad (foldM, )++import qualified Data.List as List++import Data.Word (Word32, )++import Prelude hiding+          (Real, truncate, floor, round,+           map, zipWith, iterate, replicate, reverse, concat, sum, )+++-- * target independent functions++size ::+   (TypeNum.Natural n) =>+   Value (Array n a) -> Int+size =+   let sz :: (TypeNum.Natural n) => TypeNum.Singleton n -> Value (Array n a) -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton++{- |+construct an array out of single elements++You must assert that the length of the list matches the array size.++This can be considered the inverse of 'extractAll'.+-}+assemble ::+   (TypeNum.Natural n, LLVM.IsSized a) =>+   [Value a] -> CodeGenFunction r (Value (Array n a))+assemble =+   foldM (\v (k,x) -> LLVM.insertvalue v x (k::Word32)) Tuple.undef .+   List.zip [0..]++{- |+provide the elements of an array as a list of individual virtual registers++This can be considered the inverse of 'assemble'.+-}+extractAll ::+   (TypeNum.Natural n, LLVM.IsSized a) =>+   Value (Array n a) -> LLVM.CodeGenFunction r [Value a]+extractAll x =+   mapM+      (LLVM.extractvalue x)+      (take (size x) [(0::Word32)..])++{- |+The loop is unrolled,+since 'LLVM.insertvalue' and 'LLVM.extractvalue' expect constant indices.+-}+map ::+   (TypeNum.Natural n, LLVM.IsSized a, LLVM.IsSized b) =>+   (Value a -> CodeGenFunction r (Value b)) ->+   (Value (Array n a) -> CodeGenFunction r (Value (Array n b)))+map f =+   assemble <=< mapM f <=< extractAll
+ src/LLVM/Extra/Control.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Useful control structures additionally to those in "LLVM.Util.Loop".+-}+module LLVM.Extra.Control (+   arrayLoop,+   arrayLoop2,+   arrayLoopWithExit,+   arrayLoop2WithExit,+   fixedLengthLoop,+   whileLoop,+   whileLoopShared,+   loopWithExit,+   ifThenElse,+   ifThen,+   Select(select),+   selectTraversable,+   ifThenSelect,+   ret,+   retVoid,+   ) where++import qualified LLVM.Extra.ArithmeticPrivate as A+import qualified LLVM.Extra.TuplePrivate as Tuple+import LLVM.Extra.ArithmeticPrivate (cmp, sub, dec, advanceArrayElementPtr)++import qualified LLVM.Core as LLVM+import LLVM.Core+   (getCurrentBasicBlock, newBasicBlock, defineBasicBlock,+    br, condBr,+    Value, value, valueOf,+    phi, addPhiInputs,+    CmpPredicate(CmpGT), CmpRet,+    IsInteger, IsType, IsConst, IsPrimitive,+    CodeGenFunction,+    CodeGenModule, newModule, defineModule, writeBitcodeToFile, )++import qualified Control.Applicative as App+import qualified Data.Traversable as Trav+import Control.Monad (liftM3, liftM2, )++import Data.Tuple.HT (mapSnd, )++++-- * control structures++{-+I had to export Tuple.Phi's methods in llvm-0.6.8+in order to be able to implement this function.+-}+arrayLoop ::+   (Tuple.Phi a, IsType b,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr b) -> a ->+   (Value (LLVM.Ptr b) -> a -> CodeGenFunction r a) ->+   CodeGenFunction r a+arrayLoop len ptr start loopBody =+   fmap snd $+   fixedLengthLoop len (ptr, start) $ \(p,s) ->+      liftM2 (,)+         (advanceArrayElementPtr p)+         (loopBody p s)++arrayLoop2 ::+   (Tuple.Phi s, IsType a, IsType b,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop2 len ptrA ptrB start loopBody =+   fmap snd $+   arrayLoop len ptrA (ptrB,start)+      (\pa (pb,s) ->+         liftM2 (,)+            (advanceArrayElementPtr pb)+            (loopBody pa pb s))+++arrayLoopWithExit ::+   (Tuple.Phi s, IsType a,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> s ->+   (Value (LLVM.Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->+   CodeGenFunction r (Value i, s)+arrayLoopWithExit len ptr start loopBody = do+   ((_, vars), (i,_)) <-+      whileLoopShared ((valueOf True, start), (len, ptr)) $ \((b,v0), (i,p)) ->+         (A.and b =<< cmp CmpGT i (value LLVM.zero),+          do bv1 <- loopBody p v0+             ip1 <-+                ifThen (fst bv1) (i,p) $+                   liftM2 (,)+                      (dec i)+                      (advanceArrayElementPtr p)+             return (bv1,ip1))+   pos <- sub len i+   return (pos, vars)+++{- |+An alternative to 'arrayLoopWithExit'+where I try to persuade LLVM to use x86's LOOP instruction.+Unfortunately it becomes even worse.+LLVM developers say that x86 LOOP is actually slower+than manual decrement, zero test and conditional branch.+-}+_arrayLoopWithExitDecLoop ::+   (Tuple.Phi a, IsType b,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr b) -> a ->+   (Value (LLVM.Ptr b) -> a -> CodeGenFunction r (Value Bool, a)) ->+   CodeGenFunction r (Value i, a)+_arrayLoopWithExitDecLoop len ptr start loopBody = do+   top <- getCurrentBasicBlock+   checkEnd <- newBasicBlock+   loop <- newBasicBlock+   next <- newBasicBlock+   exit <- newBasicBlock++   {- unfortunately, t0 is not just stored as processor flag+      but is written to a register and then tested again in checkEnd -}+   t0 <- cmp CmpGT len (value LLVM.zero)+   br checkEnd++   defineBasicBlock checkEnd+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- Tuple.phi top start+   t <- phi [(t0, top)]+   condBr t loop exit++   defineBasicBlock loop++   (cont, vars') <- loopBody p vars+   Tuple.addPhi next vars vars'+   condBr cont next exit++   defineBasicBlock next+   p' <- advanceArrayElementPtr p+   i' <- dec i+   t' <- cmp CmpGT i' (value LLVM.zero)++   addPhiInputs i [(i', next)]+   addPhiInputs p [(p', next)]+   addPhiInputs t [(t', next)]+   br checkEnd++   defineBasicBlock exit+   pos <- sub len i+   return (pos, vars)+++arrayLoop2WithExit ::+   (Tuple.Phi s, IsType a, IsType b,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s -> CodeGenFunction r (Value Bool, s)) ->+   CodeGenFunction r (Value i, s)+arrayLoop2WithExit len ptrA ptrB start loopBody =+   fmap (mapSnd snd) $+   arrayLoopWithExit len ptrA (ptrB,start)+      (\ptrAi (ptrB0,s0) -> do+         (cont, s1) <- loopBody ptrAi ptrB0 s0+         ptrB1 <- advanceArrayElementPtr ptrB0+         return (cont, (ptrB1,s1)))+++fixedLengthLoop ::+   (Tuple.Phi s,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> s ->+   (s -> CodeGenFunction r s) ->+   CodeGenFunction r s+fixedLengthLoop len start loopBody =+   fmap snd $+   whileLoopShared (len,start) $ \(i,s) ->+      (cmp LLVM.CmpGT i (value LLVM.zero),+       liftM2 (,) (dec i) (loopBody s))+++whileLoop, _whileLoop ::+   Tuple.Phi a =>+   a ->+   (a -> CodeGenFunction r (Value Bool)) ->+   (a -> CodeGenFunction r a) ->+   CodeGenFunction r a+whileLoop start check body =+   loopWithExit start+      (\a -> fmap (flip (,) a) $ check a)+      body++_whileLoop start check body = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   cont <- newBasicBlock+   exit <- newBasicBlock+   br loop++   defineBasicBlock loop+   state <- Tuple.phi top start+   b <- check state+   condBr b cont exit+   defineBasicBlock cont+   res <- body state+   cont' <- getCurrentBasicBlock+   Tuple.addPhi cont' state res+   br loop++   defineBasicBlock exit+   return state+++{- |+This is a loop with a single point for exit from within the loop.+The @Bool@ value indicates whether the loop shall be continued.+-}+loopWithExit ::+   Tuple.Phi a =>+   a ->+   (a -> CodeGenFunction r (Value Bool, b)) ->+   (b -> CodeGenFunction r a) ->+   CodeGenFunction r b+loopWithExit start check body = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   cont <- newBasicBlock+   exit <- newBasicBlock+   br loop++   defineBasicBlock loop+   state <- Tuple.phi top start+   (contB,b) <- check state+   condBr contB cont exit+   defineBasicBlock cont+   a <- body b+   cont' <- getCurrentBasicBlock+   Tuple.addPhi cont' state a+   br loop++   defineBasicBlock exit+   return b+++{- |+This is a variant of 'whileLoop' that may be more convient,+because you only need one lambda expression+for both loop condition and loop body.+-}+whileLoopShared ::+   Tuple.Phi a =>+   a ->+   (a ->+      (CodeGenFunction r (Value Bool),+       CodeGenFunction r a)) ->+   CodeGenFunction r a+whileLoopShared start checkBody =+   whileLoop start+      (fst . checkBody)+      (snd . checkBody)++{- |+This construct starts new blocks,+so be prepared when continueing after an 'ifThenElse'.+-}+ifThenElse ::+   Tuple.Phi a =>+   Value Bool ->+   CodeGenFunction r a ->+   CodeGenFunction r a ->+   CodeGenFunction r a+ifThenElse cond thenCode elseCode = do+   thenBlock <- newBasicBlock+   elseBlock <- newBasicBlock+   mergeBlock <- newBasicBlock+   condBr cond thenBlock elseBlock++   defineBasicBlock thenBlock+   a0 <- thenCode+   thenBlock' <- getCurrentBasicBlock+   br mergeBlock++   defineBasicBlock elseBlock+   a1 <- elseCode+   elseBlock' <- getCurrentBasicBlock+   br mergeBlock++   defineBasicBlock mergeBlock+   a2 <- Tuple.phi thenBlock' a0+   Tuple.addPhi elseBlock' a2 a1+   return a2+++ifThen ::+   Tuple.Phi a =>+   Value Bool ->+   a ->+   CodeGenFunction r a ->+   CodeGenFunction r a+ifThen cond deflt thenCode = do+   defltBlock <- getCurrentBasicBlock+   thenBlock <- newBasicBlock+   mergeBlock <- newBasicBlock+   condBr cond thenBlock mergeBlock++   defineBasicBlock thenBlock+   a0 <- thenCode+   thenBlock' <- getCurrentBasicBlock+   br mergeBlock++   defineBasicBlock mergeBlock+   a1 <- Tuple.phi defltBlock deflt+   Tuple.addPhi thenBlock' a1 a0+   return a1+++class Tuple.Phi a => Select a where+   select :: Value Bool -> a -> a -> CodeGenFunction r a++instance (CmpRet a, IsPrimitive a) => Select (Value a) where+   select = LLVM.select++instance Select () where+   select _ () () = return ()++instance (Select a, Select b) => Select (a,b) where+   select cond (a0,b0) (a1,b1) =+      liftM2 (,)+         (select cond a0 a1)+         (select cond b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select cond (a0,b0,c0) (a1,b1,c1) =+      liftM3 (,,)+         (select cond a0 a1)+         (select cond b0 b1)+         (select cond c0 c1)++selectTraversable ::+   (Select a, Trav.Traversable f, App.Applicative f) =>+   Value Bool -> f a -> f a -> CodeGenFunction r (f a)+selectTraversable b x y =+   Trav.sequence (App.liftA2 (select b) x y)+++{- |+Branch-free variant of 'ifThen'+that is faster if the enclosed block is very simply,+say, if it contains at most two instructions.+It can only be used as alternative to 'ifThen'+if the enclosed block is free of side effects.+-}+ifThenSelect ::+   Select a =>+   Value Bool ->+   a ->+   CodeGenFunction r a ->+   CodeGenFunction r a+ifThenSelect cond deflt thenCode = do+   thenResult <- thenCode+   select cond thenResult deflt+++-- * return with better type inference++{- |+'ret' terminates a basic block which interferes badly+with other control structures in this module.+If you use the control structures then better use "LLVM.Extra.Function".+-}+ret :: Value a -> CodeGenFunction a ()+ret = LLVM.ret++retVoid :: CodeGenFunction () ()+retVoid = LLVM.ret ()+++-- * debugging++_emitCode :: FilePath -> CodeGenModule a -> IO ()+_emitCode fileName cgm = do+   m <- newModule+   _ <- defineModule m cgm+   writeBitcodeToFile fileName m
+ src/LLVM/Extra/Either.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TypeFamilies #-}+{- |+LLVM counterpart to 'Either' datatype.+-}+module LLVM.Extra.Either (+   Either.T(..),+   Either.run,+   Either.getIsLeft,+   Either.mapLeft,+   Either.mapRight,+   left,+   right,+   ) where++import qualified LLVM.Extra.EitherPrivate as Either+import qualified LLVM.Extra.Tuple as Tuple+++left :: (Tuple.Undefined b) => a -> Either.T a b+left = Either.left Tuple.undef++right :: (Tuple.Undefined a) => b -> Either.T a b+right = Either.right Tuple.undef
+ src/LLVM/Extra/EitherPrivate.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.EitherPrivate where++import qualified LLVM.Extra.TuplePrivate as Tuple+import LLVM.Extra.Control (ifThenElse, )++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, valueOf, CodeGenFunction, )++import Control.Monad (liftM3, )+++{- |+If @isRight@, then @fromLeft@ is an @undefTuple@.+If @not isRight@, then @fromRight@ is an @undefTuple@.+I would prefer a union type,+but it was temporarily removed in LLVM-2.8 and did not return since then.+-}+data T a b = Cons {isRight :: Value Bool, fromLeft :: a, fromRight :: b}+++instance+   (Tuple.Undefined a, Tuple.Undefined b) =>+      Tuple.Undefined (T a b) where+   undef = Cons Tuple.undef Tuple.undef Tuple.undef++instance (Tuple.Phi a, Tuple.Phi b) => Tuple.Phi (T a b) where+   phi bb (Cons r a b) =+      liftM3 Cons (Tuple.phi bb r) (Tuple.phi bb a) (Tuple.phi bb b)+   addPhi bb (Cons r0 a0 b0) (Cons r1 a1 b1) =+      Tuple.addPhi bb r0 r1 >> Tuple.addPhi bb a0 a1 >> Tuple.addPhi bb b0 b1+++{- |+counterpart to 'either'+-}+run ::+   (Tuple.Phi c) =>+   T a b ->+   (a -> CodeGenFunction r c) ->+   (b -> CodeGenFunction r c) ->+   CodeGenFunction r c+run (Cons r a b) fa fb =+   ifThenElse r (fb b) (fa a)+++mapLeft :: (a0 -> a1) -> T a0 b -> T a1 b+mapLeft f (Cons r a b) = Cons r (f a) b++mapRight :: (b0 -> b1) -> T a b0 -> T a b1+mapRight f (Cons r a b) = Cons r a (f b)+++getIsLeft :: T a b -> CodeGenFunction r (Value Bool)+getIsLeft (Cons r _ _) = LLVM.inv r++left :: b -> a -> T a b+left undef a =+   Cons {isRight = valueOf False, fromLeft = a, fromRight = undef}++right :: a -> b -> T a b+right undef b =+   Cons {isRight = valueOf True, fromLeft = undef, fromRight = b}
+ src/LLVM/Extra/FastMath.hs view
@@ -0,0 +1,533 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module LLVM.Extra.FastMath ( +   NoNaNs(NoNaNs),+   NoInfs(NoInfs),+   NoSignedZeros(NoSignedZeros),+   AllowReciprocal(AllowReciprocal),+   Fast(Fast),+   Flags(setFlags),++   Number(Number, deconsNumber),+   getNumber,+   nvNumber,+   nvDenumber,+   mvNumber,+   mvDenumber,++   NiceValue(setMultiValueFlags, setNiceValueFlags),+   attachNiceValueFlags,+   attachMultiValueFlags,+   liftNumberM,+   liftNumberM2,+   nvecNumber,+   nvecDenumber,+   mvecNumber,+   mvecDenumber,++   NiceVector(setMultiVectorFlags, setNiceVectorFlags),+   attachNiceVectorFlags,+   liftNiceVectorM,+   liftNiceVectorM2,+   attachMultiVectorFlags,+   liftMultiVectorM,+   liftMultiVectorM2,++   Tuple(setTupleFlags),+   Context(Context),+   attachTupleFlags,+   liftContext,+   liftContext2,+   ) where++import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as Nice+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Core as LLVM+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 NiceValue a => Nice.C (Number flags a) where+   type Repr (Number flags a) = Nice.Repr a+   cons = nvNumber . Nice.cons . deconsNumber+   undef = nvNumber Nice.undef+   zero = nvNumber Nice.zero+   phi bb = fmap nvNumber . Nice.phi bb . nvDenumber+   addPhi bb a b = Nice.addPhi bb (nvDenumber a) (nvDenumber b)++nvNumber :: Nice.T a -> Nice.T (Number flags a)+nvNumber (Nice.Cons a) = Nice.Cons a++nvDenumber :: Nice.T (Number flags a) -> Nice.T a+nvDenumber (Nice.Cons a) = Nice.Cons a++{-# DEPRECATED mvNumber "Use nvNumber instead" #-}+mvNumber :: Nice.T a -> Nice.T (Number flags a)+mvNumber (Nice.Cons a) = Nice.Cons a++{-# DEPRECATED mvDenumber "Use nvDenumber instead" #-}+mvDenumber :: Nice.T (Number flags a) -> Nice.T a+mvDenumber (Nice.Cons a) = Nice.Cons a+++{-# DEPRECATED setMultiValueFlags "use setNiceValueFlags instead" #-}+class Nice.C a => NiceValue a where+   {-# MINIMAL setNiceValueFlags | setMultiValueFlags #-}+   setNiceValueFlags, setMultiValueFlags ::+      (Flags flags) =>+      Proxy flags -> Bool -> Nice.T (Number flags a) ->+      LLVM.CodeGenFunction r ()+   setNiceValueFlags = setMultiValueFlags+   setMultiValueFlags = setNiceValueFlags++instance NiceValue Float where+   setNiceValueFlags p b (Nice.Cons a) = setFlags p b a++instance NiceValue Double where+   setNiceValueFlags p b (Nice.Cons a) = setFlags p b a+++type Id a = a -> a++{-# DEPRECATED attachMultiValueFlags "Use attachNiceValueFlags instead." #-}+attachMultiValueFlags, attachNiceValueFlags ::+   (Flags flags, NiceValue a) =>+   Id (LLVM.CodeGenFunction r (Nice.T (Number flags a)))+attachMultiValueFlags = attachNiceValueFlags+attachNiceValueFlags act = do+   mv <- act+   setMultiValueFlags Proxy True mv+   return mv++liftNumberM ::+   (m ~ LLVM.CodeGenFunction r, Flags flags, NiceValue b) =>+   (Nice.T a -> m (Nice.T b)) ->+   Nice.T (Number flags a) -> m (Nice.T (Number flags b))+liftNumberM f =+   attachMultiValueFlags . Monad.lift nvNumber . f . nvDenumber++liftNumberM2 ::+   (m ~ LLVM.CodeGenFunction r, Flags flags, NiceValue c) =>+   (Nice.T a -> Nice.T b -> m (Nice.T c)) ->+   Nice.T (Number flags a) -> Nice.T (Number flags b) ->+   m (Nice.T (Number flags c))+liftNumberM2 f a b =+   attachMultiValueFlags $ Monad.lift nvNumber $ f (nvDenumber a) (nvDenumber b)+++instance (Flags flags, Nice.Compose a) => Nice.Compose (Number flags a) where+   type Composed (Number flags a) = Number flags (Nice.Composed a)+   compose = nvNumber . Nice.compose . deconsNumber++instance+      (Flags flags, Nice.Decompose pa) => Nice.Decompose (Number flags pa) where+   decompose (Number p) = Number . Nice.decompose p . nvDenumber++type instance+   Nice.Decomposed f (Number flags pa) = Number flags (Nice.Decomposed f pa)+type instance+   Nice.PatternTuple (Number flags pa) = Number flags (Nice.PatternTuple pa)+++instance+   (Flags flags, NiceValue a, Nice.IntegerConstant a) =>+      Nice.IntegerConstant (Number flags a) where+   fromInteger' = nvNumber . Nice.fromInteger'++instance+   (Flags flags, NiceValue a, Nice.RationalConstant a) =>+      Nice.RationalConstant (Number flags a) where+   fromRational' = nvNumber . Nice.fromRational'++instance+   (Flags flags, NiceValue a, Nice.Additive a) =>+      Nice.Additive (Number flags a) where+   add = liftNumberM2 Nice.add+   sub = liftNumberM2 Nice.sub+   neg = liftNumberM Nice.neg++instance+   (Flags flags, NiceValue a, Nice.PseudoRing a) =>+      Nice.PseudoRing (Number flags a) where+   mul = liftNumberM2 Nice.mul++instance+   (Flags flags, NiceValue a, Nice.Field a) =>+      Nice.Field (Number flags a) where+   fdiv = liftNumberM2 Nice.fdiv++type instance Nice.Scalar (Number flags a) = Number flags (Nice.Scalar a)++instance+   (Flags flags, NiceValue a, a ~ Nice.Scalar v,+    NiceValue v, Nice.PseudoModule v) =>+      Nice.PseudoModule (Number flags v) where+   scale = liftNumberM2 Nice.scale++instance+   (Flags flags, NiceValue a, Nice.Real a) =>+      Nice.Real (Number flags a) where+   min = liftNumberM2 Nice.min+   max = liftNumberM2 Nice.max+   abs = liftNumberM Nice.abs+   signum = liftNumberM Nice.signum++instance+   (Flags flags, NiceValue a, Nice.Fraction a) =>+      Nice.Fraction (Number flags a) where+   truncate = liftNumberM Nice.truncate+   fraction = liftNumberM Nice.fraction++instance+   (Flags flags, NiceValue a, Nice.Algebraic a) =>+      Nice.Algebraic (Number flags a) where+   sqrt = liftNumberM Nice.sqrt++instance+   (Flags flags, NiceValue a, Nice.Transcendental a) =>+      Nice.Transcendental (Number flags a) where+   pi = fmap nvNumber Nice.pi+   sin = liftNumberM Nice.sin+   cos = liftNumberM Nice.cos+   exp = liftNumberM Nice.exp+   log = liftNumberM Nice.log+   pow = liftNumberM2 Nice.pow++instance+   (Flags flags, NiceValue a, Nice.Select a) =>+      Nice.Select (Number flags a) where+   select = liftNumberM2 . Nice.select++instance+   (Flags flags, NiceValue a, Nice.Comparison a) =>+      Nice.Comparison (Number flags a) where+   cmp p a b = Nice.cmp p (nvDenumber a) (nvDenumber b)++instance+   (Flags flags, NiceValue a, Nice.FloatingComparison a) =>+      Nice.FloatingComparison (Number flags a) where+   fcmp p a b = Nice.fcmp p (nvDenumber a) (nvDenumber b)++++nvecNumber :: NiceVector.T n a -> NiceVector.T n (Number flags a)+nvecNumber (NiceVector.Cons v) = NiceVector.Cons v++nvecDenumber :: NiceVector.T n (Number flags a) -> NiceVector.T n a+nvecDenumber (NiceVector.Cons v) = NiceVector.Cons v++{-# DEPRECATED mvecNumber "Use nvecNumber instead" #-}+mvecNumber :: NiceVector.T n a -> NiceVector.T n (Number flags a)+mvecNumber (NiceVector.Cons v) = NiceVector.Cons v++{-# DEPRECATED mvecDenumber "Use nvecDenumber instead" #-}+mvecDenumber :: NiceVector.T n (Number flags a) -> NiceVector.T n a+mvecDenumber (NiceVector.Cons v) = NiceVector.Cons v++{-# DEPRECATED setMultiVectorFlags "use setNiceVectorFlags instead" #-}+class (NiceValue a, NiceVector.C a) => NiceVector a where+   {-# MINIMAL setNiceVectorFlags | setMultiVectorFlags #-}+   setNiceVectorFlags, setMultiVectorFlags ::+      (Flags flags, LLVM.Positive n) =>+      Proxy flags -> Bool ->+      NiceVector.T n (Number flags a) -> LLVM.CodeGenFunction r ()+   setNiceVectorFlags = setMultiVectorFlags+   setMultiVectorFlags = setNiceVectorFlags++instance NiceVector Float where+   setMultiVectorFlags p b =+      setFlags p b . NiceVector.deconsPrim . nvecDenumber++instance NiceVector Double where+   setMultiVectorFlags p b =+      setFlags p b . NiceVector.deconsPrim . nvecDenumber++{-# DEPRECATED attachMultiVectorFlags "Use attachNiceVectorFlags instead." #-}+attachNiceVectorFlags, attachMultiVectorFlags ::+   (LLVM.Positive n, Flags flags, NiceVector a) =>+   Id (LLVM.CodeGenFunction r (NiceVector.T n (Number flags a)))+attachMultiVectorFlags = attachNiceVectorFlags+attachNiceVectorFlags act = do+   mv <- act+   setMultiVectorFlags Proxy True mv+   return mv++{-# DEPRECATED liftMultiVectorM "Use liftNiceVectorM instead." #-}+liftNiceVectorM, liftMultiVectorM ::+   (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, NiceVector b) =>+   (NiceVector.T n a -> m (NiceVector.T n b)) ->+   NiceVector.T n (Number flags a) -> m (NiceVector.T n (Number flags b))+liftMultiVectorM = liftNiceVectorM+liftNiceVectorM f =+   attachMultiVectorFlags . Monad.lift nvecNumber . f . nvecDenumber++{-# DEPRECATED liftMultiVectorM2 "Use liftNiceVectorM2 instead." #-}+liftNiceVectorM2, liftMultiVectorM2 ::+   (m ~ LLVM.CodeGenFunction r, LLVM.Positive n, Flags flags, NiceVector c) =>+   (NiceVector.T n a -> NiceVector.T n b -> m (NiceVector.T n c)) ->+   NiceVector.T n (Number flags a) -> NiceVector.T n (Number flags b) ->+   m (NiceVector.T n (Number flags c))+liftMultiVectorM2 = liftNiceVectorM2+liftNiceVectorM2 f a b =+   attachMultiVectorFlags $+      Monad.lift nvecNumber $ f (nvecDenumber a) (nvecDenumber b)++instance (Flags flags, NiceVector a) => NiceVector.C (Number flags a) where+   type Repr n (Number flags a) = NiceVector.Repr n a+   cons = nvecNumber . NiceVector.cons . fmap deconsNumber+   undef = nvecNumber NiceVector.undef+   zero = nvecNumber NiceVector.zero+   phi bb = fmap nvecNumber . NiceVector.phi bb . nvecDenumber+   addPhi bb a b = NiceVector.addPhi bb (nvecDenumber a) (nvecDenumber b)+   shuffle ks a b =+      fmap nvecNumber $ NiceVector.shuffle ks (nvecDenumber a) (nvecDenumber b)+   extract k = fmap nvNumber . NiceVector.extract k . nvecDenumber+   insert k x =+      fmap nvecNumber . NiceVector.insert k (nvDenumber x) . nvecDenumber++instance+   (Flags flags, NiceVector a, NiceVector.IntegerConstant a) =>+      NiceVector.IntegerConstant (Number flags a) where+   fromInteger' = nvecNumber . NiceVector.fromInteger'++instance+   (Flags flags, NiceVector a, NiceVector.RationalConstant a) =>+      NiceVector.RationalConstant (Number flags a) where+   fromRational' = nvecNumber . NiceVector.fromRational'++instance+   (Flags flags, NiceVector a, NiceVector.Additive a) =>+      NiceVector.Additive (Number flags a) where+   add = liftNiceVectorM2 NiceVector.add+   sub = liftNiceVectorM2 NiceVector.sub+   neg = liftNiceVectorM NiceVector.neg++instance+   (Flags flags, NiceVector a, NiceVector.PseudoRing a) =>+      NiceVector.PseudoRing (Number flags a) where+   mul = liftNiceVectorM2 NiceVector.mul++instance+   (Flags flags, NiceVector a, NiceVector.Field a) =>+      NiceVector.Field (Number flags a) where+   fdiv = liftNiceVectorM2 NiceVector.fdiv+++{-+type instance NiceValue.Scalar (Number flags a) =+      Number flags (NiceValue.Scalar a)+instance+   (Flags flags, NiceVector a, NiceVector.PseudoModule a) =>+      NiceVector.PseudoModule (Number flags a) where+   scale = liftNiceVectorM2 NiceVector.mul+-}++instance+   (Flags flags, NiceVector a, NiceVector.Real a) =>+      NiceVector.Real (Number flags a) where+   min = liftNiceVectorM2 NiceVector.min+   max = liftNiceVectorM2 NiceVector.max+   abs = liftNiceVectorM NiceVector.abs+   signum = liftNiceVectorM NiceVector.signum++instance+   (Flags flags, NiceVector a, NiceVector.Fraction a) =>+      NiceVector.Fraction (Number flags a) where+   truncate = liftNiceVectorM NiceVector.truncate+   fraction = liftNiceVectorM NiceVector.fraction++instance+   (Flags flags, NiceVector a, NiceVector.Algebraic a) =>+      NiceVector.Algebraic (Number flags a) where+   sqrt = liftNiceVectorM NiceVector.sqrt++instance+   (Flags flags, NiceVector a, NiceVector.Transcendental a) =>+      NiceVector.Transcendental (Number flags a) where+   pi = fmap nvecNumber NiceVector.pi+   sin = liftNiceVectorM NiceVector.sin+   cos = liftNiceVectorM NiceVector.cos+   exp = liftNiceVectorM NiceVector.exp+   log = liftNiceVectorM NiceVector.log+   pow = liftNiceVectorM2 NiceVector.pow++instance+   (Flags flags, NiceVector a, NiceVector.Select a) =>+      NiceVector.Select (Number flags a) where+   select = liftNiceVectorM2 . NiceVector.select++instance+   (Flags flags, NiceVector a, NiceVector.Comparison a) =>+      NiceVector.Comparison (Number flags a) where+   cmp p a b = NiceVector.cmp p (nvecDenumber a) (nvecDenumber b)++instance+   (Flags flags, NiceVector a, NiceVector.FloatingComparison a) =>+      NiceVector.FloatingComparison (Number flags a) where+   fcmp p a b = NiceVector.fcmp p (nvecDenumber a) (nvecDenumber 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, Tuple.Zero a, Tuple a) =>+      Tuple.Zero (Context flags a) where+   zero = Context Tuple.zero++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/Function.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Alternative to 'LLVM.Core.defineFunction'+that creates the final 'LLVM.Core.ret' instruction for you.+-}+module LLVM.Extra.Function (+   C,+   CodeGen,+   define,+   create,+   createNamed,+   Return, Result, ret,+   ) where++import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM++import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (Ptr, FunPtr)++import Control.Applicative ((<*>))++import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64, Word)+++define ::+   (C f) => LLVM.Function f -> CodeGen f -> LLVM.CodeGenModule ()+define fn body =+   LLVM.defineFunction fn (addRet (proxyFromElement2 fn) body)++proxyFromElement2 :: f (g a) -> LP.Proxy a+proxyFromElement2 _ = LP.Proxy+++create ::+   (C f) =>+   LLVM.Linkage -> CodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+create linkage body = do+   f <- LLVM.newFunction linkage+   define f body+   return f++createNamed ::+   (C f) =>+   LLVM.Linkage -> String -> CodeGen f -> LLVM.CodeGenModule (LLVM.Function f)+createNamed linkage name body = do+   f <- LLVM.newNamedFunction linkage name+   define f body+   return f+++{- |+> CodeGen (a->b->...-> IO z) =+>    Value a -> Value b -> ... CodeGenFunction r (Value z)@.+-}+class LLVM.FunctionArgs f => C f where+   type CodeGen f+   addRet :: LP.Proxy f -> CodeGen f -> LLVM.FunctionCodeGen f++instance (C b, LLVM.IsFirstClass a) => C (a -> b) where+   type CodeGen (a -> b) = LLVM.Value a -> CodeGen b+   addRet proxy f a = addRet (proxy<*>LP.Proxy) (f a)++instance Return a => C (IO a) where+   type CodeGen (IO a) = LLVM.CodeGenFunction a (Result a)+   addRet LP.Proxy code = code >>= ret+++class (LLVM.IsFirstClass a) => Return a where+   type Result a+   ret :: Result a -> LLVM.CodeGenFunction a ()+instance Return () where+   type Result () = ()+   ret = LLVM.ret++instance Return Bool where+   type Result Bool = LLVM.Value Bool; ret = LLVM.ret+instance Return Int where+   type Result Int = LLVM.Value Int; ret = LLVM.ret+instance Return Int8 where+   type Result Int8 = LLVM.Value Int8; ret = LLVM.ret+instance Return Int16 where+   type Result Int16 = LLVM.Value Int16; ret = LLVM.ret+instance Return Int32 where+   type Result Int32 = LLVM.Value Int32; ret = LLVM.ret+instance Return Int64 where+   type Result Int64 = LLVM.Value Int64; ret = LLVM.ret+instance Return Word where+   type Result Word = LLVM.Value Word; ret = LLVM.ret+instance Return Word8 where+   type Result Word8 = LLVM.Value Word8; ret = LLVM.ret+instance Return Word16 where+   type Result Word16 = LLVM.Value Word16; ret = LLVM.ret+instance Return Word32 where+   type Result Word32 = LLVM.Value Word32; ret = LLVM.ret+instance Return Word64 where+   type Result Word64 = LLVM.Value Word64; ret = LLVM.ret++instance Return Float where+   type Result Float = LLVM.Value Float; ret = LLVM.ret+instance Return Double where+   type Result Double = LLVM.Value Double; ret = LLVM.ret++instance Return (Ptr a) where+   type Result (Ptr a) = LLVM.Value (Ptr a); ret = LLVM.ret+instance (LLVM.IsType a) => Return (LLVM.Ptr a) where+   type Result (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a); ret = LLVM.ret+instance (LLVM.IsFunction a) => Return (FunPtr a) where+   type Result (FunPtr a) = LLVM.Value (FunPtr a); ret = LLVM.ret+instance Return (StablePtr a) where+   type Result (StablePtr a) = LLVM.Value (StablePtr a); ret = LLVM.ret
+ src/LLVM/Extra/Iterator.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Iterator (+   T,+   -- * consumers+   mapM_,+   mapState_,+   mapStateM_,+   mapWhileState_,+   -- * producers+   empty,+   singleton,+   cons,+   iterate,+   countDown,+   arrayPtrs,+   storableArrayPtrs,+   -- * modifiers+   mapM,+   mapMaybe,+   catMaybes,+   takeWhileJust,+   takeWhile,+   cartesian,+   take,+   -- * application examples+   fixedLengthLoop,+   arrayLoop,+   arrayLoopWithExit,+   arrayLoop2,+   ) where++import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe++import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.ArithmeticPrivate as A+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Control as C+import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, Value, value, valueOf,+    CmpRet, IsInteger, IsType, IsConst, IsPrimitive)++import Foreign.Ptr (Ptr, )++import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad (void, (<=<), )+import Control.Applicative (Applicative, liftA2, (<$>), (<$), )++import Data.Tuple.HT (mapFst, mapSnd, )++import Prelude2010 hiding (iterate, takeWhile, take, mapM, mapM_)+import Prelude ()+++{- |+Simulates a non-strict list.+-}+data T r a =+   forall s. (Tuple.Phi s, Tuple.Undefined s) =>+   Cons s (forall z. (Tuple.Phi z) => s -> MaybeCont.T r z (a,s))++mapM_ :: (a -> CodeGenFunction r ()) -> T r a -> CodeGenFunction r ()+mapM_ f (Cons s next) =+   void $+   C.loopWithExit s+      (\s0 ->+         MaybeCont.resolve (next s0)+            (return (valueOf False, s0))+            (\(a,s1) -> (valueOf True, s1) <$ f a))+      return++mapState_ ::+   (Tuple.Phi t) =>+   (a -> t -> CodeGenFunction r t) ->+   T r a -> t -> CodeGenFunction r t+mapState_ f (Cons s next) t =+   snd <$>+   C.loopWithExit (s,t)+      (\(s0,t0) ->+         MaybeCont.resolve (next s0)+            (return (valueOf False, (s0,t0)))+            (\(a,s1) -> (\t1 -> (valueOf True, (s1,t1))) <$> f a t0))+      return++mapStateM_ ::+   (Tuple.Phi t) =>+   (a -> MS.StateT t (CodeGenFunction r) ()) ->+   T r a -> MS.StateT t (CodeGenFunction r) ()+mapStateM_ f xs =+   MS.StateT $ \t ->+      (,) () <$> mapState_ (\a t0 -> snd <$> MS.runStateT (f a) t0) xs t+++mapWhileState_ ::+   (Tuple.Phi t) =>+   (a -> t -> CodeGenFunction r (Value Bool, t)) ->+   T r a -> t -> CodeGenFunction r t+mapWhileState_ f (Cons s next) t =+   snd <$>+   C.loopWithExit (s,t)+      (\(s0,t0) ->+         MaybeCont.resolve (next s0)+            (return (valueOf False, (s0,t0)))+            (\(a,s1) -> (\(b,t1) -> (b, (s1,t1))) <$> f a t0))+      return+++empty :: T r a+empty = Cons () (\() -> MaybeCont.nothing)++singleton :: a -> T r a+singleton a =+   Cons+      (valueOf True)+      (\running -> MaybeCont.guard running >> return (a, valueOf False))++cons :: (Tuple.Phi a, Tuple.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)++{- |+@ZipList@ semantics+-}+instance Applicative (T r) where+   pure a = Cons () (\() -> return (a,()))+   Cons fs fnext <*> Cons as anext =+      Cons (fs,as)+         (\(fs0,as0) -> do+            (f,fs1) <- fnext fs0+            (a,as1) <- anext as0+            return (f a, (fs1,as1)))+++{-+On the one hand,+I did not want to name it @map@ because it differs from @fmap@.+On the other hand, @mapM@ does not fit very well+because the result is not in the CodeGenFunction monad.+-}+mapM :: (a -> CodeGenFunction r b) -> T r a -> T r b+mapM f (Cons s next) = Cons s (MaybeCont.lift . FuncHT.mapFst f <=< next)++mapMaybe ::+   (Tuple.Phi b, Tuple.Undefined b) =>+   (a -> CodeGenFunction r (Maybe.T b)) -> T r a -> T r b+mapMaybe f = catMaybes . mapM f++catMaybes :: (Tuple.Phi a, Tuple.Undefined a) => T r (Maybe.T a) -> T r a+catMaybes (Cons s next) =+   Cons s+      (\s0 ->+         MaybeCont.fromMaybe $+         fmap (\(ma,s2) -> fmap (flip (,) s2) ma) $+         C.loopWithExit s0+            (\s1 ->+               MaybeCont.resolve (next s1)+                  (return (valueOf False, (Maybe.nothing, s1)))+                  (\(ma,s2) ->+                     Maybe.run ma+                        (return (valueOf True, (Maybe.nothing, s2)))+                        (\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 = takeWhileJust . mapM (\a -> flip Maybe.fromBool a <$> p a)++{- |+Attention:+This always performs one function call more than necessary.+I.e. if 'f' reads from or writes to memory+make sure that accessing one more pointer is legal.+-}+iterate ::+   (Tuple.Phi a, Tuple.Undefined a) => (a -> CodeGenFunction r a) -> a -> T r a+iterate f a = Cons a (\a0 -> MaybeCont.lift $ fmap ((,) a0) $ f a0)+++cartesianAux ::+   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined a, Tuple.Undefined b) =>+   T r a -> T r b -> T r (Maybe.T (a,b))+cartesianAux (Cons sa nextA) (Cons sb nextB) =+   Cons (Maybe.nothing,sa,sb)+      (\(ma0,sa0,sb0) -> do+         (a1,sa1) <-+            MaybeCont.alternative+               (MaybeCont.fromMaybe $ return $ fmap (flip (,) sa0) ma0)+               (nextA sa0)+         MaybeCont.lift $+            MaybeCont.resolve (nextB sb0)+               (return (Maybe.nothing,(Maybe.nothing,sa1,sb)))+               (\(b1,sb1) ->+                  return (Maybe.just (a1,b1), (Maybe.just a1, sa1, sb1))))++cartesian ::+   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined a, Tuple.Undefined b) =>+   T r a -> T r b -> T r (a,b)+cartesian as bs = catMaybes $ cartesianAux as bs++countDown ::+   (Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> T r (Value i)+countDown len =+   takeWhile (A.cmp LLVM.CmpLT (value LLVM.zero)) $ iterate A.dec len++take ::+   (Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> T r a -> T r a+take len xs = liftA2 const xs (countDown len)++arrayPtrs :: (IsType a) => Value (LLVM.Ptr a) -> T r (Value (LLVM.Ptr a))+arrayPtrs = iterate A.advanceArrayElementPtr++storableArrayPtrs :: (Storable.C a) => Value (Ptr a) -> T r (Value (Ptr a))+storableArrayPtrs = iterate Storable.incrementPtr+++-- * examples++fixedLengthLoop ::+   (Tuple.Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> s ->+   (s -> CodeGenFunction r s) ->+   CodeGenFunction r s+fixedLengthLoop len start loopBody =+   mapState_ (const loopBody) (countDown len) start++arrayLoop ::+   (Tuple.Phi a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr b) -> a ->+   (Value (LLVM.Ptr b) -> a -> CodeGenFunction r a) ->+   CodeGenFunction r a+arrayLoop len ptr start loopBody =+   mapState_ loopBody (take len $ arrayPtrs ptr) start++arrayLoopWithExit ::+   (Tuple.Phi s, IsType a, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> s ->+   (Value (LLVM.Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->+   CodeGenFunction r (Value i, s)+arrayLoopWithExit len ptr0 start loopBody = do+   (i, end) <-+      mapWhileState_+         (\(i,ptr) (_i,s) -> mapSnd ((,) i) <$> loopBody ptr s)+         (liftA2 (,) (countDown len) (arrayPtrs ptr0))+         (len,start)+   pos <- A.sub len i+   return (pos, end)++arrayLoop2 ::+   (Tuple.Phi s, IsType a, IsType b, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop2 len ptrA ptrB start loopBody =+   mapState_ (uncurry loopBody)+      (take len $ liftA2 (,) (arrayPtrs ptrA) (arrayPtrs ptrB)) start
+ src/LLVM/Extra/Marshal.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Transfer values between Haskell and JIT generated code+in an LLVM-compatible format.+E.g. 'Bool' is stored as 'i1' and occupies a byte,+@'Vector' n 'Bool'@ is stored as a bit vector,+@'Vector' n 'Word8'@ is stored in an order depending on machine endianess,+and Haskell tuples are stored as LLVM structs.+-}+module LLVM.Extra.Marshal (+   C(..),+   Struct,+   peek,+   poke,++   VectorStruct,+   Vector(..),++   with,+   EE.alloca,+   ) where++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Functor.HT as FuncHT+import Control.Applicative (liftA2, liftA3, (<$>))++import Foreign.Storable (Storable)+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (FunPtr, Ptr)++import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)++++peek ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> IO a+peek ptr = unpack <$> EE.peek ptr++poke ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO ()+poke ptr = EE.poke ptr . pack+++type Struct a = Memory.Struct (Tuple.ValueOf a)++class+   (Tuple.Value a, Memory.C (Tuple.ValueOf a),+    EE.Marshal (Struct a), LLVM.IsSized (Struct a)) =>+      C a where+   pack :: a -> Struct a+   unpack :: Struct a -> a++instance C Bool   where pack = id; unpack = id+instance C Float  where pack = id; unpack = id+instance C Double where pack = id; unpack = id+instance C Word   where pack = id; unpack = id+instance C Word8  where pack = id; unpack = id+instance C Word16 where pack = id; unpack = id+instance C Word32 where pack = id; unpack = id+instance C Word64 where pack = id; unpack = id+instance C Int    where pack = id; unpack = id+instance C Int8   where pack = id; unpack = id+instance C Int16  where pack = id; unpack = id+instance C Int32  where pack = id; unpack = id+instance C Int64  where pack = id; unpack = id++instance (Storable a)        => C (Ptr a)       where pack = id; unpack = id+instance (LLVM.IsType a)     => C (LLVM.Ptr a)  where pack = id; unpack = id+instance (LLVM.IsFunction a) => C (FunPtr a)    where pack = id; unpack = id+instance                        C (StablePtr a) where pack = id; unpack = id++instance C () where+   pack = LLVM.Struct+   unpack (LLVM.Struct unit) = unit++instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), C a, C b) =>+      C (a,b) where+   pack (a,b) = LLVM.consStruct (pack a) (pack b)+   unpack = LLVM.uncurryStruct $ \a b -> (unpack a, unpack b)++instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b), LLVM.IsSized (Struct c),+    C a, C b, C c) =>+      C (a,b,c) where+   pack (a,b,c) = LLVM.consStruct (pack a) (pack b) (pack c)+   unpack = LLVM.uncurryStruct $ \a b c -> (unpack a, unpack b, unpack c)++instance+   (LLVM.IsSized (Struct a), LLVM.IsSized (Struct b),+    LLVM.IsSized (Struct c), LLVM.IsSized (Struct d),+    C a, C b, C c, C d) =>+      C (a,b,c,d) where+   pack (a,b,c,d) = LLVM.consStruct (pack a) (pack b) (pack c) (pack d)+   unpack =+      LLVM.uncurryStruct $ \a b c d -> (unpack a, unpack b, unpack c, unpack d)++++type VectorStruct n a = Memory.Struct (Tuple.VectorValueOf n a)++class+   (TypeNum.Positive n,+    Tuple.VectorValue n a, Memory.C (Tuple.VectorValueOf n a),+    EE.Marshal (VectorStruct n a), LLVM.IsSized (VectorStruct n a)) =>+      Vector n a where+   packVector :: LLVM.Vector n a -> VectorStruct n a+   unpackVector :: VectorStruct n a -> LLVM.Vector n a++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.SizeOf a),+    Vector n a) =>+      C (LLVM.Vector n a) where+   pack = packVector; unpack = unpackVector+++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) =>+      Vector n Bool where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Float where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Double where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Word where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>+      Vector n Word8 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>+      Vector n Word16 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Word32 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Word64 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Int where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>+      Vector n Int8 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>+      Vector n Int16 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Int32 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Int64 where+   packVector = id+   unpackVector = id++instance (Vector n a, Vector n b) => Vector n (a,b) where+   packVector x =+      case FuncHT.unzip x of+         (a,b) -> LLVM.consStruct (packVector a) (packVector b)+   unpackVector = LLVM.uncurryStruct $ \a b ->+      liftA2 (,) (unpackVector a) (unpackVector b)++instance (Vector n a, Vector n b, Vector n c) => Vector n (a,b,c) where+   packVector x =+      case FuncHT.unzip3 x of+         (a,b,c) -> LLVM.consStruct (packVector a) (packVector b) (packVector c)+   unpackVector = LLVM.uncurryStruct $ \a b c ->+      liftA3 (,,) (unpackVector a) (unpackVector b) (unpackVector c)+++with :: (C a) => a -> (LLVM.Ptr (Struct a) -> IO b) -> IO b+with a act = EE.alloca $ \ptr -> poke ptr a >> act ptr
+ src/LLVM/Extra/Maybe.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE TypeFamilies #-}+{- |+LLVM counterpart to 'Maybe' datatype.+-}+module LLVM.Extra.Maybe (+   Maybe.T(..),+   Maybe.run,+   Maybe.for,+   Maybe.select,+   Maybe.alternative,+   Maybe.fromBool,+   Maybe.toBool,+   Maybe.getIsNothing,+   Maybe.just,+   nothing,+   Maybe.sequence,+   Maybe.traverse,+   Maybe.lift2,+   Maybe.liftM2,++   loopWithExit,+   ) where++import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.MaybePrivate as Maybe+import qualified LLVM.Extra.Control as C++import LLVM.Core (CodeGenFunction, )+++nothing :: (Tuple.Undefined a) => Maybe.T a+nothing = Maybe.nothing Tuple.undef+++loopWithExit ::+   Tuple.Phi a =>+   a ->+   (a -> CodeGenFunction r (Maybe.T c, b)) ->+   ((c,b) -> CodeGenFunction r a) ->+   CodeGenFunction r b+loopWithExit start check body =+   fmap snd $+   C.loopWithExit start+      (\a -> do+         (mc,b) <- check a+         let (j,c) = Maybe.toBool mc+         return (j, (c,b)))+      body
+ src/LLVM/Extra/MaybeContinuation.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE TypeFamilies #-}+{- |+Maybe transformer datatype implemented in continuation passing style.+-}+module LLVM.Extra.MaybeContinuation where++import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import LLVM.Extra.Control (ifThenElse, )++import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, Value, value, valueOf,+    IsConst, IsType, IsPrimitive, IsInteger, CmpRet)++import qualified Control.Monad as M+import qualified Control.Applicative as App+import Control.Monad.IO.Class (MonadIO(liftIO), )+import Control.Monad.HT ((<=<), )++import Data.Tuple.HT (mapSnd, )++import Prelude hiding (map, )+++{- |+Isomorphic to @ReaderT (CodeGenFunction r z) (ContT z (CodeGenFunction r)) a@,+where the reader provides the block for 'Nothing'+and the continuation part manages the 'Just'.+-}+newtype T r z a =+   Cons {resolve ::+      CodeGenFunction r z ->+      (a -> CodeGenFunction r z) ->+      CodeGenFunction r z+   }+++map :: (a -> CodeGenFunction r b) -> T r z a -> T r z b+map f (Cons m) = Cons $ \n j ->+   m n (j <=< f)++instance Functor (T r z) where+   fmap f (Cons m) = Cons $ \n j -> m n (j . f)++instance App.Applicative (T r z) where+   pure a = lift (pure a)+   (<*>) = M.ap++instance Monad (T r z) where+   return = pure+   (>>=) = bind++instance MonadIO (T r z) where+   liftIO = lift . liftIO++{- |+counterpart to Data.Maybe.HT.toMaybe+-}+withBool ::+   (Tuple.Phi z) =>+   Value Bool -> CodeGenFunction r a -> T r z a+withBool b a =+   guard b >> lift a+{-+withBool b a = Cons $ \n j ->+   ifThenElse b (j =<< a) n+-}++fromBool ::+   (Tuple.Phi z) =>+   CodeGenFunction r (Value Bool, a) ->+   T r z a+fromBool m = do+   (b,a) <- lift m+   guard b+   return a++toBool ::+   (Tuple.Undefined a) =>+   T r (Value Bool, a) a -> CodeGenFunction r (Value Bool, a)+toBool (Cons m) =+   m (return (valueOf False, Tuple.undef)) (return . (,) (valueOf True))+++fromPlainMaybe :: (Tuple.Phi z) => Maybe.T a -> T r z a+fromPlainMaybe (Maybe.Cons b a) = guard b >> return a++fromMaybe :: (Tuple.Phi z) => CodeGenFunction r (Maybe.T a) -> T r z a+fromMaybe m = lift m >>= fromPlainMaybe++toMaybe ::+   (Tuple.Undefined a) =>+   T r (Maybe.T a) a -> CodeGenFunction r (Maybe.T a)+toMaybe (Cons m) =+   m (return Maybe.nothing) (return . Maybe.just)+++isJust ::+   T r (Value Bool) a -> CodeGenFunction r (Value Bool)+isJust (Cons m) =+   m (return (valueOf False)) (const $ return (valueOf True))++lift :: CodeGenFunction r a -> T r z a+lift a = Cons $ \ _n j -> j =<< a++guard ::+   (Tuple.Phi z) =>+   Value Bool -> T r z ()+guard b = Cons $ \n j ->+   ifThenElse b (j ()) n++just :: a -> T r z a+just a = Cons $ \ _n j -> j a++nothing :: T r z a+nothing = Cons $ \n _j -> n++bind ::+   T r z a ->+   (a -> T r z b) ->+   T r z b+bind (Cons ma) mb = Cons $ \n j ->+   ma n (\a -> resolve (mb a) n j)++{- |+Run an exception handler if the Maybe-action fails.+The exception is propagated.+That is, the handler is intended for a cleanup procedure.+-}+onFail :: CodeGenFunction r () -> T r z a -> T r z a+onFail handler m = Cons $ \n j -> resolve m (handler >> n) j++{- |+Run the first action and if that fails run the second action.+If both actions fail, then the composed action fails, too.+-}+alternative ::+   (Tuple.Phi z, Tuple.Undefined a) =>+   T r (Maybe.T a) a -> T r (Maybe.T a) a -> T r z a+alternative x y =+   fromMaybe $ resolve x (toMaybe y) (return . Maybe.just)+++fixedLengthLoop ::+   (Tuple.Phi s, Tuple.Undefined s,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i -> s ->+   (s -> T r (Maybe.T s) s) ->+   CodeGenFunction r (Value i, Maybe.T s)+fixedLengthLoop len start loopBody = do+   (vars, i) <-+      C.loopWithExit (start, len)+         (\(s0, i) -> do+            counterRunning <- A.cmp LLVM.CmpGT i (value LLVM.zero)+            (running, ms1) <-+               C.ifThen counterRunning (valueOf False, Maybe.just s0) $+               fmap (\m -> (Maybe.isJust m, m)) $ toMaybe $ loopBody s0+            return (running, (ms1, i)))+         (\(ms, i) ->+            fmap ((,) (Maybe.fromJust ms)) $ A.dec i)+   pos <- A.sub len i+   return (pos, vars)+++{- |+If the returned position is smaller than the array size,+then returned final state is 'Maybe.nothing'.+-}+arrayLoop ::+   (Tuple.Phi s, Tuple.Undefined s, IsType a,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i ->+   Value (LLVM.Ptr a) -> s ->+   (Value (LLVM.Ptr a) -> s -> T r (Maybe.T (Value (LLVM.Ptr a), s)) s) ->+   CodeGenFunction r (Value i, Maybe.T s)+arrayLoop len ptr start loopBody =+   fmap (mapSnd (fmap snd)) $+   fixedLengthLoop len (ptr,start) $ \(ptr0,s0) -> do+      s1 <- loopBody ptr0 s0+      ptr1 <- lift $ A.advanceArrayElementPtr ptr0+      return (ptr1,s1)+++arrayLoop2 ::+   (Tuple.Phi s, Tuple.Undefined s, IsType a, IsType b,+    Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i) =>+   Value i ->+   Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+   (Value (LLVM.Ptr a) -> Value (LLVM.Ptr b) -> s ->+      T r (Maybe.T (Value (LLVM.Ptr a), (Value (LLVM.Ptr b), s))) s) ->+   CodeGenFunction r (Value i, Maybe.T s)+arrayLoop2 len ptrA ptrB start loopBody =+   fmap (mapSnd (fmap snd)) $+   arrayLoop len ptrA (ptrB,start) $ \ptrAi (ptrB0,s0) -> do+      s1 <- loopBody ptrAi ptrB0 s0+      ptrB1 <- lift $ A.advanceArrayElementPtr ptrB0+      return (ptrB1,s1)+++{-+In case of early exit we would not have a final state.+However, the loop could be in the T monad+and we could just propagate a Nothing.++whileLoop ::+   Tuple.Phi a =>+   a ->+   (a -> T r z a) ->+   CodeGenFunction r a+whileLoop start check body = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   cont <- newBasicBlock+   exit <- newBasicBlock+   br loop++   defineBasicBlock loop+   state <- phi top start+   b <- check state+   condBr b cont exit+   defineBasicBlock cont+   res <- body state+   cont' <- getCurrentBasicBlock+   addPhi cont' state res+   br loop++   defineBasicBlock exit+   return state+-}
+ src/LLVM/Extra/MaybePrivate.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.MaybePrivate where++import qualified LLVM.Extra.TuplePrivate as Tuple+import qualified LLVM.Extra.Control as C+import LLVM.Extra.Control (ifThenElse, )++import qualified LLVM.Core as LLVM+import LLVM.Core (Value, valueOf, CodeGenFunction, )++import qualified Control.Monad as Monad++import Prelude hiding (map, sequence)+++{- |+If @isJust = False@, then @fromJust@ is an @undefTuple@.+-}+data T a = Cons {isJust :: Value Bool, fromJust :: a}+++instance Functor T where+   fmap f (Cons b a) = Cons b (f a)++instance (Tuple.Undefined a) => Tuple.Undefined (T a) where+   undef = Cons Tuple.undef Tuple.undef++instance (Tuple.Phi a) => Tuple.Phi (T a) where+   phi bb (Cons b a) = Monad.liftM2 Cons (Tuple.phi bb b) (Tuple.phi bb a)+   addPhi bb (Cons b0 a0) (Cons b1 a1) =+      Tuple.addPhi bb b0 b1 >> Tuple.addPhi bb a0 a1+++{- |+counterpart to 'maybe'+-}+run ::+   (Tuple.Phi b) =>+   T a ->+   CodeGenFunction r b ->+   (a -> CodeGenFunction r b) ->+   CodeGenFunction r b+run (Cons b a) n j =+   ifThenElse b (j a) n++for ::+   T a ->+   (a -> CodeGenFunction r ()) ->+   CodeGenFunction r ()+for = flip run (return ())++{- |+counterpart to 'Data.Maybe.fromMaybe' with swapped arguments+-}+select ::+   (C.Select a) =>+   T a ->+   a ->+   CodeGenFunction r a+select (Cons b a) d = C.select b a d++alternative ::+   (C.Select a) =>+   T a -> T a -> CodeGenFunction r (T a)+alternative (Cons b0 a0) (Cons b1 a1) =+   Monad.liftM2 Cons+      (LLVM.or b0 b1)+      (C.select b0 a0 a1)+++{- |+counterpart to Data.Maybe.HT.toMaybe+-}+fromBool :: Value Bool -> a -> T a+fromBool = Cons++toBool :: T a -> (Value Bool, a)+toBool (Cons b a) = (b,a)++just :: a -> T a+just = Cons (valueOf True)++nothing :: a -> T a+nothing undef = Cons (valueOf False) undef++getIsNothing :: T a -> CodeGenFunction r (Value Bool)+getIsNothing (Cons b _a) = LLVM.inv b+++lift2 ::+   (a -> b -> c) ->+   T a -> T b -> CodeGenFunction r (T c)+lift2 f (Cons b0 a0) (Cons b1 a1) =+   Monad.liftM (flip Cons (f a0 a1)) (LLVM.and b0 b1)++sequence :: T (CodeGenFunction r a) -> CodeGenFunction r (T a)+sequence (Cons b0 a0) =+   Monad.liftM (Cons b0) a0++traverse ::+   (a -> CodeGenFunction r b) ->+   T a -> CodeGenFunction r (T b)+traverse f = sequence . fmap f++liftM2 ::+   (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 ::+   (Tuple.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/Memory.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Memory (+   C(load, store, decompose, compose), modify,+   Struct,+   Record, Element, element,+   loadRecord, storeRecord, decomposeRecord, composeRecord,+   loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,+   ) where++import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.Scalar as Scalar+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Struct as Struct+import qualified LLVM.Extra.Either as Either+import qualified LLVM.Extra.Maybe as Maybe++import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, Value, IsType, IsSized,+    getElementPtr0, extractvalue, insertvalue)++import qualified Type.Data.Num.Decimal as TypeNum+import qualified Type.Data.Num.Unary as Unary+import Type.Data.Num.Decimal (d0, d1, d2, d3)+import Type.Base.Proxy (Proxy(Proxy))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.FixedLength as FixedLength+import qualified Data.Complex as Complex+import Data.Complex (Complex((:+)))+import Data.Tuple.HT (fst3, snd3, thd3, )+import Data.Word (Word)++import qualified Control.Applicative.HT as App+import Control.Monad (ap, (<=<))+import Control.Applicative (Applicative, pure, liftA2, liftA3, (<*>))++import Prelude2010 hiding (maybe, either, )+import Prelude ()+++class+   (Tuple.Phi llvmValue, Tuple.Undefined llvmValue,+    IsType (Struct llvmValue), IsSized (Struct llvmValue)) =>+      C llvmValue where+   type Struct llvmValue+   load :: Value (LLVM.Ptr (Struct llvmValue)) -> CodeGenFunction r llvmValue+   load ptr  =  decompose =<< LLVM.load ptr+   store ::+      llvmValue -> Value (LLVM.Ptr (Struct llvmValue)) -> CodeGenFunction r ()+   store r ptr  =  flip LLVM.store ptr =<< compose r+   {- |+   In principle it holds:++   > decompose struct = do+   >   ptr <- LLVM.alloca+   >   LLVM.store struct ptr+   >   Memory.load ptr++   but 'LLVM.alloca' will blast your stack when used in a loop.+   -}+   decompose :: Value (Struct llvmValue) -> CodeGenFunction r llvmValue+   {- |+   In principle it holds:++   > compose struct = do+   >   ptr <- LLVM.alloca+   >   Memory.store struct ptr+   >   LLVM.load ptr++   but 'LLVM.alloca' will blast your stack when used in a loop.+   -}+   compose :: llvmValue -> CodeGenFunction r (Value (Struct llvmValue))++modify ::+   (C llvmValue) =>+   (llvmValue -> CodeGenFunction r llvmValue) ->+   Value (LLVM.Ptr (Struct llvmValue)) -> CodeGenFunction r ()+modify f ptr =+   flip store ptr =<< f =<< load ptr+++instance C () where+   type Struct () = LLVM.Struct ()+   load _ = return ()+   store _ _ = return ()+   decompose _ = return ()+   compose _ = return (LLVM.value $ LLVM.constStruct ())+++type Record r o v = Element r o v v++data Element r o v x =+   Element {+      loadElement :: Value (LLVM.Ptr o) -> CodeGenFunction r x,+      storeElement :: Value (LLVM.Ptr o) -> v -> CodeGenFunction r (),+      extractElement :: Value o -> CodeGenFunction r x,+      insertElement :: v -> Value o -> CodeGenFunction r (Value o)+         -- State.Monoid+   }++element ::+   (C x, IsType o,+    LLVM.GetValue o n, LLVM.ValueType o n ~ Struct x,+    LLVM.GetElementPtr o (n, ()), LLVM.ElementPtrType o (n, ()) ~ Struct x) =>+   (v -> x) -> n -> Element r o v x+element field n =+   Element {+      loadElement = \ptr -> load =<< getElementPtr0 ptr (n, ()),+      storeElement = \ptr v -> store (field v) =<< getElementPtr0 ptr (n, ()),+      extractElement = \o -> decompose =<< extractvalue o n,+      insertElement = \v o -> flip (insertvalue o) n =<< compose (field v)+   }++instance Functor (Element r o v) where+   fmap f m =+      Element {+         loadElement = fmap f . loadElement m,+         storeElement = storeElement m,+         extractElement = fmap f . extractElement m,+         insertElement = insertElement m+      }++instance Applicative (Element r o v) where+   pure x =+      Element {+         loadElement = \ _ptr -> return x,+         storeElement = \ _ptr _v -> return (),+         extractElement = \ _o -> return x,+         insertElement = \ _v o -> return o+      }+   f <*> x =+      Element {+         loadElement = \ptr -> loadElement f ptr `ap` loadElement x ptr,+         storeElement = \ptr y -> storeElement f ptr y >> storeElement x ptr y,+         extractElement = \o -> extractElement f o `ap` extractElement x o,+         insertElement = \y o -> insertElement f y o >>= insertElement x y+      }+++loadRecord ::+   Record r o llvmValue ->+   Value (LLVM.Ptr o) -> CodeGenFunction r llvmValue+loadRecord = loadElement++storeRecord ::+   Record r o llvmValue ->+   llvmValue -> Value (LLVM.Ptr o) -> CodeGenFunction r ()+storeRecord m y ptr = storeElement m ptr y++decomposeRecord ::+   Record r o llvmValue ->+   Value o -> CodeGenFunction r llvmValue+decomposeRecord m =+   extractElement m++composeRecord ::+   (IsType o) =>+   Record r o llvmValue ->+   llvmValue -> CodeGenFunction r (Value o)+composeRecord m v =+   insertElement m v (LLVM.value LLVM.undef)++++pair ::+   (C a, C b) =>+   Record r (LLVM.Struct (Struct a, (Struct b, ()))) (a, b)+pair =+   liftA2 (,)+      (element fst d0)+      (element snd d1)++instance (C a, C b) => C (a, b) where+   type Struct (a, b) = LLVM.Struct (Struct a, (Struct b, ()))+   load = loadRecord pair+   store = storeRecord pair+   decompose = decomposeRecord pair+   compose = composeRecord pair+++triple ::+   (C a, C b, C c) =>+   Record r (LLVM.Struct (Struct a, (Struct b, (Struct c, ())))) (a, b, c)+triple =+   liftA3 (,,)+      (element fst3 d0)+      (element snd3 d1)+      (element thd3 d2)++instance (C a, C b, C c) => C (a, b, c) where+   type Struct (a, b, c) =+           LLVM.Struct (Struct a, (Struct b, (Struct c, ())))+   load = loadRecord triple+   store = storeRecord triple+   decompose = decomposeRecord triple+   compose = composeRecord triple+++quadruple ::+   (C a, C b, C c, C d) =>+   Record r+      (LLVM.Struct (Struct a, (Struct b, (Struct c, (Struct d, ())))))+      (a, b, c, d)+quadruple =+   App.lift4 (,,,)+      (element (\(x,_,_,_) -> x) d0)+      (element (\(_,x,_,_) -> x) d1)+      (element (\(_,_,x,_) -> x) d2)+      (element (\(_,_,_,x) -> x) d3)++instance (C a, C b, C c, C d) => C (a, b, c, d) where+   type Struct (a, b, c, d) =+           LLVM.Struct (Struct a, (Struct b, (Struct c, (Struct d, ()))))+   load = loadRecord quadruple+   store = storeRecord quadruple+   decompose = decomposeRecord quadruple+   compose = composeRecord quadruple+++complex ::+   (C a) =>+   Record r (LLVM.Struct (Struct a, (Struct a, ()))) (Complex a)+complex =+   liftA2 (:+)+      (element Complex.realPart d0)+      (element Complex.imagPart d1)++instance (C a) => C (Complex a) where+   type Struct (Complex a) = LLVM.Struct (Struct a, (Struct a, ()))+   load = loadRecord complex+   store = storeRecord complex+   decompose = decomposeRecord complex+   compose = composeRecord complex+++instance+   (Unary.Natural n, C a,+    TypeNum.Natural (TypeNum.FromUnary n),+    TypeNum.Natural (TypeNum.FromUnary n TypeNum.:*: LLVM.SizeOf (Struct a)),+    LLVM.IsFirstClass (Struct a)) =>+      C (FixedLength.T n a) where+   type Struct (FixedLength.T n a) =+            LLVM.Array (TypeNum.FromUnary n) (Struct a)+   compose xs =+      Fold.foldlM+         (\arr (x,i) -> compose x >>= \xc -> LLVM.insertvalue arr xc i)+         (LLVM.value LLVM.undef) $+      FixedLength.zipWith (,) xs $ iterateTrav (1+) (0::Word)+   decompose arr =+      Trav.mapM (decompose <=< LLVM.extractvalue arr) $+      iterateTrav (1+) (0::Word)++iterateTrav :: (Applicative t, Trav.Traversable t) => (a -> a) -> a -> t a+iterateTrav f a0 = snd $ Trav.mapAccumL (\a () -> (f a, a)) a0 $ pure ()+++maybe ::+   (C a) =>+   Record r (LLVM.Struct (Bool, (Struct a, ()))) (Maybe.T a)+maybe =+   liftA2 Maybe.Cons+      (element Maybe.isJust d0)+      (element Maybe.fromJust d1)++instance (C a) => C (Maybe.T a) where+   type Struct (Maybe.T a) = LLVM.Struct (Bool, (Struct a, ()))+   load = loadRecord maybe+   store = storeRecord maybe+   decompose = decomposeRecord maybe+   compose = composeRecord maybe+++either ::+   (C a, C b) =>+   Record r (LLVM.Struct (Bool, (Struct a, (Struct b, ())))) (Either.T a b)+either =+   liftA3 Either.Cons+      (element Either.isRight d0)+      (element Either.fromLeft d1)+      (element Either.fromRight d2)++instance (C a, C b) => C (Either.T a b) where+   type Struct (Either.T a b) = LLVM.Struct (Bool, (Struct a, (Struct b, ())))+   load = loadRecord either+   store = storeRecord either+   decompose = decomposeRecord either+   compose = composeRecord either++++instance (C a) => C (Scalar.T a) where+   type Struct (Scalar.T a) = Struct a+   load = loadNewtype Scalar.Cons+   store = storeNewtype Scalar.decons+   decompose = decomposeNewtype Scalar.Cons+   compose = composeNewtype Scalar.decons+++instance (IsSized a) => C (Value a) where+   type Struct (Value a) = a+   load = LLVM.load+   store = LLVM.store+   decompose = return+   compose = return+++type family StructStruct s+type instance StructStruct (a,as) = (Struct a, StructStruct as)+type instance StructStruct () = ()++instance+   (Struct.Phi s, Struct.Undefined s,+    LLVM.StructFields (StructStruct s),+    ConvertStruct (StructStruct s) TypeNum.D0 s) =>+      C (Struct.T s) where+   type Struct (Struct.T s) = LLVM.Struct (StructStruct s)+   decompose = fmap Struct.Cons . decomposeFields TypeNum.d0+   compose (Struct.Cons s) = composeFields TypeNum.d0 s++class ConvertStruct s i rem where+   decomposeFields ::+      Proxy i -> Value (LLVM.Struct s) -> CodeGenFunction r rem+   composeFields ::+      Proxy i -> rem -> CodeGenFunction r (Value (LLVM.Struct s))++instance+   (TypeNum.Natural i, LLVM.GetField s i, LLVM.FieldType s i ~ Struct a, C a,+    ConvertStruct s (TypeNum.Succ i) rem) =>+      ConvertStruct s i (a,rem) where+   decomposeFields i sm =+      liftA2 (,)+         (decompose =<< LLVM.extractvalue sm i)+         (decomposeFields (decSucc i) sm)+   composeFields i (a,as) = do+      sm <- composeFields (decSucc i) as+      am <- compose a+      LLVM.insertvalue sm am i++decSucc :: Proxy n -> Proxy (TypeNum.Succ n)+decSucc Proxy = Proxy++instance (LLVM.StructFields s) => ConvertStruct s i () where+   decomposeFields _ _ = return ()+   composeFields _ _ = return (LLVM.value LLVM.undef)++++-- redundant IsType and IsSized constraints required for loopy instance+instance+   (IsType (Struct (NiceValue.Repr a)),+    IsSized (Struct (NiceValue.Repr a)),+    NiceValue.C a, C (NiceValue.Repr a)) =>+      C (NiceValue.T a) where+   type Struct (NiceValue.T a) = Struct (NiceValue.Repr a)+   load = fmap NiceValue.Cons . load+   store (NiceValue.Cons a) = store a+   decompose = fmap NiceValue.Cons . decompose+   compose (NiceValue.Cons a) = compose a++instance+   (IsType (Struct (NiceVector.Repr n a)),+    IsSized (Struct (NiceVector.Repr n a)),+    TypeNum.Positive n, NiceVector.C a, C (NiceVector.Repr n a)) =>+      C (NiceVector.T n a) where+   type Struct (NiceVector.T n a) = Struct (NiceVector.Repr n a)+   load = fmap NiceVector.Cons . load+   store (NiceVector.Cons a) = store a+   decompose = fmap NiceVector.Cons . decompose+   compose (NiceVector.Cons a) = compose a++++loadNewtype ::+   (C a) =>+   (a -> llvmValue) ->+   Value (LLVM.Ptr (Struct a)) -> CodeGenFunction r llvmValue+loadNewtype wrap ptr =+   fmap wrap $ load ptr++storeNewtype ::+   (C a) =>+   (llvmValue -> a) ->+   llvmValue -> Value (LLVM.Ptr (Struct a)) -> CodeGenFunction r ()+storeNewtype unwrap y ptr =+   store (unwrap y) ptr++decomposeNewtype ::+   (C a) =>+   (a -> llvmValue) ->+   Value (Struct a) -> CodeGenFunction r llvmValue+decomposeNewtype wrap y =+   fmap wrap $ decompose y++composeNewtype ::+   (C a) =>+   (llvmValue -> a) ->+   llvmValue -> CodeGenFunction r (Value (Struct a))+composeNewtype unwrap y =+   compose (unwrap y)
+ src/LLVM/Extra/Monad.hs view
@@ -0,0 +1,24 @@+{- |+These functions work in arbitrary monads+but are especially helpful when working with the @CodeGenFunction@ monad.+-}+module LLVM.Extra.Monad+   {-# DEPRECATED "use utility-ht:Control.Monad.HT" #-} where++import Control.Monad (liftM2, liftM3, join, (<=<), )+++{-# DEPRECATED chain "use utility-ht:Control.Monad.HT.chain" #-}+chain :: (Monad m) => [a -> m a] -> (a -> m a)+chain =+   foldr (flip (<=<)) return++{-# DEPRECATED liftR2 "use utility-ht:Control.Monad.HT.liftJoin2" #-}+liftR2 :: (Monad m) => (a -> b -> m c) -> m a -> m b -> m c+liftR2 f ma mb =+   join (liftM2 f ma mb)++{-# DEPRECATED liftR3 "use utility-ht:Control.Monad.HT.liftJoin3" #-}+liftR3 :: (Monad m) => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d+liftR3 f ma mb mc =+   join (liftM3 f ma mb mc)
+ src/LLVM/Extra/Multi/Class.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Class+   {-# DEPRECATED "Use LLVM.Extra.Nice.Class instead." #-}+   (module LLVM.Extra.Nice.Class) where++import LLVM.Extra.Nice.Class
+ src/LLVM/Extra/Multi/Iterator.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Iterator+   {-# DEPRECATED "Use LLVM.Extra.Nice.Iterator instead." #-}+   (module LLVM.Extra.Nice.Iterator) where++import LLVM.Extra.Nice.Iterator
+ src/LLVM/Extra/Multi/Value.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Value+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value instead." #-}+   (module LLVM.Extra.Nice.Value) where++import LLVM.Extra.Nice.Value
+ src/LLVM/Extra/Multi/Value/Marshal.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Value.Marshal+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Marshal instead." #-}+   (module LLVM.Extra.Nice.Value.Marshal) where++import LLVM.Extra.Nice.Value.Marshal
+ src/LLVM/Extra/Multi/Value/Storable.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Value.Storable+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Storable instead." #-}+   (module LLVM.Extra.Nice.Value.Storable) where++import LLVM.Extra.Nice.Value.Storable
+ src/LLVM/Extra/Multi/Value/Vector.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Value.Vector+   {-# DEPRECATED "Use LLVM.Extra.Nice.Value.Vector instead." #-}+   (module LLVM.Extra.Nice.Value.Vector) where++import LLVM.Extra.Nice.Value.Vector
+ src/LLVM/Extra/Multi/Vector.hs view
@@ -0,0 +1,5 @@+module LLVM.Extra.Multi.Vector+   {-# DEPRECATED "Use LLVM.Extra.Nice.Vector instead." #-}+   (module LLVM.Extra.Nice.Vector) where++import LLVM.Extra.Nice.Vector
+ src/LLVM/Extra/Multi/Vector/Instance.hs view
@@ -0,0 +1,36 @@+module LLVM.Extra.Multi.Vector.Instance+   {-# DEPRECATED "Use LLVM.Extra.Nice.Vector.Instance instead." #-}+   where++import qualified LLVM.Extra.Nice.Vector.Instance as Inst+import qualified LLVM.Extra.Nice.Vector as Vector++import Prelude2010+import Prelude ()+++type MVVector n a = Inst.NVVector n a++toMultiValue :: Vector.T n a -> MVVector n a+toMultiValue = Inst.toNiceValue++fromMultiValue :: MVVector n a -> Vector.T n a+fromMultiValue = Inst.fromNiceValue++liftMultiValueM ::+   (Functor f) =>+   (Vector.T n a -> f (Vector.T m b)) ->+   (MVVector n a -> f (MVVector m b))+liftMultiValueM = Inst.liftNiceValueM++liftMultiValueM2 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) ->+   (MVVector n a -> MVVector m b -> f (MVVector k c))+liftMultiValueM2 = Inst.liftNiceValueM2++liftMultiValueM3 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) ->+   (MVVector n a -> MVVector m b -> MVVector m c -> f (MVVector k d))+liftMultiValueM3 = Inst.liftNiceValueM3
+ src/LLVM/Extra/Nice/Class.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.Nice.Class where++import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+++class C value where+   type Size value+   switch ::+      f NiceValue.T ->+      f (NiceVector.T (Size value)) ->+      f value++instance C NiceValue.T where+   type Size NiceValue.T = TypeNum.D1+   switch x _ = x++instance (TypeNum.Positive n) => C (NiceVector.T n) where+   type Size (NiceVector.T n) = n+   switch _ x = x+++newtype Const a value = Const {getConst :: value a}++undef ::+   (C value, Size value ~ n, TypeNum.Positive n, NiceVector.C a) =>+   value a+undef =+   getConst $+   switch+      (Const NiceValue.undef)+      (Const NiceVector.undef)++zero ::+   (C value, Size value ~ n, TypeNum.Positive n, NiceVector.C a) =>+   value a+zero =+   getConst $+   switch+      (Const NiceValue.zero)+      (Const NiceVector.zero)+++newtype+   Op0 r a value =+      Op0 {runOp0 :: LLVM.CodeGenFunction r (value a)}++newtype+   Op1 r a b value =+      Op1 {runOp1 :: value a -> LLVM.CodeGenFunction r (value b)}++newtype+   Op2 r a b c value =+      Op2 {runOp2 :: value a -> value b -> LLVM.CodeGenFunction r (value c)}++add, sub ::+   (TypeNum.Positive n, NiceVector.Additive a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+add = runOp2 $ switch (Op2 A.add) (Op2 A.add)+sub = runOp2 $ switch (Op2 A.sub) (Op2 A.sub)++neg ::+   (TypeNum.Positive n, NiceVector.Additive a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+neg = runOp1 $ switch (Op1 A.neg) (Op1 A.neg)+++mul ::+   (TypeNum.Positive n, NiceVector.PseudoRing a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+mul = runOp2 $ switch (Op2 A.mul) (Op2 A.mul)+fdiv ::+   (TypeNum.Positive n, NiceVector.Field a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+fdiv = runOp2 $ switch (Op2 A.fdiv) (Op2 A.fdiv)++scale ::+   (TypeNum.Positive n, NiceVector.PseudoModule v,+    n ~ Size value, C value) =>+   value (NiceValue.Scalar v) -> value v -> LLVM.CodeGenFunction r (value v)+scale = runOp2 $ switch (Op2 A.scale) (Op2 A.scale)++min, max ::+   (TypeNum.Positive n, NiceVector.Real a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+min = runOp2 $ switch (Op2 A.min) (Op2 A.min)+max = runOp2 $ switch (Op2 A.max) (Op2 A.max)++abs, signum ::+   (TypeNum.Positive n, NiceVector.Real a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+abs = runOp1 $ switch (Op1 A.abs) (Op1 A.abs)+signum = runOp1 $ switch (Op1 A.signum) (Op1 A.signum)++truncate, fraction ::+   (TypeNum.Positive n, NiceVector.Fraction a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+truncate = runOp1 $ switch (Op1 A.truncate) (Op1 A.truncate)+fraction = runOp1 $ switch (Op1 A.fraction) (Op1 A.fraction)++sqrt ::+   (TypeNum.Positive n, NiceVector.Algebraic a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+sqrt = runOp1 $ switch (Op1 A.sqrt) (Op1 A.sqrt)++pi ::+   (TypeNum.Positive n, NiceVector.Transcendental a,+    n ~ Size value, C value) =>+   LLVM.CodeGenFunction r (value a)+pi = runOp0 $ switch (Op0 A.pi) (Op0 A.pi)++sin, cos, exp, log ::+   (TypeNum.Positive n, NiceVector.Transcendental a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+sin = runOp1 $ switch (Op1 A.sin) (Op1 A.sin)+cos = runOp1 $ switch (Op1 A.cos) (Op1 A.cos)+exp = runOp1 $ switch (Op1 A.exp) (Op1 A.exp)+log = runOp1 $ switch (Op1 A.log) (Op1 A.log)++pow ::+   (TypeNum.Positive n, NiceVector.Transcendental a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+pow = runOp2 $ switch (Op2 A.pow) (Op2 A.pow)+++cmp ::+   (TypeNum.Positive n, NiceVector.Comparison a,+    n ~ Size value, C value) =>+   LLVM.CmpPredicate ->+   value a -> value a -> LLVM.CodeGenFunction r (value Bool)+cmp p = runOp2 $ switch (Op2 $ A.cmp p) (Op2 $ A.cmp p)++fcmp ::+   (TypeNum.Positive n, NiceVector.FloatingComparison a,+    n ~ Size value, C value) =>+   LLVM.FPPredicate ->+   value a -> value a -> LLVM.CodeGenFunction r (value Bool)+fcmp p = runOp2 $ switch (Op2 $ A.fcmp p) (Op2 $ A.fcmp p)+++and, or, xor ::+   (TypeNum.Positive n, NiceVector.Logic a,+    n ~ Size value, C value) =>+   value a -> value a -> LLVM.CodeGenFunction r (value a)+and = runOp2 $ switch (Op2 A.and) (Op2 A.and)+or = runOp2 $ switch (Op2 A.or) (Op2 A.or)+xor = runOp2 $ switch (Op2 A.xor) (Op2 A.xor)++inv ::+   (TypeNum.Positive n, NiceVector.Logic a,+    n ~ Size value, C value) =>+   value a -> LLVM.CodeGenFunction r (value a)+inv = runOp1 $ switch (Op1 A.inv) (Op1 A.inv)
+ src/LLVM/Extra/Nice/Iterator.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Nice.Iterator (+   takeWhile,+   countDown,+   take,+   Enum(..),+   ) where++import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.Iterator as Iter+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.MaybePrivate as Maybe+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction)++import Control.Applicative (liftA2)++import qualified Data.Enum.Storable as Enum++import qualified Prelude as P+import Prelude hiding (take, takeWhile, Enum, enumFrom, enumFromTo)++++takeWhile ::+   (a -> CodeGenFunction r (NiceValue.T Bool)) ->+   Iter.T r a -> Iter.T r a+takeWhile p = Iter.takeWhile (fmap unpackBool . p)++unpackBool :: NiceValue.T Bool -> LLVM.Value Bool+unpackBool (NiceValue.Cons b) = b++countDown ::+   (NiceValue.Additive i, NiceValue.Comparison i,+    NiceValue.IntegerConstant i) =>+   NiceValue.T i -> Iter.T r (NiceValue.T i)+countDown len =+   takeWhile (NiceValue.cmp LLVM.CmpLT NiceValue.zero) $+   Iter.iterate NiceValue.dec len++take ::+   (NiceValue.Additive i, NiceValue.Comparison i,+    NiceValue.IntegerConstant i) =>+   NiceValue.T i -> Iter.T r a -> Iter.T r a+take len xs = liftA2 const xs (countDown len)+++class (NiceValue.C a) => Enum a where+   succ, pred :: NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a)+   enumFrom :: NiceValue.T a -> Iter.T r (NiceValue.T a)+   enumFromTo :: NiceValue.T a -> NiceValue.T a -> Iter.T r (NiceValue.T a)++instance+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>+      Enum (Enum.T w e) where+   succ = NiceValue.succ+   pred = NiceValue.pred+   enumFrom = Iter.iterate NiceValue.succ+   {- |+   More complicated than 'enumFromToSimple'+   but works also for e.g. [0 .. (0xFFFF::Word16)].+   -}+   enumFromTo from to =+      Iter.takeWhileJust $+      Iter.iterate (Maybe.maybeArg Tuple.undef (succMax to)) (Maybe.just from)++succMax ::+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>+   NiceValue.T (Enum.T w e) ->+   NiceValue.T (Enum.T w e) ->+   LLVM.CodeGenFunction r (Maybe.T (NiceValue.T (Enum.T w e)))+succMax to e = do+   NiceValue.Cons less <- NiceValue.cmpEnum A.CmpLT e to+   C.ifThen less (Maybe.nothing Tuple.undef) $+      fmap Maybe.just $ NiceValue.succ e++{- |+Warning: For [0 .. (0xFFFF::Word16)]+it would compute an undefined @0xFFFF+1@.+In modulo arithmetic it would enter an infinite loop.+-}+_enumFromToSimple ::+   (LLVM.IsInteger w, SoV.IntegerConstant w, Num w,+    LLVM.CmpRet w, LLVM.IsPrimitive w, P.Enum e) =>+   NiceValue.T (Enum.T w e) ->+   NiceValue.T (Enum.T w e) ->+   Iter.T r (NiceValue.T (Enum.T w e))+_enumFromToSimple from to =+   takeWhile (NiceValue.cmpEnum LLVM.CmpGE to) $ enumFrom from
+ src/LLVM/Extra/Nice/Value.hs view
@@ -0,0 +1,8 @@+module LLVM.Extra.Nice.Value (+   module LLVM.Extra.Nice.Value.Private,+   Array(..), withArraySize, extractArrayValue, insertArrayValue,+   ) where++import LLVM.Extra.Nice.Vector.Instance ()+import LLVM.Extra.Nice.Value.Array+import LLVM.Extra.Nice.Value.Private
+ src/LLVM/Extra/Nice/Value/Array.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Nice.Value.Array where++import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Nice.Value.Marshal as Marshal+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import LLVM.Extra.Nice.Value.Private (Repr)++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import qualified Type.Data.Num.Decimal.Number as Dec+import Type.Base.Proxy (Proxy(Proxy))++import Control.Applicative (Applicative(pure, (<*>)))++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Functor.Identity (Identity(Identity, runIdentity))+import Data.Functor ((<$>))++import Prelude2010+import Prelude ()++++newtype Array n a = Array [a]+   deriving (Eq, Show)++instance (Dec.Integer n) => Functor (Array n) where+   fmap f (Array xs) = Array (map f xs)++instance (Dec.Integer n) => Applicative (Array n) where+   pure x =+      runIdentity $ withArraySize $+         \n -> Identity $ Array $ replicate (Dec.integralFromProxy n) x+   Array fs <*> Array xs = Array $ zipWith id fs xs++instance (Dec.Integer n) => Fold.Foldable (Array n) where+   foldMap f (Array xs) = Fold.foldMap f xs++instance (Dec.Integer n) => Trav.Traversable (Array n) where+   traverse f (Array xs) = Array <$> Trav.traverse f xs++withArraySize :: (Proxy n -> gen (Array n a)) -> gen (Array n a)+withArraySize f = f Proxy+++instance (TypeNum.Natural n, Marshal.C a) => NiceValue.C (Array n a) where+   type Repr (Array n a) = LLVM.Value (LLVM.Array n (Marshal.Struct a))+   cons (Array xs) = NiceValue.consPrimitive $ LLVM.Array $ map Marshal.pack xs+   undef = NiceValue.undefPrimitive+   zero = NiceValue.zeroPrimitive+   phi = NiceValue.phiPrimitive+   addPhi = NiceValue.addPhiPrimitive++instance+   (TypeNum.Natural n, Marshal.C a,+    Dec.Natural (n Dec.:*: LLVM.SizeOf (Marshal.Struct a))) =>+      Marshal.C (Array n a) where+   pack (Array xs) = LLVM.Array $ map Marshal.pack xs+   unpack (LLVM.Array xs) = Array $ map Marshal.unpack xs++extractArrayValue ::+   (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) =>+   i -> NiceValue.T (Array n a) ->+   LLVM.CodeGenFunction r (NiceValue.T a)+extractArrayValue i (NiceValue.Cons arr) =+   NiceValue.Cons <$> (Memory.decompose =<< LLVM.extractvalue arr i)++insertArrayValue ::+   (TypeNum.Natural n, LLVM.ArrayIndex n i, Marshal.C a) =>+   i -> NiceValue.T a -> NiceValue.T (Array n a) ->+   LLVM.CodeGenFunction r (NiceValue.T (Array n a))+insertArrayValue i (NiceValue.Cons a) (NiceValue.Cons arr) =+   NiceValue.Cons <$> (flip (LLVM.insertvalue arr) i =<< Memory.compose a)
+ src/LLVM/Extra/Nice/Value/Marshal.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Transfer values between Haskell and JIT generated code+in an LLVM-compatible format.+E.g. 'Bool' is stored as 'i1' and occupies a byte,+@'Vector' n 'Bool'@ is stored as a bit vector,+@'Vector' n 'Word8'@ is stored in an order depending on machine endianess,+and Haskell tuples are stored as LLVM structs.+-}+module LLVM.Extra.Nice.Value.Marshal (+   C(..),+   Struct,+   peek,+   poke,++   VectorStruct,+   Vector(..),++   with,+   EE.alloca,+   ) where++import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Nice.Vector.Instance ()++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Functor.HT as FuncHT+import Control.Applicative (liftA2, liftA3, (<$>))++import Foreign.Storable (Storable)+import Foreign.StablePtr (StablePtr)+import Foreign.Ptr (FunPtr, Ptr)++import Data.Complex (Complex((:+)))+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)++++peek ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> IO a+peek ptr = unpack <$> EE.peek ptr++poke ::+   (C a, Struct a ~ struct, EE.Marshal struct) => LLVM.Ptr struct -> a -> IO ()+poke ptr = EE.poke ptr . pack+++type Struct a = Memory.Struct (NiceValue.Repr a)++class+   (NiceValue.C a, Memory.C (NiceValue.Repr a),+    EE.Marshal (Struct a), LLVM.IsConst (Struct a)) =>+      C a where+   pack :: a -> Struct a+   unpack :: Struct a -> a++instance C Bool   where pack = id; unpack = id+instance C Float  where pack = id; unpack = id+instance C Double where pack = id; unpack = id+instance C Word   where pack = id; unpack = id+instance C Word8  where pack = id; unpack = id+instance C Word16 where pack = id; unpack = id+instance C Word32 where pack = id; unpack = id+instance C Word64 where pack = id; unpack = id+instance C Int    where pack = id; unpack = id+instance C Int8   where pack = id; unpack = id+instance C Int16  where pack = id; unpack = id+instance C Int32  where pack = id; unpack = id+instance C Int64  where pack = id; unpack = id++instance (Storable a)        => C (Ptr a)       where pack = id; unpack = id+instance (LLVM.IsType a)     => C (LLVM.Ptr a)  where pack = id; unpack = id+instance (LLVM.IsFunction a) => C (FunPtr a)    where pack = id; unpack = id+instance                        C (StablePtr a) where pack = id; unpack = id++instance C () where+   pack = LLVM.Struct+   unpack (LLVM.Struct unit) = unit++instance (C a, C b) => C (a,b) where+   pack (a,b) = LLVM.consStruct (pack a) (pack b)+   unpack = LLVM.uncurryStruct $ \a b -> (unpack a, unpack b)++instance (C a, C b, C c) => C (a,b,c) where+   pack (a,b,c) = LLVM.consStruct (pack a) (pack b) (pack c)+   unpack = LLVM.uncurryStruct $ \a b c -> (unpack a, unpack b, unpack c)++instance (C a, C b, C c, C d) => C (a,b,c,d) where+   pack (a,b,c,d) = LLVM.consStruct (pack a) (pack b) (pack c) (pack d)+   unpack =+      LLVM.uncurryStruct $ \a b c d -> (unpack a, unpack b, unpack c, unpack d)+++instance (C a) => C (Complex a) where+   pack (a:+b) = LLVM.consStruct (pack a) (pack b)+   unpack = LLVM.uncurryStruct $ \a b -> unpack a :+ unpack b++++type VectorStruct n a = Memory.Struct (NiceVector.Repr n a)++class+   (TypeNum.Positive n, C a,+    NiceVector.C a, Memory.C (NiceVector.Repr n a),+    EE.Marshal (VectorStruct n a),+    LLVM.IsConst (VectorStruct n a)) =>+      Vector n a where+   packVector :: LLVM.Vector n a -> VectorStruct n a+   unpackVector :: VectorStruct n a -> LLVM.Vector n a++instance (TypeNum.Positive n, Vector n a) => C (LLVM.Vector n a) where+   pack = packVector; unpack = unpackVector+++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D1)) =>+      Vector n Bool where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Float where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Double where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Word where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>+      Vector n Word8 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>+      Vector n Word16 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Word32 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Word64 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: LLVM.IntSize)) =>+      Vector n Int where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D8)) =>+      Vector n Int8 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D16)) =>+      Vector n Int16 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D32)) =>+      Vector n Int32 where+   packVector = id+   unpackVector = id++instance+   (TypeNum.Positive n, TypeNum.Natural (n TypeNum.:*: TypeNum.D64)) =>+      Vector n Int64 where+   packVector = id+   unpackVector = id++instance (Vector n a, Vector n b) => Vector n (a,b) where+   packVector x =+      case FuncHT.unzip x of+         (a,b) -> LLVM.consStruct (packVector a) (packVector b)+   unpackVector = LLVM.uncurryStruct $ \a b ->+      liftA2 (,) (unpackVector a) (unpackVector b)++instance (Vector n a, Vector n b, Vector n c) => Vector n (a,b,c) where+   packVector x =+      case FuncHT.unzip3 x of+         (a,b,c) -> LLVM.consStruct (packVector a) (packVector b) (packVector c)+   unpackVector = LLVM.uncurryStruct $ \a b c ->+      liftA3 (,,) (unpackVector a) (unpackVector b) (unpackVector c)+++with :: (C a) => a -> (LLVM.Ptr (Struct a) -> IO b) -> IO b+with a act = EE.alloca $ \ptr -> poke ptr a >> act ptr
+ src/LLVM/Extra/Nice/Value/Private.hs view
@@ -0,0 +1,1491 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.Extra.Nice.Value.Private where++import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Control as C+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Struct as Struct++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM+import LLVM.Core (WordN, IntN, )++import qualified Type.Data.Num.Decimal.Number as Dec++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (Ptr, FunPtr, )++import qualified Control.Monad.HT as Monad+import qualified Control.Functor.HT as FuncHT+import Control.Monad (Monad, return, fmap, (>>), )+import Data.Functor (Functor, )++import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tup+import qualified Data.EnumBitSet as EnumBitSet+import qualified Data.Enum.Storable as Enum+import qualified Data.Bool8 as Bool8+import Data.Complex (Complex((:+)))+import Data.Tagged (Tagged(Tagged, unTagged))+import Data.Function (id, (.), ($), )+import Data.Maybe (Maybe(Nothing,Just), )+import Data.Bool (Bool(False,True), )+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64, Int)+import Data.Bool8 (Bool8)++import qualified Prelude as P+import Prelude (Float, Double, Integer, Rational, )+++newtype T a = Cons (Repr a)+++class C a where+   type Repr a+   cons :: a -> T a+   undef :: T a+   zero :: T a+   phi :: LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+   addPhi :: LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()++instance C Bool where+   type Repr Bool = LLVM.Value Bool+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Float where+   type Repr Float = LLVM.Value Float+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Double where+   type Repr Double = LLVM.Value Double+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word where+   type Repr Word = LLVM.Value Word+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word8 where+   type Repr Word8 = LLVM.Value Word8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word16 where+   type Repr Word16 = LLVM.Value Word16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word32 where+   type Repr Word32 = LLVM.Value Word32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Word64 where+   type Repr Word64 = LLVM.Value Word64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (Dec.Positive n) => C (LLVM.WordN n) where+   type Repr (LLVM.WordN n) = LLVM.Value (LLVM.WordN n)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int where+   type Repr Int = LLVM.Value Int+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int8 where+   type Repr Int8 = LLVM.Value Int8+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int16 where+   type Repr Int16 = LLVM.Value Int16+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int32 where+   type Repr Int32 = LLVM.Value Int32+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C Int64 where+   type Repr Int64 = LLVM.Value Int64+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (Dec.Positive n) => C (LLVM.IntN n) where+   type Repr (LLVM.IntN n) = LLVM.Value (LLVM.IntN n)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (LLVM.IsType a) => C (LLVM.Ptr a) where+   type Repr (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C (Ptr a) where+   type Repr (Ptr a) = LLVM.Value (Ptr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance (LLVM.IsFunction a) => C (FunPtr a) where+   type Repr (FunPtr a) = LLVM.Value (FunPtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++instance C (StablePtr a) where+   type Repr (StablePtr a) = LLVM.Value (StablePtr a)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+++cast :: (Repr a ~ Repr b) => T a -> T b+cast (Cons a) = Cons a+++consPrimitive ::+   (LLVM.IsConst al, LLVM.Value al ~ Repr a) =>+   al -> T a+consPrimitive = Cons . LLVM.valueOf++undefPrimitive, zeroPrimitive ::+   (LLVM.IsType al, LLVM.Value al ~ Repr a) =>+   T a+undefPrimitive = Cons $ LLVM.value LLVM.undef+zeroPrimitive = Cons $ LLVM.value LLVM.zero++phiPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a++addPhiPrimitive ::+   (LLVM.IsFirstClass al, LLVM.Value al ~ Repr a) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b+++consTuple :: (Tuple.Value a, Repr a ~ Tuple.ValueOf a) => a -> T a+consTuple = Cons . Tuple.valueOf++undefTuple :: (Repr a ~ al, Tuple.Undefined al) => T a+undefTuple = Cons Tuple.undef++zeroTuple :: (Repr a ~ al, Tuple.Zero al) => T a+zeroTuple = Cons Tuple.zero++phiTuple ::+   (Repr a ~ al, Tuple.Phi al) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phiTuple bb (Cons a) = fmap Cons $ Tuple.phi bb a++addPhiTuple ::+   (Repr a ~ al, Tuple.Phi al) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhiTuple bb (Cons a) (Cons b) = Tuple.addPhi bb a b+++instance C () where+   type Repr () = ()+   cons = consUnit+   undef = undefUnit+   zero = zeroUnit+   phi = phiUnit+   addPhi = addPhiUnit++consUnit :: (Repr a ~ ()) => a -> T a+consUnit _ = Cons ()++undefUnit :: (Repr a ~ ()) => T a+undefUnit = Cons ()++zeroUnit :: (Repr a ~ ()) => T a+zeroUnit = Cons ()++phiUnit ::+   (Repr a ~ ()) =>+   LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+phiUnit _bb (Cons ()) = return $ Cons ()++addPhiUnit ::+   (Repr a ~ ()) =>+   LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()+addPhiUnit _bb (Cons ()) (Cons ()) = return ()+++instance C Bool8 where+   type Repr Bool8 = LLVM.Value Bool+   cons = consPrimitive . Bool8.toBool+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++boolPFrom8 :: T Bool8 -> T Bool+boolPFrom8 (Cons b) = Cons b++bool8FromP :: T Bool -> T Bool8+bool8FromP (Cons b) = Cons b++intFromBool8 :: (NativeInteger i ir) => T Bool8 -> LLVM.CodeGenFunction r (T i)+intFromBool8 = liftM LLVM.zadapt++floatFromBool8 ::+   (NativeFloating a ar) => T Bool8 -> LLVM.CodeGenFunction r (T a)+floatFromBool8 = liftM LLVM.uitofp+++instance+   (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e) =>+      C (Enum.T w e) where+   type Repr (Enum.T w e) = LLVM.Value w+   cons = consPrimitive . P.fromIntegral . P.fromEnum . Enum.toPlain+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive++toEnum ::+   (Repr w ~ LLVM.Value w) =>+   T w -> T (Enum.T w e)+toEnum (Cons w) = Cons w++fromEnum ::+   (Repr w ~ LLVM.Value w) =>+   T (Enum.T w e) -> T w+fromEnum (Cons w) = Cons w++succ, pred ::+   (LLVM.IsArithmetic w, SoV.IntegerConstant w) =>+   T (Enum.T w e) -> LLVM.CodeGenFunction r (T (Enum.T w e))+succ = liftM $ \w -> A.add w A.one+pred = liftM $ \w -> A.sub w A.one++-- cannot be an instance of 'Comparison' because there is no 'Real' instance+cmpEnum ::+   (LLVM.CmpRet w, LLVM.IsPrimitive w) =>+   LLVM.CmpPredicate -> T (Enum.T w a) -> T (Enum.T w a) ->+   LLVM.CodeGenFunction r (T Bool)+cmpEnum = liftM2 . LLVM.cmp+++class (C a) => Bounded a where+   minBound, maxBound :: T a++instance+   (LLVM.IsInteger w, LLVM.IsConst w, P.Num w, P.Enum e, P.Bounded e) =>+      Bounded (Enum.T w e) where+   minBound = cons P.minBound+   maxBound = cons P.maxBound+++instance (LLVM.IsInteger w, LLVM.IsConst w) => C (EnumBitSet.T w i) where+   type Repr (EnumBitSet.T w i) = LLVM.Value w+   cons = consPrimitive . EnumBitSet.decons+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+++instance (C a) => C (Maybe a) where+   type Repr (Maybe a) = (LLVM.Value Bool, Repr a)+   cons Nothing = nothing+   cons (Just a) = just $ cons a+   undef = toMaybe undef undef+   zero = toMaybe (cons False) zero+   phi bb ma =+      case splitMaybe ma of+         (b,a) -> Monad.lift2 toMaybe (phi bb b) (phi bb a)+   addPhi bb x y =+      case (splitMaybe x, splitMaybe y) of+         ((xb,xa), (yb,ya)) ->+            addPhi bb xb yb >>+            addPhi bb xa ya++splitMaybe :: T (Maybe a) -> (T Bool, T a)+splitMaybe (Cons (b,a)) = (Cons b, Cons a)++toMaybe :: T Bool -> T a -> T (Maybe a)+toMaybe (Cons b) (Cons a) = Cons (b,a)++nothing :: (C a) => T (Maybe a)+nothing = toMaybe (cons False) undef++just :: T a -> T (Maybe a)+just = toMaybe (cons True)+++instance (C a, C b) => C (a,b) where+   type Repr (a, b) = (Repr a, Repr b)+   cons (a,b) = zip (cons a) (cons b)+   undef = zip undef undef+   zero = zip zero zero+   phi bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phi bb a0) (phi bb a1)+   addPhi bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1++instance (C a, C b, C c) => C (a,b,c) where+   type Repr (a, b, c) = (Repr a, Repr b, Repr c)+   cons (a,b,c) = zip3 (cons a) (cons b) (cons c)+   undef = zip3 undef undef undef+   zero = zip3 zero zero zero+   phi bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2)+   addPhi bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2++instance (C a, C b, C c, C d) => C (a,b,c,d) where+   type Repr (a, b, c, d) = (Repr a, Repr b, Repr c, Repr d)+   cons (a,b,c,d) = zip4 (cons a) (cons b) (cons c) (cons d)+   undef = zip4 undef undef undef undef+   zero = zip4 zero zero zero zero+   phi bb a =+      case unzip4 a of+         (a0,a1,a2,a3) ->+            Monad.lift4 zip4 (phi bb a0) (phi bb a1) (phi bb a2) (phi bb a3)+   addPhi bb a b =+      case (unzip4 a, unzip4 b) of+         ((a0,a1,a2,a3), (b0,b1,b2,b3)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2 >>+            addPhi bb a3 b3+++fst :: T (a,b) -> T a+fst (Cons (a,_b)) = Cons a++snd :: T (a,b) -> T b+snd (Cons (_a,b)) = Cons b++curry :: (T (a,b) -> c) -> (T a -> T b -> c)+curry f a b = f $ zip a b++uncurry :: (T a -> T b -> c) -> (T (a,b) -> c)+uncurry f = Tup.uncurry f . unzip+++mapFst :: (T a0 -> T a1) -> T (a0,b) -> T (a1,b)+mapFst f = Tup.uncurry zip . TupleHT.mapFst f . unzip++mapSnd :: (T b0 -> T b1) -> T (a,b0) -> T (a,b1)+mapSnd f = Tup.uncurry zip . TupleHT.mapSnd f . unzip++mapFstF :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b) -> f (T (a1,b))+mapFstF f = fmap (Tup.uncurry zip) . FuncHT.mapFst f . unzip++mapSndF :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0) -> f (T (a,b1))+mapSndF f = fmap (Tup.uncurry zip) . FuncHT.mapSnd f . unzip++swap :: T (a,b) -> T (b,a)+swap = Tup.uncurry zip . TupleHT.swap . unzip+++fst3 :: T (a,b,c) -> T a+fst3 (Cons (a,_b,_c)) = Cons a++snd3 :: T (a,b,c) -> T b+snd3 (Cons (_a,b,_c)) = Cons b++thd3 :: T (a,b,c) -> T c+thd3 (Cons (_a,_b,c)) = Cons c++curry3 :: (T (a,b,c) -> d) -> (T a -> T b -> T c -> d)+curry3 f a b c = f $ zip3 a b c++uncurry3 :: (T a -> T b -> T c -> d) -> (T (a,b,c) -> d)+uncurry3 f = TupleHT.uncurry3 f . unzip3+++mapFst3 :: (T a0 -> T a1) -> T (a0,b,c) -> T (a1,b,c)+mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 :: (T b0 -> T b1) -> T (a,b0,c) -> T (a,b1,c)+mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 :: (T c0 -> T c1) -> T (a,b,c0) -> T (a,b,c1)+mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3++mapFst3F :: (Functor f) => (T a0 -> f (T a1)) -> T (a0,b,c) -> f (T (a1,b,c))+mapFst3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapFst3 f . unzip3++mapSnd3F :: (Functor f) => (T b0 -> f (T b1)) -> T (a,b0,c) -> f (T (a,b1,c))+mapSnd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapSnd3 f . unzip3++mapThd3F :: (Functor f) => (T c0 -> f (T c1)) -> T (a,b,c0) -> f (T (a,b,c1))+mapThd3F f = fmap (TupleHT.uncurry3 zip3) . FuncHT.mapThd3 f . unzip3+++zip :: T a -> T b -> T (a,b)+zip (Cons a) (Cons b) = Cons (a,b)++zip3 :: T a -> T b -> T c -> T (a,b,c)+zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)++zip4 :: T a -> T b -> T c -> T d -> T (a,b,c,d)+zip4 (Cons a) (Cons b) (Cons c) (Cons d) = Cons (a,b,c,d)++unzip :: T (a,b) -> (T a, T b)+unzip (Cons (a,b)) = (Cons a, Cons b)++unzip3 :: T (a,b,c) -> (T a, T b, T c)+unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)++unzip4 :: T (a,b,c,d) -> (T a, T b, T c, T d)+unzip4 (Cons (a,b,c,d)) = (Cons a, Cons b, Cons c, Cons d)+++instance (C tuple) => C (StoreTuple.Tuple tuple) where+   type Repr (StoreTuple.Tuple tuple) = Repr tuple+   cons = tuple . cons . StoreTuple.getTuple+   undef = tuple undef+   zero = tuple zero+   phi bb = fmap tuple . phi bb . untuple+   addPhi bb a b = addPhi bb (untuple a) (untuple b)++tuple :: T tuple -> T (StoreTuple.Tuple tuple)+tuple (Cons a) = Cons a++untuple :: T (StoreTuple.Tuple tuple) -> T tuple+untuple (Cons a) = Cons a+++class Struct struct where+   consStruct :: (Struct.T struct ~ a) => a -> T a+   undefStruct :: (Struct.T struct ~ a) => T a+   zeroStruct :: (Struct.T struct ~ a) => T a+   phiStruct :: (Struct.T struct ~ a) =>+      LLVM.BasicBlock -> T a -> LLVM.CodeGenFunction r (T a)+   addPhiStruct :: (Struct.T struct ~ a) =>+      LLVM.BasicBlock -> T a -> T a -> LLVM.CodeGenFunction r ()++instance (Struct struct) => C (Struct.T struct) where+   type Repr (Struct.T struct) = Struct.T (Repr struct)+   cons = consStruct+   undef = undefStruct+   zero = zeroStruct+   phi = phiStruct+   addPhi = addPhiStruct++instance Struct () where+   consStruct unit = Cons unit+   undefStruct = Cons (Struct.Cons ())+   zeroStruct = Cons (Struct.Cons ())+   phiStruct _bb = return+   addPhiStruct _bb _a _b = return ()++structCons :: T a -> T (Struct.T as) -> T (Struct.T (a,as))+structCons (Cons b) (Cons (Struct.Cons bs)) = Cons (Struct.Cons (b,bs))++structUncons :: T (Struct.T (a,as)) -> (T a, T (Struct.T as))+structUncons (Cons (Struct.Cons (b,bs))) = (Cons b, Cons (Struct.Cons bs))++instance (C a, Struct as) => Struct (a,as) where+   consStruct (Struct.Cons (a,as)) =+      structCons (cons a) (consStruct (Struct.Cons as))+   undefStruct = structCons undef undefStruct+   zeroStruct = structCons zero zeroStruct+   phiStruct bb at =+      case structUncons at of+         (a,as) -> Monad.lift2 structCons (phi bb a) (phiStruct bb as)+   addPhiStruct bb at bt =+      case (structUncons at, structUncons bt) of+         ((a,as), (b,bs)) -> addPhi bb a b >> addPhiStruct bb as bs+++instance (LLVM.IsConst a, LLVM.IsFirstClass a) => C (EE.Stored a) where+   type Repr (EE.Stored a) = LLVM.Value a+   cons = Cons . LLVM.valueOf . EE.getStored+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+++instance C a => C (Tagged tag a) where+   type Repr (Tagged tag a) = Repr a+   cons = tag . cons . unTagged+   undef = tag undef+   zero = tag zero+   phi bb = fmap tag . phi bb . untag+   addPhi bb a b = addPhi bb (untag a) (untag b)++tag :: T a -> T (Tagged tag a)+tag = cast++untag :: T (Tagged tag a) -> T a+untag = cast++liftTaggedM ::+   (Monad m) => (T a -> m (T b)) -> T (Tagged tag a) -> m (T (Tagged tag b))+liftTaggedM f = Monad.lift tag . f . untag++liftTaggedM2 ::+   (Monad m) =>+   (T a -> T b -> m (T c)) ->+   T (Tagged tag a) -> T (Tagged tag b) -> m (T (Tagged tag c))+liftTaggedM2 f a b = Monad.lift tag $ f (untag a) (untag b)+++instance (C a) => C (Complex a) where+   type Repr (Complex a) = Complex (Repr a)+   cons (a:+b) = consComplex (cons a) (cons b)+   undef = consComplex undef undef+   zero = consComplex zero zero+   phi bb a =+      case deconsComplex a of+         (a0,a1) ->+            Monad.lift2 consComplex (phi bb a0) (phi bb a1)+   addPhi bb a b =+      case (deconsComplex a, deconsComplex b) of+         ((a0,a1), (b0,b1)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1++consComplex :: T a -> T a -> T (Complex a)+consComplex (Cons a) (Cons b) = Cons (a:+b)++deconsComplex :: T (Complex a) -> (T a, T a)+deconsComplex (Cons (a:+b)) = (Cons a, Cons b)++++class Compose nicetuple where+   type Composed nicetuple+   {- |+   A nested 'zip'.+   -}+   compose :: nicetuple -> T (Composed nicetuple)++class+   (Composed (Decomposed T pattern) ~ PatternTuple pattern) =>+      Decompose pattern where+   {- |+   A nested 'unzip'.+   Since it is not obvious how deep to decompose nested tuples,+   you must provide a pattern of the decomposed tuple.+   E.g.++   > f :: NiceValue ((a,b),(c,d)) ->+   >      ((NiceValue a, NiceValue b), NiceValue (c,d))+   > f = decompose ((atom,atom),atom)+   -}+   decompose :: pattern -> T (PatternTuple pattern) -> Decomposed T pattern++type family Decomposed (f :: * -> *) pattern+type family PatternTuple pattern+++{- |+A combination of 'compose' and 'decompose'+that let you operate on tuple NiceValues as Haskell tuples.+-}+modify ::+   (Compose a, Decompose pattern) =>+   pattern ->+   (Decomposed T pattern -> a) ->+   T (PatternTuple pattern) -> T (Composed a)+modify p f = compose . f . decompose p++modify2 ::+   (Compose a, Decompose patternA, Decompose patternB) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> T (Composed a)+modify2 pa pb f a b = compose $ f (decompose pa a) (decompose pb b)++modifyF ::+   (Compose a, Decompose pattern, Functor f) =>+   pattern ->+   (Decomposed T pattern -> f a) ->+   T (PatternTuple pattern) -> f (T (Composed a))+modifyF p f = fmap compose . f . decompose p++modifyF2 ::+   (Compose a, Decompose patternA, Decompose patternB,+    Functor f) =>+   patternA ->+   patternB ->+   (Decomposed T patternA -> Decomposed T patternB -> f a) ->+   T (PatternTuple patternA) -> T (PatternTuple patternB) -> f (T (Composed a))+modifyF2 pa pb f a b = fmap compose $ f (decompose pa a) (decompose pb b)++++instance Compose (T a) where+   type Composed (T a) = a+   compose = id++instance Decompose (Atom a) where+   decompose _ = id++type instance Decomposed f (Atom a) = f a+type instance PatternTuple (Atom a) = a++data Atom a = Atom++atom :: Atom a+atom = Atom+++instance Compose () where+   type Composed () = ()+   compose = cons++instance Decompose () where+   decompose () _ = ()++type instance Decomposed f () = ()+type instance PatternTuple () = ()+++instance (Compose a, Compose b) => Compose (a,b) where+   type Composed (a,b) = (Composed a, Composed b)+   compose = Tup.uncurry zip . TupleHT.mapPair (compose, compose)++instance (Decompose pa, Decompose pb) => Decompose (pa,pb) where+   decompose (pa,pb) =+      TupleHT.mapPair (decompose pa, decompose pb) . unzip++type instance Decomposed f (pa,pb) = (Decomposed f pa, Decomposed f pb)+type instance PatternTuple (pa,pb) = (PatternTuple pa, PatternTuple pb)+++instance (Compose a, Compose b, Compose c) => Compose (a,b,c) where+   type Composed (a,b,c) = (Composed a, Composed b, Composed c)+   compose = TupleHT.uncurry3 zip3 . TupleHT.mapTriple (compose, compose, compose)++instance+   (Decompose pa, Decompose pb, Decompose pc) =>+      Decompose (pa,pb,pc) where+   decompose (pa,pb,pc) =+      TupleHT.mapTriple (decompose pa, decompose pb, decompose pc) . unzip3++type instance Decomposed f (pa,pb,pc) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc)+type instance PatternTuple (pa,pb,pc) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc)+++instance (Compose a, Compose b, Compose c, Compose d) => Compose (a,b,c,d) where+   type Composed (a,b,c,d) = (Composed a, Composed b, Composed c, Composed d)+   compose (a,b,c,d) = zip4 (compose a) (compose b) (compose c) (compose d)++instance+   (Decompose pa, Decompose pb, Decompose pc, Decompose pd) =>+      Decompose (pa,pb,pc,pd) where+   decompose (pa,pb,pc,pd) x =+      case unzip4 x of+         (a,b,c,d) ->+            (decompose pa a, decompose pb b, decompose pc c, decompose pd d)+type instance Decomposed f (pa,pb,pc,pd) =+        (Decomposed f pa, Decomposed f pb, Decomposed f pc, Decomposed f pd)+type instance PatternTuple (pa,pb,pc,pd) =+        (PatternTuple pa, PatternTuple pb, PatternTuple pc, PatternTuple pd)+++instance (Compose tuple) => Compose (StoreTuple.Tuple tuple) where+   type Composed (StoreTuple.Tuple tuple) = StoreTuple.Tuple (Composed tuple)+   compose = tuple . compose . StoreTuple.getTuple++instance (Decompose p) => Decompose (StoreTuple.Tuple p) where+   decompose (StoreTuple.Tuple p) = StoreTuple.Tuple . decompose p . untuple++type instance Decomposed f (StoreTuple.Tuple p) =+                  StoreTuple.Tuple (Decomposed f p)+type instance PatternTuple (StoreTuple.Tuple p) =+                  StoreTuple.Tuple (PatternTuple p)+++instance (Compose a) => Compose (Tagged tag a) where+   type Composed (Tagged tag a) = Tagged tag (Composed a)+   compose = tag . compose . unTagged++instance (Decompose pa) => Decompose (Tagged tag pa) where+   decompose (Tagged p) = Tagged . decompose p . untag++type instance Decomposed f (Tagged tag pa) = Tagged tag (Decomposed f pa)+type instance PatternTuple (Tagged tag pa) = Tagged tag (PatternTuple pa)+++instance (Compose a) => Compose (Complex a) where+   type Composed (Complex a) = Complex (Composed a)+   compose (a:+b) = consComplex (compose a) (compose b)++instance (Decompose pa) => Decompose (Complex pa) where+   decompose (pa:+pb) =+      Tup.uncurry (:+) .+      TupleHT.mapPair (decompose pa, decompose pb) . deconsComplex++type instance Decomposed f (Complex pa) = Complex (Decomposed f pa)+type instance PatternTuple (Complex pa) = Complex (PatternTuple pa)++realPart, imagPart :: T (Complex a) -> T a+realPart (Cons (a:+_)) = Cons a+imagPart (Cons (_:+b)) = Cons b++++lift1 :: (Repr a -> Repr b) -> T a -> T b+lift1 f (Cons a) = Cons $ f a++liftM0 ::+   (Monad m) =>+   m (Repr a) ->+   m (T a)+liftM0 f = Monad.lift Cons f++liftM ::+   (Monad m) =>+   (Repr a -> m (Repr b)) ->+   T a -> m (T b)+liftM f (Cons a) = Monad.lift Cons $ f a++liftM2 ::+   (Monad m) =>+   (Repr a -> Repr b -> m (Repr c)) ->+   T a -> T b -> m (T c)+liftM2 f (Cons a) (Cons b) = Monad.lift Cons $ f a b++liftM3 ::+   (Monad m) =>+   (Repr a -> Repr b -> Repr c ->+    m (Repr d)) ->+   T a -> T b -> T c -> m (T d)+liftM3 f (Cons a) (Cons b) (Cons c) = Monad.lift Cons $ f a b c+++instance (C a) => Tuple.Zero (T a) where+   zero = zero++instance (C a) => Tuple.Undefined (T a) where+   undef = undef++instance (C a) => Tuple.Phi (T a) where+   phi = phi+   addPhi = addPhi+++class (C a) => IntegerConstant a where+   fromInteger' :: Integer -> T a++class (IntegerConstant a) => RationalConstant a where+   fromRational' :: Rational -> T a++instance IntegerConstant Float  where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Double where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant Word where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Word64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant Int where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int8 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int16 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int32 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance IntegerConstant Int64 where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance (Dec.Positive n) => IntegerConstant (WordN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger+instance (Dec.Positive n) => IntegerConstant (IntN n) where fromInteger' = Cons . LLVM.value . SoV.constFromInteger++instance IntegerConstant a => IntegerConstant (Tagged tag a) where+   fromInteger' = tag . fromInteger'++instance RationalConstant Float  where fromRational' = Cons . LLVM.value . SoV.constFromRational+instance RationalConstant Double where fromRational' = Cons . LLVM.value . SoV.constFromRational++instance RationalConstant a => RationalConstant (Tagged tag a) where+   fromRational' = tag . fromRational'+++instance (IntegerConstant a) => A.IntegerConstant (T a) where+   fromInteger' = fromInteger'++instance (RationalConstant a) => A.RationalConstant (T a) where+   fromRational' = fromRational'+++class (C a) => Additive a where+   add :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   sub :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   neg :: T a -> LLVM.CodeGenFunction r (T a)++instance Additive Float where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Double where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word8 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word16 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int8 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int16 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Dec.Positive n) => Additive (WordN n) where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance (Dec.Positive n) => Additive (IntN n) where+   add = liftM2 LLVM.add+   sub = liftM2 LLVM.sub+   neg = liftM LLVM.neg++instance Additive a => Additive (Tagged tag a) where+   add = liftTaggedM2 add+   sub = liftTaggedM2 sub+   neg = liftTaggedM neg++instance (Additive a) => A.Additive (T a) where+   zero = zero+   add = add+   sub = sub+   neg = neg++inc, dec ::+   (Additive i, IntegerConstant i) => T i -> LLVM.CodeGenFunction r (T i)+inc x = add x A.one+dec x = sub x A.one+++class (Additive a) => PseudoRing a where+   mul :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance PseudoRing Float where mul = liftM2 LLVM.mul+instance PseudoRing Double where mul = liftM2 LLVM.mul+instance PseudoRing Word where mul = liftM2 LLVM.mul+instance PseudoRing Word8 where mul = liftM2 LLVM.mul+instance PseudoRing Word16 where mul = liftM2 LLVM.mul+instance PseudoRing Word32 where mul = liftM2 LLVM.mul+instance PseudoRing Word64 where mul = liftM2 LLVM.mul+instance PseudoRing Int where mul = liftM2 LLVM.mul+instance PseudoRing Int8 where mul = liftM2 LLVM.mul+instance PseudoRing Int16 where mul = liftM2 LLVM.mul+instance PseudoRing Int32 where mul = liftM2 LLVM.mul+instance PseudoRing Int64 where mul = liftM2 LLVM.mul++instance (PseudoRing a) => PseudoRing (Tagged tag a) where+   mul = liftTaggedM2 mul++instance (PseudoRing a) => A.PseudoRing (T a) where+   mul = mul+++class (PseudoRing a) => Field a where+   fdiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Field Float where+   fdiv = liftM2 LLVM.fdiv++instance Field Double where+   fdiv = liftM2 LLVM.fdiv++instance (Field a) => Field (Tagged tag a) where+   fdiv = liftTaggedM2 fdiv++instance (Field a) => A.Field (T a) where+   fdiv = fdiv+++type family Scalar vector+type instance Scalar Float = Float+type instance Scalar Double = Double+type instance Scalar (Tagged tag a) = Tagged tag (Scalar a)+type instance A.Scalar (T a) = T (Scalar a)++class (PseudoRing (Scalar v), Additive v) => PseudoModule v where+   scale :: T (Scalar v) -> T v -> LLVM.CodeGenFunction r (T v)++instance PseudoModule Float where+   scale = liftM2 A.mul++instance PseudoModule Double where+   scale = liftM2 A.mul++instance (PseudoModule a) => PseudoModule (Tagged tag a) where+   scale = liftTaggedM2 scale++instance (PseudoModule a) => A.PseudoModule (T a) where+   scale = scale+++class (Additive a) => Real a where+   min :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   max :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   abs :: T a -> LLVM.CodeGenFunction r (T a)+   signum :: T a -> LLVM.CodeGenFunction r (T a)++instance Real Float where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Double where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Dec.Positive n) => Real (WordN n) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Dec.Positive n) => Real (IntN n) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (Real a) => Real (Tagged tag a) where+   min = liftTaggedM2 min+   max = liftTaggedM2 max+   abs = liftTaggedM abs+   signum = liftTaggedM signum++instance (Real a) => A.Real (T a) where+   min = min+   max = max+   abs = abs+   signum = signum+++class (Real a) => Fraction a where+   truncate :: T a -> LLVM.CodeGenFunction r (T a)+   fraction :: T a -> LLVM.CodeGenFunction r (T a)++instance Fraction Float where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance Fraction Double where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (Fraction a) => Fraction (Tagged tag a) where+   truncate = liftTaggedM truncate+   fraction = liftTaggedM fraction++instance (Fraction a) => A.Fraction (T a) where+   truncate = truncate+   fraction = fraction+++class+   (Repr i ~ LLVM.Value ir,+    LLVM.IsInteger ir, SoV.IntegerConstant ir,+    LLVM.CmpRet ir, LLVM.IsPrimitive ir) =>+      NativeInteger i ir where++instance NativeInteger Word   Word   where+instance NativeInteger Word8  Word8  where+instance NativeInteger Word16 Word16 where+instance NativeInteger Word32 Word32 where+instance NativeInteger Word64 Word64 where++instance NativeInteger Int   Int   where+instance NativeInteger Int8  Int8  where+instance NativeInteger Int16 Int16 where+instance NativeInteger Int32 Int32 where+instance NativeInteger Int64 Int64 where++instance NativeInteger a a => NativeInteger (Tagged tag a) a where+++class+   (Repr a ~ LLVM.Value ar,+    LLVM.IsFloating ar, SoV.RationalConstant ar,+    LLVM.CmpRet ar, LLVM.IsPrimitive ar) =>+      NativeFloating a ar where++instance NativeFloating Float  Float where+instance NativeFloating Double Double where+++truncateToInt, floorToInt, ceilingToInt, roundToIntFast ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T a -> LLVM.CodeGenFunction r (T i)+truncateToInt  = liftM SoV.truncateToInt+floorToInt     = liftM SoV.floorToInt+ceilingToInt   = liftM SoV.ceilingToInt+roundToIntFast = liftM SoV.roundToIntFast++splitFractionToInt ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T a -> LLVM.CodeGenFunction r (T (i,a))+splitFractionToInt = liftM SoV.splitFractionToInt+++class Field a => Algebraic a where+   sqrt :: T a -> LLVM.CodeGenFunction r (T a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (Algebraic a) => Algebraic (Tagged tag a) where+   sqrt = liftTaggedM sqrt++instance (Algebraic a) => A.Algebraic (T a) where+   sqrt = sqrt+++class Algebraic a => Transcendental a where+   pi :: LLVM.CodeGenFunction r (T a)+   sin, cos, exp, log :: T a -> LLVM.CodeGenFunction r (T a)+   pow :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Transcendental Float where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance Transcendental Double where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance (Transcendental a) => Transcendental (Tagged tag a) where+   pi = fmap tag pi+   sin = liftTaggedM sin+   cos = liftTaggedM cos+   exp = liftTaggedM exp+   log = liftTaggedM log+   pow = liftTaggedM2 pow++instance (Transcendental a) => A.Transcendental (T a) where+   pi = pi+   sin = sin+   cos = cos+   exp = exp+   log = log+   pow = pow++++class (C a) => Select a where+   select ::+      T Bool -> T a -> T a ->+      LLVM.CodeGenFunction r (T a)++instance Select Bool where select = liftM3 LLVM.select+instance Select Bool8 where select = liftM3 LLVM.select+instance Select Float where select = liftM3 LLVM.select+instance Select Double where select = liftM3 LLVM.select+instance Select Word where select = liftM3 LLVM.select+instance Select Word8 where select = liftM3 LLVM.select+instance Select Word16 where select = liftM3 LLVM.select+instance Select Word32 where select = liftM3 LLVM.select+instance Select Word64 where select = liftM3 LLVM.select+instance Select Int where select = liftM3 LLVM.select+instance Select Int8 where select = liftM3 LLVM.select+instance Select Int16 where select = liftM3 LLVM.select+instance Select Int32 where select = liftM3 LLVM.select+instance Select Int64 where select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select b =+      modifyF2 (atom,atom) (atom,atom) $+      \(a0,b0) (a1,b1) ->+         Monad.lift2 (,)+            (select b a0 a1)+            (select b b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select b =+      modifyF2 (atom,atom,atom) (atom,atom,atom) $+      \(a0,b0,c0) (a1,b1,c1) ->+         Monad.lift3 (,,)+            (select b a0 a1)+            (select b b0 b1)+            (select b c0 c1)++instance (Select a) => Select (Tagged tag a) where+   select = liftTaggedM2 . select++instance (Select a) => C.Select (T a) where+   select b = select (Cons b)++++class (Real a) => Comparison a where+   {- |+   It must hold++   > max x y  ==  do gt <- cmp CmpGT x y; select gt x y+   -}+   cmp ::+      LLVM.CmpPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance Comparison Float where cmp = liftM2 . LLVM.cmp+instance Comparison Double where cmp = liftM2 . LLVM.cmp++instance Comparison Int where cmp = liftM2 . LLVM.cmp+instance Comparison Int8 where cmp = liftM2 . LLVM.cmp+instance Comparison Int16 where cmp = liftM2 . LLVM.cmp+instance Comparison Int32 where cmp = liftM2 . LLVM.cmp+instance Comparison Int64 where cmp = liftM2 . LLVM.cmp++instance Comparison Word where cmp = liftM2 . LLVM.cmp+instance Comparison Word8 where cmp = liftM2 . LLVM.cmp+instance Comparison Word16 where cmp = liftM2 . LLVM.cmp+instance Comparison Word32 where cmp = liftM2 . LLVM.cmp+instance Comparison Word64 where cmp = liftM2 . LLVM.cmp++instance (Dec.Positive n) => Comparison (IntN n) where cmp = liftM2 . LLVM.cmp+instance (Dec.Positive n) => Comparison (WordN n) where cmp = liftM2 . LLVM.cmp++instance (Comparison a) => Comparison (Tagged tag a) where+   cmp p a b = cmp p (untag a) (untag b)++instance (Comparison a) => A.Comparison (T a) where+   type CmpResult (T a) = T Bool+   cmp = cmp++++class (Comparison a) => FloatingComparison a where+   fcmp ::+      LLVM.FPPredicate -> T a -> T a ->+      LLVM.CodeGenFunction r (T Bool)++instance FloatingComparison Float where+   fcmp = liftM2 . LLVM.fcmp++instance (FloatingComparison a) => FloatingComparison (Tagged tag a) where+   fcmp p a b = fcmp p (untag a) (untag b)++instance (FloatingComparison a) => A.FloatingComparison (T a) where+   fcmp = fcmp++++class (C a) => Logic a where+   and :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   or :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   xor :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   inv :: T a -> LLVM.CodeGenFunction r (T a)++instance Logic Bool where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Bool8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word16 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word32 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word64 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance (Dec.Positive n) => Logic (WordN n) where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance (LLVM.IsInteger w, LLVM.IsConst w) => Logic (EnumBitSet.T w i) where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic a => Logic (Tagged tag a) where+   and = liftTaggedM2 and; or = liftTaggedM2 or+   xor = liftTaggedM2 xor; inv = liftTaggedM inv+++instance Logic a => A.Logic (T a) where+   and = and+   or = or+   xor = xor+   inv = inv++++class BitShift a where+   shl :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   shr :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance BitShift Word where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Int where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++++class (PseudoRing a) => Integral a where+   idiv :: T a -> T a -> LLVM.CodeGenFunction r (T a)+   irem :: T a -> T a -> LLVM.CodeGenFunction r (T a)++instance Integral Word where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Word32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Word64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int32 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance Integral Int64 where+   idiv = liftM2 LLVM.idiv+   irem = liftM2 LLVM.irem++instance (Integral a) => Integral (Tagged tag a) where+   idiv = liftTaggedM2 idiv+   irem = liftTaggedM2 irem+++fromIntegral ::+   (NativeInteger i ir, NativeFloating a ar) =>+   T i -> LLVM.CodeGenFunction r (T a)+fromIntegral = liftM LLVM.inttofp
+ src/LLVM/Extra/Nice/Value/Storable.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module LLVM.Extra.Nice.Value.Storable (+   -- * Basic class+   C(load, store),+   storeNext,+   modify,++   -- * Classes for tuples and vectors+   Tuple(..),+   Vector(..),+   TupleVector(..),++   -- * Standard method implementations+   loadTraversable,+   loadApplicative,+   storeFoldable,++   -- * Pointer handling+   Storable.advancePtr,+   Storable.incrementPtr,+   Storable.decrementPtr,++   -- * Loops over Storable arrays+   Array.arrayLoop,+   Array.arrayLoop2,+   Array.arrayLoopMaybeCont,+   Array.arrayLoopMaybeCont2,+   ) where++import qualified LLVM.Extra.Storable.Private as Storable+import qualified LLVM.Extra.Storable.Array as Array+import LLVM.Extra.Storable.Private+         (BytePtr, advancePtrStatic, incPtrState, incrementPtr, update,+          castFromBytePtr, castToBytePtr,+          runElements, elementOffset, castElementPtr,+          assemblePrimitive, disassemblePrimitive, proxyFromElement3)++import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value as NiceValue+import qualified LLVM.Extra.ArithmeticPrivate as A++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value)++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.Reader as MR+import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative.HT as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad (foldM, replicateM, replicateM_, (<=<))+import Control.Applicative (Applicative, pure, (<$>))++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import qualified Foreign.Storable as Store+import Foreign.Ptr (Ptr)++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Orphans ()+import Data.Tuple.HT (uncurry3)+import Data.Complex (Complex)+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)+import Data.Bool8 (Bool8)++++class (Store.Storable a, NiceValue.C a) => C a where+   {-+   Not all Storable types have a compatible LLVM type,+   or even more, one LLVM type that is compatible on all platforms.+   -}+   load :: Value (Ptr a) -> CodeGenFunction r (NiceValue.T a)+   store :: NiceValue.T a -> Value (Ptr a) -> CodeGenFunction r ()++storeNext ::+   (C a, Value (Ptr a) ~ ptr) => NiceValue.T a -> ptr -> CodeGenFunction r ptr+storeNext a ptr  =  store a ptr >> incrementPtr ptr++modify ::+   (C a, NiceValue.T a ~ al) =>+   (al -> CodeGenFunction r al) ->+   Value (Ptr a) -> CodeGenFunction r ()+modify f ptr  =  flip store ptr =<< f =<< load ptr+++instance+   (EE.Marshal a, LLVM.IsConst a, LLVM.IsFirstClass a) =>+      C (EE.Stored a) where+   load = fmap NiceValue.Cons . LLVM.load <=< castFromStoredPtr+   store (NiceValue.Cons a) = LLVM.store a <=< castFromStoredPtr++castFromStoredPtr ::+   (LLVM.IsType a) =>+   Value (Ptr (EE.Stored a)) -> CodeGenFunction r (Value (LLVM.Ptr a))+castFromStoredPtr = LLVM.bitcast+++loadPrimitive ::+   (LLVM.Storable a, NiceValue.Repr a ~ LLVM.Value a) =>+   Value (Ptr a) -> CodeGenFunction r (NiceValue.T a)+loadPrimitive ptr = fmap NiceValue.Cons $ LLVM.load =<< LLVM.bitcast ptr++storePrimitive ::+   (LLVM.Storable a, NiceValue.Repr a ~ LLVM.Value a) =>+   NiceValue.T a -> Value (Ptr a) -> CodeGenFunction r ()+storePrimitive (NiceValue.Cons a) ptr = LLVM.store a =<< LLVM.bitcast ptr++instance C Float where+   load = loadPrimitive; store = storePrimitive++instance C Double where+   load = loadPrimitive; store = storePrimitive++instance C Word where+   load = loadPrimitive; store = storePrimitive++instance C Word8 where+   load = loadPrimitive; store = storePrimitive++instance C Word16 where+   load = loadPrimitive; store = storePrimitive++instance C Word32 where+   load = loadPrimitive; store = storePrimitive++instance C Word64 where+   load = loadPrimitive; store = storePrimitive++instance C Int where+   load = loadPrimitive; store = storePrimitive++instance C Int8 where+   load = loadPrimitive; store = storePrimitive++instance C Int16 where+   load = loadPrimitive; store = storePrimitive++instance C Int32 where+   load = loadPrimitive; store = storePrimitive++instance C Int64 where+   load = loadPrimitive; store = storePrimitive++{- |+Not very efficient implementation+because we want to adapt to @sizeOf Bool@ dynamically.+Unfortunately, LLVM-9's optimizer does not recognize the instruction pattern.+Better use 'Bool8' for booleans.+-}+instance C Bool where+   load ptr = do+      bytePtr <- castToBytePtr ptr+      bytes <-+         flip MS.evalStateT bytePtr $+            replicateM (Store.sizeOf (False :: Bool))+               (MT.lift . LLVM.load =<< incPtrState)+      let zero = LLVM.valueOf 0+      mask <- foldM A.or zero bytes+      NiceValue.Cons <$> A.cmp LLVM.CmpNE mask zero+   store (NiceValue.Cons b) ptr = do+      bytePtr <- castToBytePtr ptr+      byte <- LLVM.sext b+      flip MS.evalStateT bytePtr $+         replicateM_ (Store.sizeOf (False :: Bool))+            (MT.lift . LLVM.store byte =<< incPtrState)++instance C Bool8 where+   load ptr =+      fmap NiceValue.Cons $+      A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr+   store (NiceValue.Cons b) ptr = do+      byte <- LLVM.zext b+      LLVM.store byte =<< castToBytePtr ptr++instance (C a) => C (Complex a) where+   load = loadApplicative; store = storeFoldable++++instance (Tuple tuple) => C (StoreTuple.Tuple tuple) where+   load ptr = NiceValue.tuple <$> loadTuple ptr+   store = storeTuple . NiceValue.untuple++class (StoreTuple.Storable tuple, NiceValue.C tuple) => Tuple tuple where+   loadTuple ::+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r (NiceValue.T tuple)+   storeTuple ::+      NiceValue.T tuple ->+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r ()++instance (C a, C b) => Tuple (a,b) where+   loadTuple ptr =+      runElements ptr $ fmap (uncurry NiceValue.zip) $+         App.mapPair (loadElement, loadElement) $+         FuncHT.unzip $ proxyFromElement3 ptr+   storeTuple = NiceValue.uncurry $ \a b ptr ->+      case FuncHT.unzip $ proxyFromElement3 ptr of+         (pa,pb) -> runElements ptr $ storeElement pa a >> storeElement pb b++instance (C a, C b, C c) => Tuple (a,b,c) where+   loadTuple ptr =+      runElements ptr $ fmap (uncurry3 NiceValue.zip3) $+         App.mapTriple (loadElement, loadElement, loadElement) $+         FuncHT.unzip3 $ proxyFromElement3 ptr+   storeTuple = NiceValue.uncurry3 $ \a b c ptr ->+      case FuncHT.unzip3 $ proxyFromElement3 ptr of+         (pa,pb,pc) ->+            runElements ptr $+               storeElement pa a >> storeElement pb b >> storeElement pc c++loadElement ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (NiceValue.T a)+loadElement proxy =+   MT.lift . MT.lift . load =<< elementPtr proxy++storeElement ::+   (C a) =>+   LP.Proxy a -> NiceValue.T a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) ()+storeElement proxy a =+   MT.lift . MT.lift . store a =<< elementPtr proxy++elementPtr ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr+      (MS.StateT Int (CodeGenFunction r)) (LLVM.Value (Ptr a))+elementPtr proxy = do+   ptr <- MR.ask+   MT.lift $ do+      offset <- elementOffset proxy+      MT.lift $ castFromBytePtr =<< LLVM.getElementPtr ptr (offset, ())+++instance+   (TypeNum.Positive n, Vector a) =>+      C (LLVM.Vector n a) where+   load ptr =+      fmap NiceValue.Cons $+      assembleVector (proxyFromElement3 ptr) =<< loadApplicativeRepr ptr+   store (NiceValue.Cons a) ptr =+      flip storeFoldableRepr ptr+         =<< disassembleVector (proxyFromElement3 ptr) a++class (C a, NiceVector.C a) => Vector a where+   assembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (NiceValue.Repr a) ->+      CodeGenFunction r (NiceVector.Repr n a)+   disassembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> NiceVector.Repr n a ->+      CodeGenFunction r (LLVM.Vector n (NiceValue.Repr a))++instance Vector Float where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Double where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word16 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word32 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word64 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int16 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int32 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int64 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Bool where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Bool8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive+++instance+   (Tuple tuple, TupleVector tuple) =>+      Vector (StoreTuple.Tuple tuple) where+   assembleVector = deinterleave . fmap StoreTuple.getTuple+   disassembleVector = interleave . fmap StoreTuple.getTuple+++class (NiceVector.C a) => TupleVector a where+   deinterleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (NiceValue.Repr a) ->+      CodeGenFunction r (NiceVector.Repr n a)+   interleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> NiceVector.Repr n a ->+      CodeGenFunction r (LLVM.Vector n (NiceValue.Repr a))++instance (Vector a, Vector b) => TupleVector (a,b) where+   deinterleave = FuncHT.uncurry $ \pa pb -> FuncHT.uncurry $ \a b ->+      App.lift2 (,) (assembleVector pa a) (assembleVector pb b)+   interleave = FuncHT.uncurry $ \pa pb (a,b) ->+      App.lift2 (App.lift2 (,))+         (disassembleVector pa a) (disassembleVector pb b)++instance (Vector a, Vector b, Vector c) => TupleVector (a,b,c) where+   deinterleave = FuncHT.uncurry3 $ \pa pb pc -> FuncHT.uncurry3 $ \a b c ->+      App.lift3 (,,)+         (assembleVector pa a)+         (assembleVector pb b)+         (assembleVector pc c)+   interleave = FuncHT.uncurry3 $ \pa pb pc (a,b,c) ->+      App.lift3 (App.lift3 (,,))+         (disassembleVector pa a)+         (disassembleVector pb b)+         (disassembleVector pc c)+++{-+instance Storable () available since base-4.9/GHC-8.0.+Before we need Data.Orphans.+-}+instance C () where+   load _ptr = return $ NiceValue.Cons ()+   store (NiceValue.Cons ()) _ptr = return ()+++loadTraversable ::+   (NonEmptyC.Repeat f, Trav.Traversable f,+    C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) =>+   Value (Ptr (f a)) -> CodeGenFunction r (NiceValue.T fa)+loadTraversable =+   (MS.evalStateT $ fmap NiceValue.Cons $+    Trav.sequence $ NonEmptyC.repeat $ loadState)+      <=< castElementPtr++loadApplicative ::+   (Applicative f, Trav.Traversable f,+    C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) =>+   Value (Ptr (f a)) -> CodeGenFunction r (NiceValue.T fa)+loadApplicative = fmap NiceValue.Cons . loadApplicativeRepr++loadApplicativeRepr ::+   (Applicative f, Trav.Traversable f, C a) =>+   Value (Ptr (f a)) -> CodeGenFunction r (f (NiceValue.Repr a))+loadApplicativeRepr =+   (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr++loadState ::+   (C a, NiceValue.Repr a ~ al) =>+   MS.StateT (Value (Ptr a)) (CodeGenFunction r) al+loadState =+   MT.lift . fmap (\(NiceValue.Cons a) -> a) . load =<< advancePtrState+++storeFoldable ::+   (Fold.Foldable f, C a, NiceValue.Repr fa ~ f (NiceValue.Repr a)) =>+    NiceValue.T fa -> Value (Ptr (f a)) -> CodeGenFunction r ()+storeFoldable (NiceValue.Cons xs) = storeFoldableRepr xs++storeFoldableRepr ::+   (Fold.Foldable f, C a) =>+   f (NiceValue.Repr a) -> Value (Ptr (f a)) -> CodeGenFunction r ()+storeFoldableRepr xs =+   MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr++storeState ::+   (C a, NiceValue.Repr a ~ al) =>+   al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) ()+storeState a = MT.lift . store (NiceValue.Cons a) =<< advancePtrState+++advancePtrState ::+   (C a, Value (Ptr a) ~ ptr) =>+   MS.StateT ptr (CodeGenFunction r) ptr+advancePtrState = update $ advancePtrStatic 1
+ src/LLVM/Extra/Nice/Value/Vector.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module LLVM.Extra.Nice.Value.Vector (+   cons,+   fst, snd,+   fst3, snd3, thd3,+   zip, zip3,+   unzip, unzip3,++   swap,+   mapFst, mapSnd,+   mapFst3, mapSnd3, mapThd3,++   extract, insert,+   replicate,+   iterate,+   dissect,+   dissect1,+   select,+   cmp,+   take, takeRev,++   NativeInteger,+   NativeFloating,+   fromIntegral,+   truncateToInt,+   splitFractionToInt,+   ) where++import qualified LLVM.Extra.Nice.Vector.Instance as Inst+import qualified LLVM.Extra.Nice.Vector as NiceVector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.ScalarOrVector as SoV+import LLVM.Extra.Nice.Vector.Instance (NVVector)++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+++import qualified Data.NonEmpty as NonEmpty+import qualified Data.Tuple.HT as TupleHT+import qualified Data.Tuple as Tuple+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64, Int)++import Prelude (Float, Double, Bool, fmap, (.))+++cons ::+   (TypeNum.Positive n, NiceVector.C a) =>+   LLVM.Vector n a -> NVVector n a+cons = Inst.toNiceValue . NiceVector.cons++fst :: NVVector n (a,b) -> NVVector n a+fst = NiceValue.lift1 Tuple.fst++snd :: NVVector n (a,b) -> NVVector n b+snd = NiceValue.lift1 Tuple.snd++swap :: NVVector n (a,b) -> NVVector n (b,a)+swap = NiceValue.lift1 TupleHT.swap++mapFst ::+   (NVVector n a0 -> NVVector n a1) ->+   NVVector n (a0,b) -> NVVector n (a1,b)+mapFst f = Tuple.uncurry zip . TupleHT.mapFst f . unzip++mapSnd ::+   (NVVector n b0 -> NVVector n b1) ->+   NVVector n (a,b0) -> NVVector n (a,b1)+mapSnd f = Tuple.uncurry zip . TupleHT.mapSnd f . unzip+++fst3 :: NVVector n (a,b,c) -> NVVector n a+fst3 = NiceValue.lift1 TupleHT.fst3++snd3 :: NVVector n (a,b,c) -> NVVector n b+snd3 = NiceValue.lift1 TupleHT.snd3++thd3 :: NVVector n (a,b,c) -> NVVector n c+thd3 = NiceValue.lift1 TupleHT.thd3++mapFst3 ::+   (NVVector n a0 -> NVVector n a1) ->+   NVVector n (a0,b,c) -> NVVector n (a1,b,c)+mapFst3 f = TupleHT.uncurry3 zip3 . TupleHT.mapFst3 f . unzip3++mapSnd3 ::+   (NVVector n b0 -> NVVector n b1) ->+   NVVector n (a,b0,c) -> NVVector n (a,b1,c)+mapSnd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapSnd3 f . unzip3++mapThd3 ::+   (NVVector n c0 -> NVVector n c1) ->+   NVVector n (a,b,c0) -> NVVector n (a,b,c1)+mapThd3 f = TupleHT.uncurry3 zip3 . TupleHT.mapThd3 f . unzip3+++zip :: NVVector n a -> NVVector n b -> NVVector n (a,b)+zip (NiceValue.Cons a) (NiceValue.Cons b) = NiceValue.Cons (a,b)++zip3 :: NVVector n a -> NVVector n b -> NVVector n c -> NVVector n (a,b,c)+zip3 (NiceValue.Cons a) (NiceValue.Cons b) (NiceValue.Cons c) =+   NiceValue.Cons (a,b,c)++unzip :: NVVector n (a,b) -> (NVVector n a, NVVector n b)+unzip (NiceValue.Cons (a,b)) = (NiceValue.Cons a, NiceValue.Cons b)++unzip3 :: NVVector n (a,b,c) -> (NVVector n a, NVVector n b, NVVector n c)+unzip3 (NiceValue.Cons (a,b,c)) =+   (NiceValue.Cons a, NiceValue.Cons b, NiceValue.Cons c)+++extract ::+   (TypeNum.Positive n, NiceVector.C a) =>+   LLVM.Value Word32 -> NVVector n a ->+   LLVM.CodeGenFunction r (NiceValue.T a)+extract k v = NiceVector.extract k (Inst.fromNiceValue v)++insert ::+   (TypeNum.Positive n, NiceVector.C a) =>+   LLVM.Value Word32 -> NiceValue.T a ->+   NVVector n a -> LLVM.CodeGenFunction r (NVVector n a)+insert k a = Inst.liftNiceValueM (NiceVector.insert k a)+++replicate ::+   (TypeNum.Positive n, NiceVector.C a) =>+   NiceValue.T a -> LLVM.CodeGenFunction r (NVVector n a)+replicate = fmap Inst.toNiceValue . NiceVector.replicate++iterate ::+   (TypeNum.Positive n, NiceVector.C a) =>+   (NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T a)) ->+   NiceValue.T a -> LLVM.CodeGenFunction r (NVVector n a)+iterate f = fmap Inst.toNiceValue . NiceVector.iterate f++take ::+   (TypeNum.Positive n, TypeNum.Positive m, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r (NVVector m a)+take = Inst.liftNiceValueM NiceVector.take++takeRev ::+   (TypeNum.Positive n, TypeNum.Positive m, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r (NVVector m a)+takeRev = Inst.liftNiceValueM NiceVector.takeRev+++dissect ::+   (TypeNum.Positive n, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r [NiceValue.T a]+dissect = NiceVector.dissect . Inst.fromNiceValue++dissect1 ::+   (TypeNum.Positive n, NiceVector.C a) =>+   NVVector n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a))+dissect1 = NiceVector.dissect1 . Inst.fromNiceValue++select ::+   (TypeNum.Positive n, NiceVector.Select a) =>+   NVVector n Bool ->+   NVVector n a -> NVVector n a ->+   LLVM.CodeGenFunction r (NVVector n a)+select = Inst.liftNiceValueM3 NiceVector.select++cmp ::+   (TypeNum.Positive n, NiceVector.Comparison a) =>+   LLVM.CmpPredicate ->+   NVVector n a -> NVVector n a ->+   LLVM.CodeGenFunction r (NVVector n Bool)+cmp = Inst.liftNiceValueM2 . NiceVector.cmp+++{-+ToDo: make this a super-class of NiceValue.NativeInteger+problem: we need NiceValue.Repr, which provokes an import cycle+maybe we should break the cycle using a ConstraintKind,+i.e. define class NativeIntegerVec in NiceValue,+and define NativeInteger = NiceValue.NativeIntegerVec here+and export only NiceValueVec.NativeInteger constraint synonym.+-}+class+   (NiceValue.Repr i ~ LLVM.Value ir,+    LLVM.CmpRet ir, LLVM.IsInteger ir, SoV.IntegerConstant ir) =>+      NativeInteger i ir where++instance NativeInteger Word   Word   where+instance NativeInteger Word8  Word8  where+instance NativeInteger Word16 Word16 where+instance NativeInteger Word32 Word32 where+instance NativeInteger Word64 Word64 where++instance NativeInteger Int   Int   where+instance NativeInteger Int8  Int8  where+instance NativeInteger Int16 Int16 where+instance NativeInteger Int32 Int32 where+instance NativeInteger Int64 Int64 where++instance+   (TypeNum.Positive n, n ~ m,+    NiceVector.NativeInteger n i ir,+    NiceValue.NativeInteger i ir) =>+      NativeInteger (LLVM.Vector n i) (LLVM.Vector m ir) where+++class+   (NiceValue.Repr a ~ LLVM.Value ar,+    LLVM.CmpRet ar,  SoV.RationalConstant ar, LLVM.IsFloating ar) =>+      NativeFloating a ar where++instance NativeFloating Float  Float  where+instance NativeFloating Double Double where++instance+   (TypeNum.Positive n, n ~ m,+    NiceVector.NativeFloating n a ar,+    NiceValue.NativeFloating a ar) =>+      NativeFloating (LLVM.Vector n a) (LLVM.Vector m ar) where++fromIntegral ::+   (NativeInteger i ir, NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   NiceValue.T i -> LLVM.CodeGenFunction r (NiceValue.T a)+fromIntegral = NiceValue.liftM LLVM.inttofp+++truncateToInt ::+   (NativeInteger i ir, NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T i)+truncateToInt = NiceValue.liftM LLVM.fptoint++splitFractionToInt ::+   (NativeInteger i ir, NativeFloating a ar,+    LLVM.ShapeOf ir ~ LLVM.ShapeOf ar) =>+   NiceValue.T a -> LLVM.CodeGenFunction r (NiceValue.T (i,a))+splitFractionToInt = NiceValue.liftM SoV.splitFractionToInt
+ src/LLVM/Extra/Nice/Vector.hs view
@@ -0,0 +1,1346 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Nice.Vector (+   T(Cons), consPrim, deconsPrim,+   C(..),+   Value,+   map,+   zip, zip3, unzip, unzip3,+   replicate,+   iterate,+   take,+   takeRev,++   sum,+   dotProduct,+   cumulate,+   cumulate1,++   lift1,++   modify,+   assemble,+   dissect,+   dissectList,++   assemble1,+   dissect1,+   dissectList1,++   assembleFromVector,+   consVarArg,++   reverse,+   rotateUp,+   rotateDown,+   shiftUp,+   shiftDown,+   shiftUpMultiZero,+   shiftDownMultiZero,+   shiftUpMultiUndef,+   shiftDownMultiUndef,++   undefPrimitive,+   shufflePrimitive,+   extractPrimitive,+   insertPrimitive,++   shuffleMatchTraversable,+   insertTraversable,+   extractTraversable,++   IntegerConstant(..),+   RationalConstant(..),+   Additive(..),+   PseudoRing(..),+   Field(..),+   scale,+   PseudoModule(..),+   Real(..),+   Fraction(..),+   NativeInteger, NativeFloating, fromIntegral,+   Algebraic(..),+   Transcendental(..),+   FloatingComparison(..),+   Select(..),+   Comparison(..),+   Logic(..),+   BitShift(..),+   ) where++import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, IsPrimitive, valueOf, value, )++import qualified Type.Data.Num.Decimal as TypeNum+import qualified Type.Data.Num.Decimal as Dec+import qualified Type.Data.Num.Unary as Unary++import qualified Foreign.Storable.Record.Tuple as StoreTuple++import qualified Data.Traversable as Trav+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List as List+import qualified Data.Bool8 as Bool8+import Data.Traversable (mapM, sequence, )+import Data.Foldable (foldlM)+import Data.NonEmpty ((!:), )+import Data.Function (flip, (.), ($), )+import Data.Tuple (snd, )+import Data.Maybe (maybe, )+import Data.Ord ((<), )+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int (Int8, Int16, Int32, Int64, )+import Data.Bool8 (Bool8)+import Data.Bool (Bool, )++import qualified Control.Monad.HT as Monad+import qualified Control.Applicative as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad.HT ((<=<), )+import Control.Monad (Monad, join, fmap, return, (>>), (=<<))+import Control.Applicative (liftA2, (<$>))++import qualified Prelude as P+import Prelude+         (Float, Double, Integer, Int, Rational, asTypeOf, (-), (+), (*), error)+++newtype T n a = Cons (Repr n a)++type Value n a = LLVM.Value (LLVM.Vector n a)+++consPrim :: (Repr n a ~ Value n ar) => Value n ar -> T n a+consPrim = Cons++deconsPrim :: (Repr n a ~ Value n ar) => T n a -> Value n ar+deconsPrim (Cons a) = a+++instance (TypeNum.Positive n, C a) => Tuple.Undefined (T n a) where+   undef = undef++instance (TypeNum.Positive n, C a) => Tuple.Zero (T n a) where+   zero = zero++instance (TypeNum.Positive n, C a) => Tuple.Phi (T n a) where+   phi = phi+   addPhi = addPhi+++sizeS :: TypeNum.Positive n => T n a -> TypeNum.Singleton n+sizeS _ = TypeNum.singleton++size :: (TypeNum.Positive n, P.Integral i) => T n a -> i+size = TypeNum.integralFromSingleton . sizeS++last ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (NiceValue.T a)+last x = extract (valueOf (size x - 1)) x+++zip :: T n a -> T n b -> T n (a,b)+zip (Cons a) (Cons b) = Cons (a,b)++zip3 :: T n a -> T n b -> T n c -> T n (a,b,c)+zip3 (Cons a) (Cons b) (Cons c) = Cons (a,b,c)++unzip :: T n (a,b) -> (T n a, T n b)+unzip (Cons (a,b)) = (Cons a, Cons b)++unzip3 :: T n (a,b,c) -> (T n a, T n b, T n c)+unzip3 (Cons (a,b,c)) = (Cons a, Cons b, Cons c)+++class (NiceValue.C a) => C a where+   type Repr n a+   cons :: (TypeNum.Positive n) => LLVM.Vector n a -> T n a+   undef :: (TypeNum.Positive n) => T n a+   zero :: (TypeNum.Positive n) => T n a+   phi ::+      (TypeNum.Positive n) =>+      LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)+   addPhi ::+      (TypeNum.Positive n) =>+      LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()++   shuffle ::+      (TypeNum.Positive n, TypeNum.Positive m) =>+      LLVM.ConstValue (LLVM.Vector m Word32) -> T n a -> T n a ->+      CodeGenFunction r (T m a)+   extract ::+      (TypeNum.Positive n) =>+      LLVM.Value Word32 -> T n a -> CodeGenFunction r (NiceValue.T a)+   insert ::+      (TypeNum.Positive n) =>+      LLVM.Value Word32 -> NiceValue.T a ->+      T n a -> CodeGenFunction r (T n a)++instance C Bool where+   type Repr n Bool = LLVM.Value (LLVM.Vector n Bool)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Bool8 where+   type Repr n Bool8 = LLVM.Value (LLVM.Vector n Bool)+   cons = consPrimitive . fmap Bool8.toBool+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Float where+   type Repr n Float = LLVM.Value (LLVM.Vector n Float)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Double where+   type Repr n Double = LLVM.Value (LLVM.Vector n Double)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int where+   type Repr n Int = LLVM.Value (LLVM.Vector n Int)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int8 where+   type Repr n Int8 = LLVM.Value (LLVM.Vector n Int8)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int16 where+   type Repr n Int16 = LLVM.Value (LLVM.Vector n Int16)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int32 where+   type Repr n Int32 = LLVM.Value (LLVM.Vector n Int32)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Int64 where+   type Repr n Int64 = LLVM.Value (LLVM.Vector n Int64)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word where+   type Repr n Word = LLVM.Value (LLVM.Vector n Word)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word8 where+   type Repr n Word8 = LLVM.Value (LLVM.Vector n Word8)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word16 where+   type Repr n Word16 = LLVM.Value (LLVM.Vector n Word16)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word32 where+   type Repr n Word32 = LLVM.Value (LLVM.Vector n Word32)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++instance C Word64 where+   type Repr n Word64 = LLVM.Value (LLVM.Vector n Word64)+   cons = consPrimitive+   undef = undefPrimitive+   zero = zeroPrimitive+   phi = phiPrimitive+   addPhi = addPhiPrimitive+   shuffle = shufflePrimitive+   extract = extractPrimitive+   insert = insertPrimitive++consPrimitive ::+   (TypeNum.Positive n, LLVM.IsConst al, IsPrimitive al,+    Repr n a ~ Value n al) =>+   LLVM.Vector n al -> T n a+consPrimitive = Cons . LLVM.valueOf++undefPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    Repr n a ~ Value n al) =>+   T n a+undefPrimitive = Cons $ LLVM.value LLVM.undef++zeroPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    Repr n a ~ Value n al) =>+   T n a+zeroPrimitive = Cons $ LLVM.value LLVM.zero++phiPrimitive ::+   (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) =>+   LLVM.BasicBlock -> T n a -> LLVM.CodeGenFunction r (T n a)+phiPrimitive bb (Cons a) = fmap Cons $ Tuple.phi bb a++addPhiPrimitive ::+   (TypeNum.Positive n, IsPrimitive al, Repr n a ~ Value n al) =>+   LLVM.BasicBlock -> T n a -> T n a -> LLVM.CodeGenFunction r ()+addPhiPrimitive bb (Cons a) (Cons b) = Tuple.addPhi bb a b+++shufflePrimitive ::+   (TypeNum.Positive n, TypeNum.Positive m, IsPrimitive al,+    NiceValue.Repr a ~ LLVM.Value al,+    Repr n a ~ Value n al,+    Repr m a ~ Value m al) =>+   LLVM.ConstValue (LLVM.Vector m Word32) ->+   T n a -> T n a -> CodeGenFunction r (T m a)+shufflePrimitive k (Cons u) (Cons v) =+   fmap Cons $ LLVM.shufflevector u v k++extractPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    NiceValue.Repr a ~ LLVM.Value al,+    Repr n a ~ Value n al) =>+   LLVM.Value Word32 -> T n a -> CodeGenFunction r (NiceValue.T a)+extractPrimitive k (Cons v) =+   fmap NiceValue.Cons $ LLVM.extractelement v k++insertPrimitive ::+   (TypeNum.Positive n, IsPrimitive al,+    NiceValue.Repr a ~ LLVM.Value al,+    Repr n a ~ Value n al) =>+   LLVM.Value Word32 ->+   NiceValue.T a -> T n a -> CodeGenFunction r (T n a)+insertPrimitive k (NiceValue.Cons a) (Cons v) =+   fmap Cons $ LLVM.insertelement v a k+++instance (C a, C b) => C (a,b) where+   type Repr n (a,b) = (Repr n a, Repr n b)+   cons v = case FuncHT.unzip v of (a,b) -> zip (cons a) (cons b)+   undef = zip undef undef+   zero = zip zero zero++   phi bb a =+      case unzip a of+         (a0,a1) ->+            Monad.lift2 zip (phi bb a0) (phi bb a1)+   addPhi bb a b =+      case (unzip a, unzip b) of+         ((a0,a1), (b0,b1)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1++   shuffle is u v =+      case (unzip u, unzip v) of+         ((u0,u1), (v0,v1)) ->+            Monad.lift2 zip+               (shuffle is u0 v0)+               (shuffle is u1 v1)++   extract k v =+      case unzip v of+         (v0,v1) ->+            Monad.lift2 NiceValue.zip+               (extract k v0)+               (extract k v1)++   insert k a v =+      case (NiceValue.unzip a, unzip v) of+         ((a0,a1), (v0,v1)) ->+            Monad.lift2 zip+               (insert k a0 v0)+               (insert k a1 v1)+++instance (C a, C b, C c) => C (a,b,c) where+   type Repr n (a,b,c) = (Repr n a, Repr n b, Repr n c)+   cons v = case FuncHT.unzip3 v of (a,b,c) -> zip3 (cons a) (cons b) (cons c)+   undef = zip3 undef undef undef+   zero = zip3 zero zero zero++   phi bb a =+      case unzip3 a of+         (a0,a1,a2) ->+            Monad.lift3 zip3 (phi bb a0) (phi bb a1) (phi bb a2)+   addPhi bb a b =+      case (unzip3 a, unzip3 b) of+         ((a0,a1,a2), (b0,b1,b2)) ->+            addPhi bb a0 b0 >>+            addPhi bb a1 b1 >>+            addPhi bb a2 b2++   shuffle is u v =+      case (unzip3 u, unzip3 v) of+         ((u0,u1,u2), (v0,v1,v2)) ->+            Monad.lift3 zip3+               (shuffle is u0 v0)+               (shuffle is u1 v1)+               (shuffle is u2 v2)++   extract k v =+      case unzip3 v of+         (v0,v1,v2) ->+            Monad.lift3 NiceValue.zip3+               (extract k v0)+               (extract k v1)+               (extract k v2)++   insert k a v =+      case (NiceValue.unzip3 a, unzip3 v) of+         ((a0,a1,a2), (v0,v1,v2)) ->+            Monad.lift3 zip3+               (insert k a0 v0)+               (insert k a1 v1)+               (insert k a2 v2)+++instance (C tuple) => C (StoreTuple.Tuple tuple) where+   type Repr n (StoreTuple.Tuple tuple) = Repr n tuple+   cons = tuple . cons . fmap StoreTuple.getTuple+   undef = tuple undef+   zero = tuple zero+   phi bb = fmap tuple . phi bb . untuple+   addPhi bb a b = addPhi bb (untuple a) (untuple b)+   shuffle is u v = tuple <$> shuffle is (untuple u) (untuple v)+   extract k v = NiceValue.tuple <$> extract k (untuple v)+   insert k a v = tuple <$> insert k (NiceValue.untuple a) (untuple v)++tuple :: T n tuple -> T n (StoreTuple.Tuple tuple)+tuple (Cons a) = Cons a++untuple :: T n (StoreTuple.Tuple tuple) -> T n tuple+untuple (Cons a) = Cons a+++class (NiceValue.IntegerConstant a, C a) => IntegerConstant a where+   fromInteger' :: (TypeNum.Positive n) => Integer -> T n a++class+   (NiceValue.RationalConstant a, IntegerConstant a) =>+      RationalConstant a where+   fromRational' :: (TypeNum.Positive n) => Rational -> T n a++instance IntegerConstant Float  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Double where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word   where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word8  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word16 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word32 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Word64 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int   where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int8  where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int16 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int32 where fromInteger' = fromIntegerPrimitive+instance IntegerConstant Int64 where fromInteger' = fromIntegerPrimitive++fromIntegerPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, SoV.IntegerConstant a,+    Repr n a ~ Value n a) =>+   Integer -> T n a+fromIntegerPrimitive = Cons . LLVM.value . SoV.constFromInteger++instance RationalConstant Float  where fromRational' = fromRationalPrimitive+instance RationalConstant Double where fromRational' = fromRationalPrimitive++fromRationalPrimitive ::+   (TypeNum.Positive n, IsPrimitive a, SoV.RationalConstant a,+    Repr n a ~ Value n a) =>+   Rational -> T n a+fromRationalPrimitive = Cons . LLVM.value . SoV.constFromRational++instance+   (TypeNum.Positive n, IntegerConstant a) =>+      A.IntegerConstant (T n a) where+   fromInteger' = fromInteger'++instance+   (TypeNum.Positive n, RationalConstant a) =>+      A.RationalConstant (T n a) where+   fromRational' = fromRational'+++modify ::+   (TypeNum.Positive n, C a) =>+   LLVM.Value Word32 ->+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) ->+   (T n a -> CodeGenFunction r (T n a))+modify k f v =+   flip (insert k) v =<< f =<< extract k v+++assemble ::+   (TypeNum.Positive n, C a) =>+   [NiceValue.T a] -> CodeGenFunction r (T n a)+assemble =+   foldlM (\v (k,x) -> insert (valueOf k) x v) undef .+   List.zip [0..]++dissect ::+   (TypeNum.Positive n, C a) =>+   T n a -> LLVM.CodeGenFunction r [NiceValue.T a]+dissect = sequence . dissectList++dissectList ::+   (TypeNum.Positive n, C a) =>+   T n a -> [LLVM.CodeGenFunction r (NiceValue.T a)]+dissectList x =+   List.map+      (flip extract x . LLVM.valueOf)+      (List.take (size x) [0..])+++assemble1 ::+   (TypeNum.Positive n, C a) =>+   NonEmpty.T [] (NiceValue.T a) -> CodeGenFunction r (T n a)+assemble1 = assemble . NonEmpty.flatten++dissect1 ::+   (TypeNum.Positive n, C a) =>+   T n a -> LLVM.CodeGenFunction r (NonEmpty.T [] (NiceValue.T a))+dissect1 = sequence . dissectList1++dissectList1 ::+   (TypeNum.Positive n, C a) =>+   T n a -> NonEmpty.T [] (LLVM.CodeGenFunction r (NiceValue.T a))+dissectList1 x =+   fmap+      (flip extract x . LLVM.valueOf)+      (0 !: List.take (size x - 1) [1 ..])+++assembleFromVector ::+   (TypeNum.Positive n, C a) =>+   LLVM.Vector n (NiceValue.T a) -> CodeGenFunction r (T n a)+assembleFromVector =+   fmap snd .+   foldlM (\(k,v) x -> (,) (k+1) <$> insert (valueOf k) x v) (0,undef)+++type family VectorSize v+type instance VectorSize (T n a) = n++type family VectorElement v+type instance VectorElement (T n a) = a++class+   (Dec.Positive n, C a, ResultRet f ~ r,+    VectorSize (ResultVector f) ~ n, VectorElement (ResultVector f) ~ a) =>+      Cons r n a f where+   type NumberOfArguments f+   type ResultRet f+   type ResultVector f+   consAux :: Word32 -> CodeGenFunction r (T n a) -> f++instance+   (Dec.Positive n, C a, r0 ~ r, T n a ~ v) =>+      Cons r0 n a (CodeGenFunction r v) where+   type NumberOfArguments (CodeGenFunction r v) = Unary.Zero+   type ResultRet (CodeGenFunction r v) = r+   type ResultVector (CodeGenFunction r v) = v+   consAux _ mv = mv++instance (NiceValue.T a ~ arg, Cons r n a f) => Cons r n a (arg -> f) where+   type NumberOfArguments (arg -> f) = Unary.Succ (NumberOfArguments f)+   type ResultRet (arg -> f) = ResultRet f+   type ResultVector (arg -> f) = ResultVector f+   consAux k mv x = consAux (k+1) (insert (LLVM.valueOf k) x =<< mv)++consVarArg ::+   (Cons r n a f, NumberOfArguments f ~ u,+    u ~ Dec.ToUnary n, Dec.FromUnary u ~ n, Dec.Natural n) =>+   f+consVarArg = consAux 0 (return undef)++++map ::+   (TypeNum.Positive n, C a, C b) =>+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T b)) ->+   (T n a -> CodeGenFunction r (T n b))+map f  =  assemble <=< mapM f <=< dissect+++singleton :: (C a) => NiceValue.T a -> CodeGenFunction r (T TypeNum.D1 a)+singleton x = insert (LLVM.value LLVM.zero) x undef++replicate ::+   (TypeNum.Positive n, C a) =>+   NiceValue.T a -> CodeGenFunction r (T n a)+replicate x = do+   single <- singleton x+   shuffle (constCyclicVector $ NonEmpty.singleton 0) single undef++iterate ::+   (TypeNum.Positive n, C a) =>+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) ->+   NiceValue.T a -> CodeGenFunction r (T n a)+iterate f x = fmap snd $ iterateCore f x Tuple.undef++iterateCore ::+   (TypeNum.Positive n, C a) =>+   (NiceValue.T a -> CodeGenFunction r (NiceValue.T a)) ->+   NiceValue.T a -> T n a ->+   CodeGenFunction r (NiceValue.T a, T n a)+iterateCore f x0 v0 =+   foldlM+      (\(x,v) k -> Monad.lift2 (,) (f x) (insert (valueOf k) x v))+      (x0,v0)+      (List.take (size v0) [0..])+++sum ::+   (TypeNum.Positive n, Additive a) =>+   T n a -> CodeGenFunction r (NiceValue.T a)+sum =+   NonEmpty.foldBalanced (\x y -> join $ liftA2 NiceValue.add x y) .+   dissectList1++dotProduct ::+   (TypeNum.Positive n, PseudoRing a) =>+   T n a -> T n a -> CodeGenFunction r (NiceValue.T a)+dotProduct x y = sum =<< mul x y+++cumulate ::+   (TypeNum.Positive n, Additive a) =>+   NiceValue.T a -> T n a ->+   CodeGenFunction r (NiceValue.T a, T n a)+cumulate a x0 = do+   (b,x1) <- shiftUp a x0+   y <- cumulate1 x1+   z <- A.add b =<< last y+   return (z,y)++{- |+Needs (log n) vector additions+-}+cumulate1 ::+   (TypeNum.Positive n, Additive a) =>+   T n a -> CodeGenFunction r (T n a)+cumulate1 x =+   foldlM+      (\y k -> A.add y =<< shiftUpMultiZero k y)+      x+      (List.takeWhile (< size x) $ List.iterate (2*) 1)+++-- * re-ordering of elements++constCyclicVector ::+   (LLVM.IsConst a, TypeNum.Positive n) =>+   NonEmpty.T [] a -> LLVM.ConstValue (LLVM.Vector n a)+constCyclicVector =+   LLVM.constCyclicVector . fmap LLVM.constOf++shuffleMatch ::+   (TypeNum.Positive n, C a) =>+   LLVM.ConstValue (LLVM.Vector n Word32) -> T n a ->+   CodeGenFunction r (T n a)+shuffleMatch k v = shuffle k v undef++{- |+Rotate one element towards the higher elements.++I don't want to call it rotateLeft or rotateRight,+because there is no prefered layout for the vector elements.+In Intel's instruction manual vector+elements are indexed like the bits,+that is from right to left.+However, when working with Haskell list and enumeration syntax,+the start index is left.+-}+rotateUp ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+rotateUp x =+   shuffleMatch (constCyclicVector $ (size x - 1) !: [0..]) x++rotateDown ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+rotateDown x =+   shuffleMatch+      (constCyclicVector $+       NonEmpty.snoc (List.take (size x - 1) [1..]) 0) x++reverse ::+   (TypeNum.Positive n, C a) =>+   T n a -> CodeGenFunction r (T n a)+reverse x =+   shuffleMatch+      (constCyclicVector $+       maybe (error "vector size must be positive") NonEmpty.reverse $+       NonEmpty.fetch $+       List.take (size x) [0..])+      x++take ::+   (TypeNum.Positive n, TypeNum.Positive m, C a) =>+   T n a -> CodeGenFunction r (T m a)+take u = shuffle (constCyclicVector $ NonEmptyC.iterate (1+) 0) u undef++takeRev ::+   (TypeNum.Positive n, TypeNum.Positive m, C a) =>+   T n a -> CodeGenFunction r (T m a)+takeRev u = do+   let v0 = zero+   v <-+      shuffle+         (constCyclicVector $ NonEmptyC.iterate (1+) (size u - size v0))+         u undef+   return $ v `asTypeOf` v0++shiftUp ::+   (TypeNum.Positive n, C a) =>+   NiceValue.T a -> T n a -> CodeGenFunction r (NiceValue.T a, T n a)+shiftUp x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $ LLVM.undef !: List.map LLVM.constOf [0..]) x+   Monad.lift2 (,) (last x) (insert (value LLVM.zero) x0 y)++shiftDown ::+   (TypeNum.Positive n, C a) =>+   NiceValue.T a -> T n a -> CodeGenFunction r (NiceValue.T a, T n a)+shiftDown x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $+          NonEmpty.snoc+             (List.map LLVM.constOf $ List.take (size x - 1) [1..])+             LLVM.undef) x+   Monad.lift2 (,)+      (extract (value LLVM.zero) x)+      (insert (LLVM.valueOf (size x - 1)) x0 y)++shiftUpMultiIndices ::+   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)+shiftUpMultiIndices n sizev =+   constCyclicVector $ fmap P.fromIntegral $+   NonEmpty.appendLeft (List.replicate n sizev) (NonEmptyC.iterate (1+) 0)++shiftDownMultiIndices ::+   (TypeNum.Positive n) => Int -> Int -> LLVM.ConstValue (LLVM.Vector n Word32)+shiftDownMultiIndices n sizev =+   constCyclicVector $ fmap P.fromIntegral $+   NonEmpty.appendLeft+      (List.takeWhile (< sizev) $ List.iterate (1+) n)+      (NonEmptyC.repeat sizev)++shiftUpMultiZero ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftUpMultiZero n v =+   shuffle (shiftUpMultiIndices n (size v)) v zero++shiftDownMultiZero ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftDownMultiZero n v =+   shuffle (shiftDownMultiIndices n (size v)) v zero++shiftUpMultiUndef ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftUpMultiUndef n v =+   shuffle (shiftUpMultiIndices n (size v)) v undef++shiftDownMultiUndef ::+   (TypeNum.Positive n, C a) =>+   Int -> T n a -> LLVM.CodeGenFunction r (T n a)+shiftDownMultiUndef n v =+   shuffle (shiftDownMultiIndices n (size v)) v undef+++-- * method implementations based on Traversable++shuffleMatchTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f) =>+   LLVM.ConstValue (LLVM.Vector n Word32) ->+   f (T n a) -> CodeGenFunction r (f (T n a))+shuffleMatchTraversable is v =+   Trav.mapM (shuffleMatch is) v++insertTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f, App.Applicative f) =>+   LLVM.Value Word32 -> f (NiceValue.T a) ->+   f (T n a) -> CodeGenFunction r (f (T n a))+insertTraversable n a v =+   Trav.sequence (liftA2 (insert n) a v)++extractTraversable ::+   (TypeNum.Positive n, C a, Trav.Traversable f) =>+   LLVM.Value Word32 -> f (T n a) ->+   CodeGenFunction r (f (NiceValue.T a))+extractTraversable n v =+   Trav.mapM (extract n) v++++lift1 :: (Repr n a -> Repr n b) -> T n a -> T n b+lift1 f (Cons a) = Cons $ f a++_liftM0 ::+   (Monad m) =>+   m (Repr n a) ->+   m (T n a)+_liftM0 f = Monad.lift Cons f++liftM0 ::+   (Monad m,+    Repr n a ~ Value n ar) =>+   m (Value n ar) ->+   m (T n a)+liftM0 f = Monad.lift consPrim f++liftM ::+   (Monad m,+    Repr n a ~ Value n ar,+    Repr n b ~ Value n br) =>+   (Value n ar -> m (Value n br)) ->+   T n a -> m (T n b)+liftM f a = Monad.lift consPrim $ f (deconsPrim a)++liftM2 ::+   (Monad m,+    Repr n a ~ Value n ar,+    Repr n b ~ Value n br,+    Repr n c ~ Value n cr) =>+   (Value n ar -> Value n br -> m (Value n cr)) ->+   T n a -> T n b -> m (T n c)+liftM2 f a b = Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b)++liftM3 ::+   (Monad m,+    Repr n a ~ Value n ar,+    Repr n b ~ Value n br,+    Repr n c ~ Value n cr,+    Repr n d ~ Value n dr) =>+   (Value n ar -> Value n br -> Value n cr -> m (Value n dr)) ->+   T n a -> T n b -> T n c -> m (T n d)+liftM3 f a b c =+   Monad.lift consPrim $ f (deconsPrim a) (deconsPrim b) (deconsPrim c)++++class (NiceValue.Additive a, C a) => Additive a where+   add ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   sub ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   neg ::+      (TypeNum.Positive n) =>+      T n a -> LLVM.CodeGenFunction r (T n a)++instance Additive Float where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Double where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int8 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int16 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int32 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Int64 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word8 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word16 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word32 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance Additive Word64 where+   add = liftM2 LLVM.add; sub = liftM2 LLVM.sub; neg = liftM LLVM.neg++instance (TypeNum.Positive n, Additive a) => A.Additive (T n a) where+   zero = zero+   add = add+   sub = sub+   neg = neg+++class (NiceValue.PseudoRing a, Additive a) => PseudoRing a where+   mul ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance PseudoRing Float where+   mul = liftM2 LLVM.mul++instance PseudoRing Double where+   mul = liftM2 LLVM.mul++instance (TypeNum.Positive n, PseudoRing a) => A.PseudoRing (T n a) where+   mul = mul+++class (NiceValue.Field a, PseudoRing a) => Field a where+   fdiv ::+      (TypeNum.Positive n) =>+      T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance Field Float where+   fdiv = liftM2 LLVM.fdiv++instance Field Double where+   fdiv = liftM2 LLVM.fdiv++instance (TypeNum.Positive n, Field a) => A.Field (T n a) where+   fdiv = fdiv+++scale ::+   (TypeNum.Positive n, PseudoRing a) =>+   NiceValue.T a -> T n a -> LLVM.CodeGenFunction r (T n a)+scale a v = flip mul v =<< replicate a+++type instance A.Scalar (T n a) = T n (NiceValue.Scalar a)++class+   (NiceValue.PseudoModule v, PseudoRing (NiceValue.Scalar v), Additive v) =>+      PseudoModule v where+   scaleMulti ::+      (TypeNum.Positive n) =>+      T n (NiceValue.Scalar v) -> T n v -> LLVM.CodeGenFunction r (T n v)++instance PseudoModule Float where+   scaleMulti = liftM2 A.mul++instance PseudoModule Double where+   scaleMulti = liftM2 A.mul++instance (TypeNum.Positive n, PseudoModule a) => A.PseudoModule (T n a) where+   scale = scaleMulti+++class (NiceValue.Real a, Additive a) => Real a where+   min :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   max :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   abs :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   signum :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Real Float where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Double where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Word64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int8 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int16 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int32 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance Real Int64 where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum+++instance (TypeNum.Positive n, Real a) => A.Real (T n a) where+   min = min+   max = max+   abs = abs+   signum = signum+++class (NiceValue.Fraction a, Real a) => Fraction a where+   truncate :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   fraction :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Fraction Float where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance Fraction Double where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (TypeNum.Positive n, Fraction a) => A.Fraction (T n a) where+   truncate = truncate+   fraction = fraction+++class+   (TypeNum.Positive n, Repr n i ~ Value n ir,+    NiceValue.NativeInteger i ir, IsPrimitive ir, LLVM.IsInteger ir) =>+      NativeInteger n i ir where++instance (TypeNum.Positive n) => NativeInteger n Word   Word   where+instance (TypeNum.Positive n) => NativeInteger n Word8  Word8  where+instance (TypeNum.Positive n) => NativeInteger n Word16 Word16 where+instance (TypeNum.Positive n) => NativeInteger n Word32 Word32 where+instance (TypeNum.Positive n) => NativeInteger n Word64 Word64 where++instance (TypeNum.Positive n) => NativeInteger n Int   Int   where+instance (TypeNum.Positive n) => NativeInteger n Int8  Int8  where+instance (TypeNum.Positive n) => NativeInteger n Int16 Int16 where+instance (TypeNum.Positive n) => NativeInteger n Int32 Int32 where+instance (TypeNum.Positive n) => NativeInteger n Int64 Int64 where++class+   (TypeNum.Positive n, Repr n a ~ Value n ar,+    NiceValue.NativeFloating a ar, IsPrimitive ar, LLVM.IsFloating ar) =>+      NativeFloating n a ar where++instance (TypeNum.Positive n) => NativeFloating n Float  Float where+instance (TypeNum.Positive n) => NativeFloating n Double Double where++fromIntegral ::+   (NativeInteger n i ir, NativeFloating n a ar) =>+   T n i -> LLVM.CodeGenFunction r (T n a)+fromIntegral = liftM LLVM.inttofp+++class (NiceValue.Algebraic a, Field a) => Algebraic a where+   sqrt :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Algebraic Float where+   sqrt = liftM A.sqrt++instance Algebraic Double where+   sqrt = liftM A.sqrt++instance (TypeNum.Positive n, Algebraic a) => A.Algebraic (T n a) where+   sqrt = sqrt+++class (NiceValue.Transcendental a, Algebraic a) => Transcendental a where+   pi :: (TypeNum.Positive n) => LLVM.CodeGenFunction r (T n a)+   sin, cos, exp, log ::+      (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)+   pow ::+      (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance Transcendental Float where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance Transcendental Double where+   pi = liftM0 A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow++instance (TypeNum.Positive n, Transcendental a) => A.Transcendental (T n a) where+   pi = pi+   sin = sin+   cos = cos+   exp = exp+   log = log+   pow = pow++++class (NiceValue.Select a, C a) => Select a where+   select ::+      (TypeNum.Positive n) =>+      T n Bool -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n a)++instance Select Float where select = liftM3 LLVM.select+instance Select Double where select = liftM3 LLVM.select+instance Select Bool where select = liftM3 LLVM.select+instance Select Word where select = liftM3 LLVM.select+instance Select Word8 where select = liftM3 LLVM.select+instance Select Word16 where select = liftM3 LLVM.select+instance Select Word32 where select = liftM3 LLVM.select+instance Select Word64 where select = liftM3 LLVM.select+instance Select Int where select = liftM3 LLVM.select+instance Select Int8 where select = liftM3 LLVM.select+instance Select Int16 where select = liftM3 LLVM.select+instance Select Int32 where select = liftM3 LLVM.select+instance Select Int64 where select = liftM3 LLVM.select++instance (Select a, Select b) => Select (a,b) where+   select x y0 y1 =+      case (unzip y0, unzip y1) of+         ((a0,b0), (a1,b1)) ->+            Monad.lift2 zip+               (select x a0 a1)+               (select x b0 b1)++instance (Select a, Select b, Select c) => Select (a,b,c) where+   select x y0 y1 =+      case (unzip3 y0, unzip3 y1) of+         ((a0,b0,c0), (a1,b1,c1)) ->+            Monad.lift3 zip3+               (select x a0 a1)+               (select x b0 b1)+               (select x c0 c1)++++class (NiceValue.Comparison a, Real a) => Comparison a where+   cmp ::+      (TypeNum.Positive n) =>+      LLVM.CmpPredicate -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n Bool)++instance Comparison Float where cmp = liftM2 . LLVM.cmp+instance Comparison Double where cmp = liftM2 . LLVM.cmp+instance Comparison Word where cmp = liftM2 . LLVM.cmp+instance Comparison Word8 where cmp = liftM2 . LLVM.cmp+instance Comparison Word16 where cmp = liftM2 . LLVM.cmp+instance Comparison Word32 where cmp = liftM2 . LLVM.cmp+instance Comparison Word64 where cmp = liftM2 . LLVM.cmp+instance Comparison Int where cmp = liftM2 . LLVM.cmp+instance Comparison Int8 where cmp = liftM2 . LLVM.cmp+instance Comparison Int16 where cmp = liftM2 . LLVM.cmp+instance Comparison Int32 where cmp = liftM2 . LLVM.cmp+instance Comparison Int64 where cmp = liftM2 . LLVM.cmp++instance (TypeNum.Positive n, Comparison a) => A.Comparison (T n a) where+   type CmpResult (T n a) = T n Bool+   cmp = cmp++++class+   (NiceValue.FloatingComparison a, Comparison a) =>+      FloatingComparison a where+   fcmp ::+      (TypeNum.Positive n) =>+      LLVM.FPPredicate -> T n a -> T n a ->+      LLVM.CodeGenFunction r (T n Bool)++instance FloatingComparison Float where+   fcmp = liftM2 . LLVM.fcmp++instance+   (TypeNum.Positive n, FloatingComparison a) =>+      A.FloatingComparison (T n a) where+   fcmp = fcmp++++class (NiceValue.Logic a, C a) => Logic a where+   and, or, xor ::+      (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   inv :: (TypeNum.Positive n) => T n a -> LLVM.CodeGenFunction r (T n a)++instance Logic Bool where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word8 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word16 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word32 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv++instance Logic Word64 where+   and = liftM2 LLVM.and; or = liftM2 LLVM.or+   xor = liftM2 LLVM.xor; inv = liftM LLVM.inv+++instance (TypeNum.Positive n, Logic a) => A.Logic (T n a) where+   and = and+   or = or+   xor = xor+   inv = inv++++class (NiceValue.BitShift a, C a) => BitShift a where+   shl :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)+   shr :: (TypeNum.Positive n) => T n a -> T n a -> LLVM.CodeGenFunction r (T n a)++instance BitShift Word where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Word64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.lshr++instance BitShift Int where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int8 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int16 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int32 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr++instance BitShift Int64 where+   shl = liftM2 LLVM.shl; shr = liftM2 LLVM.ashr
+ src/LLVM/Extra/Nice/Vector/Instance.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module LLVM.Extra.Nice.Vector.Instance where++import qualified LLVM.Extra.Nice.Vector as Vector+import qualified LLVM.Extra.Nice.Value.Private as NiceValue+import LLVM.Extra.Nice.Value.Private (Repr, )++import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Functor ((<$>), )++import Prelude2010+import Prelude ()+++type NVVector n a = NiceValue.T (LLVM.Vector n a)++toNiceValue :: Vector.T n a -> NVVector n a+toNiceValue (Vector.Cons x) = NiceValue.Cons x++fromNiceValue :: NVVector n a -> Vector.T n a+fromNiceValue (NiceValue.Cons x) = Vector.Cons x++liftNiceValueM ::+   (Functor f) =>+   (Vector.T n a -> f (Vector.T m b)) ->+   (NVVector n a -> f (NVVector m b))+liftNiceValueM f a =+   toNiceValue <$> f (fromNiceValue a)++liftNiceValueM2 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> f (Vector.T k c)) ->+   (NVVector n a -> NVVector m b -> f (NVVector k c))+liftNiceValueM2 f a b =+   toNiceValue <$> f (fromNiceValue a) (fromNiceValue b)++liftNiceValueM3 ::+   (Functor f) =>+   (Vector.T n a -> Vector.T m b -> Vector.T m c -> f (Vector.T k d)) ->+   (NVVector n a -> NVVector m b -> NVVector m c -> f (NVVector k d))+liftNiceValueM3 f a b c =+   toNiceValue <$> f (fromNiceValue a) (fromNiceValue b) (fromNiceValue c)++instance+   (TypeNum.Positive n, Vector.C a) =>+      NiceValue.C (LLVM.Vector n a) where+   type Repr (LLVM.Vector n a) = Vector.Repr n a+   cons = toNiceValue . Vector.cons+   undef = toNiceValue Vector.undef+   zero = toNiceValue Vector.zero+   phi = liftNiceValueM . Vector.phi+   addPhi bb x y = Vector.addPhi bb (fromNiceValue x) (fromNiceValue y)++instance+   (TypeNum.Positive n, Vector.IntegerConstant a) =>+      NiceValue.IntegerConstant (LLVM.Vector n a) where+   fromInteger' = toNiceValue . Vector.fromInteger'++instance+   (TypeNum.Positive n, Vector.RationalConstant a) =>+      NiceValue.RationalConstant (LLVM.Vector n a) where+   fromRational' = toNiceValue . Vector.fromRational'++instance+   (TypeNum.Positive n, Vector.Additive a) =>+      NiceValue.Additive (LLVM.Vector n a) where+   add = liftNiceValueM2 Vector.add+   sub = liftNiceValueM2 Vector.sub+   neg = liftNiceValueM Vector.neg++instance+   (TypeNum.Positive n, Vector.PseudoRing a) =>+      NiceValue.PseudoRing (LLVM.Vector n a) where+   mul = liftNiceValueM2 Vector.mul++instance+   (TypeNum.Positive n, Vector.Real a) =>+      NiceValue.Real (LLVM.Vector n a) where+   min = liftNiceValueM2 Vector.min+   max = liftNiceValueM2 Vector.max+   abs = liftNiceValueM Vector.abs+   signum = liftNiceValueM Vector.signum++instance+   (TypeNum.Positive n, Vector.Fraction a) =>+      NiceValue.Fraction (LLVM.Vector n a) where+   truncate = liftNiceValueM Vector.truncate+   fraction = liftNiceValueM Vector.fraction++instance+   (TypeNum.Positive n, Vector.Logic a) =>+      NiceValue.Logic (LLVM.Vector n a) where+   and = liftNiceValueM2 Vector.and+   or = liftNiceValueM2 Vector.or+   xor = liftNiceValueM2 Vector.xor+   inv = liftNiceValueM Vector.inv++instance+   (TypeNum.Positive n, Vector.BitShift a) =>+      NiceValue.BitShift (LLVM.Vector n a) where+   shl = liftNiceValueM2 Vector.shl+   shr = liftNiceValueM2 Vector.shr
+ src/LLVM/Extra/Scalar.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TypeFamilies #-}+module LLVM.Extra.Scalar where++import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Arithmetic as A++import qualified Control.Monad as Monad+++{- |+The entire purpose of this datatype is to mark a type as scalar,+although it might also be interpreted as vector.+This way you can write generic operations for vectors+using the 'A.PseudoModule' class,+and specialise them to scalar types with respect to the 'A.PseudoRing' class.+From another perspective+you can consider the 'Scalar.T' type constructor a marker+where the 'A.Scalar' type function+stops reducing nested vector types to scalar types.+-}+newtype T a = Cons {decons :: a}++liftM :: (Monad m) => (a -> m b) -> T a -> m (T b)+liftM f (Cons a) = Monad.liftM Cons $ f a++liftM2 :: (Monad m) => (a -> b -> m c) -> T a -> T b -> m (T c)+liftM2 f (Cons a) (Cons b) = Monad.liftM Cons $ f a b+++unliftM ::+   (Monad m) =>+   (T a -> m (T r)) ->+   a -> m r+unliftM f a =+   Monad.liftM decons $ f (Cons a)++unliftM2 ::+   (Monad m) =>+   (T a -> T b -> m (T r)) ->+   a -> b -> m r+unliftM2 f a b =+   Monad.liftM decons $ f (Cons a) (Cons b)++unliftM3 ::+   (Monad m) =>+   (T a -> T b -> T c -> m (T r)) ->+   a -> b -> c -> m r+unliftM3 f a b c =+   Monad.liftM decons $ f (Cons a) (Cons b) (Cons c)++unliftM4 ::+   (Monad m) =>+   (T a -> T b -> T c -> T d -> m (T r)) ->+   a -> b -> c -> d -> m r+unliftM4 f a b c d =+   Monad.liftM decons $ f (Cons a) (Cons b) (Cons c) (Cons d)++unliftM5 ::+   (Monad m) =>+   (T a -> T b -> T c -> T d -> T e -> m (T r)) ->+   a -> b -> c -> d -> e -> m r+unliftM5 f a b c d e =+   Monad.liftM decons $ f (Cons a) (Cons b) (Cons c) (Cons d) (Cons e)+++instance (Tuple.Zero a) => Tuple.Zero (T a) where+   zero = Cons Tuple.zero++instance (Tuple.Undefined a) => Tuple.Undefined (T a) where+   undef = Cons Tuple.undef++instance (Tuple.Phi a) => Tuple.Phi (T a) where+   phi bb = fmap Cons . Tuple.phi bb . decons+   addPhi bb (Cons a) (Cons b) = Tuple.addPhi bb a b++instance (A.IntegerConstant a) => A.IntegerConstant (T a) where+   fromInteger' = Cons . A.fromInteger'++instance (A.RationalConstant a) => A.RationalConstant (T a) where+   fromRational' = Cons . A.fromRational'++instance (A.Additive a) => A.Additive (T a) where+   zero = Cons A.zero+   add = liftM2 A.add+   sub = liftM2 A.sub+   neg = liftM A.neg++instance (A.PseudoRing a) => A.PseudoRing (T a) where+   mul = liftM2 A.mul++instance (A.Field a) => A.Field (T a) where+   fdiv = liftM2 A.fdiv++type instance A.Scalar (T a) = T a++instance (A.PseudoRing a) => A.PseudoModule (T a) where+   scale = liftM2 A.mul+++instance (A.Real a) => A.Real (T a) where+   min = liftM2 A.min+   max = liftM2 A.max+   abs = liftM A.abs+   signum = liftM A.signum++instance (A.Fraction a) => A.Fraction (T a) where+   truncate = liftM A.truncate+   fraction = liftM A.fraction++instance (A.Algebraic a) => A.Algebraic (T a) where+   sqrt = liftM A.sqrt++instance (A.Transcendental a) => A.Transcendental (T a) where+   pi = fmap Cons A.pi+   sin = liftM A.sin+   cos = liftM A.cos+   exp = liftM A.exp+   log = liftM A.log+   pow = liftM2 A.pow
+ src/LLVM/Extra/ScalarOrVector.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Support for unified handling of scalars and vectors.++Attention:+The rounding and fraction functions only work+for floating point values with maximum magnitude of @maxBound :: Int32@.+This way we save expensive handling of possibly seldom cases.+-}+module LLVM.Extra.ScalarOrVector (+   Fraction (truncate, fraction),+   signedFraction,+   addToPhase,+   incPhase,++   truncateToInt,+   floorToInt,+   ceilingToInt,+   roundToIntFast,+   splitFractionToInt,++   Scalar,+   Replicate (replicate, replicateConst),+   replicateOf,+   Real (min, max, abs, signum),+   Saturated(addSat, subSat),+   PseudoModule (scale),+   IntegerConstant(constFromInteger),+   RationalConstant(constFromRational),+   TranscendentalConstant(constPi),+   ) where++import qualified LLVM.Extra.ScalarOrVectorPrivate as Priv+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.ArithmeticPrivate as A+import LLVM.Extra.ScalarOrVectorPrivate+   (Scalar, Replicate(replicate, replicateConst))++import qualified LLVM.Util.Intrinsic as Intrinsic+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, ConstValue, constOf,+    CmpRet, CmpResult, ShapeOf,+    Vector, WordN(WordN), IntN(IntN), FP128,+    IsConst, IsInteger, IsFloating,+    CodeGenFunction, )++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64, )+import Data.Maybe (fromMaybe)++import Prelude hiding (Real, replicate, min, max, abs, truncate)++++class (Real a, IsFloating a) => Fraction a where+   truncate :: Value a -> CodeGenFunction r (Value a)+   fraction :: Value a -> CodeGenFunction r (Value a)++instance Fraction Float where+   truncate = Intrinsic.truncate+   fraction = A.fraction++instance Fraction Double where+   truncate = Intrinsic.truncate+   fraction = A.fraction++instance (TypeNum.Positive n, Vector.Real a, IsFloating a, IsConst a) =>+      Fraction (Vector n a) where+   truncate = Vector.truncate+   fraction = Vector.fraction+++{- |+The fraction has the same sign as the argument.+This is not particular useful but fast on IEEE implementations.+-}+signedFraction ::+   (Fraction a) =>+   Value a -> CodeGenFunction r (Value a)+signedFraction x =+   A.sub x =<< truncate x++_fractionGen ::+   (IntegerConstant v, Fraction v, CmpRet v) =>+   Value v -> CodeGenFunction r (Value v)+_fractionGen x =+   do xf <- signedFraction x+      b <- A.fcmp LLVM.FPOGE xf zero+      LLVM.select b xf =<< A.add xf (LLVM.value $ constFromInteger 1)++_fractionLogical ::+   (Fraction a, LLVM.IsPrimitive a,+    IsInteger b, LLVM.IsPrimitive b) =>+   (LLVM.FPPredicate ->+    Value a -> Value a -> CodeGenFunction r (Value b)) ->+   Value a -> CodeGenFunction r (Value a)+_fractionLogical cmp x =+   do xf <- signedFraction x+      b <- cmp LLVM.FPOLT xf zero+      A.sub xf =<< LLVM.inttofp b++{- |+increment (first operand) may be negative,+phase must always be non-negative+-}+addToPhase ::+   (Fraction a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+addToPhase d p =+   fraction =<< A.add d p++{- |+both increment and phase must be non-negative+-}+incPhase ::+   (Fraction a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+incPhase d p =+   signedFraction =<< A.add d p++++truncateToInt ::+   (IsFloating a, IsInteger i, ShapeOf a ~ ShapeOf i) =>+   Value a -> CodeGenFunction r (Value i)+truncateToInt = LLVM.fptoint++{- |+Rounds to the next integer.+For numbers of the form @n+0.5@,+we choose one of the neighboured integers+such that the overall implementation is most efficient.+-}+roundToIntFast ::+   (IsFloating a, RationalConstant a, CmpRet a,+    IsInteger i, IntegerConstant i, CmpRet i,+    CmpResult a ~ CmpResult i,+    ShapeOf a ~ ShapeOf i) =>+   Value a -> CodeGenFunction r (Value i)+roundToIntFast x = do+   pos <- A.cmp LLVM.CmpGT x zero+   truncateToInt =<< A.add x =<<+      LLVM.select pos (ratio 0.5) (ratio (-0.5))++floorToInt ::+   (IsFloating a, CmpRet a,+    IsInteger i, IntegerConstant i, CmpRet i,+    CmpResult a ~ CmpResult i,+    ShapeOf a ~ ShapeOf i) =>+   Value a -> CodeGenFunction r (Value i)+floorToInt x = do+   i <- truncateToInt x+   lt <- A.cmp LLVM.CmpLT x =<< LLVM.inttofp i+   A.sub i =<< LLVM.select lt (int 1) (int 0)++splitFractionToInt ::+   (IsFloating a, CmpRet a,+    IsInteger i, IntegerConstant i, CmpRet i,+    CmpResult a ~ CmpResult i,+    ShapeOf a ~ ShapeOf i) =>+   Value a -> CodeGenFunction r (Value i, Value a)+splitFractionToInt x = do+   i <- floorToInt x+   frac <- A.sub x =<< LLVM.inttofp i+   return (i, frac)++ceilingToInt ::+   (IsFloating a, CmpRet a,+    IsInteger i, IntegerConstant i, CmpRet i,+    CmpResult a ~ CmpResult i,+    ShapeOf a ~ ShapeOf i) =>+   Value a -> CodeGenFunction r (Value i)+ceilingToInt x = do+   i <- truncateToInt x+   gt <- A.cmp LLVM.CmpGT x =<< LLVM.inttofp i+   A.add i =<< LLVM.select gt (int 1) (int 0)+++zero :: (LLVM.IsType a) => Value a+zero = LLVM.value LLVM.zero++int :: (IntegerConstant a) => Integer -> Value a+int = LLVM.value . constFromInteger++ratio :: (RationalConstant a) => Rational -> Value a+ratio = LLVM.value . constFromRational++++replicateOf ::+   (IsConst (Scalar v), Replicate v) =>+   Scalar v -> Value v+replicateOf =+   LLVM.value . replicateConst . LLVM.constOf+++class (LLVM.IsArithmetic a) => Real a where+   min :: Value a -> Value a -> CodeGenFunction r (Value a)+   max :: Value a -> Value a -> CodeGenFunction r (Value a)+   abs :: Value a -> CodeGenFunction r (Value a)+   signum :: Value a -> CodeGenFunction r (Value a)+++instance Real Float  where+   min = Intrinsic.min+   max = Intrinsic.max+   abs = Intrinsic.abs+   signum = A.signum++instance Real Double where+   min = Intrinsic.min+   max = Intrinsic.max+   abs = Intrinsic.abs+   signum = A.signum++instance Real FP128  where+   min = Intrinsic.min+   max = Intrinsic.max+   abs = Intrinsic.abs+   signum x = do+      minusOne <- LLVM.inttofp $ LLVM.valueOf (-1 :: Int8)+      one      <- LLVM.inttofp $ LLVM.valueOf ( 1 :: Int8)+      A.signumGen minusOne one x+++instance Real Int    where min = A.min; max = A.max; signum = A.signum; abs = A.abs;+instance Real Int8   where min = A.min; max = A.max; signum = A.signum; abs = A.abs;+instance Real Int16  where min = A.min; max = A.max; signum = A.signum; abs = A.abs;+instance Real Int32  where min = A.min; max = A.max; signum = A.signum; abs = A.abs;+instance Real Int64  where min = A.min; max = A.max; signum = A.signum; abs = A.abs;+instance Real Word   where min = A.min; max = A.max; signum = A.signum; abs = return;+instance Real Word8  where min = A.min; max = A.max; signum = A.signum; abs = return;+instance Real Word16 where min = A.min; max = A.max; signum = A.signum; abs = return;+instance Real Word32 where min = A.min; max = A.max; signum = A.signum; abs = return;+instance Real Word64 where min = A.min; max = A.max; signum = A.signum; abs = return;++instance (TypeNum.Positive n) => Real (IntN n) where+   min = A.min; max = A.max; abs = A.abs+   signum = A.signumGen (LLVM.valueOf $ IntN (-1)) (LLVM.valueOf $ IntN 1)+instance (TypeNum.Positive n) => Real (WordN n) where+   min = A.min; max = A.max; abs = return+   signum = A.signumGen (LLVM.value LLVM.undef) (LLVM.valueOf $ WordN 1)++instance (TypeNum.Positive n, Vector.Real a) => Real (Vector n a) where+   min = Vector.min+   max = Vector.max+   abs = Vector.abs+   signum = Vector.signum+++class (IsInteger a) => Saturated a where+   addSat, subSat :: Value a -> Value a -> CodeGenFunction r (Value a)++instance Saturated Int    where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Int8   where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Int16  where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Int32  where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Int64  where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Word   where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Word8  where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Word16 where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Word32 where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance Saturated Word64 where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance (TypeNum.Positive d) => Saturated (IntN  d) where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance (TypeNum.Positive d) => Saturated (WordN d) where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;+instance+   (TypeNum.Positive n, LLVM.IsPrimitive a,+    Saturated a, Bounded a, CmpRet a, IsConst a) =>+      Saturated (Vector n a) where+   addSat = addSatProxy LP.Proxy; subSat = subSatProxy LP.Proxy;++addSatProxy, subSatProxy ::+   (IsInteger v, CmpRet v, Replicate v, ShapeOf v ~ shape,+    LLVM.ShapedType shape Bool ~ bv, ShapeOf bv ~ shape, CmpRet bv,+    Scalar v ~ a, IsConst a, Bounded a) =>+   LP.Proxy v -> Value v -> Value v -> CodeGenFunction r (Value v)+addSatProxy proxy =+   if LLVM.isSigned proxy+      then fromMaybe Priv.saddSat Intrinsic.maybeSAddSat+      else fromMaybe Priv.uaddSat Intrinsic.maybeUAddSat+subSatProxy proxy =+   if LLVM.isSigned proxy+      then fromMaybe Priv.ssubSat Intrinsic.maybeSSubSat+      else fromMaybe Priv.usubSat Intrinsic.maybeUSubSat++++class+   (LLVM.IsArithmetic (Scalar v), LLVM.IsArithmetic v) =>+      PseudoModule v where+   scale :: (a ~ Scalar v) => Value a -> Value v -> CodeGenFunction r (Value v)++instance PseudoModule Word   where scale = LLVM.mul+instance PseudoModule Word8  where scale = LLVM.mul+instance PseudoModule Word16 where scale = LLVM.mul+instance PseudoModule Word32 where scale = LLVM.mul+instance PseudoModule Word64 where scale = LLVM.mul+instance PseudoModule Int    where scale = LLVM.mul+instance PseudoModule Int8   where scale = LLVM.mul+instance PseudoModule Int16  where scale = LLVM.mul+instance PseudoModule Int32  where scale = LLVM.mul+instance PseudoModule Int64  where scale = LLVM.mul+instance PseudoModule Float  where scale = LLVM.mul+instance PseudoModule Double where scale = LLVM.mul+instance (LLVM.IsArithmetic a, LLVM.IsPrimitive a, TypeNum.Positive n) =>+         PseudoModule (Vector n a) where+   scale a v = flip A.mul v =<< replicate a++++class (LLVM.IsConst a) => IntegerConstant a where+   constFromInteger :: Integer -> ConstValue a++instance IntegerConstant Word   where constFromInteger = constOf . fromInteger+instance IntegerConstant Word8  where constFromInteger = constOf . fromInteger+instance IntegerConstant Word16 where constFromInteger = constOf . fromInteger+instance IntegerConstant Word32 where constFromInteger = constOf . fromInteger+instance IntegerConstant Word64 where constFromInteger = constOf . fromInteger+instance IntegerConstant Int    where constFromInteger = constOf . fromInteger+instance IntegerConstant Int8   where constFromInteger = constOf . fromInteger+instance IntegerConstant Int16  where constFromInteger = constOf . fromInteger+instance IntegerConstant Int32  where constFromInteger = constOf . fromInteger+instance IntegerConstant Int64  where constFromInteger = constOf . fromInteger+instance IntegerConstant Float  where constFromInteger = constOf . fromInteger+instance IntegerConstant Double where constFromInteger = constOf . fromInteger+instance (TypeNum.Positive n) => IntegerConstant (WordN n) where+   constFromInteger = constOf . WordN+instance (TypeNum.Positive n) => IntegerConstant (IntN n)  where+   constFromInteger = constOf . IntN+instance (IntegerConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>+         IntegerConstant (Vector n a) where+   constFromInteger = replicateConst . constFromInteger+++class (IntegerConstant a) => RationalConstant a where+   constFromRational :: Rational -> ConstValue a++instance RationalConstant Float  where constFromRational = constOf . fromRational+instance RationalConstant Double where constFromRational = constOf . fromRational+instance (RationalConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>+         RationalConstant (Vector n a) where+   constFromRational = replicateConst . constFromRational+++class (RationalConstant a) => TranscendentalConstant a where+   constPi :: ConstValue a++instance TranscendentalConstant Float  where constPi = constOf pi+instance TranscendentalConstant Double where constPi = constOf pi+instance (TranscendentalConstant a, LLVM.IsPrimitive a, TypeNum.Positive n) =>+         TranscendentalConstant (Vector n a) where+   constPi = replicateConst constPi
+ src/LLVM/Extra/Storable.hs view
@@ -0,0 +1,41 @@+{- |+Transfer values between Haskell and JIT generated code+in a Haskell-compatible format as dictated by the 'Foreign.Storable' class.+E.g. instance 'Bool' may use more than a byte (e.g. Word32).+For tuples, you may use the @Tuple@ wrapper from the @storable-record@ package.+The 'Storable' instance for 'Vector's is compatible with arrays,+i.e. indices always count upwards irrespective of machine endianess+and tuple elements are interleaved.+-}+module LLVM.Extra.Storable (+   -- * Basic class+   Store.C(..),+   Store.storeNext,+   Store.modify,++   -- * Classes for tuples and vectors+   Store.Tuple(..),+   Store.Vector(..),+   Store.TupleVector(..),++   -- * Standard method implementations+   Store.loadNewtype,+   Store.storeNewtype,+   Store.loadTraversable,+   Store.loadApplicative,+   Store.storeFoldable,++   -- * Pointer handling+   Store.advancePtr,+   Store.incrementPtr,+   Store.decrementPtr,++   -- * Loops over Storable arrays+   Array.arrayLoop,+   Array.arrayLoop2,+   Array.arrayLoopMaybeCont,+   Array.arrayLoopMaybeCont2,+   ) where++import qualified LLVM.Extra.Storable.Private as Store+import qualified LLVM.Extra.Storable.Array as Array
+ src/LLVM/Extra/Storable/Array.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{- |+Loops over Storable arrays.+-}+module LLVM.Extra.Storable.Array where++import qualified LLVM.Extra.Storable.Private as Storable+import qualified LLVM.Extra.MaybeContinuation as MaybeCont+import qualified LLVM.Extra.Maybe as Maybe+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.Control as C+import LLVM.Core+   (CodeGenFunction, Value, CmpRet, IsInteger, IsConst, IsPrimitive)++import Foreign.Storable (Storable)+import Foreign.Ptr (Ptr)++import Control.Monad (liftM2)++import Data.Tuple.HT (mapSnd)+++arrayLoop ::+   (Tuple.Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA) =>+   Value i -> ptrA -> s ->+   (ptrA -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop len ptr start body =+   fmap snd $+   C.fixedLengthLoop len (ptr, start) $ \(p,s) ->+      liftM2 (,) (Storable.incrementPtr p) (body p s)++arrayLoop2 ::+   (Tuple.Phi s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA,+    Storable b, Value (Ptr b) ~ ptrB) =>+   Value i -> ptrA -> ptrB -> s ->+   (ptrA -> ptrB -> s -> CodeGenFunction r s) ->+   CodeGenFunction r s+arrayLoop2 len ptrA ptrB start body =+   fmap snd $+   arrayLoop len ptrA (ptrB,start) $ \pa (pb,s) ->+      liftM2 (,) (Storable.incrementPtr pb) (body pa pb s)+++arrayLoopMaybeCont ::+   (Tuple.Phi s, Tuple.Undefined s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA,+    Maybe.T (ptrA, s) ~ z) =>+   Value i ->+   ptrA -> s ->+   (ptrA -> s -> MaybeCont.T r z s) ->+   CodeGenFunction r (Value i, Maybe.T s)+arrayLoopMaybeCont len ptr start body =+   fmap (mapSnd (fmap snd)) $+   MaybeCont.fixedLengthLoop len (ptr,start) $ \(ptr0,s0) ->+      liftM2 (,)+         (MaybeCont.lift $ Storable.incrementPtr ptr0)+         (body ptr0 s0)++arrayLoopMaybeCont2 ::+   (Tuple.Phi s, Tuple.Undefined s, Num i, IsConst i, IsInteger i, CmpRet i, IsPrimitive i,+    Storable a, Value (Ptr a) ~ ptrA,+    Storable b, Value (Ptr b) ~ ptrB,+    Maybe.T (ptrA, (ptrB, s)) ~ z) =>+   Value i ->+   ptrA -> ptrB -> s ->+   (ptrA -> ptrB -> s -> MaybeCont.T r z s) ->+   CodeGenFunction r (Value i, Maybe.T s)+arrayLoopMaybeCont2 len ptrA ptrB start body =+   fmap (mapSnd (fmap snd)) $+   arrayLoopMaybeCont len ptrA (ptrB,start) $ \ptrAi (ptrB0,s0) ->+      liftM2 (,)+         (MaybeCont.lift $ Storable.incrementPtr ptrB0)+         (body ptrAi ptrB0 s0)
+ src/LLVM/Extra/Storable/Private.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Storable.Private where++import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.ArithmeticPrivate as A+import qualified LLVM.Util.Proxy as LP+import qualified LLVM.Core as LLVM+import LLVM.Core (CodeGenFunction, Value)++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Control.Monad.Trans.Class as MT+import qualified Control.Monad.Trans.Reader as MR+import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative.HT as App+import qualified Control.Functor.HT as FuncHT+import Control.Monad (foldM, replicateM, replicateM_, (<=<))+import Control.Applicative (Applicative, pure)++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import qualified Foreign.Storable as Store+import Foreign.Storable.FixedArray (roundUp)+import Foreign.Ptr (Ptr)++import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import Data.Orphans ()+import Data.Complex (Complex)+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64)+import Data.Bool8 (Bool8)++++class+   (Store.Storable a, Tuple.Value a,+    Tuple.Phi (Tuple.ValueOf a), Tuple.Undefined (Tuple.ValueOf a)) =>+      C a where++   {-+   Not all Storable types have a compatible LLVM type,+   or even more, one LLVM type that is compatible on all platforms.+   -}+   load :: Value (Ptr a) -> CodeGenFunction r (Tuple.ValueOf a)+   store :: Tuple.ValueOf a -> Value (Ptr a) -> CodeGenFunction r ()++storeNext ::+   (C a, Tuple.ValueOf a ~ al, Value (Ptr a) ~ ptr) =>+   al -> ptr -> CodeGenFunction r ptr+storeNext a ptr  =  store a ptr >> incrementPtr ptr++modify ::+   (C a, Tuple.ValueOf a ~ al) =>+   (al -> CodeGenFunction r al) ->+   Value (Ptr a) -> CodeGenFunction r ()+modify f ptr  =  flip store ptr =<< f =<< load ptr+++loadPrimitive ::+   (LLVM.Storable a) => Value (Ptr a) -> CodeGenFunction r (Value a)+loadPrimitive ptr = LLVM.load =<< LLVM.bitcast ptr++storePrimitive ::+   (LLVM.Storable a) => Value a -> Value (Ptr a) -> CodeGenFunction r ()+storePrimitive a ptr = LLVM.store a =<< LLVM.bitcast ptr++instance C Float where+   load = loadPrimitive; store = storePrimitive++instance C Double where+   load = loadPrimitive; store = storePrimitive++instance C Word where+   load = loadPrimitive; store = storePrimitive++instance C Word8 where+   load = loadPrimitive; store = storePrimitive++instance C Word16 where+   load = loadPrimitive; store = storePrimitive++instance C Word32 where+   load = loadPrimitive; store = storePrimitive++instance C Word64 where+   load = loadPrimitive; store = storePrimitive++instance C Int where+   load = loadPrimitive; store = storePrimitive++instance C Int8 where+   load = loadPrimitive; store = storePrimitive++instance C Int16 where+   load = loadPrimitive; store = storePrimitive++instance C Int32 where+   load = loadPrimitive; store = storePrimitive++instance C Int64 where+   load = loadPrimitive; store = storePrimitive++{- |+Not very efficient implementation+because we want to adapt to @sizeOf Bool@ dynamically.+Unfortunately, LLVM-9's optimizer does not recognize the instruction pattern.+Better use 'Bool8' for booleans.+-}+instance C Bool where+   load ptr = do+      bytePtr <- castToBytePtr ptr+      bytes <-+         flip MS.evalStateT bytePtr $+            replicateM (Store.sizeOf (False :: Bool))+               (MT.lift . LLVM.load =<< incPtrState)+      let zero = LLVM.valueOf 0+      mask <- foldM A.or zero bytes+      A.cmp LLVM.CmpNE mask zero+   store b ptr = do+      bytePtr <- castToBytePtr ptr+      byte <- LLVM.sext b+      flip MS.evalStateT bytePtr $+         replicateM_ (Store.sizeOf (False :: Bool))+            (MT.lift . LLVM.store byte =<< incPtrState)++incPtrState :: MS.StateT BytePtr (CodeGenFunction r) BytePtr+incPtrState = update A.advanceArrayElementPtr++instance C Bool8 where+   load ptr =+      A.cmp LLVM.CmpNE (LLVM.valueOf 0) =<< LLVM.load =<< castToBytePtr ptr+   store b ptr = do+      byte <- LLVM.zext b+      LLVM.store byte =<< castToBytePtr ptr++instance (C a) => C (Complex a) where+   load = loadApplicative; store = storeFoldable++++instance (Tuple tuple) => C (StoreTuple.Tuple tuple) where+   load = loadTuple+   store = storeTuple++class+   (StoreTuple.Storable tuple, Tuple.Value tuple,+    Tuple.Phi (Tuple.ValueOf tuple), Tuple.Undefined (Tuple.ValueOf tuple)) =>+      Tuple tuple where+   loadTuple ::+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r (Tuple.ValueOf tuple)+   storeTuple ::+      Tuple.ValueOf tuple ->+      Value (Ptr (StoreTuple.Tuple tuple)) ->+      CodeGenFunction r ()++instance (C a, C b) => Tuple (a,b) where+   loadTuple ptr =+      runElements ptr $+         App.mapPair (loadElement, loadElement) $+         FuncHT.unzip $ proxyFromElement3 ptr+   storeTuple (a,b) ptr =+      case FuncHT.unzip $ proxyFromElement3 ptr of+         (pa,pb) -> runElements ptr $ storeElement pa a >> storeElement pb b++instance (C a, C b, C c) => Tuple (a,b,c) where+   loadTuple ptr =+      runElements ptr $+         App.mapTriple (loadElement, loadElement, loadElement) $+         FuncHT.unzip3 $ proxyFromElement3 ptr+   storeTuple (a,b,c) ptr =+      case FuncHT.unzip3 $ proxyFromElement3 ptr of+         (pa,pb,pc) ->+            runElements ptr $+               storeElement pa a >> storeElement pb b >> storeElement pc c++runElements ::+   Value (Ptr a) ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) c ->+   CodeGenFunction r c+runElements ptr act = do+   bytePtr <- castToBytePtr ptr+   flip MS.evalStateT 0 $ flip MR.runReaderT bytePtr act++loadElement ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) (Tuple.ValueOf a)+loadElement proxy =+   MT.lift . MT.lift . load =<< elementPtr proxy++storeElement ::+   (C a) =>+   LP.Proxy a -> Tuple.ValueOf a ->+   MR.ReaderT BytePtr (MS.StateT Int (CodeGenFunction r)) ()+storeElement proxy a =+   MT.lift . MT.lift . store a =<< elementPtr proxy++elementPtr ::+   (C a) =>+   LP.Proxy a ->+   MR.ReaderT BytePtr+      (MS.StateT Int (CodeGenFunction r)) (LLVM.Value (Ptr a))+elementPtr proxy = do+   ptr <- MR.ask+   MT.lift $ do+      offset <- elementOffset proxy+      MT.lift $ castFromBytePtr =<< LLVM.getElementPtr ptr (offset, ())++elementOffset ::+   (Monad m, Store.Storable a) => LP.Proxy a -> MS.StateT Int m Int+elementOffset proxy = do+   let dummy = elementFromProxy proxy+   MS.modify (roundUp $ Store.alignment dummy)+   offset <- MS.get+   MS.modify (+ Store.sizeOf dummy)+   return offset+++instance+   (TypeNum.Positive n, Vector a, Tuple.VectorValue n a,+    Tuple.Phi (Tuple.VectorValueOf n a)) =>+      C (LLVM.Vector n a) where+   load ptr =+      assembleVector (proxyFromElement3 ptr) =<< loadApplicative ptr+   store a ptr =+      flip storeFoldable ptr+         =<< disassembleVector (proxyFromElement3 ptr) a++class (C a) => Vector a where+   assembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (Tuple.ValueOf a) ->+      CodeGenFunction r (Tuple.VectorValueOf n a)+   disassembleVector ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> Tuple.VectorValueOf n a ->+      CodeGenFunction r (LLVM.Vector n (Tuple.ValueOf a))++assemblePrimitive ::+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+   LLVM.Vector n (Value a) -> CodeGenFunction r (Value (LLVM.Vector n a))+assemblePrimitive =+   foldM+      (\v (i,x) -> LLVM.insertelement v x (LLVM.valueOf i))+      (LLVM.value LLVM.undef)+    . zip [0..] . Fold.toList++disassemblePrimitive ::+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+   Value (LLVM.Vector n a) -> CodeGenFunction r (LLVM.Vector n (Value a))+disassemblePrimitive v =+   Trav.mapM (LLVM.extractelement v . LLVM.valueOf) indices++indices :: (Applicative f, Trav.Traversable f) => f Word32+indices =+   flip MS.evalState 0 $ Trav.sequenceA $ pure $ MS.state (\k -> (k,k+1))++instance Vector Float where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Double where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word16 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word32 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Word64 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int16 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int32 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Int64 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Bool where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive++instance Vector Bool8 where+   assembleVector LP.Proxy = assemblePrimitive+   disassembleVector LP.Proxy = disassemblePrimitive+++instance+   (Tuple tuple, TupleVector tuple) =>+      Vector (StoreTuple.Tuple tuple) where+   assembleVector = deinterleave . fmap StoreTuple.getTuple+   disassembleVector = interleave . fmap StoreTuple.getTuple+++class TupleVector a where+   deinterleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> LLVM.Vector n (Tuple.ValueOf a) ->+      CodeGenFunction r (Tuple.VectorValueOf n a)+   interleave ::+      (TypeNum.Positive n) =>+      LP.Proxy a -> Tuple.VectorValueOf n a ->+      CodeGenFunction r (LLVM.Vector n (Tuple.ValueOf a))++instance (Vector a, Vector b) => TupleVector (a,b) where+   deinterleave = FuncHT.uncurry $ \pa pb -> FuncHT.uncurry $ \a b ->+      App.lift2 (,) (assembleVector pa a) (assembleVector pb b)+   interleave = FuncHT.uncurry $ \pa pb (a,b) ->+      App.lift2 (App.lift2 (,))+         (disassembleVector pa a) (disassembleVector pb b)++instance (Vector a, Vector b, Vector c) => TupleVector (a,b,c) where+   deinterleave = FuncHT.uncurry3 $ \pa pb pc -> FuncHT.uncurry3 $ \a b c ->+      App.lift3 (,,)+         (assembleVector pa a)+         (assembleVector pb b)+         (assembleVector pc c)+   interleave = FuncHT.uncurry3 $ \pa pb pc (a,b,c) ->+      App.lift3 (App.lift3 (,,))+         (disassembleVector pa a)+         (disassembleVector pb b)+         (disassembleVector pc c)+++{-+instance Storable () available since base-4.9/GHC-8.0.+Before we need Data.Orphans.+-}+instance C () where+   load _ptr = return ()+   store () _ptr = return ()+++loadNewtype ::+   (C a, Tuple.ValueOf a ~ al) =>+   (a -> wrapped) ->+   (al -> wrappedl) ->+   Value (Ptr wrapped) -> CodeGenFunction r wrappedl+loadNewtype wrap wrapl =+   fmap wrapl . load <=< rmapPtr wrap++storeNewtype ::+   (C a, Tuple.ValueOf a ~ al) =>+   (a -> wrapped) ->+   (wrappedl -> al) ->+   wrappedl -> Value (Ptr wrapped) -> CodeGenFunction r ()+storeNewtype wrap unwrapl y =+   store (unwrapl y) <=< rmapPtr wrap++rmapPtr :: (a -> b) -> Value (Ptr b) -> CodeGenFunction r (Value (Ptr a))+rmapPtr _f = LLVM.bitcast+++loadTraversable ::+   (NonEmptyC.Repeat f, Trav.Traversable f, C a, Tuple.ValueOf a ~ al) =>+   Value (Ptr (f a)) -> CodeGenFunction r (f al)+loadTraversable =+   (MS.evalStateT $ Trav.sequence $ NonEmptyC.repeat $ loadState)+      <=< castElementPtr++loadApplicative ::+   (Applicative f, Trav.Traversable f, C a, Tuple.ValueOf a ~ al) =>+   Value (Ptr (f a)) -> CodeGenFunction r (f al)+loadApplicative =+   (MS.evalStateT $ Trav.sequence $ pure loadState) <=< castElementPtr++loadState ::+   (C a, Tuple.ValueOf a ~ al) =>+   MS.StateT (Value (Ptr a)) (CodeGenFunction r) al+loadState = MT.lift . load =<< advancePtrState+++storeFoldable ::+   (Fold.Foldable f, C a, Tuple.ValueOf a ~ al) =>+   f al -> Value (Ptr (f a)) -> CodeGenFunction r ()+storeFoldable xs = MS.evalStateT (Fold.mapM_ storeState xs) <=< castElementPtr++storeState ::+   (C a, Tuple.ValueOf a ~ al) =>+   al -> MS.StateT (Value (Ptr a)) (CodeGenFunction r) ()+storeState a = MT.lift . store a =<< advancePtrState+++update :: (Monad m) => (a -> m a) -> MS.StateT a m a+update f = MS.StateT $ \a0 -> do a1 <- f a0; return (a0,a1)++advancePtrState ::+   (C a, Value (Ptr a) ~ ptr) =>+   MS.StateT ptr (CodeGenFunction r) ptr+advancePtrState = update $ advancePtrStatic 1++advancePtr ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   Value Int -> ptr -> CodeGenFunction r ptr+advancePtr n ptr = do+   size <- A.mul n $ LLVM.valueOf $ Store.sizeOf (elementFromPtr ptr)+   addPointer size ptr++advancePtrStatic ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   Int -> ptr -> CodeGenFunction r ptr+advancePtrStatic n ptr =+   addPointer (LLVM.valueOf (Store.sizeOf (elementFromPtr ptr) * n)) ptr++incrementPtr ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   ptr -> CodeGenFunction r ptr+incrementPtr = advancePtrStatic 1++decrementPtr ::+   (Store.Storable a, Value (Ptr a) ~ ptr) =>+   ptr -> CodeGenFunction r ptr+decrementPtr = advancePtrStatic (-1)++addPointer :: Value Int -> Value (Ptr a) -> CodeGenFunction r (Value (Ptr a))+addPointer k ptr = do+   bytePtr <- castToBytePtr ptr+   castFromBytePtr =<< LLVM.getElementPtr bytePtr (k, ())++type BytePtr = Value (LLVM.Ptr Word8)++castToBytePtr :: Value (Ptr a) -> CodeGenFunction r BytePtr+castToBytePtr = LLVM.bitcast++castFromBytePtr :: BytePtr -> CodeGenFunction r (Value (Ptr a))+castFromBytePtr = LLVM.bitcast++castElementPtr :: Value (Ptr (f a)) -> CodeGenFunction r (Value (Ptr a))+castElementPtr = LLVM.bitcast+++sizeOf :: (Store.Storable a) => LP.Proxy a -> Int+sizeOf = Store.sizeOf . elementFromProxy++elementFromPtr :: LLVM.Value (Ptr a) -> a+elementFromPtr _ = error "elementFromProxy"++elementFromProxy :: LP.Proxy a -> a+elementFromProxy LP.Proxy = error "elementFromProxy"++proxyFromElement2 :: f (g a) -> LP.Proxy a+proxyFromElement2 _ = LP.Proxy++proxyFromElement3 :: f (g (h a)) -> LP.Proxy a+proxyFromElement3 _ = LP.Proxy
+ src/LLVM/Extra/Struct.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+In contrast to 'LLVM.Struct' it allows to store high-level values+and thus allows to implement arbitrary-sized tuples of NiceValue's.+-}+module LLVM.Extra.Struct where++import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.Core as LLVM++import qualified Control.Applicative.HT as App+import Control.Applicative ((<$>))+++newtype T struct = Cons struct+++class Undefined struct where+   undef :: struct++instance (Undefined struct) => Tuple.Undefined (T struct) where+   undef = Cons undef++instance+   (Tuple.Undefined a, Undefined as) =>+      Undefined (a,as) where+   undef = (Tuple.undef, undef)++instance Undefined () where+   undef = ()+++class Zero struct where+   zero :: struct++instance (Zero struct) => Tuple.Zero (T struct) where+   zero = Cons zero++instance (Tuple.Zero a, Zero as) => Zero (a,as) where+   zero = (Tuple.zero, zero)++instance Zero () where+   zero = ()+++class Phi struct where+   phi :: LLVM.BasicBlock -> struct -> LLVM.CodeGenFunction r struct+   addPhi :: LLVM.BasicBlock -> struct -> struct -> LLVM.CodeGenFunction r ()++instance (Phi struct) => Tuple.Phi (T struct) where+   phi bb (Cons s) = Cons <$> phi bb s+   addPhi bb (Cons a) (Cons b) = addPhi bb a b++instance (Tuple.Phi a, Phi as) => Phi (a,as) where+   phi bb (a,as) = App.lift2 (,) (Tuple.phi bb a) (phi bb as)+   addPhi bb (a,as) (b,bs) = Tuple.addPhi bb a b >> addPhi bb as bs++instance Phi () where+   phi _bb = return+   addPhi _bb () () = return ()+++class (Undefined (ValueOf struct)) => Value struct where+   type ValueOf struct+   valueOf :: struct -> ValueOf struct++instance (Value struct) => Tuple.Value (T struct) where+   type ValueOf (T struct) = T (ValueOf struct)+   valueOf (Cons struct) = Cons $ valueOf struct++instance (Tuple.Value a, Value as) => Value (a,as) where+   type ValueOf (a,as) = (Tuple.ValueOf a, ValueOf as)+   valueOf (a,as) = (Tuple.valueOf a, valueOf as)++instance Value () where+   type ValueOf () = ()+   valueOf () = ()
+ src/LLVM/Extra/Tuple.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Tuple (+   Phi(..), phiTraversable, addPhiFoldable,+   Undefined(..), undefPointed,+   Zero(..), zeroPointed,+   Value(..), valueOfFunctor,+   VectorValue(..),+   ) where++import LLVM.Extra.TuplePrivate (+   Phi(..), phiTraversable, addPhiFoldable,+   Undefined(..), undefPointed,+   Zero(..), zeroPointed,+   )+import qualified LLVM.Extra.EitherPrivate as Either+import qualified LLVM.Extra.MaybePrivate as Maybe+import qualified LLVM.Core as LLVM+import LLVM.Core (IsType, Vector)++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:*:))++import qualified Control.Monad.Trans.State as MS+import qualified Control.Applicative as App+import qualified Control.Functor.HT as FuncHT++import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import qualified Foreign.Storable.Record.Tuple as StoreTuple+import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (FunPtr, Ptr, )++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(unTagged))+import Data.Word (Word8, Word16, Word32, Word64, Word)+import Data.Int  (Int8,  Int16,  Int32,  Int64, )+import Data.Bool8 (Bool8)++import Prelude2010+import Prelude ()+++-- * class for creating tuples of constant values++class (Undefined (ValueOf a)) => Value a where+   type ValueOf a+   valueOf :: a -> ValueOf a++instance (Value a, Value b) => Value (a,b) where+   type ValueOf (a,b) = (ValueOf a, ValueOf b)+   valueOf ~(a,b) = (valueOf a, valueOf b)++instance (Value a, Value b, Value c) => Value (a,b,c) where+   type ValueOf (a,b,c) = (ValueOf a, ValueOf b, ValueOf c)+   valueOf ~(a,b,c) = (valueOf a, valueOf b, valueOf c)++instance (Value a, Value b, Value c, Value d) => Value (a,b,c,d) where+   type ValueOf (a,b,c,d) = (ValueOf a, ValueOf b, ValueOf c, ValueOf d)+   valueOf ~(a,b,c,d) = (valueOf a, valueOf b, valueOf c, valueOf d)++instance (Value tuple) => Value (StoreTuple.Tuple tuple) where+   type ValueOf (StoreTuple.Tuple tuple) = ValueOf tuple+   valueOf (StoreTuple.Tuple a) = valueOf a++instance (Value a) => Value (Maybe a) where+   type ValueOf (Maybe a) = Maybe.T (ValueOf a)+   valueOf = maybe (Maybe.nothing undef) (Maybe.just . valueOf)++instance (Value a, Value b) => Value (Either a b) where+   type ValueOf (Either a b) = Either.T (ValueOf a) (ValueOf b)+   valueOf =+      either+         (Either.left undef . valueOf)+         (Either.right undef . valueOf)++instance Value Float  where type ValueOf Float  = LLVM.Value Float  ; valueOf = LLVM.valueOf+instance Value Double where type ValueOf Double = LLVM.Value Double ; valueOf = LLVM.valueOf+-- instance Value FP128  where type ValueOf FP128  = LLVM.Value FP128  ; valueOf = LLVM.valueOf+instance Value Bool   where type ValueOf Bool   = LLVM.Value Bool   ; valueOf = LLVM.valueOf+instance Value Bool8  where type ValueOf Bool8  = LLVM.Value Bool   ; valueOf = LLVM.valueOf . Bool8.toBool+instance Value Int    where type ValueOf Int    = LLVM.Value Int    ; valueOf = LLVM.valueOf+instance Value Int8   where type ValueOf Int8   = LLVM.Value Int8   ; valueOf = LLVM.valueOf+instance Value Int16  where type ValueOf Int16  = LLVM.Value Int16  ; valueOf = LLVM.valueOf+instance Value Int32  where type ValueOf Int32  = LLVM.Value Int32  ; valueOf = LLVM.valueOf+instance Value Int64  where type ValueOf Int64  = LLVM.Value Int64  ; valueOf = LLVM.valueOf+instance Value Word   where type ValueOf Word   = LLVM.Value Word   ; valueOf = LLVM.valueOf+instance Value Word8  where type ValueOf Word8  = LLVM.Value Word8  ; valueOf = LLVM.valueOf+instance Value Word16 where type ValueOf Word16 = LLVM.Value Word16 ; valueOf = LLVM.valueOf+instance Value Word32 where type ValueOf Word32 = LLVM.Value Word32 ; valueOf = LLVM.valueOf+instance Value Word64 where type ValueOf Word64 = LLVM.Value Word64 ; valueOf = LLVM.valueOf+instance Value ()     where type ValueOf ()     = ()           ; valueOf = id+++instance (TypeNum.Positive n) => Value (LLVM.IntN n) where+   type ValueOf (LLVM.IntN n) = LLVM.Value (LLVM.IntN n)+   valueOf = LLVM.valueOf++instance (TypeNum.Positive n) => Value (LLVM.WordN n) where+   type ValueOf (LLVM.WordN n) = LLVM.Value (LLVM.WordN n)+   valueOf = LLVM.valueOf+++instance Value (Ptr a) where+   type ValueOf (Ptr a) = LLVM.Value (Ptr a)+   valueOf = LLVM.valueOf++instance IsType a => Value (LLVM.Ptr a) where+   type ValueOf (LLVM.Ptr a) = LLVM.Value (LLVM.Ptr a)+   valueOf = LLVM.valueOf++instance LLVM.IsFunction a => Value (FunPtr a) where+   type ValueOf (FunPtr a) = LLVM.Value (FunPtr a)+   valueOf = LLVM.valueOf++instance Value (StablePtr a) where+   type ValueOf (StablePtr a) = LLVM.Value (StablePtr a)+   valueOf = LLVM.valueOf++instance+   (TypeNum.Positive n, VectorValue n a, Undefined (VectorValueOf n a)) =>+      Value (Vector n a) where+   type ValueOf (Vector n a) = VectorValueOf n a+   valueOf = vectorValueOf+++instance Value a => Value (Tagged tag a) where+   type ValueOf (Tagged tag a) = ValueOf a+   valueOf = valueOf . unTagged++instance+   (LLVM.IsInteger w, LLVM.IsConst w, Num w, Enum e) =>+      Value (Enum.T w e) where+   type ValueOf (Enum.T w e) = LLVM.Value w+   valueOf = LLVM.valueOf . fromIntegral . fromEnum . Enum.toPlain++instance (LLVM.IsInteger w, LLVM.IsConst w) => Value (EnumBitSet.T w i) where+   type ValueOf (EnumBitSet.T w i) = LLVM.Value w+   valueOf = LLVM.valueOf . EnumBitSet.decons++instance (Value a) => Value (Complex a) where+   type ValueOf (Complex a) = Complex (ValueOf a)+   valueOf (a:+b) = valueOf a :+ valueOf b+++-- * class for vectors of tuples and other complex types++class+   (TypeNum.Positive n, Undefined (VectorValueOf n a)) =>+      VectorValue n a where+   type VectorValueOf n a+   vectorValueOf :: Vector n a -> VectorValueOf n a++-- may be simplified using a fake proof of TypeNum.Positive (n :*: m)+instance+   (TypeNum.Positive n, TypeNum.Positive m, TypeNum.Positive (n :*: m),+    Undefined (Vector (n :*: m) a)) =>+      VectorValue n (Vector m a) where+   type VectorValueOf n (Vector m a) = Vector (n :*: m) a+   vectorValueOf = vectorFromList . Fold.foldMap Fold.toList++vectorFromList :: (TypeNum.Positive n) => [a] -> Vector n a+vectorFromList =+   MS.evalState $ Trav.sequence $ App.pure $ MS.state $ \(y:ys) -> (y,ys)++instance (VectorValue n a, VectorValue n b) => VectorValue n (a,b) where+   type VectorValueOf n (a,b) = (VectorValueOf n a, VectorValueOf n b)+   vectorValueOf v =+      case FuncHT.unzip v of+         (a,b) -> (vectorValueOf a, vectorValueOf b)++instance+   (VectorValue n a, VectorValue n b, VectorValue n c) =>+      VectorValue n (a,b,c) where+   type VectorValueOf n (a,b,c) =+         (VectorValueOf n a, VectorValueOf n b, VectorValueOf n c)+   vectorValueOf v =+      case FuncHT.unzip3 v of+         (a,b,c) -> (vectorValueOf a, vectorValueOf b, vectorValueOf c)++instance (VectorValue n tuple) => VectorValue n (StoreTuple.Tuple tuple) where+   type VectorValueOf n (StoreTuple.Tuple tuple) = VectorValueOf n tuple+   vectorValueOf = vectorValueOf . fmap StoreTuple.getTuple++instance (TypeNum.Positive n) => VectorValue n Float where+   type VectorValueOf n Float  = LLVM.Value (Vector n Float)+   vectorValueOf = LLVM.valueOf++instance (TypeNum.Positive n) => VectorValue n Double where+   type VectorValueOf n Double = LLVM.Value (Vector n Double)+   vectorValueOf = LLVM.valueOf+{-+instance (TypeNum.Positive n) => VectorValue n FP128  where+   type VectorValueOf n FP128  = LLVM.Value (Vector n FP128)+   vectorValueOf = LLVM.valueOf+-}+instance (TypeNum.Positive n) => VectorValue n Bool   where+   type VectorValueOf n Bool   = LLVM.Value (Vector n Bool)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Bool8  where+   type VectorValueOf n Bool8  = LLVM.Value (Vector n Bool)+   vectorValueOf = LLVM.valueOf . fmap Bool8.toBool+instance (TypeNum.Positive n) => VectorValue n Int  where+   type VectorValueOf n Int    = LLVM.Value (Vector n Int)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int8   where+   type VectorValueOf n Int8   = LLVM.Value (Vector n Int8)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int16  where+   type VectorValueOf n Int16  = LLVM.Value (Vector n Int16)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int32  where+   type VectorValueOf n Int32  = LLVM.Value (Vector n Int32)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Int64  where+   type VectorValueOf n Int64  = LLVM.Value (Vector n Int64)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word   where+   type VectorValueOf n Word   = LLVM.Value (Vector n Word)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word8  where+   type VectorValueOf n Word8  = LLVM.Value (Vector n Word8)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word16 where+   type VectorValueOf n Word16 = LLVM.Value (Vector n Word16)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word32 where+   type VectorValueOf n Word32 = LLVM.Value (Vector n Word32)+   vectorValueOf = LLVM.valueOf+instance (TypeNum.Positive n) => VectorValue n Word64 where+   type VectorValueOf n Word64 = LLVM.Value (Vector n Word64)+   vectorValueOf = LLVM.valueOf+++-- * default methods for LLVM classes++valueOfFunctor :: (Value h, Functor f) => f h -> f (ValueOf h)+valueOfFunctor = fmap valueOf
+ src/LLVM/Extra/TuplePrivate.hs view
@@ -0,0 +1,140 @@+module LLVM.Extra.TuplePrivate where++import qualified LLVM.Core as LLVM++import qualified Data.FixedLength as FixedLength+import Data.Complex (Complex)++import qualified Type.Data.Num.Unary as Unary++import qualified Control.Applicative.HT as App+import Control.Applicative (Applicative, liftA2, pure)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold++import Data.Orphans ()++++-- * class for phi operating on value tuples++class Phi a where+   phi :: LLVM.BasicBlock -> a -> LLVM.CodeGenFunction r a+   addPhi :: LLVM.BasicBlock -> a -> a -> LLVM.CodeGenFunction r ()++instance Phi () where+   phi _ _ = return ()+   addPhi _ _ _ = return ()++instance (LLVM.IsFirstClass a) => Phi (LLVM.Value a) where+   phi bb a = LLVM.phi [(a, bb)]+   addPhi bb a a' = LLVM.addPhiInputs a [(a', bb)]++instance (Phi a, Phi b) => Phi (a, b) where+   phi bb = App.mapPair (phi bb, phi bb)+   addPhi bb (a0,b0) (a1,b1) = do+      addPhi bb a0 a1+      addPhi bb b0 b1++instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where+   phi bb = App.mapTriple (phi bb, phi bb, phi bb)+   addPhi bb (a0,b0,c0) (a1,b1,c1) = do+      addPhi bb a0 a1+      addPhi bb b0 b1+      addPhi bb c0 c1++instance (Phi a, Phi b, Phi c, Phi d) => Phi (a, b, c, d) where+   phi bb (a,b,c,d) =+      App.lift4 (,,,) (phi bb a) (phi bb b) (phi bb c) (phi bb d)+   addPhi bb (a0,b0,c0,d0) (a1,b1,c1,d1) = do+      addPhi bb a0 a1+      addPhi bb b0 b1+      addPhi bb c0 c1+      addPhi bb d0 d1++instance (Phi a) => Phi (Complex a) where+   phi = phiTraversable+   addPhi = addPhiFoldable++instance (Unary.Natural n, Phi a) => Phi (FixedLength.T n a) where+   phi = phiTraversable+   addPhi = addPhiFoldable++phiTraversable ::+   (Phi a, Trav.Traversable f) =>+   LLVM.BasicBlock -> f a -> LLVM.CodeGenFunction r (f a)+phiTraversable bb x = Trav.mapM (phi bb) x++addPhiFoldable ::+   (Phi a, Fold.Foldable f, Applicative f) =>+   LLVM.BasicBlock -> f a -> f a -> LLVM.CodeGenFunction r ()+addPhiFoldable bb x y = Fold.sequence_ (liftA2 (addPhi bb) x y)+++-- * class for tuples of undefined values++class Undefined a where+   undef :: a++instance Undefined () where+   undef = ()++instance (LLVM.IsFirstClass a) => Undefined (LLVM.Value a) where+   undef = LLVM.value LLVM.undef++instance (LLVM.IsFirstClass a) => Undefined (LLVM.ConstValue a) where+   undef = LLVM.undef++instance (Undefined a, Undefined b) => Undefined (a, b) where+   undef = (undef, undef)++instance (Undefined a, Undefined b, Undefined c) => Undefined (a, b, c) where+   undef = (undef, undef, undef)++instance+   (Undefined a, Undefined b, Undefined c, Undefined d) =>+      Undefined (a, b, c, d) where+   undef = (undef, undef, undef, undef)++instance (Undefined a) => Undefined (Complex a) where+   undef = undefPointed++instance (Unary.Natural n, Undefined a) => Undefined (FixedLength.T n a) where+   undef = undefPointed++undefPointed :: (Undefined a, Applicative f) => f a+undefPointed = pure undef+++-- * class for tuples of zero values++class Zero a where+   zero :: a++instance Zero () where+   zero = ()++instance (LLVM.IsFirstClass a) => Zero (LLVM.Value a) where+   zero = LLVM.value LLVM.zero++instance (LLVM.IsFirstClass a) => Zero (LLVM.ConstValue a) where+   zero = LLVM.zero++instance (Zero a, Zero b) => Zero (a, b) where+   zero = (zero, zero)++instance (Zero a, Zero b, Zero c) => Zero (a, b, c) where+   zero = (zero, zero, zero)++instance (Zero a, Zero b, Zero c, Zero d) => Zero (a, b, c, d) where+   zero = (zero, zero, zero, zero)++instance (Zero a) => Zero (Complex a) where+   zero = zeroPointed++instance (Unary.Natural n, Zero a) => Zero (FixedLength.T n a) where+   zero = zeroPointed++zeroPointed :: (Zero a, Applicative f) => f a+zeroPointed = pure zero
+ src/LLVM/Extra/Vector.hs view
@@ -0,0 +1,1072 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Vector (+   Simple (shuffleMatch, extract), C (insert),+   Element, Size,+   Canonical, Construct,++   size, sizeInTuple,+   replicate, iterate, assemble,++   shuffle,+   rotateUp, rotateDown, reverse,+   shiftUp, shiftDown,+   shiftUpMultiZero, shiftDownMultiZero,++   shuffleMatchTraversable,+   shuffleMatchAccess,+   shuffleMatchPlain1,+   shuffleMatchPlain2,++   insertTraversable,+   extractTraversable,+   extractAll,++   Constant, constant,++   insertChunk, modify,+   map, mapChunks, zipChunksWith,+   chop, concat,+   signedFraction,+   cumulate1,+   Arithmetic+      (sum, sumToPair, sumInterleavedToPair,+       cumulate, dotProduct, mul),+   Real+      (min, max, abs, signum,+       truncate, floor, fraction),+   ) where++import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.Extra.ArithmeticPrivate as A+import qualified LLVM.Util.Intrinsic as Intrinsic++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, ConstValue, valueOf, value, constOf, undef,+    Vector, insertelement, extractelement,+    IsConst, IsArithmetic, IsFloating,+    IsPrimitive,+    CodeGenFunction, )++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Data.Num.Decimal ((:+:))++import qualified Control.Applicative as App+import qualified Control.Monad.HT as M+import Control.Monad.HT ((<=<), )+import Control.Monad (liftM2, liftM3, foldM, )+import Control.Applicative (liftA2, )++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.NonEmpty.Class as NonEmptyC+import qualified Data.NonEmpty as NonEmpty+import qualified Data.List.HT as ListHT+import qualified Data.List as List+import Data.NonEmpty ((!:), )++import Data.Int  (Int8, Int16, Int32, Int64, )+import Data.Word (Word8, Word16, Word32, Word64, Word)++import Prelude hiding+          (Real, truncate, floor, round,+           map, zipWith, iterate, replicate, reverse, concat, sum, )+++-- * target independent functions++{- |+Allow to work on records of vectors as if they are vectors of records.+This is a reasonable approach for records of different element types+since processor vectors can only be built from elements of the same type.+But also, say, for chunked stereo signal this makes sense.+In this case we would work on @Stereo (Value a)@.++Formerly we used a two-way dependency Vector <-> (Element, Size).+Now we have only the dependency Vector -> (Element, Size).+This means that we need some more type annotations+as in umul32to64/assemble,+on the other hand we can allow multiple vector types+with respect to the same element type.+E.g. we can provide a vector type with pair elements+where the pair elements are interleaved in the vector.+-}+class (Simple v) => C v where+   insert :: Value Word32 -> Element v -> v -> CodeGenFunction r v++class+   (TypeNum.Positive (Size v), Tuple.Phi v, Tuple.Undefined v) =>+      Simple v where++   type Element v+   type Size v++   shuffleMatch ::+      ConstValue (Vector (Size v) Word32) -> v -> CodeGenFunction r v++   extract :: Value Word32 -> v -> CodeGenFunction r (Element v)+++instance+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+      Simple (Value (Vector n a)) where++   type Element (Value (Vector n a)) = Value a+   type Size (Value (Vector n a)) = n++   shuffleMatch is v = shuffleMatchPlain1 v is+   extract k v = extractelement v k++instance+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+      C (Value (Vector n a)) where++   insert k a v = insertelement v a k+++instance+   (Simple v0, Simple v1, Size v0 ~ Size v1) =>+      Simple (v0, v1) where++   type Element (v0, v1) = (Element v0, Element v1)+   type Size (v0, v1) = Size v0++   shuffleMatch is (v0,v1) =+      liftM2 (,)+         (shuffleMatch is v0)+         (shuffleMatch is v1)++   extract k (v0,v1) =+      liftM2 (,)+         (extract k v0)+         (extract k v1)++instance+   (C v0, C v1, Size v0 ~ Size v1) =>+      C (v0, v1) where++   insert k (a0,a1) (v0,v1) =+      liftM2 (,)+         (insert k a0 v0)+         (insert k a1 v1)+++instance+   (Simple v0, Simple v1, Simple v2, Size v0 ~ Size v1, Size v1 ~ Size v2) =>+      Simple (v0, v1, v2) where++   type Element (v0, v1, v2) = (Element v0, Element v1, Element v2)+   type Size (v0, v1, v2) = Size v0++   shuffleMatch is (v0,v1,v2) =+      liftM3 (,,)+         (shuffleMatch is v0)+         (shuffleMatch is v1)+         (shuffleMatch is v2)++   extract k (v0,v1,v2) =+      liftM3 (,,)+         (extract k v0)+         (extract k v1)+         (extract k v2)++instance+   (C v0, C v1, C v2, Size v0 ~ Size v1, Size v1 ~ Size v2) =>+      C (v0, v1, v2) where++   insert k (a0,a1,a2) (v0,v1,v2) =+      liftM3 (,,)+         (insert k a0 v0)+         (insert k a1 v1)+         (insert k a2 v2)+++newtype Constant n a = Constant a++constant :: (TypeNum.Positive n) => a -> Constant n a+constant = Constant++instance Functor (Constant n) where+   {-# INLINE fmap #-}+   fmap f (Constant a) = Constant (f a)++instance App.Applicative (Constant n) where+   {-# INLINE pure #-}+   pure = Constant+   {-# INLINE (<*>) #-}+   Constant f <*> Constant a = Constant (f a)++instance Fold.Foldable (Constant n) where+   {-# INLINE foldMap #-}+   foldMap = Trav.foldMapDefault++instance Trav.Traversable (Constant n) where+   {-# INLINE sequenceA #-}+   sequenceA (Constant a) = fmap Constant a++instance (Tuple.Phi a) => Tuple.Phi (Constant n a) where+   phi = Tuple.phiTraversable+   addPhi = Tuple.addPhiFoldable++instance (Tuple.Undefined a) => Tuple.Undefined (Constant n a) where+   undef = Tuple.undefPointed++instance (TypeNum.Positive n, Tuple.Phi a, Tuple.Undefined a) => Simple (Constant n a) where++   type Element (Constant n a) = a+   type Size (Constant n a) = n++   shuffleMatch _ = return+   extract _ (Constant a) = return a+++class (n ~ Size (Construct n a), a ~ Element (Construct n a),+       C (Construct n a)) =>+         Canonical n a where+   type Construct n a++instance+   (TypeNum.Positive n, LLVM.IsPrimitive a) =>+      Canonical n (Value a) where+   type Construct n (Value a) = Value (Vector n a)++instance (Canonical n a0, Canonical n a1) => Canonical n (a0, a1) where+   type Construct n (a0, a1) = (Construct n a0, Construct n a1)++instance (Canonical n a0, Canonical n a1, Canonical n a2) => Canonical n (a0, a1, a2) where+   type Construct n (a0, a1, a2) = (Construct n a0, Construct n a1, Construct n a2)+++size ::+   (TypeNum.Positive n) =>+   Value (Vector n a) -> Int+size =+   let sz :: (TypeNum.Positive n) => TypeNum.Singleton n -> Value (Vector n a) -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton++{- |+Manually assemble a vector of equal values.+Better use ScalarOrVector.replicate.+-}+replicate ::+   (C v) =>+   Element v -> CodeGenFunction r v+replicate = replicateCore TypeNum.singleton++replicateCore ::+   (C v) =>+   TypeNum.Singleton (Size v) -> Element v -> CodeGenFunction r v+replicateCore n =+   assemble . List.replicate (TypeNum.integralFromSingleton n)++{- |+construct a vector out of single elements++You must assert that the length of the list matches the vector size.++This can be considered the inverse of 'extractAll'.+-}+assemble ::+   (C v) =>+   [Element v] -> CodeGenFunction r v+assemble =+   foldM (\v (k,x) -> insert (valueOf k) x v) Tuple.undef .+   List.zip [0..]+{- sends GHC into an infinite loop+   foldM (\(k,x) -> insert (valueOf k) x) Tuple.undef .+   List.zip [0..]+-}++insertChunk ::+   (C c, C v, Element c ~ Element v) =>+   Int -> c ->+   v -> CodeGenFunction r v+insertChunk k x =+   M.chain $+   List.zipWith+      (\i j -> \v ->+          extract (valueOf i) x >>= \e ->+          insert (valueOf j) e v)+      (take (sizeInTuple x) [0..])+      [fromIntegral k ..]++iterate ::+   (C v) =>+   (Element v -> CodeGenFunction r (Element v)) ->+   Element v -> CodeGenFunction r v+iterate f x =+   fmap snd $+   iterateCore f x Tuple.undef++iterateCore ::+   (C v) =>+   (Element v -> CodeGenFunction r (Element v)) ->+   Element v -> v ->+   CodeGenFunction r (Element v, v)+iterateCore f x0 v0 =+   foldM+      (\(x,v) k ->+         liftM2 (,) (f x)+            (insert (valueOf k) x v))+      (x0,v0)+      (take (sizeInTuple v0) [0..])++{- |+Manually implement vector shuffling using insertelement and extractelement.+In contrast to LLVM's built-in instruction it supports distinct vector sizes,+but it allows only one input vector+(or a tuple of vectors, but we cannot shuffle between them).+For more complex shuffling we recommend 'extractAll' and 'assemble'.+-}+shuffle ::+   (C v, C w, Element v ~ Element w) =>+   v ->+   ConstValue (Vector (Size w) Word32) ->+   CodeGenFunction r w+shuffle x i =+   assemble =<<+   mapM+      (flip extract x <=< extractelement (value i) . valueOf)+      (take (size (value i)) [0..])+++sizeInTuple :: Simple v => v -> Int+sizeInTuple =+   let sz :: Simple v => TypeNum.Singleton (Size v) -> v -> Int+       sz n _ = TypeNum.integralFromSingleton n+   in  sz TypeNum.singleton++constCyclicVector ::+   (IsConst a, TypeNum.Positive n) =>+   NonEmpty.T [] a -> ConstValue (Vector n a)+constCyclicVector =+   LLVM.constCyclicVector . fmap constOf++{- |+Rotate one element towards the higher elements.++I don't want to call it rotateLeft or rotateRight,+because there is no prefered layout for the vector elements.+In Intel's instruction manual vector+elements are indexed like the bits,+that is from right to left.+However, when working with Haskell list and enumeration syntax,+the start index is left.+-}+rotateUp ::+   (Simple v) =>+   v -> CodeGenFunction r v+rotateUp x =+   shuffleMatch+      (constCyclicVector $+       (fromIntegral (sizeInTuple x) - 1) !: [0..]) x++rotateDown ::+   (Simple v) =>+   v -> CodeGenFunction r v+rotateDown x =+   shuffleMatch+      (constCyclicVector $+       NonEmpty.snoc (List.take (sizeInTuple x - 1) [1..]) 0) x++reverse ::+   (Simple v) =>+   v -> CodeGenFunction r v+reverse x =+   shuffleMatch+      (constCyclicVector $+       maybe (error "vector size must be positive") NonEmpty.reverse $+       NonEmpty.fetch $+       List.take (sizeInTuple x) [0..])+      x++shiftUp ::+   (C v) =>+   Element v -> v -> CodeGenFunction r (Element v, v)+shiftUp x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $ undef !: List.map constOf [0..]) x+   liftM2 (,)+      (extract (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x)+      (insert (value LLVM.zero) x0 y)++shiftDown ::+   (C v) =>+   Element v -> v -> CodeGenFunction r (Element v, v)+shiftDown x0 x = do+   y <-+      shuffleMatch+         (LLVM.constCyclicVector $+          NonEmpty.snoc+             (List.map constOf $ List.take (sizeInTuple x - 1) [1..])+             undef) x+   liftM2 (,)+      (extract (value LLVM.zero) x)+      (insert (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x0 y)++shiftUpMultiZero ::+   (C v, Tuple.Zero (Element v)) =>+   Int -> v -> LLVM.CodeGenFunction r v+shiftUpMultiZero n v =+   assemble . take (sizeInTuple v) .+   (List.replicate n Tuple.zero ++) =<< extractAll v++shiftDownMultiZero ::+   (C v, Tuple.Zero (Element v)) =>+   Int -> v -> LLVM.CodeGenFunction r v+shiftDownMultiZero n v =+   assemble . take (sizeInTuple v) .+   (++ List.repeat Tuple.zero) . List.drop n+      =<< extractAll v+++shuffleMatchTraversable ::+   (Simple v, Trav.Traversable f) =>+   ConstValue (Vector (Size v) Word32) -> f v -> CodeGenFunction r (f v)+shuffleMatchTraversable is v =+   Trav.mapM (shuffleMatch is) v++{- |+Implement the 'shuffleMatch' method using the methods of the 'C' class.+-}+shuffleMatchAccess ::+   (C v) =>+   ConstValue (Vector (Size v) Word32) -> v -> CodeGenFunction r v+shuffleMatchAccess is v =+   assemble =<<+   mapM+      (flip extract v <=<+       flip extract (value is) . valueOf)+      (take (size (value is)) [0..])+++shuffleMatchPlain1 ::+   (TypeNum.Positive n, IsPrimitive a) =>+   Value (Vector n a) ->+   ConstValue (Vector n Word32) ->+   CodeGenFunction r (Value (Vector n a))+shuffleMatchPlain1 x =+   shuffleMatchPlain2 x (value undef)++shuffleMatchPlain2 ::+   (TypeNum.Positive n, IsPrimitive a) =>+   Value (Vector n a) ->+   Value (Vector n a) ->+   ConstValue (Vector n Word32) ->+   CodeGenFunction r (Value (Vector n a))+shuffleMatchPlain2 =+   LLVM.shufflevector+++insertTraversable ::+   (C v, Trav.Traversable f, App.Applicative f) =>+   Value Word32 -> f (Element v) -> f v -> CodeGenFunction r (f v)+insertTraversable n a v =+   Trav.sequence (liftA2 (insert n) a v)++extractTraversable ::+   (Simple v, Trav.Traversable f) =>+   Value Word32 -> f v -> CodeGenFunction r (f (Element v))+extractTraversable n v =+   Trav.mapM (extract n) v++{- |+provide the elements of a vector as a list of individual virtual registers++This can be considered the inverse of 'assemble'.+-}+extractAll ::+   (Simple v) =>+   v -> LLVM.CodeGenFunction r [Element v]+extractAll = sequence . extractList++extractList ::+   (Simple v) =>+   v -> [LLVM.CodeGenFunction r (Element v)]+extractList x =+   List.map+      (flip extract x . LLVM.valueOf)+      (take (sizeInTuple x) [0..])+++modify ::+   (C v) =>+   Value Word32 ->+   (Element v -> CodeGenFunction r (Element v)) ->+   (v -> CodeGenFunction r v)+modify k f v =+   flip (insert k) v =<< f =<< extract k v++{- |+Like LLVM.Util.Loop.mapVector but the loop is unrolled,+which is faster since it can be packed by the code generator.+-}+map, _mapByFold ::+   (C v, C w, Size v ~ Size w) =>+   (Element v -> CodeGenFunction r (Element w)) ->+   (v -> CodeGenFunction r w)+map f =+   assemble <=< mapM f <=< extractAll++_mapByFold f a =+   foldM+      (\b n ->+         extract (valueOf n) a >>=+         f >>=+         flip (insert (valueOf n)) b)+      Tuple.undef+      (take (sizeInTuple a) [0..])++mapChunks ::+   (C ca, C cb, Size ca ~ Size cb,+    C va, C vb, Size va ~ Size vb,+    Element ca ~ Element va, Element cb ~ Element vb) =>+   (ca -> CodeGenFunction r cb) ->+   (va -> CodeGenFunction r vb)+mapChunks f a =+   foldM+      (\b (am,k) ->+         am >>= \ac ->+         f ac >>= \bc ->+         insertChunk (k * sizeInTuple ac) bc b)+      Tuple.undef $+   List.zip (chop a) [0..]++zipChunksWith ::+   (C ca, C cb, C cc, Size ca ~ Size cb, Size cb ~ Size cc,+    C va, C vb, C vc, Size va ~ Size vb, Size vb ~ Size vc,+    Element ca ~ Element va, Element cb ~ Element vb, Element cc ~ Element vc) =>+   (ca -> cb -> CodeGenFunction r cc) ->+   (va -> vb -> CodeGenFunction r vc)+zipChunksWith f a b =+   mapChunks (uncurry f) (a,b)+++mapChunks2 ::+   (C ca, C cb, Size ca ~ Size cb,+    C la, C lb, Size la ~ Size lb,+    C va, C vb, Size va ~ Size vb,+    Element ca ~ Element va, Element la ~ Element va,+    Element cb ~ Element vb, Element lb ~ Element vb) =>+   (ca -> CodeGenFunction r cb) ->+   (la -> CodeGenFunction r lb) ->+   (va -> CodeGenFunction r vb)+mapChunks2 f g a = do+   let chunkSize :: C ca => (ca -> cgf) -> TypeNum.Singleton (Size ca) -> Int+       chunkSize _ = TypeNum.integralFromSingleton+   xs <- extractAll a+   case ListHT.viewR $+        ListHT.sliceVertical (chunkSize g TypeNum.singleton) xs of+      Nothing -> assemble []+      Just (cs,c) -> do+         ds <- mapM (extractAll <=< g <=< assemble) cs+         d <-+            if List.length c <= chunkSize f TypeNum.singleton+              then fmap List.concat $+                   mapM (extractAll <=< f <=< assemble) $+                   ListHT.sliceVertical (chunkSize f TypeNum.singleton) c+              else extractAll =<< g =<< assemble c+         assemble $ List.concat ds ++ d++_zipChunks2With ::+   (C ca, C cb, C cc, Size ca ~ Size cb, Size cb ~ Size cc,+    C la, C lb, C lc, Size la ~ Size lb, Size lb ~ Size lc,+    C va, C vb, C vc, Size va ~ Size vb, Size vb ~ Size vc,+    Element ca ~ Element va, Element la ~ Element va,+    Element cb ~ Element vb, Element lb ~ Element vb,+    Element cc ~ Element vc, Element lc ~ Element vc) =>+   (ca -> cb -> CodeGenFunction r cc) ->+   (la -> lb -> CodeGenFunction r lc) ->+   (va -> vb -> CodeGenFunction r vc)+_zipChunks2With f g a b =+   mapChunks2 (uncurry f) (uncurry g) (a,b)++++{- |+Ideally on ix86 with SSE41 this would be translated to 'dpps'.+-}+dotProductPartial ::+   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+   Int ->+   Value (Vector n a) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value a)+dotProductPartial n x y =+   sumPartial n =<< A.mul x y++sumPartial ::+   (TypeNum.Positive n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+   Int ->+   Value (Vector n a) ->+   CodeGenFunction r (Value a)+sumPartial n x =+   foldl1+      {- quite the same as (+) using LLVM.Arithmetic instances,+         but requires less type constraints -}+      (M.liftJoin2 A.add)+      (List.map (LLVM.extractelement x . valueOf) $ take n $ [0..])+++{- |+If the target vector type is a native type+then the chop operation produces no actual machine instruction. (nop)+If the vector cannot be evenly divided into chunks+the last chunk will be padded with undefined values.+-}+chop ::+   (C c, C v, Element c ~ Element v) =>+   v -> [CodeGenFunction r c]+chop = chopCore TypeNum.singleton++chopCore ::+   (C c, C v, Element c ~ Element v) =>+   TypeNum.Singleton (Size c) -> v -> [CodeGenFunction r c]+chopCore m x =+   List.map (assemble <=< sequence) $+   ListHT.sliceVertical (TypeNum.integralFromSingleton m) $+   extractList x++{- |+The target size is determined by the type.+If the chunk list provides more data, the exceeding data is dropped.+If the chunk list provides too few data,+the target vector is filled with undefined elements.+-}+concat ::+   (C c, C v, Element c ~ Element v) =>+   [c] -> CodeGenFunction r v+concat xs =+   foldM+      (\v0 (js,c) ->+         foldM+            (\v (i,j) -> do+               x <- extract (valueOf i) c+               insert (valueOf j) x v)+            v0 $+         List.zip [0..] js)+      Tuple.undef $+   List.zip+      (ListHT.sliceVertical (sizeInTuple (head xs)) [0..])+      xs+++getLowestPair ::+   (TypeNum.Positive n, IsPrimitive a) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value a, Value a)+getLowestPair x =+   liftM2 (,)+      (extractelement x (valueOf 0))+      (extractelement x (valueOf 1))+++_reduceAddInterleaved ::+   (IsArithmetic a, IsPrimitive a,+    TypeNum.Positive n, TypeNum.Positive m, (m :+: m) ~ n) =>+   TypeNum.Singleton m ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector m a))+_reduceAddInterleaved tm v = do+   let m = TypeNum.integralFromSingleton tm+   x <- shuffle v (constCyclicVector $ NonEmptyC.iterate succ 0)+   y <- shuffle v (constCyclicVector $ NonEmptyC.iterate succ m)+   A.add x y++sumGeneric ::+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value a)+sumGeneric =+   flip extractelement (valueOf 0) <=<+   reduceSumInterleaved 1++sumToPairGeneric ::+   (Arithmetic a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value a, Value a)+sumToPairGeneric v =+   let n2 = div (size v) 2+   in  sumInterleavedToPair =<<+       shuffleMatchPlain1 v+          (maybe (error "vector size must be positive") LLVM.constCyclicVector $+           NonEmpty.fetch $+           List.map (constOf . fromIntegral) $+           concatMap (\k -> [k, k+n2]) [0..])++{- |+We partition a vector of size n into chunks of size m+and add these chunks using vector additions.+We do this by repeated halving of the vector,+since this way we do not need assumptions about the native vector size.++We reduce the vector size only virtually,+that is we maintain the vector size and fill with undefined values.+This is reasonable+since LLVM-2.5 and LLVM-2.6 does not allow shuffling between vectors of different size+and because it likes to do computations on Vector D2 Float+in MMX registers on ix86 CPU's,+which interacts badly with FPU usage.+Since we fill the vector with undefined values,+LLVM actually treats the vectors like vectors of smaller size.+-}+reduceSumInterleaved ::+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>+   Int ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+reduceSumInterleaved m x0 =+   let go ::+          (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>+          Int ->+          Value (Vector n a) ->+          CodeGenFunction r (Value (Vector n a))+       go n x =+          if m==n+            then return x+            else+               let n2 = div n 2+               in  go n2+                      =<< A.add x+                      =<< shuffleMatchPlain1 x+                             (LLVM.constCyclicVector $+                              NonEmpty.appendLeft+                                 (List.map constOf $+                                  take n2 [fromIntegral n2 ..])+                                 (NonEmptyC.repeat undef))+   in  go (size x0) x0++cumulateGeneric, _cumulateSimple ::+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>+   Value a -> Value (Vector n a) ->+   CodeGenFunction r (Value a, Value (Vector n a))+_cumulateSimple a x =+   foldM+      (\(a0,y0) k -> do+         a1 <- A.add a0 =<< extract (valueOf k) x+         y1 <- insert (valueOf k) a0 y0+         return (a1,y1))+      (a, Tuple.undef)+      (take (sizeInTuple x) $ [0..])++cumulateGeneric =+   cumulateFrom1 cumulate1++cumulateFrom1 ::+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>+   (Value (Vector n a) ->+    CodeGenFunction r (Value (Vector n a))) ->+   Value a -> Value (Vector n a) ->+   CodeGenFunction r (Value a, Value (Vector n a))+cumulateFrom1 cum a x0 = do+   (b,x1) <- shiftUp a x0+   y <- cum x1+   z <- A.add b =<< extract (valueOf (fromIntegral (sizeInTuple x0) - 1)) y+   return (z,y)+++{- |+Needs (log n) vector additions+-}+cumulate1 ::+   (IsArithmetic a, IsPrimitive a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+cumulate1 x =+   foldM+      (\y k -> A.add y =<< shiftUpMultiZero k y)+      x+      (takeWhile (<sizeInTuple x) $ List.iterate (2*) 1)+++{-+{- |+This one does not use vectorized select.+Cf. the outcommented signumInt.+-}+signumInt ::+   (TypeNum.Positive n,+    IsPrimitive a, IsArithmetic a, IsConst a, Num a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ b,+    IsPrimitive b, LLVM.IsInteger b) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signumInt x = do+   let zero = LLVM.value LLVM.zero+   negative <- A.cmp LLVM.CmpLT x zero+   positive <- A.cmp LLVM.CmpGT x zero+   map+      (\(n,p) ->+         LLVM.select n (valueOf (-1))+            =<< LLVM.select p (valueOf 1) (LLVM.value LLVM.zero))+      (negative, positive)++signumWord ::+   (TypeNum.Positive n,+    IsPrimitive a, IsArithmetic a, IsConst a, Num a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ b,+    IsPrimitive b, LLVM.IsInteger b) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signumWord x = do+   positive <- A.cmp LLVM.CmpGT x (LLVM.value LLVM.zero)+   map+      (\p -> LLVM.select p (valueOf 1) (LLVM.value LLVM.zero))+      positive+-}++signumIntGeneric ::+   (TypeNum.Positive n,+    {- TypeNum.Positive (n :*: LLVM.SizeOf a), -}+    IsPrimitive a, LLVM.IsInteger a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ b,+    IsPrimitive b, LLVM.IsInteger b) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signumIntGeneric x = do+   let zero = LLVM.value LLVM.zero+   negative <- LLVM.sadapt =<< A.cmp LLVM.CmpLT x zero+   positive <- LLVM.sadapt =<< A.cmp LLVM.CmpGT x zero+   A.sub negative positive++signumWordGeneric ::+   (TypeNum.Positive n,+    IsPrimitive a, LLVM.IsInteger a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ b,+    IsPrimitive b, LLVM.IsInteger b) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signumWordGeneric x =+   LLVM.zadapt =<< A.cmp LLVM.CmpGT x (LLVM.value LLVM.zero)++signumFloatGeneric ::+   (TypeNum.Positive n,+    IsPrimitive a, IsArithmetic a, IsFloating a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ b,+    IsPrimitive b, LLVM.IsInteger b) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signumFloatGeneric x = do+   let zero = LLVM.value LLVM.zero+   negative <- LLVM.sitofp =<< A.cmp LLVM.CmpLT x zero+   positive <- LLVM.sitofp =<< A.cmp LLVM.CmpGT x zero+   A.sub negative positive+++signedFraction ::+   (IsFloating a, IsConst a, Real a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signedFraction x =+   A.sub x =<< truncate x+++-- * target independent functions with target dependent optimizations++{- |+The order of addition is chosen for maximum efficiency.+We do not try to prevent cancelations.+-}+class (IsArithmetic a, IsPrimitive a) => Arithmetic a where+   sum ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value a)+   sum = sumGeneric++   {- |+   The first result value is the sum of all vector elements from 0 to @div n 2 + 1@+   and the second result value is the sum of vector elements from @div n 2@ to @n-1@.+   n must be at least D2.+   -}+   sumToPair ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value a, Value a)+   sumToPair = sumToPairGeneric++   {- |+   Treat the vector as concatenation of pairs and all these pairs are added.+   Useful for stereo signal processing.+   n must be at least D2.+   -}+   sumInterleavedToPair ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value a, Value a)+   sumInterleavedToPair v =+      getLowestPair =<< reduceSumInterleaved 2 v++   cumulate ::+      (TypeNum.Positive n) =>+      Value a -> Value (Vector n a) ->+      CodeGenFunction r (Value a, Value (Vector n a))+   cumulate = cumulateGeneric++   dotProduct ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      Value (Vector n a) ->+      CodeGenFunction r (Value a)+   dotProduct x y =+      dotProductPartial (size x) x y++   mul ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))+   mul = A.mul++instance Arithmetic Float where+instance Arithmetic Double where++instance Arithmetic Int    where+instance Arithmetic Int8   where+instance Arithmetic Int16  where+instance Arithmetic Int32  where+instance Arithmetic Int64  where+instance Arithmetic Word   where+instance Arithmetic Word8  where+instance Arithmetic Word16 where+instance Arithmetic Word32 where+instance Arithmetic Word64 where++++class (Arithmetic a, LLVM.CmpRet a, LLVM.IsPrimitive a, IsConst a) =>+         Real a where+   min, max ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++   abs ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++   signum ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++   truncate, floor, fraction ::+      (TypeNum.Positive n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++instance Real Float where+   min = Intrinsic.min+   max = Intrinsic.max+   abs = Intrinsic.abs+   signum = signumFloatGeneric+   truncate = Intrinsic.truncate+   floor = Intrinsic.floor+   fraction = A.fraction++instance Real Double where+   min = Intrinsic.min+   max = Intrinsic.max+   abs = Intrinsic.abs+   signum = signumFloatGeneric+   truncate = Intrinsic.truncate+   floor = Intrinsic.floor+   fraction = A.fraction++instance Real Int where+   min = A.min+   max = A.max+   abs = A.abs+   signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int8 where+   min = A.min+   max = A.max+   abs = A.abs+   signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int16 where+   min = A.min+   max = A.max+   abs = A.abs+   signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int32 where+   min = A.min+   max = A.max+   abs = A.abs+   signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int64 where+   min = A.min+   max = A.max+   abs = A.abs+   signum = signumIntGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word where+   min = A.min+   max = A.max+   abs = return+   signum = signumWordGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word8 where+   min = A.min+   max = A.max+   abs = return+   signum = signumWordGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word16 where+   min = A.min+   max = A.max+   abs = return+   signum = signumWordGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word32 where+   min = A.min+   max = A.max+   abs = return+   signum = signumWordGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word64 where+   min = A.min+   max = A.max+   abs = return+   signum = signumWordGeneric+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)
+ test/LLVM/Extra/VectorAlt.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+This maintains old code for LLVM-2.6+where vector comparison and select on X86+did not work or generated cumbersome assembly code.+It may still be useful for testing.+-}+module LLVM.Extra.VectorAlt where++import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Util.Intrinsic as Intrinsic+import qualified LLVM.Core.Guided as Guided+import qualified LLVM.Core as LLVM+import LLVM.Core+   (CodeGenFunction, Value, valueOf, value, Vector,+    CmpRet, IsConst, IsArithmetic, IsFloating, IsPrimitive)++import qualified Type.Data.Num.Decimal as TypeNum++import Data.Tuple.HT (uncurry3, )++import Data.Int  (Int8, Int16, Int32, Int64, )+import Data.Word (Word8, Word16, Word32, Word64, )++import Prelude hiding (max, min, abs, signum, floor, truncate)++++{-+Can be used for both integer and float types,+but we need it only for Float types,+because LLVM produces ugly code for Float and even more ugly code for Double.+-}+signum ::+   (TypeNum.Positive n,+    IsPrimitive a, IsPrimitive b, IsArithmetic b) =>+   (Value (Vector n a) ->+    Value (Vector n a) ->+    CodeGenFunction r (Value (Vector n b))) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n b))+signum gt x = do+   let zero = LLVM.value LLVM.zero+   negative <- gt zero x+   positive <- gt x zero+   A.sub negative positive++ext2 ::+   (TypeNum.Positive n) =>+   Value (Vector n Bool) ->+   CodeGenFunction r (Value (Vector n (LLVM.IntN TypeNum.D2)))+ext2 = Guided.extBool Guided.vector++{- |+This has least instruction count for Vector D4 Float on X86.+-}+signumFloat ::+   (TypeNum.Positive n,+    IsPrimitive a, IsArithmetic a, IsFloating a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ Bool) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signumFloat x = do+   let zero = LLVM.value LLVM.zero+   negative <- ext2 =<< A.cmp LLVM.CmpLT x zero+   positive <- ext2 =<< A.cmp LLVM.CmpGT x zero+   LLVM.sitofp =<< A.sub negative positive+++select ::+   (TypeNum.Positive n, LLVM.IsFirstClass a, IsPrimitive a,+    LLVM.CmpRet a, LLVM.CmpResult a ~ Bool) =>+   Value (Vector n Bool) ->+   Value (Vector n a) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+select b x y =+   Vector.map (uncurry3 LLVM.select) (b, x, y)+++floor ::+   (TypeNum.Positive n, IsFloating a, Vector.Real a) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+floor = floorLogical A.fcmp++fraction ::+   (TypeNum.Positive n, IsFloating a, Vector.Real a) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+fraction = fractionLogical A.fcmp+++floorLogical ::+   (TypeNum.Positive n, IsFloating a, Vector.Real a,+    IsPrimitive i, LLVM.IsInteger i) =>+   (LLVM.FPPredicate ->+    Value (Vector n a) ->+    Value (Vector n a) ->+    CodeGenFunction r (Value (Vector n i))) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+floorLogical cmp x = do+   xr <- Intrinsic.truncate x+   b <- cmp LLVM.FPOGT xr x+   A.add xr =<< LLVM.sitofp b++fractionLogical ::+   (TypeNum.Positive n, IsFloating a, Vector.Real a,+    IsPrimitive i, LLVM.IsInteger i) =>+   (LLVM.FPPredicate ->+    Value (Vector n a) ->+    Value (Vector n a) ->+    CodeGenFunction r (Value (Vector n i))) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+fractionLogical cmp x = do+   xf <- Vector.signedFraction x+   b <- cmp LLVM.FPOLT xf (value LLVM.zero)+   A.sub xf =<< LLVM.sitofp b+++{- |+'floor' implemented using 'select'.+This will need jumps.+-}+floorSelect ::+   (TypeNum.Positive n, Num a, IsFloating a, Vector.Real a) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+floorSelect x = do+   xr <- Intrinsic.truncate x+   b <- A.fcmp LLVM.FPOLE xr x+   select b xr =<< A.sub xr =<< Vector.replicate (valueOf 1)++{- |+'fraction' implemented using 'select'.+This will need jumps.+-}+fractionSelect ::+   (TypeNum.Positive n, Num a, IsFloating a, Vector.Real a) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+fractionSelect x = do+   xf <- Vector.signedFraction x+   b <- A.fcmp LLVM.FPOGE xf (value LLVM.zero)+   select b xf =<< A.add xf =<< Vector.replicate (valueOf 1)+++class (LLVM.IsSized a, LLVM.IsSized (Mask a),+       LLVM.SizeOf a ~ LLVM.SizeOf (Mask a),+       LLVM.IsPrimitive a, LLVM.IsPrimitive (Mask a),+       LLVM.IsInteger (Mask a)) =>+         Maskable a where+   type Mask a :: *++instance Maskable Int8   where type Mask Int8   = Int8+instance Maskable Int16  where type Mask Int16  = Int16+instance Maskable Int32  where type Mask Int32  = Int32+instance Maskable Int64  where type Mask Int64  = Int64+instance Maskable Word8  where type Mask Word8  = Int8+instance Maskable Word16 where type Mask Word16 = Int16+instance Maskable Word32 where type Mask Word32 = Int32+instance Maskable Word64 where type Mask Word64 = Int64+instance Maskable Float  where type Mask Float  = Int32+instance Maskable Double where type Mask Double = Int64++makeMask ::+   (Maskable a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   Value (Vector n Bool) ->+   CodeGenFunction r (Value (Vector n (Mask a)))+makeMask _ = Guided.extBool Guided.vector+++min, max ::+   (IsConst a, IsArithmetic a, CmpRet a, Maskable a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))++min x y = do+   b <- makeMask x =<< A.cmp LLVM.CmpLT x y+   selectLogical b x y++max x y = do+   b <- makeMask x =<< A.cmp LLVM.CmpGT x y+   selectLogical b x y++abs ::+   (IsConst a, IsArithmetic a, CmpRet a, Maskable a, TypeNum.Positive n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+abs x = max x =<< LLVM.neg x+++{- |+Another implementation of 'select',+this time in terms of binary logical operations.+The selecting integers must be+(-1) for selecting an element from the first operand+and 0 for selecting an element from the second operand.+This leads to optimal code.++On SSE41 this could be done with blendvps or blendvpd.+-}+selectLogical ::+   (LLVM.IsFirstClass a, IsPrimitive a,+    LLVM.IsInteger i, IsPrimitive i,+    LLVM.IsSized a, LLVM.IsSized i,+    LLVM.SizeOf a ~ LLVM.SizeOf i,+    TypeNum.Positive n) =>+   Value (Vector n i) ->+   Value (Vector n a) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+selectLogical b x y = do+   bneg <- LLVM.inv b+   xm <- A.and b    =<< Guided.bitcast Guided.vector x+   ym <- A.and bneg =<< Guided.bitcast Guided.vector y+   Guided.bitcast Guided.vector =<< A.or xm ym
+ test/Main.hs view
@@ -0,0 +1,25 @@+module Main where++import qualified Test.Storable as Storable+import qualified Test.Vector as Vector++import qualified LLVM.Core as LLVM++import Data.Tuple.HT (mapFst)++import Control.Monad.IO.Class (liftIO)++import qualified Test.DocTest.Driver as DocTest+++main :: IO ()+main = do+   LLVM.initializeNativeTarget++   DocTest.run $ mapM_+      (\(msg,prop) -> do+         DocTest.printPrefix (msg++": ")+         DocTest.property =<< liftIO prop) $+      map (mapFst ("Storable."++)) Storable.tests +++      map (mapFst ("Vector."++)) Vector.tests +++      []
+ test/Test/Storable.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Test.Storable (tests) where++import qualified LLVM.Extra.Storable as Storable+import qualified LLVM.Extra.Tuple as Tuple++import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum++import qualified Foreign+import Foreign.Storable.Record.Tuple (Tuple(Tuple))+import Foreign.Ptr (FunPtr, Ptr)++import Data.Complex (Complex)+import Data.Word (Word16, Word32)+import Data.Int (Int8, Int16, Int32)+import Data.Tuple.HT (mapFst)++import qualified Test.QuickCheck.Monadic as QCMon+import qualified Test.QuickCheck as QC++++type Importer func = FunPtr func -> func++generateFunction ::+   EE.ExecutionFunction f =>+   Importer f -> LLVM.CodeGenModule (LLVM.Function f) -> IO f+generateFunction imprt code = do+   m <- LLVM.newModule+   fn <- do+      func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> code+      EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func+   LLVM.writeBitcodeToFile "test-storable.bc" m+   return fn+++foreign import ccall safe "dynamic" derefTestCasePtr ::+   Importer (Ptr inp -> Ptr out -> IO ())++modul ::+   (Storable.C a, Tuple.ValueOf a ~ al) =>+   (Storable.C b, Tuple.ValueOf b ~ bl) =>+   (al -> LLVM.CodeGenFunction () bl) ->+   LLVM.CodeGenModule (LLVM.Function (Ptr a -> Ptr b -> IO ()))+modul codegen =+   LLVM.createFunction LLVM.ExternalLinkage $ \aPtr bPtr -> do+      flip Storable.store bPtr =<< codegen =<< Storable.load aPtr+      LLVM.ret ()++run ::+   (Show a) =>+   (Storable.C a, Tuple.ValueOf a ~ al) =>+   (Storable.C b, Tuple.ValueOf b ~ bl) =>+   QC.Gen a ->+   (al -> LLVM.CodeGenFunction () bl) ->+   (a -> b -> Bool) ->+   IO QC.Property+run qcgen codegen predicate = do+   funIO <- generateFunction derefTestCasePtr $ modul codegen+   return $ QC.forAll qcgen $ \a ->+      QCMon.monadicIO $ do+         b <-+            QCMon.run $+               Foreign.with a $ \aPtr ->+               Foreign.alloca $ \bPtr -> do+                  funIO aPtr bPtr+                  Foreign.peek bPtr+         QCMon.assert $ predicate a b+++roundTrip ::+   (Show a, Eq a, Storable.C a) =>+   QC.Gen a -> IO QC.Property+roundTrip qcgen = run qcgen return (==)+++tests :: [(String, IO QC.Property)]+tests =+   map (mapFst ("RoundTrip." ++)) $+   ("()",+      roundTrip (QC.arbitrary :: QC.Gen ())) :+   ("Float",+      roundTrip (QC.arbitrary :: QC.Gen Float)) :+   ("(Word16,Float)",+      roundTrip (fmap Tuple (QC.arbitrary :: QC.Gen (Word16,Float)))) :+   ("(Int8,Bool,Double)",+      roundTrip (fmap Tuple (QC.arbitrary :: QC.Gen (Int8,Bool,Double)))) :+   ("Complex Float",+      roundTrip (QC.arbitrary :: QC.Gen (Complex Float))) :+   ("Vector D3 Int32",+      roundTrip (QC.arbitrary :: QC.Gen (LLVM.Vector TypeNum.D3 Int32))) :+   ("Vector D7 (Int16,Word32)",+      roundTrip (fmap (fmap Tuple)+         (QC.arbitrary :: QC.Gen (LLVM.Vector TypeNum.D7 (Int16,Word32))))) :+   []
+ test/Test/Vector.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Test.Vector where++import qualified LLVM.Extra.ScalarOrVectorPrivate as SoVPriv+import qualified LLVM.Extra.ScalarOrVector as SoV+import qualified LLVM.Extra.VectorAlt as VectorAlt+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Memory as Memory+import qualified LLVM.Extra.Marshal as Marshal+import qualified LLVM.Extra.Tuple as Tuple+import qualified LLVM.ExecutionEngine as EE+import qualified LLVM.Core as LLVM++import qualified Type.Data.Num.Decimal as TypeNum+import Type.Base.Proxy (Proxy(Proxy))++import Foreign.Ptr (FunPtr)++import qualified Data.Traversable as Trav+import qualified Data.Foldable as Fold+import qualified Data.Bits as Bits+import Data.Word (Word8, Word16, Word32)+import Data.Int (Int8, Int32)++import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.Monadic as QCMon++import Control.Applicative (liftA2, pure)++import qualified Prelude as P+import Prelude hiding (min, max)+++type V4 = LLVM.Vector TypeNum.D4+type V5 = LLVM.Vector TypeNum.D5+type V4Word32 = V4 Word32+type V4Int32 = V4 Int32+type V4Float = V4 Float++type Importer func = FunPtr func -> func++generateFunction ::+   EE.ExecutionFunction f =>+   Importer f -> LLVM.CodeGenModule (LLVM.Function f) -> IO f+generateFunction imprt code = do+   m <- LLVM.newModule+   fn <- do+      func <- LLVM.defineModule m $ LLVM.setTarget LLVM.hostTriple >> code+      EE.runEngineAccessWithModule m $ EE.getExecutionFunction imprt func+   LLVM.writeBitcodeToFile "test-vector.bc" m+   return fn+++foreign import ccall safe "dynamic" derefTestCasePtr ::+   Importer (LLVM.Ptr inp -> LLVM.Ptr out -> IO ())++modul ::+   (Memory.C linp, Memory.Struct linp ~ minp, LLVM.IsType minp,+    Memory.C lout, Memory.Struct lout ~ mout, LLVM.IsType mout) =>+   (linp -> LLVM.CodeGenFunction () lout) ->+   LLVM.CodeGenModule (LLVM.Function (LLVM.Ptr minp -> LLVM.Ptr mout -> IO ()))+modul codegen =+   LLVM.createFunction LLVM.ExternalLinkage $ \xPtr yPtr -> do+      flip Memory.store yPtr =<< codegen =<< Memory.load xPtr+      LLVM.ret ()++run ::+   (Marshal.C inp, Marshal.Struct inp ~ minp, LLVM.IsType minp,+    Marshal.C out, Marshal.Struct out ~ mout, LLVM.IsType mout,+    Tuple.ValueOf inp ~ linp, Tuple.ValueOf out ~ lout) =>+   (Show inp, QC.Arbitrary inp) =>+   (linp -> LLVM.CodeGenFunction () lout) ->+   (inp -> out -> Bool) ->+   IO QC.Property+run codegen predicate = do+   funIO <- generateFunction derefTestCasePtr $ modul codegen+   return $ QC.property $ \x ->+      QCMon.monadicIO $ do+         y <-+            QCMon.run $+               Marshal.with x $ \xPtr ->+               Marshal.alloca $ \yPtr -> do+                  funIO xPtr yPtr+                  Marshal.peek yPtr+         QCMon.assert $ predicate x y+++vec4 :: V4 a -> V4 a+vec4 = id+++unop ::+   (LLVM.Value V4Int32 -> LLVM.CodeGenFunction () (LLVM.Value V4Int32)) ->+   (Int32 -> Int32) ->+   IO QC.Property+unop codegen fun =+   run codegen (\x y -> fmap fun (vec4 x) == vec4 y)++unopFloat ::+   (LLVM.Value V4Float -> LLVM.CodeGenFunction () (LLVM.Value V4Float)) ->+   (Float -> Float) ->+   IO QC.Property+unopFloat codegen fun =+   run codegen (\x y -> fmap fun (vec4 x) == vec4 y)+++binop ::+   ((TypeNum.D4 TypeNum.:*: LLVM.SizeOf a) ~ size, TypeNum.Natural size,+    QC.Arbitrary a, Show a, Eq a,+    Marshal.Vector TypeNum.D4 a, Tuple.VectorValueOf TypeNum.D4 a ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->+   (a -> a -> a) ->+   IO QC.Property+binop codegen fun =+   run (uncurry codegen)+      (\(x,y) z -> liftA2 fun (vec4 x) (vec4 y)  ==  vec4 z)++binopInt ::+   (LLVM.Value V4Int32 ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->+   (Int32 -> Int32 -> Int32) ->+   IO QC.Property+binopInt = binop+++type Int2 = LLVM.IntN TypeNum.D2+type Int3 = LLVM.IntN TypeNum.D3+type Word2 = LLVM.WordN TypeNum.D2+type Word3 = LLVM.WordN TypeNum.D3++vectorise ::+   (TypeNum.Positive n, Integral a) =>+   Integer -> a -> LLVM.Vector n Integer+vectorise modu x =+   snd $ Trav.mapAccumL (\xi f -> f xi) (toInteger x) $+   pure (\xi -> divMod xi modu)++unpackInts ::+   (TypeNum.Positive n, TypeNum.Positive d, Integral a) =>+   Integer -> a -> LLVM.Vector n (LLVM.IntN d)+unpackInts modu =+   fmap+      (\x ->+         LLVM.IntN $+         if Bits.shiftR modu 1 Bits..&. x /= 0+            then toInteger x - modu+            else toInteger x) .+   vectorise modu++unpackWords ::+   (TypeNum.Positive n, TypeNum.Positive d, Integral a) =>+   Integer -> a -> LLVM.Vector n (LLVM.WordN d)+unpackWords modu = fmap LLVM.WordN . vectorise modu++unpackInt2 :: Word8 -> V4 Int2+unpackInt2 = unpackInts 4++unpackWord2 :: Word8 -> V4 Word2+unpackWord2 = unpackWords 4++unpackInt3 :: Word16 -> V5 Int3+unpackInt3 = unpackInts 8++unpackWord3 :: Word16 -> V5 Word3+unpackWord3 = unpackWords 8++binopV4I2 ::+   (Eq a, LLVM.IsPrimitive a, LLVM.IsSized a, LLVM.SizeOf a ~ TypeNum.D2,+    LLVM.Value (V4 a) ~ v) =>+   (Word8 -> V4 a) ->+   (v -> v -> LLVM.CodeGenFunction () v) ->+   (a -> a -> a) ->+   IO QC.Property+binopV4I2 unpackBits codegen fun =+   run+      (\(x,y) -> do+         vx <- LLVM.bitcast x+         vy <- LLVM.bitcast y+         vz <- codegen vx vy+         LLVM.bitcast vz)+      (\(x,y) z ->+         liftA2 fun (unpackBits x) (unpackBits y)  ==  unpackBits z)++type Code15 r = LLVM.CodeGenFunction r (LLVM.Value (LLVM.WordN TypeNum.D15))++binopV5I3 ::+   (Eq a, LLVM.IsPrimitive a, LLVM.IsSized a, LLVM.SizeOf a ~ TypeNum.D3,+    LLVM.Value (V5 a) ~ v) =>+   (Word16 -> V5 a) ->+   (v -> v -> LLVM.CodeGenFunction () v) ->+   (a -> a -> a) ->+   IO QC.Property+binopV5I3 unpackBits codegen fun =+   run+      (\(x,y) -> do+         vx <- LLVM.bitcast =<< (LLVM.trunc x :: Code15 r)+         vy <- LLVM.bitcast =<< (LLVM.trunc y :: Code15 r)+         vz <- codegen vx vy+         LLVM.zext =<< (LLVM.bitcast vz :: Code15 r))+      (\(x,y) z ->+         liftA2 fun (unpackBits x) (unpackBits y)  ==  unpackBits z)++binopInt8 ::+   (LLVM.Value (V4 Int8) ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->+   (Int8 -> Int8 -> Int8) ->+   IO QC.Property+binopInt8 = binop++binopWord8 ::+   (LLVM.Value (V4 Word8) ~ v) =>+   (v -> v -> LLVM.CodeGenFunction () v) ->+   (Word8 -> Word8 -> Word8) ->+   IO QC.Property+binopWord8 = binop+++addSat, subSat :: (Bounded a, Integral a) => a -> a -> a+addSat = addSatMan (toInteger, fromInteger)+subSat = subSatMan (toInteger, fromInteger)++addSatMan, subSatMan ::+   (Bounded a) => (a -> Integer, Integer -> a) -> a -> a -> a+addSatMan = opSat (+)+subSatMan = opSat (-)++convertIntN :: Proxy d -> (LLVM.IntN d -> Integer, Integer -> LLVM.IntN d)+convertIntN Proxy = (\(LLVM.IntN n) -> n, LLVM.IntN)++convertWordN :: Proxy d -> (LLVM.WordN d -> Integer, Integer -> LLVM.WordN d)+convertWordN Proxy = (\(LLVM.WordN n) -> n, LLVM.WordN)++opSat ::+   (Bounded a) =>+   (Integer -> Integer -> Integer) ->+   (a -> Integer, Integer -> a) ->+   a -> a -> a+opSat op (toIntg, fromIntg) x y =+   fromIntg $+   P.max (toIntg $ minBound `asTypeOf` x) $+   P.min (toIntg $ maxBound `asTypeOf` x) $+   op (toIntg x) (toIntg y)+++fraction :: RealFrac a => a -> a+fraction x = x - fromInteger (floor x)+++split :: String -> (a -> b -> c) -> (a,a) -> b -> [(String, c)]+split name driver (intrinsic, fallback) f =+   (name ++ ".intrinsic", driver intrinsic f) :+   (name ++ ".fallback",  driver fallback  f) :+   []++tests :: [(String, IO QC.Property)]+tests =+   ("abs", unop Vector.abs P.abs) :+   ("signum", unop Vector.signum P.signum) :+   ("Alt.abs", unop VectorAlt.abs P.abs) :++   ("min", binopInt Vector.min P.min) :+   ("max", binopInt Vector.max P.max) :+   ("Alt.min", binopInt VectorAlt.min P.min) :+   ("Alt.max", binopInt VectorAlt.max P.max) :++   split "addSat.Word8" binopWord8 (SoV.addSat, SoVPriv.uaddSat) addSat +++   split "subSat.Word8" binopWord8 (SoV.subSat, SoVPriv.usubSat) subSat +++   split "addSat.Int8"  binopInt8  (SoV.addSat, SoVPriv.saddSat) addSat +++   split "subSat.Int8"  binopInt8  (SoV.subSat, SoVPriv.ssubSat) subSat ++++   split "addSat.Word3"+      (binopV5I3 unpackWord3) (SoV.addSat, SoVPriv.uaddSat)+      (addSatMan $ convertWordN TypeNum.d3) +++   split "subSat.Word3"+      (binopV5I3 unpackWord3) (SoV.subSat, SoVPriv.usubSat)+      (subSatMan $ convertWordN TypeNum.d3) +++   split "addSat.Int3"+      (binopV5I3 unpackInt3) (SoV.addSat, SoVPriv.saddSat)+      (addSatMan $ convertIntN TypeNum.d3) +++   split "subSat.Int3"+      (binopV5I3 unpackInt3) (SoV.subSat, SoVPriv.ssubSat)+      (subSatMan $ convertIntN TypeNum.d3) ++++   split "addSat.Word2"+      (binopV4I2 unpackWord2) (SoV.addSat, SoVPriv.uaddSat)+      (addSatMan $ convertWordN TypeNum.d2) +++   split "subSat.Word2"+      (binopV4I2 unpackWord2) (SoV.subSat, SoVPriv.usubSat)+      (subSatMan $ convertWordN TypeNum.d2) +++   split "addSat.Int2"+      (binopV4I2 unpackInt2) (SoV.addSat, SoVPriv.saddSat)+      (addSatMan $ convertIntN TypeNum.d2) +++   split "subSat.Int2"+      (binopV4I2 unpackInt2) (SoV.subSat, SoVPriv.ssubSat)+      (subSatMan $ convertIntN TypeNum.d2) ++++   ("sum",+      run Vector.sum (\x y -> Fold.sum (vec4 x) == (y::Int32))) :+   ("cumulate",+      run+         (uncurry Vector.cumulate)+         (\(x0,xv) (y0,yv) ->+            scanl (+) x0 (Fold.toList (vec4 xv))+            ==+            Fold.toList (vec4 yv) ++ [y0::Int32])) :+   ("dot",+      run+         (uncurry Vector.dotProduct)+         (\(x,y) z ->+            Fold.sum (liftA2 (*) (vec4 x) (vec4 y))  ==  (z::Int32))) :++   ("truncate", unopFloat Vector.truncate (fromInteger . P.truncate)) :+   ("floor", unopFloat Vector.floor (fromInteger . P.floor)) :+   ("fraction", unopFloat Vector.fraction fraction) :++   ("floorLogical", unopFloat VectorAlt.floor (fromInteger . P.floor)) :+   ("fractionLogical", unopFloat VectorAlt.fraction fraction) :+   ("floorSelect", unopFloat VectorAlt.floorSelect (fromInteger . P.floor)) :+   ("fractionSelect", unopFloat VectorAlt.fractionSelect fraction) :+   []