llvm 0.5.0.1 → 0.6.0.2

raw patch · 25 files changed

+865/−400 lines, 25 filesdep +directorydep +processbuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, process

API changes (from Hackage documentation)

Files

• INSTALL.txt +14/−3
• LLVM/Core.hs +9/−2
• LLVM/Core/CodeGen.hs +9/−0
• LLVM/Core/Instructions.hs +73/−55
• LLVM/Core/Type.hs +137/−76
• LLVM/Core/Util.hs +14/−26
• LLVM/Core/Vector.hs +99/−5
• LLVM/ExecutionEngine/Engine.hs +5/−14
• LLVM/FFI/Core.hsc +64/−31
• LLVM/FFI/ExecutionEngine.hsc +7/−7
• LLVM/Util/Arithmetic.hs +130/−55
• LLVM/Util/File.hs +48/−0
• LLVM/Util/Foreign.hs +29/−0
• LLVM/Util/Loop.hs +109/−0
• Makefile +2/−1
• Setup.lhs +26/−1
• examples/Arith.hs +52/−5
• examples/Array.hs +1/−2
• examples/BrainF.hs +11/−6
• examples/DotProd.hs +6/−19
• examples/Loop.hs +0/−83
• examples/Makefile +2/−3
• examples/Vector.hs +1/−1
• llvm.buildinfo.windows.in +4/−0
• llvm.cabal +13/−5

@@ -10,8 +10,15 @@ -------------  Firstly, you'll need to have LLVM.  I recommend installing LLVM-version 2.4 which is what it's been tested with.+version 2.4 (from llvm.org) which is what it's been tested with.+Do A or B. +A) Install from a binary package.  Follow the LLVM instructions.+The binary package at llvm.org for Windows only contains executable+files and no libraries.  You can find a complete Windows binary package+at ???.++B) Install from source. Build this and install it somewhere.  Follow the LLVM instructions, or use this: @@ -26,8 +33,12 @@ Building -------- It's normal cabal package, but using a configure script as well to-configure LLVM.  It can be build and installed with the usual-three steps.+configure LLVM.  Do A or B.++A) If you have cabal-install just do+  cabal install --configure-option --with-llvm-prefix=$SOMEWHERE++B) If you don't have cabal-install:  Configure the package.   runhaskell Setup configure --configure-option --with-llvm-prefix=$SOMEWHERE

@@ -44,7 +44,7 @@     zero, allOnes, undef,     createString, createStringNul,     constVector, constArray,-    mkVector,+    toVector, fromVector,     -- * Code generation     CodeGenFunction, CodeGenModule,     -- * Functions@@ -58,8 +58,10 @@     Linkage(..),     -- * Basic blocks     BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,+    -- * Misc+    addAttributes, Attribute(..),     -- * Debugging-    dumpValue, dumpType,+    dumpValue, dumpType, getValueName,     -- * Transformations     addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,     addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,@@ -79,8 +81,13 @@ dumpValue :: Value a -> IO () dumpValue (Value v) = FFI.dumpValue v +-- |Print a type. dumpType :: Value a -> IO () dumpType (Value v) = showTypeOf v >>= putStrLn++-- |Get the name of a 'Value'.+getValueName :: Value a -> IO String+getValueName (Value a) = getValueNameU a  -- TODO for types: -- Enforce free is only called on malloc memory.  (Enforce only one free?)

@@ -7,6 +7,8 @@     Linkage(..),     -- * Function creation     Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction,+    addAttributes,+    FFI.Attribute(..),     externFunction,     FunctionArgs, FunctionRet,     TFunction,@@ -72,6 +74,7 @@  newtype ConstValue a = ConstValue FFI.ValueRef +-- XXX merge with IsArithmetic? class (IsArithmetic a) => IsConst a where     constOf :: a -> ConstValue a @@ -186,6 +189,12 @@     f <- newNamedFunction linkage name     defineFunction f body     return f++-- | Add attributes to a value.  Beware, what attributes are allowed depends on+-- what kind of value it is.+addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r ()+addAttributes (Value f) i as = do+    liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as)  -- XXX This is ugly, it must be possible to make it simpler -- Convert a function of type f = t1->t2->...-> IO r to

@@ -35,7 +35,8 @@     ptrtoint, inttoptr,     bitcast,     -- * Comparison-    IntPredicate(..), RealPredicate(..),+    IntPredicate(..), FPPredicate(..),+    CmpRet,     icmp, fcmp,     select,     -- * Other@@ -144,8 +145,6 @@  -------------------------------------- --- XXX Vector ops not implemented- type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef @@ -271,47 +270,48 @@  -- XXX size a > size b not enforced -- | Truncate a value to a shorter bit width.-trunc :: (IsInteger a, IsInteger b) => Value a -> CodeGenFunction r (Value b)+trunc :: (IsInteger a, IsInteger b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) trunc = convert FFI.buildTrunc  -- XXX size a < size b not enforced -- | Zero extend a value to a wider width.-zext :: (IsInteger a, IsInteger b) => Value a -> CodeGenFunction r (Value b)+zext :: (IsInteger a, IsInteger b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) zext = convert FFI.buildZExt  -- XXX size a < size b not enforced -- | Sign extend a value to wider width.-sext :: (IsInteger a, IsInteger b) => Value a -> CodeGenFunction r (Value b)+sext :: (IsInteger a, IsInteger b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) sext = convert FFI.buildSExt  -- XXX size a > size b not enforced -- | Truncate a floating point value.-fptrunc :: (IsFloating a, IsFloating b) => Value a -> CodeGenFunction r (Value b)+fptrunc :: (IsFloating a, IsFloating b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) fptrunc = convert FFI.buildFPTrunc  -- XXX size a < size b not enforced -- | Extend a floating point value.-fpext :: (IsFloating a, IsFloating b) => Value a -> CodeGenFunction r (Value b)+fpext :: (IsFloating a, IsFloating b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) fpext = convert FFI.buildFPExt +-- XXX The fp<->i conversion can handle vectors. -- | Convert a floating point value to an unsigned integer.-fptoui :: (IsFloating a, IsInteger b) => Value a -> CodeGenFunction r (Value b)+fptoui :: (IsFloating a, IsInteger b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) fptoui = convert FFI.buildFPToUI  -- | Convert a floating point value to a signed integer.-fptosi :: (IsFloating a, IsInteger b) => Value a -> CodeGenFunction r (Value b)+fptosi :: (IsFloating a, IsInteger b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) fptosi = convert FFI.buildFPToSI  -- | Convert an unsigned integer to a floating point value.-uitofp :: (IsInteger a, IsFloating b) => Value a -> CodeGenFunction r (Value b)+uitofp :: (IsInteger a, IsFloating b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) uitofp = convert FFI.buildUIToFP  -- | Convert a signed integer to a floating point value.-sitofp :: (IsInteger a, IsFloating b) => Value a -> CodeGenFunction r (Value b)+sitofp :: (IsInteger a, IsFloating b, IsPrimitive a, IsPrimitive b) => Value a -> CodeGenFunction r (Value b) sitofp = convert FFI.buildSIToFP  -- | Convert a pointer to an integer.-ptrtoint :: (IsInteger b) => Value (Ptr a) -> CodeGenFunction r (Value b)+ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b) ptrtoint = convert FFI.buildPtrToInt  -- | Convert an integer to a pointer.@@ -349,56 +349,74 @@ fromIntPredicate :: IntPredicate -> CInt fromIntPredicate p = fromIntegral (fromEnum p + 32) -data RealPredicate =-    RealFalse           -- ^ Always false (always folded)-  | RealOEQ             -- ^ True if ordered and equal-  | RealOGT             -- ^ True if ordered and greater than-  | RealOGE             -- ^ True if ordered and greater than or equal-  | RealOLT             -- ^ True if ordered and less than-  | RealOLE             -- ^ True if ordered and less than or equal-  | RealONE             -- ^ True if ordered and operands are unequal-  | RealORD             -- ^ True if ordered (no nans)-  | RealUNO             -- ^ True if unordered: isnan(X) | isnan(Y)-  | RealUEQ             -- ^ True if unordered or equal-  | RealUGT             -- ^ True if unordered or greater than-  | RealUGE             -- ^ True if unordered, greater than, or equal-  | RealULT             -- ^ True if unordered or less than-  | RealULE             -- ^ True if unordered, less than, or equal-  | RealUNE             -- ^ True if unordered or not equal-  | RealT               -- ^ Always true (always folded)+data FPPredicate =+    FPFalse           -- ^ Always false (always folded)+  | FPOEQ             -- ^ True if ordered and equal+  | FPOGT             -- ^ True if ordered and greater than+  | FPOGE             -- ^ True if ordered and greater than or equal+  | FPOLT             -- ^ True if ordered and less than+  | FPOLE             -- ^ True if ordered and less than or equal+  | FPONE             -- ^ True if ordered and operands are unequal+  | FPORD             -- ^ True if ordered (no nans)+  | FPUNO             -- ^ True if unordered: isnan(X) | isnan(Y)+  | FPUEQ             -- ^ True if unordered or equal+  | FPUGT             -- ^ True if unordered or greater than+  | FPUGE             -- ^ True if unordered, greater than, or equal+  | FPULT             -- ^ True if unordered or less than+  | FPULE             -- ^ True if unordered, less than, or equal+  | FPUNE             -- ^ True if unordered or not equal+  | FPT               -- ^ Always true (always folded)     deriving (Eq, Ord, Enum, Show) -fromRealPredicate :: RealPredicate -> CInt-fromRealPredicate p = fromIntegral (fromEnum p)+fromFPPredicate :: FPPredicate -> CInt+fromFPPredicate p = fromIntegral (fromEnum p)  -- |Acceptable operands to comparison instructions.-class CmpOp a b c | a b -> c where-    cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value Bool)+class CmpOp a b c d | a b -> c where+    cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value d) -instance CmpOp (Value a) (Value a) a where+instance CmpOp (Value a) (Value a) a d where     cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2 -instance (IsConst a) => CmpOp a (Value a) a where+instance (IsConst a) => CmpOp a (Value a) a d where     cmpop op a1 a2 = cmpop op (valueOf a1) a2 -instance (IsConst a) => CmpOp (Value a) a a where+instance (IsConst a) => CmpOp (Value a) a a d where     cmpop op a1 a2 = cmpop op a1 (valueOf a2) +class CmpRet a b | a -> b+instance CmpRet Float Bool+instance CmpRet Double Bool+instance CmpRet FP128 Bool+instance CmpRet Bool Bool+instance CmpRet Word8 Bool+instance CmpRet Word16 Bool+instance CmpRet Word32 Bool+instance CmpRet Word64 Bool+instance CmpRet Int8 Bool+instance CmpRet Int16 Bool+instance CmpRet Int32 Bool+instance CmpRet Int64 Bool+instance CmpRet (Vector n a) (Vector n Bool)++-- XXX Vector -- | Compare integers.-icmp :: (IsInteger c, CmpOp a b c) =>-        IntPredicate -> a -> b -> CodeGenFunction r (Value Bool)+icmp :: (IsInteger c, CmpOp a b c d, CmpRet c d) =>+        IntPredicate -> a -> b -> CodeGenFunction r (Value d) icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) +-- XXX Vector -- | Compare floating point values.-fcmp :: (IsFloating c, CmpOp a b c) =>-        RealPredicate -> a -> b -> CodeGenFunction r (Value Bool)-fcmp p = cmpop (flip FFI.buildFCmp (fromRealPredicate p))+fcmp :: (IsFloating c, CmpOp a b c d, CmpRet c d) =>+        FPPredicate -> a -> b -> CodeGenFunction r (Value d)+fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p))  -------------------------------------- +-- XXX can handle vectors, needs bool vector args -- XXX could do const song and dance -- | Select between two values depending on a boolean.-select :: (IsFirstClass a) => Value Bool -> Value a -> Value a -> CodeGenFunction r (Value a)+select :: (IsFirstClass a, CmpRet a b) => Value b -> Value a -> Value a -> CodeGenFunction r (Value a) select (Value cnd) (Value thn) (Value els) =     liftM Value $       withCurrentBuilder $ \ bldPtr ->@@ -632,25 +650,25 @@ {- instance (IsConst a) => Eq (ConstValue a) where     ConstValue x == ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromRealPredicate RealOEQ) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate    IntEQ) x y)+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOEQ) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y)     ConstValue x /= ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromRealPredicate RealONE) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate    IntNE) x y)+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPONE) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y)  instance (IsConst a) => Ord (ConstValue a) where     ConstValue x <  ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromRealPredicate RealOLT) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate    IntLT) x y)+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOLT) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y)     ConstValue x <= ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromRealPredicate RealOLE) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate    IntLE) x y)+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOLE) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y)     ConstValue x >  ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromRealPredicate RealOGT) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate    IntGT) x y)+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOGT) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y)     ConstValue x >= ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromRealPredicate RealOGE) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate    IntGE) x y)+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOGE) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y) -}  instance (Num a, IsConst a) => Num (ConstValue a) where

