diff --git a/LLVM/Core.hs b/LLVM/Core.hs --- a/LLVM/Core.hs +++ b/LLVM/Core.hs @@ -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 diff --git a/LLVM/Core/CodeGenMonad.hs b/LLVM/Core/CodeGenMonad.hs --- a/LLVM/Core/CodeGenMonad.hs +++ b/LLVM/Core/CodeGenMonad.hs @@ -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 diff --git a/LLVM/Core/Instructions.hs b/LLVM/Core/Instructions.hs --- a/LLVM/Core/Instructions.hs +++ b/LLVM/Core/Instructions.hs @@ -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. diff --git a/LLVM/Core/Type.hs b/LLVM/Core/Type.hs --- a/LLVM/Core/Type.hs +++ b/LLVM/Core/Type.hs @@ -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 diff --git a/LLVM/Core/Util.hs b/LLVM/Core/Util.hs --- a/LLVM/Core/Util.hs +++ b/LLVM/Core/Util.hs @@ -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) diff --git a/LLVM/ExecutionEngine/Engine.hs b/LLVM/ExecutionEngine/Engine.hs --- a/LLVM/ExecutionEngine/Engine.hs +++ b/LLVM/ExecutionEngine/Engine.hs @@ -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 diff --git a/LLVM/FFI/Core.hsc b/LLVM/FFI/Core.hsc --- a/LLVM/FFI/Core.hsc +++ b/LLVM/FFI/Core.hsc @@ -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 diff --git a/LLVM/FFI/Transforms/IPO.hsc b/LLVM/FFI/Transforms/IPO.hsc --- a/LLVM/FFI/Transforms/IPO.hsc +++ b/LLVM/FFI/Transforms/IPO.hsc @@ -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 diff --git a/LLVM/FFI/Transforms/Scalar.hsc b/LLVM/FFI/Transforms/Scalar.hsc --- a/LLVM/FFI/Transforms/Scalar.hsc +++ b/LLVM/FFI/Transforms/Scalar.hsc @@ -48,3 +48,5 @@ :: PassManagerRef -> IO () foreign import ccall unsafe "LLVMAddTailCallEliminationPass" addTailCallEliminationPass :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddVerifierPass" addVerifierPass + :: PassManagerRef -> IO () diff --git a/LLVM/Target/MSIL.hs b/LLVM/Target/MSIL.hs deleted file mode 100644 --- a/LLVM/Target/MSIL.hs +++ /dev/null @@ -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 () diff --git a/LLVM/Util/Arithmetic.hs b/LLVM/Util/Arithmetic.hs --- a/LLVM/Util/Arithmetic.hs +++ b/LLVM/Util/Arithmetic.hs @@ -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) diff --git a/LLVM/Util/File.hs b/LLVM/Util/File.hs --- a/LLVM/Util/File.hs +++ b/LLVM/Util/File.hs @@ -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 () diff --git a/LLVM/Util/Loop.hs b/LLVM/Util/Loop.hs --- a/LLVM/Util/Loop.hs +++ b/LLVM/Util/Loop.hs @@ -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 diff --git a/LLVM/Util/Memory.hs b/LLVM/Util/Memory.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/Memory.hs @@ -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 diff --git a/LLVM/Util/Optimize.hs b/LLVM/Util/Optimize.hs --- a/LLVM/Util/Optimize.hs +++ b/LLVM/Util/Optimize.hs @@ -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 +-} diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/cbits/malloc.c b/cbits/malloc.c new file mode 100644 --- /dev/null +++ b/cbits/malloc.c @@ -0,0 +1,190 @@ +#include +#include + +#ifdef DEBUG +#include +#endif + +#ifdef TEST +#include +#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 (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 diff --git a/examples/Fibonacci.hs b/examples/Fibonacci.hs --- a/examples/Fibonacci.hs +++ b/examples/Fibonacci.hs @@ -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 diff --git a/examples/List.hs b/examples/List.hs --- a/examples/List.hs +++ b/examples/List.hs @@ -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 diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -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 diff --git a/llvm.cabal b/llvm.cabal --- a/llvm.cabal +++ b/llvm.cabal @@ -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 , Lennart Augustsson bug-reports: Lennart Augustsson 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