llvm 0.9.0.1 → 0.9.1.0
raw patch · 22 files changed
+932/−264 lines, 22 filessetup-changednew-uploader
Files
- LLVM/Core.hs +1/−2
- LLVM/Core/CodeGenMonad.hs +3/−2
- LLVM/Core/Instructions.hs +268/−57
- LLVM/Core/Type.hs +27/−17
- LLVM/Core/Util.hs +4/−4
- LLVM/ExecutionEngine/Engine.hs +3/−2
- LLVM/FFI/Core.hsc +3/−0
- LLVM/FFI/Transforms/IPO.hsc +2/−0
- LLVM/FFI/Transforms/Scalar.hsc +2/−0
- LLVM/Target/MSIL.hs +0/−10
- LLVM/Util/Arithmetic.hs +65/−35
- LLVM/Util/File.hs +2/−2
- LLVM/Util/Loop.hs +1/−1
- LLVM/Util/Memory.hs +89/−0
- LLVM/Util/Optimize.hs +172/−71
- Setup.hs +15/−16
- cbits/malloc.c +190/−0
- examples/BrainF.hs +24/−13
- examples/Fibonacci.hs +2/−2
- examples/List.hs +1/−1
- examples/Makefile +24/−2
- llvm.cabal +34/−27
LLVM/Core.hs view
@@ -75,8 +75,7 @@ import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) import LLVM.Core.CodeGen import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule, GlobalMappings, getGlobalMappings)-import LLVM.Core.Data hiding (Vector, Array)-import LLVM.Core.Data(Vector, Array)+import LLVM.Core.Data import LLVM.Core.Instructions import LLVM.Core.Type import LLVM.Core.Vector
LLVM/Core/CodeGenMonad.hs view
@@ -10,6 +10,7 @@ ) where import Data.Typeable import Control.Monad.State+import Control.Applicative (Applicative, ) import Foreign.Ptr (Ptr, ) @@ -25,7 +26,7 @@ } deriving (Show, Typeable) newtype CodeGenModule a = CGM (StateT CGMState IO a)- deriving (Functor, Monad, MonadState CGMState, MonadIO, Typeable)+ deriving (Functor, Applicative, Monad, MonadState CGMState, MonadIO, Typeable) genMSym :: String -> CodeGenModule String genMSym prefix = do@@ -52,7 +53,7 @@ } deriving (Show, Typeable) newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)- deriving (Functor, Monad, MonadState (CGFState r), MonadIO, Typeable)+ deriving (Functor, Applicative, Monad, MonadState (CGFState r), MonadIO, Typeable) genFSym :: CodeGenFunction a String genFSym = do
LLVM/Core/Instructions.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, FlexibleContexts, TypeOperators, DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, FlexibleContexts, TypeOperators, DeriveDataTypeable, ForeignFunctionInterface #-} module LLVM.Core.Instructions( -- * Terminator instructions ret,@@ -12,7 +12,9 @@ -- | Arithmetic operations with the normal semantics. -- The u instractions are unsigned, the s instructions are signed. add, sub, mul, neg,- fadd, fsub, fmul, -- fneg,+ iadd, isub, imul, ineg,+ fadd, fsub, fmul, fneg,+ idiv, irem, udiv, sdiv, fdiv, urem, srem, frem, -- * Logical binary operations -- |Logical instructions with the normal semantics.@@ -21,7 +23,7 @@ extractelement, insertelement, shufflevector,- -- * Aggregate operations+ -- * Aggregate operation extractvalue, insertvalue, -- * Memory access@@ -39,14 +41,14 @@ ptrtoint, inttoptr, bitcast, bitcastUnify, -- * Comparison- IntPredicate(..), FPPredicate(..),+ CmpPredicate(..), IntPredicate(..), FPPredicate(..), CmpRet,- icmp, fcmp,+ cmp, pcmp, icmp, fcmp, select, -- * Other phi, addPhiInputs, call, callWithConv,- + -- * Classes and types Terminate, Ret, CallArgs, ABinOp, CmpOp, FunctionArgs, FunctionRet, IsConst,@@ -58,8 +60,9 @@ import Control.Monad(liftM) import Data.Int import Data.Word+import Foreign.Ptr (FunPtr, ) import Foreign.C(CInt, CUInt)-import Data.TypeLevel((:<:), (:>:), (:==:), D0, toNum, Succ)+import Data.TypeLevel((:<:), (:>:), (:==:), D0, d1, toNum, Succ) import qualified LLVM.FFI.Core as FFI import LLVM.Core.Data import LLVM.Core.Type@@ -157,17 +160,63 @@ type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef ++withArithmeticType ::+ (IsArithmetic c) =>+ (ArithmeticType c -> a -> CodeGenFunction r (v c)) ->+ (a -> CodeGenFunction r (v c))+withArithmeticType f = f arithmeticType+ -- |Acceptable arguments to arithmetic binary instructions. class ABinOp a b c | a b -> c where abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r c -add :: ({-IsInteger-} IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)-add = abinop FFI.constAdd FFI.buildAdd-sub :: ({-IsInteger-} IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)-sub = abinop FFI.constSub FFI.buildSub-mul :: ({-IsInteger-} IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)-mul = abinop FFI.constMul FFI.buildMul+add :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)+add =+ curry $ withArithmeticType $ \typ -> uncurry $ case typ of+ IntegerType -> abinop FFI.constAdd FFI.buildAdd+ FloatingType -> abinop FFI.constFAdd FFI.buildFAdd +sub :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)+sub =+ curry $ withArithmeticType $ \typ -> uncurry $ case typ of+ IntegerType -> abinop FFI.constSub FFI.buildSub+ FloatingType -> abinop FFI.constFSub FFI.buildFSub++mul :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)+mul =+ curry $ withArithmeticType $ \typ -> uncurry $ case typ of+ IntegerType -> abinop FFI.constMul FFI.buildMul+ FloatingType -> abinop FFI.constFMul FFI.buildFMul++iadd :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)+iadd = abinop FFI.constAdd FFI.buildAdd+isub :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)+isub = abinop FFI.constSub FFI.buildSub+imul :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)+imul = abinop FFI.constMul FFI.buildMul++-- | signed or unsigned integer division depending on the type+idiv ::+ forall a b c r v. (IsInteger c, ABinOp a b (v c)) =>+ a -> b -> CodeGenFunction r (v c)+idiv =+ if isSigned (undefined :: c)+ then abinop FFI.constSDiv FFI.buildSDiv+ else abinop FFI.constUDiv FFI.buildUDiv+-- | signed or unsigned remainder depending on the type+irem ::+ forall a b c r v. (IsInteger c, ABinOp a b (v c)) =>+ a -> b -> CodeGenFunction r (v c)+irem =+ if isSigned (undefined :: c)+ then abinop FFI.constSRem FFI.buildSRem+ else abinop FFI.constURem FFI.buildURem++{-# DEPRECATED udiv "use idiv instead" #-}+{-# DEPRECATED sdiv "use idiv instead" #-}+{-# DEPRECATED urem "use irem instead" #-}+{-# DEPRECATED srem "use irem instead" #-} udiv :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) udiv = abinop FFI.constUDiv FFI.buildUDiv sdiv :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c)@@ -240,11 +289,18 @@ withCurrentBuilder $ \ bld -> U.withEmptyCString $ op bld a -neg :: ({-IsInteger-} IsArithmetic a) => Value a -> CodeGenFunction r (Value a)-neg (Value x) = buildUnOp FFI.buildNeg x+neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)+neg =+ withArithmeticType $ \typ -> case typ of+ IntegerType -> \(Value x) -> buildUnOp FFI.buildNeg x+ FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a) +ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)+ineg (Value x) = buildUnOp FFI.buildNeg x++fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a)+fneg = fsub (value zero :: Value a) {--fneg :: (IsFloating a) => Value a -> CodeGenFunction r (Value a) fneg (Value x) = buildUnOp FFI.buildFNeg x -} @@ -274,14 +330,12 @@ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i --- XXX The documentation say the mask and result can different length from--- the two first operand, but the C++ code doesn't do that. -- | Permute vector.-shufflevector :: (Pos n)+shufflevector :: (Pos n, Pos m) => Value (Vector n a) -> Value (Vector n a)- -> ConstValue (Vector n Word32)- -> CodeGenFunction r (Value (Vector n a))+ -> ConstValue (Vector m Word32)+ -> CodeGenFunction r (Value (Vector m a)) shufflevector (Value a) (Value b) (ConstValue mask) = liftM Value $ withCurrentBuilder $ \ bldPtr ->@@ -402,6 +456,46 @@ -------------------------------------- +data CmpPredicate =+ CmpEQ -- ^ equal+ | CmpNE -- ^ not equal+ | CmpGT -- ^ greater than+ | CmpGE -- ^ greater or equal+ | CmpLT -- ^ less than+ | CmpLE -- ^ less or equal+ deriving (Eq, Ord, Enum, Show, Typeable)++uintFromCmpPredicate :: CmpPredicate -> IntPredicate+uintFromCmpPredicate p =+ case p of+ CmpEQ -> IntEQ+ CmpNE -> IntNE+ CmpGT -> IntUGT+ CmpGE -> IntUGE+ CmpLT -> IntULT+ CmpLE -> IntULE++sintFromCmpPredicate :: CmpPredicate -> IntPredicate+sintFromCmpPredicate p =+ case p of+ CmpEQ -> IntEQ+ CmpNE -> IntNE+ CmpGT -> IntSGT+ CmpGE -> IntSGE+ CmpLT -> IntSLT+ CmpLE -> IntSLE++fpFromCmpPredicate :: CmpPredicate -> FPPredicate+fpFromCmpPredicate p =+ case p of+ CmpEQ -> FPOEQ+ CmpNE -> FPONE+ CmpGT -> FPOGT+ CmpGE -> FPOGE+ CmpLT -> FPOLT+ CmpLE -> FPOLE++ data IntPredicate = IntEQ -- ^ equal | IntNE -- ^ not equal@@ -453,22 +547,63 @@ 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 (Ptr a) Bool-instance (Pos n) => CmpRet (Vector n a) (Vector n Bool)+class CmpRet c d | c -> d where+ cmpBld :: c -> CmpPredicate -> FFIBinOp+instance CmpRet Float Bool where cmpBld _ = fcmpBld+instance CmpRet Double Bool where cmpBld _ = fcmpBld+instance CmpRet FP128 Bool where cmpBld _ = fcmpBld+instance CmpRet Bool Bool where cmpBld _ = ucmpBld+instance CmpRet Word8 Bool where cmpBld _ = ucmpBld+instance CmpRet Word16 Bool where cmpBld _ = ucmpBld+instance CmpRet Word32 Bool where cmpBld _ = ucmpBld+instance CmpRet Word64 Bool where cmpBld _ = ucmpBld+instance CmpRet Int8 Bool where cmpBld _ = scmpBld+instance CmpRet Int16 Bool where cmpBld _ = scmpBld+instance CmpRet Int32 Bool where cmpBld _ = scmpBld+instance CmpRet Int64 Bool where cmpBld _ = scmpBld+instance CmpRet (Ptr a) Bool where cmpBld _ = ucmpBld+instance (CmpRet a b, IsPrimitive a, Pos n) =>+ CmpRet (Vector n a) (Vector n b)+ where cmpBld _ = cmpBld (undefined :: a) ++{- |+Compare values of ordered types+and choose predicates according to the compared types.+Floating point numbers are compared in \"ordered\" mode,+that is @NaN@ operands yields 'False' as result.+Pointers are compared unsigned.+These choices are consistent with comparison in plain Haskell.+-}+cmp :: forall a b c d r.+ (CmpOp a b c d, CmpRet c d) =>+ CmpPredicate -> a -> b -> CodeGenFunction r (Value d)+cmp p = cmpop (cmpBld (undefined :: c) p)++ucmpBld :: CmpPredicate -> FFIBinOp+ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))++scmpBld :: CmpPredicate -> FFIBinOp+scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))++fcmpBld :: CmpPredicate -> FFIBinOp+fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p))+++_ucmp :: (IsInteger c, CmpOp a b c d, CmpRet c d) =>+ CmpPredicate -> a -> b -> CodeGenFunction r (Value d)+_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)))++_scmp :: (IsInteger c, CmpOp a b c d, CmpRet c d) =>+ CmpPredicate -> a -> b -> CodeGenFunction r (Value d)+_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)))++pcmp :: (CmpOp a b (Ptr c) d, CmpRet (Ptr c) d) =>+ IntPredicate -> a -> b -> CodeGenFunction r (Value d)+pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))+++{-# DEPRECATED icmp "use cmp or pcmp instead" #-} -- | Compare integers. icmp :: (IsIntegerOrPointer c, CmpOp a b c d, CmpRet c d) => IntPredicate -> a -> b -> CodeGenFunction r (Value d)@@ -509,7 +644,7 @@ doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a) doCallDef mkCall args _ =- withCurrentBuilder $ \ bld -> + withCurrentBuilder $ \ bld -> liftM Value $ mkCall bld (reverse args) -- | Call a function with the given arguments. The 'call' instruction is variadic, i.e., the number of arguments@@ -556,7 +691,7 @@ -- |Join several variables (virtual registers) from different basic blocks into one. -- All of the variables in the list are joined. See also 'addPhiInputs'. phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)-phi incoming = +phi incoming = liftM Value $ withCurrentBuilder $ \ bldPtr -> do inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a))@@ -572,38 +707,82 @@ -> CodeGenFunction r () addPhiInputs (Value inst) incoming = liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]- + -------------------------------------- -- | Acceptable argument to array memory allocation. class AllocArg a where- getAllocArg :: a -> FFI.ValueRef+ getAllocArg :: a -> Value Word32 instance AllocArg (Value Word32) where- getAllocArg (Value v) = v+ getAllocArg = id instance AllocArg (ConstValue Word32) where- getAllocArg = unConst+ getAllocArg = value instance AllocArg Word32 where- getAllocArg = unConst . constOf+ getAllocArg = valueOf +-- could be moved to Util.Memory+-- FFI.buildMalloc deprecated since LLVM-2.7 -- XXX What's the type returned by malloc -- | Allocate heap memory. malloc :: forall a r s . (IsSized a s) => CodeGenFunction r (Value (Ptr a))-malloc =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $ FFI.buildMalloc bldPtr (typeRef (undefined :: a))+malloc = arrayMalloc (1::Word32) +{-+I use a pointer type as size parameter of 'malloc'.+This way I hope that the parameter has always the correct size (32 or 64 bit).+A side effect is that we can convert the result of 'getelementptr' using 'bitcast',+that does not suffer from the slow assembly problem. (bug #8281)+-}+foreign import ccall "&aligned_malloc_sizeptr"+ alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))++foreign import ccall "&aligned_free"+ alignedFree :: FunPtr (Ptr Word8 -> IO ())+++{-+There is a bug in LLVM-2.7 and LLVM-2.8+(http://llvm.org/bugs/show_bug.cgi?id=8281)+that causes huge assembly times for expressions like+ptrtoint(getelementptr(zero,..)).+If you break those expressions into two statements+at separate lines, everything is fine.+But the C interface is too clever,+and rewrites two separate statements into a functional expression on a single line.+Such code is generated whenever you call+buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.+One possible way is to write a getelementptr expression+containing a nullptr in a way+that hides the constant nature of nullptr.++ ptr <- alloca+ store (value zero) ptr+ z <- load ptr+ size <- bitcastUnify =<<+ getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())++However, I found that bitcast on pointers causes no problems.+Thus I switched to using pointers for size quantities.+This still allows for optimizations involving pointers.+-}+ -- XXX What's the type returned by arrayMalloc? -- | Allocate heap (array) memory. arrayMalloc :: forall a n r s . (IsSized a n, AllocArg s) => s -> CodeGenFunction r (Value (Ptr a)) -- XXX-arrayMalloc s =- liftM Value $- withCurrentBuilder $ \ bldPtr ->- U.withEmptyCString $- FFI.buildArrayMalloc bldPtr (typeRef (undefined :: a)) (getAllocArg s)+arrayMalloc s = do+ func <- staticFunction alignedMalloc+-- func <- externFunction "malloc" + size <- sizeOfArray (undefined :: a) (getAllocArg s)+ alignment <- alignOf (undefined :: a)+ bitcastUnify =<<+ call+ (func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)))+ size+ alignment+ -- XXX What's the type returned by malloc -- | Allocate stack memory. alloca :: forall a r s . (IsSized a s) => CodeGenFunction r (Value (Ptr a))@@ -620,14 +799,46 @@ liftM Value $ withCurrentBuilder $ \ bldPtr -> U.withEmptyCString $- FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (getAllocArg s)+ FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (case getAllocArg s of Value v -> v) +-- FFI.buildFree deprecated since LLVM-2.7 -- XXX What's the type of free? -- | Free heap memory.-free :: Value (Ptr a) -> CodeGenFunction r ()-free (Value a) =- liftM (const ()) $- withCurrentBuilder $ \ bldPtr -> FFI.buildFree bldPtr a+free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()+free ptr = do+ func <- staticFunction alignedFree+-- func <- externFunction "free"+ _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcastUnify ptr+ return ()+++-- | If we want to export that, then we should have a Size type+-- This is the official implementation,+-- but it suffers from the ptrtoint(gep) bug.+_sizeOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value Word64)+_sizeOf a =+ liftIO $ liftM Value $+ FFI.sizeOf (typeRef a)++_alignOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value Word64)+_alignOf a =+ liftIO $ liftM Value $+ FFI.alignOf (typeRef a)+++-- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.+-- see ConstantExpr::getSizeOf+sizeOfArray :: forall a r s . (IsSized a s) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8))+sizeOfArray _ len =+ bitcastUnify =<<+ getElementPtr (value zero :: Value (Ptr a)) (len, ())++-- see ConstantExpr::getAlignOf+alignOf :: forall a r s . (IsSized a s) => a -> CodeGenFunction r (Value (Ptr Word8))+alignOf _ =+ bitcastUnify =<<+ getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())+ -- | Load a value from memory. load :: Value (Ptr a) -- ^ Address to load from.
LLVM/Core/Type.hs view
@@ -10,7 +10,8 @@ -- ** Special type classifiers Nat, Pos,- IsArithmetic,+ IsArithmetic(arithmeticType),+ ArithmeticType(IntegerType,FloatingType), IsInteger, IsIntegerOrPointer, IsFloating,@@ -95,8 +96,15 @@ -- 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+class IsFirstClass a => IsArithmetic a where+ arithmeticType :: ArithmeticType a +data ArithmeticType a = IntegerType | FloatingType++instance Functor ArithmeticType where+ fmap _ IntegerType = IntegerType+ fmap _ FloatingType = FloatingType+ -- Usage: -- constI, allOnes -- many instructions. XXX some need vector@@ -240,21 +248,23 @@ a & as = (a, as) --- Instances to classify types-instance IsArithmetic Float-instance IsArithmetic Double-instance IsArithmetic FP128-instance (Pos n) => IsArithmetic (IntN n)-instance (Pos 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 (Pos n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a)+instance IsArithmetic Float where arithmeticType = FloatingType+instance IsArithmetic Double where arithmeticType = FloatingType+instance IsArithmetic FP128 where arithmeticType = FloatingType+instance (Pos n) => IsArithmetic (IntN n) where arithmeticType = IntegerType+instance (Pos n) => IsArithmetic (WordN n) where arithmeticType = IntegerType+instance IsArithmetic Bool where arithmeticType = IntegerType+instance IsArithmetic Int8 where arithmeticType = IntegerType+instance IsArithmetic Int16 where arithmeticType = IntegerType+instance IsArithmetic Int32 where arithmeticType = IntegerType+instance IsArithmetic Int64 where arithmeticType = IntegerType+instance IsArithmetic Word8 where arithmeticType = IntegerType+instance IsArithmetic Word16 where arithmeticType = IntegerType+instance IsArithmetic Word32 where arithmeticType = IntegerType+instance IsArithmetic Word64 where arithmeticType = IntegerType+instance (Pos n, IsPrimitive a, IsArithmetic a) =>+ IsArithmetic (Vector n a) where+ arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType instance IsFloating Float instance IsFloating Double
LLVM/Core/Util.hs view
@@ -288,7 +288,7 @@ makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value makeCall = makeCallWithCc FFI.C- + makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value makeCallWithCc cc func bldPtr args = do {-@@ -324,7 +324,7 @@ withEmptyCString $ FFI.buildPhi bldPtr typ withEmptyCString :: (CString -> IO a) -> IO a-withEmptyCString = withCString "" +withEmptyCString = withCString "" addPhiIns :: Value -> [(Value, BasicBlock)] -> IO () addPhiIns inst incoming = do@@ -399,14 +399,14 @@ -- The unsafePerformIO is just for the non-effecting withArrayLen constVector :: Int -> [Value] -> Value constVector n xs = unsafePerformIO $ do- let xs' = take n (cycle xs) + let xs' = take n (cycle xs) withArrayLen xs' $ \ len ptr -> return $ FFI.constVector ptr (fromIntegral len) -- The unsafePerformIO is just for the non-effecting withArrayLen constArray :: Type -> Int -> [Value] -> Value constArray t n xs = unsafePerformIO $ do- let xs' = take n (cycle xs) + let xs' = take n (cycle xs) withArrayLen xs' $ \ len ptr -> return $ FFI.constArray t ptr (fromIntegral len)
LLVM/ExecutionEngine/Engine.hs view
@@ -15,6 +15,7 @@ GenericValue, Generic(..) ) where import Control.Monad.State+import Control.Applicative (Applicative, ) import Control.Concurrent.MVar import Data.Typeable import Data.Int@@ -126,7 +127,7 @@ deriving (Show, Typeable) newtype EngineAccess a = EA (StateT EAState IO a)- deriving (Functor, Monad, MonadState EAState, MonadIO)+ deriving (Functor, Applicative, Monad, MonadState EAState, MonadIO) -- |The LLVM execution engine is encapsulated so it cannot be accessed directly. -- The reason is that (currently) there must only ever be one engine,@@ -181,7 +182,7 @@ -} addGlobalMappings :: GlobalMappings -> EngineAccess () addGlobalMappings (GlobalMappings gms) =- mapM_ (uncurry addFunctionValueCore) gms+ mapM_ (uncurry addFunctionValueCore) gms addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess () addFunctionValueCore g f = do
LLVM/FFI/Core.hsc view
@@ -403,6 +403,7 @@ , PassManagerRef , createFunctionPassManager , createPassManager+ , disposePassManager , ptrDisposePassManager , finalizeFunctionPassManager , initializeFunctionPassManager@@ -1344,6 +1345,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
LLVM/FFI/Transforms/IPO.hsc view
@@ -26,6 +26,8 @@ :: PassManagerRef -> IO () foreign import ccall unsafe "LLVMAddPruneEHPass" addPruneEHPass :: PassManagerRef -> IO ()+foreign import ccall unsafe "LLVMAddIPSCCPPass" addIPSCCPPass+ :: PassManagerRef -> IO () foreign import ccall unsafe "LLVMAddRaiseAllocationsPass" addRaiseAllocationsPass :: PassManagerRef -> IO () foreign import ccall unsafe "LLVMAddStripDeadPrototypesPass" addStripDeadPrototypesPass
LLVM/FFI/Transforms/Scalar.hsc view
@@ -48,3 +48,5 @@ :: PassManagerRef -> IO () foreign import ccall unsafe "LLVMAddTailCallEliminationPass" addTailCallEliminationPass :: PassManagerRef -> IO ()+foreign import ccall unsafe "LLVMAddVerifierPass" addVerifierPass+ :: PassManagerRef -> IO ()
− LLVM/Target/MSIL.hs
@@ -1,10 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module LLVM.Target.MSIL(initializeTarget) where--initializeTarget :: IO ()-initializeTarget = do- initializeMSILTargetInfo- initializeMSILTarget--foreign import ccall unsafe "LLVMInitializeMSILTargetInfo" initializeMSILTargetInfo :: IO ()-foreign import ccall unsafe "LLVMInitializeMSILTarget" initializeMSILTarget :: IO ()
LLVM/Util/Arithmetic.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies, OverlappingInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies #-} module LLVM.Util.Arithmetic( TValue, Cmp(..),@@ -14,13 +14,15 @@ ) where import Data.Word import Data.Int-import Data.TypeLevel (D4)-import LLVM.Core+import qualified Data.TypeLevel.Num as TypeNum+import qualified LLVM.Core as LLVM+import LLVM.Core hiding (cmp, ) import LLVM.Util.Loop(mapVector, mapVector2) -- |Synonym for @CodeGenFunction r (Value a)@. type TValue r a = CodeGenFunction r (Value a) +{-# DEPRECATED cmp "use LLVM.Core.cmp instead" #-} class (CmpRet a b) => Cmp a b | a -> b where cmp :: IntPredicate -> Value a -> Value a -> TValue r b @@ -73,13 +75,13 @@ infix 4 %==, %/=, %<, %<=, %>=, %> -- |Comparison functions.-(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (Cmp a b) => TValue r a -> TValue r a -> TValue r b-(%==) = binop $ cmp IntEQ-(%/=) = binop $ cmp IntNE-(%>) = binop $ cmp IntUGT-(%>=) = binop $ cmp IntUGE-(%<) = binop $ cmp IntULT-(%<=) = binop $ cmp IntULE+(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a b) => TValue r a -> TValue r a -> TValue r b+(%==) = binop $ LLVM.cmp CmpEQ+(%/=) = binop $ LLVM.cmp CmpNE+(%>) = binop $ LLVM.cmp CmpGT+(%>=) = binop $ LLVM.cmp CmpGE+(%<) = binop $ LLVM.cmp CmpLT+(%<=) = binop $ LLVM.cmp CmpLE infixr 3 %&& infixr 2 %||@@ -149,8 +151,8 @@ toRational _ = error "CodeGenFunction Value: toRational" 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)+ quot = binop idiv+ rem = binop irem quotRem x y = (quot x y, rem x y) toInteger _ = error "CodeGenFunction Value: toInteger" @@ -202,21 +204,43 @@ y' <- y op x' y' +{-+If we add the ReadNone attribute, then LLVM-2.8 complains:++llvm/examples$ Arith_dyn.exe+Attribute readnone only applies to the function!+ %2 = call readnone double @llvm.sin.f64(double %0)+Attribute readnone only applies to the function!+ %3 = call readnone double @llvm.exp.f64(double %2)+Broken module found, compilation aborted!+Stack dump:+0. Running pass 'Function Pass Manager' on module '_module'.+1. Running pass 'Module Verifier' on function '@_fun1'+Aborted+-}+addReadNone :: Value a -> CodeGenFunction r (Value a)+addReadNone x = do+-- addAttributes x 0 [ReadNoneAttribute]+ return x+ callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) =>- String -> Value a -> TValue r b+ 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+{-+You can add these attributes,+but the verifier pass in the optimizer checks whether they match+the attributes that are declared for that intrinsic.+If we omit adding attributes then the right attributes are added automatically.+ addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute]+-}+ call op x >>= addReadNone callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) =>- String -> Value a -> Value b -> TValue r c+ 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+ call op x y >>= addReadNone ------------------------------------------- @@ -270,7 +294,7 @@ ------------------------------------------- --- |Define a recursive 'arithFunction', gets pased itself as the first argument.+-- |Define a recursive 'arithFunction', gets passed itself as the first argument. recursiveFunction :: (CallArgs a g, UnwrapArgs a11 a1 b1 b g r,@@ -298,24 +322,30 @@ callIntrinsic1' = callIntrinsicP1 callIntrinsic2' = callIntrinsicP2 +{-+I think such a special case for certain systems+would be better handled as in LLVM.Extra.Extension.+(lemming)+-}+macOS :: Bool+#if defined(__MACOS__)+macOS = True+#else+macOS = False+#endif+ instance (Pos n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where- callIntrinsic1' s = mapVector (callIntrinsic1' s)+ callIntrinsic1' s x =+ if macOS && TypeNum.toInt (undefined :: n) == 4 &&+ elem s ["sqrt", "log", "exp", "sin", "cos", "tan"]+ then do+ op <- externFunction ("v" ++ s ++ "f")+ call op x >>= addReadNone+ else mapVector (callIntrinsic1' s) x 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 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-+callIntrinsic2 s = binop (callIntrinsic2' s)
LLVM/Util/File.hs view
@@ -4,13 +4,13 @@ import LLVM.Core import LLVM.ExecutionEngine -writeCodeGenModule :: String -> CodeGenModule a -> IO ()+writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () writeCodeGenModule name f = do m <- newModule _ <- defineModule m f writeBitcodeToFile name m -optimize :: String -> IO ()+optimize :: FilePath -> IO () optimize name = do _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name return ()
LLVM/Util/Loop.hs view
@@ -69,7 +69,7 @@ defineBasicBlock loop i <- phi [(low, top)] vars <- phis top start- t <- icmp IntNE i high+ t <- cmp CmpNE i high condBr t body exit defineBasicBlock body
+ LLVM/Util/Memory.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}+module LLVM.Util.Memory (+ memcpy,+ memmove,+ memset,+ IsLengthType,+ ) where++import LLVM.Core++import Data.Word (Word8, Word32, Word64, )+++class IsFirstClass len => IsLengthType len where++instance IsLengthType Word32 where+instance IsLengthType Word64 where+++memcpyFunc ::+ forall len.+ IsLengthType len =>+ TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memcpyFunc =+ newNamedFunction ExternalLinkage $+ "llvm.memcpy.p0i8.p0i8." ++ typeName (undefined :: len)++memcpy ::+ IsLengthType len =>+ CodeGenModule+ (Value (Ptr Word8) ->+ Value (Ptr Word8) ->+ Value len ->+ Value Word32 ->+ Value Bool ->+ CodeGenFunction r ())+memcpy =+ fmap+ (\f dest src len align volatile ->+ fmap (const()) $ call f dest src len align volatile)+ memcpyFunc+++memmoveFunc ::+ forall len.+ IsLengthType len =>+ TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memmoveFunc =+ newNamedFunction ExternalLinkage $+ "llvm.memmove.p0i8.p0i8." ++ typeName (undefined :: len)++memmove ::+ IsLengthType len =>+ CodeGenModule+ (Value (Ptr Word8) ->+ Value (Ptr Word8) ->+ Value len ->+ Value Word32 ->+ Value Bool ->+ CodeGenFunction r ())+memmove =+ fmap+ (\f dest src len align volatile ->+ fmap (const()) $ call f dest src len align volatile)+ memmoveFunc+++memsetFunc ::+ forall len.+ IsLengthType len =>+ TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ())+memsetFunc =+ newNamedFunction ExternalLinkage $+ "llvm.memset.p0i8." ++ typeName (undefined :: len)++memset ::+ IsLengthType len =>+ CodeGenModule+ (Value (Ptr Word8) ->+ Value Word8 ->+ Value len ->+ Value Word32 ->+ Value Bool ->+ CodeGenFunction r ())+memset =+ fmap+ (\f dest val len align volatile ->+ fmap (const()) $ call f dest val len align volatile)+ memsetFunc
LLVM/Util/Optimize.hs view
@@ -1,107 +1,208 @@+{-+LLVM does not export its functions+@createStandardFunctionPasses@ and+@createStandardModulePasses@ via its C interface+and interfacing to C-C++ wrappers is not very portable.+Thus we reimplement these functions+from @opt.cpp@ and @StandardPasses.h@ in Haskell.+However this way we risk inconsistencies+between 'optimizeModule' and the @opt@ shell command.+-} module LLVM.Util.Optimize(optimizeModule) where-import Control.Monad-import Foreign.Ptr(nullPtr) +import Control.Monad(when)+ import LLVM.Core.Util(Module, withModule) import qualified LLVM.FFI.Core as FFI-import LLVM.FFI.Target(addTargetData, createTargetData)+-- import LLVM.FFI.Target(addTargetData, createTargetData) import LLVM.FFI.Transforms.IPO import LLVM.FFI.Transforms.Scalar+import Control.Exception (bracket, ) -optimizeModule :: Int -> Module -> IO Int-optimizeModule optLevel mdl = withModule mdl $ \ m -> do- passes <- FFI.createPassManager +{- |+Result tells whether the module was modified by any of the passes.+-}+optimizeModule :: Int -> Module -> IO Bool+optimizeModule optLevel mdl =+ withModule mdl $ \ m ->+ {-+ Core.Util.createPassManager would provide a finalizer for us,+ but I think it is better here to immediately dispose the manager+ when we need it no longer.+ -}+ bracket FFI.createPassManager FFI.disposePassManager $ \ passes ->++{-+Note on LLVM-2.6 to 2.8 (at least):+As far as I understand, if we do not set target data,+then the optimizer will only perform machine independent optimizations.+If we set target data+(e.g. an empty layout string obtained from a module without 'target data' specification.)+we risk that the optimizer switches to a wrong layout+(e.g. to 64 bit pointers on a 32 bit machine for empty layout string)+and thus generates corrupt code.++Currently it seems to be safer to disable+machine dependent optimization completely.++http://llvm.org/bugs/show_bug.cgi?id=6394+ -- Pass the module target data to the pass manager. target <- FFI.getDataLayout m >>= createTargetData addTargetData target passes+-} ---FCN fPasses <- FFI.createFunctionPassManager mp- let fPasses = nullPtr- -- XXX add module target data+ {-+ opt.cpp does not use a FunctionPassManager for function optimization,+ but a module PassManager.+ Thus we do it the same way.+ I assume that we would need a FunctionPassManager+ only if we wanted to apply individual optimizations to functions. --- addVerifierPass passes -- XXX does not exist+ fPasses <- FFI.createFunctionPassManager mp+ -}+ bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do+ -- add module target data?++ -- tools/opt/opt.cpp: AddStandardCompilePasses+ addVerifierPass passes addLowerSetJmpPass passes addOptimizationPasses passes fPasses optLevel - --FCN XXX loop through all functions and optimize them.--- initializeFunctionPassManager fPasses--- runFunctionPassManager fPasses fcn+ {- if we wanted to do so, we could loop through all functions and optimize them.+ initializeFunctionPassManager fPasses+ runFunctionPassManager fPasses fcn+ -} --- addVerifierPass passes -- XXX does not exist+ functionsModified <- FFI.runPassManager fPasses m - rc <- FFI.runPassManager passes m- -- XXX discard pass manager?+ moduleModified <- FFI.runPassManager passes m - return (fromIntegral rc)+ return $+ toEnum (fromIntegral moduleModified) ||+ toEnum (fromIntegral functionsModified) +-- tools/opt/opt.cpp: AddOptimizationPasses addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO () addOptimizationPasses passes fPasses optLevel = do createStandardFunctionPasses fPasses optLevel - let inline = addFunctionInliningPass -- if optLevel > 1 then addFunctionInliningPass else const (return ())+ -- if optLevel > 1 then addFunctionInliningPass else const (return ())+ let inline = addFunctionInliningPass createStandardModulePasses passes optLevel True (optLevel > 1) True True inline +-- llvm/Support/StandardPasses.h: createStandardFunctionPasses createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () createStandardFunctionPasses fPasses optLevel = do- when False $ do -- FCN+ when (optLevel > 0) $ do addCFGSimplificationPass fPasses- if optLevel == 1 then- addPromoteMemoryToRegisterPass fPasses- else- addScalarReplAggregatesPass fPasses+ if optLevel == 1+ then addPromoteMemoryToRegisterPass fPasses+ else addScalarReplAggregatesPass fPasses addInstructionCombiningPass fPasses +-- llvm/Support/StandardPasses.h: createStandardModulePasses createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> (FFI.PassManagerRef -> IO()) -> IO () createStandardModulePasses passes optLevel unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = do- when unitAtATime $ do- addRaiseAllocationsPass passes- addCFGSimplificationPass passes- addPromoteMemoryToRegisterPass passes- when unitAtATime $ do- addGlobalOptimizerPass passes- addGlobalDCEPass passes- addIPConstantPropagationPass passes- addDeadArgEliminationPass passes- addInstructionCombiningPass passes- addCFGSimplificationPass passes- when unitAtATime $ do- when haveExceptions $ addPruneEHPass passes- addFunctionAttrsPass passes- inliningPass passes- when (optLevel > 2) $ do- addArgumentPromotionPass passes- when simplifyLibCalls $ do- addSimplifyLibCallsPass passes- addInstructionCombiningPass passes- addJumpThreadingPass passes- addCFGSimplificationPass passes- addScalarReplAggregatesPass passes- addInstructionCombiningPass passes- addTailCallEliminationPass passes- addCFGSimplificationPass passes- addReassociatePass passes- addLoopRotatePass passes- addLICMPass passes- addLoopUnswitchPass passes- addInstructionCombiningPass passes- addIndVarSimplifyPass passes- addLoopDeletionPass passes- when unrollLoops $- addLoopUnrollPass passes- addInstructionCombiningPass passes- addGVNPass passes- addMemCpyOptPass passes- addSCCPPass passes+ if optLevel == 0+ then inliningPass passes+ else do+ when unitAtATime $ do+ addGlobalOptimizerPass passes -- Optimize out global vars - addInstructionCombiningPass passes- addDeadStoreEliminationPass passes- addAggressiveDCEPass passes- addCFGSimplificationPass passes+ addIPSCCPPass passes -- IP SCCP+ addDeadArgEliminationPass passes -- Dead argument elimination - when unitAtATime $ do- addStripDeadPrototypesPass passes- addDeadTypeEliminationPass passes+ addInstructionCombiningPass passes -- Clean up after IPCP & DAE+ addCFGSimplificationPass passes -- Clean up after IPCP & DAE - when (optLevel > 1 && unitAtATime) $- addConstantMergePass passes+ -- Start of CallGraph SCC passes.+ when (unitAtATime && haveExceptions) $+ addPruneEHPass passes -- Remove dead EH info+ inliningPass passes+ when unitAtATime $+ addFunctionAttrsPass passes -- Set readonly/readnone attrs+ when (optLevel > 2) $+ addArgumentPromotionPass passes -- Scalarize uninlined fn args++ -- Start of function pass.+ addScalarReplAggregatesPass passes -- Break up aggregate allocas+ when simplifyLibCalls $+ addSimplifyLibCallsPass passes -- Library Call Optimizations+ addInstructionCombiningPass passes -- Cleanup for scalarrepl.+ addJumpThreadingPass passes -- Thread jumps.+ addCFGSimplificationPass passes -- Merge & remove BBs+ addInstructionCombiningPass passes -- Combine silly seq's++ addTailCallEliminationPass passes -- Eliminate tail calls+ addCFGSimplificationPass passes -- Merge & remove BBs+ addReassociatePass passes -- Reassociate expressions+ addLoopRotatePass passes -- Rotate Loop+ addLICMPass passes -- Hoist loop invariants+ -- The C interface does not allow to pass the optimizeForSize parameter+ -- addLoopUnswitchPass(optimizeSize || optLevel < 3));+ addInstructionCombiningPass passes+ addIndVarSimplifyPass passes -- Canonicalize indvars+ addLoopDeletionPass passes -- Delete dead loops+ when unrollLoops $+ addLoopUnrollPass passes -- Unroll small loops+ addInstructionCombiningPass passes -- Clean up after the unroller+ when (optLevel > 1) $+ addGVNPass passes -- Remove redundancies+ addMemCpyOptPass passes -- Remove memcpy / form memset+ addSCCPPass passes -- Constant prop with SCCP++ -- Run instcombine after redundancy elimination to exploit opportunities+ -- opened up by them.+ addInstructionCombiningPass passes+ addJumpThreadingPass passes -- Thread jumps+ -- Not available in C interface+ -- addCorrelatedValuePropagationPass+ addDeadStoreEliminationPass passes -- Delete dead stores+ addAggressiveDCEPass passes -- Delete dead instructions+ addCFGSimplificationPass passes -- Merge & remove BBs++ when unitAtATime $ do+ addStripDeadPrototypesPass passes -- Get rid of dead prototypes+ addDeadTypeEliminationPass passes -- Eliminate dead types++ -- GlobalOpt already deletes dead functions and globals, at -O3 try a+ -- late pass of GlobalDCE. It is capable of deleting dead cycles.+ when (optLevel > 2) $+ addGlobalDCEPass passes -- Remove dead fns and globals.++ when (optLevel > 1) $+ addConstantMergePass passes -- Merge dup global constants+++{-+ToDo:+Function that adds passes according to a list of opt-options.+This would simplify to get consistent behaviour between opt and optimizeModule.++-adce addAggressiveDCEPass+-deadargelim addDeadArgEliminationPass+-deadtypeelim addDeadTypeEliminationPass+-dse addDeadStoreEliminationPass+-functionattrs addFunctionAttrsPass+-globalopt addGlobalOptimizerPass+-indvars addIndVarSimplifyPass+-instcombine addInstructionCombiningPass+-ipsccp addIPSCCPPass+-jump-threading addJumpThreadingPass+-licm addLICMPass+-loop-deletion addLoopDeletionPass+-loop-rotate addLoopRotatePass+-lowersetjmp addLowerSetJmpPass+-memcpyopt addMemCpyOptPass+-prune-eh addPruneEHPass+-reassociate addReassociatePass+-scalarrepl addScalarReplAggregatesPass+-sccp addSCCPPass+-simplifycfg addCFGSimplificationPass+-simplify-libcalls addSimplifyLibCallsPass+-strip-dead-prototypes addStripDeadPrototypesPass+-tailcallelim addTailCallEliminationPass+-verify addVerifierPass+-}
Setup.hs view
@@ -20,10 +20,8 @@ let hooks = autoconfUserHooks { postConf = if os == "mingw32" then generateBuildInfo else postConf autoconfUserHooks-#if (__GLASGOW_HASKELL__ >= 612) , instHook = installHookWithExtraGhciLibraries , regHook = regHookWithExtraGhciLibraries-#endif } defaultMainWithHooks hooks @@ -42,16 +40,18 @@ subst from to xs | Just r <- stripPrefix from xs = to ++ subst from to r subst from to (x:xs) = x : subst from to xs --- To compensate for Cabal's bad design, we need to replicate the default registration hook code here,--- to inject a value for extra-ghci-libraries into the package registration info. (Inspired by--- 'Gtk2HsSetup.hs'.) This only works for Cabal 1.8, but we can't test for that, so we test for the GHC--- version.------ We define an extension field 'x-extra-ghci-libraries' in the .buildinfo file to communicate the--- version information of the LLVM dynamic library from the configure script to the registration code.--#if (__GLASGOW_HASKELL__ >= 612)+{-+To compensate for Cabal's current design,+we need to replicate the default registration hook code here,+to inject a value for extra-ghci-libraries into the package registration info.+(Inspired by 'Gtk2HsSetup.hs'.)+This only works for Cabal 1.10,+thus we added an according constraint to llvm.cabal. +We define an extension field 'x-extra-ghci-libraries' in the .buildinfo file+in order to communicate the version information of the LLVM dynamic library+from the configure script to the registration code.+-} installHookWithExtraGhciLibraries :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () installHookWithExtraGhciLibraries pkg_descr localbuildinfo _ flags = do@@ -105,14 +105,13 @@ modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) inplace = fromFlag (regInPlace regFlags)- packageDb = case flagToMaybe (regPackageDB regFlags) of- Just db -> db- Nothing -> registrationPackageDB (withPackageDB lbi)+ packageDb = case flagToList (regPackageDB regFlags) of+ [] -> [GlobalPackageDB,+ registrationPackageDB (withPackageDB lbi)]+ xs -> xs distPref = fromFlag (regDistPref regFlags) verbosity = fromFlag (regVerbosity regFlags) register' _ _ regFlags = notice verbosity "No package to register" where verbosity = fromFlag (regVerbosity regFlags)--#endif
+ cbits/malloc.c view
@@ -0,0 +1,190 @@+#include <stdlib.h>+#include <stdint.h>++#ifdef DEBUG+#include <stdio.h>+#endif++#ifdef TEST+#include <stdio.h>+#endif+++size_t gcd(size_t x, size_t y) {+ while (x!=0) {+ size_t tmp = y%x;+ y = x;+ x = tmp;+ }+ return y;+};++__inline__+size_t lcm(size_t x, size_t y) {+ return x*(y/gcd(x,y));+};++__inline__+size_t round_down_multiple(size_t x, size_t y) {+ return x - (x%y);+};++/*+This is the alignment that malloc always warrants.+If smaller alignments are requested, then we do not need to pad.++FIXME:+This was only tested on ix86-linux.+How to get the right number for every platform?+*/+const size_t default_align = 8;++/*+We have to waste a lot of memory,+since we need an aligned address+and before that space for a pointer.+Less memory can be wasted if 'free' also gets size and align information.+In this case we could omit padding in some cases+and in the other cases we could put the pointer after the memory chunk,+which allows us to use less padding.+*/+void *aligned_malloc(size_t size, size_t requested_align) {+ const size_t ptrsize = sizeof(void *);+ /*+ Ensure that alignment always allows to store a pointer+ (to the whole allocated block).+ */+ const size_t align = lcm(requested_align, ptrsize);+ const size_t pad = align;+ void *ptr = malloc(pad+ptrsize+size);+ if (ptr) {+ void **alignedptr = (void **) round_down_multiple((size_t)(ptr+pad+ptrsize), align);+ *(alignedptr-1) = ptr;+#ifdef DEBUG+ printf("allocated size %x with alignment %x at %08x %08x \n",+ size, align, (size_t) ptr, (size_t) alignedptr);+#endif+ return alignedptr;+ } else {+ return NULL;+ }+};++/* align must be a power of two */+void *power2_aligned_malloc(size_t size, size_t align) {+ const size_t ptrsize = sizeof(void *);+ size_t pad = align>=default_align ? align-default_align : 0;+ void *ptr = malloc(pad+ptrsize+size);+ if (ptr) {+ void **alignedptr = (void **)((size_t)(ptr+pad+ptrsize) & (-align));+ *(alignedptr-1) = ptr;+#ifdef DEBUG+ printf("allocated size 0x%x with alignment 0x%x at %08x %08x \n",+ size, align, (size_t) ptr, (size_t) alignedptr);+#endif+ return alignedptr;+ } else {+ return NULL;+ }+};++void aligned_free(void *alignedptr) {+ if (alignedptr) {+ void **sptr = (void **) alignedptr;+ void *ptr = *(sptr - 1);+#ifdef DEBUG+ printf("freed %08x %08x \n", (size_t) ptr, (size_t) alignedptr);+#endif+ free(ptr);+ } else {+ /*+ What shall we do about NULL pointers?+ Crash immediately? Make an official crash by 'free'?+ */+ free(alignedptr);+ }+};+++/*+Abuse a pointer type as a size_t compatible type+and choose a name that will hopefully not clash+with names an llvm user already uses (such as 'malloc').+*/+void *aligned_malloc_sizeptr(void *size, void *align) {+ return aligned_malloc((size_t) size, (size_t) align);+}+++const int+ prepadsize = 1024,+ postpadsize = 1024;++void *padded_aligned_malloc(size_t size, size_t align) {+ void *ptr = aligned_malloc(prepadsize+size+postpadsize, align);+ return ptr ? ptr+prepadsize : NULL;+};++void padded_aligned_free(void *ptr) {+ aligned_free(ptr ? ptr-prepadsize : NULL);+};+++#ifdef TEST+void test_gcd (size_t x, size_t y) {+ printf("gcd(%d,%d) = %d\n", x, y, gcd (x,y));+}++void test_malloc (size_t size, size_t align) {+ uint8_t *ptr = aligned_malloc (size, align);+ if (ptr) {+ if (((size_t) ptr) % align) {+ printf ("ptr %08x not correctly aligned\n", (size_t) ptr);+ }+ size_t k;+ for (k = 0; k<size; k++) {+ ptr[k] = 0;+ }+ aligned_free (ptr);+ }+}++int main () {+ test_gcd (0,0);+ test_gcd (0,1);+ test_gcd (0,2);+ test_gcd (1,0);+ test_gcd (2,0);+ test_gcd (1,2);+ test_gcd (2,1);+ test_gcd (2,2);+ test_gcd (2,3);+ test_gcd (2,4);+ test_gcd (16,64);+ test_gcd (15,10);+ test_gcd (96,81);++ test_malloc (128, 1);+ test_malloc (128, 2);+ test_malloc (128, 3);+ test_malloc (128, 4);+ test_malloc (128, 5);+ test_malloc (128, 6);+ test_malloc (128, 8);+ test_malloc (128, 16);+ test_malloc (128, 32);+ test_malloc (128, 64);+ test_malloc (111, 1);+ test_malloc (111, 2);+ test_malloc (111, 3);+ test_malloc (111, 4);+ test_malloc (111, 5);+ test_malloc (111, 6);+ test_malloc (111, 8);+ test_malloc (111, 16);+ test_malloc (111, 32);+ test_malloc (111, 64);++ return 0;+}+#endif
examples/BrainF.hs view
@@ -1,5 +1,5 @@ module BrainF where--- BrainF compiler example +-- BrainF compiler example -- -- The BrainF language has 8 commands: -- Command Equivalent C Action@@ -17,9 +17,12 @@ import Data.Word import Data.Int import System.Environment(getArgs)+import System.Exit(exitFailure)+import qualified System.IO as IO import LLVM.Core import LLVM.Util.File(writeCodeGenModule)+import qualified LLVM.Util.Memory as Memory import LLVM.ExecutionEngine main :: IO ()@@ -28,7 +31,10 @@ initializeNativeTarget aargs <- getArgs- let (args, debug) = if take 1 aargs == ["-"] then (tail aargs, True) else (aargs, False)+ let (args, debug) =+ case aargs of+ "-":rargs -> (rargs, True)+ _ -> (aargs, False) let text = "+++++++++++++++++++++++++++++++++" ++ -- constant 33 ">++++" ++ -- next cell, loop counter, constant 4 "[>++++++++++" ++ -- loop, loop counter, constant 10@@ -37,10 +43,16 @@ "]<-" ++ -- back to 4, decrement loop counter "]" ++ "++++++++++."- prog <- if length args == 1 then readFile (head args) else return text+ prog <-+ case args of+ [] -> return text+ fileName:[] -> readFile fileName+ _ ->+ IO.hPutStrLn IO.stderr "too many arguments" >>+ exitFailure - when (debug) $- writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536+ when debug $+ writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536 bfprog <- simpleFunction $ brainCompile debug prog 65536 when (prog == text) $@@ -50,8 +62,7 @@ brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) brainCompile _debug instrs wmemtotal = do -- LLVM functions- memset <- newNamedFunction ExternalLinkage "llvm.memset.i32"- :: TFunction (Ptr Word8 -> Word8 -> Word32 -> Word32 -> IO ())+ memset <- Memory.memset getchar <- newNamedFunction ExternalLinkage "getchar" :: TFunction (IO Int32) putchar <- newNamedFunction ExternalLinkage "putchar"@@ -74,7 +85,7 @@ br loop defineBasicBlock exit generate is bs (cphi, exit)- + generate ('[':is) bs curbb = do -- Start a new loop. loop <- newBasicBlock -- loop top@@ -85,12 +96,12 @@ defineBasicBlock loop cur <- phi [curbb] -- will get one more input from the loop terminator. val <- load cur -- load head byte.- eqz <- icmp IntEQ val (0::Word8) -- test if it is 0.+ eqz <- cmp CmpEQ val (0::Word8) -- test if it is 0. condBr eqz exit body -- and branch accordingly.- + defineBasicBlock body generate is ((cur, loop, exit) : bs) (cur, body)- + generate (i:is) bs (curhead, bb) = do -- A simple command, with no new basic blocks. -- Just update which register the head is in.@@ -132,7 +143,7 @@ brainf <- createFunction ExternalLinkage $ do ptr_arr <- arrayMalloc wmemtotal- _ <- call memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0)+ _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False) -- _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ()) -- Start head in the middle. curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ())@@ -140,7 +151,7 @@ bb <- getCurrentBasicBlock generate instrs [] (curhead, bb) - _ <- free ptr_arr+ free ptr_arr ret () return brainf
examples/Fibonacci.hs view
@@ -59,7 +59,7 @@ -- Test if x is even/odd. a <- and x (1 :: Word32)- c <- icmp IntEQ a (0 :: Word32)+ c <- cmp CmpEQ a (0 :: Word32) condBr c l1 l2 -- Do x+y if even.@@ -86,7 +86,7 @@ exit <- newBasicBlock -- Test if arg > 2- test <- icmp IntUGT arg (2::Word32)+ test <- cmp CmpGT arg (2::Word32) condBr test recurse exit -- Just return 1 if not > 2
examples/List.hs view
@@ -39,7 +39,7 @@ i <- phi [(len, top)] p <- phi [(ptr, top)] vars <- phis top start- t <- icmp IntNE i (valueOf 0 `asTypeOf` len)+ t <- cmp CmpNE i (valueOf 0 `asTypeOf` len) condBr t body exit defineBasicBlock body
examples/Makefile view
@@ -8,15 +8,37 @@ Vector: Convert.hs %.exe: %.hs- $(ghc) $(ghcflags) --make -o $(basename $<).exe -main-is $(basename $<).main $<+ $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< +%_dyn.exe: %.hs+ $(ghc) $(ghcflags) -dynamic --make -o $@ -main-is $(basename $<).main $<+ Struct.exe: Struct.hs structCheck.c- $(ghc) $(ghcflags) --make -o Struct.exe -main-is Struct.main Struct.hs structCheck.c+ $(ghc) $(ghcflags) --make -o $@ -main-is Struct.main $^ +Struct_dyn.exe: Struct.hs structCheck.c+ $(ghc) $(ghcflags) -dynamic --make -o $@ -main-is $(basename $<).main $^+ %.run: %.exe ./$< run: $(examples:%=%.run)++%.s: %.bc+ llc -f $<++# This would lead to a cycle with llvm-as.+# %.ll: %.bc+# llvm-dis -f $<++%-dis.ll: %.bc+ llvm-dis -o $@ -f $<++%.bc: %.ll+ llvm-as -f $<++%-opt.bc: %.bc+ opt -O3 < $< > $@ N=40 fastfib: Fibonacci
llvm.cabal view
@@ -1,38 +1,42 @@ name: llvm-version: 0.9.0.1+version: 0.9.1.0 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit.-description: Bindings to the LLVM compiler toolkit.- * New in 0.9.0.0: Adapted to LLVM 2.8 (removed support for Union types);- .- * New in 0.8.2.0: Support for GHC calling convention.- .- * New in 0.8.1.0: Numerous small changes.- .- * New in 0.8.0.0: Adapted to LLVM 2.7;- .- * New in 0.7.1.0: More attributes- .- * New in 0.7.0.1: MacOS fixes.- .- * New in 0.7.0.0: Adapted to LLVM 2.6;- .- * New in 0.6.8.0: Add functions to allow freeing function resources;- .- * New in 0.6.7.0: Struct types;- .- * New in 0.6.6.0: Bug fixes;- .- * New in 0.6.5.0: Adapted to LLVM 2.5;+description:+ Bindings to the LLVM compiler toolkit.+ .+ * New in 0.9.1.0: Util.Memory for memory related intrinsics+ .+ * New in 0.9.0.0: Adapted to LLVM 2.8 (removed support for Union types);+ .+ * New in 0.8.2.0: Support for GHC calling convention.+ .+ * New in 0.8.1.0: Numerous small changes.+ .+ * New in 0.8.0.0: Adapted to LLVM 2.7;+ .+ * New in 0.7.1.0: More attributes+ .+ * New in 0.7.0.1: MacOS fixes.+ .+ * New in 0.7.0.0: Adapted to LLVM 2.6;+ .+ * New in 0.6.8.0: Add functions to allow freeing function resources;+ .+ * New in 0.6.7.0: Struct types;+ .+ * New in 0.6.6.0: Bug fixes;+ .+ * New in 0.6.5.0: Adapted to LLVM 2.5; author: Bryan O'Sullivan, Lennart Augustsson maintainer: Bryan O'Sullivan <bos@serpentine.com>, Lennart Augustsson <lennart@augustsson.net> bug-reports: Lennart Augustsson <lennart@augustsson.net> homepage: http://code.haskell.org/llvm/ stability: experimental category: Compilers/Interpreters, Code Generation-tested-with: GHC == 6.10.4, GHC == 6.12.2-cabal-version: >= 1.6+tested-with: GHC == 6.10.4, GHC == 6.12.3+cabal-version: >= 1.10 build-type: Custom extra-source-files:@@ -74,6 +78,7 @@ llvm.buildinfo library+ default-language: Haskell98 build-depends: base >= 3 && < 5, bytestring >= 0.9,@@ -104,6 +109,7 @@ LLVM.Util.File LLVM.Util.Foreign LLVM.Util.Loop+ LLVM.Util.Memory LLVM.Util.Optimize other-modules:@@ -122,7 +128,6 @@ LLVM.Target.CBackend LLVM.Target.CellSPU LLVM.Target.CppBackend- LLVM.Target.MSIL LLVM.Target.MSP430 LLVM.Target.Mips LLVM.Target.Native@@ -133,7 +138,9 @@ LLVM.Target.X86 LLVM.Target.XCore - C-Sources: cbits/free.c+ C-Sources:+ cbits/malloc.c+ cbits/free.c source-repository head type: darcs