packages feed

llvm-extra 0.1 → 0.2

raw patch · 15 files changed

+822/−710 lines, 15 filesdep +llvmdep −llvm-htdep ~cpuid

Dependencies added: llvm

Dependencies removed: llvm-ht

Dependency ranges changed: cpuid

Files

Problems.txt view
@@ -12,6 +12,10 @@ This is a known issue:    http://hackage.haskell.org/trac/ghc/ticket/2615#comment:16 +In GHC-6.12.3 you must also run+   ghc-pkg recache --user+  after removing pthread from ~/.ghc/i386-linux-6.12.3/package.conf.d/llvm-*.conf+ 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.@@ -64,3 +68,24 @@ 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.+++LLVM-2.8++If I remove 'pthread' from Extra-Libraries and add 'LLVM-2.8rc' to Extra-GHCi-Libraries in+  $HOME/.ghc/i386-linux-6.12.3/package.conf.d/llvm-0.9.*-*.conf+ and run+  ghc-pkg recache --user+ I am even able to run 'llvm' example programs from within GHCi!++Sometimes it happends that llvm.buildinfo contains+ld-options: /usr/local/lib/libLLVM-2.8rc.so+and then llvm-0.9.*-*.conf contains this as well.+This leads to a failure of a LLVM runtime assertion:++llvm/examples$ DotProd.exe+Two passes with the same argument (-preverify) attempted to be registered!+UNREACHABLE executed!+Aborted++ld-options field must be empty!
llvm-extra.cabal view
@@ -1,5 +1,5 @@ Name:           llvm-extra-Version:        0.1+Version:        0.2 License:        BSD3 License-File:   LICENSE Author:         Henning Thielemann <haskell@henning-thielemann.de>@@ -18,7 +18,7 @@     in "LLVM.Extra.Arithmetic",   .   * a type class for loading and storing sets of values with one command (macro)-    in "LLVM.Extra.Representation",+    in "LLVM.Extra.Memory",   .   * support instance declarations of LLVM classes     in "LLVM.Extra.Class",@@ -48,8 +48,8 @@   * 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+Tested-With:    GHC==6.10.4, GHC==6.12.3+Cabal-Version:  >=1.6 Build-Type:     Simple Extra-Source-Files:   Makefile@@ -61,11 +61,15 @@   description: Build example executables   default:     False +Source-Repository head+  Type:        darcs+  Location:    http://code.haskell.org/~thielema/llvm-extra/+ 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,+    llvm >=0.9.1.0 && <0.9.1.2,     type-level >=0.2.3 && <0.3,     containers >=0.1 && <0.4,     transformers >=0.1.1 && <0.3,@@ -75,7 +79,7 @@     base >= 3 && <5    If arch(i386)-    Build-Depends: cpuid >=0.2 && <0.3+    Build-Depends: cpuid >=0.2.2 && <0.3     Hs-Source-Dirs: x86/cpuid   Else     -- Instead of calling the cpuid instruction directly@@ -89,7 +93,8 @@   Exposed-Modules:     LLVM.Extra.Arithmetic     LLVM.Extra.Monad-    LLVM.Extra.Representation+    LLVM.Extra.Memory+    LLVM.Extra.ForeignPtr     LLVM.Extra.MaybeContinuation     LLVM.Extra.Class     LLVM.Extra.Control
src/Array.hs view
@@ -4,7 +4,6 @@ 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
src/LLVM/Extra/Arithmetic.hs view
@@ -2,12 +2,10 @@ module LLVM.Extra.Arithmetic (    add, sub, inc, dec,    mul, square, fdiv,-   udiv, urem,-   fcmp, icmp,+   idiv, irem,+   fcmp, cmp,    and, or,-   umin, umax,-   smin, smax, sabs,-   fmin, fmax, fabs,+   min, max, abs,    advanceArrayElementPtr,    sqrt, sin, cos, exp, log, pow,    ) where@@ -15,17 +13,15 @@ import qualified LLVM.Core as LLVM import LLVM.Core    (Ptr, getElementPtr, value, valueOf, Value,-    IntPredicate(IntULE, IntSLE, IntUGE, IntSGE),-    FPPredicate(FPOLE, FPOGE),-    IsIntegerOrPointer,+    CmpPredicate(CmpLE, CmpGE), CmpRet,+    FPPredicate,     IsType, IsConst, IsInteger, IsFloating, IsArithmetic, IsFirstClass,-    CmpRet,     CodeGenFunction, )  import Data.Word (Word32, )  -import Prelude hiding (and, or, sqrt, sin, cos, exp, log, )+import Prelude hiding (and, or, sqrt, sin, cos, exp, log, abs, min, max, )   @@ -69,25 +65,25 @@ fdiv = LLVM.fdiv  fcmp ::-  (IsFloating a, CmpRet a b) =>-  FPPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+   (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+cmp ::+   (CmpRet a b) =>+   CmpPredicate -> Value a -> Value a -> CodeGenFunction r (Value b)+cmp = LLVM.cmp -udiv ::+idiv ::    (IsInteger a) =>    Value a -> Value a -> CodeGenFunction r (Value a)-udiv = LLVM.udiv+idiv = LLVM.idiv -urem ::+irem ::    (IsInteger a) =>    Value a -> Value a -> CodeGenFunction r (Value a)-urem = LLVM.urem+irem = LLVM.irem   and ::@@ -106,42 +102,18 @@ 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) =>+min :: (IsFirstClass a, CmpRet a Bool) =>    Value a -> Value a -> CodeGenFunction r (Value a)-fmin = cmpSelect (fcmp FPOLE)+min = cmpSelect (cmp CmpLE) -fmax :: (IsFloating a, CmpRet a Bool) =>+max :: (IsFirstClass a, CmpRet a Bool) =>    Value a -> Value a -> CodeGenFunction r (Value a)-fmax = cmpSelect (fcmp FPOGE)+max = cmpSelect (cmp CmpGE) -fabs :: (IsFloating a, CmpRet a Bool) =>+abs :: (IsArithmetic a, CmpRet a Bool) =>    Value a -> CodeGenFunction r (Value a)-fabs x = do-   b <- fcmp FPOGE x (value LLVM.zero)+abs x = do+   b <- cmp CmpGE x (value LLVM.zero)    LLVM.select b x =<< LLVM.neg x  @@ -179,18 +151,37 @@    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+   LLVM.call op x >>= addReadNone  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+   LLVM.call op x y >>= addReadNone+++{-+If we add the attribute, then LLVM-2.8 complains:++$ ./dist/build/synthi-llvm-test/synthi-llvm-test+Attribute readnone only applies to the function!+  %97 = call readnone float @llvm.sin.f32(float %96)+Attribute readnone only applies to the function!+  %99 = call readnone float @llvm.exp.f32(float %98)+Attribute readnone only applies to the function!+  %102 = call readnone float @llvm.cos.f32(float %101)+Broken module found, compilation aborted!+Stack dump:+0.      Running pass 'Function Pass Manager' on module '_module'.+1.      Running pass 'Module Verifier' on function '@fillsignal'+make: *** [test] Abgebrochen+-}+addReadNone :: Value a -> CodeGenFunction r (Value a)+addReadNone x = do+--   LLVM.addAttributes x 0 [LLVM.ReadNoneAttribute]+   return x+   sqrt, sin, cos, exp, log ::
src/LLVM/Extra/Class.hs view
@@ -7,21 +7,45 @@  import qualified LLVM.Core as LLVM import LLVM.Core-   (Undefined, undefTuple,-    IsTuple, tupleDesc, TypeDesc,-    MakeValueTuple, valueTupleOf,-    Value,+   (Value, value, valueOf, undef,+    Vector,+    IsConst, IsType, IsFirstClass, IsPrimitive,     CodeGenFunction, BasicBlock, ) import LLVM.Util.Loop (Phi, phis, addPhis, )+import qualified Data.TypeLevel.Num as TypeNum  import Control.Applicative (pure, liftA2, ) import qualified Control.Applicative as App import qualified Data.Foldable as Fold import qualified Data.Traversable as Trav +import Foreign.StablePtr (StablePtr, )+import Foreign.Ptr (Ptr, )++import Data.Word (Word8, Word16, Word32, Word64, )+import Data.Int  (Int8,  Int16,  Int32,  Int64, )+ import Prelude hiding (and, iterate, map, zipWith, writeFile, )  +-- * class for tuples of undefined values++class Undefined a where+   undefTuple :: a++instance Undefined () where+   undefTuple = ()++instance (IsFirstClass a) => Undefined (Value a) where+   undefTuple = value undef++instance (Undefined a, Undefined b) => Undefined (a, b) where+   undefTuple = (undefTuple, undefTuple)++instance (Undefined a, Undefined b, Undefined c) => Undefined (a, b, c) where+   undefTuple = (undefTuple, undefTuple, undefTuple)++ -- * class for tuples of zero values  class Zero a where@@ -46,6 +70,61 @@    pure zeroTuple  +-- * class for creating tuples of constant values++{-+ToDo: flip type parameter order in order to match good style+-}+-- class (IsTuple haskellValue, ValueTuple llvmValue) =>+--      MakeValueTuple haskellValue llvmValue | haskellValue -> llvmValue where+class (Undefined llvmValue) =>+      MakeValueTuple haskellValue llvmValue | haskellValue -> llvmValue where+   valueTupleOf :: haskellValue -> llvmValue++instance (MakeValueTuple ah al, MakeValueTuple bh bl) =>+      MakeValueTuple (ah,bh) (al,bl) where+   valueTupleOf ~(a,b) = (valueTupleOf a, valueTupleOf b)++instance (MakeValueTuple ah al, MakeValueTuple bh bl, MakeValueTuple ch cl) =>+      MakeValueTuple (ah,bh,ch) (al,bl,cl) where+   valueTupleOf ~(a,b,c) = (valueTupleOf a, valueTupleOf b, valueTupleOf c)++instance MakeValueTuple Float        (Value Float)  where valueTupleOf = valueOf+instance MakeValueTuple Double       (Value Double) where valueTupleOf = valueOf+-- instance MakeValueTuple FP128        (Value FP128)  where valueTupleOf = valueOf+instance MakeValueTuple Bool         (Value Bool)   where valueTupleOf = valueOf+instance MakeValueTuple Int8         (Value Int8)   where valueTupleOf = valueOf+instance MakeValueTuple Int16        (Value Int16)  where valueTupleOf = valueOf+instance MakeValueTuple Int32        (Value Int32)  where valueTupleOf = valueOf+instance MakeValueTuple Int64        (Value Int64)  where valueTupleOf = valueOf+instance MakeValueTuple Word8        (Value Word8)  where valueTupleOf = valueOf+instance MakeValueTuple Word16       (Value Word16) where valueTupleOf = valueOf+instance MakeValueTuple Word32       (Value Word32) where valueTupleOf = valueOf+instance MakeValueTuple Word64       (Value Word64) where valueTupleOf = valueOf+instance MakeValueTuple ()           ()             where valueTupleOf = id++{-+I'm not sure about this instance.+Maybe it is better to convert the pointer target type+according to a class that maps Haskell tuples to LLVM structs.+-}+instance IsType a =>+         MakeValueTuple (Ptr a) (Value (Ptr a)) where valueTupleOf = valueOf+instance MakeValueTuple (StablePtr a) (Value (StablePtr a)) where valueTupleOf = valueOf++{-+instance (MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>+         MakeValueTuple (Ptr haskellValue) (Value (Ptr llvmStruct)) where+   valueTupleOf = valueOf . castStorablePtr+instance (Pos n) =>+         MakeValueTuple (IntN n)     (Value (IntN n)) where+instance (Pos n) =>+         MakeValueTuple (WordN n)    (Value (WordN n)) where+-}+instance (TypeNum.Pos n, IsPrimitive a, IsConst a) =>+         MakeValueTuple (Vector n a) (Value (Vector n a)) where valueTupleOf = valueOf++ -- * default methods for LLVM classes  {-@@ -63,12 +142,14 @@ buildTupleTraversable build =    Trav.sequence (pure build) -}+{- this is the version I used 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) =>@@ -82,11 +163,13 @@ valueTupleOfFunctor =    fmap valueTupleOf +{- tupleDescFoldable ::    (IsTuple a, Fold.Foldable f) =>    f a -> [TypeDesc] tupleDescFoldable =    Fold.foldMap tupleDesc+-}  phisTraversable ::    (Phi a, Trav.Traversable f) =>
src/LLVM/Extra/Control.hs view
@@ -10,7 +10,9 @@    arrayLoop,    arrayLoopWithExit,    arrayLoop2WithExit,+   fixedLengthLoop,    whileLoop,+   whileLoopShared,    ifThenElse,    ifThen,    Select(select),@@ -19,14 +21,15 @@    ) where  import LLVM.Extra.Arithmetic-   (icmp, sub, dec, advanceArrayElementPtr, )+   (cmp, sub, dec, advanceArrayElementPtr, )+import qualified LLVM.Extra.Arithmetic as A import qualified LLVM.Core as LLVM import LLVM.Core    (getCurrentBasicBlock, newBasicBlock, defineBasicBlock,     br, condBr,-    Ptr, Value, value,+    Ptr, Value, value, valueOf,     phi, addPhiInputs,-    IntPredicate(IntNE), CmpRet,+    CmpPredicate(CmpGT), CmpRet,     IsInteger, IsType, IsConst, IsFirstClass,     CodeGenFunction,     CodeGenModule, newModule, defineModule, writeBitcodeToFile, )@@ -52,35 +55,12 @@    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+arrayLoop len ptr start loopBody =+   fmap snd $+   fixedLengthLoop len (ptr, start) $ \(p,s) ->+      liftM2 (,)+         (advanceArrayElementPtr p)+         (loopBody p s)   arrayLoopWithExit ::@@ -90,35 +70,16 @@    (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+   ((_, vars), (i,_)) <-+      whileLoopShared ((valueOf True, start), (len, ptr)) $ \((b,v0), (i,p)) ->+         (A.and b =<< cmp CmpGT i (value LLVM.zero),+          do bv1 <- loopBody p v0+             ip1 <-+                ifThen (fst bv1) (i,p) $+                   liftM2 (,)+                      (dec i)+                      (advanceArrayElementPtr p)+             return (bv1,ip1))    pos <- sub len i    return (pos, vars) @@ -145,7 +106,7 @@     {- 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)+   t0 <- cmp CmpGT len (value LLVM.zero)    br checkEnd     defineBasicBlock checkEnd@@ -164,7 +125,7 @@    defineBasicBlock next    p' <- advanceArrayElementPtr p    i' <- dec i-   t' <- icmp IntNE i' (value LLVM.zero)+   t' <- cmp CmpGT i' (value LLVM.zero)     addPhiInputs i [(i', next)]    addPhiInputs p [(p', next)]@@ -185,12 +146,25 @@ 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)))+      (\ptrAi (ptrB0,s0) -> do+         (cont, s1) <- loopBody ptrAi ptrB0 s0+         ptrB1 <- advanceArrayElementPtr ptrB0+         return (cont, (ptrB1,s1)))  +fixedLengthLoop ::+   (Phi s,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i -> s ->+   (s -> CodeGenFunction r s) ->+   CodeGenFunction r s+fixedLengthLoop len start loopBody =+   fmap snd $+   whileLoopShared (len,start) $ \(i,s) ->+      (cmp LLVM.CmpGT i (value LLVM.zero),+       liftM2 (,) (dec i) (loopBody s))++ whileLoop ::    Phi a =>    a ->@@ -217,6 +191,23 @@    defineBasicBlock exit    return state ++{- |+This is a variant of 'whileLoop' that may be more convient,+because you only need one lambda expression+for both loop condition and loop body.+-}+whileLoopShared ::+   Phi a =>+   a ->+   (a ->+      (CodeGenFunction r (Value Bool),+       CodeGenFunction r a)) ->+   CodeGenFunction r a+whileLoopShared start checkBody =+   whileLoop start+      (fst . checkBody)+      (snd . checkBody)  {- | This construct starts new blocks,
src/LLVM/Extra/Extension.hs view
@@ -16,13 +16,12 @@ import qualified LLVM.Core as LLVM import LLVM.Core    (Value, CodeGenFunction, externFunction, call,-    addAttributes, Attribute(ReadNoneAttribute), )+    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, (<*>), ) @@ -106,7 +105,7 @@    (LLVM.IsFunction f, LLVM.CallArgs f g, CallArgs g r) =>    Subtarget -> String -> T g intrinsic =-   intrinsicAttr [ReadNoneAttribute]+   intrinsicAttr [{- ReadNoneAttribute -}]  intrinsicAttr ::    (LLVM.IsFunction f, LLVM.CallArgs f g, CallArgs g r) =>
src/LLVM/Extra/Extension/X86.hs view
@@ -84,7 +84,7 @@ switchFPPred ::    (Num i, LLVM.IsConst i, LLVM.IsInteger i, LLVM.IsPrimitive i,     LLVM.IsFirstClass v,-    LLVM.IsPowerOf2 n,+    TypeNum.Pos 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))@@ -135,7 +135,7 @@   pcmpuFromPcmp ::-   (LLVM.IsPowerOf2 n,+   (TypeNum.Pos n,     LLVM.IsPrimitive s,     LLVM.IsPrimitive u, LLVM.IsArithmetic u, LLVM.IsConst u,     Bounded u, Integral u,@@ -227,16 +227,22 @@ cvtpd2dq :: Ext.T (VDouble -> CodeGenFunction r (Value (Vector D4 Int32))) cvtpd2dq = Ext.intrinsic sse2 "cvtpd2dq" ++valueUnit :: Value () -> ()+valueUnit _ = ()+ {- | 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"+ldmxcsr :: Ext.T (Value (Ptr Word32) -> CodeGenFunction r ())+ldmxcsr =+   fmap (fmap valueUnit .) $ Ext.intrinsicAttr [] sse1 "ldmxcsr" -stmxcsr :: Ext.T (Value (Ptr Word32) -> CodeGenFunction r (Value ()))-stmxcsr = Ext.intrinsicAttr [] sse1 "stmxcsr"+stmxcsr :: Ext.T (Value (Ptr Word32) -> CodeGenFunction r ())+stmxcsr =+   fmap (fmap valueUnit .) $ Ext.intrinsicAttr [] sse1 "stmxcsr"  withMXCSR :: Word32 -> Ext.T (CodeGenFunction r a -> CodeGenFunction r a) withMXCSR mxcsr =
+ src/LLVM/Extra/ForeignPtr.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module LLVM.Extra.ForeignPtr (+   newInit, newParam,+   new, with,+   ) where++import qualified LLVM.Extra.Memory as Memory+import LLVM.Extra.Class (MakeValueTuple, )++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, FunPtr, )+++type Importer f = FunPtr f -> f++foreign import ccall safe "dynamic" derefStartPtr ::+   Importer (IO (Ptr a))++newInit ::+   FunPtr (Ptr a -> IO ()) ->+   FunPtr (IO (Ptr a)) ->+   IO (FPtr.ForeignPtr a)+newInit 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.+-}+newParam ::+   (Storable b, MakeValueTuple b bl, Memory.C bl bp) =>+   FunPtr (Ptr a -> IO ()) ->+   FunPtr (Ptr bp -> IO (Ptr a)) ->+   b -> IO (FPtr.ForeignPtr a)+newParam stop start b =+   FPtr.newForeignPtr stop =<<+   Marshal.with b (derefStartParamPtr start . Memory.castStorablePtr)++{-+requires (Storable ap) constraint+and we have no Storable instance for Struct++new ::+   (Storable a, MakeValueTuple a al, Memory.C al ap) =>+   a -> IO (FPtr.ForeignPtr ap)+new 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.+-}+new ::+   Storable a =>+   IO () ->+   a -> IO (FPtr.ForeignPtr a)+new finalizer a = do+   ptr <- FPtr.mallocForeignPtr+   FC.addForeignPtrFinalizer ptr finalizer+   FPtr.withForeignPtr ptr (flip poke a)+   return ptr++with ::+   (Storable a, MakeValueTuple a al, Memory.C al ap) =>+   FPtr.ForeignPtr a -> (Ptr ap -> IO b) -> IO b+with fp func =+   FPtr.withForeignPtr fp (func . Memory.castStorablePtr)
src/LLVM/Extra/MaybeContinuation.hs view
@@ -7,9 +7,10 @@ -} module LLVM.Extra.MaybeContinuation where -import qualified LLVM.Extra.Control as U+import qualified LLVM.Extra.Control as C import LLVM.Extra.Control (ifThenElse, ) +import LLVM.Extra.Class (Undefined, undefTuple, ) import qualified LLVM.Extra.Arithmetic as A import LLVM.Core as LLVM import LLVM.Util.Loop (Phi, ) -- (phis, addPhis, )@@ -20,7 +21,7 @@ import Control.Monad.HT ((<=<), ) import Data.Tuple.HT (mapSnd, ) -import Prelude hiding (fmap, and, iterate, map, zip, zipWith, writeFile, )+import Prelude hiding (and, iterate, map, zip, zipWith, writeFile, ) import qualified Prelude as P  @@ -67,7 +68,7 @@  fromBool ::    (Phi z) =>-   CodeGenFunction r (Value Bool, a) -> +   CodeGenFunction r (Value Bool, a) ->    T r z a fromBool m = do    (b,a) <- lift m@@ -80,6 +81,11 @@ toBool (Cons m) =    m (return (valueOf False, undefTuple)) (return . (,) (valueOf True)) +isJust ::+   T r (Value Bool) a -> CodeGenFunction r (Value Bool)+isJust (Cons m) =+   m (return (valueOf False)) (const $ return (valueOf True))+ lift :: CodeGenFunction r a -> T r z a lift a = Cons $ \ _n j -> j =<< a @@ -109,53 +115,18 @@ then returned final state is undefined. -} arrayLoop ::-   (Phi s, IsType a,+   (Phi s, Undefined 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 ->+   C.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,+   (Phi s, Undefined 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 ->@@ -163,12 +134,58 @@       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)+   fmap (mapSnd snd) $+   arrayLoop len ptrA (ptrB,start) $ \ptrAi (ptrB0,s0) -> do+      s1 <- loopBody ptrAi ptrB0 s0+      ptrB1 <- lift $ A.advanceArrayElementPtr ptrB0+      return (ptrB1,s1) ++fixedLengthLoop ::+   (Phi s, Undefined s,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+   Value i -> s ->+   (s -> T r (Value Bool, (Value i, s)) s) ->+   CodeGenFunction r (Value i, s)+fixedLengthLoop len start loopBody = do+   (_,(lastI,lastS)) <-+      C.whileLoopShared (valueOf True, (len, start)) $ \(cont,(i,s)) ->+         (A.and cont =<< A.cmp LLVM.CmpGT i (value LLVM.zero),+          resolve (loopBody s)+             (return (valueOf False, undefTuple))+             (\newS -> do+                newI <- A.dec i+                return (valueOf True, (newI, newS))))+   fmap (flip (,) lastS) $ A.sub len lastI++ {--a specialised variant of whileLoop might also be useful+In case of early exit we would not have a final state.+However, the loop could be in the T monad+and we could just propagate a Nothing.++whileLoop ::+   Phi a =>+   a ->+   (a -> T r z a) ->+   CodeGenFunction r a+whileLoop start check body = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   cont <- newBasicBlock+   exit <- newBasicBlock+   br loop++   defineBasicBlock loop+   state <- 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 -}
+ src/LLVM/Extra/Memory.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module LLVM.Extra.Memory (+   C(load, store, decompose, compose), modify, castStorablePtr,+   Record, Element, element,+   loadRecord, storeRecord, decomposeRecord, composeRecord,+   loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,+   ) where++import LLVM.Extra.Class (MakeValueTuple, Undefined, )++import qualified LLVM.Core as LLVM+import LLVM.Core+   (Struct, getElementPtr0,+    extractvalue, insertvalue,+    Value, -- valueOf, Vector,+    IsType, IsSized,+    CodeGenFunction, )+import LLVM.Util.Loop (Phi, )++-- import qualified Data.TypeLevel.Num as TypeNum+import Data.TypeLevel.Num (d0, d1, d2, )++import Foreign.Ptr (Ptr, castPtr, )++import Control.Monad (ap, )+import Control.Applicative (pure, liftA2, liftA3, )+import qualified Control.Applicative as App++import Data.Tuple.HT (fst3, snd3, thd3, )+++{- |+An implementation of both 'MakeValueTuple' and 'Memory.C'+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.+ToDo: In future we may also require Storable constraint for llvmStruct.++We use a functional dependency in order to let type inference work nicely.+-}+class (Phi llvmValue, Undefined llvmValue, IsType llvmStruct) =>+      C 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 ()+   store r ptr  =  flip LLVM.store ptr =<< compose r+   decompose :: Value llvmStruct -> CodeGenFunction r llvmValue+   compose :: llvmValue -> CodeGenFunction r (Value llvmStruct)++modify ::+   (C llvmValue llvmStruct) =>+   (llvmValue -> CodeGenFunction r llvmValue) ->+   Value (Ptr llvmStruct) -> CodeGenFunction r ()+modify f ptr =+   flip store ptr =<< f =<< load ptr+++type Record r o v = Element r o v v++data Element r o v x =+   Element {+      loadElement :: Value (Ptr o) -> CodeGenFunction r x,+      storeElement :: Value (Ptr o) -> v -> CodeGenFunction r (),+      extractElement :: Value o -> CodeGenFunction r x,+      insertElement :: v -> Value o -> CodeGenFunction r (Value o)+         -- State.Monoid+   }++element ::+   (C x llvmStruct,+    LLVM.GetValue o n llvmStruct,+    LLVM.GetElementPtr o (n, ()) llvmStruct) =>+   (v -> x) -> n -> Element r o v x+element field n =+   Element {+      loadElement = \ptr -> load =<< getElementPtr0 ptr (n, ()),+      storeElement = \ptr v -> store (field v) =<< getElementPtr0 ptr (n, ()),+      extractElement = \o -> decompose =<< extractvalue o n,+      insertElement = \v o -> flip (insertvalue o) n =<< compose (field v)+   }++instance Functor (Element r o v) where+   fmap f m =+      Element {+         loadElement = fmap f . loadElement m,+         storeElement = storeElement m,+         extractElement = fmap f . extractElement m,+         insertElement = insertElement m+      }++instance App.Applicative (Element r o v) where+   pure x =+      Element {+         loadElement = \ _ptr -> return x,+         storeElement = \ _ptr _v -> return (),+         extractElement = \ _o -> return x,+         insertElement = \ _v o -> return o+      }+   f <*> x =+      Element {+         loadElement = \ptr -> loadElement f ptr `ap` loadElement x ptr,+         storeElement = \ptr y -> storeElement f ptr y >> storeElement x ptr y,+         extractElement = \o -> extractElement f o `ap` extractElement x o,+         insertElement = \y o -> insertElement f y o >>= insertElement x y+      }+++loadRecord ::+   Record r o llvmValue ->+   Value (Ptr o) -> CodeGenFunction r llvmValue+loadRecord = loadElement++storeRecord ::+   Record r o llvmValue ->+   llvmValue -> Value (Ptr o) -> CodeGenFunction r ()+storeRecord m y ptr = storeElement m ptr y++decomposeRecord ::+   Record r o llvmValue ->+   Value o -> CodeGenFunction r llvmValue+decomposeRecord m =+   extractElement m++composeRecord ::+   (IsType o) =>+   Record r o llvmValue ->+   llvmValue -> CodeGenFunction r (Value o)+composeRecord m v =+   insertElement m v (LLVM.value LLVM.undef)++++pair ::+   (C al as, C bl bs,+    IsSized as sas, IsSized bs sbs) =>+   Record r (Struct (as, (bs, ()))) (al, bl)+pair =+   liftA2 (,)+      (element fst d0)+      (element snd d1)++instance+      (C al as, C bl bs,+       IsSized as sas, IsSized bs sbs) =>+      C (al, bl) (Struct (as, (bs, ()))) where+   load = loadRecord pair+   store = storeRecord pair+   decompose = decomposeRecord pair+   compose = composeRecord pair+++triple ::+   (C al as, C bl bs, C cl cs,+    IsSized as sas, IsSized bs sbs, IsSized cs scs) =>+   Record r (Struct (as, (bs, (cs, ())))) (al, bl, cl)+triple =+   liftA3 (,,)+      (element fst3 d0)+      (element snd3 d1)+      (element thd3 d2)++instance+      (C al as, C bl bs, C cl cs,+       IsSized as sas, IsSized bs sbs, IsSized cs scs) =>+      C (al, bl, cl) (Struct (as, (bs, (cs, ())))) where+   load = loadRecord triple+   store = storeRecord triple+   decompose = decomposeRecord triple+   compose = composeRecord triple+++{- |+ToDo:+This is dangerous because LLVM uses one bit for Bool representation,+and I think one byte in memory,+whereas Storable uses 4 byte and 4 byte alignment.+We should define a sub-class of IsFirstClass for all compatible types,+and make this a super-class of this instance.+-}+instance (LLVM.IsFirstClass a) => C (Value a) a where+   load = LLVM.load+   store = LLVM.store+   decompose = return+   compose = return++instance C () (Struct ()) where+   load _ = return ()+   store _ _ = return ()+   decompose _ = return ()+   compose _ = return (LLVM.value LLVM.undef)++castStorablePtr ::+   (MakeValueTuple haskellValue llvmValue, C llvmValue llvmStruct) =>+   Ptr haskellValue -> Ptr llvmStruct+castStorablePtr = castPtr++++loadNewtype ::+   (C a o) =>+   (a -> llvmValue) ->+   Value (Ptr o) -> CodeGenFunction r llvmValue+loadNewtype wrap ptr =+   fmap wrap $ load ptr++storeNewtype ::+   (C a o) =>+   (llvmValue -> a) ->+   llvmValue -> Value (Ptr o) -> CodeGenFunction r ()+storeNewtype unwrap y ptr =+   store (unwrap y) ptr++decomposeNewtype ::+   (C a o) =>+   (a -> llvmValue) ->+   Value o -> CodeGenFunction r llvmValue+decomposeNewtype wrap y =+   fmap wrap $ decompose y++composeNewtype ::+   (C a o) =>+   (llvmValue -> a) ->+   llvmValue -> CodeGenFunction r (Value o)+composeNewtype unwrap y =+   compose (unwrap y)
− src/LLVM/Extra/Representation.hs 
@@ -1,376 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module LLVM.Extra.Representation (-   Memory(load, store, decompose, compose), modify, castStorablePtr,-   MemoryRecord, MemoryElement, memoryElement,-   loadRecord, storeRecord, decomposeRecord, composeRecord,-   loadNewtype, storeNewtype, decomposeNewtype, composeNewtype,--   newForeignPtrInit, newForeignPtrParam,-   newForeignPtr, withForeignPtr,-   malloc, free,-   ) where--import qualified LLVM.Core as LLVM-import LLVM.Core-   (MakeValueTuple,-    Struct, getElementPtr0,-    extractvalue, insertvalue,-    Value, valueOf, Vector,-    IsType, IsSized,-    CodeGenFunction, )-import LLVM.Util.Loop (Phi, )--import qualified Foreign.Marshal.Utils as Marshal-import qualified Foreign.ForeignPtr as FPtr-import qualified Foreign.Concurrent as FC-import Foreign.Storable (Storable, poke, )-import Foreign.Ptr (Ptr, castPtr, FunPtr, )-import Data.TypeLevel.Num (d0, d1, d2, D4, )-import Data.Word (Word32, Word64, )--- import Data.Word (Word8, Word16, Word32, Word64, )--- import Data.Int  (Int8,  Int16,  Int32,  Int64, )--import Control.Monad (ap, )-import Control.Applicative (pure, liftA2, liftA3, )-import qualified Control.Applicative as App--import Data.Tuple.HT (fst3, snd3, thd3, )----- * Memory class and helper functions--{- |-An implementation of both 'MakeValueTuple' and 'Memory'-must ensure that @haskellValue@ is compatible with @llvmStruct@.-That is, writing and reading @llvmStruct@ by LLVM-must be the same as accessing @haskellValue@ by 'Storable' methods.--We use a functional dependency in order to let type inference work nicely.--}-class (Phi llvmValue, IsType llvmStruct) =>-      Memory llvmValue llvmStruct | llvmValue -> llvmStruct where-   load :: Value (Ptr llvmStruct) -> CodeGenFunction r llvmValue-   load ptr  =  decompose =<< LLVM.load ptr-   store :: llvmValue -> Value (Ptr llvmStruct) -> CodeGenFunction r (Value ())-   store r ptr  =  flip LLVM.store ptr =<< compose r-   decompose :: Value llvmStruct -> CodeGenFunction r llvmValue-   compose :: llvmValue -> CodeGenFunction r (Value llvmStruct)--modify ::-   (Memory llvmValue llvmStruct) =>-   (llvmValue -> CodeGenFunction r llvmValue) ->-   Value (Ptr llvmStruct) -> CodeGenFunction r (Value ())-modify f ptr =-   flip store ptr =<< f =<< load ptr---type MemoryRecord r o v = MemoryElement r o v v--data MemoryElement r o v x =-   MemoryElement {-      loadElement :: Value (Ptr o) -> CodeGenFunction r x,-      storeElement :: Value (Ptr o) -> v -> CodeGenFunction r (Value ()),-      extractElement :: Value o -> CodeGenFunction r x,-      insertElement :: v -> Value o -> CodeGenFunction r (Value o)-         -- State.Monoid-   }--memoryElement ::-   (Memory x llvmStruct,-    LLVM.GetValue o n llvmStruct,-    LLVM.GetElementPtr o (n, ()) llvmStruct) =>-   (v -> x) -> n -> MemoryElement r o v x-memoryElement field n =-   MemoryElement {-      loadElement = \ptr -> load =<< getElementPtr0 ptr (n, ()),-      storeElement = \ptr v -> store (field v) =<< getElementPtr0 ptr (n, ()),-      extractElement = \o -> decompose =<< extractvalue o n,-      insertElement = \v o -> flip (insertvalue o) n =<< compose (field v)-   }--instance Functor (MemoryElement r o v) where-   fmap f m =-      MemoryElement {-         loadElement = fmap f . loadElement m,-         storeElement = storeElement m,-         extractElement = fmap f . extractElement m,-         insertElement = insertElement m-      }--instance App.Applicative (MemoryElement r o v) where-   pure x =-      MemoryElement {-         loadElement = \ _ptr -> return x,-         storeElement = \ _ptr _v ->-            return (error "MemoryElement: undefined value" :: Value ()),-         extractElement = \ _o -> return x,-         insertElement = \ _v o -> return o-      }-   f <*> x =-      MemoryElement {-         loadElement = \ptr -> loadElement f ptr `ap` loadElement x ptr,-         storeElement = \ptr y -> storeElement f ptr y >> storeElement x ptr y,-         extractElement = \o -> extractElement f o `ap` extractElement x o,-         insertElement = \y o -> insertElement f y o >>= insertElement x y-      }---loadRecord ::-   MemoryRecord r o llvmValue ->-   Value (Ptr o) -> CodeGenFunction r llvmValue-loadRecord = loadElement--storeRecord ::-   MemoryRecord r o llvmValue ->-   llvmValue -> Value (Ptr o) -> CodeGenFunction r (Value ())-storeRecord m y ptr = storeElement m ptr y--decomposeRecord ::-   MemoryRecord r o llvmValue ->-   Value o -> CodeGenFunction r llvmValue-decomposeRecord m =-   extractElement m--composeRecord ::-   (IsType o) =>-   MemoryRecord r o llvmValue ->-   llvmValue -> CodeGenFunction r (Value o)-composeRecord m v =-   insertElement m v (LLVM.value LLVM.undef)----pairMemory ::-   (Memory al as, Memory bl bs,-    IsSized as sas, IsSized bs sbs) =>-   MemoryRecord r (Struct (as, (bs, ()))) (al, bl)-pairMemory =-   liftA2 (,)-      (memoryElement fst d0)-      (memoryElement snd d1)--instance-      (Memory al as, Memory bl bs,-       IsSized as sas, IsSized bs sbs) =>-      Memory (al, bl) (Struct (as, (bs, ()))) where-   load = loadRecord pairMemory-   store = storeRecord pairMemory-   decompose = decomposeRecord pairMemory-   compose = composeRecord pairMemory---tripleMemory ::-   (Memory al as, Memory bl bs, Memory cl cs,-    IsSized as sas, IsSized bs sbs, IsSized cs scs) =>-   MemoryRecord r (Struct (as, (bs, (cs, ())))) (al, bl, cl)-tripleMemory =-   liftA3 (,,)-      (memoryElement fst3 d0)-      (memoryElement snd3 d1)-      (memoryElement thd3 d2)--instance-      (Memory al as, Memory bl bs, Memory cl cs,-       IsSized as sas, IsSized bs sbs, IsSized cs scs) =>-      Memory (al, bl, cl) (Struct (as, (bs, (cs, ())))) where-   load = loadRecord tripleMemory-   store = storeRecord tripleMemory-   decompose = decomposeRecord tripleMemory-   compose = composeRecord tripleMemory---instance (LLVM.IsFirstClass a) => Memory (Value a) a where-   load = LLVM.load-   store = LLVM.store-   decompose = return-   compose = return--instance Memory () (Struct ()) where-   load _ = return ()-   store _ _ = return (error "().store: no result" :: Value ())-   decompose _ = return ()-   compose _ = return (LLVM.value LLVM.undef)--castStorablePtr ::-   (MakeValueTuple haskellValue llvmValue, Memory llvmValue llvmStruct) =>-   Ptr haskellValue -> Ptr llvmStruct-castStorablePtr = castPtr----loadNewtype ::-   (Memory a o) =>-   (a -> llvmValue) ->-   Value (Ptr o) -> CodeGenFunction r llvmValue-loadNewtype wrap ptr =-   fmap wrap $ load ptr--storeNewtype ::-   (Memory a o) =>-   (llvmValue -> a) ->-   llvmValue -> Value (Ptr o) -> CodeGenFunction r (Value ())-storeNewtype unwrap y ptr =-   store (unwrap y) ptr--decomposeNewtype ::-   (Memory a o) =>-   (a -> llvmValue) ->-   Value o -> CodeGenFunction r llvmValue-decomposeNewtype wrap y =-   fmap wrap $ decompose y--composeNewtype ::-   (Memory a o) =>-   (llvmValue -> a) ->-   llvmValue -> CodeGenFunction r (Value o)-composeNewtype unwrap y =-   compose (unwrap y)------- * ForeignPtr support--type Importer f = FunPtr f -> f--foreign import ccall safe "dynamic" derefStartPtr ::-   Importer (IO (Ptr a))--newForeignPtrInit ::-   FunPtr (Ptr a -> IO ()) ->-   FunPtr (IO (Ptr a)) ->-   IO (FPtr.ForeignPtr a)-newForeignPtrInit stop start =-   FPtr.newForeignPtr stop =<< derefStartPtr start---foreign import ccall safe "dynamic" derefStartParamPtr ::-   Importer (Ptr b -> IO (Ptr a))--{--We cannot use 'bracket' when constructing lazy StorableVector,-since this would mean that the temporary memory is freed immediately.-Instead we must add a Finalizer to the ForeignPtr.--}-newForeignPtrParam ::-   (Storable b, MakeValueTuple b bl, Memory bl bp) =>-   FunPtr (Ptr a -> IO ()) ->-   FunPtr (Ptr bp -> IO (Ptr a)) ->-   b -> IO (FPtr.ForeignPtr a)-newForeignPtrParam stop start b =-   FPtr.newForeignPtr stop =<<-   Marshal.with b (derefStartParamPtr start . castStorablePtr)--{--requires (Storable ap) constraint-and we have no Storable instance for Struct--newForeignPtr ::-   (Storable a, MakeValueTuple a al, Memory al ap) =>-   a -> IO (FPtr.ForeignPtr ap)-newForeignPtr a = do-   ptr <- FPtr.mallocForeignPtr-   FPtr.withForeignPtr ptr (flip poke a . castPtr)-   return ptr--}--{- |-Adding the finalizer to a ForeignPtr seems to be the only way-that warrants execution of the finalizer (not too early and not never).-However, the normal ForeignPtr finalizers must be independent from Haskell runtime.-In contrast to ForeignPtr finalizers,-addFinalizer adds finalizers to boxes, that are optimized away.-Thus finalizers are run too early or not at all.-Concurrent.ForeignPtr and using threaded execution-is the only way to get finalizers in Haskell IO.--}-newForeignPtr ::-   Storable a =>-   IO () ->-   a -> IO (FPtr.ForeignPtr a)-newForeignPtr finalizer a = do-   ptr <- FPtr.mallocForeignPtr-   FC.addForeignPtrFinalizer ptr finalizer-   FPtr.withForeignPtr ptr (flip poke a)-   return ptr--withForeignPtr ::-   (Storable a, MakeValueTuple a al, Memory al ap) =>-   FPtr.ForeignPtr a -> (Ptr ap -> IO b) -> IO b-withForeignPtr fp func =-   FPtr.withForeignPtr fp (func . castStorablePtr)---{--malloc :: (IsSized a s) => CodeGenFunction r (Value (Ptr a))-malloc = LLVM.malloc--free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())-free = LLVM.free--}---type Aligned a = Struct (a, (Ptr (Vector D4 Float), ()))-type AlignedPtr a = Ptr (Aligned a)--{- |-Returns 16 Byte aligned piece of memory.-Otherwise program crashes when vectors are part of the structure.-I think that malloc in LLVM-2.5 and LLVM-2.6 is simply buggy.--FIXME:-Aligning to 16 Byte might not be appropriate for all vector types on all platforms.-Maybe we should use alignment of Storable class-in order to determine the right alignment.--}-malloc :: (IsSized a s) => CodeGenFunction r (Value (Ptr a))-malloc =-   let m :: (IsSized a s) =>-            CodeGenFunction r (Value (Ptr (Struct (Vector D4 Float, (Aligned a, ())))))-       m = LLVM.malloc-   in  do p <- m-          -- skip pad-          p1 <- getElementPtr0 p (d1, ())-          p1int <- LLVM.ptrtoint p1-          -- go back to the last 16 byte aligned address-          p16int <- LLVM.and (valueOf (-16) :: Value Word64) (p1int :: Value Word64)-          p16 <- LLVM.inttoptr p16int-          {--          v has same address as p but different type.-          This way we avoid a recursive datatype but we avoid also a cast.-          -}-          v <- getElementPtr0 p (d0, ())-          store v =<< getElementPtr0 (p16 `asTypeOf` p1) (d1, ())-          getElementPtr0 p16 (d0, ())--{--This is correct but will be optimized incorrectly.-The "optimized" code will access a pointer-that is 4 cells greater than the right pointer-for certain sizes of the record @a@.--free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())-free p =-   LLVM.free =<<-   load =<<-   flip getElementPtr0 (d1, ()) =<<-   (LLVM.bitcastUnify ::-      (IsSized a sa) =>-      Value (Ptr a) ->-      CodeGenFunction r (Value (AlignedPtr a))) p--}--free :: (IsSized a s) => Value (Ptr a) -> CodeGenFunction r (Value ())-free p =-   LLVM.free =<<-   load =<<-   (LLVM.bitcastUnify ::-      (IsSized a sa) =>-      Value (Ptr a) ->-      CodeGenFunction r (Value (Ptr (AlignedPtr a)))) =<<-   LLVM.getElementPtr p (1 :: Word32, ())
src/LLVM/Extra/ScalarOrVector.hs view
@@ -8,7 +8,7 @@ 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.+This way we save expensive handling of possibly seldom cases. -} module LLVM.Extra.ScalarOrVector (    Fraction (truncate, fraction),@@ -24,16 +24,17 @@ import qualified LLVM.Extra.Extension.X86 as X86 import qualified LLVM.Extra.Extension as Ext +import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Arithmetic as A +import qualified Data.TypeLevel.Num as TypeNum 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, )+    Vector, FP128,+    IsConst, IsFloating,+    CodeGenFunction, )  import Control.Monad.HT ((<=<), ) @@ -71,12 +72,12 @@    fptosi = LLVM.fptosi    sitofp = LLVM.sitofp -instance (LLVM.IsPowerOf2 n) =>+instance (TypeNum.Pos n) =>       Fraction (Vector n Int32) (Vector n Float) where    fptosi = LLVM.fptosi    sitofp = LLVM.sitofp -instance (LLVM.IsPowerOf2 n) =>+instance (TypeNum.Pos n) =>       Fraction (Vector n Int64) (Vector n Double) where    fptosi = LLVM.fptosi    sitofp = LLVM.sitofp@@ -125,7 +126,7 @@       (Ext.with X86.roundsd $ \round x ->          A.sub x =<< round x (valueOf 1)) -instance (LLVM.IsPowerOf2 n, Vector.Real a, IsFloating a, IsConst a) =>+instance (TypeNum.Pos n, Vector.Real a, IsFloating a, IsConst a) =>       Fraction (Vector n a) where    truncate = Vector.truncate    fraction = Vector.fraction@@ -197,10 +198,10 @@ 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+instance (TypeNum.Pos 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)+      v <- singleton x       LLVM.shufflevector v (LLVM.value LLVM.undef) LLVM.zero {- crashes LLVM-2.5    replicate x = do@@ -216,6 +217,12 @@ -}    replicateConst x = LLVM.constVector [x]; +singleton ::+   (LLVM.IsPrimitive a) =>+   Value a -> CodeGenFunction r (Value (Vector D1 a))+singleton x =+   LLVM.insertelement (LLVM.value LLVM.undef) x (valueOf 0)+ replicateOf ::    (IsConst a, Replicate a v) =>    a -> Value v@@ -230,16 +237,16 @@   instance Real Float  where-   min = zipAutoWith A.fmin X86.minss-   max = zipAutoWith A.fmax X86.maxss-   abs = mapAuto     A.fabs X86.absss+   min = zipAutoWith A.min X86.minss+   max = zipAutoWith A.max X86.maxss+   abs = mapAuto     A.abs X86.absss    -- abs x = max x =<< LLVM.neg x-   -- abs x = A.fabs+   -- abs x = A.abs  instance Real Double where-   min = zipAutoWith A.fmin X86.minsd-   max = zipAutoWith A.fmax X86.maxsd-   abs = mapAuto     A.fabs X86.abssd+   min = zipAutoWith A.min X86.minsd+   max = zipAutoWith A.max X86.maxsd+   abs = mapAuto     A.abs X86.abssd   infixl 1 `mapAuto`@@ -257,7 +264,7 @@ runScalar op a =    Vector.extract (valueOf 0)      =<< op-     =<< Vector.insert (valueOf 0) a LLVM.undefTuple+     =<< Vector.insert (valueOf 0) a Class.undefTuple  mapAuto ::    (Vector.Access n a va, Vector.Access n b vb) =>@@ -277,17 +284,17 @@    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 Real FP128  where min = A.min; max = A.max; abs = A.abs;+instance Real Int8   where min = A.min; max = A.max; abs = A.abs;+instance Real Int16  where min = A.min; max = A.max; abs = A.abs;+instance Real Int32  where min = A.min; max = A.max; abs = A.abs;+instance Real Int64  where min = A.min; max = A.max; abs = A.abs;+instance Real Word8  where min = A.min; max = A.max; abs = return;+instance Real Word16 where min = A.min; max = A.max; abs = return;+instance Real Word32 where min = A.min; max = A.max; abs = return;+instance Real Word64 where min = A.min; max = A.max; abs = return; -instance (LLVM.IsPowerOf2 n, Vector.Real a) =>+instance (TypeNum.Pos n, Vector.Real a) =>          Real (Vector n a) where    min = Vector.min    max = Vector.max
src/LLVM/Extra/Vector.hs view
@@ -13,10 +13,14 @@    shiftUpMultiZero, shiftDownMultiZero,    ShuffleMatch (shuffleMatch),    shuffleMatchTraversable,+   shuffleMatchAccess,+   shuffleMatchPlain1,+   shuffleMatchPlain2,     Access (insert, extract),    insertTraversable,    extractTraversable,+   extractAll,     insertChunk, modify,    map, mapChunks, zipChunksWith,@@ -34,6 +38,7 @@ import qualified LLVM.Extra.Extension.X86 as X86 import qualified LLVM.Extra.Extension as Ext +import qualified LLVM.Extra.Class as Class import qualified LLVM.Extra.Monad as M import qualified LLVM.Extra.Arithmetic as A @@ -41,9 +46,9 @@ import LLVM.Util.Loop (Phi, ) import LLVM.Core    (Value, ConstValue, valueOf, value, constOf, undef,-    Vector, shufflevector, insertelement, extractelement, constVector,+    Vector, insertelement, extractelement, constVector,     IsConst, IsArithmetic, IsFloating,-    IsPrimitive, IsPowerOf2,+    IsPrimitive,     CodeGenFunction, )  import Data.TypeLevel.Num (D2, )@@ -70,10 +75,10 @@ -- * target independent functions  size ::-   (TypeNum.Nat n) =>+   (TypeNum.Pos n) =>    Value (Vector n a) -> Int size =-   let sz :: (TypeNum.Nat n) => n -> Value (Vector n a) -> Int+   let sz :: (TypeNum.Pos n) => n -> Value (Vector n a) -> Int        sz n _ = TypeNum.toInt n    in  sz undefined @@ -96,15 +101,17 @@ construct a vector out of single elements  You must assert that the length of the list matches the vector size.++This can be considered the inverse of 'extractAll'. -} assemble ::    (Access n a va) =>    [a] -> CodeGenFunction r va assemble =-   foldM (\v (k,x) -> insert (valueOf k) x v) LLVM.undefTuple .+   foldM (\v (k,x) -> insert (valueOf k) x v) Class.undefTuple .    List.zip [0..] {- sends GHC into an infinite loop-   foldM (\(k,x) -> insert (valueOf k) x) LLVM.undefTuple .+   foldM (\(k,x) -> insert (valueOf k) x) Class.undefTuple .    List.zip [0..] -} @@ -127,7 +134,7 @@    a -> CodeGenFunction r va iterate f x =    fmap snd $-   iterateCore f x LLVM.undefTuple+   iterateCore f x Class.undefTuple  iterateCore ::    (Access n a va) =>@@ -147,6 +154,7 @@ In contrast to LLVM's built-in instruction it supports distinct vector sizes, but it allows only one input vector (or a tuple of vectors, but we cannot shuffle between them).+For more complex shuffling we recommend 'extractAll' and 'assemble'. -} shuffle ::    (Access m a ca, Access n a va) =>@@ -226,28 +234,28 @@       (insert (LLVM.valueOf (fromIntegral (sizeInTuple x) - 1)) x0 y)  shiftUpMultiZero ::-   (IsPrimitive a, IsPowerOf2 n) =>+   (IsPrimitive a, TypeNum.Pos n) =>    Int ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) shiftUpMultiZero k x =-   LLVM.shufflevector (LLVM.value LLVM.zero) x+   shuffleMatchPlain2 (LLVM.value LLVM.zero) x       (constVector $ List.map constOf $        take k [0..] ++ [(fromIntegral (sizeInTuple x)) ..])  shiftDownMultiZero ::-   (IsPrimitive a, IsPowerOf2 n) =>+   (IsPrimitive a, TypeNum.Pos n) =>    Int ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) shiftDownMultiZero k x =-   LLVM.shufflevector x (LLVM.value LLVM.zero)+   shuffleMatchPlain2 x (LLVM.value LLVM.zero)       (constVector $ List.map constOf $        [(fromIntegral k) ..])   class-   (LLVM.IsPowerOf2 n, Phi v) =>+   (TypeNum.Pos n, Phi v, Class.Undefined v) =>       ShuffleMatch n v | v -> n where    shuffleMatch ::       ConstValue (Vector n Word32) -> v -> CodeGenFunction r v@@ -258,7 +266,37 @@ shuffleMatchTraversable is v =    Trav.mapM (shuffleMatch is) v +{- |+Implement the 'shuffleMatch' method using the methods of the 'Access' class.+-}+shuffleMatchAccess ::+   (Access n a v) =>+   ConstValue (Vector n Word32) -> v -> CodeGenFunction r v+shuffleMatchAccess is v =+   assemble =<<+   mapM+      (flip extract v <=<+       flip extract (value is) . valueOf)+      (take (size (value is)) [0..]) ++shuffleMatchPlain1 ::+   (TypeNum.Pos n, IsPrimitive a) =>+   Value (Vector n a) ->+   ConstValue (Vector n Word32) ->+   CodeGenFunction r (Value (Vector n a))+shuffleMatchPlain1 x =+   shuffleMatchPlain2 x (value undef)++shuffleMatchPlain2 ::+   (TypeNum.Pos n, IsPrimitive a) =>+   Value (Vector n a) ->+   Value (Vector n a) ->+   ConstValue (Vector n Word32) ->+   CodeGenFunction r (Value (Vector n a))+shuffleMatchPlain2 =+   LLVM.shufflevector+ {- | 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@@ -284,14 +322,27 @@ extractTraversable n v =    Trav.mapM (extract n) v +{- |+provide the elements of a vector as a list of individual virtual registers +This can be considered the inverse of 'assemble'.+-}+extractAll ::+   (Access n a v) =>+   v -> LLVM.CodeGenFunction r [a]+extractAll x =+   mapM+      (flip extract x . LLVM.valueOf)+      (take (sizeInTuple x) [0..])++ instance-   (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a) =>+   (TypeNum.Pos n, LLVM.IsPrimitive a) =>       ShuffleMatch n (Value (Vector n a)) where-   shuffleMatch is v = shufflevector v (value undef) is+   shuffleMatch is v = shuffleMatchPlain1 v is  instance-   (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a) =>+   (TypeNum.Pos 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@@ -354,17 +405,20 @@ Like LLVM.Util.Loop.mapVector but the loop is unrolled, which is faster since it can be packed by the code generator. -}-map ::+map, _mapByFold ::    (Access n a va, Access n b vb) =>    (a -> CodeGenFunction r b) ->    (va -> CodeGenFunction r vb)-map f a =+map f =+   assemble <=< mapM f <=< extractAll++_mapByFold f a =    foldM       (\b n ->          extract (valueOf n) a >>=          f >>=          flip (insert (valueOf n)) b)-      LLVM.undefTuple+      Class.undefTuple       (take (sizeInTuple a) [0..])  mapChunks ::@@ -378,7 +432,7 @@          am >>= \ac ->          f ac >>= \bc ->          insertChunk (k * sizeInTuple ac) bc b)-      LLVM.undefTuple $+      Class.undefTuple $    List.zip (chop a) [0..]  zipChunksWith ::@@ -414,7 +468,7 @@ Ideally on ix86 with SSE41 this would be translated to 'dpps'. -} dotProductPartial ::-   (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+   (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>    Int ->    Value (Vector n a) ->    Value (Vector n a) ->@@ -423,7 +477,7 @@    sumPartial n =<< A.mul x y  sumPartial ::-   (LLVM.IsPowerOf2 n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>+   (TypeNum.Pos n, LLVM.IsPrimitive a, LLVM.IsArithmetic a) =>    Int ->    Value (Vector n a) ->    CodeGenFunction r (Value a)@@ -473,13 +527,14 @@                insert (valueOf j) x v)             v0 $          List.zip [0..] js)-      LLVM.undefTuple $+      Class.undefTuple $    List.zip       (ListHT.sliceVertical (sizeInTuple (head xs)) [0..])       xs   getLowestPair ::+   (TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value a, Value a) getLowestPair x =@@ -490,7 +545,7 @@  _reduceAddInterleaved ::    (IsArithmetic a, IsPrimitive a,-    IsPowerOf2 n, IsPowerOf2 m, TypeNum.Mul D2 m n) =>+    TypeNum.Pos n, TypeNum.Pos m, TypeNum.Mul D2 m n) =>    m ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector m a))@@ -501,7 +556,7 @@    A.add x y  sumGeneric ::-   (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value a) sumGeneric =@@ -509,13 +564,13 @@    reduceSumInterleaved 1  sumToPairGeneric ::-   (Arithmetic a, IsPowerOf2 n) =>+   (Arithmetic a, TypeNum.Pos 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)+       shuffleMatchPlain1 v           (constVector $            List.map (constOf . fromIntegral) $            concatMap (\k -> [k, k+n2]) $@@ -538,13 +593,13 @@ LLVM actually treats the vectors like vectors of smaller size. -} reduceSumInterleaved ::-   (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Pos n) =>    Int ->    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) reduceSumInterleaved m x0 =    let go ::-          (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+          (IsArithmetic a, IsPrimitive a, TypeNum.Pos n) =>           Int ->           Value (Vector n a) ->           CodeGenFunction r (Value (Vector n a))@@ -555,13 +610,13 @@                let n2 = div n 2                in  go n2                       =<< A.add x-                      =<< shufflevector x (value undef)+                      =<< shuffleMatchPlain1 x                              (constVector $ List.map constOf (take n2 [fromIntegral n2 ..])                                  ++ List.repeat undef)    in  go (size x0) x0  cumulateGeneric, _cumulateSimple ::-   (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Pos n) =>    Value a -> Value (Vector n a) ->    CodeGenFunction r (Value a, Value (Vector n a)) _cumulateSimple a x =@@ -570,14 +625,14 @@          a1 <- A.add a0 =<< extract (valueOf k) x          y1 <- insert (valueOf k) a0 y0          return (a1,y1))-      (a, LLVM.undefTuple)+      (a, Class.undefTuple)       (take (sizeInTuple x) $ [0..])  cumulateGeneric =    cumulateFrom1 cumulate1  cumulateFrom1 ::-   (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Pos n) =>    (Value (Vector n a) ->     CodeGenFunction r (Value (Vector n a))) ->    Value a -> Value (Vector n a) ->@@ -593,7 +648,7 @@ Needs (log n) vector additions -} cumulate1 ::-   (IsArithmetic a, IsPrimitive a, IsPowerOf2 n) =>+   (IsArithmetic a, IsPrimitive a, TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) cumulate1 x =@@ -604,14 +659,14 @@   signedFraction ::-   (IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   (IsFloating a, IsConst a, Real a, TypeNum.Pos 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) =>+   (IsFloating a, IsConst a, Real a, TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) floorGeneric = floorLogical A.fcmp@@ -625,7 +680,7 @@ and then to a floating point number. -} fractionGeneric ::-   (IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   (IsFloating a, IsConst a, Real a, TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) fractionGeneric = fractionLogical A.fcmp@@ -638,7 +693,7 @@ When this issue is fixed, this function will be replaced by LLVM.select. -} select ::-   (LLVM.IsFirstClass a, IsPrimitive a, IsPowerOf2 n,+   (LLVM.IsFirstClass a, IsPrimitive a, TypeNum.Pos n,     LLVM.CmpRet a Bool) =>    Value (Vector n Bool) ->    Value (Vector n a) ->@@ -652,7 +707,7 @@ This will need jumps. -} _floorSelect ::-   (Num a, IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   (Num a, IsFloating a, IsConst a, Real a, TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) _floorSelect x =@@ -665,7 +720,7 @@ This will need jumps. -} _fractionSelect ::-   (Num a, IsFloating a, IsConst a, Real a, IsPowerOf2 n) =>+   (Num a, IsFloating a, IsConst a, Real a, TypeNum.Pos n) =>    Value (Vector n a) ->    CodeGenFunction r (Value (Vector n a)) _fractionSelect x =@@ -690,7 +745,7 @@ --    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) =>+    TypeNum.Pos n) =>    Value (Vector n i) ->    Value (Vector n a) ->    Value (Vector n a) ->@@ -705,7 +760,7 @@  floorLogical ::    (IsFloating a, IsConst a, Real a,-    IsPrimitive i, LLVM.IsInteger i, IsPowerOf2 n) =>+    IsPrimitive i, LLVM.IsInteger i, TypeNum.Pos n) =>    (LLVM.FPPredicate ->     Value (Vector n a) ->     Value (Vector n a) ->@@ -719,7 +774,7 @@  fractionLogical ::    (IsFloating a, IsConst a, Real a,-    IsPrimitive i, LLVM.IsInteger i, IsPowerOf2 n) =>+    IsPrimitive i, LLVM.IsInteger i, TypeNum.Pos n) =>    (LLVM.FPPredicate ->     Value (Vector n a) ->     Value (Vector n a) ->@@ -733,7 +788,7 @@   orderBy ::-   (IsPowerOf2 m,+   (TypeNum.Pos m,     LLVM.IsFirstClass a, IsPrimitive a,     LLVM.IsInteger i, IsPrimitive i,     LLVM.IsSized (Vector m a) s, LLVM.IsSized (Vector m i) s) =>@@ -744,7 +799,7 @@       pcmpgt x y >>= \b -> selectLogical b y x  order ::-   (IsPowerOf2 n, IsPowerOf2 m,+   (TypeNum.Pos n, TypeNum.Pos m,     LLVM.IsFirstClass a, IsPrimitive a,     LLVM.IsInteger i, IsPrimitive i,     LLVM.IsSized (Vector m a) s, LLVM.IsSized (Vector m i) s) =>@@ -779,7 +834,7 @@ -} class (IsArithmetic a, IsPrimitive a) => Arithmetic a where    sum ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       CodeGenFunction r (Value a)    sum = sumGeneric@@ -790,7 +845,7 @@    n must be at least D2.    -}    sumToPair ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       CodeGenFunction r (Value a, Value a)    sumToPair = sumToPairGeneric@@ -801,20 +856,20 @@    n must be at least D2.    -}    sumInterleavedToPair ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       CodeGenFunction r (Value a, Value a)    sumInterleavedToPair v =       getLowestPair =<< reduceSumInterleaved 2 v     cumulate ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value a -> Value (Vector n a) ->       CodeGenFunction r (Value a, Value (Vector n a))    cumulate = cumulateGeneric     dotProduct ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       Value (Vector n a) ->       CodeGenFunction r (Value a)@@ -822,7 +877,7 @@       dotProductPartial (size x) x y     mul ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))@@ -917,19 +972,19 @@       (Ext.with X86.pmuludq $ \pmul ->          zipChunksWith             (\cx cy -> do-               evenX <- LLVM.shufflevector cx (value undef)+               evenX <- shuffleMatchPlain1 cx                   (constVector [constOf 0, undef, constOf 2, undef])-               evenY <- LLVM.shufflevector cy (value undef)+               evenY <- shuffleMatchPlain1 cy                   (constVector [constOf 0, undef, constOf 2, undef])                evenZ64 <- pmul evenX evenY                evenZ <- LLVM.bitcastUnify evenZ64-               oddX <- LLVM.shufflevector cx (value undef)+               oddX <- shuffleMatchPlain1 cx                   (constVector [constOf 1, undef, constOf 3, undef])-               oddY <- LLVM.shufflevector cy (value undef)+               oddY <- shuffleMatchPlain1 cy                   (constVector [constOf 1, undef, constOf 3, undef])                oddZ64 <- pmul oddX oddY                oddZ <- LLVM.bitcastUnify oddZ64-               LLVM.shufflevector evenZ oddZ+               shuffleMatchPlain2 evenZ oddZ                   (constVector [constOf 0, constOf 4, constOf 2, constOf 6]))             x y)       `Ext.run`@@ -938,7 +993,7 @@   umul32to64 ::-   (IsPowerOf2 n) =>+   (TypeNum.Pos n) =>    Value (Vector n Word32) ->    Value (Vector n Word32) ->    CodeGenFunction r (Value (Vector n Word64))@@ -951,18 +1006,18 @@       zipChunksWith          -- save an initial shuffle          (\cx cy -> do-            evenX <- LLVM.shufflevector cx (value undef)+            evenX <- shuffleMatchPlain1 cx                (constVector [constOf 0, undef, constOf 2, undef])-            evenY <- LLVM.shufflevector cy (value undef)+            evenY <- shuffleMatchPlain1 cy                (constVector [constOf 0, undef, constOf 2, undef])             evenZ <- pmul evenX evenY-            oddX <- LLVM.shufflevector cx (value undef)+            oddX <- shuffleMatchPlain1 cx                (constVector [constOf 1, undef, constOf 3, undef])-            oddY <- LLVM.shufflevector cy (value undef)+            oddY <- shuffleMatchPlain1 cy                (constVector [constOf 1, undef, constOf 3, undef])             oddZ <- pmul oddX oddY {--            LLVM.shufflevector evenZ oddZ+            shuffleMatchPlain2 evenZ oddZ                (constVector [constOf 0, constOf 2, constOf 1, constOf 3]) -}             assemble =<< (sequence $@@ -974,18 +1029,18 @@ {-          -- save the final shuffle          (\cx cy -> do-            lowerX <- LLVM.shufflevector cx (value undef)+            lowerX <- shuffleMatchPlain1 cx                (constVector [constOf 0, undef, constOf 1, undef])-            lowerY <- LLVM.shufflevector cy (value undef)+            lowerY <- shuffleMatchPlain1 cy                (constVector [constOf 0, undef, constOf 1, undef])             lowerZ <- pmul lowerX lowerY-            upperX <- LLVM.shufflevector cx (value undef)+            upperX <- shuffleMatchPlain1 cx                (constVector [constOf 2, undef, constOf 3, undef])-            upperY <- LLVM.shufflevector cy (value undef)+            upperY <- shuffleMatchPlain1 cy                (constVector [constOf 2, undef, constOf 3, undef])             upperZ <- pmul upperX upperY {--            LLVM.shufflevector lowerZ upperZ+            shuffleMatchPlain2 lowerZ upperZ                (constVector [constOf 0, constOf 1, constOf 2, constOf 3]) -}             concat [lowerZ, upperZ])@@ -1002,25 +1057,25 @@ class (Arithmetic a, LLVM.CmpRet a Bool, IsConst a) =>          Real a where    min, max ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))     abs ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos n) =>       Value (Vector n a) ->       CodeGenFunction r (Value (Vector n a))     truncate, floor, fraction ::-      (IsPowerOf2 n) =>+      (TypeNum.Pos 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+   min = zipAutoWith A.min X86.minps+   max = zipAutoWith A.max X86.maxps+   abs = mapAuto A.abs X86.absps    {-    An IEEE specific implementation could do some bit manipulation:    s eeeeeeee mmmmmmmmmmmmmmmmmmmmmmm@@ -1071,9 +1126,9 @@           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+   min = zipAutoWith A.min X86.minpd+   max = zipAutoWith A.max X86.maxpd+   abs = mapAuto A.abs X86.abspd    truncate x =       (LLVM.sitofp .        (id :: Value (Vector n Int64) -> Value (Vector n Int64))@@ -1099,33 +1154,33 @@           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+   min = order A.min X86.pcmpgtb X86.pminsb+   max = order A.max (fmap flip X86.pcmpgtb) X86.pmaxsb+   abs = mapAuto A.abs 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+   min = order A.min X86.pcmpgtw X86.pminsw+   max = order A.max (fmap flip X86.pcmpgtw) X86.pmaxsw+   abs = mapAuto A.abs 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+   min = order A.min X86.pcmpgtd X86.pminsd+   max = order A.max (fmap flip X86.pcmpgtd) X86.pmaxsd+   abs = mapAuto A.abs 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 $+   min = zipAutoWith A.min (orderBy X86.pcmpgtq)+   max = zipAutoWith A.max (orderBy (fmap flip X86.pcmpgtq))+   abs = mapAuto A.abs $       Ext.with (orderBy (fmap flip X86.pcmpgtq)) $          \smax x -> smax x =<< LLVM.neg x    truncate = return@@ -1133,32 +1188,32 @@    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+   min = order A.min X86.pcmpugtb X86.pminub+   max = order A.max (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+   min = order A.min X86.pcmpugtw X86.pminuw+   max = order A.max (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+   min = order A.min X86.pcmpugtd X86.pminud+   max = order A.max (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))+   min = zipAutoWith A.min (orderBy X86.pcmpugtq)+   max = zipAutoWith A.max (orderBy (fmap flip X86.pcmpugtq))    abs = return    truncate = return    floor = return
x86/cpuid/LLVM/Extra/ExtensionCheck/X86.hs view
@@ -3,47 +3,44 @@    ) where  import qualified LLVM.Extra.Extension as Ext-import Data.Word (Word32, )-import Data.Bits (testBit, )-import System.Cpuid (cpuid, )+import qualified System.Cpuid as 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 ::+   String ->+   (CPUID.FlagSet CPUID.Feature1C -> CPUID.FlagSet CPUID.Feature1D -> 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)+check ::+   (CPUID.FlagSet CPUID.Feature1C -> CPUID.FlagSet CPUID.Feature1D -> Bool) ->+   IO Bool+check q =+   fmap (uncurry q) $ CPUID.features   -- * target specific extensions  sse1 :: Ext.Subtarget-sse1 = subtarget "sse" (\_ecx edx -> testBit edx 25)+sse1 = subtarget "sse" (\_ecx edx -> CPUID.testFlag CPUID.sse edx)  sse2 :: Ext.Subtarget-sse2 = subtarget "sse2" (\_ecx edx -> testBit edx 26)+sse2 = subtarget "sse2" (\_ecx edx -> CPUID.testFlag CPUID.sse2 edx)  sse3 :: Ext.Subtarget-sse3 = subtarget "sse3" (\ecx _edx -> testBit ecx 0)+sse3 = subtarget "sse3" (\ecx _edx -> CPUID.testFlag CPUID.sse3 ecx)  ssse3 :: Ext.Subtarget-ssse3 = subtarget "ssse3" (\ecx _edx -> testBit ecx 9)+ssse3 = subtarget "ssse3" (\ecx _edx -> CPUID.testFlag CPUID.ssse3 ecx)  sse41 :: Ext.Subtarget-sse41 = subtarget "sse41" (\ecx _edx -> testBit ecx 19)+sse41 = subtarget "sse41" (\ecx _edx -> CPUID.testFlag CPUID.sse4_1 ecx)  sse42 :: Ext.Subtarget-sse42 = subtarget "sse42" (\ecx _edx -> testBit ecx 20)+sse42 = subtarget "sse42" (\ecx _edx -> CPUID.testFlag CPUID.sse4_2 ecx)