@@ -8,18 +8,23 @@     -- * Type classifier     IsType(..),     -- ** Special type classifiers-    IsArithmetic(..),-    IsInteger(..),+    IsArithmetic,+    IsInteger,     IsFloating,     IsPrimitive,     IsFirstClass,     IsSized,     IsFunction,---    IsFunctionRet,-    IsSequence,     -- ** Others-    IsPowerOf2+    IsPowerOf2,+    -- ** Type tests+    TypeDesc(..),+    isFloating,+    isSigned,+    typeRef,+    typeName     ) where+import Data.List(intercalate) import Data.Int import Data.Word import Data.TypeNumbers@@ -27,6 +32,10 @@ import LLVM.Core.Data import qualified LLVM.FFI.Core as FFI +-- XXX+-- IsSized should have two parameters, the second being the size and computed from the first++-- Usage: vector precondition -- XXX This could defined inductively, but this is good enough for LLVM class (IsTypeNumber n) => IsPowerOf2 n instance IsPowerOf2 (D1 End)@@ -49,123 +58,178 @@  -- |The 'IsType' class classifies all types that have an LLVM representation. class IsType a where-    typeRef :: a -> FFI.TypeRef  -- ^The argument is never evaluated+    typeDesc :: a -> TypeDesc --- |Arithmetic types, i.e., integral and floating types.-class IsFirstClass a => IsArithmetic a where-    isFloating :: a -> Bool-    isFloating _ = False-    typeName :: a -> String -- XXX could be in IsType+typeRef :: (IsType a) => a -> FFI.TypeRef  -- ^The argument is never evaluated+typeRef = code . typeDesc+  where code TDFloat  = FFI.floatType+  	code TDDouble = FFI.doubleType+	code TDFP128  = FFI.fp128Type+	code TDVoid   = FFI.voidType+	code (TDInt _ n)  = FFI.integerType (fromInteger n)+	code (TDArray n a) = FFI.arrayType (code a) (fromInteger n)+	code (TDVector n a) = FFI.vectorType (code a) (fromInteger n)+	code (TDPtr a) = FFI.pointerType (code a) 0+	code (TDFunction as b) = functionType False (code b) (map code as) +typeName :: (IsType a) => a -> String+typeName = code . typeDesc+  where code TDFloat  = "f32"+  	code TDDouble = "f64"+	code TDFP128  = "f128"+	code TDVoid   = "void"+	code (TDInt _ n)  = "i" ++ show n+	code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"+	code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"+	code (TDPtr a) = code a ++ "*"+	code (TDFunction as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")" +-- |Type descriptor, used to convey type information through the LLVM API.+data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer+              | TDArray Integer TypeDesc | TDVector Integer TypeDesc+	      | TDPtr TypeDesc | TDFunction [TypeDesc] TypeDesc+    deriving (Eq, Ord, Show)++-- XXX isFloating and typeName could be extracted from typeRef+-- Usage:+--   superclass of IsConst+--   add, sub, mul, neg context+--   used to get type name to call intrinsic+-- |Arithmetic types, i.e., integral and floating types.+class IsFirstClass a => IsArithmetic a++-- Usage:+--  constI, allOnes+--  many instructions.  XXX some need vector+--  used to find signedness in Arithmetic -- |Integral types.-class IsArithmetic a => IsInteger a where-    isSigned :: a -> Bool+class IsArithmetic a => IsInteger a +isSigned :: (IsInteger a) => a -> Bool+isSigned = is . typeDesc+  where is (TDInt s _) = s+  	is (TDVector _ a) = is a+	is _ = error "isSigned got impossible input"++-- Usage:+--  constF+--  many instructions -- |Floating types. class IsArithmetic a => IsFloating a +isFloating :: (IsArithmetic a) => a -> Bool+isFloating = is . typeDesc+  where is TDFloat = True+  	is TDDouble = True+	is TDFP128 = True+	is (TDVector _ a) = is a+	is _ = False++-- Usage:+--  Precondition for Vector -- |Primitive types. class IsType a => IsPrimitive a +-- Usage:+--  Precondition for function args and result.+--  Used by some instructions, like ret and phi.+--  XXX IsSized as precondition? -- |First class types, i.e., the types that can be passed as arguments, etc. class IsType a => IsFirstClass a --- XXX use kind annotation--- |Sequence types, i.e., vectors and arrays-class IsSequence c where dummy__ :: c a -> a; dummy__ = undefined-+-- Usage:+--  Context for Array being a type+--  thus, allocation instructions -- |Types with a fixed size. class (IsType a) => IsSized a  -- |Function type. class (IsType a) => IsFunction a where-    funcType :: [FFI.TypeRef] -> a -> FFI.TypeRef+    funcType :: [TypeDesc] -> a -> TypeDesc  -- Only make instances for types that make sense in Haskell -- (i.e., some floating types are excluded).  -- Floating point types.-instance IsType Float  where typeRef _ = FFI.floatType-instance IsType Double where typeRef _ = FFI.doubleType-instance IsType FP128  where typeRef _ = FFI.fp128Type+instance IsType Float  where typeDesc _ = TDFloat+instance IsType Double where typeDesc _ = TDDouble+instance IsType FP128  where typeDesc _ = TDFP128  -- Void type-instance IsType ()     where typeRef _ = FFI.voidType---- Label type---data Label---instance IsType Label  where typeRef _ = FFI.labelType+instance IsType ()     where typeDesc _ = TDVoid  -- Variable size integer types instance (IsTypeNumber n) => IsType (IntN n)-    where typeRef _ = FFI.integerType (typeNumber (undefined :: n))+    where typeDesc _ = TDInt True  (typeNumber (undefined :: n))  instance (IsTypeNumber n) => IsType (WordN n)-    where typeRef _ = FFI.integerType (typeNumber (undefined :: n))+    where typeDesc _ = TDInt False (typeNumber (undefined :: n))  -- Fixed size integer types.-instance IsType Bool   where typeRef _ = FFI.int1Type-instance IsType Word8  where typeRef _ = FFI.int8Type-instance IsType Word16 where typeRef _ = FFI.int16Type-instance IsType Word32 where typeRef _ = FFI.int32Type-instance IsType Word64 where typeRef _ = FFI.int64Type-instance IsType Int8   where typeRef _ = FFI.int8Type-instance IsType Int16  where typeRef _ = FFI.int16Type-instance IsType Int32  where typeRef _ = FFI.int32Type-instance IsType Int64  where typeRef _ = FFI.int64Type+instance IsType Bool   where typeDesc _ = TDInt False  1+instance IsType Word8  where typeDesc _ = TDInt False  8+instance IsType Word16 where typeDesc _ = TDInt False 16+instance IsType Word32 where typeDesc _ = TDInt False 32+instance IsType Word64 where typeDesc _ = TDInt False 64+instance IsType Int8   where typeDesc _ = TDInt True   8+instance IsType Int16  where typeDesc _ = TDInt True  16+instance IsType Int32  where typeDesc _ = TDInt True  32+instance IsType Int64  where typeDesc _ = TDInt True  64  -- Sequence types instance (IsTypeNumber n, IsSized a) => IsType (Array n a)-    where typeRef _ = FFI.arrayType (typeRef (undefined :: a))-    	  	      		    (typeNumber (undefined :: n))-+    where typeDesc _ = TDArray (typeNumber (undefined :: n))+    	  	               (typeDesc (undefined :: a)) instance (IsPowerOf2 n, IsPrimitive a) => IsType (Vector n a)-    where typeRef _ = FFI.vectorType (typeRef (undefined :: a))-    	  	      		     (typeNumber (undefined :: n))+    where typeDesc _ = TDVector (typeNumber (undefined :: n))+    	  	       		(typeDesc (undefined :: a)) +-- Pointer type. instance (IsType a) => IsType (Ptr a) where-    typeRef _ = FFI.pointerType (typeRef (undefined :: a)) 0+    typeDesc _ = TDPtr (typeDesc (undefined :: a))  -- Functions. instance (IsFirstClass a, IsFunction b) => IsType (a->b) where-    typeRef = funcType []+    typeDesc = funcType [] +-- Function base type, always IO. instance (IsFirstClass a) => IsType (IO a) where-    typeRef = funcType []+    typeDesc = funcType []  --- Instances to classify types-instance IsArithmetic Float where isFloating _ = True; typeName _ = "f32"-instance IsArithmetic Double where isFloating _ = True; typeName _ = "f64"-instance IsArithmetic FP128 where isFloating _ = True; typeName _ = "f128"-instance (IsTypeNumber n) => IsArithmetic (IntN n) where typeName _ = "i" ++ show (typeNumber (undefined :: n) :: Int)-instance (IsTypeNumber n) => IsArithmetic (WordN n) where typeName _ = "i" ++ show (typeNumber (undefined :: n) :: Int)-instance IsArithmetic Bool where typeName _ = "i1"-instance IsArithmetic Int8 where typeName _ = "i8"-instance IsArithmetic Int16 where typeName _ = "i16"-instance IsArithmetic Int32 where typeName _ = "i32"-instance IsArithmetic Int64 where typeName _ = "i64"-instance IsArithmetic Word8 where typeName _ = "i8"-instance IsArithmetic Word16 where typeName _ = "i16"-instance IsArithmetic Word32 where typeName _ = "i32"-instance IsArithmetic Word64 where typeName _ = "i64"-instance (IsPowerOf2 n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a) where typeName _ = error "vector type name"+instance IsArithmetic Float+instance IsArithmetic Double+instance IsArithmetic FP128+instance (IsTypeNumber n) => IsArithmetic (IntN n)+instance (IsTypeNumber n) => IsArithmetic (WordN n)+instance IsArithmetic Bool+instance IsArithmetic Int8+instance IsArithmetic Int16+instance IsArithmetic Int32+instance IsArithmetic Int64+instance IsArithmetic Word8+instance IsArithmetic Word16+instance IsArithmetic Word32+instance IsArithmetic Word64+instance (IsPowerOf2 n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a)  instance IsFloating Float instance IsFloating Double instance IsFloating FP128+instance (IsPowerOf2 n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a) -instance (IsTypeNumber n) => IsInteger (IntN n) where isSigned _ = True-instance (IsTypeNumber n) => IsInteger (WordN n) where isSigned _ = False-instance IsInteger Bool where isSigned _ = False-instance IsInteger Int8 where isSigned _ = True-instance IsInteger Int16 where isSigned _ = True-instance IsInteger Int32 where isSigned _ = True-instance IsInteger Int64 where isSigned _ = True-instance IsInteger Word8 where isSigned _ = False-instance IsInteger Word16 where isSigned _ = False-instance IsInteger Word32 where isSigned _ = False-instance IsInteger Word64 where isSigned _ = False+instance (IsTypeNumber n) => IsInteger (IntN n)+instance (IsTypeNumber n) => IsInteger (WordN n)+instance IsInteger Bool+instance IsInteger Int8+instance IsInteger Int16+instance IsInteger Int32+instance IsInteger Int64+instance IsInteger Word8+instance IsInteger Word16+instance IsInteger Word32+instance IsInteger Word64+instance (IsPowerOf2 n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)  instance IsFirstClass Float instance IsFirstClass Double@@ -185,9 +249,6 @@ instance (IsType a) => IsFirstClass (Ptr a) instance IsFirstClass () -- XXX This isn't right, but () can be returned -instance (IsTypeNumber n) => IsSequence (Array n)---instance (IsPowerOf2 n, IsPrimitive a) => IsSequence (Vector n) a- instance IsSized Float instance IsSized Double instance IsSized FP128@@ -225,9 +286,9 @@  -- Functions. instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where-    funcType ts _ = funcType (typeRef (undefined :: a) : ts) (undefined :: b)+    funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b) instance (IsFirstClass a) => IsFunction (IO a) where-    funcType ts _ = functionType False (typeRef (undefined :: a)) (reverse ts)+    funcType ts _ = TDFunction (reverse ts) (typeDesc (undefined :: a))  -- XXX Structures not implemented.  Tuples is probably an easy way. 

@@ -25,7 +25,7 @@     CString, withArrayLen,     withEmptyCString,     functionType, buildEmptyPhi, addPhiIns,-    showTypeOf,+    showTypeOf, getValueNameU,     -- * Transformation passes     addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,     addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,@@ -34,7 +34,7 @@ import Data.List(intercalate) import Control.Monad(liftM, when) import Foreign.C.String (withCString, withCStringLen, CString, peekCString)-import Foreign.ForeignPtr (ForeignPtr, FinalizerPtr, newForeignPtr, withForeignPtr)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) import Foreign.Ptr (nullPtr) import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) import Foreign.Marshal.Alloc (alloca)@@ -72,11 +72,7 @@ createModule name =     withCString name $ \namePtr -> do       ptr <- FFI.moduleCreateWithName namePtr-      final <- h2c_module FFI.disposeModule-      liftM Module $ newForeignPtr final ptr--foreign import ccall "wrapper" h2c_module-    :: (FFI.ModuleRef -> IO ()) -> IO (FinalizerPtr a)+      liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr -}  -- Don't use a finalizer for the module, but instead provide an@@ -136,8 +132,7 @@                 ptr <- peek modPtr                 return $ Module ptr {--                final <- h2c_module FFI.disposeModule-                liftM Module $ newForeignPtr final ptr+                liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr -}  getModuleValues :: Module -> IO [(String, Value)]@@ -214,11 +209,7 @@ createModuleProviderForExistingModule modul =     withModule modul $ \modulPtr -> do         ptr <- FFI.createModuleProviderForExistingModule modulPtr-        final <- h2c_moduleProvider FFI.disposeModuleProvider-        liftM ModuleProvider $ newForeignPtr final ptr--foreign import ccall "wrapper" h2c_moduleProvider-    :: (FFI.ModuleProviderRef -> IO ()) -> IO (FinalizerPtr a)+        liftM ModuleProvider $ newForeignPtr FFI.ptrDisposeModuleProvider ptr   --------------------------------------@@ -233,12 +224,8 @@  createBuilder :: IO Builder createBuilder = do-    final <- h2c_builder FFI.disposeBuilder     ptr <- FFI.createBuilder-    liftM Builder $ newForeignPtr final ptr--foreign import ccall "wrapper" h2c_builder-    :: (FFI.BuilderRef -> IO ()) -> IO (FinalizerPtr a)+    liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr  positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO () positionAtEnd bld bblk =@@ -351,19 +338,14 @@ createPassManager :: IO PassManager createPassManager = do     ptr <- FFI.createPassManager-    final <- h2c_passManager FFI.disposePassManager-    liftM PassManager $ newForeignPtr final ptr+    liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr  -- | Create a pass manager for a module. createFunctionPassManager :: ModuleProvider -> IO PassManager createFunctionPassManager modul =     withModuleProvider modul $ \modulPtr -> do         ptr <- FFI.createFunctionPassManager modulPtr-        final <- h2c_passManager FFI.disposePassManager-        liftM PassManager $ newForeignPtr final ptr--foreign import ccall "wrapper" h2c_passManager-    :: (FFI.PassManagerRef -> IO ()) -> IO (FinalizerPtr a)+        liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr  -- | Add a control flow graph simplification pass to the manager. addCFGSimplificationPass :: PassManager -> IO ()@@ -417,3 +399,9 @@     withArrayLen xs' $ \ len ptr ->         return $ FFI.constArray t ptr (fromIntegral len) +--------------------------------------++getValueNameU :: Value -> IO String+getValueNameU a = do+    cs <- FFI.getValueName a+    peekCString cs

