diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Makefile b/Makefile
new file mode 100644
--- /dev/null
+++ b/Makefile
@@ -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 < $< > $@
diff --git a/Problems.txt b/Problems.txt
new file mode 100644
--- /dev/null
+++ b/Problems.txt
@@ -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.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#! /usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/llvm-extra.cabal b/llvm-extra.cabal
new file mode 100644
--- /dev/null
+++ b/llvm-extra.cabal
@@ -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
diff --git a/src/Array.hs b/src/Array.hs
new file mode 100644
--- /dev/null
+++ b/src/Array.hs
@@ -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
diff --git a/src/LLVM/Extra/Arithmetic.hs b/src/LLVM/Extra/Arithmetic.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Arithmetic.hs
@@ -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"
diff --git a/src/LLVM/Extra/Class.hs b/src/LLVM/Extra/Class.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Class.hs
@@ -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)
+
+
diff --git a/src/LLVM/Extra/Control.hs b/src/LLVM/Extra/Control.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Control.hs
@@ -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
diff --git a/src/LLVM/Extra/Extension.hs b/src/LLVM/Extra/Extension.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Extension.hs
@@ -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
diff --git a/src/LLVM/Extra/Extension/X86.hs b/src/LLVM/Extra/Extension/X86.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Extension/X86.hs
@@ -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
diff --git a/src/LLVM/Extra/MaybeContinuation.hs b/src/LLVM/Extra/MaybeContinuation.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/MaybeContinuation.hs
@@ -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
+-}
diff --git a/src/LLVM/Extra/Monad.hs b/src/LLVM/Extra/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Monad.hs
@@ -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)
diff --git a/src/LLVM/Extra/Representation.hs b/src/LLVM/Extra/Representation.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Representation.hs
@@ -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, ())
diff --git a/src/LLVM/Extra/ScalarOrVector.hs b/src/LLVM/Extra/ScalarOrVector.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/ScalarOrVector.hs
@@ -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
diff --git a/src/LLVM/Extra/Vector.hs b/src/LLVM/Extra/Vector.hs
new file mode 100644
--- /dev/null
+++ b/src/LLVM/Extra/Vector.hs
@@ -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)
diff --git a/x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs b/x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs
new file mode 100644
--- /dev/null
+++ b/x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs
@@ -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)
diff --git a/x86/none/LLVM/Extra/ExtensionCheck/X86.hs b/x86/none/LLVM/Extra/ExtensionCheck/X86.hs
new file mode 100644
--- /dev/null
+++ b/x86/none/LLVM/Extra/ExtensionCheck/X86.hs
@@ -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