packages feed

llvm-extra (empty) → 0.1

raw patch · 18 files changed

+3815/−0 lines, 18 filesdep +basedep +containersdep +cpuidsetup-changed

Dependencies added: base, containers, cpuid, llvm-ht, transformers, type-level, utility-ht

Files

+ 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,33 @@+.PHONY:	sharedobj++ghci:+	ghci -Wall -i:src:x86/cpuid src/Array.hs++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 -f $<++# 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 < $< > $@
+ Problems.txt view
@@ -0,0 +1,66 @@+LLVM-2.5 running GHCi++First I can load, say, Array.hs in ghci.+When running 'main' I get the error that LLVMSystem.so cannot be found.+No LLVM*.so file on my machine, cannot be found in a Suse package.+Building .so file manually using gcc as in ./make-so.sh.++Then I get a problem with pthread.so not being a shared object file+but a script.+However, we do not need pthread anyway,+thus removing it from ~/.ghc/i386-linux-6.10.4/package.conf solves that problem.+This is a known issue:+   http://hackage.haskell.org/trac/ghc/ticket/2615#comment:16++Now when running 'main' I get the error,+that something about CurrentEngine cannot be found.+It means, we must also include /usr/lib/llvm/LLVM*.o files.+But in what order?+Seems there is no working order,+but the one given by+   llvm-config --libs+is close to what we need.+Problem: GHCi cannot cope with weak symbol _ZTIN4llvm12X86SubtargetE ("V" in nm)++This is a known issue due to+  http://hackage.haskell.org/trac/ghc/ticket/3333#comment:3++I have used gcc to build a monolithic libLLVM.so+containing all libLLVM*.a and libLLVM*.o files of /usr/lib/llvm/.+Then I reduced the occurrences of LLVM in package.conf+in the extraLibraries field to "LLVM"+and the ldOptions to -lLLVM.+++Now I can call LLVM in GHCi - but only until I do :reload.+After reload the next attempt to play something will let GHCi quit with:++ghci: JITEmitter.cpp:110: <unnamed>::JITResolver::JITResolver(llvm::JIT&): Assertion `TheJITResolver == 0 && "Multiple JIT resolvers?"' failed.++Maybe this can be handled in LLVM-2.6+where the JIT must be initialized explicitly.+++LLVM-2.6:++If I do as described above,+then when linking the Array example+I get errors for undefined symbols like+/usr/local/lib/libLLVM.so: undefined reference to `AutoGeneratedSwitch_emit_dash_llvm'+/usr/local/lib/libLLVM.so: undefined reference to `AutoGeneratedList_Wl_comma_'+...++These can be avoided by excluding libplugin_llvmc_Base.a+and libplugin_llvmc_Clang.a from the libLLVM.so conglomerate.+Then the example can be compiled but it aborts with PassRegistrar error as below.++I GHCi I get «unknown symbol `LLVMGetBitcodeModuleProviderInContext'»+when running 'main' in GHCi.+Additionally to -lLLVM for our custom libLLVM.so+I have to add -lLTO to ldOptions.+Then all symbols can be found.+However, when running LLVM.initializeNativeTarget+GHCi quits with+ghci: Pass.cpp:152: void<unnamed>::PassRegistrar::RegisterPass(const llvm::PassInfo&): Assertion `Inserted && "Pass registered multiple times!"' failed.+Also running LLVM.Target.X86.initializeTarget or Array.renderRamp+leads to this error.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ llvm-extra.cabal view
@@ -0,0 +1,107 @@+Name:           llvm-extra+Version:        0.1+License:        BSD3+License-File:   LICENSE+Author:         Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:     Henning Thielemann <haskell@henning-thielemann.de>+-- Homepage:       http://www.haskell.org/haskellwiki/LLVM+Homepage:       http://code.haskell.org/~thielema/llvm-extra/+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 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.Representation",+  .+  * support instance declarations of LLVM classes+    in "LLVM.Extra.Class",+  .+  * 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"+  .+  * automatic adaption to target specific extensions,+    currently used for access of vector operations+    that are specific to an SSE level on x86 processors+    in "LLVM.Extra.Extension"+    (On x86 architectures we depend on the cpuid package+     that is needed for automatic detection of available features.)+  .+  * 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"+  .+  * a Makefile and a description+    of how to run LLVM code from within GHCi.+Stability:      Experimental+Tested-With:    GHC==6.10.4+Cabal-Version:  >=1.2+Build-Type:     Simple+Extra-Source-Files:+  Makefile+  Problems.txt+  x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs+  x86/none/LLVM/Extra/ExtensionCheck/X86.hs++Flag buildExamples+  description: Build example executables+  default:     False++Library+  Build-Depends:+    -- llvm must be imported with restrictive version bounds,+    -- because we import implicitly and unqualified+    llvm-ht >=0.7.0 && <0.7.1,+    type-level >=0.2.3 && <0.3,+    containers >=0.1 && <0.4,+    transformers >=0.1.1 && <0.3,+    utility-ht >=0.0.1 && <0.1++  Build-Depends:+    base >= 3 && <5++  If arch(i386)+    Build-Depends: cpuid >=0.2 && <0.3+    Hs-Source-Dirs: x86/cpuid+  Else+    -- Instead of calling the cpuid instruction directly+    -- we may ask LLVM's Subtarget detection.+    -- This would also enable cross compilation.+    -- However in LLVM-2.6 this is only available in the C++ interface.+    Hs-Source-Dirs: x86/none++  GHC-Options:    -Wall+  Hs-source-dirs: src+  Exposed-Modules:+    LLVM.Extra.Arithmetic+    LLVM.Extra.Monad+    LLVM.Extra.Representation+    LLVM.Extra.MaybeContinuation+    LLVM.Extra.Class+    LLVM.Extra.Control+    LLVM.Extra.Extension+    LLVM.Extra.Extension.X86+    LLVM.Extra.ExtensionCheck.X86+    LLVM.Extra.Vector+    LLVM.Extra.ScalarOrVector++Executable tone-llvm+  If !flag(buildExamples)+    Buildable: False+  GHC-Options:    -Wall+  Hs-Source-Dirs: src, x86/none+  Main-Is: Array.hs
+ src/Array.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE FlexibleContexts #-}+module Main where++import LLVM.Extra.Control (arrayLoop, )+import qualified LLVM.Extra.ScalarOrVector as SV+import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Control as U++import qualified LLVM.Extra.Extension.X86 as X86+import qualified LLVM.Extra.Extension as Ext++import qualified LLVM.Extra.Arithmetic as A++import LLVM.Core+import LLVM.ExecutionEngine (simpleFunction, )+import qualified System.IO as IO++import Data.TypeLevel.Num(D4, )+import Data.Word (Word32, )+import Data.Int (Int32, )+import Foreign.Storable (Storable, sizeOf, )+import Foreign.Marshal.Array (allocaArray, )++import Control.Monad.Trans.State (StateT(StateT), runStateT, )+import Control.Monad (liftM2, )++++type Vec = ConstValue (Vector D4 Float)++constVec ::+   Float -> CodeGenFunction r (Value (Vector D4 Float))+constVec x =+   return $ valueOf $ toVector (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 ::+   (IsFloating c, ABinOp a (Value (Vector D4 Float)) (v c)) =>+   a -> CodeGenFunction r (v c)+fractionVector0 x =+   frem x =<< constVec 1++{-+Works only when Floating point number is in the range+that is representable by Int32.+-}+fraction :: Value Float -> CodeGenFunction r (Value Float)+fraction x =+   A.sub x =<<+   sitofp . flip asTypeOf (undefined :: Value Int32) =<<+   fptosi x++fractionVector ::+   Value (Vector D4 Float) ->+   CodeGenFunction r (Value (Vector D4 Float))+fractionVector x =+   A.sub x =<<+   sitofp . flip asTypeOf (undefined :: Value (Vector D4 Int32)) =<<+   fptosi x+++{-+This call++    fill (fromIntegral len) ptr+       (toVector (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 =<< mul (valueOf 0.25 :: Value Float) s0123+      fractionVector =<< 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) (constVector [constOf 0, constOf 1])+    y23 <- shufflevector y (value undef) (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)+    mul (0.25 :: Float) =<< 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) (constVector [constOf 2, constOf 3, undef, undef])+    z <- add y (y23 :: Value (Vector D4 Float))+    s0 <- extractelement z (valueOf 0)+    s1 <- extractelement z (valueOf 1)+    mul (0.25 :: Float) =<< add s0 s1+++{-+Needs the horizontal add instruction from the SSSE3 extension in ix86 CPUs.+-}+mixHorizontal :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float)+mixHorizontal y = do+    z <- Ext.runUnsafe X86.haddps (value undef) y+    s <- Ext.runUnsafe X86.haddps (value undef) z+    mul (0.25 :: Float) =<< extractelement s (valueOf 0)++{-+Needs the dot product instruction from the SSE4 extension in ix86 CPUs.+-}+mixDotProduct :: Value (Vector D4 Float) -> CodeGenFunction r (Value Float)+mixDotProduct y = do+    x <- SV.replicate (valueOf 0.25)+    z <- Ext.runUnsafe X86.dpps x y (valueOf 0xF1)+    extractelement z (valueOf 0)++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 =<< mixHorizontal =<< add const1 =<< mul const2 phase+      fractionVector =<< add phase (freq :: Value (Vector D4 Float))+    ss <- extractelement s (valueOf 0)+    ret (ss :: Value Float)++waveSaw :: Value Float -> CodeGenFunction r (Value Float)+waveSaw t =+  sub (valueOf 1 :: Value Float) =<<+  mul (valueOf 2 :: Value Float) t++incPhase :: Value Float -> Value Float -> CodeGenFunction r (Value Float)+incPhase d p =+  fraction =<< add d p++osciSaw :: Value Float -> Value Float -> CodeGenFunction r (Value Float, Value Float)+osciSaw freq phase =+  liftM2 (,) (waveSaw phase) (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+            ((valueOf 0 :: Value Float, valueOf 0 :: Value Float),+             (valueOf 0 :: Value Float, valueOf 0 :: Value Float)) $+         \ 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 <- add y0 y1+      y23 <- add y2 y3+      y0123 <- add y01 y23+      flip store ptri =<< mul (valueOf 0.25 :: Value Float) 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+            ((valueOf 0 :: Value Float, valueOf 0 :: Value Float),+             (valueOf 0 :: Value Float, valueOf 0 :: Value Float)) $+         \ ptri phases -> do+      (y, phases') <-+         flip runStateT phases $+            (sawOsciAction f0 =+= sawOsciAction f1) =+=+            (sawOsciAction f2 =+= sawOsciAction f3)+      flip store ptri =<< mul (valueOf 0.25 :: Value Float) y+      return phases'+    ret (fst (fst s) :: Value Float)++renderChorus :: IO ()+renderChorus = do+  m <- newModule+  _f <- defineModule m mChorusVector+  writeBitcodeToFile "array.bc" m++  fill <- simpleFunction mChorusVector+  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*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)++renderSaw :: IO ()+renderSaw = do+  fill <- simpleFunction 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*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*sizeOf(undefined::Float))++main :: IO ()+main = do+   initializeNativeTarget+   renderChorus
+ src/LLVM/Extra/Arithmetic.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Arithmetic (+   add, sub, inc, dec,+   mul, square, fdiv,+   udiv, urem,+   fcmp, icmp,+   and, or,+   umin, umax,+   smin, smax, sabs,+   fmin, fmax, fabs,+   advanceArrayElementPtr,+   sqrt, sin, cos, exp, log, pow,+   ) where++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Ptr, getElementPtr, value, valueOf, Value,+    IntPredicate(IntULE, IntSLE, IntUGE, IntSGE),+    FPPredicate(FPOLE, FPOGE),+    IsIntegerOrPointer,+    IsType, IsConst, IsInteger, IsFloating, IsArithmetic, IsFirstClass,+    CmpRet,+    CodeGenFunction, )++import Data.Word (Word32, )+++import Prelude hiding (and, or, sqrt, sin, cos, exp, log, )++++-- * arithmetic with better type inference++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)+++mul ::+   (IsArithmetic a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+mul = LLVM.mul++square ::+   (IsArithmetic a) =>+   Value a -> CodeGenFunction r (Value a)+square x = mul x x+++fdiv ::+   (IsFloating a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+fdiv = LLVM.fdiv++fcmp ::+  (IsFloating a, CmpRet a b) =>+  FPPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+fcmp = LLVM.fcmp+++icmp ::+  (IsIntegerOrPointer a, CmpRet a b) =>+  IntPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+icmp = LLVM.icmp++udiv ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+udiv = LLVM.udiv++urem ::+   (IsInteger a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+urem = LLVM.urem+++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++++{- |+This would also work for vectors,+if LLVM would support 'select' with bool vectors as condition.+-}+umin :: (IsInteger a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+umin = cmpSelect (icmp IntULE)++umax :: (IsInteger a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+umax = cmpSelect (icmp IntUGE)+++smin :: (IsInteger a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+smin = cmpSelect (icmp IntSLE)++smax :: (IsInteger a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+smax = cmpSelect (icmp IntSGE)++sabs :: (IsInteger a, CmpRet a Bool) =>+   Value a -> CodeGenFunction r (Value a)+sabs x = do+   b <- icmp IntSGE x (value LLVM.zero)+   LLVM.select b x =<< LLVM.neg x+++fmin :: (IsFloating a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+fmin = cmpSelect (fcmp FPOLE)++fmax :: (IsFloating a, CmpRet a Bool) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+fmax = cmpSelect (fcmp FPOGE)++fabs :: (IsFloating a, CmpRet a Bool) =>+   Value a -> CodeGenFunction r (Value a)+fabs x = do+   b <- fcmp FPOGE x (value LLVM.zero)+   LLVM.select b x =<< LLVM.neg x+++cmpSelect ::+   (IsFirstClass a, CmpRet a Bool) =>+   (Value a -> Value a -> CodeGenFunction r (Value Bool)) ->+   (Value a -> Value a -> CodeGenFunction r (Value a))+cmpSelect f x y =+   f x y >>= \b -> LLVM.select b x y++++-- * pointers++advanceArrayElementPtr ::+   Value (Ptr o) ->+   CodeGenFunction r (Value (Ptr o))+advanceArrayElementPtr p =+   getElementPtr p (valueOf 1 :: Value Word32, ())++++-- * transcendental functions+++valueTypeName ::+   (IsType a) =>+   Value a -> String+valueTypeName =+   LLVM.typeName . (undefined :: Value a -> a)+++callIntrinsic1 ::+   (IsFirstClass a) =>+   String -> Value a -> CodeGenFunction r (Value a)+callIntrinsic1 fn x = do+   op <- LLVM.externFunction ("llvm." ++ fn ++ "." ++ valueTypeName x)+   r <- LLVM.call op x+   LLVM.addAttributes r 0 [LLVM.ReadNoneAttribute]+   return r++callIntrinsic2 ::+   (IsFirstClass a) =>+   String -> Value a -> Value a -> CodeGenFunction r (Value a)+callIntrinsic2 fn x y = do+   op <- LLVM.externFunction ("llvm." ++ fn ++ "." ++ valueTypeName x)+   r <- LLVM.call op x y+   LLVM.addAttributes r 0 [LLVM.ReadNoneAttribute]+   return r+++sqrt, sin, cos, exp, log ::+   (IsFloating a) =>+   Value a -> CodeGenFunction r (Value a)+sqrt = callIntrinsic1 "sqrt"+sin = callIntrinsic1 "sin"+cos = callIntrinsic1 "cos"+exp = callIntrinsic1 "exp"+log = callIntrinsic1 "log"++pow ::+   (IsFloating a) =>+   Value a -> Value a -> CodeGenFunction r (Value a)+pow = callIntrinsic2 "pow"
+ src/LLVM/Extra/Class.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Class where++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Undefined, undefTuple,+    IsTuple, tupleDesc, TypeDesc,+    MakeValueTuple, valueTupleOf,+    Value,+    CodeGenFunction, BasicBlock, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++import Control.Applicative (pure, liftA2, )+import qualified Control.Applicative as App+import qualified Data.Foldable as Fold+import qualified Data.Traversable as Trav++import Prelude hiding (and, iterate, map, zipWith, writeFile, )+++-- * class for tuples of zero values++class Zero a where+   zeroTuple :: a++instance Zero () where+   zeroTuple = ()++instance (LLVM.IsFirstClass a) => Zero (Value a) where+   zeroTuple = LLVM.value LLVM.zero++instance (Zero a, Zero b) => Zero (a, b) where+   zeroTuple = (zeroTuple, zeroTuple)++instance (Zero a, Zero b, Zero c) => Zero (a, b, c) where+   zeroTuple = (zeroTuple, zeroTuple, zeroTuple)++zeroTuplePointed ::+   (Zero a, App.Applicative f) =>+   f a+zeroTuplePointed =+   pure zeroTuple+++-- * default methods for LLVM classes++{-+buildTupleTraversable ::+   (Undefined a, Trav.Traversable f, App.Applicative f) =>+   FunctionRef -> State Int (f a)+buildTupleTraversable f =+   Trav.sequence (pure (buildTuple f))+-}+{-+buildTupleTraversable ::+   (Trav.Traversable f, App.Applicative f) =>+   State Int a ->+   State Int (f a)+buildTupleTraversable build =+   Trav.sequence (pure build)+-}+buildTupleTraversable ::+   (Monad m, Trav.Traversable f, App.Applicative f) =>+   m a ->+   m (f a)+buildTupleTraversable build =+   Trav.sequence (pure build)++undefTuplePointed ::+   (Undefined a, App.Applicative f) =>+   f a+undefTuplePointed =+   pure undefTuple++valueTupleOfFunctor ::+   (MakeValueTuple h l, Functor f) =>+   f h -> f l+valueTupleOfFunctor =+   fmap valueTupleOf++tupleDescFoldable ::+   (IsTuple a, Fold.Foldable f) =>+   f a -> [TypeDesc]+tupleDescFoldable =+   Fold.foldMap tupleDesc++phisTraversable ::+   (Phi a, Trav.Traversable f) =>+   BasicBlock -> f a -> CodeGenFunction r (f a)+phisTraversable bb x =+   Trav.mapM (phis bb) x++addPhisFoldable ::+   (Phi a, Fold.Foldable f, App.Applicative f) =>+   BasicBlock -> f a -> f a -> CodeGenFunction r ()+addPhisFoldable bb x y =+   Fold.sequence_ (liftA2 (addPhis bb) x y)++
+ src/LLVM/Extra/Control.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Useful control structures additionally to those in "LLVM.Util.Loop".+-}+module LLVM.Extra.Control (+   arrayLoop,+   arrayLoopWithExit,+   arrayLoop2WithExit,+   whileLoop,+   ifThenElse,+   ifThen,+   Select(select),+   selectTraversable,+   ifThenSelect,+   ) where++import LLVM.Extra.Arithmetic+   (icmp, sub, dec, advanceArrayElementPtr, )+import qualified LLVM.Core as LLVM+import LLVM.Core+   (getCurrentBasicBlock, newBasicBlock, defineBasicBlock,+    br, condBr,+    Ptr, Value, value,+    phi, addPhiInputs,+    IntPredicate(IntNE), CmpRet,+    IsInteger, IsType, IsConst, IsFirstClass,+    CodeGenFunction,+    CodeGenModule, newModule, defineModule, writeBitcodeToFile, )+import LLVM.Util.Loop (Phi, phis, addPhis, )++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 Phi's methods in llvm-0.6.8+in order to be able to implement this function.+-}+arrayLoop ::+   (Phi a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i -> Value (Ptr b) -> a ->+   (Value (Ptr b) -> a -> CodeGenFunction r a) ->+   CodeGenFunction r a+arrayLoop len ptr start loopBody = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   body <- newBasicBlock+   exit <- newBasicBlock++   br loop++   defineBasicBlock loop+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- phis top start+   t <- icmp IntNE i (value LLVM.zero)+   condBr t body exit++   defineBasicBlock body++   vars' <- loopBody p vars+   i' <- dec i+   p' <- advanceArrayElementPtr p++   body' <- getCurrentBasicBlock+   addPhis body' vars vars'+   addPhiInputs i [(i', body')]+   addPhiInputs p [(p', body')]+   br loop++   defineBasicBlock exit+   return vars+++arrayLoopWithExit ::+   (Phi s, IsType a,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i -> Value (Ptr a) -> s ->+   (Value (Ptr a) -> s -> CodeGenFunction r (Value Bool, s)) ->+   CodeGenFunction r (Value i, s)+arrayLoopWithExit len ptr start loopBody = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   body <- newBasicBlock+   next <- newBasicBlock+   exit <- newBasicBlock++   br loop++   defineBasicBlock loop+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- phis top start+   t <- icmp IntNE i (value LLVM.zero)+   condBr t body exit++   defineBasicBlock body+   (cont, vars') <- loopBody p vars+   addPhis next vars vars'+   condBr cont next exit++   defineBasicBlock next+   i' <- dec i+   p' <- advanceArrayElementPtr p++   addPhiInputs i [(i', next)]+   addPhiInputs p [(p', next)]+   br loop++   defineBasicBlock exit+   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 ::+   (Phi a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i -> Value (Ptr b) -> a ->+   (Value (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 <- icmp IntNE len (value LLVM.zero)+   br checkEnd++   defineBasicBlock checkEnd+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- phis top start+   t <- phi [(t0, top)]+   condBr t loop exit++   defineBasicBlock loop++   (cont, vars') <- loopBody p vars+   addPhis next vars vars'+   condBr cont next exit++   defineBasicBlock next+   p' <- advanceArrayElementPtr p+   i' <- dec i+   t' <- icmp IntNE 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 ::+   (Phi s, IsType a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i -> Value (Ptr a) -> Value (Ptr b) -> s ->+   (Value (Ptr a) -> Value (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 (ptrBi,s0) -> do+         (cont, s1) <- loopBody ptrAi ptrBi s0+         ptrBi' <- advanceArrayElementPtr ptrBi+         return (cont, (ptrBi',s1)))+++whileLoop ::+   Phi a =>+   a ->+   (a -> CodeGenFunction r (Value Bool)) ->+   (a -> CodeGenFunction r a) ->+   CodeGenFunction r a+whileLoop start check body = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   cont <- newBasicBlock+   exit <- newBasicBlock+   br loop++   defineBasicBlock loop+   state <- phis top start+   b <- check state+   condBr b cont exit+   defineBasicBlock cont+   res <- body state+   cont' <- getCurrentBasicBlock+   addPhis cont' state res+   br loop++   defineBasicBlock exit+   return state+++{- |+This construct starts new blocks,+so be prepared when continueing after an 'ifThenElse'.+-}+ifThenElse ::+   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 <- phis thenBlock' a0+   addPhis elseBlock' a2 a1+   return a2+++ifThen ::+   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 <- phis defltBlock deflt+   addPhis thenBlock' a1 a0+   return a1+++class Phi a => Select a where+   select :: Value Bool -> a -> a -> CodeGenFunction r a++instance (IsFirstClass a, CmpRet a Bool) => 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+++-- * debugging++_emitCode :: FilePath -> CodeGenModule a -> IO ()+_emitCode fileName cgm = do+   m <- newModule+   _ <- defineModule m cgm+   writeBitcodeToFile fileName m
+ src/LLVM/Extra/Extension.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+module LLVM.Extra.Extension (+   T, CallArgs,+   Subtarget(Subtarget), wrap,+   intrinsic, intrinsicAttr,+   run, runWhen, runUnsafe,+   with, with2, with3,+   ) where++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, CodeGenFunction, externFunction, call,+    addAttributes, Attribute(ReadNoneAttribute), )++import Data.Map (Map, )+import qualified Data.Map as Map++import Control.Monad.Trans.Writer (Writer, writer, runWriter, )+import qualified Control.Monad.Trans.Writer as Writer+import Control.Monad (join, )+import Control.Applicative (Applicative, pure, (<*>), )++import Prelude hiding (replicate, sum, map, zipWith, )+++data Subtarget =+   Subtarget {+      targetName, name :: String,+      check :: forall r. CodeGenFunction r Bool+   }+++{- |+This is an Applicative functor that registers,+what extensions are needed in order to run the contained instructions.+You can escape from the functor by calling 'run'+and providing a generic implementation.++We use an applicative functor+since with a monadic interface+we had to create the specialised code in every case,+in order to see which extensions where used+in the course of creating the instructions.++We use only one (unparameterized) type for all extensions,+since this is the most simple solution.+Alternatively we could use a type parameter+where class constraints show what extensions are needed.+This would be just like exceptions that are explicit in the type signature+as in the control-monad-exception package.+However we would still need to lift all basic LLVM instructions to the new monad.+-}+newtype T a =+   Cons (Writer (Map String Subtarget) a)+   deriving (Functor, Applicative)++{- |+Declare that a certain plain LLVM instruction+depends on a particular extension.+This can be useful if you rely on the data layout+of a certain architecture when doing a bitcast,+or if you know that LLVM translates a certain generic operation+to something especially optimal for the declared extension.+-}+wrap :: Subtarget -> a -> T a+wrap tar cgf =+   Cons $+   writer (cgf, Map.singleton (name tar) tar)+++{- | Analogous to 'LLVM.FunctionArgs'++The type parameter @r@ and its functional dependency are necessary+since @g@ must be a function of the form @a -> ... -> c -> CodeGenFunction r d@+and we must ensure that the explicit @r@ and the implicit @r@ in the @g@ do match.+-}+class CallArgs g r | g -> r where+   buildIntrinsic :: [Attribute] -> CodeGenFunction r g -> g++instance (CallArgs g r) =>+      CallArgs (Value a -> g) r where+   buildIntrinsic attrs g x =+      buildIntrinsic attrs (fmap ($x) g)++instance CallArgs (CodeGenFunction r (Value a)) r where+   buildIntrinsic attrs g = do+      z <- join g+      addAttributes z 0 attrs+      return z++{- |+Create an intrinsic and register the needed extension.+We cannot immediately check whether the signature matches+or whether the right extension is given.+However, when resolving intrinsics+LLVM will not find the intrinsic if the extension is wrong,+and it also checks the signature.+-}+intrinsic ::+   (LLVM.IsFunction f, LLVM.CallArgs f g, CallArgs g r) =>+   Subtarget -> String -> T g+intrinsic =+   intrinsicAttr [ReadNoneAttribute]++intrinsicAttr ::+   (LLVM.IsFunction f, LLVM.CallArgs f g, CallArgs g r) =>+   [Attribute] -> Subtarget -> String -> T g+intrinsicAttr attrs tar intr =+   wrap tar $+   buildIntrinsic attrs $+   fmap call $+   externFunction $+      "llvm." ++ targetName tar ++ "." ++ name tar ++ "." ++ intr+++infixl 1 `run`++{- |+@run generic specific@ generates the @specific@ code+if the required extensions are available on the host processor+and @generic@ otherwise.+-}+run ::+   CodeGenFunction r a ->+   T (CodeGenFunction r a) ->+   CodeGenFunction r a+run alt (Cons m) = do+   let (a,s) = runWriter m+   b <- mapM check (Map.elems s)+   if and b+     then a+     else alt++{- |+Convenient variant of 'run':+Only run the code with extended instructions+if an additional condition is given.+-}+runWhen ::+   Bool ->+   CodeGenFunction r a ->+   T (CodeGenFunction r a) ->+   CodeGenFunction r a+runWhen c alt (Cons m) = do+   let (a,s) = runWriter m+   b <- mapM check (Map.elems s)+   if c && and b+     then a+     else alt++{- |+Only for debugging purposes.+-}+runUnsafe ::+   T a -> a+runUnsafe (Cons m) =+   fst $ runWriter m+++with :: (Functor f) => f a -> (a -> b) -> f b+with = flip fmap++with2 :: (Applicative f) => f a -> f b -> (a -> b -> c) -> f c+with2 a b f =+   pure f <*> a <*> b++with3 :: (Applicative f) => f a -> f b -> f c -> (a -> b -> c -> d) -> f d+with3 a b c f =+   pure f <*> a <*> b <*> c
+ src/LLVM/Extra/Extension/X86.hs view
@@ -0,0 +1,362 @@+{-# LANGUAGE FlexibleContexts #-}+{- |+Some special operations on X86 processors.+If you want to use them in algorithm+you will always have to prepare an alternative implementation+in terms of plain LLVM instructions.+You will then run them with 'Ext.run'+and this driver function then selects the most advanced of both implementations.+Functions that are written this way can be found in "LLVM.Extra.Vector".+Availability of extensions is checked with the @CPUID@ instruction.+However this does only work if you compile code for the host machine,+that is cross compilation will fail!+For cross compilation we would need access to the SubTarget detection of LLVM+that is only available in the C++ interface in version 2.6.+-}+module LLVM.Extra.Extension.X86 (+   maxss, minss, maxps, minps,+   maxsd, minsd, maxpd, minpd,+   cmpss, cmpps, cmpsd, cmppd,+   pcmpgtb,  pcmpgtw,  pcmpgtd,  pcmpgtq,+   pcmpugtb, pcmpugtw, pcmpugtd, pcmpugtq,+   pminsb, pminsw, pminsd,+   pmaxsb, pmaxsw, pmaxsd,+   pminub, pminuw, pminud,+   pmaxub, pmaxuw, pmaxud,+   pabsb, pabsw, pabsd,+   pmuludq, pmulld,+   cvtps2dq, cvtpd2dq,+   ldmxcsr, stmxcsr, withMXCSR,+   haddps, haddpd, dpps, dppd,+   roundss, roundps, roundsd, roundpd,+   absss, abssd, absps, abspd,+   ) where++import qualified LLVM.Extra.Extension as Ext+import LLVM.Extra.ExtensionCheck.X86+          (sse1, sse2, sse3, ssse3, sse41, sse42, )++import qualified LLVM.Extra.Monad as M+import qualified LLVM.Extra.Arithmetic as A+import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, Vector, value, valueOf, constOf, constVector,+    CodeGenFunction, FPPredicate, )++import qualified Data.TypeLevel.Num as TypeNum+import Data.TypeLevel.Num (D2, D4, D8, D16, )++import Data.Bits (clearBit, complement, )+import Data.Int  (Int8, Int16, Int32, Int64, )+import Data.Word (Word8, Word16, Word32, Word64, )++import Control.Monad.HT ((<=<), )++import Foreign.Ptr (Ptr, )+++-- * target dependent functions++type VFloat  = Value (Vector D4 Float)+type VDouble = Value (Vector D2 Double)+++maxss, minss, maxps, minps ::+   Ext.T (VFloat -> VFloat -> CodeGenFunction r VFloat)+maxss = Ext.intrinsic sse1 "max.ss"+minss = Ext.intrinsic sse1 "min.ss"+maxps = Ext.intrinsic sse1 "max.ps"+minps = Ext.intrinsic sse1 "min.ps"++{- here r would be unified+[maxss, minss, maxps, minps] =+   map (Ext.intrinsic sse1)+     ["max.ss", "min.ss", "max.ps", "min.ps"]+-}++maxsd, minsd, maxpd, minpd ::+   Ext.T (VDouble -> VDouble -> CodeGenFunction r VDouble)+maxsd = Ext.intrinsic sse1 "max.sd"+minsd = Ext.intrinsic sse1 "min.sd"+maxpd = Ext.intrinsic sse1 "max.pd"+minpd = Ext.intrinsic sse1 "min.pd"++switchFPPred ::+   (Num i, LLVM.IsConst i, LLVM.IsInteger i, LLVM.IsPrimitive i,+    LLVM.IsFirstClass v,+    LLVM.IsPowerOf2 n,+    LLVM.IsSized v s, LLVM.IsSized (Vector n i) s) =>+   (Value v -> Value v -> Value Word8 -> CodeGenFunction r (Value v)) ->+   FPPredicate -> Value v -> Value v -> CodeGenFunction r (Value (Vector n i))+switchFPPred g p x y =+   let f i x0 y0 = LLVM.bitcastUnify =<< g x0 y0 (valueOf i)+   in  case p of+          LLVM.FPFalse -> return (LLVM.value LLVM.zero)+          LLVM.FPOEQ   -> f 0 x y+          LLVM.FPOGT   -> f 1 y x+          LLVM.FPOGE   -> f 2 y x+          LLVM.FPOLT   -> f 1 x y+          LLVM.FPOLE   -> f 2 x y+          LLVM.FPONE   -> M.liftR2 A.and (f 7 x y) (f 4 x y)+          LLVM.FPORD   -> f 7 x y+          LLVM.FPUNO   -> f 3 x y+          LLVM.FPUEQ   -> M.liftR2 A.or (f 3 x y) (f 0 x y)+          LLVM.FPUGT   -> f 6 x y+          LLVM.FPUGE   -> f 5 x y+          LLVM.FPULT   -> f 6 y x+          LLVM.FPULE   -> f 5 y x+          LLVM.FPUNE   -> f 4 x y+          LLVM.FPT     -> return (LLVM.value (LLVM.constVector [LLVM.constOf (-1)]))++cmpss :: Ext.T (FPPredicate -> VFloat -> VFloat -> CodeGenFunction r (Value (Vector D4 Int32)))+cmpss = fmap switchFPPred (Ext.intrinsic sse1 "cmp.ss")++cmpps :: Ext.T (FPPredicate -> VFloat -> VFloat -> CodeGenFunction r (Value (Vector D4 Int32)))+cmpps = fmap switchFPPred (Ext.intrinsic sse1 "cmp.ps")++cmpsd :: Ext.T (FPPredicate -> VDouble -> VDouble -> CodeGenFunction r (Value (Vector D2 Int64)))+cmpsd = fmap switchFPPred (Ext.intrinsic sse2 "cmp.sd")++cmppd :: Ext.T (FPPredicate -> VDouble -> VDouble -> CodeGenFunction r (Value (Vector D2 Int64)))+cmppd = fmap switchFPPred (Ext.intrinsic sse2 "cmp.pd")+++pcmpgtb :: Ext.T (Value (Vector D16 Int8) -> Value (Vector D16 Int8) -> CodeGenFunction r (Value (Vector D16 Int8)))+pcmpgtb = Ext.intrinsic sse2 "pcmpgt.b"++pcmpgtw :: Ext.T (Value (Vector D8 Int16) -> Value (Vector D8 Int16) -> CodeGenFunction r (Value (Vector D8 Int16)))+pcmpgtw = Ext.intrinsic sse2 "pcmpgt.w"++pcmpgtd :: Ext.T (Value (Vector D4 Int32) -> Value (Vector D4 Int32) -> CodeGenFunction r (Value (Vector D4 Int32)))+pcmpgtd = Ext.intrinsic sse2 "pcmpgt.d"++pcmpgtq :: Ext.T (Value (Vector D2 Int64) -> Value (Vector D2 Int64) -> CodeGenFunction r (Value (Vector D2 Int64)))+pcmpgtq = Ext.intrinsic sse42 "pcmpgtq"+++pcmpuFromPcmp ::+   (LLVM.IsPowerOf2 n,+    LLVM.IsPrimitive s,+    LLVM.IsPrimitive u, LLVM.IsArithmetic u, LLVM.IsConst u,+    Bounded u, Integral u,+    LLVM.IsSized (Vector n s) size,+    LLVM.IsSized (Vector n u) size) =>+   Ext.T (Value (Vector n s) -> Value (Vector n s) -> CodeGenFunction r (Value (Vector n s))) ->+   Ext.T (Value (Vector n u) -> Value (Vector n u) -> CodeGenFunction r (Value (Vector n u)))+pcmpuFromPcmp pcmp =+   Ext.with pcmp $ \cmp x y -> do+      let offset = value (constVector [constOf (1 + div maxBound 2)])+      xa <- LLVM.bitcastUnify =<< A.sub x offset+      ya <- LLVM.bitcastUnify =<< A.sub y offset+      LLVM.bitcastUnify =<< cmp xa ya++pcmpugtb :: Ext.T (Value (Vector D16 Word8) -> Value (Vector D16 Word8) -> CodeGenFunction r (Value (Vector D16 Word8)))+pcmpugtb = pcmpuFromPcmp pcmpgtb++pcmpugtw :: Ext.T (Value (Vector D8 Word16) -> Value (Vector D8 Word16) -> CodeGenFunction r (Value (Vector D8 Word16)))+pcmpugtw = pcmpuFromPcmp pcmpgtw++pcmpugtd :: Ext.T (Value (Vector D4 Word32) -> Value (Vector D4 Word32) -> CodeGenFunction r (Value (Vector D4 Word32)))+pcmpugtd = pcmpuFromPcmp pcmpgtd++pcmpugtq :: Ext.T (Value (Vector D2 Word64) -> Value (Vector D2 Word64) -> CodeGenFunction r (Value (Vector D2 Word64)))+pcmpugtq = pcmpuFromPcmp pcmpgtq+++pminsb :: Ext.T (Value (Vector D16 Int8) -> Value (Vector D16 Int8) -> CodeGenFunction r (Value (Vector D16 Int8)))+pminsb = Ext.intrinsic sse41 "pminsb"++pminsw :: Ext.T (Value (Vector D8 Int16) -> Value (Vector D8 Int16) -> CodeGenFunction r (Value (Vector D8 Int16)))+pminsw = Ext.intrinsic sse2 "pmins.w"++pminsd :: Ext.T (Value (Vector D4 Int32) -> Value (Vector D4 Int32) -> CodeGenFunction r (Value (Vector D4 Int32)))+pminsd = Ext.intrinsic sse41 "pminsd"+++pmaxsb :: Ext.T (Value (Vector D16 Int8) -> Value (Vector D16 Int8) -> CodeGenFunction r (Value (Vector D16 Int8)))+pmaxsb = Ext.intrinsic sse41 "pmaxsb"++pmaxsw :: Ext.T (Value (Vector D8 Int16) -> Value (Vector D8 Int16) -> CodeGenFunction r (Value (Vector D8 Int16)))+pmaxsw = Ext.intrinsic sse2 "pmaxs.w"++pmaxsd :: Ext.T (Value (Vector D4 Int32) -> Value (Vector D4 Int32) -> CodeGenFunction r (Value (Vector D4 Int32)))+pmaxsd = Ext.intrinsic sse41 "pmaxsd"+++pminub :: Ext.T (Value (Vector D16 Word8) -> Value (Vector D16 Word8) -> CodeGenFunction r (Value (Vector D16 Word8)))+pminub = Ext.intrinsic sse2 "pminu.b"++pminuw :: Ext.T (Value (Vector D8 Word16) -> Value (Vector D8 Word16) -> CodeGenFunction r (Value (Vector D8 Word16)))+pminuw = Ext.intrinsic sse41 "pminuw"++pminud :: Ext.T (Value (Vector D4 Word32) -> Value (Vector D4 Word32) -> CodeGenFunction r (Value (Vector D4 Word32)))+pminud = Ext.intrinsic sse41 "pminud"+++pmaxub :: Ext.T (Value (Vector D16 Word8) -> Value (Vector D16 Word8) -> CodeGenFunction r (Value (Vector D16 Word8)))+pmaxub = Ext.intrinsic sse2 "pmaxu.b"++pmaxuw :: Ext.T (Value (Vector D8 Word16) -> Value (Vector D8 Word16) -> CodeGenFunction r (Value (Vector D8 Word16)))+pmaxuw = Ext.intrinsic sse41 "pmaxuw"++pmaxud :: Ext.T (Value (Vector D4 Word32) -> Value (Vector D4 Word32) -> CodeGenFunction r (Value (Vector D4 Word32)))+pmaxud = Ext.intrinsic sse41 "pmaxud"+++pabsb :: Ext.T (Value (Vector D16 Int8) -> CodeGenFunction r (Value (Vector D16 Int8)))+pabsb = Ext.intrinsic ssse3 "pabs.b"++pabsw :: Ext.T (Value (Vector D8 Int16) -> CodeGenFunction r (Value (Vector D8 Int16)))+pabsw = Ext.intrinsic ssse3 "pabs.w"++pabsd :: Ext.T (Value (Vector D4 Int32) -> CodeGenFunction r (Value (Vector D4 Int32)))+pabsd = Ext.intrinsic ssse3 "pabs.d"+++pmuludq :: Ext.T (Value (Vector D4 Word32) -> Value (Vector D4 Word32) -> CodeGenFunction r (Value (Vector D2 Word64)))+pmuludq = Ext.intrinsic sse2 "pmulu.dq"++pmulld :: Ext.T (Value (Vector D4 Word32) -> Value (Vector D4 Word32) -> CodeGenFunction r (Value (Vector D4 Word32)))+pmulld = Ext.intrinsic sse41 "pmulld"+++cvtps2dq :: Ext.T (VFloat -> CodeGenFunction r (Value (Vector D4 Int32)))+cvtps2dq = Ext.intrinsic sse2 "cvtps2dq"++-- | the upper two integers are set to zero, there is no instruction that converts to Int64+cvtpd2dq :: Ext.T (VDouble -> CodeGenFunction r (Value (Vector D4 Int32)))+cvtpd2dq = Ext.intrinsic sse2 "cvtpd2dq"++{- |+MXCSR is not really supported by LLVM-2.6.+LLVM does not know about the dependency of all floating point operations+on this status register.+-}+ldmxcsr :: Ext.T (Value (Ptr Word32) -> CodeGenFunction r (Value ()))+ldmxcsr = Ext.intrinsicAttr [] sse1 "ldmxcsr"++stmxcsr :: Ext.T (Value (Ptr Word32) -> CodeGenFunction r (Value ()))+stmxcsr = Ext.intrinsicAttr [] sse1 "stmxcsr"++withMXCSR :: Word32 -> Ext.T (CodeGenFunction r a -> CodeGenFunction r a)+withMXCSR mxcsr =+   Ext.with2 ldmxcsr stmxcsr $ \ ld st f -> do+      mxcsrOld <- LLVM.alloca+      st mxcsrOld+      mxcsrFloor <- LLVM.alloca+      LLVM.store (valueOf $ mxcsr) mxcsrFloor+{- unfortunately, createGlobal is a function CodeGenModule monad+      mxcsrFloor <-+         LLVM.createGlobal True LLVM.InternalLinkage mxcsr+-}+      ld mxcsrFloor+      r <- f+      ld mxcsrOld+      return r++{-+[maxsd, minsd, maxpd, minpd] =+   map (Ext.intrinsic sse2)+     ["max.ss", "min.ss", "max.ps", "min.ps"]+-}++haddps :: Ext.T (VFloat -> VFloat -> CodeGenFunction r VFloat)+haddps = Ext.intrinsic sse3 "hadd.ps"++haddpd :: Ext.T (VDouble -> VDouble -> CodeGenFunction r VDouble)+haddpd = Ext.intrinsic sse3 "hadd.pd"++dpps :: Ext.T (VFloat -> VFloat -> Value Word32 -> CodeGenFunction r VFloat)+dpps = Ext.intrinsic sse41 "dpps"++dppd :: Ext.T (VDouble -> VDouble -> Value Word32 -> CodeGenFunction r VDouble)+dppd = Ext.intrinsic sse41 "dppd"++roundss, roundps :: Ext.T (VFloat -> Value Word32 -> CodeGenFunction r VFloat)+roundss = Ext.intrinsic sse41 "round.ss"+roundps = Ext.intrinsic sse41 "round.ps"++roundsd, roundpd :: Ext.T (VDouble -> Value Word32 -> CodeGenFunction r VDouble)+roundsd = Ext.intrinsic sse41 "round.sd"+roundpd = Ext.intrinsic sse41 "round.pd"++++{-+Not an LLVM intrinsic but implementation specific:+We expect that floating point values are in IEEE format+and thus the most significant bit is the sign.+The absolute value can be computed very efficiently by clearing the sign bit.+Actually, LLVM's codegen implements neg by an XOR on the sign bit.+-}+absss :: Ext.T (VFloat -> CodeGenFunction r VFloat)+absss =+   Ext.wrap sse1 $+   LLVM.bitcastUnify+     <=< A.and (LLVM.value $ constVector $ map constOf $ (flip clearBit 31 $ complement 0) : repeat (complement 0)+            :: Value (Vector D4 Word32))+     <=< LLVM.bitcastUnify++{-+This function works on a single Float,+but I like to do the masking in an XMM register+because usually the value is there anyway.++absss =+   flip LLVM.extractelement (valueOf 0)+     . flip asTypeOf (undefined :: VFloat)+     <=< LLVM.bitcastUnify+--        <=< A.and (LLVM.value $ constVector [constOf 0x7FFFFFFF] :: Value (Vector D4 Word32))+--        <=< A.and (LLVM.value $ constVector [constOf 0x7FFFFFFF, LLVM.undef, LLVM.undef, LLVM.undef] :: Value (Vector D4 Word32))+     <=< A.and (LLVM.value $ constVector [constOf 0x7FFFFFFF, LLVM.zero, LLVM.zero, LLVM.zero] :: Value (Vector D4 Word32))+     <=< LLVM.bitcastUnify+     . flip asTypeOf (undefined :: VFloat)+     <=< flip (LLVM.insertelement (LLVM.value LLVM.undef)) (valueOf 0)+-}+{- This moves the value to a general purpose register and performs the bit masking there+absss =+   LLVM.bitcastUnify+     <=< A.and (valueOf 0x7FFFFFFF :: Value Word32)+     <=< LLVM.bitcastUnify+-}++abssd :: Ext.T (VDouble -> CodeGenFunction r VDouble)+abssd =+   Ext.wrap sse2 $+   LLVM.bitcastUnify+     <=< A.and (LLVM.value $ constVector $ map constOf $ (flip clearBit 63 $ complement 0) : repeat (complement 0)+            :: Value (Vector D2 Word64))+     <=< LLVM.bitcastUnify++absps :: Ext.T (VFloat -> CodeGenFunction r VFloat)+absps =+   Ext.wrap sse1 $+   LLVM.bitcastUnify+     <=< A.and (LLVM.value $ constVector [constOf $ flip clearBit 31 $ complement 0]+            :: Value (Vector D4 Word32))+     <=< LLVM.bitcastUnify++abspd :: Ext.T (VDouble -> CodeGenFunction r VDouble)+abspd =+   Ext.wrap sse2 $+   LLVM.bitcastUnify+     <=< A.and (LLVM.value $ constVector [constOf $ flip clearBit 63 $ complement 0]+            :: Value (Vector D2 Word64))+     <=< LLVM.bitcastUnify+++{- |+cumulative sum:+@(a,b,c,d) -> (a,a+b,a+b+c,a+b+c+d)@++I try to cleverly use horizontal add,+but the generic version in the Vector module is better.+-}+_cumulate1s :: Ext.T (VFloat -> CodeGenFunction r VFloat)+_cumulate1s = Ext.with haddps $ \haddp x -> do+   y <- haddp x (LLVM.value LLVM.undef)+   z <- LLVM.shufflevector x y $+      constVector $ map constOf [0,4,2,5]+   offset <- LLVM.shufflevector y (LLVM.value LLVM.zero) $+      constVector $ map constOf [4,5,0,0]+   A.add z offset
+ src/LLVM/Extra/MaybeContinuation.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{- |+Maybe datatype implemented in continuation passing style.+-}+module LLVM.Extra.MaybeContinuation where++import qualified LLVM.Extra.Control as U+import LLVM.Extra.Control (ifThenElse, )++import qualified LLVM.Extra.Arithmetic as A+import LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, ) -- (phis, addPhis, )++import qualified Control.Applicative as App+import qualified Control.Monad as M++import Control.Monad.HT ((<=<), )+import Data.Tuple.HT (mapSnd, )++import Prelude hiding (fmap, and, iterate, map, zip, zipWith, writeFile, )+import qualified Prelude as P+++{- |+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 = return+   (<*>) = M.ap++instance Monad (T r z) where+   return a = lift (return a)+   (>>=) = bind++{- |+counterpart to Data.Maybe.HT.toMaybe+-}+withBool ::+   (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 ::+   (Phi z) =>+   CodeGenFunction r (Value Bool, a) -> +   T r z a+fromBool m = do+   (b,a) <- lift m+   guard b+   return a++toBool ::+   (Undefined a) =>+   T r (Value Bool, a) a -> CodeGenFunction r (Value Bool, a)+toBool (Cons m) =+   m (return (valueOf False, undefTuple)) (return . (,) (valueOf True))++lift :: CodeGenFunction r a -> T r z a+lift a = Cons $ \ _n j -> j =<< a++guard ::+   (Phi z) =>+   Value Bool -> T r z ()+guard b = Cons $ \n j ->+   ifThenElse b (j ()) n++{-+just :: CodeGenFunction r 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)++{- |+If the returned position is smaller than the array size,+then returned final state is undefined.+-}+arrayLoop ::+   (Phi s, IsType a,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i ->+   Value (Ptr a) -> s ->+   (Value (Ptr a) -> s -> T r (Value Bool, s) s) ->+   CodeGenFunction r (Value i, s)+arrayLoop len ptr start loopBody =+   U.arrayLoopWithExit len ptr start $ \ptri s0 ->+      toBool (loopBody ptri s0)++{-+arrayLoop len ptr start loopBody = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   body <- newBasicBlock+   exit <- newBasicBlock++   br loop++   defineBasicBlock loop+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- phis top start+   t <- A.icmp IntNE i (value LLVM.zero)+   condBr t body exit++   defineBasicBlock body+   loopBody p vars+      (br exit)+      (\vars' -> do+         next <- getCurrentBasicBlock+         addPhis next vars vars'++         i' <- A.dec i+         p' <- A.advanceArrayElementPtr p++         addPhiInputs i [(i', next)]+         addPhiInputs p [(p', next)]+         br loop)++   defineBasicBlock exit+   pos <- sub len i+   return (pos, vars)+-}++arrayLoop2 ::+   (Phi s, IsType a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i ->+   Value (Ptr a) -> Value (Ptr b) -> s ->+   (Value (Ptr a) -> Value (Ptr b) -> s ->+      T r (Value Bool, (Value (Ptr b), s)) s) ->+   CodeGenFunction r (Value i, s)+arrayLoop2 len ptrA ptrB start loopBody =+   P.fmap (mapSnd snd) $+   arrayLoop len ptrA (ptrB,start) $ \ptrAi (ptrBi,s0) -> do+      s1 <- loopBody ptrAi ptrBi s0+      ptrBi' <- lift $ A.advanceArrayElementPtr ptrBi+      return (ptrBi',s1)++{-+a specialised variant of whileLoop might also be useful+-}
+ src/LLVM/Extra/Monad.hs view
@@ -0,0 +1,20 @@+{- |+These functions work in arbitrary monads+but are especially helpful when working with the CodeGenFunction monad.+-}+module LLVM.Extra.Monad where++import Control.Monad (liftM2, liftM3, join, (<=<), )+++chain :: (Monad m) => [a -> m a] -> (a -> m a)+chain =+   foldr (flip (<=<)) return++liftR2 :: (Monad m) => (a -> b -> m c) -> m a -> m b -> m c+liftR2 f ma mb =+   join (liftM2 f ma mb)++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/Representation.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module LLVM.Extra.Representation (+   Memory(load, store, decompose, compose), modify, castStorablePtr,+   MemoryRecord, MemoryElement, memoryElement,+   loadRecord, storeRecord, decomposeRecord, composeRecord,+   loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,++   newForeignPtrInit, newForeignPtrParam,+   newForeignPtr, withForeignPtr,+   malloc, free,+   ) where++import qualified LLVM.Core as LLVM+import LLVM.Core+   (MakeValueTuple,+    Struct, getElementPtr0,+    extractvalue, insertvalue,+    Value, valueOf, Vector,+    IsType, IsSized,+    CodeGenFunction, )+import LLVM.Util.Loop (Phi, )++import qualified Foreign.Marshal.Utils as Marshal+import qualified Foreign.ForeignPtr as FPtr+import qualified Foreign.Concurrent as FC+import Foreign.Storable (Storable, poke, )+import Foreign.Ptr (Ptr, castPtr, FunPtr, )+import Data.TypeLevel.Num (d0, d1, d2, D4, )+import Data.Word (Word32, Word64, )+-- import Data.Word (Word8, Word16, Word32, Word64, )+-- import Data.Int  (Int8,  Int16,  Int32,  Int64, )++import Control.Monad (ap, )+import Control.Applicative (pure, liftA2, liftA3, )+import qualified Control.Applicative as App++import Data.Tuple.HT (fst3, snd3, thd3, )+++-- * Memory class and helper functions++{- |+An implementation of both 'MakeValueTuple' and 'Memory'+must ensure that @haskellValue@ is compatible with @llvmStruct@.+That is, writing and reading @llvmStruct@ by LLVM+must be the same as accessing @haskellValue@ by 'Storable' methods.++We use a functional dependency in order to let type inference work nicely.+-}+class (Phi llvmValue, IsType llvmStruct) =>+      Memory llvmValue llvmStruct | llvmValue -> llvmStruct where+   load :: Value (Ptr llvmStruct) -> CodeGenFunction r llvmValue+   load ptr  =  decompose =<< LLVM.load ptr+   store :: llvmValue -> Value (Ptr llvmStruct) -> CodeGenFunction r (Value ())+   store r ptr  =  flip LLVM.store ptr =<< compose r+   decompose :: Value llvmStruct -> CodeGenFunction r llvmValue+   compose :: llvmValue -> CodeGenFunction r (Value llvmStruct)++modify ::+   (Memory llvmValue llvmStruct) =>+   (llvmValue -> CodeGenFunction r llvmValue) ->+   Value (Ptr llvmStruct) -> CodeGenFunction r (Value ())+modify f ptr =+   flip store ptr =<< f =<< load ptr+++type MemoryRecord r o v = MemoryElement r o v v++data MemoryElement r o v x =+   MemoryElement {+      loadElement :: Value (Ptr o) -> CodeGenFunction r x,+      storeElement :: Value (Ptr o) -> v -> CodeGenFunction r (Value ()),+      extractElement :: Value o -> CodeGenFunction r x,+      insertElement :: v -> Value o -> CodeGenFunction r (Value o)+         -- State.Monoid+   }++memoryElement ::+   (Memory x llvmStruct,+    LLVM.GetValue o n llvmStruct,+    LLVM.GetElementPtr o (n, ()) llvmStruct) =>+   (v -> x) -> n -> MemoryElement r o v x+memoryElement field n =+   MemoryElement {+      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 (MemoryElement r o v) where+   fmap f m =+      MemoryElement {+         loadElement = fmap f . loadElement m,+         storeElement = storeElement m,+         extractElement = fmap f . extractElement m,+         insertElement = insertElement m+      }++instance App.Applicative (MemoryElement r o v) where+   pure x =+      MemoryElement {+         loadElement = \ _ptr -> return x,+         storeElement = \ _ptr _v ->+            return (error "MemoryElement: undefined value" :: Value ()),+         extractElement = \ _o -> return x,+         insertElement = \ _v o -> return o+      }+   f <*> x =+      MemoryElement {+         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 ::+   MemoryRecord r o llvmValue ->+   Value (Ptr o) -> CodeGenFunction r llvmValue+loadRecord = loadElement++storeRecord ::+   MemoryRecord r o llvmValue ->+   llvmValue -> Value (Ptr o) -> CodeGenFunction r (Value ())+storeRecord m y ptr = storeElement m ptr y++decomposeRecord ::+   MemoryRecord r o llvmValue ->+   Value o -> CodeGenFunction r llvmValue+decomposeRecord m =+   extractElement m++composeRecord ::+   (IsType o) =>+   MemoryRecord r o llvmValue ->+   llvmValue -> CodeGenFunction r (Value o)+composeRecord m v =+   insertElement m v (LLVM.value LLVM.undef)++++pairMemory ::+   (Memory al as, Memory bl bs,+    IsSized as sas, IsSized bs sbs) =>+   MemoryRecord r (Struct (as, (bs, ()))) (al, bl)+pairMemory =+   liftA2 (,)+      (memoryElement fst d0)+      (memoryElement snd d1)++instance+      (Memory al as, Memory bl bs,+       IsSized as sas, IsSized bs sbs) =>+      Memory (al, bl) (Struct (as, (bs, ()))) where+   load = loadRecord pairMemory+   store = storeRecord pairMemory+   decompose = decomposeRecord pairMemory+   compose = composeRecord pairMemory+++tripleMemory ::+   (Memory al as, Memory bl bs, Memory cl cs,+    IsSized as sas, IsSized bs sbs, IsSized cs scs) =>+   MemoryRecord r (Struct (as, (bs, (cs, ())))) (al, bl, cl)+tripleMemory =+   liftA3 (,,)+      (memoryElement fst3 d0)+      (memoryElement snd3 d1)+      (memoryElement thd3 d2)++instance+      (Memory al as, Memory bl bs, Memory cl cs,+       IsSized as sas, IsSized bs sbs, IsSized cs scs) =>+      Memory (al, bl, cl) (Struct (as, (bs, (cs, ())))) where+   load = loadRecord tripleMemory+   store = storeRecord tripleMemory+   decompose = decomposeRecord tripleMemory+   compose = composeRecord tripleMemory+++instance (LLVM.IsFirstClass a) => Memory (Value a) a where+   load = LLVM.load+   store = LLVM.store+   decompose = return+   compose = return++instance Memory () (Struct ()) where+   load _ = return ()+   store _ _ = return (error "().store: no result" :: Value ())+   decompose _ = return ()+   compose _ = return (LLVM.value LLVM.undef)++castStorablePtr ::+   (MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>+   Ptr haskellValue -> Ptr llvmStruct+castStorablePtr = castPtr++++loadNewtype ::+   (Memory a o) =>+   (a -> llvmValue) ->+   Value (Ptr o) -> CodeGenFunction r llvmValue+loadNewtype wrap ptr =+   fmap wrap $ load ptr++storeNewtype ::+   (Memory a o) =>+   (llvmValue -> a) ->+   llvmValue -> Value (Ptr o) -> CodeGenFunction r (Value ())+storeNewtype unwrap y ptr =+   store (unwrap y) ptr++decomposeNewtype ::+   (Memory a o) =>+   (a -> llvmValue) ->+   Value o -> CodeGenFunction r llvmValue+decomposeNewtype wrap y =+   fmap wrap $ decompose y++composeNewtype ::+   (Memory a o) =>+   (llvmValue -> a) ->+   llvmValue -> CodeGenFunction r (Value o)+composeNewtype unwrap y =+   compose (unwrap y)+++++-- * ForeignPtr support++type Importer f = FunPtr f -> f++foreign import ccall safe "dynamic" derefStartPtr ::+   Importer (IO (Ptr a))++newForeignPtrInit ::+   FunPtr (Ptr a -> IO ()) ->+   FunPtr (IO (Ptr a)) ->+   IO (FPtr.ForeignPtr a)+newForeignPtrInit stop start =+   FPtr.newForeignPtr stop =<< derefStartPtr start+++foreign import ccall safe "dynamic" derefStartParamPtr ::+   Importer (Ptr b -> IO (Ptr a))++{-+We cannot use 'bracket' when constructing lazy StorableVector,+since this would mean that the temporary memory is freed immediately.+Instead we must add a Finalizer to the ForeignPtr.+-}+newForeignPtrParam ::+   (Storable b, MakeValueTuple b bl, Memory bl bp) =>+   FunPtr (Ptr a -> IO ()) ->+   FunPtr (Ptr bp -> IO (Ptr a)) ->+   b -> IO (FPtr.ForeignPtr a)+newForeignPtrParam stop start b =+   FPtr.newForeignPtr stop =<<+   Marshal.with b (derefStartParamPtr start . castStorablePtr)++{-+requires (Storable ap) constraint+and we have no Storable instance for Struct++newForeignPtr ::+   (Storable a, MakeValueTuple a al, Memory al ap) =>+   a -> IO (FPtr.ForeignPtr ap)+newForeignPtr a = do+   ptr <- FPtr.mallocForeignPtr+   FPtr.withForeignPtr ptr (flip poke a . castPtr)+   return ptr+-}++{- |+Adding the finalizer to a ForeignPtr seems to be the only way+that warrants execution of the finalizer (not too early and not never).+However, the normal ForeignPtr finalizers must be independent from Haskell runtime.+In contrast to ForeignPtr finalizers,+addFinalizer adds finalizers to boxes, that are optimized away.+Thus finalizers are run too early or not at all.+Concurrent.ForeignPtr and using threaded execution+is the only way to get finalizers in Haskell IO.+-}+newForeignPtr ::+   Storable a =>+   IO () ->+   a -> IO (FPtr.ForeignPtr a)+newForeignPtr finalizer a = do+   ptr <- FPtr.mallocForeignPtr+   FC.addForeignPtrFinalizer ptr finalizer+   FPtr.withForeignPtr ptr (flip poke a)+   return ptr++withForeignPtr ::+   (Storable a, MakeValueTuple a al, Memory al ap) =>+   FPtr.ForeignPtr a -> (Ptr ap -> IO b) -> IO b+withForeignPtr fp func =+   FPtr.withForeignPtr fp (func . castStorablePtr)+++{-+malloc :: (IsSized a s) => CodeGenFunction r (Value (Ptr a))+malloc = LLVM.malloc++free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())+free = LLVM.free+-}+++type Aligned a = Struct (a, (Ptr (Vector D4 Float), ()))+type AlignedPtr a = Ptr (Aligned a)++{- |+Returns 16 Byte aligned piece of memory.+Otherwise program crashes when vectors are part of the structure.+I think that malloc in LLVM-2.5 and LLVM-2.6 is simply buggy.++FIXME:+Aligning to 16 Byte might not be appropriate for all vector types on all platforms.+Maybe we should use alignment of Storable class+in order to determine the right alignment.+-}+malloc :: (IsSized a s) => CodeGenFunction r (Value (Ptr a))+malloc =+   let m :: (IsSized a s) =>+            CodeGenFunction r (Value (Ptr (Struct (Vector D4 Float, (Aligned a, ())))))+       m = LLVM.malloc+   in  do p <- m+          -- skip pad+          p1 <- getElementPtr0 p (d1, ())+          p1int <- LLVM.ptrtoint p1+          -- go back to the last 16 byte aligned address+          p16int <- LLVM.and (valueOf (-16) :: Value Word64) (p1int :: Value Word64)+          p16 <- LLVM.inttoptr p16int+          {-+          v has same address as p but different type.+          This way we avoid a recursive datatype but we avoid also a cast.+          -}+          v <- getElementPtr0 p (d0, ())+          store v =<< getElementPtr0 (p16 `asTypeOf` p1) (d1, ())+          getElementPtr0 p16 (d0, ())++{-+This is correct but will be optimized incorrectly.+The "optimized" code will access a pointer+that is 4 cells greater than the right pointer+for certain sizes of the record @a@.++free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())+free p =+   LLVM.free =<<+   load =<<+   flip getElementPtr0 (d1, ()) =<<+   (LLVM.bitcastUnify ::+      (IsSized a sa) =>+      Value (Ptr a) ->+      CodeGenFunction r (Value (AlignedPtr a))) p+-}++free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())+free p =+   LLVM.free =<<+   load =<<+   (LLVM.bitcastUnify ::+      (IsSized a sa) =>+      Value (Ptr a) ->+      CodeGenFunction r (Value (Ptr (AlignedPtr a)))) =<<+   LLVM.getElementPtr p (1 :: Word32, ())
+ src/LLVM/Extra/ScalarOrVector.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# 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 safe expensive handling of possibly seldom cases.+-}+module LLVM.Extra.ScalarOrVector (+   Fraction (truncate, fraction),+   signedFraction,+   addToPhase,+   incPhase,+   Replicate (replicate, replicateConst),+   replicateOf,+   Real (min, max, abs),+   ) where++import qualified LLVM.Extra.Vector as Vector+import qualified LLVM.Extra.Extension.X86 as X86+import qualified LLVM.Extra.Extension as Ext++import qualified LLVM.Extra.Arithmetic as A++import Data.TypeLevel.Num (D1, )+import qualified LLVM.Core as LLVM+import LLVM.Core+   (Value, ConstValue, valueOf,+    Vector, insertelement, constOf, constVector,+    IsConst, IsFloating, IsPrimitive, IsPowerOf2,+    CodeGenFunction,+    FP128, )++import Control.Monad.HT ((<=<), )++import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Int  (Int8,  Int16,  Int32,  Int64, )++import Prelude hiding (Real, replicate, min, max, abs, truncate, floor, round, )+++{-+class+   (IsFloating frac,+    IsInteger int,+    LLVM.NumberOfElements n frac,+    LLVM.NumberOfElements n int) =>+      Fraction n int frac | frac -> int, frac -> n, int -> n where+   fptosi :: Value frac -> CodeGenFunction r (Value int)+   fptosi = LLVM.fptosi+   sitofp :: Value int -> CodeGenFunction r (Value frac)+   sitofp = LLVM.sitofp+-}++{-+class+   (IsFloating frac) =>+      Fraction int frac | frac -> int where+   fptosi :: Value frac -> CodeGenFunction r (Value int)+   sitofp :: Value int -> CodeGenFunction r (Value frac)++instance Fraction Int32 Float where+   fptosi = LLVM.fptosi+   sitofp = LLVM.sitofp++instance Fraction Int64 Double where+   fptosi = LLVM.fptosi+   sitofp = LLVM.sitofp++instance (LLVM.IsPowerOf2 n) =>+      Fraction (Vector n Int32) (Vector n Float) where+   fptosi = LLVM.fptosi+   sitofp = LLVM.sitofp++instance (LLVM.IsPowerOf2 n) =>+      Fraction (Vector n Int64) (Vector n Double) where+   fptosi = LLVM.fptosi+   sitofp = LLVM.sitofp+-}+++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 =+      mapAuto+         (LLVM.sitofp . flip asTypeOf (undefined :: Value Int32) <=< LLVM.fptosi)+         (Ext.with X86.roundss $ \round x -> round x (valueOf 3))+   fraction =+      (\x ->+         fractionGen x+         `Ext.run`+         (Ext.with X86.cmpss $ \cmp ->+            fractionLogical (\modus -> curry (runScalar (uncurry (cmp modus)))) x))+      `mapAuto`+      (Ext.with X86.roundss $ \round x ->+         A.sub x =<< round x (valueOf 1))++instance Fraction Double where+   truncate =+      mapAuto+         -- X86 only converts Double to Int32, it cannot target Int64+         (LLVM.sitofp . flip asTypeOf (undefined :: Value Int32) <=< LLVM.fptosi)+         (Ext.with X86.roundsd $ \round x -> round x (valueOf 3))+   fraction =+      (\x ->+         fractionGen x+         `Ext.run`+         (Ext.with X86.cmpsd $ \cmp ->+            fractionLogical (\modus -> curry (runScalar (uncurry (cmp modus)))) x))+{-+For Doubles it would be more efficient to convert the lower 32 bit+instead of the lower 64 bit,+since x86 supports only conversion from 32 bit natively.+      (Ext.with X86.cmpsd $ \cmp -> fractionLogical+         (\x y -> cmp x y >>= LLVM.bitcastUnify )+-}+      `mapAuto`+      (Ext.with X86.roundsd $ \round x ->+         A.sub x =<< round x (valueOf 1))++instance (LLVM.IsPowerOf2 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 ::+   (Num a, Fraction v, Replicate a v, IsConst a, LLVM.CmpRet v b) =>+   Value v -> CodeGenFunction r (Value v)+fractionGen x =+   do xf <- signedFraction x+      b <- A.fcmp LLVM.FPOGE xf (LLVM.value LLVM.zero)+      LLVM.select b xf =<< A.add xf (replicateOf 1)++fractionLogical ::+   (Fraction a, LLVM.NumberOfElements D1 a,+    LLVM.IsInteger b, LLVM.NumberOfElements D1 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 (LLVM.value LLVM.zero)+      A.sub xf =<< LLVM.sitofp 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++++class Replicate scalar vector | vector -> scalar where+   replicate :: Value scalar -> CodeGenFunction r (Value vector)+   replicateConst :: ConstValue scalar -> ConstValue vector++instance Replicate Float  Float  where replicate = return; replicateConst = id;+instance Replicate Double Double where replicate = return; replicateConst = id;+instance Replicate FP128  FP128  where replicate = return; replicateConst = id;+instance Replicate Bool   Bool   where replicate = return; replicateConst = id;+instance Replicate Int8   Int8   where replicate = return; replicateConst = id;+instance Replicate Int16  Int16  where replicate = return; replicateConst = id;+instance Replicate Int32  Int32  where replicate = return; replicateConst = id;+instance Replicate Int64  Int64  where replicate = return; replicateConst = id;+instance Replicate Word8  Word8  where replicate = return; replicateConst = id;+instance Replicate Word16 Word16 where replicate = return; replicateConst = id;+instance Replicate Word32 Word32 where replicate = return; replicateConst = id;+instance Replicate Word64 Word64 where replicate = return; replicateConst = id;+instance (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a) => Replicate a (Vector n a) where+{- crashes LLVM-2.5, seems to be fixed in LLVM-2.6 -}+   replicate x = do+      v <- LLVM.insertelement (LLVM.value LLVM.undef) x (valueOf 0)+      LLVM.shufflevector v (LLVM.value LLVM.undef) LLVM.zero+{- crashes LLVM-2.5+   replicate x = do+      v <- LLVM.insertelement (LLVM.value LLVM.undef) x (valueOf 1)+      LLVM.shufflevector v (LLVM.value LLVM.undef) (constVector $ repeat $ LLVM.constOf 1)+-}+{- the (repeat zero) is also converted to 'zeroinitializer' and crashes LLVM compiler++         (constVector $ repeat LLVM.zero)+-}+{-+   replicate = Vector.replicate+-}+   replicateConst x = LLVM.constVector [x];++replicateOf ::+   (IsConst a, Replicate a v) =>+   a -> Value v+replicateOf a =+   LLVM.value (replicateConst (LLVM.constOf a))+++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)+++instance Real Float  where+   min = zipAutoWith A.fmin X86.minss+   max = zipAutoWith A.fmax X86.maxss+   abs = mapAuto     A.fabs X86.absss+   -- abs x = max x =<< LLVM.neg x+   -- abs x = A.fabs++instance Real Double where+   min = zipAutoWith A.fmin X86.minsd+   max = zipAutoWith A.fmax X86.maxsd+   abs = mapAuto     A.fabs X86.abssd+++infixl 1 `mapAuto`++{- |+There are functions that are intended for processing scalars+but have formally vector input and output.+This function breaks vector function down to a scalar function+by accessing the lowest vector element.+-}+runScalar ::+   (Vector.Access n a va, Vector.Access n b vb) =>+   (va -> CodeGenFunction r vb) ->+   (a -> CodeGenFunction r b)+runScalar op a =+   Vector.extract (valueOf 0)+     =<< op+     =<< Vector.insert (valueOf 0) a LLVM.undefTuple++mapAuto ::+   (Vector.Access n a va, Vector.Access n b vb) =>+   (a -> CodeGenFunction r b) ->+   Ext.T (va -> CodeGenFunction r vb) ->+   (a -> CodeGenFunction r b)+mapAuto f g a =+   Ext.run (f a) $+   Ext.with g $ \op -> runScalar op a++zipAutoWith ::+   (Vector.Access n a va, Vector.Access n b vb, Vector.Access n c vc) =>+   (a -> b -> CodeGenFunction r c) ->+   Ext.T (va -> vb -> CodeGenFunction r vc) ->+   (a -> b -> CodeGenFunction r c)+zipAutoWith f g =+   curry $ mapAuto (uncurry f) (fmap uncurry g)+++instance Real FP128  where min = A.fmin; max = A.fmax; abs = A.fabs;+instance Real Int8   where min = A.smin; max = A.smax; abs = A.sabs;+instance Real Int16  where min = A.smin; max = A.smax; abs = A.sabs;+instance Real Int32  where min = A.smin; max = A.smax; abs = A.sabs;+instance Real Int64  where min = A.smin; max = A.smax; abs = A.sabs;+instance Real Word8  where min = A.umin; max = A.umax; abs = return;+instance Real Word16 where min = A.umin; max = A.umax; abs = return;+instance Real Word32 where min = A.umin; max = A.umax; abs = return;+instance Real Word64 where min = A.umin; max = A.umax; abs = return;++instance (LLVM.IsPowerOf2 n, Vector.Real a) =>+         Real (Vector n a) where+   min = Vector.min+   max = Vector.max+   abs = Vector.abs
+ src/LLVM/Extra/Vector.hs view
@@ -0,0 +1,1165 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+module LLVM.Extra.Vector (+   size, sizeInTuple,+   replicate, iterate, assemble,++   shuffle,+   rotateUp, rotateDown, reverse,+   shiftUp, shiftDown,+   shiftUpMultiZero, shiftDownMultiZero,+   ShuffleMatch (shuffleMatch),+   shuffleMatchTraversable,++   Access (insert, extract),+   insertTraversable,+   extractTraversable,++   insertChunk, modify,+   map, mapChunks, zipChunksWith,+   chop, concat, select,+   signedFraction,+   cumulate1, umul32to64,+   Arithmetic+      (sum, sumToPair, sumInterleavedToPair,+       cumulate, dotProduct, mul),+   Real+      (min, max, abs,+       truncate, floor, fraction),+   ) where++import qualified LLVM.Extra.Extension.X86 as X86+import qualified LLVM.Extra.Extension as Ext++import qualified LLVM.Extra.Monad as M+import qualified LLVM.Extra.Arithmetic as A++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (Phi, )+import LLVM.Core+   (Value, ConstValue, valueOf, value, constOf, undef,+    Vector, shufflevector, insertelement, extractelement, constVector,+    IsConst, IsArithmetic, IsFloating,+    IsPrimitive, IsPowerOf2,+    CodeGenFunction, )++import Data.TypeLevel.Num (D2, )+import qualified Data.TypeLevel.Num as TypeNum+import Control.Monad.HT ((<=<), )+import Control.Monad (liftM2, liftM3, foldM, )+import Data.Tuple.HT (uncurry3, )+import qualified Data.List.HT as ListHT+import qualified Data.List as List++import Control.Applicative (liftA2, )+import qualified Control.Applicative as App+import qualified Data.Traversable as Trav++-- import qualified Data.Bits as Bit+import Data.Int  (Int8, Int16, Int32, Int64, )+import Data.Word (Word8, Word16, Word32, Word64, )++import Prelude hiding+          (Real, truncate, floor, round,+           map, zipWith, iterate, replicate, reverse, concat, sum, )+++-- * target independent functions++size ::+   (TypeNum.Nat n) =>+   Value (Vector n a) -> Int+size =+   let sz :: (TypeNum.Nat n) => n -> Value (Vector n a) -> Int+       sz n _ = TypeNum.toInt n+   in  sz undefined++{- |+Manually assemble a vector of equal values.+Better use ScalarOrVector.replicate.+-}+replicate ::+   (Access n a va) =>+   a -> CodeGenFunction r va+replicate = replicateCore undefined++replicateCore ::+   (Access n a va) =>+   n -> a -> CodeGenFunction r va+replicateCore n =+   assemble . List.replicate (TypeNum.toInt n)++{- |+construct a vector out of single elements++You must assert that the length of the list matches the vector size.+-}+assemble ::+   (Access n a va) =>+   [a] -> CodeGenFunction r va+assemble =+   foldM (\v (k,x) -> insert (valueOf k) x v) LLVM.undefTuple .+   List.zip [0..]+{- sends GHC into an infinite loop+   foldM (\(k,x) -> insert (valueOf k) x) LLVM.undefTuple .+   List.zip [0..]+-}++insertChunk ::+   (Access m a ca, Access n a va) =>+   Int -> ca ->+   va -> CodeGenFunction r va+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 ::+   (Access n a va) =>+   (a -> CodeGenFunction r a) ->+   a -> CodeGenFunction r va+iterate f x =+   fmap snd $+   iterateCore f x LLVM.undefTuple++iterateCore ::+   (Access n a va) =>+   (a -> CodeGenFunction r a) ->+   a -> va ->+   CodeGenFunction r (a, va)+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).+-}+shuffle ::+   (Access m a ca, Access n a va) =>+   va ->+   ConstValue (Vector m Word32) ->+   CodeGenFunction r ca+shuffle x i =+   assemble =<<+   mapM+      (flip extract x <=< extractelement (value i) . valueOf)+      (take (size (value i)) [0..])+++sizeInTuple :: ShuffleMatch n v => v -> Int+sizeInTuple =+   let sz :: (ShuffleMatch n v) => n -> v -> Int+       sz n _ = TypeNum.toInt n+   in  sz undefined++{- |+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 ::+   (ShuffleMatch n v) =>+   v -> CodeGenFunction r v+rotateUp x =+   shuffleMatch+      (constVector $ List.map constOf $+       (fromIntegral (sizeInTuple x) - 1) : [0..]) x++rotateDown ::+   (ShuffleMatch n v) =>+   v -> CodeGenFunction r v+rotateDown x =+   shuffleMatch+      (constVector $ List.map constOf $+       List.take (sizeInTuple x - 1) [1..] ++ [0]) x++reverse ::+   (ShuffleMatch n v) =>+   v -> CodeGenFunction r v+reverse x =+   shuffleMatch+      (constVector $ List.map constOf $+       List.reverse $+       List.take (sizeInTuple x) [0..]) x++shiftUp ::+   (Access n a v) =>+   a -> v -> CodeGenFunction r (a, v)+shiftUp x0 x = do+   y <-+      shuffleMatch+         (constVector $ undef : List.map constOf [0..]) x+   liftM2 (,)+      (extract (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x)+      (insert (value LLVM.zero) x0 y)++shiftDown ::+   (Access n a v) =>+   a -> v -> CodeGenFunction r (a, v)+shiftDown x0 x = do+   y <-+      shuffleMatch+         (constVector $+          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 ::+   (IsPrimitive a, IsPowerOf2 n) =>+   Int ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+shiftUpMultiZero k x =+   LLVM.shufflevector (LLVM.value LLVM.zero) x+      (constVector $ List.map constOf $+       take k [0..] ++ [(fromIntegral (sizeInTuple x)) ..])++shiftDownMultiZero ::+   (IsPrimitive a, IsPowerOf2 n) =>+   Int ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+shiftDownMultiZero k x =+   LLVM.shufflevector x (LLVM.value LLVM.zero)+      (constVector $ List.map constOf $+       [(fromIntegral k) ..])+++class+   (LLVM.IsPowerOf2 n, Phi v) =>+      ShuffleMatch n v | v -> n where+   shuffleMatch ::+      ConstValue (Vector n Word32) -> v -> CodeGenFunction r v++shuffleMatchTraversable ::+   (ShuffleMatch n v, Trav.Traversable f) =>+   ConstValue (Vector n Word32) -> f v -> CodeGenFunction r (f v)+shuffleMatchTraversable is v =+   Trav.mapM (shuffleMatch is) v+++{- |+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)@.+-}+class+   (ShuffleMatch n v) =>+      Access n a v | v -> a n, a n -> v where+   insert :: Value Word32 -> a -> v -> CodeGenFunction r v+   extract :: Value Word32 -> v -> CodeGenFunction r a++insertTraversable ::+   (Access n a v, Trav.Traversable f, App.Applicative f) =>+   Value Word32 -> f a -> f v -> CodeGenFunction r (f v)+insertTraversable n a v =+   Trav.sequence (liftA2 (insert n) a v)++extractTraversable ::+   (Access n a v, Trav.Traversable f) =>+   Value Word32 -> f v -> CodeGenFunction r (f a)+extractTraversable n v =+   Trav.mapM (extract n) v+++instance+   (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a) =>+      ShuffleMatch n (Value (Vector n a)) where+   shuffleMatch is v = shufflevector v (value undef) is++instance+   (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a) =>+      Access n (Value a) (Value (Vector n a)) where+   insert  k a v = insertelement v a k+   extract k v   = extractelement v k+++instance+   (ShuffleMatch n v0, ShuffleMatch n v1) =>+      ShuffleMatch n (v0, v1) where+   shuffleMatch is (v0,v1) =+      liftM2 (,)+         (shuffleMatch is v0)+         (shuffleMatch is v1)++instance+   (Access n a0 v0, Access n a1 v1) =>+      Access n (a0, a1) (v0, v1) where+   insert k (a0,a1) (v0,v1) =+      liftM2 (,)+         (insert k a0 v0)+         (insert k a1 v1)+   extract k (v0,v1) =+      liftM2 (,)+         (extract k v0)+         (extract k v1)+++instance+   (ShuffleMatch n v0, ShuffleMatch n v1, ShuffleMatch n v2) =>+      ShuffleMatch n (v0, v1, v2) where+   shuffleMatch is (v0,v1,v2) =+      liftM3 (,,)+         (shuffleMatch is v0)+         (shuffleMatch is v1)+         (shuffleMatch is v2)++instance+   (Access n a0 v0, Access n a1 v1, Access n a2 v2) =>+      Access n (a0, a1, a2) (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)+   extract k (v0,v1,v2) =+      liftM3 (,,)+         (extract k v0)+         (extract k v1)+         (extract k v2)+++modify ::+   (Access n a va) =>+   Value Word32 ->+   (a -> CodeGenFunction r a) ->+   (va -> CodeGenFunction r va)+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 ::+   (Access n a va, Access n b vb) =>+   (a -> CodeGenFunction r b) ->+   (va -> CodeGenFunction r vb)+map f a =+   foldM+      (\b n ->+         extract (valueOf n) a >>=+         f >>=+         flip (insert (valueOf n)) b)+      LLVM.undefTuple+      (take (sizeInTuple a) [0..])++mapChunks ::+   (Access m a ca, Access m b cb,+    Access n a va, Access n b 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)+      LLVM.undefTuple $+   List.zip (chop a) [0..]++zipChunksWith ::+   (Access m a ca, Access m b cb, Access m c cc,+    Access n a va, Access n b vb, Access n c vc) =>+   (ca -> cb -> CodeGenFunction r cc) ->+   (va -> vb -> CodeGenFunction r vc)+zipChunksWith f a b =+   mapChunks (uncurry f) (a,b)+++mapAuto ::+   (Access m a ca, Access m b cb,+    Access n a va, Access n b vb) =>+   (a -> CodeGenFunction r b) ->+   Ext.T (ca -> CodeGenFunction r cb) ->+   (va -> CodeGenFunction r vb)+mapAuto f g a =+   Ext.run (map f a) $+   Ext.with g $ \op -> mapChunks op a++zipAutoWith ::+   (Access m a ca, Access m b cb, Access m c cc,+    Access n a va, Access n b vb, Access n c vc) =>+   (a -> b -> CodeGenFunction r c) ->+   Ext.T (ca -> cb -> CodeGenFunction r cc) ->+   (va -> vb -> CodeGenFunction r vc)+zipAutoWith f g a b =+   mapAuto (uncurry f) (fmap uncurry g) (a,b)+++{- |+Ideally on ix86 with SSE41 this would be translated to 'dpps'.+-}+dotProductPartial ::+   (LLVM.IsPowerOf2 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 ::+   (LLVM.IsPowerOf2 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.liftR2 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 ::+   (Access m a ca, Access n a va) =>+   va -> [CodeGenFunction r ca]+chop = chopCore undefined++chopCore ::+   (Access m a ca, Access n a va) =>+   m -> va -> [CodeGenFunction r ca]+chopCore m x =+   List.map (shuffle x . constVector) $+   ListHT.sliceVertical (TypeNum.toInt m) $+   List.map constOf $+   take (sizeInTuple x) [0..]++{- |+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 ::+   (Access m a ca, Access n a va) =>+   [ca] -> CodeGenFunction r va+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)+      LLVM.undefTuple $+   List.zip+      (ListHT.sliceVertical (sizeInTuple (head xs)) [0..])+      xs+++getLowestPair ::+   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,+    IsPowerOf2 n, IsPowerOf2 m, TypeNum.Mul D2 m n) =>+   m ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector m a))+_reduceAddInterleaved tm v = do+   let m = TypeNum.toInt tm+   x <- shuffle v (constVector $ List.map constOf $ take m [0..])+   y <- shuffle v (constVector $ List.map constOf $ take m [fromIntegral m ..])+   A.add x y++sumGeneric ::+   (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value a)+sumGeneric =+   flip extractelement (valueOf 0) <=<+   reduceSumInterleaved 1++sumToPairGeneric ::+   (Arithmetic a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value a, Value a)+sumToPairGeneric v =+   let n2 = div (size v) 2+   in  sumInterleavedToPair =<<+       shufflevector v (value undef)+          (constVector $+           List.map (constOf . fromIntegral) $+           concatMap (\k -> [k, k+n2]) $+           take 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, IsPowerOf2 n) =>+   Int ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+reduceSumInterleaved m x0 =+   let go ::+          (IsArithmetic a, IsPrimitive a, IsPowerOf2 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+                      =<< shufflevector x (value undef)+                             (constVector $ List.map constOf (take n2 [fromIntegral n2 ..])+                                 ++ List.repeat undef)+   in  go (size x0) x0++cumulateGeneric, _cumulateSimple ::+   (IsArithmetic a, IsPrimitive a, IsPowerOf2 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, LLVM.undefTuple)+      (take (sizeInTuple x) $ [0..])++cumulateGeneric =+   cumulateFrom1 cumulate1++cumulateFrom1 ::+   (IsArithmetic a, IsPrimitive a, IsPowerOf2 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, IsPowerOf2 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)+++signedFraction ::+   (IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+signedFraction x =+   A.sub x =<< truncate x++floorGeneric ::+   (IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+floorGeneric = floorLogical A.fcmp++{- |+On LLVM-2.6 and X86 this produces branch-free+but even slower code than 'fractionSelect',+since the comparison to booleans and+back to a floating point number is translated literally+to elementwise comparison, conversion to a 0 or -1 byte+and then to a floating point number.+-}+fractionGeneric ::+   (IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+fractionGeneric = fractionLogical A.fcmp+++{- |+LLVM.select on boolean vectors cannot be translated to X86 code in LLVM-2.6,+thus I code my own version that calls select on all elements.+This is slow but works.+When this issue is fixed, this function will be replaced by LLVM.select.+-}+select ::+   (LLVM.IsFirstClass a, IsPrimitive a, IsPowerOf2 n,+    LLVM.CmpRet a Bool) =>+   Value (Vector n Bool) ->+   Value (Vector n a) ->+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+select b x y =+   map (uncurry3 LLVM.select) (b, x, y)++{- |+'floor' implemented using 'select'.+This will need jumps.+-}+_floorSelect ::+   (Num a, IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+_floorSelect x =+   do xr <- truncate x+      b <- A.fcmp LLVM.FPOLE xr x+      select b xr =<< A.sub xr =<< replicate (valueOf 1)++{- |+'fraction' implemented using 'select'.+This will need jumps.+-}+_fractionSelect ::+   (Num a, IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   Value (Vector n a) ->+   CodeGenFunction r (Value (Vector n a))+_fractionSelect x =+   do xf <- signedFraction x+      b <- A.fcmp LLVM.FPOGE xf (value LLVM.zero)+      select b xf =<< A.add xf =<< replicate (valueOf 1)+++{- |+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 sa, LLVM.IsSized i si, sa :==: si, si :==: sa,+--    LLVM.IsSized a s, LLVM.IsSized i s,+    LLVM.IsSized (Vector n a) s, LLVM.IsSized (Vector n i) s,+    IsPowerOf2 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 <- A.xor b+   bneg <- LLVM.inv b+   xm <- A.and b    =<< LLVM.bitcastUnify x+   ym <- A.and bneg =<< LLVM.bitcastUnify y+   LLVM.bitcastUnify =<< A.or xm ym+++floorLogical ::+   (IsFloating a, IsConst a, Real a,+    IsPrimitive i, LLVM.IsInteger i, IsPowerOf2 n) =>+   (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 <- truncate x+      b <- cmp LLVM.FPOGT xr x+      A.add xr =<< LLVM.sitofp b++fractionLogical ::+   (IsFloating a, IsConst a, Real a,+    IsPrimitive i, LLVM.IsInteger i, IsPowerOf2 n) =>+   (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 <- signedFraction x+      b <- cmp LLVM.FPOLT xf (value LLVM.zero)+      A.sub xf =<< LLVM.sitofp b+++orderBy ::+   (IsPowerOf2 m,+    LLVM.IsFirstClass a, IsPrimitive a,+    LLVM.IsInteger i, IsPrimitive i,+    LLVM.IsSized (Vector m a) s, LLVM.IsSized (Vector m i) s) =>+   Ext.T (Value (Vector m a) -> Value (Vector m a) -> CodeGenFunction r (Value (Vector m i))) ->+   Ext.T (Value (Vector m a) -> Value (Vector m a) -> CodeGenFunction r (Value (Vector m a)))+orderBy cmp =+   Ext.with cmp $ \pcmpgt x y ->+      pcmpgt x y >>= \b -> selectLogical b y x++order ::+   (IsPowerOf2 n, IsPowerOf2 m,+    LLVM.IsFirstClass a, IsPrimitive a,+    LLVM.IsInteger i, IsPrimitive i,+    LLVM.IsSized (Vector m a) s, LLVM.IsSized (Vector m i) s) =>+   (Value a -> Value a -> CodeGenFunction r (Value a)) ->+   Ext.T (Value (Vector m a) -> Value (Vector m a) -> CodeGenFunction r (Value (Vector m i))) ->+   Ext.T (Value (Vector m a) -> Value (Vector m a) -> CodeGenFunction r (Value (Vector m a))) ->+   (Value (Vector n a) -> Value (Vector n a) -> CodeGenFunction r (Value (Vector n a)))+order byScalar byCmp byChunk x y =+   map (uncurry byScalar) (x,y)+   `Ext.run`+   (Ext.with byCmp $ \pcmpgt ->+      mapChunks (\(cx,cy) ->+         pcmpgt cx cy >>= \b -> selectLogical b cy cx) (x,y))+{-+This is not nice, because selectLogical uses bitcast+and bitcast requires ugly type constraints for equal vector sizes.+Thus we restrict selectLogical to chunks and thus monomorphic types.+   (Ext.with byCmp $ \pcmpgt -> do+       b <- mapChunks (uncurry pcmpgt) (x,y)+       selectLogical b y x)+-}+   `Ext.run`+   (Ext.with byChunk $ \psel ->+       zipChunksWith psel x y)+++-- * 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 ::+      (IsPowerOf2 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 ::+      (IsPowerOf2 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 ::+      (IsPowerOf2 n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value a, Value a)+   sumInterleavedToPair v =+      getLowestPair =<< reduceSumInterleaved 2 v++   cumulate ::+      (IsPowerOf2 n) =>+      Value a -> Value (Vector n a) ->+      CodeGenFunction r (Value a, Value (Vector n a))+   cumulate = cumulateGeneric++   dotProduct ::+      (IsPowerOf2 n) =>+      Value (Vector n a) ->+      Value (Vector n a) ->+      CodeGenFunction r (Value a)+   dotProduct x y =+      dotProductPartial (size x) x y++   mul ::+      (IsPowerOf2 n) =>+      Value (Vector n a) ->+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))+   mul = A.mul++instance Arithmetic Float where+   sum x =+      Ext.runWhen (size x >= 4) (sumGeneric x) $+      Ext.with X86.haddps $ \haddp ->+          {-+          We can make use of the following facts:+          SSE3 has Float vectors of size 4,+          there is an instruction for horizontal add.+          -}+          do chunkSum <-+                foldl1 (M.liftR2 A.add) $ chop x+             y <- haddp chunkSum (value undef)+             z <- haddp y        (value undef)+{-+             y <- haddp chunkSum chunkSum+             z <- haddp y y+-}+             extractelement z (valueOf 0)++   sumToPair x =+      Ext.runWhen (size x >= 4) (getLowestPair x) $+      Ext.with X86.haddps $ \haddp ->+          let {-+              reduce ::+                 [CodeGenFunction r (Value (Vector D4 Float))] ->+                 [CodeGenFunction r (Value (Vector D4 Float))]+              -}+              reduce [] = []+              reduce [_] = error "vector must have size power of two"+              reduce (x0:x1:xs) =+                 M.liftR2 haddp x0 x1 : reduce xs+              go []  = error "vector must not be empty"+              go [c] =+                 getLowestPair+                    =<< flip haddp (value undef)+                    =<< c+              go cs  = go (reduce cs)+          in  go $ chop x++{-+The haddps based implementation cumulate is slower than the generic one.+However, one day the x86 processors may implement a cumulative sum+which we could employ with this frame.++   cumulate a x =+      Ext.runWhen (size x >= 4) (cumulateGeneric a x) $+      Ext.with X86.cumulate1s $ \cumulate1s -> do+         (b,ys) <-+            foldr+               (\chunk0 cont a0 -> do+                  (a1,chunk1) <- cumulateFrom1 cumulate1s a0 =<< chunk0+                  fmap (mapSnd (chunk1:)) (cont a1))+               (\a0 -> return (a0,[]))+               (chop x)+               a+         y <- concat ys+         return (b,y)+-}++   dotProduct x y =+      Ext.run (sum =<< A.mul x y) $+      Ext.with X86.dpps $ \dpp ->+         foldl1 (M.liftR2 A.add) $+         List.zipWith+            (\mx my -> do+               cx <- mx+               cy <- my+               flip extractelement (valueOf 0)+                =<< dpp cx cy (valueOf 0xF1))+            (chop x)+            (chop y)++instance Arithmetic Double where++instance Arithmetic Int8   where+instance Arithmetic Int16  where+instance Arithmetic Int32  where+instance Arithmetic Int64  where+instance Arithmetic Word8  where+instance Arithmetic Word16 where+instance Arithmetic Word64 where++instance Arithmetic Word32 where+   mul x y =+      A.mul x y+      `Ext.run`+      (Ext.with X86.pmuludq $ \pmul ->+         zipChunksWith+            (\cx cy -> do+               evenX <- LLVM.shufflevector cx (value undef)+                  (constVector [constOf 0, undef, constOf 2, undef])+               evenY <- LLVM.shufflevector cy (value undef)+                  (constVector [constOf 0, undef, constOf 2, undef])+               evenZ64 <- pmul evenX evenY+               evenZ <- LLVM.bitcastUnify evenZ64+               oddX <- LLVM.shufflevector cx (value undef)+                  (constVector [constOf 1, undef, constOf 3, undef])+               oddY <- LLVM.shufflevector cy (value undef)+                  (constVector [constOf 1, undef, constOf 3, undef])+               oddZ64 <- pmul oddX oddY+               oddZ <- LLVM.bitcastUnify oddZ64+               LLVM.shufflevector evenZ oddZ+                  (constVector [constOf 0, constOf 4, constOf 2, constOf 6]))+            x y)+      `Ext.run`+      (Ext.with X86.pmulld $ \pmul ->+         zipChunksWith pmul x y)+++umul32to64 ::+   (IsPowerOf2 n) =>+   Value (Vector n Word32) ->+   Value (Vector n Word32) ->+   CodeGenFunction r (Value (Vector n Word64))+umul32to64 x y =+   (do x64 <- map LLVM.zext x+       y64 <- map LLVM.zext y+       A.mul x64 y64)+   `Ext.run`+   (Ext.with X86.pmuludq $ \pmul ->+      zipChunksWith+         -- save an initial shuffle+         (\cx cy -> do+            evenX <- LLVM.shufflevector cx (value undef)+               (constVector [constOf 0, undef, constOf 2, undef])+            evenY <- LLVM.shufflevector cy (value undef)+               (constVector [constOf 0, undef, constOf 2, undef])+            evenZ <- pmul evenX evenY+            oddX <- LLVM.shufflevector cx (value undef)+               (constVector [constOf 1, undef, constOf 3, undef])+            oddY <- LLVM.shufflevector cy (value undef)+               (constVector [constOf 1, undef, constOf 3, undef])+            oddZ <- pmul oddX oddY+{-+            LLVM.shufflevector evenZ oddZ+               (constVector [constOf 0, constOf 2, constOf 1, constOf 3])+-}+            assemble =<< (sequence $+               extract (valueOf 0) evenZ :+               extract (valueOf 0) oddZ :+               extract (valueOf 1) evenZ :+               extract (valueOf 1) oddZ :+               []))+{-+         -- save the final shuffle+         (\cx cy -> do+            lowerX <- LLVM.shufflevector cx (value undef)+               (constVector [constOf 0, undef, constOf 1, undef])+            lowerY <- LLVM.shufflevector cy (value undef)+               (constVector [constOf 0, undef, constOf 1, undef])+            lowerZ <- pmul lowerX lowerY+            upperX <- LLVM.shufflevector cx (value undef)+               (constVector [constOf 2, undef, constOf 3, undef])+            upperY <- LLVM.shufflevector cy (value undef)+               (constVector [constOf 2, undef, constOf 3, undef])+            upperZ <- pmul upperX upperY+{-+            LLVM.shufflevector lowerZ upperZ+               (constVector [constOf 0, constOf 1, constOf 2, constOf 3])+-}+            concat [lowerZ, upperZ])+-}+         x y)+++{- |+Attention:+The rounding and fraction functions only work+for floating point values with maximum magnitude of @maxBound :: Int32@.+This way we safe expensive handling of possibly seldom cases.+-}+class (Arithmetic a, LLVM.CmpRet a Bool, IsConst a) =>+         Real a where+   min, max ::+      (IsPowerOf2 n) =>+      Value (Vector n a) ->+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++   abs ::+      (IsPowerOf2 n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++   truncate, floor, fraction ::+      (IsPowerOf2 n) =>+      Value (Vector n a) ->+      CodeGenFunction r (Value (Vector n a))++instance Real Float where+   min = zipAutoWith A.fmin X86.minps+   max = zipAutoWith A.fmax X86.maxps+   abs = mapAuto A.fabs X86.absps+   {-+   An IEEE specific implementation could do some bit manipulation:+   s eeeeeeee mmmmmmmmmmmmmmmmmmmmmmm+   Generate a pure power of two by clearing mantissa:+   s eeeeeeee 00000000000000000000000+   Now subtract 1 in order to get the required bit mask for the mantissa+   s eeeeeeee 11111111110000000000000+   multiply with 2 in order to correct exponent+   and then do bitwise AND of the mask with the original number.+   This method only works for numbers from 1 to 2^23-1,+   that is the range is even more smaller+   than that for the rounding via Int32.+   -}+   truncate x =+      (LLVM.sitofp .+       (id :: Value (Vector n Int32) -> Value (Vector n Int32))+       <=< LLVM.fptosi) x+      `Ext.run`+      (Ext.with X86.roundps $ \round ->+          mapChunks (flip round (valueOf 3)) x)+   floor x =+      floorGeneric x+      `Ext.run`+      (Ext.with X86.cmpps $ \cmp ->+          mapChunks (floorLogical cmp) x)+{- LLVM-2.6 rearranges the MXCSR manipulations in an invalid way+      `Ext.run`+      (Ext.with2 (X86.withMXCSR (Bit.shiftL 1 13)) X86.cvtps2dq $+          \ with cvtps2dq -> with $+             LLVM.sitofp =<< mapChunks cvtps2dq x)+-}+      `Ext.run`+      (Ext.with X86.roundps $ \round ->+          mapChunks (flip round (valueOf 1)) x)+   fraction x =+      fractionGeneric x+      `Ext.run`+      (Ext.with X86.cmpps $ \cmp ->+          mapChunks (fractionLogical cmp) x)+{-+      `Ext.run`+      (Ext.with2 (X86.withMXCSR (Bit.shiftL 1 13)) X86.cvtps2dq $+          \ with cvtps2dq -> with $+             A.sub x =<< LLVM.sitofp =<< mapChunks cvtps2dq x)+-}+      `Ext.run`+      (Ext.with X86.roundps $ \round ->+          mapChunks (\c -> A.sub c =<< flip round (valueOf 1) c) x)++instance Real Double where+   min = zipAutoWith A.fmin X86.minpd+   max = zipAutoWith A.fmax X86.maxpd+   abs = mapAuto A.fabs X86.abspd+   truncate x =+      (LLVM.sitofp .+       (id :: Value (Vector n Int64) -> Value (Vector n Int64))+       <=< LLVM.fptosi) x+      `Ext.run`+      (Ext.with X86.roundpd $ \round ->+          mapChunks (flip round (valueOf 3)) x)+   floor x =+      floorGeneric x+      `Ext.run`+      (Ext.with X86.cmppd $ \cmp ->+          mapChunks (floorLogical cmp) x)+      `Ext.run`+      (Ext.with X86.roundpd $ \round ->+          mapChunks (flip round (valueOf 1)) x)+   fraction x =+      fractionGeneric x+      `Ext.run`+      (Ext.with X86.cmppd $ \cmp ->+          mapChunks (fractionLogical cmp) x)+      `Ext.run`+      (Ext.with X86.roundpd $ \round ->+          mapChunks (\c -> A.sub c =<< flip round (valueOf 1) c) x)++instance Real Int8 where+   min = order A.smin X86.pcmpgtb X86.pminsb+   max = order A.smax (fmap flip X86.pcmpgtb) X86.pmaxsb+   abs = mapAuto A.sabs X86.pabsb+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int16 where+   min = order A.smin X86.pcmpgtw X86.pminsw+   max = order A.smax (fmap flip X86.pcmpgtw) X86.pmaxsw+   abs = mapAuto A.sabs X86.pabsw+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int32 where+   min = order A.smin X86.pcmpgtd X86.pminsd+   max = order A.smax (fmap flip X86.pcmpgtd) X86.pmaxsd+   abs = mapAuto A.sabs X86.pabsd+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Int64 where+   min = zipAutoWith A.smin (orderBy X86.pcmpgtq)+   max = zipAutoWith A.smax (orderBy (fmap flip X86.pcmpgtq))+   abs = mapAuto A.sabs $+      Ext.with (orderBy (fmap flip X86.pcmpgtq)) $+         \smax x -> smax x =<< LLVM.neg x+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word8 where+   min = order A.umin X86.pcmpugtb X86.pminub+   max = order A.umax (fmap flip X86.pcmpugtb) X86.pmaxub+   abs = return+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word16 where+   min = order A.umin X86.pcmpugtw X86.pminuw+   max = order A.umax (fmap flip X86.pcmpugtw) X86.pmaxuw+   abs = return+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word32 where+   min = order A.umin X86.pcmpugtd X86.pminud+   max = order A.umax (fmap flip X86.pcmpugtd) X86.pmaxud+   abs = return+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)++instance Real Word64 where+   min = zipAutoWith A.umin (orderBy X86.pcmpugtq)+   max = zipAutoWith A.umax (orderBy (fmap flip X86.pcmpugtq))+   abs = return+   truncate = return+   floor = return+   fraction = const $ return (value LLVM.zero)
+ x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs view
@@ -0,0 +1,49 @@+module LLVM.Extra.ExtensionCheck.X86 (+   sse1, sse2, sse3, ssse3, sse41, sse42,+   ) where++import qualified LLVM.Extra.Extension as Ext+import Data.Word (Word32, )+import Data.Bits (testBit, )+import System.Cpuid (cpuid, )+import System.IO.Unsafe (unsafePerformIO, )++{-+I expect that the cpuid does not suddenly change+and thus calling unsafePerformIO is safe.+-}+subtarget :: String -> (Word32 -> Word32 -> Bool) -> Ext.Subtarget+subtarget name q =+   Ext.Subtarget "x86" name+      (return $ unsafePerformIO $ check q)++check :: (Word32 -> Word32 -> Bool) -> IO Bool+check q = do+   (high, _, _, _) <- cpuid 0+   let featureId = 1+   if featureId>high+     then return False+     else do+       (_,_,ecx,edx) <- cpuid featureId+       return (q ecx edx)+++-- * target specific extensions++sse1 :: Ext.Subtarget+sse1 = subtarget "sse" (\_ecx edx -> testBit edx 25)++sse2 :: Ext.Subtarget+sse2 = subtarget "sse2" (\_ecx edx -> testBit edx 26)++sse3 :: Ext.Subtarget+sse3 = subtarget "sse3" (\ecx _edx -> testBit ecx 0)++ssse3 :: Ext.Subtarget+ssse3 = subtarget "ssse3" (\ecx _edx -> testBit ecx 9)++sse41 :: Ext.Subtarget+sse41 = subtarget "sse41" (\ecx _edx -> testBit ecx 19)++sse42 :: Ext.Subtarget+sse42 = subtarget "sse42" (\ecx _edx -> testBit ecx 20)
+ x86/none/LLVM/Extra/ExtensionCheck/X86.hs view
@@ -0,0 +1,30 @@+module LLVM.Extra.ExtensionCheck.X86 (+   sse1, sse2, sse3, ssse3, sse41, sse42,+   ) where++import qualified LLVM.Extra.Extension as Ext++subtarget :: String -> Bool -> Ext.Subtarget+subtarget name q =+   Ext.Subtarget "x86" name (return q)+++-- * target specific extensions++sse1 :: Ext.Subtarget+sse1 = subtarget "sse" False++sse2 :: Ext.Subtarget+sse2 = subtarget "sse2" False++sse3 :: Ext.Subtarget+sse3 = subtarget "sse3" False++ssse3 :: Ext.Subtarget+ssse3 = subtarget "ssse3" False++sse41 :: Ext.Subtarget+sse41 = subtarget "sse41" False++sse42 :: Ext.Subtarget+sse42 = subtarget "sse42" False