@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, ScopedTypeVariables #-} module LLVM.Core.Vector(MkVector(..)) where+import Data.Function import Data.TypeNumbers import LLVM.Core.Type import LLVM.Core.Data@@ -13,21 +14,28 @@  -- XXX Should these really be here? class (IsPowerOf2 n, IsPrimitive a) => MkVector va n a | va -> n a, n a -> va where-    mkVector :: va -> Vector n a+    toVector :: va -> Vector n a+    fromVector :: Vector n a -> va  {- instance (IsPrimitive a) => MkVector (Value a) (D1 End) (Value a) where-    mkVector a = Vector [a]+    toVector a = Vector [a] -}  instance (IsPrimitive a) => MkVector (a, a) (D2 End) a where-    mkVector (a1, a2) = Vector [a1, a2]+    toVector (a1, a2) = Vector [a1, a2]+    fromVector (Vector [a1, a2]) = (a1, a2)+    fromVector _ = error "fromVector: impossible"  instance (IsPrimitive a) => MkVector (a, a, a, a) (D4 End) a where-    mkVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]+    toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]+    fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4)+    fromVector _ = error "fromVector: impossible"  instance (IsPrimitive a) => MkVector (a, a, a, a, a, a, a, a) (D8 End) a where-    mkVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]+    toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]+    fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8)+    fromVector _ = error "fromVector: impossible"  instance (Storable a, IsTypeNumber n) => Storable (Vector n a) where     sizeOf _ = sizeOf (undefined :: a) * typeNumber (undefined :: n)@@ -40,3 +48,89 @@         unsafePerformIO $         withArrayLen [ c | v <- vs, let ConstValue c = constOf v ]  $ \ len ptr ->         return $ ConstValue $ constVector ptr (fromIntegral len)++--------------------------------------++unVector :: Vector n a -> [a]+unVector (Vector xs) = xs++binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c+binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys)++unop :: (a -> b) -> Vector n a -> Vector n b+unop op = Vector . map op . unVector++instance (Eq a) => Eq (Vector n a) where+    (==) = (==) `on` unVector++instance (Ord a) => Ord (Vector n a) where+    compare = compare `on` unVector++instance (Num a, IsTypeNumber n) => Num (Vector n a) where+    (+) = binop (+)+    (-) = binop (-)+    (*) = binop (*)+    negate = unop negate+    abs = unop abs+    signum = unop signum+    fromInteger = Vector . replicate (typeNumber (undefined :: n)) . fromInteger++instance (Enum a, IsTypeNumber n) => Enum (Vector n a) where+    succ = unop succ+    pred = unop pred+    fromEnum = error "Vector fromEnum"+    toEnum = Vector . map toEnum . replicate (typeNumber (undefined :: n))++instance (Real a, IsTypeNumber n) => Real (Vector n a) where+    toRational = error "Vector toRational"++instance (Integral a, IsTypeNumber n) => Integral (Vector n a) where+    quot = binop quot+    rem  = binop rem+    div  = binop div+    mod  = binop mod+    quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys+    divMod  (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod  xs ys+    toInteger = error "Vector toInteger"++instance (Fractional a, IsTypeNumber n) => Fractional (Vector n a) where+    (/) = binop (/)+    fromRational = Vector . replicate (typeNumber (undefined :: n)) . fromRational++instance (RealFrac a, IsTypeNumber n) => RealFrac (Vector n a) where+    properFraction = error "Vector properFraction"++instance (Floating a, IsTypeNumber n) => Floating (Vector n a) where+    pi = Vector $ replicate (typeNumber (undefined :: n)) pi+    sqrt = unop sqrt+    log = unop log+    logBase = binop logBase+    (**) = binop (**)+    exp = unop exp+    sin = unop sin+    cos = unop cos+    tan = unop tan+    asin = unop asin+    acos = unop acos+    atan = unop atan+    sinh = unop sinh+    cosh = unop cosh+    tanh = unop tanh+    asinh = unop asinh+    acosh = unop acosh+    atanh = unop atanh++instance (RealFloat a, IsTypeNumber n) => RealFloat (Vector n a) where+    floatRadix = floatRadix . head . unVector+    floatDigits = floatDigits . head . unVector+    floatRange = floatRange . head . unVector+    decodeFloat = error "Vector decodeFloat"+    encodeFloat = error "Vector encodeFloat"+    exponent _ = 0+    scaleFloat 0 x = x+    scaleFloat _ _ = error "Vector scaleFloat"+    isNaN = error "Vector isNaN"+    isInfinite = error "Vector isInfinite"+    isDenormalized = error "Vector isDenormalized"+    isNegativeZero = error "Vector isNegativeZero"+    isIEEE = isIEEE . head . unVector

@@ -20,8 +20,7 @@ import Data.Word import Foreign.Marshal.Alloc (alloca, free) import Foreign.Marshal.Array (withArrayLen)-import Foreign.ForeignPtr (FinalizerPtr, ForeignPtr, newForeignPtr,-                           withForeignPtr)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) import Foreign.Marshal.Utils (fromBool) import Foreign.C.String (peekCString) import Foreign.Ptr (Ptr)@@ -36,7 +35,7 @@ import qualified LLVM.FFI.ExecutionEngine as FFI import qualified LLVM.FFI.Target as FFI import qualified LLVM.Core.Util(Function)-import LLVM.Core.Type(IsFirstClass, IsType(..))+import LLVM.Core.Type(IsFirstClass, typeRef)  {- -- |The type of the JITer.@@ -62,11 +61,7 @@                     free err                     ioError . userError $ errStr             else do ptr <- peek eePtr-                    final <- h2c_ee FFI.disposeExecutionEngine-                    liftM ExecutionEngine $ newForeignPtr final ptr--foreign import ccall "wrapper" h2c_ee-    :: (Ptr FFI.ExecutionEngine -> IO ()) -> IO (FinalizerPtr a)+                    liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr  addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO () addModuleProvider ee prov =@@ -155,7 +150,7 @@     liftIO $ FFI.getExecutionEngineTargetData eePtr  #if HAS_GETPOINTERTOGLOBAL-getPointerToFunction :: Function f -> IO (FunPtr f)+getPointerToFunction :: Function f -> EngineAccess (FunPtr f) getPointerToFunction (Value f) = do     eePtr <- gets ea_engine     liftIO $ FFI.getPointerToGlobal eePtr f@@ -177,12 +172,8 @@  createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue createGenericValueWith f = do-  final <- h2c_genericValue FFI.disposeGenericValue   ptr <- f-  liftM GenericValue $ newForeignPtr final ptr--foreign import ccall "wrapper" h2c_genericValue-    :: (FFI.GenericValueRef -> IO ()) -> IO (FinalizerPtr a)+  liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr  withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a withAll ps a = go [] ps

@@ -18,6 +18,7 @@     , ModuleRef     , moduleCreateWithName     , disposeModule+    , ptrDisposeModule      , getDataLayout     , setDataLayout@@ -29,7 +30,7 @@     , ModuleProvider     , ModuleProviderRef     , createModuleProviderForExistingModule-    , disposeModuleProvider+    , ptrDisposeModuleProvider      -- * Types     , Type@@ -246,7 +247,7 @@     , Builder     , BuilderRef     , createBuilder-    , disposeBuilder+    , ptrDisposeBuilder     , positionBuilder     , positionBefore     , positionAtEnd@@ -342,13 +343,16 @@     , removeAttribute     , setInstrParamAlignment     , setParamAlignment+    , Attribute(..)+    , fromAttribute+    , toAttribute      -- * Pass manager     , PassManager     , PassManagerRef     , createFunctionPassManager     , createPassManager-    , disposePassManager+    , ptrDisposePassManager     , finalizeFunctionPassManager     , initializeFunctionPassManager     , runFunctionPassManager@@ -359,7 +363,7 @@  import Foreign.C.String (CString) import Foreign.C.Types (CDouble, CInt, CUInt, CULLong)-import Foreign.Ptr (Ptr)+import Foreign.Ptr (Ptr, FunPtr)  #include <llvm-c/Core.h> @@ -372,6 +376,9 @@ foreign import ccall unsafe "LLVMDisposeModule" disposeModule     :: ModuleRef -> IO () +foreign import ccall unsafe "&LLVMDisposeModule" ptrDisposeModule+    :: FunPtr (ModuleRef -> IO ())+ foreign import ccall unsafe "LLVMGetDataLayout" getDataLayout     :: ModuleRef -> IO CString @@ -386,8 +393,8 @@     createModuleProviderForExistingModule     :: ModuleRef -> IO ModuleProviderRef -foreign import ccall unsafe "LLVMDisposeModuleProvider" disposeModuleProvider-    :: ModuleProviderRef -> IO ()+foreign import ccall unsafe "&LLVMDisposeModuleProvider" ptrDisposeModuleProvider+    :: FunPtr (ModuleProviderRef -> IO ())   data Type@@ -572,7 +579,7 @@                        | Cold                        | X86StdCall                        | X86FastCall-                         deriving (Eq, Show)+                         deriving (Show, Eq, Ord, Enum, Bounded)  fromCallingConvention :: CallingConvention -> CUInt fromCallingConvention C = (#const LLVMCCallConv)@@ -805,8 +812,8 @@ foreign import ccall unsafe "LLVMCreateBuilder" createBuilder     :: IO BuilderRef -foreign import ccall unsafe "LLVMDisposeBuilder" disposeBuilder-    :: BuilderRef -> IO ()+foreign import ccall unsafe "&LLVMDisposeBuilder" ptrDisposeBuilder+    :: FunPtr (BuilderRef -> IO ())  foreign import ccall unsafe "LLVMPositionBuilderBefore" positionBefore     :: BuilderRef -> ValueRef -> IO ()@@ -1019,23 +1026,49 @@ foreign import ccall unsafe "LLVMSizeOf" sizeOf     :: TypeRef -> IO ValueRef -{--typedef enum {-    LLVMZExtAttribute       = 1<<0,-    LLVMSExtAttribute       = 1<<1,-    LLVMNoReturnAttribute   = 1<<2,-    LLVMInRegAttribute      = 1<<3,-    LLVMStructRetAttribute  = 1<<4,-    LLVMNoUnwindAttribute   = 1<<5,-    LLVMNoAliasAttribute    = 1<<6,-    LLVMByValAttribute      = 1<<7,-    LLVMNestAttribute       = 1<<8,-    LLVMReadNoneAttribute   = 1<<9,-    LLVMReadOnlyAttribute   = 1<<10-} LLVMAttribute;--}-type Attribute = CInt+data Attribute+    = ZExtAttribute+    | SExtAttribute+    | NoReturnAttribute+    | InRegAttribute+    | StructRetAttribute+    | NoUnwindAttribute+    | NoAliasAttribute+    | ByValAttribute+    | NestAttribute+    | ReadNoneAttribute+    | ReadOnlyAttribute+    deriving (Show, Eq, Ord, Enum, Bounded) +fromAttribute :: Attribute -> CAttribute+fromAttribute ZExtAttribute = (#const LLVMZExtAttribute)+fromAttribute SExtAttribute = (#const LLVMSExtAttribute)+fromAttribute NoReturnAttribute = (#const LLVMNoReturnAttribute)+fromAttribute InRegAttribute = (#const LLVMInRegAttribute)+fromAttribute StructRetAttribute = (#const LLVMStructRetAttribute)+fromAttribute NoUnwindAttribute = (#const LLVMNoUnwindAttribute)+fromAttribute NoAliasAttribute = (#const LLVMNoAliasAttribute)+fromAttribute ByValAttribute = (#const LLVMByValAttribute)+fromAttribute NestAttribute = (#const LLVMNestAttribute)+fromAttribute ReadNoneAttribute = (#const LLVMReadNoneAttribute)+fromAttribute ReadOnlyAttribute = (#const LLVMReadOnlyAttribute)++toAttribute :: CAttribute -> Attribute+toAttribute c | c == (#const LLVMZExtAttribute) = ZExtAttribute+toAttribute c | c == (#const LLVMSExtAttribute) = SExtAttribute+toAttribute c | c == (#const LLVMNoReturnAttribute) = NoReturnAttribute+toAttribute c | c == (#const LLVMInRegAttribute) = InRegAttribute+toAttribute c | c == (#const LLVMStructRetAttribute) = StructRetAttribute+toAttribute c | c == (#const LLVMNoUnwindAttribute) = NoUnwindAttribute+toAttribute c | c == (#const LLVMNoAliasAttribute) = NoAliasAttribute+toAttribute c | c == (#const LLVMByValAttribute) = ByValAttribute+toAttribute c | c == (#const LLVMNestAttribute) = NestAttribute+toAttribute c | c == (#const LLVMReadNoneAttribute) = ReadNoneAttribute+toAttribute c | c == (#const LLVMReadOnlyAttribute) = ReadOnlyAttribute+toAttribute _ = error "toAttribute: bad value"++type CAttribute = CInt+ data PassManager type PassManagerRef = Ptr PassManager @@ -1045,8 +1078,8 @@     :: ModuleProviderRef -> IO PassManagerRef foreign import ccall unsafe "LLVMCreatePassManager" createPassManager     :: IO PassManagerRef-foreign import ccall unsafe "LLVMDisposePassManager" disposePassManager-    :: PassManagerRef -> IO ()+foreign import ccall unsafe "&LLVMDisposePassManager" ptrDisposePassManager+    :: FunPtr (PassManagerRef -> IO ()) foreign import ccall unsafe "LLVMDumpModule" dumpModule     :: ModuleRef -> IO () foreign import ccall unsafe "LLVMFinalizeFunctionPassManager" finalizeFunctionPassManager@@ -1118,15 +1151,15 @@ foreign import ccall unsafe "LLVMSetParamAlignment" setParamAlignment     :: ValueRef -> CUInt -> IO () foreign import ccall unsafe "LLVMAddAttribute" addAttribute-    :: ValueRef -> Attribute -> IO ()+    :: ValueRef -> CAttribute -> IO () foreign import ccall unsafe "LLVMAddInstrAttribute" addInstrAttribute-    :: ValueRef -> CUInt -> Attribute -> IO ()+    :: ValueRef -> CUInt -> CAttribute -> IO () foreign import ccall unsafe "LLVMIsTailCall" isTailCall     :: ValueRef -> IO CInt foreign import ccall unsafe "LLVMRemoveAttribute" removeAttribute-    :: ValueRef -> Attribute -> IO ()+    :: ValueRef -> CAttribute -> IO () foreign import ccall unsafe "LLVMRemoveInstrAttribute" removeInstrAttribute-    :: ValueRef -> CUInt -> Attribute -> IO ()+    :: ValueRef -> CUInt -> CAttribute -> IO () foreign import ccall unsafe "LLVMSetTailCall" setTailCall     :: ValueRef -> CInt -> IO () {-

@@ -5,7 +5,7 @@     -- * Execution engines       ExecutionEngine     , createExecutionEngine-    , disposeExecutionEngine+    , ptrDisposeExecutionEngine     , createInterpreter     , createJITCompiler     , addModuleProvider@@ -32,12 +32,12 @@     , genericValueToFloat     , createGenericValueOfPointer     , genericValueToPointer-    , disposeGenericValue+    , ptrDisposeGenericValue     ) where  import Foreign.C.String (CString) import Foreign.C.Types (CDouble, CInt, CUInt, CULLong)-import Foreign.Ptr (Ptr)+import Foreign.Ptr (Ptr, FunPtr) #if HAS_GETPOINTERTOGLOBAL import Foreign.Ptr (FunPtr) #endif@@ -52,8 +52,8 @@     :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString     -> IO CInt -foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine-    :: ExecutionEngineRef -> IO ()+foreign import ccall unsafe "&LLVMDisposeExecutionEngine" ptrDisposeExecutionEngine+    :: FunPtr (ExecutionEngineRef -> IO ())  foreign import ccall unsafe "LLVMRunStaticConstructors" runStaticConstructors     :: ExecutionEngineRef -> IO ()@@ -78,8 +78,8 @@ foreign import ccall unsafe "LLVMGenericValueToFloat" genericValueToFloat     :: TypeRef -> GenericValueRef -> CDouble -foreign import ccall unsafe "LLVMDisposeGenericValue" disposeGenericValue-    :: GenericValueRef -> IO ()+foreign import ccall unsafe "&LLVMDisposeGenericValue" ptrDisposeGenericValue+    :: FunPtr (GenericValueRef -> IO ())  foreign import ccall unsafe "LLVMRunFunction" runFunction     :: ExecutionEngineRef -> ValueRef -> CUInt

@@ -1,35 +1,53 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances #-} module LLVM.Util.Arithmetic(     TValue,     Cmp,     (%==), (%/=), (%<), (%<=), (%>), (%>=),     (%&&), (%||),-    (?),-    retrn,-    ArithFunction(..), UnwrapArgs, toArithFunction, recursiveFunction+    (?), (??),+    retrn, set,+    ArithFunction, arithFunction,+    UnwrapArgs, toArithFunction,+    recursiveFunction,+    CallIntrinsic,     ) where+import Data.TypeNumbers import Data.Word import Data.Int import LLVM.Core+import LLVM.Util.Loop(mapVector, mapVector2) +-- |Synonym for @CodeGenFunction r (Value a)@. type TValue r a = CodeGenFunction r (Value a) -class Cmp a where-    cmp :: IntPredicate -> Value a -> Value a -> TValue r Bool+class (CmpRet a b) => Cmp a b | a -> b where+    cmp :: IntPredicate -> Value a -> Value a -> TValue r b -instance Cmp Bool where cmp = icmp-instance Cmp Word8 where cmp = icmp-instance Cmp Word16 where cmp = icmp-instance Cmp Word32 where cmp = icmp-instance Cmp Word64 where cmp = icmp-instance Cmp Int8 where cmp = icmp . adjSigned-instance Cmp Int16 where cmp = icmp . adjSigned-instance Cmp Int32 where cmp = icmp . adjSigned-instance Cmp Int64 where cmp = icmp . adjSigned-instance Cmp Float where cmp = fcmp . adjFloat-instance Cmp Double where cmp = fcmp . adjFloat-instance Cmp FP128 where cmp = fcmp . adjFloat+instance Cmp Bool Bool where cmp = icmp+instance Cmp Word8 Bool where cmp = icmp+instance Cmp Word16 Bool where cmp = icmp+instance Cmp Word32 Bool where cmp = icmp+instance Cmp Word64 Bool where cmp = icmp+instance Cmp Int8 Bool where cmp = icmp . adjSigned+instance Cmp Int16 Bool where cmp = icmp . adjSigned+instance Cmp Int32 Bool where cmp = icmp . adjSigned+instance Cmp Int64 Bool where cmp = icmp . adjSigned+instance Cmp Float Bool where cmp = fcmp . adjFloat+instance Cmp Double Bool where cmp = fcmp . adjFloat+instance Cmp FP128 Bool where cmp = fcmp . adjFloat+instance (IsPowerOf2 n) => Cmp (Vector n Bool) (Vector n Bool) where cmp = icmp+instance (IsPowerOf2 n) => Cmp (Vector n Word8) (Vector n Bool) where cmp = icmp+instance (IsPowerOf2 n) => Cmp (Vector n Word16) (Vector n Bool) where cmp = icmp+instance (IsPowerOf2 n) => Cmp (Vector n Word32) (Vector n Bool) where cmp = icmp+instance (IsPowerOf2 n) => Cmp (Vector n Word64) (Vector n Bool) where cmp = icmp+instance (IsPowerOf2 n) => Cmp (Vector n Int8) (Vector n Bool) where cmp = icmp . adjSigned+instance (IsPowerOf2 n) => Cmp (Vector n Int16) (Vector n Bool) where cmp = icmp . adjSigned+instance (IsPowerOf2 n) => Cmp (Vector n Int32) (Vector n Bool) where cmp = icmp . adjSigned+instance (IsPowerOf2 n) => Cmp (Vector n Int64) (Vector n Bool) where cmp = icmp . adjSigned+instance (IsPowerOf2 n) => Cmp (Vector n Float) (Vector n Bool) where cmp = fcmp . adjFloat+instance (IsPowerOf2 n) => Cmp (Vector n Double) (Vector n Bool) where cmp = fcmp . adjFloat+instance (IsPowerOf2 n) => Cmp (Vector n FP128) (Vector n Bool) where cmp = fcmp . adjFloat  adjSigned :: IntPredicate -> IntPredicate adjSigned IntUGT = IntSGT@@ -38,17 +56,18 @@ adjSigned IntULE = IntSLE adjSigned p = p -adjFloat :: IntPredicate -> RealPredicate-adjFloat IntEQ  = RealOEQ-adjFloat IntNE  = RealONE-adjFloat IntUGT = RealOGT-adjFloat IntUGE = RealOGE-adjFloat IntULT = RealOLT-adjFloat IntULE = RealOLE+adjFloat :: IntPredicate -> FPPredicate+adjFloat IntEQ  = FPOEQ+adjFloat IntNE  = FPONE+adjFloat IntUGT = FPOGT+adjFloat IntUGE = FPOGE+adjFloat IntULT = FPOLT+adjFloat IntULE = FPOLE adjFloat _ = error "adjFloat"  infix  4  %==, %/=, %<, %<=, %>=, %>-(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (Cmp a) => TValue r a -> TValue r a -> TValue r Bool+-- |Comparison functions.+(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (Cmp a b) => TValue r a -> TValue r a -> TValue r b (%==) = binop $ cmp IntEQ (%/=) = binop $ cmp IntNE (%>)  = binop $ cmp IntUGT@@ -58,12 +77,15 @@  infixr 3  %&& infixr 2  %||+-- |Lazy and. (%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool a %&& b = a ? (b, return (valueOf False))+-- |Lazy or. (%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool a %|| b = a ? (return (valueOf True), b)  infix  0 ?+-- |Conditional, returns first element of the pair when condition is true, otherwise second. (?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a c ? (t, f) = do     lt <- newBasicBlock@@ -82,45 +104,58 @@     defineBasicBlock lj     phi [(rt, lt'), (rf, lf')] +infix 0 ??+(??) :: (IsFirstClass a, CmpRet a b) => TValue r b -> (TValue r a, TValue r a) -> TValue r a+c ?? (t, f) = do+    c' <- c+    t' <- t+    f' <- f+    select c' t' f'++-- | Return a value from an 'arithFunction'. retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r () retrn x = x >>= ret +-- | Use @x <- set $ ...@ to make a binding.+set :: TValue r a -> (CodeGenFunction r (TValue r a))+set x = do x' <- x; return (return x')+ instance (Show (TValue r a)) instance (Eq (TValue r a)) instance (Ord (TValue r a)) -instance (Cmp a, Num a, IsArithmetic a, IsConst a) => Num (TValue r a) where+instance (Cmp a b, Num a, IsConst a) => Num (TValue r a) where     (+) = binop add     (-) = binop sub     (*) = binop mul     negate = (>>= neg)-    abs x = x %< 0 ? (-x, x)-    signum x = x %< 0 ? (-1, x %> 0 ? (1, 0))+    abs x = x %< 0 ?? (-x, x)+    signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0))     fromInteger = return . valueOf . fromInteger -instance (Cmp a, Num a, IsConst a, IsArithmetic a) => Enum (TValue r a) where+instance (Cmp a b, Num a, IsConst a) => Enum (TValue r a) where     succ x = x + 1     pred x = x - 1     fromEnum _ = error "CodeGenFunction Value: fromEnum"     toEnum = fromIntegral -instance (Cmp a, Num a, IsConst a, IsArithmetic a) => Real (TValue r a) where+instance (Cmp a b, Num a, IsConst a) => Real (TValue r a) where     toRational _ = error "CodeGenFunction Value: toRational" -instance (Cmp a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where+instance (Cmp a b, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where     quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)     rem  = binop (if (isSigned (undefined :: a)) then srem else urem)     quotRem x y = (quot x y, rem x y)     toInteger _ = error "CodeGenFunction Value: toInteger" -instance (Cmp a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where+instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where     (/) = binop fdiv     fromRational = return . valueOf . fromRational -instance (Cmp a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where+instance (Cmp a b, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where     properFraction _ = error "CodeGenFunction Value: properFraction" -instance (Cmp a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where+instance (Cmp a b, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where     pi = return $ valueOf pi     sqrt = callIntrinsic1 "sqrt"     sin = callIntrinsic1 "sin"@@ -139,7 +174,7 @@     acosh x          = log (x + sqrt (x*x - 1))     atanh x          = (log (1 + x) - log (1 - x)) / 2 -instance (Cmp a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where+instance (Cmp a b, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where     floatRadix _ = floatRadix (undefined :: a)     floatDigits _ = floatDigits (undefined :: a)     floatRange _ = floatRange (undefined :: a)@@ -161,34 +196,37 @@     y' <- y     op x' y' -callIntrinsic1 :: forall a b r . (IsArithmetic a, IsFirstClass b) =>-	          String -> TValue r a -> TValue r b-callIntrinsic1 fn x = do-    x' <- x-    op <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a))-    let _ = op :: Function (a -> IO b)-    call op x'+callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) =>+	           String -> Value a -> TValue r b+callIntrinsicP1 fn x = do+    op :: Function (a -> IO b) <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a))+    r <- call op x+    addAttributes r 0 [ReadNoneAttribute]+    return r -callIntrinsic2 :: forall a b c r . (IsArithmetic a, IsFirstClass b, IsFirstClass c) =>-	          String -> TValue r a -> TValue r b -> TValue r c-callIntrinsic2 fn x y = do-    x' <- x-    y' <- y-    op <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a))-    let _ = op :: Function (a -> b -> IO c)-    call op x' y'+callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) =>+	           String -> Value a -> Value b -> TValue r c+callIntrinsicP2 fn x y = do+    op :: Function (a -> b -> IO c) <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a))+    r <- call op x y+    addAttributes r 0 [ReadNoneAttribute]+    return r  -------------------------------------------  class ArithFunction a b | a -> b, b -> a where-    arithFunction :: a -> b+    arithFunction' :: a -> b  instance (Ret a r) => ArithFunction (CodeGenFunction r a) (CodeGenFunction r ()) where-    arithFunction x = x >>= ret+    arithFunction' x = x >>= ret  instance (ArithFunction b b') => ArithFunction (CodeGenFunction r a -> b) (a -> b') where-    arithFunction f = arithFunction . f . return+    arithFunction' f = arithFunction' . f . return +-- |Unlift a function with @TValue@ to have @Value@ arguments.+arithFunction :: ArithFunction a b => a -> b+arithFunction = arithFunction'+ -------------------------------------------  class UncurryN a b | a -> b, b -> a where@@ -213,18 +251,20 @@     liftTuple (a, b) = do a' <- a; b' <- liftTuple b; return (a', b')  class (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) =>-      UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b -> a where+      UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b1 -> a2 where     unwrapArgs :: a2 -> a instance (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) =>          UnwrapArgs a a1 b1 b a2 r where     unwrapArgs f = curryN $ \ x -> do x' <- liftTuple x; uncurryN f x' +-- |Lift a function from having @Value@ arguments to having @TValue@ arguments. toArithFunction :: (CallArgs f g, UnwrapArgs a a1 b1 b g r) =>                     Function f -> a toArithFunction f = unwrapArgs (call f)  ------------------------------------------- +-- |Define a recursive 'arithFunction', gets pased itself as the first argument. recursiveFunction ::         (CallArgs a g,          UnwrapArgs a11 a1 b1 b g r,@@ -237,4 +277,39 @@     let f' = toArithFunction f     defineFunction f $ arithFunction (af f')     return f++-------------------------------------------++class CallIntrinsic a where+    callIntrinsic1' :: String -> Value a -> TValue r a+    callIntrinsic2' :: String -> Value a -> Value a -> TValue r a++instance CallIntrinsic Float where+    callIntrinsic1' = callIntrinsicP1+    callIntrinsic2' = callIntrinsicP2++instance CallIntrinsic Double where+    callIntrinsic1' = callIntrinsicP1+    callIntrinsic2' = callIntrinsicP2++instance (IsPowerOf2 n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where+    callIntrinsic1' s = mapVector (callIntrinsic1' s)+    callIntrinsic2' s = mapVector2 (callIntrinsic2' s)++callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a+callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x'++callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a+callIntrinsic2 s x y = do x' <- x; y' <- y; callIntrinsic2' s x' y'++#if defined(__MACOS__)+instance CallIntrinsic (Vector (D4 End) Float) where+    callIntrinsic1' s x | hasVFun   = do op <- externFunction ("v" ++ s ++ "f")+    		      	  	         r <- call op x+					 addAttributes r 0 [ReadNoneAttribute]+					 return r+    		        | otherwise = mapVector (callIntrinsic1' s) x+      where hasVFun = s `elem` ["sqrt", "log", "exp", "sin", "cos", "tan"]+    callIntrinsic2' s = mapVector2 (callIntrinsic2' s)+#endif 

@@ -0,0 +1,48 @@+module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where+import System.Directory+import System.Process++import LLVM.Core+import LLVM.ExecutionEngine++writeCodeGenModule :: String -> CodeGenModule a -> IO ()+writeCodeGenModule name f = do+    m <- newModule+    defineModule m f+    writeBitcodeToFile name m++optimize :: String -> IO ()+optimize name = do+    _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name+    return ()++optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t)+optimizeFunction = fmap snd . optimizeFunction'++optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t)+optimizeFunction' mdl = do+    m <- newModule+    mf <- defineModule m mdl+    fName <- getValueName mf++    let name = "__tmp__" ++ fName ++ ".bc"+    writeBitcodeToFile name m++    optimize name++    m' <- readBitcodeFromFile name+    funcs <- getModuleValues m'++--    removeFile name++    let Just mf' = castModuleValue =<< lookup fName funcs++    return (m', mf')++optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t+optimizeFunctionCG mdl = do+    (m', mf') <- optimizeFunction' mdl+    rf <- runEngineAccess $ do+        addModule m'+        generateFunction mf'+    return rf

@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- These are replacements for the broken equivalents in Foreign.*.+-- The functions in Foreign.* do not obey the required alignment.+module LLVM.Util.Foreign where++import Foreign.Ptr(alignPtr, Ptr)+import Foreign.Storable(Storable(poke, sizeOf, alignment))+import Foreign.Marshal.Alloc(allocaBytes)+import Foreign.Marshal.Array(allocaArray, pokeArray)++with :: Storable a => a -> (Ptr a -> IO b) -> IO b+with x act =+    alloca $ \ p -> do+    poke p x+    act p++alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b+alloca act =+    allocaBytes (2 * sizeOf (undefined :: a)) $ \ p ->+       act $ alignPtr p (alignment (undefined :: a))++withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen xs act =+    let l = length xs in+    allocaArray (l+1) $ \ p -> do+    let p' = alignPtr p (alignment (head xs))+    pokeArray p' xs+    act l p'+

@@ -0,0 +1,109 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeOperators, FlexibleContexts #-}+module LLVM.Util.Loop(Phi, forLoop, mapVector, mapVector2) where+import Data.TypeNumbers+import LLVM.Core++class Phi a where+    phis :: BasicBlock -> a -> CodeGenFunction r a+    addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()++{-+infixr 1 :*+-- XXX should use HList if it was packaged in a nice way.+data a :* b = a :* b+    deriving (Eq, Ord, Show, Read)++instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where+    phis bb (a :* b) = do+        a' <- phi [(a, bb)]+        b' <- phis bb b+        return (a' :* b')+    addPhis bb (a :* b) (a' :* b') = do+        addPhiInputs a [(a', bb)]+        addPhis bb b b'+-}++instance Phi () where+    phis _ _ = return ()+    addPhis _ _ _ = return ()++instance (IsFirstClass a) => Phi (Value a) where+    phis bb a = do+        a' <- phi [(a, bb)]+        return a'+    addPhis bb a a' = do+        addPhiInputs a [(a', bb)]++instance (Phi a, Phi b) => Phi (a, b) where+    phis bb (a, b) = do+        a' <- phis bb a+        b' <- phis bb b+        return (a', b')+    addPhis bb (a, b) (a', b') = do+        addPhis bb a a'+        addPhis bb b b'++instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where+    phis bb (a, b, c) = do+        a' <- phis bb a+        b' <- phis bb b+        c' <- phis bb c+        return (a', b', c')+    addPhis bb (a, b, c) (a', b', c') = do+        addPhis bb a a'+        addPhis bb b b'+        addPhis bb c c'++-- Loop the index variable from low to high.  The state in the loop starts as start, and is modified+-- by incr in each iteration.+forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i Bool) =>+           Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a+forLoop low high start incr = do+    top <- getCurrentBasicBlock+    loop <- newBasicBlock+    body <- newBasicBlock+    exit <- newBasicBlock++    br loop++    defineBasicBlock loop+    i <- phi [(low, top)]+    vars <- phis top start+    t <- icmp IntNE i high+    condBr t body exit++    defineBasicBlock body++    vars' <- incr i vars+    i' <- add i (valueOf 1 :: Value i)++    body' <- getCurrentBasicBlock+    addPhis body' vars vars'+    addPhiInputs i [(i', body')]+    br loop+    defineBasicBlock exit++    return vars++--------------------------------------++mapVector :: forall a b n r .+             (IsPowerOf2 n, IsPrimitive b) =>+             (Value a -> CodeGenFunction r (Value b)) ->+             Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))+mapVector f v =+    forLoop (valueOf 0) (valueOf (typeNumber (undefined :: n))) (value undef) $ \ i w -> do+        x <- extractelement v i+        y <- f x+        insertelement w y i++mapVector2 :: forall a b c n r .+             (IsPowerOf2 n, IsPrimitive c) =>+             (Value a -> Value b -> CodeGenFunction r (Value c)) ->+             Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c))+mapVector2 f v1 v2 =+    forLoop (valueOf 0) (valueOf (typeNumber (undefined :: n))) (value undef) $ \ i w -> do+        x <- extractelement v1 i+        y <- extractelement v2 i+        z <- f x y+        insertelement w z i

@@ -49,7 +49,8 @@ 	-$(MAKE) -C tests clean 	-rm -f Setup.hi Setup.o 	-./setup clean-	-rm setup+	-rm -f setup setup.exe setup.exe.manifest+	-rm *~  distclean: clean 	-rm -f setup configure

@@ -1,3 +1,28 @@ #!/usr/bin/env runhaskell+> {-# LANGUAGE PatternGuards #-}+> import System.Environment+> import System.Info+> import Control.Monad+> import Data.List > import Distribution.Simple-> main = defaultMainWithHooks autoconfUserHooks+> import Distribution.Simple.Setup+> +> main = do+>     let hooks = if os == "mingw32" then autoconfUserHooks{ postConf = generateBuildInfo }+>                 else autoconfUserHooks+>     defaultMainWithHooks hooks+> +> -- On Windows we can't count on the configure script, so generate the+> -- llvm.buildinfo from a template.+> generateBuildInfo _ conf _ _ = do+>     let args = configConfigureArgs conf+>     let pref = "--with-llvm-prefix="+>     let path = case [ p | arg <- args, Just p <- [stripPrefix pref arg] ] of+>                [p] -> p+>                _ -> error $ "Use '--configure-option " ++ pref ++ "PATH' to give LLVM installation path"+>     info <- readFile "llvm.buildinfo.windows.in"+>     writeFile "llvm.buildinfo" $ subst "@llvm_path@" path info+> +> subst from to [] = []+> subst from to xs | Just r <- stripPrefix from xs = to ++ subst from to r+> subst from to (x:xs) = x : subst from to xs

@@ -2,29 +2,52 @@ {-# LANGUAGE ScopedTypeVariables #-} module Arith where import Data.Int+import Data.TypeNumbers import LLVM.Core import LLVM.ExecutionEngine import LLVM.Util.Arithmetic+import LLVM.Util.Foreign as F -mSomeFn :: forall a . (IsConst a, Floating a, IsFloating a, Cmp a,-	      FunctionRet a-	     ) => CodeGenModule (Function (a -> IO a))+import Foreign.Storable+{-+import Foreign.Ptr+import Foreign.Marshal.Utils+import Foreign.Marshal.Alloc as F+-}++mSomeFn :: forall a b . (IsConst a, Floating a, IsFloating a, CallIntrinsic a,+	                 FunctionRet a, Cmp a b+                        ) => CodeGenModule (Function (a -> IO a)) mSomeFn = do     foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y-    createFunction ExternalLinkage $ arithFunction $ \ x ->-        sqrt (x^2 - 5 * x + 6) + toArithFunction foo x x+    let foo' = toArithFunction foo+    createFunction ExternalLinkage $ arithFunction $ \ x -> do+        y <- set $ x^3+        sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y  mFib :: CodeGenModule (Function (Int32 -> IO Int32)) mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2)) +type V = Vector (D4 End) Float++mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+mVFun = do+    fn :: Function (V -> IO V)+       <- createFunction ExternalLinkage $ arithFunction $ \ x ->+            log x * exp x * x - 16++    vectorToPtr fn+ writeFunction :: String -> CodeGenModule a -> IO () writeFunction name f = do     m <- newModule     defineModule m f     writeBitcodeToFile name m + main :: IO () main = do+     let mSomeFn' = mSomeFn     ioSomeFn <- simpleFunction mSomeFn'     let someFn :: Double -> Double@@ -39,3 +62,27 @@      fib <- simpleFunction mFib     fib 22 >>= print+++    writeFunction "VArith.bc" mVFun++    ioVFun <- simpleFunction mVFun+    let v = toVector (1,2,3,4)++    r <- vectorPtrWrap ioVFun v+    print r++vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+vectorToPtr f =+    createFunction ExternalLinkage $ \ px py -> do+        x <- load px+        y <- call f x+        store y py+	ret ()++vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V+vectorPtrWrap f v =+    with v $ \ aPtr ->+        F.alloca $ \ bPtr -> do+             f aPtr bPtr+             peek bPtr

@@ -3,8 +3,7 @@  import LLVM.Core --import LLVM.ExecutionEngine--import Loop+import LLVM.Util.Loop  cg :: CodeGenModule (Function (Double -> IO (Ptr Double))) cg = do

@@ -14,7 +14,6 @@ -- ]         }               End loop -- import Control.Monad(when)-import Control.Monad.Trans import Data.Word import Data.Int import System.Environment(getArgs)@@ -36,13 +35,22 @@                "++++++++++."     prog <- if length args == 1 then readFile (head args) else return text +    when (debug) $+        writeFunction "BrainF.bc" $ brainCompile debug prog 65536+     bfprog <- simpleFunction $ brainCompile debug prog 65536     when (prog == text) $         putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:"     bfprog +writeFunction :: String -> CodeGenModule a -> IO ()+writeFunction name f = do+    m <- newModule+    defineModule m f+    writeBitcodeToFile name m+ brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ()))-brainCompile debug instrs wmemtotal = do+brainCompile _debug instrs wmemtotal = do     -- LLVM functions     memset    <- newNamedFunction ExternalLinkage "llvm.memset.i32"               :: TFunction (Ptr Word8 -> Word8 -> Word32 -> Word32 -> IO ())@@ -124,7 +132,7 @@         gen _ c = error $ "Bad character in program: " ++ show c  -    brainf <- createFunction InternalLinkage $ do+    brainf <- createFunction ExternalLinkage $ do         ptr_arr <- arrayMalloc wmemtotal         call memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) --        _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ())@@ -136,8 +144,5 @@          free ptr_arr         ret ()--    when (debug) $-        liftIO $ dumpValue brainf      return brainf

@@ -2,13 +2,10 @@ module DotProd where import Data.Word import Data.TypeNumbers-import Foreign.Marshal.Array(allocaArray, pokeArray)-import Foreign.Ptr-import Foreign.Storable import LLVM.Core import LLVM.ExecutionEngine--import Loop+import LLVM.Util.Loop+import LLVM.Util.Foreign  mDotProd :: forall n a . (IsPowerOf2 n, IsTypeNumber n, 	                  IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a,@@ -46,8 +43,6 @@          unsafePurify $          withArrayLen a $ \ aLen aPtr ->          withArrayLen b $ \ bLen bPtr ->--- XXX something weird is going on here.  Without that putStr the result is wrong.-         putStr "" >>          ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr  @@ -62,34 +57,26 @@     defineModule m f     writeBitcodeToFile name m -withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b-withArrayLen xs act =-    let l = length xs in-    allocaArray (l+1) $ \ p -> do-    let p' = alignPtr p (alignment (head xs))-    pokeArray p' xs-    act l p'- class Vectorize n a where     vectorize :: a -> [a] -> [Vector n a]  {- instance (IsPrimitive a) => Vectorize (D1 End) a where     vectorize _ [] = []-    vectorize x (x1:xs) = mkVector x1 : vectorize x xs+    vectorize x (x1:xs) = toVector x1 : vectorize x xs -}  instance (IsPrimitive a) => Vectorize (D2 End) a where     vectorize _ [] = []-    vectorize x (x1:x2:xs) = mkVector (x1, x2) : vectorize x xs+    vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs     vectorize x xs = vectorize x $ xs ++ [x]  instance (IsPrimitive a) => Vectorize (D4 End) a where     vectorize _ [] = []-    vectorize x (x1:x2:x3:x4:xs) = mkVector (x1, x2, x3, x4) : vectorize x xs+    vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs     vectorize x xs = vectorize x $ xs ++ [x]  instance (IsPrimitive a) => Vectorize (D8 End) a where     vectorize _ [] = []-    vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = mkVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs+    vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs     vectorize x xs = vectorize x $ xs ++ [x]

@@ -1,83 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, TypeOperators #-}-module Loop(Phi, (:*)(..), forLoop) where-import LLVM.Core--class Phi a where-    phis :: BasicBlock -> a -> CodeGenFunction r a-    addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()--infixr 1 :*--- XXX should use HList if it was packaged in a nice way.-data a :* b = a :* b-    deriving (Eq, Ord, Show, Read)--instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where-    phis bb (a :* b) = do-        a' <- phi [(a, bb)]-        b' <- phis bb b-        return (a' :* b')-    addPhis bb (a :* b) (a' :* b') = do-        addPhiInputs a [(a', bb)]-        addPhis bb b b'--instance Phi () where-    phis _ _ = return ()-    addPhis _ _ _ = return ()--instance (IsFirstClass a) => Phi (Value a) where-    phis bb a = do-        a' <- phi [(a, bb)]-        return a'-    addPhis bb a a' = do-        addPhiInputs a [(a', bb)]--instance (Phi a, Phi b) => Phi (a, b) where-    phis bb (a, b) = do-        a' <- phis bb a-        b' <- phis bb b-        return (a', b')-    addPhis bb (a, b) (a', b') = do-        addPhis bb a a'-        addPhis bb b b'--instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where-    phis bb (a, b, c) = do-        a' <- phis bb a-        b' <- phis bb b-        c' <- phis bb c-        return (a', b', c')-    addPhis bb (a, b, c) (a', b', c') = do-        addPhis bb a a'-        addPhis bb b b'-        addPhis bb c c'---- Loop the index variable from low to high.  The state in the loop starts as start, and is modified--- by incr in each iteration.-forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i) =>-           Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a-forLoop low high start incr = do-    top <- getCurrentBasicBlock-    loop <- newBasicBlock-    body <- newBasicBlock-    exit <- newBasicBlock--    br loop--    defineBasicBlock loop-    i <- phi [(low, top)]-    vars <- phis top start-    t <- icmp IntNE i high-    condBr t body exit--    defineBasicBlock body--    vars' <- incr i vars-    i' <- add i (valueOf 1 :: Value i)--    body' <- getCurrentBasicBlock-    addPhis body' vars vars'-    addPhiInputs i [(i', body')]-    br loop-    defineBasicBlock exit--    return vars

@@ -5,8 +5,7 @@  all: $(examples) -Vector:	Loop.hs Convert.hs-Array: Loop.hs+Vector:	Convert.hs  %: %.hs 	$(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<@@ -27,4 +26,4 @@ 	@echo Have a look at Fib.s if you like to see clever code.  clean:-	rm -f $(examples) *.o *.hi *.s *.bc Fib+	rm -f $(examples) *.o *.hi *.s *.bc Fib *.exe *.exe.manifest

@@ -7,8 +7,8 @@  import LLVM.Core import LLVM.ExecutionEngine+import LLVM.Util.Loop -import Loop import Convert  -- Type of vector elements.

@@ -0,0 +1,4 @@+ghc-options: -I@llvm_path@/include  -D_DEBUG  -D_GNU_SOURCE -D__STDC_LIMIT_MACROS -pgml g+++ld-options: -L@llvm_path@/lib @llvm_path@/lib/LLVMX86AsmPrinter.o -lLLVMAsmPrinter @llvm_path@/lib/LLVMX86CodeGen.o -lLLVMSelectionDAG @llvm_path@/lib/LLVMExecutionEngine.o @llvm_path@/lib/LLVMInterpreter.o @llvm_path@/lib/LLVMJIT.o -lLLVMCodeGen -lLLVMipo -lLLVMScalarOpts -lLLVMTransformUtils -lLLVMipa -lLLVMAnalysis -lLLVMTarget -lLLVMCore -lLLVMSupport -lLLVMSystem -lpsapi -limagehlp -lstdc+++include-dirs: @llvm_path@/include+extra-libraries: LLVMAnalysis LLVMBitWriter LLVMBitReader LLVMCore LLVMTarget LLVMSupport LLVMSystem

@@ -1,5 +1,5 @@ name: llvm-version: 0.5.0.1+version: 0.6.0.2 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit@@ -11,7 +11,7 @@ category: Compilers/Interpreters, Code Generation tested-with: GHC == 6.8.2, GHC == 6.10.1 cabal-version: >= 1.2.3-build-type: Configure+build-type: Custom  extra-source-files:     INSTALL.txt@@ -27,7 +27,6 @@     examples/DotProd.hs     examples/Fibonacci.hs     examples/HelloJIT.hs-    examples/Loop.hs     examples/Vector.hs     examples/Makefile     examples/mainfib.c@@ -36,6 +35,7 @@     tools/Makefile     tools/IntrinsicMangler.hs     llvm.buildinfo.in+    llvm.buildinfo.windows.in  extra-tmp-files:     autom4te.cache@@ -55,11 +55,16 @@     build-depends: base >= 2.0 && < 2.2     cpp-options:   -DBYTESTRING_IN_BASE   else-    build-depends: base < 2.0 || >= 2.2, bytestring >= 0.9, mtl+    build-depends: base < 2.0 || >= 2.2, bytestring >= 0.9, mtl, directory, process    ghc-options: -Wall---  cpp-options: -DHAS_GETPOINTERTOGLOBAL=1+  cpp-options: -DHAS_GETPOINTERTOGLOBAL=1 +  if os(darwin)+    ld-options: -w /System/Library/Frameworks/vecLib.framework/Versions/A/vecLib+    cpp-options: -D__MACOS__++   exposed-modules:       Data.TypeNumbers       LLVM.Core@@ -72,6 +77,9 @@       LLVM.FFI.Target       LLVM.FFI.Transforms.Scalar       LLVM.Util.Arithmetic+      LLVM.Util.File+      LLVM.Util.Foreign+      LLVM.Util.Loop    other-modules:       LLVM.Core.CodeGen