diff --git a/LLVM/Core.hs b/LLVM/Core.hs deleted file mode 100644 --- a/LLVM/Core.hs +++ /dev/null @@ -1,111 +0,0 @@ --- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level. --- It supports both stand alone code generation and JITing. --- The Haskell llvm package is a (relatively) high level interface to the LLVM. --- The high level interface makes it easy to construct LLVM code. --- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface. --- --- LLVM code is organized into modules (type 'Module'). --- Each module contains a number of global variables and functions (type 'Function'). --- Each functions has a number of basic blocks (type 'BasicBlock'). --- Each basic block has a number instructions, where each instruction produces --- a value (type 'Value'). --- --- Unlike assembly code for a real processor the assembly code for LLVM is --- in SSA (Static Single Assignment) form. This means that each instruction generates --- a new bound variable which may not be assigned again. --- A consequence of this is that where control flow joins from several execution --- paths there has to be a phi pseudo instruction if you want different variables --- to be joined into one. --- --- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock') --- follow the same pattern. First the entity has to be created using @newX@ (where @X@ --- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to --- given its definition using @defineX@. The reason for splitting the creation and --- definition is that you often need to be able to refer to an entity before giving --- it's body, e.g., in two mutually recursive functions. --- The the @newX@ and @defineX@ function can also be done at the same time by using --- @createX@. Furthermore, an explicit name can be given to an entity by the --- @newNamedX@ function; the @newX@ function just generates a fresh name. -module LLVM.Core( - -- * Initialize - initializeNativeTarget, - -- * Modules - Module, newModule, newNamedModule, defineModule, destroyModule, createModule, - ModuleProvider, createModuleProviderForExistingModule, - PassManager, createPassManager, createFunctionPassManager, - writeBitcodeToFile, readBitcodeFromFile, - getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue, - -- * Instructions - module LLVM.Core.Instructions, - -- * Types classification - module LLVM.Core.Type, - -- * Extra types - module LLVM.Core.Data, - -- * Values and constants - Value, ConstValue, valueOf, constOf, value, - zero, allOnes, undef, - createString, createStringNul, - withString, withStringNul, - --constString, constStringNul, - constVector, constArray, - constStruct, constPackedStruct, - toVector, fromVector, vector, - -- * Code generation - CodeGenFunction, CodeGenModule, - -- * Functions - Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, - TFunction, liftCodeGenModule, getParams, - -- * Global variable creation - Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, - externFunction, staticFunction, - externGlobal, staticGlobal, - GlobalMappings, getGlobalMappings, - TGlobal, - -- * Globals - Linkage(..), - -- * Basic blocks - BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, - getBasicBlocks, - fromLabel, toLabel, - getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, - -- * Misc - addAttributes, Attribute(..), - castVarArgs, - -- * Debugging - dumpValue, dumpType, getValueName, annotateValueList - ) where -import qualified LLVM.FFI.Core as FFI -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, liftCodeGenModule, GlobalMappings, getGlobalMappings) -import LLVM.Core.Data -import LLVM.Core.Instructions -import LLVM.Core.Type -import LLVM.Core.Vector -import LLVM.Target.Native - --- |Print a value. -dumpValue :: Value a -> IO () -dumpValue (Value v) = FFI.dumpValue v - --- |Print a type. -dumpType :: Value a -> IO () -dumpType (Value v) = showTypeOf v >>= putStrLn - --- |Get the name of a 'Value'. -getValueName :: Value a -> IO String -getValueName (Value a) = getValueNameU a - --- |Convert a varargs function to a regular function. -castVarArgs :: (CastVarArgs a b) => Function a -> Function b -castVarArgs (Value a) = Value a - --- TODO for types: --- Enforce free is only called on malloc memory. (Enforce only one free?) --- Enforce phi nodes a accessor of variables outside the bb --- Enforce bb terminator --- Enforce phi first --- --- TODO: --- Add Struct, PackedStruct types --- Get alignment from code gen diff --git a/LLVM/Core/CodeGen.hs b/LLVM/Core/CodeGen.hs deleted file mode 100644 --- a/LLVM/Core/CodeGen.hs +++ /dev/null @@ -1,513 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -module LLVM.Core.CodeGen( - -- * Module creation - newModule, newNamedModule, defineModule, createModule, - getModuleValues, ModuleValue, castModuleValue, - -- * Globals - Linkage(..), - Visibility(..), - -- * Function creation - Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, - addAttributes, - FFI.Attribute(..), - externFunction, staticFunction, - FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult, - TFunction, - -- * Global variable creation - Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal, - externGlobal, staticGlobal, - -- * Values - Value(..), ConstValue(..), - IsConst(..), valueOf, value, - zero, allOnes, undef, - createString, createStringNul, - withString, withStringNul, - constVector, constArray, constStruct, constPackedStruct, - -- * Basic blocks - BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, - fromLabel, toLabel, - -- * Misc - withCurrentBuilder - ) where -import Data.Typeable -import Control.Monad(liftM, when) -import Data.Int -import Data.Word -import Data.Maybe(fromMaybe) -import Foreign.StablePtr (StablePtr, castStablePtrToPtr) -import Foreign.Ptr(minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr) -import qualified Foreign.Storable as St -import Types.Data.Num -import LLVM.Core.CodeGenMonad -import qualified LLVM.FFI.Core as FFI -import LLVM.FFI.Core(Linkage(..), Visibility(..)) -import qualified LLVM.Core.Util as U -import LLVM.Core.Type -import LLVM.Core.Data - --------------------------------------- - --- | Create a new module. -newModule :: IO U.Module -newModule = newNamedModule "_module" -- XXX should generate a name - --- | Create a new explicitely named module. -newNamedModule :: String -- ^ module name - -> IO U.Module -newNamedModule = U.createModule - --- | Give the body for a module. -defineModule :: U.Module -- ^ module that is defined - -> CodeGenModule a -- ^ module body - -> IO a -defineModule = runCodeGenModule - --- | Create a new module with the given body. -createModule :: CodeGenModule a -- ^ module body - -> IO a -createModule cgm = newModule >>= \ m -> defineModule m cgm - --------------------------------------- - -newtype ModuleValue = ModuleValue FFI.ValueRef - deriving (Show, Typeable) - -getModuleValues :: U.Module -> IO [(String, ModuleValue)] -getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues - -castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a) -castModuleValue (ModuleValue f) = - if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing - --------------------------------------- - -newtype Value a = Value { unValue :: FFI.ValueRef } - deriving (Show, Typeable) - -newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef } - deriving (Show, Typeable) - --- XXX merge with IsArithmetic? -class IsConst a where - constOf :: a -> ConstValue a - -instance IsConst Bool where constOf = constEnum (typeRef True) ---instance IsConst Char where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode -instance IsConst Word8 where constOf = constI -instance IsConst Word16 where constOf = constI -instance IsConst Word32 where constOf = constI -instance IsConst Word64 where constOf = constI -instance IsConst Int8 where constOf = constI -instance IsConst Int16 where constOf = constI -instance IsConst Int32 where constOf = constI -instance IsConst Int64 where constOf = constI -instance IsConst Float where constOf = constF -instance IsConst Double where constOf = constF ---instance IsConst FP128 where constOf = constF - -constOfPtr :: (IsType ptr) => - ptr -> Ptr b -> ConstValue ptr -constOfPtr proto p = - let ip = p `minusPtr` nullPtr - inttoptrC :: ConstValue int -> ConstValue ptr - inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto) - in if St.sizeOf p == 4 then - inttoptrC $ constOf (fromIntegral ip :: Word32) - else if St.sizeOf p == 8 then - inttoptrC $ constOf (fromIntegral ip :: Word64) - else - error "constOf Ptr: pointer size not 4 or 8" - --- This instance doesn't belong here, but mutually recursive modules are painful. -instance (IsType a) => IsConst (Ptr a) where - constOf p = constOfPtr p p - -instance IsConst (StablePtr a) where - constOf p = constOfPtr p (castStablePtrToPtr p) - -instance (IsPrimitive a, IsConst a, PositiveT n) => IsConst (Vector n a) where - constOf (Vector xs) = constVector (map constOf xs) - -instance (IsConst a, IsSized a, NaturalT n) => IsConst (Array n a) where - constOf (Array xs) = constArray (map constOf xs) - -instance (IsConstFields a) => IsConst (Struct a) where - constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False -instance (IsConstFields a) => IsConst (PackedStruct a) where - constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True - -class IsConstFields a where - constFieldsOf :: a -> [FFI.ValueRef] - -instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where - constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as -instance IsConstFields () where - constFieldsOf _ = [] - -constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a -constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 - -constI :: (IsInteger a, Integral a) => a -> ConstValue a -constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i) - -constF :: (IsFloating a, Real a) => a -> ConstValue a -constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i) - -valueOf :: (IsConst a) => a -> Value a -valueOf = value . constOf - -value :: ConstValue a -> Value a -value (ConstValue a) = Value a - -zero :: forall a . (IsType a) => ConstValue a -zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a) - -allOnes :: forall a . (IsInteger a) => ConstValue a -allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a) - -undef :: forall a . (IsType a) => ConstValue a -undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a) - -{- -createString :: String -> ConstValue (DynamicArray Word8) -createString = ConstValue . U.constString - -constStringNul :: String -> ConstValue (DynamicArray Word8) -constStringNul = ConstValue . U.constStringNul --} - --------------------------------------- - - --- |A function is simply a pointer to the function. -type Function a = Value (Ptr a) - --- | Create a new named function. -newNamedFunction :: forall a . (IsFunction a) - => Linkage - -> String -- ^ Function name - -> CodeGenModule (Function a) -newNamedFunction linkage name = do - modul <- getModule - let typ = typeRef (undefined :: a) - liftIO $ liftM Value $ U.addFunction modul linkage name typ - --- | Create a new function. Use 'newNamedFunction' to create a function with external linkage, since --- it needs a known name. -newFunction :: forall a . (IsFunction a) - => Linkage - -> CodeGenModule (Function a) -newFunction linkage = genMSym "fun" >>= newNamedFunction linkage - --- | Define a function body. The basic block returned by the function is the function entry point. -defineFunction :: forall f . (FunctionArgs f) - => Function f -- ^ Function to define (created by 'newFunction'). - -> FunctionCodeGen f -- ^ Function body. - -> CodeGenModule () -defineFunction fn body = do - bld <- liftIO $ U.createBuilder - let body' = do - l <- newBasicBlock - defineBasicBlock l - applyArgs fn body :: CodeGenFunction (FunctionResult f) () - runCodeGenFunction bld (unValue fn) body' - return () - --- | Create a new function with the given body. -createFunction :: (FunctionArgs f) - => Linkage - -> FunctionCodeGen f -- ^ Function body. - -> CodeGenModule (Function f) -createFunction linkage body = do - f <- newFunction linkage - defineFunction f body - return f - --- | Create a new function with the given body. -createNamedFunction :: (FunctionArgs f) - => Linkage - -> String - -> FunctionCodeGen f -- ^ Function body. - -> CodeGenModule (Function f) -createNamedFunction linkage name body = do - f <- newNamedFunction linkage name - defineFunction f body - return f - --- | Set the calling convention of a function. By default it is the --- C calling convention. -setFuncCallConv :: Function a - -> FFI.CallingConvention - -> CodeGenModule () -setFuncCallConv (Value f) cc = do - liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc) - return () - --- | Add attributes to a value. Beware, what attributes are allowed depends on --- what kind of value it is. -addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r () -addAttributes (Value f) i as = do - liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as) - --- Convert a function of type f = t1->t2->...-> IO r to --- g = Value t1 -> Value t2 -> ... CodeGenFunction r () -class IsFunction f => FunctionArgs f where - type FunctionCodeGen f :: * - type FunctionResult f :: * - apArgs :: Int -> Function f -> FunctionCodeGen f -> CodeGenFunction (FunctionResult f) () - -applyArgs :: - (FunctionArgs f) => - Function f -> FunctionCodeGen f -> CodeGenFunction (FunctionResult f) () -applyArgs = apArgs 0 - -removeArg :: Function (a -> b) -> Function b -removeArg (Value f) = Value f - -instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where - type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b - type FunctionResult (a -> b) = FunctionResult b - apArgs n f g = apArgs (n+1) (removeArg f) (g $ Value $ U.getParam (unValue f) n) - -instance IsFirstClass a => FunctionArgs (IO a) where - type FunctionCodeGen (IO a) = CodeGenFunction a () - type FunctionResult (IO a) = a - apArgs _ _ g = g - --- | This class is just to simplify contexts. --- May be less useful since we convert functional dependencies to type families -class (FunctionArgs (IO a)) => FunctionRet a -instance (FunctionArgs (IO a)) => FunctionRet a - --------------------------------------- - --- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction. -newtype BasicBlock = BasicBlock FFI.BasicBlockRef - deriving (Show, Typeable) - -createBasicBlock :: CodeGenFunction r BasicBlock -createBasicBlock = do - b <- newBasicBlock - defineBasicBlock b - return b - -newBasicBlock :: CodeGenFunction r BasicBlock -newBasicBlock = genFSym >>= newNamedBasicBlock - -newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock -newNamedBasicBlock name = do - fn <- getFunction - liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name - -defineBasicBlock :: BasicBlock -> CodeGenFunction r () -defineBasicBlock (BasicBlock l) = do - bld <- getBuilder - liftIO $ U.positionAtEnd bld l - -getCurrentBasicBlock :: CodeGenFunction r BasicBlock -getCurrentBasicBlock = do - bld <- getBuilder - liftIO $ liftM BasicBlock $ U.getInsertBlock bld - -toLabel :: BasicBlock -> Value Label -toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr) - -fromLabel :: Value Label -> BasicBlock -fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr) - --------------------------------------- - ---- XXX: the functions in this section (and addGlobalMapping) don't actually use any --- Function state so should really be in the CodeGenModule monad - --- | Create a reference to an external function while code generating for a function. --- If LLVM cannot resolve its name, then you may try 'staticFunction'. -externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a) -externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage - --- | As 'externFunction', but for 'Global's rather than 'Function's -externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a) -externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage - -externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a) -externCore name act = do - es <- getExterns - case lookup name es of - Just f -> return $ Value f - Nothing -> do - f <- liftCodeGenModule $ act name - putExterns ((name, f) : es) - return $ Value f - -{- | -Make an external C function with a fixed address callable from LLVM code. -This callback function can also be a Haskell function, -that was imported like - -> foreign import ccall "&nextElement" -> nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) - -See @examples\/List.hs@. - -When you only use 'externFunction', then LLVM cannot resolve the name. -(However, I do not know why.) -Thus 'staticFunction' manages a list of static functions. -This list is automatically installed by 'ExecutionEngine.simpleFunction' -and can be manually obtained by 'getGlobalMappings' -and installed by 'ExecutionEngine.addGlobalMappings'. -\"Installing\" means calling LLVM's @addGlobalMapping@ according to -. --} -staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f) -staticFunction func = liftCodeGenModule $ do - val <- newNamedFunction ExternalLinkage "" - addGlobalMapping (unValue (val :: Function f)) (castFunPtrToPtr func) - return val - --- | As 'staticFunction', but for 'Global's rather than 'Function's -staticGlobal :: forall a r. (IsType a) => Bool -> Ptr a -> CodeGenFunction r (Global a) -staticGlobal isConst gbl = liftCodeGenModule $ do - val <- newNamedGlobal isConst ExternalLinkage "" - addGlobalMapping (unValue (val :: Global a)) (castPtr gbl) - return val - --------------------------------------- - -withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a -withCurrentBuilder body = do - bld <- getBuilder - liftIO $ U.withBuilder bld body - --------------------------------------- - --- Mark all block terminating instructions. Not used yet. ---data Terminate = Terminate - --------------------------------------- - -type Global a = Value (Ptr a) - --- | Create a new named global variable. -newNamedGlobal :: forall a . (IsType a) - => Bool -- ^Constant? - -> Linkage -- ^Visibility - -> String -- ^Name - -> TGlobal a -newNamedGlobal isConst linkage name = do - modul <- getModule - let typ = typeRef (undefined :: a) - liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ - when isConst $ FFI.setGlobalConstant g 1 - return g - --- | Create a new global variable. -newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a -newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage - --- | Give a global variable a (constant) value. -defineGlobal :: Global a -> ConstValue a -> CodeGenModule () -defineGlobal (Value g) (ConstValue v) = - liftIO $ FFI.setInitializer g v - --- | Create and define a global variable. -createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a -createGlobal isConst linkage con = do - g <- newGlobal isConst linkage - defineGlobal g con - return g - --- | Create and define a named global variable. -createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a -createNamedGlobal isConst linkage name con = do - g <- newNamedGlobal isConst linkage name - defineGlobal g con - return g - -type TFunction a = CodeGenModule (Function a) -type TGlobal a = CodeGenModule (Global a) - --- Special string creators -{-# DEPRECATED createString "use withString instead" #-} -createString :: String -> TGlobal (Array n Word8) -createString s = string (length s) (U.constString s) - -{-# DEPRECATED createStringNul "use withStringNul instead" #-} -createStringNul :: String -> TGlobal (Array n Word8) -createStringNul s = string (length s + 1) (U.constStringNul s) - -withString :: - String -> - (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) -> - CodeGenModule a -withString s act = - let n = length s - in fromMaybe (error "withString: length must always be non-negative") $ - reifyNaturalD (fromIntegral n) (\tn -> - do arr <- string n (U.constString s) - act (fixArraySize tn arr)) - -withStringNul :: - String -> - (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) -> - CodeGenModule a -withStringNul s act = - let n = length s + 1 - in fromMaybe (error "withStringNul: length must always be non-negative") $ - reifyNaturalD (fromIntegral n) (\tn -> - do arr <- string n (U.constStringNul s) - act (fixArraySize tn arr)) - -fixArraySize :: n -> Global (Array n a) -> Global (Array n a) -fixArraySize _ = id - -string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8) -string n s = do - modul <- getModule - name <- genMSym "str" - let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n) - liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ - FFI.setGlobalConstant g 1 - FFI.setInitializer g s - return g - --------------------------------------- - --- |Make a constant vector. Replicates or truncates the list to get length /n/. -constVector :: forall a n . (PositiveT n) => [ConstValue a] -> ConstValue (Vector n a) -constVector xs = - ConstValue $ U.constVector (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ] - --- |Make a constant array. Replicates or truncates the list to get length /n/. -constArray :: forall a n . (IsSized a, NaturalT n) => [ConstValue a] -> ConstValue (Array n a) -constArray xs = - ConstValue $ U.constArray (typeRef (undefined :: a)) (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ] - --- |Make a constant struct. -constStruct :: (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c)) -constStruct struct = - ConstValue $ U.constStruct (constValueFieldsOf struct) False - --- |Make a constant packed struct. -constPackedStruct :: (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c)) -constPackedStruct struct = - ConstValue $ U.constStruct (constValueFieldsOf struct) True - -class IsConstStruct c where - type ConstStructOf c :: * - constValueFieldsOf :: c -> [FFI.ValueRef] - -instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where - type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs) - constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as -instance IsConstStruct () where - type ConstStructOf () = () - constValueFieldsOf _ = [] diff --git a/LLVM/Core/CodeGenMonad.hs b/LLVM/Core/CodeGenMonad.hs deleted file mode 100644 --- a/LLVM/Core/CodeGenMonad.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -module LLVM.Core.CodeGenMonad( - -- * Module code generation - CodeGenModule, runCodeGenModule, genMSym, getModule, - GlobalMappings(..), addGlobalMapping, getGlobalMappings, - -- * Function code generation - CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, - -- * Reexport - liftIO - ) where -import Data.Typeable -import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, ) -import Control.Monad.IO.Class (MonadIO, liftIO, ) -import Control.Applicative (Applicative, ) - -import Foreign.Ptr (Ptr, ) - -import LLVM.Core.Util(Module, Builder, Function) - --------------------------------------- - -data CGMState = CGMState { - cgm_module :: Module, - cgm_externs :: [(String, Function)], - cgm_global_mappings :: [(Function, Ptr ())], - cgm_next :: !Int - } - deriving (Show, Typeable) -newtype CodeGenModule a = CGM (StateT CGMState IO a) - deriving (Functor, Applicative, Monad, MonadIO, Typeable) - -genMSym :: String -> CodeGenModule String -genMSym prefix = do - s <- CGM get - let n = cgm_next s - CGM $ put (s { cgm_next = n + 1 }) - return $ "_" ++ prefix ++ show n - -getModule :: CodeGenModule Module -getModule = CGM $ gets cgm_module - -runCodeGenModule :: Module -> CodeGenModule a -> IO a -runCodeGenModule m (CGM body) = do - let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] } - evalStateT body cgm - --------------------------------------- - -data CGFState r = CGFState { - cgf_module :: CGMState, - cgf_builder :: Builder, - cgf_function :: Function, - cgf_next :: !Int - } - deriving (Show, Typeable) -newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a) - deriving (Functor, Applicative, Monad, MonadIO, Typeable) - -genFSym :: CodeGenFunction a String -genFSym = do - s <- CGF get - let n = cgf_next s - CGF $ put (s { cgf_next = n + 1 }) - return $ "_L" ++ show n - -getFunction :: CodeGenFunction a Function -getFunction = CGF $ gets cgf_function - -getBuilder :: CodeGenFunction a Builder -getBuilder = CGF $ gets cgf_builder - -getFunctionModule :: CodeGenFunction a Module -getFunctionModule = CGF $ gets (cgm_module . cgf_module) - -getExterns :: CodeGenFunction a [(String, Function)] -getExterns = CGF $ gets (cgm_externs . cgf_module) - -putExterns :: [(String, Function)] -> CodeGenFunction a () -putExterns es = do - cgf <- CGF get - let cgm' = (cgf_module cgf) { cgm_externs = es } - CGF $ put (cgf { cgf_module = cgm' }) - -addGlobalMapping :: - Function -> Ptr () -> CodeGenModule () -addGlobalMapping value func = CGM $ modify $ \cgm -> - cgm { cgm_global_mappings = - (value,func) : cgm_global_mappings cgm } - -newtype GlobalMappings = - GlobalMappings [(Function, Ptr ())] - -{- | -Get a list created by calls to 'staticFunction' -that must be passed to the execution engine -via 'LLVM.ExecutionEngine.addGlobalMappings'. --} -getGlobalMappings :: - CodeGenModule GlobalMappings -getGlobalMappings = - CGM $ gets (GlobalMappings . cgm_global_mappings) - -runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a -runCodeGenFunction bld fn (CGF body) = do - cgm <- CGM get - let cgf = CGFState { cgf_module = cgm, - cgf_builder = bld, - cgf_function = fn, - cgf_next = 1 } - (a, cgf') <- liftIO $ runStateT body cgf - CGM $ put (cgf_module cgf') - return a - --------------------------------------- - --- | Allows you to define part of a module while in the middle of defining a function. -liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a -liftCodeGenModule (CGM act) = do - cgf <- CGF get - (a, cgm') <- liftIO $ runStateT act (cgf_module cgf) - CGF $ put (cgf { cgf_module = cgm' }) - return a diff --git a/LLVM/Core/Data.hs b/LLVM/Core/Data.hs deleted file mode 100644 --- a/LLVM/Core/Data.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE DeriveDataTypeable #-} -module LLVM.Core.Data(IntN(..), WordN(..), FP128(..), - Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where -import Data.Typeable -import Foreign.Ptr(Ptr) - --- TODO: --- Make instances IntN, WordN to actually do the right thing. --- Make FP128 do the right thing --- Make Array functions. - --- |Variable sized signed integer. --- The /n/ parameter should belong to @PosI@. -newtype IntN n = IntN Integer - deriving (Show, Typeable) - --- |Variable sized unsigned integer. --- The /n/ parameter should belong to @PosI@. -newtype WordN n = WordN Integer - deriving (Show, Typeable) - --- |128 bit floating point. -newtype FP128 = FP128 Rational - deriving (Show, Typeable) - --- |Fixed sized arrays, the array size is encoded in the /n/ parameter. -newtype Array n a = Array [a] - deriving (Show, Typeable) - --- |Fixed sized vector, the array size is encoded in the /n/ parameter. -newtype Vector n a = Vector [a] - deriving (Show, Typeable) - --- |Label type, produced by a basic block. -data Label - deriving (Typeable) - --- |Struct types; a list (nested tuple) of component types. -newtype Struct a = Struct a - deriving (Show, Typeable) -newtype PackedStruct a = PackedStruct a - deriving (Show, Typeable) diff --git a/LLVM/Core/Instructions.hs b/LLVM/Core/Instructions.hs deleted file mode 100644 --- a/LLVM/Core/Instructions.hs +++ /dev/null @@ -1,1300 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module LLVM.Core.Instructions( - -- * ADT representation of IR - BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc, - -- * Terminator instructions - ret, - condBr, - br, - switch, - invoke, invokeWithConv, - invokeFromFunction, invokeWithConvFromFunction, - unreachable, - -- * Arithmetic binary operations - -- | Arithmetic operations with the normal semantics. - -- The u instractions are unsigned, the s instructions are signed. - add, sub, mul, neg, - 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. - shl, lshr, ashr, and, or, xor, inv, - -- * Vector operations - extractelement, - insertelement, - shufflevector, - -- * Aggregate operation - extractvalue, - insertvalue, - -- * Memory access - malloc, arrayMalloc, - alloca, arrayAlloca, - free, - load, - store, - getElementPtr, getElementPtr0, - -- * Conversions - trunc, zext, sext, ext, zadapt, sadapt, adapt, - fptrunc, fpext, - fptoui, fptosi, fptoint, - uitofp, sitofp, inttofp, - ptrtoint, inttoptr, - bitcast, - bitcastElements, - -- * Comparison - CmpPredicate(..), IntPredicate(..), FPPredicate(..), - CmpOp, CmpRet, CmpResult, - cmp, pcmp, icmp, fcmp, - select, - -- * Other - phi, addPhiInputs, - call, callWithConv, - callFromFunction, callWithConvFromFunction, - Call, applyCall, runCall, - - -- * Classes and types - Terminate, - Ret, CallArgs, ABinOp, ABinOpResult, IsConst, - FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult, - AllocArg, - GetElementPtr, ElementPtrType, IsIndexArg, - GetValue, ValueType - ) where -import Prelude hiding (and, or) -import Data.Typeable -import Control.Monad(liftM) -import Data.Int -import Data.Word -import Data.Map(fromList, (!)) -import Foreign.Ptr (FunPtr, ) -import Foreign.C(CInt, CUInt) -import Types.Data.Ord(LTT, GTT) -import Types.Data.Num(Dec, DecN, (:.), d1, fromIntegerT, Pred) -import qualified LLVM.FFI.Core as FFI -import LLVM.Core.Data -import LLVM.Core.Type -import LLVM.Core.CodeGenMonad -import LLVM.Core.CodeGen -import qualified LLVM.Core.Util as U - --- TODO: --- Add vector version of arithmetic --- Add rest of instructions --- Use Terminate to ensure bb termination (how?) --- more intrinsics are needed to, e.g., create an empty vector - -data ArgDesc = AV String | AI Int | AL String | AE - -instance Show ArgDesc where - -- show (AV s) = "V_" ++ s - -- show (AI i) = "I_" ++ show i - -- show (AL l) = "L_" ++ l - show (AV s) = s - show (AI i) = show i - show (AL l) = l - show AE = "voidarg?" - -data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd - | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub - | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul - | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem - | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor - deriving Show - --- FIXME: complete definitions for unimplemented instructions -data InstrDesc = - -- terminators - IDRet TypeDesc ArgDesc | IDRetVoid - | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc - | IDSwitch [(ArgDesc, ArgDesc)] - | IDIndirectBr - | IDInvoke - | IDUnwind - | IDUnreachable - -- binary operators (including bitwise) - | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc - -- memory access and addressing - | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc - | IDGetElementPtr TypeDesc [ArgDesc] - -- conversion - | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc - | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc - | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc - | IDSItoFP TypeDesc TypeDesc ArgDesc - | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc - | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc - | IDBitcast TypeDesc TypeDesc ArgDesc - -- other - | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc - | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc] - | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg - -- vector operators - | IDExtractElement | IDInsertElement | IDShuffleVector - -- aggregate operators - | IDExtractValue | IDInsertValue - -- invalid - | IDInvalidOp - deriving Show - --- TODO: overflow support for binary operations (add/sub/mul) -getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc) -getInstrDesc v = do - valueName <- U.getValueNameU v - opcode <- FFI.instGetOpcode v - t <- FFI.typeOf v >>= typeDesc2 - -- FIXME: sizeof() does not work for types! - --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral - tsize <- return 1 - os <- U.getOperands v >>= mapM getArgDesc - os0 <- if length os > 0 then return $ os !! 0 else return AE - os1 <- if length os > 1 then return $ os !! 1 else return AE - t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41) - then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2 - else return TDVoid) - p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0 - let instr = - (if opcode >= 8 && opcode <= 25 -- binary arithmetic - then IDBinOp (getBinOp opcode) t os0 os1 - else if opcode >= 30 && opcode <= 41 -- conversion - then (getConvOp opcode) t2 t os0 - else case opcode of - { 1 -> if null os then IDRetVoid else IDRet t os0; - 2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1; - 3 -> IDSwitch $ toPairs os; - -- TODO (can skip for now) - -- 4 -> IndirectBr ; 5 -> Invoke ; - 6 -> IDUnwind; 7 -> IDUnreachable; - 26 -> IDAlloca (getPtrType t) tsize (getImmInt os0); - 27 -> IDLoad t os0; 28 -> IDStore t os0 os1; - 29 -> IDGetElementPtr t os; - 42 -> IDICmp (toIntPredicate p) os0 os1; - 43 -> IDFCmp (toFPPredicate p) os0 os1; - 44 -> IDPhi t $ toPairs os; - -- FIXME: getelementptr arguments are not handled - 45 -> IDCall t (last os) (init os); - 46 -> IDSelect t os0 os1; - -- TODO (can skip for now) - -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ; - -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ; - -- 53 -> ExtractValue ; 54 -> InsertValue ; - _ -> IDInvalidOp }) - return (valueName, instr) - --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode - where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub), - (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv), - (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem), - (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd), - (24, BOOr), (25, BOXor)] ! o - getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI), - (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc), - (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o - toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs)) - stride _ [] = [] - stride n (x:xs) = x : stride n (drop (n-1) xs) - getPtrType (TDPtr t) = t - getPtrType _ = TDVoid - getImmInt (AI i) = i - getImmInt _ = 0 - --- TODO: fix for non-int constants -getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc -getArgDesc (vname, v) = do - isC <- U.isConstant v - t <- FFI.typeOf v >>= typeDesc2 - if isC - then case t of - TDInt _ _ -> do - cV <- FFI.constIntGetSExtValue v - return $ AI $ fromIntegral cV - _ -> return AE - else case t of - TDLabel -> return $ AL vname - _ -> return $ AV vname - --------------------------------------- - -type Terminate = () -terminate :: Terminate -terminate = () - --------------------------------------- - --- |Acceptable arguments to the 'ret' instruction. -class Ret a r where - ret' :: a -> CodeGenFunction r Terminate - --- | Return from the current function with the given value. Use () as the return value for what would be a void function in C. -ret :: (Ret a r) => a -> CodeGenFunction r Terminate -ret = ret' - --- overlaps with Ret () ()! -{- -instance (IsFirstClass a, IsConst a) => Ret a a where - ret' = ret . valueOf --} - -instance Ret (Value a) a where - ret' (Value a) = do - withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a - return terminate - -instance Ret () () where - ret' _ = do - withCurrentBuilder_ $ FFI.buildRetVoid - return terminate - -withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r () -withCurrentBuilder_ p = withCurrentBuilder p >> return () - --------------------------------------- - --- | Branch to the first basic block if the boolean is true, otherwise to the second basic block. -condBr :: Value Bool -- ^ Boolean to branch upon. - -> BasicBlock -- ^ Target for true. - -> BasicBlock -- ^ Target for false. - -> CodeGenFunction r Terminate -condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do - withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2 - return terminate - --------------------------------------- - --- | Unconditionally branch to the given basic block. -br :: BasicBlock -- ^ Branch target. - -> CodeGenFunction r Terminate -br (BasicBlock t) = do - withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t - return terminate - --------------------------------------- - --- | Branch table instruction. -switch :: (IsInteger a) - => Value a -- ^ Value to branch upon. - -> BasicBlock -- ^ Default branch target. - -> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets. - -> CodeGenFunction r Terminate -switch (Value val) (BasicBlock dflt) arms = do - withCurrentBuilder_ $ \ bldPtr -> do - inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms) - sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ] - return terminate - --------------------------------------- - --- |Inform the code generator that this code can never be reached. -unreachable :: CodeGenFunction r Terminate -unreachable = do - withCurrentBuilder_ FFI.buildUnreachable - return terminate - --------------------------------------- - -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 where - type ABinOpResult a b :: * - abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b) - -add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -iadd = abinop FFI.constAdd FFI.buildAdd -isub :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -isub = abinop FFI.constSub FFI.buildSub -imul :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => - 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 ~ ABinOpResult a b) => - 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 ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -udiv = abinop FFI.constUDiv FFI.buildUDiv -sdiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -sdiv = abinop FFI.constSDiv FFI.buildSDiv -urem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -urem = abinop FFI.constURem FFI.buildURem -srem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -srem = abinop FFI.constSRem FFI.buildSRem - -fadd :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -fadd = abinop FFI.constFAdd FFI.buildFAdd -fsub :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -fsub = abinop FFI.constFSub FFI.buildFSub -fmul :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -fmul = abinop FFI.constFMul FFI.buildFMul - --- | Floating point division. -fdiv :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -fdiv = abinop FFI.constFDiv FFI.buildFDiv --- | Floating point remainder. -frem :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -frem = abinop FFI.constFRem FFI.buildFRem - -shl :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -shl = abinop FFI.constShl FFI.buildShl -lshr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -lshr = abinop FFI.constLShr FFI.buildLShr -ashr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -ashr = abinop FFI.constAShr FFI.buildAShr -and :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -and = abinop FFI.constAnd FFI.buildAnd -or :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -or = abinop FFI.constOr FFI.buildOr -xor :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) -xor = abinop FFI.constXor FFI.buildXor - -instance ABinOp (Value a) (Value a) where - type ABinOpResult (Value a) (Value a) = Value a - abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2 - -instance ABinOp (ConstValue a) (Value a) where - type ABinOpResult (ConstValue a) (Value a) = Value a - abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2 - -instance ABinOp (Value a) (ConstValue a) where - type ABinOpResult (Value a) (ConstValue a) = Value a - abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2 - -instance ABinOp (ConstValue a) (ConstValue a) where - type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a - abinop cop _ (ConstValue a1) (ConstValue a2) = - return $ ConstValue $ cop a1 a2 - -{- -instance (IsConst a) => ABinOp (Value a) a where - type ABinOpResult (Value a) a = Value a - abinop cop op a1 a2 = abinop cop op a1 (constOf a2) - -instance (IsConst a) => ABinOp a (Value a) where - type ABinOpResult a (Value a) = Value a - abinop cop op a1 a2 = abinop cop op (constOf a1) a2 --} - ---instance (IsConst a) => ABinOp a a (ConstValue a) where --- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2) - -buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a) -buildBinOp op a1 a2 = - liftM Value $ - withCurrentBuilder $ \ bld -> - U.withEmptyCString $ op bld a1 a2 - -type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef - -buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a) -buildUnOp op a = - liftM Value $ - withCurrentBuilder $ \ bld -> - U.withEmptyCString $ op bld a - -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 (Value x) = buildUnOp FFI.buildFNeg x --} - -inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a) -inv (Value x) = buildUnOp FFI.buildNot x - --------------------------------------- - --- | Get a value from a vector. -extractelement :: (PositiveT n) - => Value (Vector n a) -- ^ Vector - -> Value Word32 -- ^ Index into the vector - -> CodeGenFunction r (Value a) -extractelement (Value vec) (Value i) = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i - --- | Insert a value into a vector, nondestructive. -insertelement :: (PositiveT n) - => Value (Vector n a) -- ^ Vector - -> Value a -- ^ Value to insert - -> Value Word32 -- ^ Index into the vector - -> CodeGenFunction r (Value (Vector n a)) -insertelement (Value vec) (Value e) (Value i) = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i - --- | Permute vector. -shufflevector :: (PositiveT n, PositiveT m) - => Value (Vector n a) - -> 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 -> - U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask - - --- |Acceptable arguments to 'extractvalue' and 'insertvalue'. -class GetValue agg ix where - type ValueType agg ix :: * - getIx :: agg -> ix -> CUInt - -instance (GetField as i, NaturalT i) => GetValue (Struct as) i where - type ValueType (Struct as) i = FieldType as i - getIx _ n = fromIntegerT n - -instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where - type ValueType (Array n a) Word32 = a - getIx _ n = fromIntegral n - -instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where - type ValueType (Array n a) Word64 = a - getIx _ n = fromIntegral n - - -instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where - type ValueType (Array n a) (Dec i) = a - getIx _ n = fromIntegerT n - - --- | Get a value from an aggregate. -extractvalue :: forall r agg i. - GetValue agg i - => Value agg -- ^ Aggregate - -> i -- ^ Index into the aggregate - -> CodeGenFunction r (Value (ValueType agg i)) -extractvalue (Value agg) i = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ - FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i) - --- | Insert a value into an aggregate, nondestructive. -insertvalue :: forall r agg i. - GetValue agg i - => Value agg -- ^ Aggregate - -> Value (ValueType agg i) -- ^ Value to insert - -> i -- ^ Index into the aggregate - -> CodeGenFunction r (Value agg) -insertvalue (Value agg) (Value e) i = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ - FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i) - - --------------------------------------- - --- XXX should allows constants - --- | Truncate a value to a shorter bit width. -trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b)) - => Value a -> CodeGenFunction r (Value b) -trunc = convert FFI.buildTrunc - --- | Zero extend a value to a wider width. --- If possible, use 'ext' that chooses the right padding according to the types -zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) - => Value a -> CodeGenFunction r (Value b) -zext = convert FFI.buildZExt - --- | Sign extend a value to wider width. --- If possible, use 'ext' that chooses the right padding according to the types -sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) - => Value a -> CodeGenFunction r (Value b) -sext = convert FFI.buildSExt - --- | Extend a value to wider width. --- If the target type is signed, then preserve the sign, --- If the target type is unsigned, then extended by zeros. -ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) - => Value a -> CodeGenFunction r (Value b) -ext = - if isSigned (undefined :: b) - then convert FFI.buildSExt - else convert FFI.buildZExt - - --- | It is 'zext', 'trunc' or nop depending on the relation of the sizes. -zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) - => Value a -> CodeGenFunction r (Value b) -zadapt = - case compare (sizeOf (typeDesc (undefined :: a))) - (sizeOf (typeDesc (undefined :: b))) of - LT -> convert FFI.buildZExt - EQ -> convert FFI.buildBitCast - GT -> convert FFI.buildTrunc - --- | It is 'sext', 'trunc' or nop depending on the relation of the sizes. -sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) - => Value a -> CodeGenFunction r (Value b) -sadapt = - case compare (sizeOf (typeDesc (undefined :: a))) - (sizeOf (typeDesc (undefined :: b))) of - LT -> convert FFI.buildSExt - EQ -> convert FFI.buildBitCast - GT -> convert FFI.buildTrunc - --- | It is 'sadapt' or 'zadapt' depending on the sign mode. -adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b) - => Value a -> CodeGenFunction r (Value b) -adapt = - case compare (sizeOf (typeDesc (undefined :: a))) - (sizeOf (typeDesc (undefined :: b))) of - LT -> - if isSigned (undefined :: b) - then convert FFI.buildSExt - else convert FFI.buildZExt - EQ -> convert FFI.buildBitCast - GT -> convert FFI.buildTrunc - --- | Truncate a floating point value. -fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b)) - => Value a -> CodeGenFunction r (Value b) -fptrunc = convert FFI.buildFPTrunc - --- | Extend a floating point value. -fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) - => Value a -> CodeGenFunction r (Value b) -fpext = convert FFI.buildFPExt - -{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-} --- | Convert a floating point value to an unsigned integer. -fptoui :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) -fptoui = convert FFI.buildFPToUI - -{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-} --- | Convert a floating point value to a signed integer. -fptosi :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) -fptosi = convert FFI.buildFPToSI - --- | Convert a floating point value to an integer. --- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@. -fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) -fptoint = - if isSigned (undefined :: b) - then convert FFI.buildFPToSI - else convert FFI.buildFPToUI - - -{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -} --- | Convert an unsigned integer to a floating point value. --- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool. -uitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) -uitofp = convert FFI.buildUIToFP - -{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -} --- | Convert a signed integer to a floating point value. --- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool. -sitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) -sitofp = convert FFI.buildSIToFP - --- | Convert an integer to a floating point value. --- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@. -inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) -inttofp = - if isSigned (undefined :: a) - then convert FFI.buildSIToFP - else convert FFI.buildUIToFP - - --- | Convert a pointer to an integer. -ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b) -ptrtoint = convert FFI.buildPtrToInt - --- | Convert an integer to a pointer. -inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b)) -inttoptr = convert FFI.buildIntToPtr - --- | Convert between to values of the same size by just copying the bit pattern. -bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b) - => Value a -> CodeGenFunction r (Value b) -bitcast = convert FFI.buildBitCast - --- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same. -bitcastElements :: (PositiveT n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b) - => Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) -bitcastElements = convert FFI.buildBitCast - - -type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef - -convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b) -convert conv (Value a) = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b)) - --------------------------------------- - -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 - | IntUGT -- ^ unsigned greater than - | IntUGE -- ^ unsigned greater or equal - | IntULT -- ^ unsigned less than - | IntULE -- ^ unsigned less or equal - | IntSGT -- ^ signed greater than - | IntSGE -- ^ signed greater or equal - | IntSLT -- ^ signed less than - | IntSLE -- ^ signed less or equal - deriving (Eq, Ord, Enum, Show, Typeable) - -fromIntPredicate :: IntPredicate -> CInt -fromIntPredicate p = fromIntegral (fromEnum p + 32) - -toIntPredicate :: CInt -> IntPredicate -toIntPredicate p = toEnum $ fromIntegral p - 32 - -data FPPredicate = - FPFalse -- ^ Always false (always folded) - | FPOEQ -- ^ True if ordered and equal - | FPOGT -- ^ True if ordered and greater than - | FPOGE -- ^ True if ordered and greater than or equal - | FPOLT -- ^ True if ordered and less than - | FPOLE -- ^ True if ordered and less than or equal - | FPONE -- ^ True if ordered and operands are unequal - | FPORD -- ^ True if ordered (no nans) - | FPUNO -- ^ True if unordered: isnan(X) | isnan(Y) - | FPUEQ -- ^ True if unordered or equal - | FPUGT -- ^ True if unordered or greater than - | FPUGE -- ^ True if unordered, greater than, or equal - | FPULT -- ^ True if unordered or less than - | FPULE -- ^ True if unordered, less than, or equal - | FPUNE -- ^ True if unordered or not equal - | FPT -- ^ Always true (always folded) - deriving (Eq, Ord, Enum, Show, Typeable) - -fromFPPredicate :: FPPredicate -> CInt -fromFPPredicate p = fromIntegral (fromEnum p) - -toFPPredicate :: CInt -> FPPredicate -toFPPredicate p = toEnum $ fromIntegral p - --- |Acceptable operands to comparison instructions. -class CmpRet (CmpType a b) => CmpOp a b where - type CmpType a b :: * - cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (CmpType a b))) - -instance (CmpRet a) => CmpOp (Value a) (Value a) where - type CmpType (Value a) (Value a) = a - cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2 - -{- -instance (IsConst a, CmpRet a) => CmpOp a (Value a) where - type CmpType a (Value a) = a - cmpop op a1 a2 = cmpop op (valueOf a1) a2 - -instance (IsConst a, CmpRet a) => CmpOp (Value a) a where - type CmpType (Value a) a = a - cmpop op a1 a2 = cmpop op a1 (valueOf a2) --} - -class CmpRet c where - type CmpResult c :: * - cmpBld :: c -> CmpPredicate -> FFIBinOp - -instance CmpRet Float where type CmpResult Float = Bool ; cmpBld _ = fcmpBld -instance CmpRet Double where type CmpResult Double = Bool ; cmpBld _ = fcmpBld -instance CmpRet FP128 where type CmpResult FP128 = Bool ; cmpBld _ = fcmpBld -instance CmpRet Bool where type CmpResult Bool = Bool ; cmpBld _ = ucmpBld -instance CmpRet Word8 where type CmpResult Word8 = Bool ; cmpBld _ = ucmpBld -instance CmpRet Word16 where type CmpResult Word16 = Bool ; cmpBld _ = ucmpBld -instance CmpRet Word32 where type CmpResult Word32 = Bool ; cmpBld _ = ucmpBld -instance CmpRet Word64 where type CmpResult Word64 = Bool ; cmpBld _ = ucmpBld -instance CmpRet Int8 where type CmpResult Int8 = Bool ; cmpBld _ = scmpBld -instance CmpRet Int16 where type CmpResult Int16 = Bool ; cmpBld _ = scmpBld -instance CmpRet Int32 where type CmpResult Int32 = Bool ; cmpBld _ = scmpBld -instance CmpRet Int64 where type CmpResult Int64 = Bool ; cmpBld _ = scmpBld -instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld -instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a) - where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; 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 r. - (CmpOp a b, c ~ CmpType a b) => - CmpPredicate -> a -> b -> - CodeGenFunction r (Value (CmpResult c)) -cmp p = cmpop (cmpBld (undefined :: CmpType a b) 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 ~ CmpType a b) => - CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) -_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))) - -_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) => - CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) -_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))) - -pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) => - IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c))) -pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) - - -{-# DEPRECATED icmp "use cmp or pcmp instead" #-} --- | Compare integers. -icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) => - IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) -icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) - --- | Compare floating point values. -fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) => - FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) -fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p)) - --------------------------------------- - --- XXX could do const song and dance --- | Select between two values depending on a boolean. -select :: (IsFirstClass a, CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a) -select (Value cnd) (Value thn) (Value els) = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ - FFI.buildSelect bldPtr cnd thn els - --------------------------------------- - -type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef - -{- -Function (a -> b -> IO c) -Value a -> Value b -> CodeGenFunction r c --} - --- |Acceptable arguments to 'call'. -class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) => - CallArgs f g r where - type CalledFunction g :: * - type CallerResult g :: * - type CallerFunction f r :: * - doCall :: Call f -> g - -instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where - type CalledFunction (Value a -> b') = a -> CalledFunction b' - type CallerResult (Value a -> b') = CallerResult b' - type CallerFunction (a -> b) r = Value a -> CallerFunction b r - doCall f a = doCall (applyCall f a) - ---instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where --- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a)) - -instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where - type CalledFunction (CodeGenFunction r (Value a)) = IO a - type CallerResult (CodeGenFunction r (Value a)) = r - type CallerFunction (IO a) r = CodeGenFunction r (Value a) - doCall = runCall - -doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a) -doCallDef mkCall args _ = - 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 --- it takes depends on the type of /f/. -call :: (CallArgs f g r) => Function f -> g -call = doCall . callFromFunction - -data Call a = Call Caller [FFI.ValueRef] - -callFromFunction :: Function a -> Call a -callFromFunction (Value f) = Call (U.makeCall f) [] - --- like Applicative.<*> -infixl 4 `applyCall` - -applyCall :: Call (a -> b) -> Value a -> Call b -applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args) - -runCall :: Call (IO a) -> CodeGenFunction r (Value a) -runCall (Call mkCall args) = doCallDef mkCall args () - - -invokeFromFunction :: - BasicBlock -- ^Normal return point. - -> BasicBlock -- ^Exception return point. - -> Function f -- ^Function to call. - -> Call f -invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) = - Call (U.makeInvoke norm expt f) [] - --- | Call a function with exception handling. -invoke :: (CallArgs f g r) - => BasicBlock -- ^Normal return point. - -> BasicBlock -- ^Exception return point. - -> Function f -- ^Function to call. - -> g -invoke norm expt f = doCall $ invokeFromFunction norm expt f - -callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f -callWithConvFromFunction cc (Value f) = - Call (U.makeCallWithCc cc f) [] - --- | Call a function with the given arguments. The 'call' instruction --- is variadic, i.e., the number of arguments it takes depends on the --- type of /f/. --- This also sets the calling convention of the call to the function. --- As LLVM itself defines, if the calling conventions of the calling --- /instruction/ and the function being /called/ are different, undefined --- behavior results. -callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g -callWithConv cc f = doCall $ callWithConvFromFunction cc f - -invokeWithConvFromFunction :: - FFI.CallingConvention -- ^Calling convention - -> BasicBlock -- ^Normal return point. - -> BasicBlock -- ^Exception return point. - -> Function f -- ^Function to call. - -> Call f -invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) = - Call (U.makeInvokeWithCc cc norm expt f) [] - --- | Call a function with exception handling. --- This also sets the calling convention of the call to the function. --- As LLVM itself defines, if the calling conventions of the calling --- /instruction/ and the function being /called/ are different, undefined --- behavior results. -invokeWithConv :: (CallArgs f g r) - => FFI.CallingConvention -- ^Calling convention - -> BasicBlock -- ^Normal return point. - -> BasicBlock -- ^Exception return point. - -> Function f -- ^Function to call. - -> g -invokeWithConv cc norm expt f = - doCall $ invokeWithConvFromFunction cc norm expt f - --------------------------------------- - --- XXX could do const song and dance --- |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 = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> do - inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a)) - U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] - return inst - --- |Add additional inputs to an existing phi node. --- The reason for this instruction is that sometimes the structure of the code --- makes it impossible to have all variables in scope at the point where you need the phi node. -addPhiInputs :: forall a r . (IsFirstClass a) - => Value a -- ^Must be a variable from a call to 'phi'. - -> [(Value a, BasicBlock)] -- ^Variables to add. - -> 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 -> Value Word32 -instance AllocArg (Value Word32) where - getAllocArg = id -instance AllocArg (ConstValue Word32) where - getAllocArg = value -instance AllocArg Word32 where - 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 . (IsSized a) => CodeGenFunction r (Value (Ptr 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 <- bitcast =<< - 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 r s . (IsSized a, AllocArg s) => - s -> CodeGenFunction r (Value (Ptr a)) -- XXX -arrayMalloc s = do - func <- staticFunction alignedMalloc --- func <- externFunction "malloc" - - size <- sizeOfArray (undefined :: a) (getAllocArg s) - alignment <- alignOf (undefined :: a) - bitcast =<< - 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 . (IsSized a) => CodeGenFunction r (Value (Ptr a)) -alloca = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a)) - --- XXX What's the type returned by arrayAlloca? --- | Allocate stack (array) memory. -arrayAlloca :: forall a r s . (IsSized a, AllocArg s) => - s -> CodeGenFunction r (Value (Ptr a)) -arrayAlloca s = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ - 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 :: (IsType a) => Value (Ptr a) -> CodeGenFunction r () -free ptr = do - func <- staticFunction alignedFree --- func <- externFunction "free" - _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast 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 . (IsSized a) => a -> CodeGenFunction r (Value Word64) -_sizeOf a = - liftIO $ liftM Value $ - FFI.sizeOf (typeRef a) - -_alignOf :: forall a r . (IsSized a) => 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 . (IsSized a) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8)) -sizeOfArray _ len = - bitcast =<< - getElementPtr (value zero :: Value (Ptr a)) (len, ()) - --- see ConstantExpr::getAlignOf -alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value (Ptr Word8)) -alignOf _ = - bitcast =<< - getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ()) - - --- | Load a value from memory. -load :: Value (Ptr a) -- ^ Address to load from. - -> CodeGenFunction r (Value a) -load (Value p) = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withEmptyCString $ FFI.buildLoad bldPtr p - --- | Store a value in memory -store :: Value a -- ^ Value to store. - -> Value (Ptr a) -- ^ Address to store to. - -> CodeGenFunction r () -store (Value v) (Value p) = do - withCurrentBuilder_ $ \ bldPtr -> - FFI.buildStore bldPtr v p - return () - -{- --- XXX type is wrong --- | Address arithmetic. See LLVM description. --- (The type isn't as accurate as it should be.) -getElementPtr :: (IsInteger i) => - Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b)) -getElementPtr (Value ptr) ixs = - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr -> - U.withEmptyCString $ - FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) --} - --- |Acceptable arguments to 'getElementPointer'. -class GetElementPtr optr ixs where - type ElementPtrType optr ixs :: * - getIxList :: optr -> ixs -> [FFI.ValueRef] - --- |Acceptable single index to 'getElementPointer'. -class IsIndexArg a where - getArg :: a -> FFI.ValueRef - -instance IsIndexArg (Value Word32) where - getArg (Value v) = v - -instance IsIndexArg (Value Word64) where - getArg (Value v) = v - -instance IsIndexArg (Value Int32) where - getArg (Value v) = v - -instance IsIndexArg (Value Int64) where - getArg (Value v) = v - -instance IsIndexArg (ConstValue Word32) where - getArg = unConst - -instance IsIndexArg (ConstValue Word64) where - getArg = unConst - -instance IsIndexArg (ConstValue Int32) where - getArg = unConst - -instance IsIndexArg (ConstValue Int64) where - getArg = unConst - -instance IsIndexArg Word32 where - getArg = unConst . constOf - -instance IsIndexArg Word64 where - getArg = unConst . constOf - -instance IsIndexArg Int32 where - getArg = unConst . constOf - -instance IsIndexArg Int64 where - getArg = unConst . constOf - -unConst :: ConstValue a -> FFI.ValueRef -unConst (ConstValue v) = v - --- End of indexing -instance GetElementPtr a () where - type ElementPtrType a () = a - getIxList _ () = [] - --- Index in Array -instance (GetElementPtr o i, IsIndexArg a, NaturalT k) => GetElementPtr (Array k o) (a, i) where - type ElementPtrType (Array k o) (a, i) = ElementPtrType o i - getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i - --- Index in Vector -instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where - type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i - getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i - --- Index in Struct and PackedStruct. --- The index has to be a type level integer to statically determine the record field type -instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (Struct fs) (a, i) where - type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i - getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i -instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where - type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i - getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i - -class GetField as i where type FieldType as i :: * -instance GetField (a, as) (Dec DecN) where type FieldType (a, as) (Dec DecN) = a -instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0))) - --- | Address arithmetic. See LLVM description. --- The index is a nested tuple of the form @(i1,(i2,( ... ())))@. --- (This is without a doubt the most confusing LLVM instruction, but the types help.) -getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) => - Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) -getElementPtr (Value ptr) (a, ixs) = - let ixl = getArg a : getIxList (undefined :: o) ixs in - liftM Value $ - withCurrentBuilder $ \ bldPtr -> - U.withArrayLen ixl $ \ idxLen idxPtr -> - U.withEmptyCString $ - FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) - --- | Like getElementPtr, but with an initial index that is 0. --- This is useful since any pointer first need to be indexed off the pointer, and then into --- its actual value. This first indexing is often with 0. -getElementPtr0 :: (GetElementPtr o i) => - Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) -getElementPtr0 p i = getElementPtr p (0::Word32, i) - --------------------------------------- -{- -instance (IsConst a) => Show (ConstValue a) -- XXX -instance (IsConst a) => Eq (ConstValue a) - -{- -instance (IsConst a) => Eq (ConstValue a) where - ConstValue x == ConstValue y = - if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOEQ) x y) - else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y) - ConstValue x /= ConstValue y = - if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPONE) x y) - else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y) - -instance (IsConst a) => Ord (ConstValue a) where - ConstValue x < ConstValue y = - if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLT) x y) - else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y) - ConstValue x <= ConstValue y = - if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLE) x y) - else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y) - ConstValue x > ConstValue y = - if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGT) x y) - else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y) - ConstValue x >= ConstValue y = - if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGE) x y) - else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y) --} - -instance (Num a, IsConst a) => Num (ConstValue a) where - ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y) - ConstValue x - ConstValue y = ConstValue (FFI.constSub x y) - ConstValue x * ConstValue y = ConstValue (FFI.constMul x y) - negate (ConstValue x) = ConstValue (FFI.constNeg x) - fromInteger x = constOf (fromInteger x :: a) --} diff --git a/LLVM/Core/Type.hs b/LLVM/Core/Type.hs deleted file mode 100644 --- a/LLVM/Core/Type.hs +++ /dev/null @@ -1,504 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeFamilies #-} --- |The LLVM type system is captured with a number of Haskell type classes. --- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type. --- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for --- those types that are LLVM first class types (passable as arguments etc). --- All valid LLVM types belong to the 'IsType' class. -module LLVM.Core.Type( - -- * Type classifier - IsType(..), - -- ** Special type classifiers - NaturalT, - PositiveT, - IsArithmetic(arithmeticType), - ArithmeticType(IntegerType,FloatingType), - IsInteger, Signed, - IsIntegerOrPointer, - IsFloating, - IsPrimitive, - IsFirstClass, - IsSized, SizeOf, sizeOf, - IsFunction, - -- ** Others - IsScalarOrVector, NumberOfElements, - UnknownSize, -- needed for arrays of structs - -- ** Structs - (:&), (&), - -- ** Type tests - TypeDesc(..), - isFloating, - isSigned, - typeRef, - typeName, - intrinsicTypeName, - typeDesc2, - VarArgs, CastVarArgs, - ) where -import Data.Typeable -import Data.List(intercalate) -import Data.Int -import Data.Word -import Types.Data.Num -import Types.Data.Bool (True, False) -import Foreign.StablePtr (StablePtr, ) -import LLVM.Core.Util(functionType, structType) -import LLVM.Core.Data -import qualified LLVM.FFI.Core as FFI - -#include "MachDeps.h" - --- TODO: --- Move IntN, WordN to a special module that implements those types --- properly in Haskell. --- Also more Array and Vector to a Haskell module to implement them. --- Add Label? --- Add structures (using tuples, maybe nested). - --- |The 'IsType' class classifies all types that have an LLVM representation. -class IsType a where - typeDesc :: a -> TypeDesc - -typeRef :: (IsType a) => a -> FFI.TypeRef -- ^The argument is never evaluated -typeRef = code . typeDesc - where code TDFloat = FFI.floatType - code TDDouble = FFI.doubleType - code TDFP128 = FFI.fP128Type - code TDVoid = FFI.voidType - code (TDInt _ n) = FFI.integerType (fromInteger n) - code (TDArray n a) = FFI.arrayType (code a) (fromInteger n) - code (TDVector n a) = FFI.vectorType (code a) (fromInteger n) - code (TDPtr a) = FFI.pointerType (code a) 0 - code (TDFunction va as b) = functionType va (code b) (map code as) - code TDLabel = FFI.labelType - code (TDStruct ts packed) = structType (map code ts) packed - code TDInvalidType = error "typeRef TDInvalidType" - -typeName :: (IsType a) => a -> String -typeName = code . typeDesc - where code TDFloat = "f32" - code TDDouble = "f64" - code TDFP128 = "f128" - code TDVoid = "void" - code (TDInt _ n) = "i" ++ show n - code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]" - code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">" - code (TDPtr a) = code a ++ "*" - code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")" - code TDLabel = "label" - code (TDStruct as packed) = (if packed then "<{" else "{") ++ - intercalate "," (map code as) ++ - (if packed then "}>" else "}") - code TDInvalidType = error "typeName TDInvalidType" - -intrinsicTypeName :: (IsType a) => a -> String -intrinsicTypeName = code . typeDesc - where code TDFloat = "f32" - code TDDouble = "f64" - code TDFP128 = "f128" - code (TDInt _ n) = "i" ++ show n - code (TDVector n a) = "v" ++ show n ++ code a - code _ = error "intrinsicTypeName: type not supported in intrinsics" - -typeDesc2 :: FFI.TypeRef -> IO TypeDesc -typeDesc2 t = do - tk <- FFI.getTypeKind t - case tk of - FFI.VoidTypeKind -> return TDVoid - FFI.FloatTypeKind -> return TDFloat - FFI.DoubleTypeKind -> return TDDouble - -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80" - FFI.FP128TypeKind -> return TDFP128 - -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128" - FFI.LabelTypeKind -> return TDLabel - FFI.IntegerTypeKind -> do - n <- FFI.getIntTypeWidth t - return $ TDInt False (fromIntegral n) - -- FIXME: FFI.FunctionTypeKind - -- FIXME: FFI.StructTypeKind -> return "(Struct ...)" - FFI.ArrayTypeKind -> do - n <- FFI.getArrayLength t - et <- FFI.getElementType t - etd <- typeDesc2 et - return $ TDArray (fromIntegral n) etd - FFI.PointerTypeKind -> do - et <- FFI.getElementType t - etd <- typeDesc2 et - return $ TDPtr etd - -- FIXME: FFI.OpaqueTypeKind -> return "Opaque" - FFI.VectorTypeKind -> do - n <- FFI.getVectorSize t - et <- FFI.getElementType t - etd <- typeDesc2 et - return $ TDVector (fromIntegral n) etd - -- FIXME: LLVMMetadataTypeKind, /**< Metadata */ - -- FIXME: LLVMX86_MMXTypeKind /**< X86 MMX */ - _ -> return TDInvalidType - --- |Type descriptor, used to convey type information through the LLVM API. -data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer - | TDArray Integer TypeDesc | TDVector Integer TypeDesc - | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel - | TDStruct [TypeDesc] Bool | TDInvalidType - deriving (Eq, Ord, Show, Typeable) - --- XXX isFloating and typeName could be extracted from typeRef --- Usage: --- superclass of IsConst --- add, sub, mul, neg context --- used to get type name to call intrinsic --- |Arithmetic types, i.e., integral and floating types. -class IsFirstClass a => IsArithmetic a 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 --- used to find signedness in Arithmetic --- |Integral types. -class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where - type Signed a :: * - --- Usage: --- icmp --- |Integral or pointer type. -class IsIntegerOrPointer a - -isSigned :: (IsInteger a) => a -> Bool -isSigned = is . typeDesc - where is (TDInt s _) = s - is (TDVector _ a) = is a - is _ = error "isSigned got impossible input" - --- Usage: --- constF --- many instructions --- |Floating types. -class IsArithmetic a => IsFloating a - -isFloating :: (IsArithmetic a) => a -> Bool -isFloating = is . typeDesc - where is TDFloat = True - is TDDouble = True - is TDFP128 = True - is (TDVector _ a) = is a - is _ = False - --- Usage: --- Precondition for Vector --- |Primitive types. --- class (IsType a) => IsPrimitive a -class (IsType a, NumberOfElements a ~ D1) => IsPrimitive a - --- |Number of elements for instructions that handle both primitive and vector types -class (IsType a) => IsScalarOrVector a where - type NumberOfElements a :: * - - --- Usage: --- Precondition for function args and result. --- Used by some instructions, like ret and phi. --- XXX IsSized as precondition? --- |First class types, i.e., the types that can be passed as arguments, etc. -class IsType a => IsFirstClass a - --- Usage: --- Context for Array being a type --- thus, allocation instructions --- |Types with a fixed size. -class (IsType a, PositiveT (SizeOf a)) => IsSized a where - type SizeOf a :: * - -sizeOf :: TypeDesc -> Integer -sizeOf TDFloat = 32 -sizeOf TDDouble = 64 -sizeOf TDFP128 = 128 -sizeOf (TDInt _ bits) = bits -sizeOf (TDArray n typ) = n * sizeOf typ -sizeOf (TDVector n typ) = n * sizeOf typ -sizeOf (TDStruct ts _packed) = sum (map sizeOf ts) -sizeOf _ = error "type has no size" - --- |Function type. -class (IsType a) => IsFunction a where - funcType :: [TypeDesc] -> a -> TypeDesc - --- Only make instances for types that make sense in Haskell --- (i.e., some floating types are excluded). - --- Floating point types. -instance IsType Float where typeDesc _ = TDFloat -instance IsType Double where typeDesc _ = TDDouble -instance IsType FP128 where typeDesc _ = TDFP128 - --- Void type -instance IsType () where typeDesc _ = TDVoid - --- Label type -instance IsType Label where typeDesc _ = TDLabel - --- Variable size integer types -instance (PositiveT n) => IsType (IntN n) - where typeDesc _ = TDInt True (fromIntegerT (undefined :: n)) - -instance (PositiveT n) => IsType (WordN n) - where typeDesc _ = TDInt False (fromIntegerT (undefined :: n)) - --- Fixed size integer types. -instance IsType Bool where typeDesc _ = TDInt False 1 -instance IsType Word8 where typeDesc _ = TDInt False 8 -instance IsType Word16 where typeDesc _ = TDInt False 16 -instance IsType Word32 where typeDesc _ = TDInt False 32 -instance IsType Word64 where typeDesc _ = TDInt False 64 -instance IsType Int8 where typeDesc _ = TDInt True 8 -instance IsType Int16 where typeDesc _ = TDInt True 16 -instance IsType Int32 where typeDesc _ = TDInt True 32 -instance IsType Int64 where typeDesc _ = TDInt True 64 - --- Sequence types -instance (NaturalT n, IsSized a) => IsType (Array n a) - where typeDesc _ = TDArray (fromIntegerT (undefined :: n)) - (typeDesc (undefined :: a)) -instance (PositiveT n, IsPrimitive a) => IsType (Vector n a) - where typeDesc _ = TDVector (fromIntegerT (undefined :: n)) - (typeDesc (undefined :: a)) - --- Pointer type. -instance (IsType a) => IsType (Ptr a) where - typeDesc _ = TDPtr (typeDesc (undefined :: a)) - -instance IsType (StablePtr a) where - typeDesc _ = TDPtr (typeDesc (undefined :: Int8)) -{- - typeDesc _ = TDPtr TDVoid - -List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed. --} - - --- Functions. -instance (IsFirstClass a, IsFunction b) => IsType (a->b) where - typeDesc = funcType [] - --- Function base type, always IO. -instance (IsFirstClass a) => IsType (IO a) where - typeDesc = funcType [] - --- Struct types, basically a list of component types. -instance (StructFields a) => IsType (Struct a) where - typeDesc ~(Struct a) = TDStruct (fieldTypes a) False - -instance (StructFields a) => IsType (PackedStruct a) where - typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True - --- Use a nested tuples for struct fields. -class StructFields as where - fieldTypes :: as -> [TypeDesc] - -instance (IsSized a, StructFields as) => StructFields (a :& as) where - fieldTypes ~(a, as) = typeDesc a : fieldTypes as -instance StructFields () where - fieldTypes _ = [] - --- An alias for pairs to make structs look nicer -infixr :& -type (:&) a as = (a, as) -infixr & -(&) :: a -> as -> a :& as -a & as = (a, as) - ---- Instances to classify types -instance IsArithmetic Float where arithmeticType = FloatingType -instance IsArithmetic Double where arithmeticType = FloatingType -instance IsArithmetic FP128 where arithmeticType = FloatingType -instance (PositiveT n) => IsArithmetic (IntN n) where arithmeticType = IntegerType -instance (PositiveT 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 (PositiveT n, IsPrimitive a, IsArithmetic a) => - IsArithmetic (Vector n a) where - arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType - -instance IsFloating Float -instance IsFloating Double -instance IsFloating FP128 -instance (PositiveT n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a) - -data NotANumber - -instance (PositiveT n) => IsInteger (IntN n) where type Signed (IntN n) = True -instance (PositiveT n) => IsInteger (WordN n) where type Signed (WordN n) = False -instance IsInteger Bool where type Signed Bool = NotANumber -instance IsInteger Int8 where type Signed Int8 = True -instance IsInteger Int16 where type Signed Int16 = True -instance IsInteger Int32 where type Signed Int32 = True -instance IsInteger Int64 where type Signed Int64 = True -instance IsInteger Word8 where type Signed Word8 = False -instance IsInteger Word16 where type Signed Word16 = False -instance IsInteger Word32 where type Signed Word32 = False -instance IsInteger Word64 where type Signed Word64 = False -instance (PositiveT n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a) - where type Signed (Vector n a) = Signed a - -instance (PositiveT n) => IsIntegerOrPointer (IntN n) -instance (PositiveT n) => IsIntegerOrPointer (WordN n) -instance IsIntegerOrPointer Bool -instance IsIntegerOrPointer Int8 -instance IsIntegerOrPointer Int16 -instance IsIntegerOrPointer Int32 -instance IsIntegerOrPointer Int64 -instance IsIntegerOrPointer Word8 -instance IsIntegerOrPointer Word16 -instance IsIntegerOrPointer Word32 -instance IsIntegerOrPointer Word64 -instance (PositiveT n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a) -instance (IsType a) => IsIntegerOrPointer (Ptr a) - -instance IsFirstClass Float -instance IsFirstClass Double -instance IsFirstClass FP128 -instance (PositiveT n) => IsFirstClass (IntN n) -instance (PositiveT n) => IsFirstClass (WordN n) -instance IsFirstClass Bool -instance IsFirstClass Int8 -instance IsFirstClass Int16 -instance IsFirstClass Int32 -instance IsFirstClass Int64 -instance IsFirstClass Word8 -instance IsFirstClass Word16 -instance IsFirstClass Word32 -instance IsFirstClass Word64 -instance (PositiveT n, IsPrimitive a) => IsFirstClass (Vector n a) -instance (NaturalT n, IsSized a) => IsFirstClass (Array n a) -instance (IsType a) => IsFirstClass (Ptr a) -instance IsFirstClass (StablePtr a) -instance IsFirstClass Label -instance IsFirstClass () -- XXX This isn't right, but () can be returned -instance (StructFields as) => IsFirstClass (Struct as) - -instance (PositiveT n) => IsSized (IntN n) where type SizeOf (IntN n) = n -instance (PositiveT n) => IsSized (WordN n) where type SizeOf (WordN n) = n -instance IsSized Float where type SizeOf Float = D32 -instance IsSized Double where type SizeOf Double = D64 -instance IsSized FP128 where type SizeOf FP128 = D128 -instance IsSized Bool where type SizeOf Bool = D1 -instance IsSized Int8 where type SizeOf Int8 = D8 -instance IsSized Int16 where type SizeOf Int16 = D16 -instance IsSized Int32 where type SizeOf Int32 = D32 -instance IsSized Int64 where type SizeOf Int64 = D64 -instance IsSized Word8 where type SizeOf Word8 = D8 -instance IsSized Word16 where type SizeOf Word16 = D16 -instance IsSized Word32 where type SizeOf Word32 = D32 -instance IsSized Word64 where type SizeOf Word64 = D64 -instance (NaturalT n, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Array n a) where - type SizeOf (Array n a) = n :*: SizeOf a -instance (PositiveT n, IsPrimitive a, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Vector n a) where - type SizeOf (Vector n a) = n :*: SizeOf a -instance (IsType a) => IsSized (Ptr a) where type SizeOf (Ptr a) = PtrSize -instance IsSized (StablePtr a) where type SizeOf (StablePtr a) = PtrSize --- instance IsSized Label PtrSize -- labels are not quite first classed --- We cannot compute the sizes statically :( -instance (StructFields as) => IsSized (Struct as) where - type SizeOf (Struct as) = UnknownSize -instance (StructFields as) => IsSized (PackedStruct as) where - type SizeOf (PackedStruct as) = UnknownSize - -type UnknownSize = D99 -- XXX this is wrong! - -#if WORD_SIZE_IN_BITS == 32 -type PtrSize = D32 -#elif WORD_SIZE_IN_BITS == 64 -type PtrSize = D64 -#else -#error cannot determine type of PtrSize -#endif - -instance IsPrimitive Float -instance IsPrimitive Double -instance IsPrimitive FP128 -instance (PositiveT n) => IsPrimitive (IntN n) -instance (PositiveT n) => IsPrimitive (WordN n) -instance IsPrimitive Bool -instance IsPrimitive Int8 -instance IsPrimitive Int16 -instance IsPrimitive Int32 -instance IsPrimitive Int64 -instance IsPrimitive Word8 -instance IsPrimitive Word16 -instance IsPrimitive Word32 -instance IsPrimitive Word64 -instance IsPrimitive Label -instance IsPrimitive () - - -instance (PositiveT n) => - IsScalarOrVector (IntN n) where type NumberOfElements (IntN n) = D1 -instance (PositiveT n) => - IsScalarOrVector (WordN n) where type NumberOfElements (WordN n) = D1 -instance IsScalarOrVector Float where type NumberOfElements Float = D1 -instance IsScalarOrVector Double where type NumberOfElements Double = D1 -instance IsScalarOrVector FP128 where type NumberOfElements FP128 = D1 -instance IsScalarOrVector Bool where type NumberOfElements Bool = D1 -instance IsScalarOrVector Int8 where type NumberOfElements Int8 = D1 -instance IsScalarOrVector Int16 where type NumberOfElements Int16 = D1 -instance IsScalarOrVector Int32 where type NumberOfElements Int32 = D1 -instance IsScalarOrVector Int64 where type NumberOfElements Int64 = D1 -instance IsScalarOrVector Word8 where type NumberOfElements Word8 = D1 -instance IsScalarOrVector Word16 where type NumberOfElements Word16 = D1 -instance IsScalarOrVector Word32 where type NumberOfElements Word32 = D1 -instance IsScalarOrVector Word64 where type NumberOfElements Word64 = D1 -instance IsScalarOrVector Label where type NumberOfElements Label = D1 -instance IsScalarOrVector () where type NumberOfElements () = D1 - -instance (PositiveT n, IsPrimitive a) => - IsScalarOrVector (Vector n a) where - type NumberOfElements (Vector n a) = n - - --- Functions. -instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where - funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b) -instance (IsFirstClass a) => IsFunction (IO a) where - funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a)) -instance (IsFirstClass a) => IsFunction (VarArgs a) where - funcType ts _ = TDFunction True (reverse ts) (typeDesc (undefined :: a)) - --- |The 'VarArgs' type is a placeholder for the real 'IO' type that --- can be obtained with 'castVarArgs'. -data VarArgs a - deriving (Typeable) -instance IsType (VarArgs a) where - typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly" - --- |Define what vararg types are permissible. -class CastVarArgs a b -instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c) -instance CastVarArgs (VarArgs a) (IO a) -instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c) - - - - --- XXX Structures not implemented. Tuples is probably an easy way. - diff --git a/LLVM/Core/Util.hs b/LLVM/Core/Util.hs deleted file mode 100644 --- a/LLVM/Core/Util.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveDataTypeable #-} -module LLVM.Core.Util( - -- * Module handling - Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile, - getModuleValues, getFunctions, getGlobalVariables, valueHasType, - -- * Module provider handling - ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule, - -- * Pass manager handling - PassManager(..), withPassManager, createPassManager, createFunctionPassManager, - runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager, - -- * Instruction builder - Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock, - -- * Basic blocks - BasicBlock, - appendBasicBlock, getBasicBlocks, - -- * Functions - Function, - addFunction, getParam, getParams, - -- * Structs - structType, - -- * Globals - addGlobal, - constString, constStringNul, constVector, constArray, constStruct, - -- * Instructions - makeCall, makeInvoke, - makeCallWithCc, makeInvokeWithCc, - withValue, getInstructions, getOperands, - -- * Uses and Users - hasUsers, getUsers, getUses, getUser, isChildOf, getDep, - -- * Misc - CString, withArrayLen, - withEmptyCString, - functionType, buildEmptyPhi, addPhiIns, - showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant, - -- * Transformation passes - addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, - addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, - addTargetData - ) where -import Data.Typeable -import Data.List(intercalate) -import Control.Monad(liftM, filterM, when) -import Foreign.C.String (withCString, withCStringLen, CString, peekCString) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Storable (Storable(..)) -import Foreign.Marshal.Utils (fromBool) -import System.IO.Unsafe (unsafePerformIO) - -import qualified LLVM.FFI.Core as FFI -import qualified LLVM.FFI.Target as FFI -import qualified LLVM.FFI.BitWriter as FFI -import qualified LLVM.FFI.BitReader as FFI -import qualified LLVM.FFI.Transforms.Scalar as FFI - -type Type = FFI.TypeRef - --- unsafePerformIO just to wrap the non-effecting withArrayLen call -functionType :: Bool -> Type -> [Type] -> Type -functionType varargs retType paramTypes = unsafePerformIO $ - withArrayLen paramTypes $ \ len ptr -> - return $ FFI.functionType retType ptr (fromIntegral len) - (fromBool varargs) - --- unsafePerformIO just to wrap the non-effecting withArrayLen call -structType :: [Type] -> Bool -> Type -structType types packed = unsafePerformIO $ - withArrayLen types $ \ len ptr -> - return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0) - --------------------------------------- --- Handle modules - --- Don't use a finalizer for the module, but instead provide an --- explicit destructor. This is because handing a module to --- a module provider changes ownership of the module to the provider, --- and we don't want to free it by mistake. - --- | Type of top level modules. -newtype Module = Module { - fromModule :: FFI.ModuleRef - } - deriving (Show, Typeable) - -withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a -withModule modul f = f (fromModule modul) - -createModule :: String -> IO Module -createModule name = - withCString name $ \ namePtr -> do - liftM Module $ FFI.moduleCreateWithName namePtr - --- | Free all storage related to a module. *Note*, this is a dangerous call, since referring --- to the module after this call is an error. The reason for the explicit call to free --- the module instead of an automatic lifetime management is that modules have a --- somewhat complicated ownership. Handing a module to a module provider changes --- the ownership of the module, and the module provider will free the module when necessary. -destroyModule :: Module -> IO () -destroyModule = FFI.disposeModule . fromModule - --- |Write a module to a file. -writeBitcodeToFile :: String -> Module -> IO () -writeBitcodeToFile name mdl = - withCString name $ \ namePtr -> - withModule mdl $ \ mdlPtr -> do - rc <- FFI.writeBitcodeToFile mdlPtr namePtr - when (rc /= 0) $ - ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc - return () - --- |Read a module from a file. -readBitcodeFromFile :: String -> IO Module -readBitcodeFromFile name = - withCString name $ \ namePtr -> - alloca $ \ bufPtr -> - alloca $ \ modPtr -> - alloca $ \ errStr -> do - rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr - if rrc /= 0 then do - msg <- peek errStr >>= peekCString - ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg - else do - buf <- peek bufPtr - prc <- FFI.parseBitcode buf modPtr errStr - if prc /= 0 then do - msg <- peek errStr >>= peekCString - ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg - else do - ptr <- peek modPtr - return $ Module ptr -{- - liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr --} - -getModuleValues :: Module -> IO [(String, Value)] -getModuleValues mdl = do - fs <- getFunctions mdl - gs <- getGlobalVariables mdl - return (fs ++ gs) - -getFunctions :: Module -> IO [(String, Value)] -getFunctions mdl = getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl >>= filterM isIntrinsic >>= annotateValueList - -getGlobalVariables :: Module -> IO [(String, Value)] -getGlobalVariables mdl = getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl >>= annotateValueList - --- This is safe because we just ask for the type of a value. -valueHasType :: Value -> Type -> Bool -valueHasType v t = unsafePerformIO $ do - vt <- FFI.typeOf v - return $ vt == t -- LLVM uses hash consing for types, so pointer equality works. - -showTypeOf :: Value -> IO String -showTypeOf v = FFI.typeOf v >>= showType' - -showType' :: Type -> IO String -showType' p = do - pk <- FFI.getTypeKind p - case pk of - FFI.VoidTypeKind -> return "()" - FFI.FloatTypeKind -> return "Float" - FFI.DoubleTypeKind -> return "Double" - FFI.X86_FP80TypeKind -> return "X86_FP80" - FFI.FP128TypeKind -> return "FP128" - FFI.PPC_FP128TypeKind -> return "PPC_FP128" - FFI.LabelTypeKind -> return "Label" - FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")" - FFI.FunctionTypeKind -> do - r <- FFI.getReturnType p - c <- FFI.countParamTypes p - let n = fromIntegral c - as <- allocaArray n $ \ args -> do - FFI.getParamTypes p args - peekArray n args - ts <- mapM showType' (as ++ [r]) - return $ "(" ++ intercalate " -> " ts ++ ")" - FFI.StructTypeKind -> return "(Struct ...)" - FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")" - FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")" - FFI.OpaqueTypeKind -> return "Opaque" - FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")" - --------------------------------------- --- Handle module providers - --- | A module provider is used by the code generator to get access to a module. -newtype ModuleProvider = ModuleProvider { - fromModuleProvider :: ForeignPtr FFI.ModuleProvider - } - deriving (Show, Typeable) - -withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a) - -> IO a -withModuleProvider = withForeignPtr . fromModuleProvider - --- | Turn a module into a module provider. -createModuleProviderForExistingModule :: Module -> IO ModuleProvider -createModuleProviderForExistingModule modul = - withModule modul $ \modulPtr -> do - ptr <- FFI.createModuleProviderForExistingModule modulPtr - -- MPs given to the EE get taken over, so we should not GC them. - liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr - - --------------------------------------- --- Handle instruction builders - -newtype Builder = Builder { - fromBuilder :: ForeignPtr FFI.Builder - } - deriving (Show, Typeable) - -withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a -withBuilder = withForeignPtr . fromBuilder - -createBuilder :: IO Builder -createBuilder = do - ptr <- FFI.createBuilder - liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr - -positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO () -positionAtEnd bld bblk = - withBuilder bld $ \ bldPtr -> - FFI.positionAtEnd bldPtr bblk - -getInsertBlock :: Builder -> IO FFI.BasicBlockRef -getInsertBlock bld = - withBuilder bld $ \ bldPtr -> - FFI.getInsertBlock bldPtr - --------------------------------------- - -type BasicBlock = FFI.BasicBlockRef - -appendBasicBlock :: Function -> String -> IO BasicBlock -appendBasicBlock func name = - withCString name $ \ namePtr -> - FFI.appendBasicBlock func namePtr - -getBasicBlocks :: Value -> IO [(String, Value)] -getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v >>= annotateValueList - --------------------------------------- - -type Function = FFI.ValueRef - -addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function -addFunction modul linkage name typ = - withModule modul $ \ modulPtr -> - withCString name $ \ namePtr -> do - f <- FFI.addFunction modulPtr namePtr typ - FFI.setLinkage f (FFI.fromLinkage linkage) - return f - -getParam :: Function -> Int -> Value -getParam f = FFI.getParam f . fromIntegral - -getParams :: Value -> IO [(String, Value)] -getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList - --------------------------------------- - -addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value -addGlobal modul linkage name typ = - withModule modul $ \ modulPtr -> - withCString name $ \ namePtr -> do - v <- FFI.addGlobal modulPtr typ namePtr - FFI.setLinkage v (FFI.fromLinkage linkage) - return v - --- unsafePerformIO is safe because it's only used for the withCStringLen conversion -constStringInternal :: Bool -> String -> Value -constStringInternal nulTerm s = unsafePerformIO $ - withCStringLen s $ \(sPtr, sLen) -> - return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm)) - -constString :: String -> Value -constString = constStringInternal False - -constStringNul :: String -> Value -constStringNul = constStringInternal True - --------------------------------------- - -type Value = FFI.ValueRef - -withValue :: Value -> (Value -> IO a) -> IO a -withValue v f = f v - -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 -{- - print "makeCall" - FFI.dumpValue func - mapM_ FFI.dumpValue args - print "----------------------" --} - withArrayLen args $ \ argLen argPtr -> - withEmptyCString $ \cstr -> do - i <- FFI.buildCall bldPtr func argPtr - (fromIntegral argLen) cstr - FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) - return i - -makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> - [Value] -> IO Value -makeInvoke = makeInvokeWithCc FFI.C - -makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> - [Value] -> IO Value -makeInvokeWithCc cc norm expt func bldPtr args = - withArrayLen args $ \ argLen argPtr -> - withEmptyCString $ \cstr -> do - i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr - FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) - return i - -getInstructions :: Value -> IO [(String, Value)] -getInstructions bb = getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList - -getOperands :: Value -> IO [(String, Value)] -getOperands ii = geto ii >>= annotateValueList - where geto i = do - num <- FFI.getNumOperands i - let oloop instr number total = if number >= total then return [] else do - o <- FFI.getOperand instr number - os <- oloop instr (number + 1) total - return (o : os) - oloop i 0 num - --------------------------------------- - -buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value -buildEmptyPhi bldPtr typ = do - withEmptyCString $ FFI.buildPhi bldPtr typ - -withEmptyCString :: (CString -> IO a) -> IO a -withEmptyCString = withCString "" - -addPhiIns :: Value -> [(Value, BasicBlock)] -> IO () -addPhiIns inst incoming = do - let (vals, bblks) = unzip incoming - withArrayLen vals $ \ count valPtr -> - withArray bblks $ \ bblkPtr -> - FFI.addIncoming inst valPtr bblkPtr (fromIntegral count) - --------------------------------------- - --- | Manage compile passes. -newtype PassManager = PassManager { - fromPassManager :: ForeignPtr FFI.PassManager - } - deriving (Show, Typeable) - -withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a) - -> IO a -withPassManager = withForeignPtr . fromPassManager - --- | Create a pass manager. -createPassManager :: IO PassManager -createPassManager = do - ptr <- FFI.createPassManager - liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr - --- | Create a pass manager for a module. -createFunctionPassManager :: ModuleProvider -> IO PassManager -createFunctionPassManager modul = - withModuleProvider modul $ \modulPtr -> do - ptr <- FFI.createFunctionPassManager modulPtr - liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr - --- | Add a control flow graph simplification pass to the manager. -addCFGSimplificationPass :: PassManager -> IO () -addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass - --- | Add a constant propagation pass to the manager. -addConstantPropagationPass :: PassManager -> IO () -addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass - -addDemoteMemoryToRegisterPass :: PassManager -> IO () -addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass - --- | Add a global value numbering pass to the manager. -addGVNPass :: PassManager -> IO () -addGVNPass pm = withPassManager pm FFI.addGVNPass - -addInstructionCombiningPass :: PassManager -> IO () -addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass - -addPromoteMemoryToRegisterPass :: PassManager -> IO () -addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass - -addReassociatePass :: PassManager -> IO () -addReassociatePass pm = withPassManager pm FFI.addReassociatePass - -addTargetData :: FFI.TargetDataRef -> PassManager -> IO () -addTargetData td pm = withPassManager pm $ FFI.addTargetData td - -runFunctionPassManager :: PassManager -> Function -> IO Int -runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn - -initializeFunctionPassManager :: PassManager -> IO Int -initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager - -finalizeFunctionPassManager :: PassManager -> IO Int -finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager - --------------------------------------- - --- The unsafePerformIO is just for the non-effecting withArrayLen -constVector :: Int -> [Value] -> Value -constVector n xs = unsafePerformIO $ do - 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) - withArrayLen xs' $ \ len ptr -> - return $ FFI.constArray t ptr (fromIntegral len) - --- The unsafePerformIO is just for the non-effecting withArrayLen -constStruct :: [Value] -> Bool -> Value -constStruct xs packed = unsafePerformIO $ do - withArrayLen xs $ \ len ptr -> - return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0) - --------------------------------------- - -getValueNameU :: Value -> IO String -getValueNameU a = do - -- sometimes void values need explicit names too - cs <- FFI.getValueName a - str <- peekCString cs - if str == "" then return (show a) else return str - -getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a)) - -> (Ptr a -> IO (Ptr a)) -> t1 -> t -getObjList withF firstF nextF obj = do - withF obj $ \ objPtr -> do - ofst <- firstF objPtr - let oloop p = if p == nullPtr then return [] else do - n <- nextF p - ps <- oloop n - return (p : ps) - oloop ofst - -annotateValueList :: [Value] -> IO [(String, Value)] -annotateValueList vs = do - names <- mapM getValueNameU vs - return $ zip names vs - -isConstant :: Value -> IO Bool -isConstant v = do - isC <- FFI.isConstant v - if isC == 0 then return False else return True - -isIntrinsic :: Value -> IO Bool -isIntrinsic v = do - if FFI.getIntrinsicID v == 0 then return True else return False - --------------------------------------- - -type Use = FFI.UseRef - -hasUsers :: Value -> IO Bool -hasUsers v = do - nU <- FFI.getNumUses v - if nU == 0 then return False else return True - -getUses :: Value -> IO [Use] -getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse - -getUsers :: [Use] -> IO [(String, Value)] -getUsers us = mapM FFI.getUser us >>= annotateValueList - -getUser :: Use -> IO Value -getUser = FFI.getUser - -isChildOf :: BasicBlock -> Value -> IO Bool -isChildOf bb v = do - bb2 <- FFI.getInstructionParent v - if bb == bb2 then return True else return False - -getDep :: Use -> IO (String, String) -getDep u = do - producer <- FFI.getUsedValue u >>= getValueNameU - consumer <- FFI.getUser u >>= getValueNameU - return (producer, consumer) diff --git a/LLVM/Core/Vector.hs b/LLVM/Core/Vector.hs deleted file mode 100644 --- a/LLVM/Core/Vector.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module LLVM.Core.Vector(MkVector(..), vector, ) where -import Data.Function -import Types.Data.Num -import LLVM.Core.Type -import LLVM.Core.Data -import LLVM.ExecutionEngine.Target -import Foreign.Ptr(castPtr) -import Foreign.Storable(Storable(..)) -import Foreign.Marshal.Array(peekArray, pokeArray) -import System.IO.Unsafe(unsafePerformIO) - --- XXX Should these really be here? -class (PositiveT n, IsPrimitive a) => MkVector n a where - type Tuple n a :: * - toVector :: Tuple n a -> Vector n a - fromVector :: Vector n a -> Tuple n a - -{- -instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where - toVector a = Vector [a] --} - -instance (IsPrimitive a) => MkVector D2 a where - type Tuple D2 a = (a,a) - toVector (a1, a2) = Vector [a1, a2] - fromVector (Vector [a1, a2]) = (a1, a2) - fromVector _ = error "fromVector: impossible" - -instance (IsPrimitive a) => MkVector D4 a where - type Tuple D4 a = (a,a,a,a) - toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4] - fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4) - fromVector _ = error "fromVector: impossible" - -instance (IsPrimitive a) => MkVector D8 a where - type Tuple D8 a = (a,a,a,a,a,a,a,a) - toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8] - fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8) - fromVector _ = error "fromVector: impossible" - -instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where - sizeOf a = storeSizeOfType ourTargetData (typeRef a) - alignment a = aBIAlignmentOfType ourTargetData (typeRef a) - peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a) - poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs - --- XXX The JITer target data. This isn't really right. -ourTargetData :: TargetData -ourTargetData = unsafePerformIO getTargetData - --------------------------------------- - -unVector :: Vector n a -> [a] -unVector (Vector xs) = xs - --- |Make a constant vector. Replicates or truncates the list to get length /n/. --- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'. -vector :: forall a n. (PositiveT n) => [a] -> Vector n a -vector xs = - Vector (take (fromIntegerT (undefined :: n)) (cycle xs)) - - -binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c -binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys) - -unop :: (a -> b) -> Vector n a -> Vector n b -unop op = Vector . map op . unVector - -instance (Eq a, PositiveT n) => Eq (Vector n a) where - (==) = (==) `on` unVector - -instance (Ord a, PositiveT n) => Ord (Vector n a) where - compare = compare `on` unVector - -instance (Num a, PositiveT n) => Num (Vector n a) where - (+) = binop (+) - (-) = binop (-) - (*) = binop (*) - negate = unop negate - abs = unop abs - signum = unop signum - fromInteger = Vector . replicate (fromIntegerT (undefined :: n)) . fromInteger - -instance (Enum a, PositiveT n) => Enum (Vector n a) where - succ = unop succ - pred = unop pred - fromEnum = error "Vector fromEnum" - toEnum = Vector . map toEnum . replicate (fromIntegerT (undefined :: n)) - -instance (Real a, PositiveT n) => Real (Vector n a) where - toRational = error "Vector toRational" - -instance (Integral a, PositiveT n) => Integral (Vector n a) where - quot = binop quot - rem = binop rem - div = binop div - mod = binop mod - quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys - divMod (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod xs ys - toInteger = error "Vector toInteger" - -instance (Fractional a, PositiveT n) => Fractional (Vector n a) where - (/) = binop (/) - fromRational = Vector . replicate (fromIntegerT (undefined :: n)) . fromRational - -instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where - properFraction = error "Vector properFraction" - -instance (Floating a, PositiveT n) => Floating (Vector n a) where - pi = Vector $ replicate (fromIntegerT (undefined :: n)) pi - sqrt = unop sqrt - log = unop log - logBase = binop logBase - (**) = binop (**) - exp = unop exp - sin = unop sin - cos = unop cos - tan = unop tan - asin = unop asin - acos = unop acos - atan = unop atan - sinh = unop sinh - cosh = unop cosh - tanh = unop tanh - asinh = unop asinh - acosh = unop acosh - atanh = unop atanh - -instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where - floatRadix = floatRadix . head . unVector - floatDigits = floatDigits . head . unVector - floatRange = floatRange . head . unVector - decodeFloat = error "Vector decodeFloat" - encodeFloat = error "Vector encodeFloat" - exponent _ = 0 - scaleFloat 0 x = x - scaleFloat _ _ = error "Vector scaleFloat" - isNaN = error "Vector isNaN" - isInfinite = error "Vector isInfinite" - isDenormalized = error "Vector isDenormalized" - isNegativeZero = error "Vector isNegativeZero" - isIEEE = isIEEE . head . unVector diff --git a/LLVM/ExecutionEngine.hs b/LLVM/ExecutionEngine.hs deleted file mode 100644 --- a/LLVM/ExecutionEngine.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. -module LLVM.ExecutionEngine( - -- * Execution engine - EngineAccess, - runEngineAccess, - addModuleProvider, - addModule, -{- - runStaticConstructors, - runStaticDestructors, --} - getPointerToFunction, - addFunctionValue, - addGlobalMappings, - getFreePointers, FreePointers, - -- * Translation - Translatable, Generic, - generateFunction, - -- * Unsafe type conversion - Unsafe, - unsafeRemoveIO, - -- * Simplified interface. - simpleFunction, - unsafeGenerateFunction, - -- * Target information - module LLVM.ExecutionEngine.Target - ) where -import System.IO.Unsafe (unsafePerformIO) - -import LLVM.ExecutionEngine.Engine -import LLVM.FFI.Core(ValueRef) -import LLVM.Core.CodeGen(Value(..)) -import LLVM.Core -import LLVM.ExecutionEngine.Target ---import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) -import Control.Monad (liftM2, ) - --- |Class of LLVM function types that can be translated to the corresponding --- Haskell type. -class Translatable f where - translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f - -instance (Generic a, Translatable b) => Translatable (a -> b) where - translate run args f = \ arg -> translate run (toGeneric arg : args) f - -instance (Generic a) => Translatable (IO a) where - translate run args f = fmap fromGeneric $ run f $ reverse args - --- |Generate a Haskell function from an LLVM function. --- --- Note that the function is compiled for every call (Just-In-Time compilation). --- If you want to compile the function once and call it a lot of times --- then you should better use 'getPointerToFunction'. -generateFunction :: (Translatable f) => - Value (Ptr f) -> EngineAccess f -generateFunction (Value f) = do - run <- getRunFunction - return $ translate run [] f - -class Unsafe a where - type RemoveIO a :: * - unsafeRemoveIO :: a -> RemoveIO a -- ^Remove the IO from a function return type. This is unsafe in general. - -instance (Unsafe b) => Unsafe (a->b) where - type RemoveIO (a -> b) = a -> RemoveIO b - unsafeRemoveIO f = unsafeRemoveIO . f - -instance Unsafe (IO a) where - type RemoveIO (IO a) = a - unsafeRemoveIO = unsafePerformIO - --- |Translate a function to Haskell code. This is a simplified interface to --- the execution engine and module mechanism. --- It is based on 'generateFunction', so see there for limitations. -simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f -simpleFunction bld = do - m <- newModule - (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) - prov <- createModuleProviderForExistingModule m - runEngineAccess $ do - addModuleProvider prov - addGlobalMappings mappings - generateFunction func - -{- - m <- newModule - func <- defineModule m bld --- dumpValue func - prov <- createModuleProviderForExistingModule m - ee <- createExecutionEngine prov - pm <- createFunctionPassManager prov - td <- getExecutionEngineTargetData ee - addTargetData td pm - addInstructionCombiningPass pm - addReassociatePass pm - addGVNPass pm - addCFGSimplificationPass pm - addPromoteMemoryToRegisterPass pm - initializeFunctionPassManager pm --- print ("rc1", rc1) - runFunctionPassManager pm (unValue func) --- print ("rc2", rc2) - finalizeFunctionPassManager pm --- print ("rc3", rc3) --- dumpValue func - return $ generateFunction ee func --} - --- | Combine 'simpleFunction' and 'unsafeRemoveIO'. -unsafeGenerateFunction :: (Unsafe t, Translatable t) => - CodeGenModule (Function t) -> RemoveIO t -unsafeGenerateFunction bld = unsafePerformIO $ do - fun <- simpleFunction bld - return $ unsafeRemoveIO fun diff --git a/LLVM/ExecutionEngine/Engine.hs b/LLVM/ExecutionEngine/Engine.hs deleted file mode 100644 --- a/LLVM/ExecutionEngine/Engine.hs +++ /dev/null @@ -1,335 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverlappingInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -module LLVM.ExecutionEngine.Engine( - EngineAccess, - runEngineAccess, -{- - ExecutionEngine, --} - createExecutionEngine, addModuleProvider, addModule, - {- runStaticConstructors, runStaticDestructors, -} - getExecutionEngineTargetData, - getPointerToFunction, - addFunctionValue, addGlobalMappings, - getFreePointers, FreePointers, - runFunction, getRunFunction, - GenericValue, Generic(..) - ) where -import qualified Control.Monad.Trans.State as MS -import Control.Monad.Trans.State (StateT, runStateT, ) -import Control.Monad.IO.Class (MonadIO, liftIO, ) -import Control.Monad (liftM, ) -import Control.Applicative (Applicative, ) -import Control.Concurrent.MVar -import Data.Typeable -import Data.Int -import Data.Word -import Foreign.Marshal.Alloc (alloca, free) -import Foreign.Marshal.Array (withArrayLen) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) -import Foreign.Marshal.Utils (fromBool) -import Foreign.C.String (peekCString) -import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr) -import LLVM.Core.CodeGen(Value(..), Function) -import LLVM.Core.CodeGenMonad(GlobalMappings(..)) -import Foreign.Storable (peek) -import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, ) -import System.IO.Unsafe (unsafePerformIO) - -import LLVM.Core.Util(Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule) -import qualified LLVM.FFI.ExecutionEngine as FFI -import qualified LLVM.FFI.Target as FFI -import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef) -import qualified LLVM.Core.Util as U -import LLVM.Core.Type(IsFirstClass, typeRef) - -{- --- |The type of the JITer. -newtype ExecutionEngine = ExecutionEngine { - fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine - } - -withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a) - -> IO a -withExecutionEngine = withForeignPtr . fromExecutionEngine - --- |Create an execution engine for a module provider. --- Warning, do not call this function more than once. -createExecutionEngine :: ModuleProvider -> IO ExecutionEngine -createExecutionEngine prov = - withModuleProvider prov $ \provPtr -> - alloca $ \eePtr -> - alloca $ \errPtr -> do - ret <- FFI.createExecutionEngine eePtr provPtr errPtr - if ret == 1 - then do err <- peek errPtr - errStr <- peekCString err - free err - ioError . userError $ errStr - else do ptr <- peek eePtr - liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr - -addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO () -addModuleProvider ee prov = - withExecutionEngine ee $ \ eePtr -> - withModuleProvider prov $ \ provPtr -> - FFI.addModuleProvider eePtr provPtr - -runStaticConstructors :: ExecutionEngine -> IO () -runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors - -runStaticDestructors :: ExecutionEngine -> IO () -runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors - -getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef -getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData - -getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f) -getPointerToFunction ee (Value f) = - withExecutionEngine ee $ \ eePtr -> - FFI.getPointerToGlobal eePtr f --} - --- This global variable holds the one and only execution engine. --- It may be missing, but it never dies. --- XXX We could provide a destructor, what about functions obtained by runFunction? -{-# NOINLINE theEngine #-} -theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine)) -theEngine = unsafePerformIO $ newMVar Nothing - -createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine) -createExecutionEngine prov = - withModuleProvider prov $ \provPtr -> - alloca $ \eePtr -> - alloca $ \errPtr -> do - ret <- FFI.createExecutionEngine eePtr provPtr errPtr - if ret == 1 - then do - err <- peek errPtr - errStr <- peekCString err - free err - ioError . userError $ errStr - else - peek eePtr - -getTheEngine :: IO (Ptr FFI.ExecutionEngine) -getTheEngine = do - mee <- takeMVar theEngine - case mee of - Just ee -> do putMVar theEngine mee; return ee - Nothing -> do - m <- createModule "__empty__" - mp <- createModuleProviderForExistingModule m - ee <- createExecutionEngine mp - putMVar theEngine (Just ee) - return ee - -data EAState = EAState { - ea_engine :: Ptr FFI.ExecutionEngine, - ea_providers :: [ModuleProvider] - } - deriving (Show, Typeable) - -newtype EngineAccess a = EA (StateT EAState IO a) - deriving (Functor, Applicative, Monad, 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, --- so access to it is wrapped in a monad. -runEngineAccess :: EngineAccess a -> IO a -runEngineAccess (EA body) = do - eePtr <- getTheEngine - let ea = EAState { ea_engine = eePtr, ea_providers = [] } - (a, _ea') <- runStateT body ea - -- XXX should remove module providers again - return a - -addModuleProvider :: ModuleProvider -> EngineAccess () -addModuleProvider prov = do - ea <- EA MS.get - EA $ MS.put ea{ ea_providers = prov : ea_providers ea } - liftIO $ withModuleProvider prov $ \ provPtr -> - FFI.addModuleProvider (ea_engine ea) provPtr - - -getEngine :: EngineAccess (Ptr FFI.ExecutionEngine) -getEngine = EA $ MS.gets ea_engine - -getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef -getExecutionEngineTargetData = do - eePtr <- getEngine - liftIO $ FFI.getExecutionEngineTargetData eePtr - -{- | -In contrast to 'generateFunction' this compiles a function once. -Thus it is faster for many calls to the same function. -See @examples\/Vector.hs@. - -If the function calls back into Haskell code, -you also have to set the function addresses -using 'addFunctionValue' or 'addGlobalMappings'. --} -getPointerToFunction :: Function f -> EngineAccess (FunPtr f) -getPointerToFunction (Value f) = do - eePtr <- getEngine - liftIO $ FFI.getPointerToGlobal eePtr f - -{- | -Tell LLVM the address of an external function -if it cannot resolve a name automatically. -Alternatively you may declare the function -with 'staticFunction' instead of 'externFunction'. --} -addFunctionValue :: Function f -> FunPtr f -> EngineAccess () -addFunctionValue (Value g) f = - addFunctionValueCore g (castFunPtrToPtr f) - -{- | -Pass a list of global mappings to LLVM -that can be obtained from 'LLVM.Core.getGlobalMappings'. --} -addGlobalMappings :: GlobalMappings -> EngineAccess () -addGlobalMappings (GlobalMappings gms) = - mapM_ (uncurry addFunctionValueCore) gms - -addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess () -addFunctionValueCore g f = do - eePtr <- getEngine - liftIO $ FFI.addGlobalMapping eePtr g f - -addModule :: Module -> EngineAccess () -addModule m = do - mp <- liftIO $ createModuleProviderForExistingModule m - addModuleProvider mp - --- | Get all the information needed to free a function. --- Freeing code might have to be done from a (C) finalizer, so it has to done from C. --- The function c_freeFunctionObject take these pointers as arguments and frees the function. -type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef) -getFreePointers :: Function f -> EngineAccess FreePointers -getFreePointers (Value f) = do - ea <- EA MS.get - liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp -> - return (ea_engine ea, mpp, f) - --------------------------------------- - -newtype GenericValue = GenericValue { - fromGenericValue :: ForeignPtr FFI.GenericValue - } - -withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a -withGenericValue = withForeignPtr . fromGenericValue - -createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue -createGenericValueWith f = do - ptr <- f - liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr - -withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a -withAll ps a = go [] ps - where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs - go ptrs _ = withArrayLen (reverse ptrs) a - -runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue -runFunction func args = do - eePtr <- getEngine - liftIO $ withAll args $ \argLen argPtr -> - createGenericValueWith $ FFI.runFunction eePtr func - (fromIntegral argLen) argPtr -getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) -getRunFunction = do - eePtr <- getEngine - return $ \ func args -> - withAll args $ \argLen argPtr -> - createGenericValueWith $ FFI.runFunction eePtr func - (fromIntegral argLen) argPtr - -class Generic a where - toGeneric :: a -> GenericValue - fromGeneric :: GenericValue -> a - -instance Generic () where - toGeneric _ = error "toGeneric ()" - fromGeneric _ = () - -toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue -toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ - FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed) - -fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a -fromGenericInt signed val = unsafePerformIO $ - withGenericValue val $ \ref -> - return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed) - ---instance Generic Bool where --- toGeneric = toGenericInt False . fromBool --- fromGeneric = toBool . fromGenericInt False - -instance Generic Int8 where - toGeneric = toGenericInt True - fromGeneric = fromGenericInt True - -instance Generic Int16 where - toGeneric = toGenericInt True - fromGeneric = fromGenericInt True - -instance Generic Int32 where - toGeneric = toGenericInt True - fromGeneric = fromGenericInt True - -{- -instance Generic Int where - toGeneric = toGenericInt True - fromGeneric = fromGenericInt True --} - -instance Generic Int64 where - toGeneric = toGenericInt True - fromGeneric = fromGenericInt True - -instance Generic Word8 where - toGeneric = toGenericInt False - fromGeneric = fromGenericInt False - -instance Generic Word16 where - toGeneric = toGenericInt False - fromGeneric = fromGenericInt False - -instance Generic Word32 where - toGeneric = toGenericInt False - fromGeneric = fromGenericInt False - -instance Generic Word64 where - toGeneric = toGenericInt False - fromGeneric = fromGenericInt False - -toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue -toGenericReal val = unsafePerformIO $ createGenericValueWith $ - FFI.createGenericValueOfFloat (typeRef val) (realToFrac val) - -fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a -fromGenericReal val = unsafePerformIO $ - withGenericValue val $ \ ref -> - return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref - -instance Generic Float where - toGeneric = toGenericReal - fromGeneric = fromGenericReal - -instance Generic Double where - toGeneric = toGenericReal - fromGeneric = fromGenericReal - -instance Generic (Ptr a) where - toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer - fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer - -instance Generic (StablePtr a) where - toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr - fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer diff --git a/LLVM/ExecutionEngine/Target.hs b/LLVM/ExecutionEngine/Target.hs deleted file mode 100644 --- a/LLVM/ExecutionEngine/Target.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE DeriveDataTypeable #-} -module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where -import Data.Typeable -import Types.Data.Num(PositiveT, reifyPositiveD) -import Data.Maybe(fromMaybe) -import Foreign.C.String -import System.IO.Unsafe(unsafePerformIO) - -import LLVM.Core.Data(WordN) -import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData) - -import qualified LLVM.FFI.Core as FFI -import qualified LLVM.FFI.Target as FFI - -type Type = FFI.TypeRef - -data TargetData = TargetData { - aBIAlignmentOfType :: Type -> Int, - aBISizeOfType :: Type -> Int, - littleEndian :: Bool, - callFrameAlignmentOfType :: Type -> Int, --- elementAtOffset :: Type -> Word64 -> Int, - intPtrType :: Type, --- offsetOfElements :: Int -> Word64, - pointerSize :: Int, --- preferredAlignmentOfGlobal :: Value a -> Int, - preferredAlignmentOfType :: Type -> Int, - sizeOfTypeInBits :: Type -> Int, - storeSizeOfType :: Type -> Int - } - deriving (Typeable) - -withIntPtrType :: (forall n . (PositiveT n) => WordN n -> a) -> a -withIntPtrType f = - fromMaybe (error "withIntPtrType: pointer size must be non-negative") $ - reifyPositiveD (fromIntegral sz) (\ n -> f (g n)) - where g :: n -> WordN n - g _ = error "withIntPtrType: argument used" - sz = pointerSize $ unsafePerformIO getTargetData - --- Gets the target data for the JIT target. -getEngineTargetDataRef :: IO FFI.TargetDataRef -getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData - --- Normally the TargetDataRef never changes, so the operation --- are really pure functions. -makeTargetData :: FFI.TargetDataRef -> TargetData -makeTargetData r = TargetData { - aBIAlignmentOfType = fromIntegral . FFI.aBIAlignmentOfType r, - aBISizeOfType = fromIntegral . FFI.aBISizeOfType r, - littleEndian = FFI.byteOrder r /= 0, - callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r, - intPtrType = FFI.intPtrType r, - pointerSize = fromIntegral $ FFI.pointerSize r, - preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r, - sizeOfTypeInBits = fromIntegral . FFI.sizeOfTypeInBits r, - storeSizeOfType = fromIntegral . FFI.storeSizeOfType r - } - -getTargetData :: IO TargetData -getTargetData = fmap makeTargetData getEngineTargetDataRef - -targetDataFromString :: String -> TargetData -targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData diff --git a/LLVM/Util/Arithmetic.hs b/LLVM/Util/Arithmetic.hs deleted file mode 100644 --- a/LLVM/Util/Arithmetic.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -module LLVM.Util.Arithmetic( - TValue, - (%==), (%/=), (%<), (%<=), (%>), (%>=), - (%&&), (%||), - (?), (??), - retrn, set, -{- - ArithFunction, arithFunction, - UnwrapArgs, toArithFunction, - recursiveFunction, --} - CallIntrinsic, - ) where - -import qualified Types.Data.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) - - -infix 4 %==, %/=, %<, %<=, %>=, %> --- |Comparison functions. -(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a) => TValue r a -> TValue r a -> TValue r (CmpResult a) -(%==) = 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 %|| --- |Lazy and. -(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool -a %&& b = a ? (b, return (valueOf False)) --- |Lazy or. -(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool -a %|| b = a ? (return (valueOf True), b) - -infix 0 ? --- |Conditional, returns first element of the pair when condition is true, otherwise second. -(?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a -c ? (t, f) = do - lt <- newBasicBlock - lf <- newBasicBlock - lj <- newBasicBlock - c' <- c - condBr c' lt lf - defineBasicBlock lt - rt <- t - lt' <- getCurrentBasicBlock - br lj - defineBasicBlock lf - rf <- f - lf' <- getCurrentBasicBlock - br lj - defineBasicBlock lj - phi [(rt, lt'), (rf, lf')] - -infix 0 ?? -(??) :: (IsFirstClass a, CmpRet a) => TValue r (CmpResult a) -> (TValue r a, TValue r a) -> TValue r a -c ?? (t, f) = do - c' <- c - t' <- t - f' <- f - select c' t' f' - --- | Return a value from an 'arithFunction'. -retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r () -retrn x = x >>= ret - --- | Use @x <- set $ ...@ to make a binding. -set :: TValue r a -> (CodeGenFunction r (TValue r a)) -set x = do x' <- x; return (return x') - -instance (Show (TValue r a)) -instance (Eq (TValue r a)) -instance (Ord (TValue r a)) - -instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where - (+) = binop add - (-) = binop sub - (*) = binop mul - negate = (>>= neg) - abs x = x %< 0 ?? (-x, x) - signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0)) - fromInteger = return . valueOf . fromInteger - -instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Enum (TValue r a) where - succ x = x + 1 - pred x = x - 1 - fromEnum _ = error "CodeGenFunction Value: fromEnum" - toEnum = fromIntegral - -instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Real (TValue r a) where - toRational _ = error "CodeGenFunction Value: toRational" - -instance (CmpRet a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where - quot = binop idiv - rem = binop irem - quotRem x y = (quot x y, rem x y) - toInteger _ = error "CodeGenFunction Value: toInteger" - -instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where - (/) = binop fdiv - fromRational = return . valueOf . fromRational - -instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where - properFraction _ = error "CodeGenFunction Value: properFraction" - -instance (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where - pi = return $ valueOf pi - sqrt = callIntrinsic1 "sqrt" - sin = callIntrinsic1 "sin" - cos = callIntrinsic1 "cos" - (**) = callIntrinsic2 "pow" - exp = callIntrinsic1 "exp" - log = callIntrinsic1 "log" - - asin _ = error "LLVM missing intrinsic: asin" - acos _ = error "LLVM missing intrinsic: acos" - atan _ = error "LLVM missing intrinsic: atan" - - sinh x = (exp x - exp (-x)) / 2 - cosh x = (exp x + exp (-x)) / 2 - asinh x = log (x + sqrt (x*x + 1)) - acosh x = log (x + sqrt (x*x - 1)) - atanh x = (log (1 + x) - log (1 - x)) / 2 - -instance (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where - floatRadix _ = floatRadix (undefined :: a) - floatDigits _ = floatDigits (undefined :: a) - floatRange _ = floatRange (undefined :: a) - decodeFloat _ = error "CodeGenFunction Value: decodeFloat" - encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat" - exponent _ = 0 - scaleFloat 0 x = x - scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat" - isNaN _ = error "CodeGenFunction Value: isNaN" - isInfinite _ = error "CodeGenFunction Value: isInfinite" - isDenormalized _ = error "CodeGenFunction Value: isDenormalized" - isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero" - isIEEE _ = isIEEE (undefined :: a) - -binop :: (Value a -> Value b -> TValue r c) -> - TValue r a -> TValue r b -> TValue r c -binop op x y = do - x' <- x - 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 -callIntrinsicP1 fn x = do - op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a)) -{- -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] --} - runCall (callFromFunction op `applyCall` x) >>= addReadNone - -callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) => - String -> Value a -> Value b -> TValue r c -callIntrinsicP2 fn x y = do - op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a)) - runCall (callFromFunction op `applyCall` x `applyCall` y) >>= addReadNone - -{- -------------------------------------------- - -class ArithFunction a b | a -> b, b -> a where - arithFunction' :: a -> b - -instance (Ret a r) => ArithFunction (CodeGenFunction r a) (CodeGenFunction r ()) where - arithFunction' x = x >>= ret - -instance (ArithFunction b b') => ArithFunction (CodeGenFunction r a -> b) (a -> b') where - arithFunction' f = arithFunction' . f . return - --- |Unlift a function with @TValue@ to have @Value@ arguments. -arithFunction :: ArithFunction a b => a -> b -arithFunction = arithFunction' - -------------------------------------------- - -class UncurryN a b | a -> b, b -> a where - uncurryN :: a -> b - curryN :: b -> a - -instance UncurryN (CodeGenFunction r a) (() -> CodeGenFunction r a) where - uncurryN i = \ () -> i - curryN f = f () - -instance (UncurryN t (b -> c)) => UncurryN (a -> t) ((a, b) -> c) where - uncurryN f = \ (a, b) -> uncurryN (f a) b - curryN f = \ a -> curryN (\ b -> f (a, b)) - -class LiftTuple r a b | a -> b, b -> a where - liftTuple :: a -> CodeGenFunction r b - -instance LiftTuple r () () where - liftTuple = return - -instance (LiftTuple r b b') => LiftTuple r (CodeGenFunction r a, b) (a, b') where - liftTuple (a, b) = liftM2 (,) a (liftTuple b) - -class (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => - UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b1 -> a2 where - unwrapArgs :: a2 -> a -instance (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => - UnwrapArgs a a1 b1 b a2 r where - unwrapArgs f = curryN $ \ x -> uncurryN f =<< liftTuple x - --- |Lift a function from having @Value@ arguments to having @TValue@ arguments. -toArithFunction :: (CallArgs f g r, UnwrapArgs a a1 b1 b g r) => - Function f -> a -toArithFunction f = unwrapArgs (call f) - -------------------------------------------- - --- |Define a recursive 'arithFunction', gets passed itself as the first argument. -recursiveFunction :: - (CallArgs a g r0, - UnwrapArgs a11 a1 b1 b g r0, - FunctionArgs a, a2 ~ FunctionCodeGen a, r1 ~ FunctionResult a, - ArithFunction a3 a2, - IsFunction a) => - (a11 -> a3) -> CodeGenModule (Function a) -recursiveFunction af = do - f <- newFunction ExternalLinkage - let f' = toArithFunction f - defineFunction f $ arithFunction (af f') - return f --} - -------------------------------------------- - -class CallIntrinsic a where - callIntrinsic1' :: String -> Value a -> TValue r a - callIntrinsic2' :: String -> Value a -> Value a -> TValue r a - -instance CallIntrinsic Float where - callIntrinsic1' = callIntrinsicP1 - callIntrinsic2' = callIntrinsicP2 - -instance CallIntrinsic Double where - callIntrinsic1' = callIntrinsicP1 - callIntrinsic2' = callIntrinsicP2 - -{- -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 (PositiveT n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where - callIntrinsic1' s x = - if macOS && TypeNum.fromIntegerT (undefined :: n) == (4::Int) && - 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 = binop (callIntrinsic2' s) diff --git a/LLVM/Util/File.hs b/LLVM/Util/File.hs deleted file mode 100644 --- a/LLVM/Util/File.hs +++ /dev/null @@ -1,47 +0,0 @@ -module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where -import System.Process (system) - -import LLVM.Core -import LLVM.ExecutionEngine - -writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () -writeCodeGenModule name f = do - m <- newModule - _ <- defineModule m f - writeBitcodeToFile name m - -optimize :: FilePath -> IO () -optimize name = do - _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name - return () - -optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t) -optimizeFunction = fmap snd . optimizeFunction' - -optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t) -optimizeFunction' mdl = do - m <- newModule - mf <- defineModule m mdl - fName <- getValueName mf - - let name = "__tmp__" ++ fName ++ ".bc" - writeBitcodeToFile name m - - optimize name - - m' <- readBitcodeFromFile name - funcs <- getModuleValues m' - --- removeFile name - - let Just mf' = castModuleValue =<< lookup fName funcs - - return (m', mf') - -optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t -optimizeFunctionCG mdl = do - (m', mf') <- optimizeFunction' mdl - rf <- runEngineAccess $ do - addModule m' - generateFunction mf' - return rf diff --git a/LLVM/Util/Foreign.hs b/LLVM/Util/Foreign.hs deleted file mode 100644 --- a/LLVM/Util/Foreign.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- These are replacements for the broken equivalents in Foreign.*. --- The functions in Foreign.* do not obey the required alignment. -module LLVM.Util.Foreign where - -import Foreign.Ptr(alignPtr, Ptr) -import Foreign.Storable(Storable(poke, sizeOf, alignment)) -import Foreign.Marshal.Alloc(allocaBytes) -import Foreign.Marshal.Array(allocaArray, pokeArray) - -with :: Storable a => a -> (Ptr a -> IO b) -> IO b -with x act = - alloca $ \ p -> do - poke p x - act p - -alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b -alloca act = - allocaBytes (2 * sizeOf (undefined :: a)) $ \ p -> - act $ alignPtr p (alignment (undefined :: a)) - -withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b -withArrayLen xs act = - let l = length xs in - allocaArray (l+1) $ \ p -> do - let p' = alignPtr p (alignment (head xs)) - pokeArray p' xs - act l p' - diff --git a/LLVM/Util/Loop.hs b/LLVM/Util/Loop.hs deleted file mode 100644 --- a/LLVM/Util/Loop.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where -import Types.Data.Num -import LLVM.Core - -class Phi a where - phis :: BasicBlock -> a -> CodeGenFunction r a - addPhis :: BasicBlock -> a -> a -> CodeGenFunction r () - -{- -infixr 1 :* --- XXX should use HList if it was packaged in a nice way. -data a :* b = a :* b - deriving (Eq, Ord, Show, Read) - -instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where - phis bb (a :* b) = do - a' <- phi [(a, bb)] - b' <- phis bb b - return (a' :* b') - addPhis bb (a :* b) (a' :* b') = do - addPhiInputs a [(a', bb)] - addPhis bb b b' --} - -instance Phi () where - phis _ _ = return () - addPhis _ _ _ = return () - -instance (IsFirstClass a) => Phi (Value a) where - phis bb a = do - a' <- phi [(a, bb)] - return a' - addPhis bb a a' = do - addPhiInputs a [(a', bb)] - -instance (Phi a, Phi b) => Phi (a, b) where - phis bb (a, b) = do - a' <- phis bb a - b' <- phis bb b - return (a', b') - addPhis bb (a, b) (a', b') = do - addPhis bb a a' - addPhis bb b b' - -instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where - phis bb (a, b, c) = do - a' <- phis bb a - b' <- phis bb b - c' <- phis bb c - return (a', b', c') - addPhis bb (a, b, c) (a', b', c') = do - addPhis bb a a' - addPhis bb b b' - addPhis bb c c' - --- Loop the index variable from low to high. The state in the loop starts as start, and is modified --- by incr in each iteration. -forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) => - Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a -forLoop low high start incr = do - top <- getCurrentBasicBlock - loop <- newBasicBlock - body <- newBasicBlock - exit <- newBasicBlock - - br loop - - defineBasicBlock loop - i <- phi [(low, top)] - vars <- phis top start - t <- cmp CmpNE i high - condBr t body exit - - defineBasicBlock body - - vars' <- incr i vars - i' <- add i (valueOf 1 :: Value i) - - body' <- getCurrentBasicBlock - addPhis body' vars vars' - addPhiInputs i [(i', body')] - br loop - defineBasicBlock exit - - return vars - --------------------------------------- - -mapVector :: forall a b n r . - (PositiveT n, IsPrimitive b) => - (Value a -> CodeGenFunction r (Value b)) -> - Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) -mapVector f v = - forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do - x <- extractelement v i - y <- f x - insertelement w y i - -mapVector2 :: forall a b c n r . - (PositiveT n, IsPrimitive c) => - (Value a -> Value b -> CodeGenFunction r (Value c)) -> - Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c)) -mapVector2 f v1 v2 = - forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do - x <- extractelement v1 i - y <- extractelement v2 i - z <- f x y - insertelement w z i diff --git a/LLVM/Util/Memory.hs b/LLVM/Util/Memory.hs deleted file mode 100644 --- a/LLVM/Util/Memory.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# 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." ++ intrinsicTypeName (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." ++ intrinsicTypeName (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." ++ intrinsicTypeName (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 deleted file mode 100644 --- a/LLVM/Util/Optimize.hs +++ /dev/null @@ -1,130 +0,0 @@ -{- -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 LLVM.Core.Util(Module, withModule) -import qualified LLVM.FFI.Core as FFI -import qualified LLVM.FFI.Support as FFI -import LLVM.FFI.Transforms.Scalar -import Control.Exception (bracket) - - -{- | -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 --} - - {- - 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. - - fPasses <- FFI.createFunctionPassManager mp - -} - bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do - -- add module target data? - - -- tools/opt/opt.cpp: AddStandardCompilePasses - addVerifierPass passes - addOptimizationPasses passes fPasses optLevel - - {- if we wanted to do so, we could loop through all functions and optimize them. - initializeFunctionPassManager fPasses - runFunctionPassManager fPasses fcn - -} - - functionsModified <- FFI.runPassManager fPasses m - - moduleModified <- FFI.runPassManager passes m - - 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 - createStandardModulePasses passes optLevel True True (optLevel > 1) True True True - -createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () -createStandardFunctionPasses fPasses optLevel = - FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel) - --- llvm/Support/StandardPasses.h: createStandardModulePasses -createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO () -createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = - FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize) - (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions) - (f (not inliningPass)) - where f True = 1 - f _ = 0 - - -{- -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 --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/example/Align.hs b/example/Align.hs new file mode 100644 --- /dev/null +++ b/example/Align.hs @@ -0,0 +1,24 @@ +module Main (main) where + +import LLVM.ExecutionEngine +import LLVM.Core + +import Types.Data.Num (D1, D4) + +import Data.Word (Word32, Word64) + + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + + td <- getTargetData + print (littleEndian td, + aBIAlignmentOfType td $ typeRef (undefined :: Word32), + aBIAlignmentOfType td $ typeRef (undefined :: Word64), + aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float), + aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double), + storeSizeOfType td $ typeRef (undefined :: Vector D4 Float), + intPtrType td + ) diff --git a/example/Arith.hs b/example/Arith.hs new file mode 100644 --- /dev/null +++ b/example/Arith.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import qualified LLVM.Util.Arithmetic as A +import qualified LLVM.Util.Foreign as F +import LLVM.Util.Arithmetic (CallIntrinsic, arithFunction, (%<), (?)) +import LLVM.Util.File (writeCodeGenModule) + +import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO) +import LLVM.Core + +import Types.Data.Num (D4) + +import Data.Int (Int32) + +import Foreign.Storable (peek) +{- +import Foreign.Ptr +import Foreign.Marshal.Utils +import Foreign.Marshal.Alloc as F +-} + +mSomeFn :: forall a. + (IsConst a, Floating a, IsFloating a, CallIntrinsic a, CmpRet a) => + CodeGenModule (Function (a -> IO a)) +mSomeFn = do + foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y + let foo' = A.toArithFunction foo + createFunction ExternalLinkage $ arithFunction $ \ x -> do + y <- A.set $ x^3 + sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y + +mFib :: CodeGenModule (Function (Int32 -> IO Int32)) +mFib = A.recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2)) + +type V = Vector D4 Float + +mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) +mVFun = do + fn :: Function (V -> IO V) + <- createFunction ExternalLinkage $ arithFunction $ \ x -> + log x * exp x * x - 16 + + vectorToPtr fn + + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + + let mSomeFn' = mSomeFn + ioSomeFn <- simpleFunction mSomeFn' + let someFn :: Double -> Double + someFn = unsafeRemoveIO ioSomeFn + + writeCodeGenModule "Arith.bc" mSomeFn' + + print (someFn 10) + print (someFn 2) + + writeCodeGenModule "ArithFib.bc" mFib + + fib <- simpleFunction mFib + fib 22 >>= print + + writeCodeGenModule "VArith.bc" mVFun + + ioVFun <- simpleFunction mVFun + let v = toVector (1,2,3,4) + + r <- vectorPtrWrap ioVFun v + print r + + +vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) +vectorToPtr f = + createFunction ExternalLinkage $ \ px py -> do + x <- load px + y <- call f x + store y py + ret () + +vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V +vectorPtrWrap f v = + F.with v $ \ aPtr -> + F.alloca $ \ bPtr -> do + f aPtr bPtr + peek bPtr diff --git a/example/Array.hs b/example/Array.hs new file mode 100644 --- /dev/null +++ b/example/Array.hs @@ -0,0 +1,63 @@ +module Main (main) where + +import LLVM.Util.Loop (forLoop) +import LLVM.Util.Optimize (optimizeModule) +import LLVM.Core + +import Data.Word (Word32) + + +cg :: CodeGenModule (Function (Double -> IO (Ptr Double))) +cg = do + dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do + r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do + ai <- mul aStride i + bi <- mul bStride i + ap <- getElementPtr aPtr (ai, ()) + bp <- getElementPtr bPtr (bi, ()) + a <- load ap + b <- load bp + ab <- mul a b + add (s :: Value Double) ab + ret r + let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double) + + -- multiply a:[n x m], b:[m x l] + matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do + forLoop (valueOf 0) n () $ \ ni () -> do + forLoop (valueOf 0) l () $ \ li () -> do + ni' <- mul ni m + row <- getElementPtr aPtr (ni', ()) + col <- getElementPtr bPtr (li, ()) + x <- call dotProd m row (valueOf 1) col m + j <- add ni' li + p <- getElementPtr cPtr (j, ()) + store x p + return () + ret () + let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()) + + let fillArray _ [] = return () + fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs + + test <- createNamedFunction ExternalLinkage "test" $ \ x -> do + a <- arrayMalloc (4 :: Word32) + fillArray a $ map valueOf [1,2,3,4] + b <- arrayMalloc (4 :: Word32) + fillArray b [x,x,x,x] + c <- arrayMalloc (4 :: Word32) + _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c + ret c + let _ = test :: Function (Double -> IO (Ptr Double)) + + return test + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + m <- newModule + _f <- defineModule m cg + writeBitcodeToFile "Arr.bc" m + _ <- optimizeModule 3 m + writeBitcodeToFile "Arr-opt.bc" m diff --git a/example/BrainF.hs b/example/BrainF.hs new file mode 100644 --- /dev/null +++ b/example/BrainF.hs @@ -0,0 +1,160 @@ +module Main (main) where +-- BrainF compiler example +-- +-- The BrainF language has 8 commands: +-- Command Equivalent C Action +-- ------- ------------ ------ +-- , *h=getchar(); Read a character from stdin, 255 on EOF +-- . putchar(*h); Write a character to stdout +-- - --*h; Decrement tape +-- + ++*h; Increment tape +-- < --h; Move head left +-- > ++h; Move head right +-- [ while(*h) { Start loop +-- ] } End loop +-- + +import qualified LLVM.Util.Memory as Memory +import LLVM.ExecutionEngine (simpleFunction) +import LLVM.Util.File (writeCodeGenModule) +import LLVM.Core + +import qualified System.IO as IO +import System.Environment (getArgs) +import System.Exit (exitFailure) + +import Control.Monad (when) +import Data.Word (Word8, Word32) +import Data.Int (Int32) + + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + + aargs <- getArgs + 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 + "[" ++ -- loop + "<<.+>>-" ++ -- back to 33, print, increment, forward, decrement loop counter + "]<-" ++ -- back to 4, decrement loop counter + "]" ++ + "++++++++++." + 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 + + bfprog <- simpleFunction $ brainCompile debug prog 65536 + when (prog == text) $ + putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:" + bfprog + +brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) +brainCompile _debug instrs wmemtotal = do + -- LLVM functions + memset <- Memory.memset + getchar <- newNamedFunction ExternalLinkage "getchar" + :: TFunction (IO Int32) + putchar <- newNamedFunction ExternalLinkage "putchar" + :: TFunction (Int32 -> IO Int32) + + -- Generate code, first argument is the list of commands, + -- second argument is a stack of loop contexts, and the + -- third argument is the current register for the head and + -- the current basic block. + -- A loop context is a triple of the phi node, the loop top label, + -- and the loop exit label. + let generate [] [] _ = + return () + generate [] (_:_) _ = error "Missing ]" + generate (']':_) [] _ = error "Missing [" + generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do + -- The loop has terminated, add the phi node at the top, + -- branch to the top, and set up the exit label. + addPhiInputs cphi [(cur, bb)] + br loop + defineBasicBlock exit + generate is bs (cphi, exit) + + generate ('[':is) bs curbb = do + -- Start a new loop. + loop <- newBasicBlock -- loop top + body <- newBasicBlock -- body of the loop + exit <- newBasicBlock -- loop exit label + br loop + + defineBasicBlock loop + cur <- phi [curbb] -- will get one more input from the loop terminator. + val <- load cur -- load head byte. + eqz <- cmp CmpEQ val (valueOf (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. + curhead' <- gen curhead i + generate is bs (curhead', bb) + + gen cur ',' = do + -- Read a character. + char32 <- call getchar + char8 <- trunc char32 + store char8 cur + return cur + gen cur '.' = do + -- Write a character. + char8 <- load cur + char32 <- zext char8 + _ <- call putchar char32 + return cur + gen cur '-' = do + -- Decrement byte at head. + val <- load cur + val' <- sub val (valueOf (1 :: Word8)) + store val' cur + return cur + gen cur '+' = do + -- Increment byte at head. + val <- load cur + val' <- add val (valueOf (1 :: Word8)) + store val' cur + return cur + gen cur '<' = + -- Decrement head. + getElementPtr cur ((-1) :: Word32, ()) + gen cur '>' = + -- Increment head. + getElementPtr cur (1 :: Word32, ()) + gen _ c = error $ "Bad character in program: " ++ show c + + + brainf <- createFunction ExternalLinkage $ do + ptr_arr <- arrayMalloc wmemtotal + _ <- 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, ()) + + bb <- getCurrentBasicBlock + generate instrs [] (curhead, bb) + + free ptr_arr + ret () + + return brainf diff --git a/example/CallConv.hs b/example/CallConv.hs new file mode 100644 --- /dev/null +++ b/example/CallConv.hs @@ -0,0 +1,33 @@ +module Main (main) where + +import LLVM.Core +import LLVM.FFI.Core (CallingConvention(GHC)) + +import Data.Word (Word32) + + +-- Our module will have these two functions. +data Mod = Mod { + m1 :: Function (Word32 -> IO Word32), + m2 :: Function (Word32 -> Word32 -> IO Word32) + } + +main :: IO () +main = do + m <- newModule + _fns <- defineModule m buildMod + --_ <- optimizeModule 3 m + writeBitcodeToFile "CallConv.bc" m + return () + +buildMod :: CodeGenModule Mod +buildMod = do + mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do + r <- add x y + ret r + setFuncCallConv mod2 GHC + mod1 <- newNamedFunction ExternalLinkage "test" + defineFunction mod1 $ \ arg -> do + r <- callWithConv GHC mod2 arg (valueOf 1) + ret r + return $ Mod {m1 = mod1, m2 = mod2} diff --git a/example/Convert.hs b/example/Convert.hs new file mode 100644 --- /dev/null +++ b/example/Convert.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleInstances #-} +module Convert(Convert(..)) where + +import Foreign.Ptr (FunPtr) +import Data.Int (Int32) +import Data.Word (Word32) + +type Importer f = FunPtr f -> f + +class Convert f where + convert :: Importer f + +foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float) +instance Convert (IO Float) where convert = c_IOFloat + +foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float) +instance Convert (Float -> IO Float) where convert = c_Float_IOFloat + +foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float) +instance Convert (Float -> Float) where convert = c_Float_Float + +foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double) +instance Convert (IO Double) where convert = c_IODouble + +foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double) +instance Convert (Double -> IO Double) where convert = c_Double_IODouble + +foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double) +instance Convert (Double -> Double) where convert = c_Double_Double + +foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32) +instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32 + +foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32) +instance Convert (Word32 -> Word32) where convert = c_Word32_Word32 + +foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32) +instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32 + +foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32) +instance Convert (Int32 -> Int32) where convert = c_Int32_Int32 + diff --git a/example/DotProd.hs b/example/DotProd.hs new file mode 100644 --- /dev/null +++ b/example/DotProd.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Main (main) where + +import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO) +import LLVM.Core + +import LLVM.Util.Loop (forLoop) +import LLVM.Util.File (writeCodeGenModule) +import LLVM.Util.Foreign (withArrayLen) + +import Types.Data.Num(D2, D4, D8, fromIntegerT) + +import Data.Word (Word32) + + +mDotProd :: forall n a . + (PositiveT n, + IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a) => + CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) +mDotProd = + createFunction ExternalLinkage $ \ size aPtr bPtr -> do + s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do + + ap <- getElementPtr aPtr (i, ()) -- index into aPtr + bp <- getElementPtr bPtr (i, ()) -- index into bPtr + a <- load ap -- load element from a vector + b <- load bp -- load element from b vector + ab <- mul a b -- multiply them + add s ab -- accumulate sum + + r <- forLoop (valueOf (0::Word32)) (valueOf (fromIntegerT (undefined :: n))) + (valueOf 0) $ \ i r -> do + ri <- extractelement s i + add r ri + ret (r :: Value a) + +type R = Float +type T = Vector D4 R + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + let mDotProd' = mDotProd + writeCodeGenModule "DotProd.bc" mDotProd' + + ioDotProd <- simpleFunction mDotProd' + let dotProd :: [T] -> [T] -> R + dotProd a b = + unsafeRemoveIO $ + withArrayLen a $ \ aLen aPtr -> + withArrayLen b $ \ bLen bPtr -> + ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr + + + let a = [1 .. 8] + b = [4 .. 11] + print $ dotProd (vectorize 0 a) (vectorize 0 b) + print $ sum $ zipWith (*) a b + +class Vectorize n a where + vectorize :: a -> [a] -> [Vector n a] + +{- +instance (IsPrimitive a) => Vectorize D1 a where + vectorize _ [] = [] + vectorize x (x1:xs) = toVector x1 : vectorize x xs +-} + +instance (IsPrimitive a) => Vectorize D2 a where + vectorize _ [] = [] + vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs + vectorize x xs = vectorize x $ xs ++ [x] + +instance (IsPrimitive a) => Vectorize D4 a where + vectorize _ [] = [] + vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs + vectorize x xs = vectorize x $ xs ++ [x] + +instance (IsPrimitive a) => Vectorize D8 a where + vectorize _ [] = [] + vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs + vectorize x xs = vectorize x $ xs ++ [x] diff --git a/example/Fibonacci.hs b/example/Fibonacci.hs new file mode 100644 --- /dev/null +++ b/example/Fibonacci.hs @@ -0,0 +1,109 @@ +module Main (main) where + +import qualified LLVM.ExecutionEngine as EE +import LLVM.Util.Optimize (optimizeModule) +import LLVM.Core + +import System.Environment (getArgs) +import Control.Monad (forM_) +import Data.Word (Word32) + +import Prelude hiding(and, or) + + +-- Our module will have these two functions. +data Mod = Mod { + mfib :: Function (Word32 -> IO Word32), + _mplus :: Function (Word32 -> Word32 -> IO Word32) + } + +main :: IO () +main = do + args <- getArgs + let args' = if null args then ["10"] else args + + -- Initialize jitter + initializeNativeTarget + -- Create a module, + m <- newNamedModule "fib" + -- and define its contents. + fns <- defineModule m buildMod + + -- Show the code for the two functions, just for fun. + --dumpValue $ mfib fns + --dumpValue $ mplus fns + -- Write the code to a file for later perusal. + -- Can be disassembled with llvm-dis. + writeBitcodeToFile "Fibonacci.bc" m + + _ <- optimizeModule 3 m + writeBitcodeToFile "Fibonacci-opt.bc" m + + -- Generate code for mfib, and then throw away the IO in the type. + -- The result is an ordinary Haskell function. + iofib <- EE.runEngineAccess $ do + EE.addModule m + EE.generateFunction $ mfib fns + let fib = EE.unsafeRemoveIO iofib + + -- Run fib for the arguments. + forM_ args' $ \num -> do + putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num)) + return () + +buildMod :: CodeGenModule Mod +buildMod = do + -- Add two numbers in a cumbersome way. + plus <- createFunction InternalLinkage $ \ x y -> do + -- Create three additional basic blocks, need to be created before being referred to. + l1 <- newBasicBlock + l2 <- newBasicBlock + l3 <- newBasicBlock + + -- Test if x is even/odd. + a <- and x (valueOf (1 :: Word32)) + c <- cmp CmpEQ a (valueOf (0 :: Word32)) + condBr c l1 l2 + + -- Do x+y if even. + defineBasicBlock l1 + r1 <- add x y + br l3 + + -- Do y+x if odd. + defineBasicBlock l2 + r2 <- add y x + br l3 + + defineBasicBlock l3 + -- Join the two execution paths with a phi instruction. + r <- phi [(r1, l1), (r2, l2)] + ret r + + -- The usual doubly recursive Fibonacci. + -- Use new&define so the name fib is defined in the body for recursive calls. + fib <- newNamedFunction ExternalLinkage "fib" + defineFunction fib $ \ arg -> do + -- Create the two basic blocks. + recurse <- newBasicBlock + exit <- newBasicBlock + + -- Test if arg > 2 + test <- cmp CmpGT arg (valueOf (2::Word32)) + condBr test recurse exit + + -- Just return 1 if not > 2 + defineBasicBlock exit + ret (valueOf (1::Word32)) + + -- Recurse if > 2, using the cumbersome plus to add the results. + defineBasicBlock recurse + x1 <- sub arg (valueOf (1::Word32)) + fibx1 <- call fib x1 + x2 <- sub arg (valueOf (2::Word32)) + fibx2 <- call fib x2 + r <- call plus fibx1 fibx2 + ret r + + -- Return the two functions. + return $ Mod fib plus diff --git a/example/HelloJIT.hs b/example/HelloJIT.hs new file mode 100644 --- /dev/null +++ b/example/HelloJIT.hs @@ -0,0 +1,25 @@ +module Main (main) where + +import LLVM.ExecutionEngine (simpleFunction) +import LLVM.Core + +import Data.Word (Word8, Word32) + + +bldGreet :: CodeGenModule (Function (IO ())) +bldGreet = withStringNul "Hello, JIT!" (\greetz -> do + puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) + func <- createFunction ExternalLinkage $ do + tmp <- getElementPtr0 greetz (0::Word32, ()) + _ <- call puts tmp :: CodeGenFunction r (Value Word32) + ret () + return func) + +main :: IO () +main = do + initializeNativeTarget + greet <- simpleFunction bldGreet + greet + greet + greet + return () diff --git a/example/List.hs b/example/List.hs new file mode 100644 --- /dev/null +++ b/example/List.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module Main (main) where + +import LLVM.Util.Loop (Phi, phis, addPhis, ) +import LLVM.ExecutionEngine (simpleFunction, ) +import LLVM.Core +import qualified System.IO as IO + +import Data.Word (Word32, ) +import Data.Int (Int32, ) +import Foreign.Marshal.Array (allocaArray, ) +import qualified Foreign.Storable as St + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) +import Foreign.Ptr (FunPtr, ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) + + +{- +I had to export Phi's methods in llvm-0.6.8 +in order to be able to implement this function. +-} +arrayLoop :: + (Phi a, IsType b, + Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) => + Value i -> Value (Ptr b) -> a -> + (Value (Ptr b) -> a -> CodeGenFunction r a) -> + CodeGenFunction r a +arrayLoop len ptr start loopBody = do + top <- getCurrentBasicBlock + loop <- newBasicBlock + body <- newBasicBlock + exit <- newBasicBlock + + br loop + + defineBasicBlock loop + i <- phi [(len, top)] + p <- phi [(ptr, top)] + vars <- phis top start + t <- cmp CmpNE i (valueOf 0 `asTypeOf` len) + condBr t body exit + + defineBasicBlock body + + vars' <- loopBody p vars + i' <- sub i (valueOf 1 `asTypeOf` len) + p' <- getElementPtr p (valueOf 1 :: Value Word32, ()) + + body' <- getCurrentBasicBlock + addPhis body' vars vars' + addPhiInputs i [(i', body')] + addPhiInputs p [(p', body')] + br loop + + defineBasicBlock exit + return vars + + +mList :: + CodeGenModule (Function + (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32)) +mList = + createFunction ExternalLinkage $ \ ref size ptr -> do + next <- staticFunction nelem + let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32) + s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do + flip store ptri =<< call next ref + return y + ret (s :: Value Int32) + +renderList :: IO () +renderList = do + m <- newModule + _f <- defineModule m mList + writeBitcodeToFile "List.bc" m + + fill <- simpleFunction mList + stable <- newStablePtr =<< newIORef [3,5..] + IO.withFile "listcontent.u32" IO.WriteMode $ \h -> + let len = 100 + in allocaArray len $ \ ptr -> + fill stable (fromIntegral len) ptr >> + IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32)) + freeStablePtr stable + + +foreign import ccall "&nextListElement" + nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) + +foreign export ccall + nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 + +nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 +nextListElement stable = + do ioRef <- deRefStablePtr stable + xt <- readIORef ioRef + case xt of + [] -> return 0 + (x:xs) -> writeIORef ioRef xs >> return x + + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + renderList diff --git a/example/Struct.hs b/example/Struct.hs new file mode 100644 --- /dev/null +++ b/example/Struct.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import LLVM.ExecutionEngine (simpleFunction) +import LLVM.Util.File (writeCodeGenModule) +import LLVM.Core + +import Types.Data.Num (D10, d0, d1, d2) + +import Data.Word (Word32) + + +foreign import ccall structCheck :: Word32 -> Ptr S -> Int + +-- Watch out for double! Alignment differs between platforms. +-- struct S { uint32 x0; float x1; uint32 x2[10] }; +type S = Struct (Word32 :& Float :& Array D10 Word32 :& ()) + +-- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s; +mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S))) +mStruct = do + createFunction ExternalLinkage $ \ x -> do + p :: Value (Ptr S) + <- malloc + p0 <- getElementPtr0 p (d0 & ()) + store x (p0 :: Value (Ptr Word32)) + p1 <- getElementPtr0 p (d1 & ()) + store (valueOf 1.5) p1 + x' <- add x (valueOf (1 :: Word32)) + p2 <- getElementPtr0 p (d2 & (5::Word32) & ()) + store x' p2 + ret p + +main :: IO () +main = do + initializeNativeTarget + writeCodeGenModule "Struct.bc" mStruct + struct <- simpleFunction mStruct + let a = 10 + p <- struct a + putStrLn $ if structCheck a p /= 0 then "OK" else "failed" + return () diff --git a/example/Varargs.hs b/example/Varargs.hs new file mode 100644 --- /dev/null +++ b/example/Varargs.hs @@ -0,0 +1,38 @@ +module Main (main) where + +import LLVM.ExecutionEngine (simpleFunction) +import LLVM.Core + +import Data.Word (Word8, Word32) + + +bldVarargs :: CodeGenModule (Function (Word32 -> IO ())) +bldVarargs = + withStringNul "Hello\n" (\fmt1 -> + withStringNul "A number %d\n" (\fmt2 -> + withStringNul "Two numbers %d %d\n" (\fmt3 -> do + printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32) + func <- createFunction ExternalLinkage $ \ x -> do + + tmp1 <- getElementPtr0 fmt1 (0::Word32, ()) + let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32) + _ <- call p1 tmp1 + + tmp2 <- getElementPtr0 fmt2 (0::Word32, ()) + let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32) + _ <- call p2 tmp2 x + + tmp3 <- getElementPtr0 fmt3 (0::Word32, ()) + let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32) + _ <- call p3 tmp3 x x + + ret () + return func + ))) + +main :: IO () +main = do + initializeNativeTarget + varargs <- simpleFunction bldVarargs + varargs 42 + return () diff --git a/example/Vector.hs b/example/Vector.hs new file mode 100644 --- /dev/null +++ b/example/Vector.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TypeOperators #-} +module Main (main) where + +import Convert + +import LLVM.ExecutionEngine + (runEngineAccess, addModule, generateFunction, getPointerToFunction) +import LLVM.Util.Optimize (optimizeModule, ) +import LLVM.Util.Loop (forLoop, ) +import LLVM.Core + +import Types.Data.Num (D16, fromIntegerT, ) + +import Control.Monad (liftM2, ) +import Data.Word (Word32, ) + +-- Type of vector elements. +type T = Float + +-- Number of vector elements. +type N = D16 + +cgvec :: CodeGenModule (Function (T -> IO T)) +cgvec = do + -- A global variable that vectest messes with. + acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T)) + + -- Return the global variable. + retAcc <- createNamedFunction ExternalLinkage "retacc" $ do + vacc <- load acc + ret vacc + let _ = retAcc :: Function (IO T) -- Force the type of retAcc. + + -- A function that tests vector opreations. + f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do + + let v = value (zero :: ConstValue (Vector N T)) + n = fromIntegerT (undefined :: N) :: Word32 + + -- Fill the vector with x, x+1, x+2, ... + (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do + x1' <- add x1 (valueOf (1::T)) + v1' <- insertelement v1 x1 i + return (x1', v1') + + -- Elementwise cubing of the vector. + vsq <- mul v1 v1 + vcb <- mul vsq v1 + + -- Sum the elements of the vector. + s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do + y <- extractelement vcb i + s' <- add s (y :: Value T) + return s' + + -- Update the global variable. + vacc <- load acc + vacc' <- add vacc s + store vacc' acc + + ret (s :: Value T) + +-- liftIO $ dumpValue f + return f + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + -- First run standard code. + m <- newModule + iovec <- defineModule m cgvec + + fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec + let fvec = convert fptr + + fvec 10 >>= print + + vec <- runEngineAccess $ do addModule m; generateFunction iovec + + vec 10 >>= print + + -- And then optimize and run. + _ <- optimizeModule 1 m + + funcs <- getModuleValues m + print $ map fst funcs + + let iovec' :: Function (T -> IO T) + Just iovec' = castModuleValue =<< lookup "vectest" funcs + ioretacc' :: Function (IO T) + Just ioretacc' = castModuleValue =<< lookup "retacc" funcs + + (vec', retacc') <- runEngineAccess $ do + addModule m + liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') + + dumpValue iovec' + + vec' 10 >>= print + vec' 0 >>= print + retacc' >>= print diff --git a/example/structCheck.c b/example/structCheck.c new file mode 100644 --- /dev/null +++ b/example/structCheck.c @@ -0,0 +1,9 @@ +#include + +struct S { uint32_t x0; float x1; uint32_t x2[10]; }; + +int +structCheck(uint32_t a, struct S *s) +{ + return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1; +} diff --git a/examples/Align.hs b/examples/Align.hs deleted file mode 100644 --- a/examples/Align.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Align (main) where -import Types.Data.Num(D1, D4) -import Data.Word - -import LLVM.Core -import LLVM.ExecutionEngine - -main :: IO () -main = do - -- Initialize jitter - initializeNativeTarget - - td <- getTargetData - print (littleEndian td, - aBIAlignmentOfType td $ typeRef (undefined :: Word32), - aBIAlignmentOfType td $ typeRef (undefined :: Word64), - aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float), - aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double), - storeSizeOfType td $ typeRef (undefined :: Vector D4 Float), - intPtrType td - ) diff --git a/examples/Arith.hs b/examples/Arith.hs deleted file mode 100644 --- a/examples/Arith.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-type-defaults #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Arith where -import Data.Int -import Types.Data.Num(D4) -import LLVM.Core -import LLVM.ExecutionEngine -import LLVM.Util.Arithmetic -import LLVM.Util.Foreign as F -import LLVM.Util.File(writeCodeGenModule) - -import Foreign.Storable -{- -import Foreign.Ptr -import Foreign.Marshal.Utils -import Foreign.Marshal.Alloc as F --} - -mSomeFn :: forall a . (IsConst a, Floating a, IsFloating a, CallIntrinsic a, - FunctionRet a, CmpRet a - ) => CodeGenModule (Function (a -> IO a)) -mSomeFn = do - foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y - let foo' = toArithFunction foo - createFunction ExternalLinkage $ arithFunction $ \ x -> do - y <- set $ x^3 - sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y - -mFib :: CodeGenModule (Function (Int32 -> IO Int32)) -mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2)) - -type V = Vector D4 Float - -mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) -mVFun = do - fn :: Function (V -> IO V) - <- createFunction ExternalLinkage $ arithFunction $ \ x -> - log x * exp x * x - 16 - - vectorToPtr fn - - -main :: IO () -main = do - -- Initialize jitter - initializeNativeTarget - - let mSomeFn' = mSomeFn - ioSomeFn <- simpleFunction mSomeFn' - let someFn :: Double -> Double - someFn = unsafeRemoveIO ioSomeFn - - writeCodeGenModule "Arith.bc" mSomeFn' - - print (someFn 10) - print (someFn 2) - - writeCodeGenModule "ArithFib.bc" mFib - - fib <- simpleFunction mFib - fib 22 >>= print - -{- - writeCodeGenModule "VArith.bc" mVFun - - ioVFun <- simpleFunction mVFun - let v = toVector (1,2,3,4) - - r <- vectorPtrWrap ioVFun v - print r --} - -vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) -vectorToPtr f = - createFunction ExternalLinkage $ \ px py -> do - x <- load px - y <- call f x - store y py - ret () - -vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V -vectorPtrWrap f v = - with v $ \ aPtr -> - F.alloca $ \ bPtr -> do - f aPtr bPtr - peek bPtr diff --git a/examples/Array.hs b/examples/Array.hs deleted file mode 100644 --- a/examples/Array.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Array where -import Data.Word - -import LLVM.Core ---import LLVM.ExecutionEngine -import LLVM.Util.Loop -import LLVM.Util.Optimize - -cg :: CodeGenModule (Function (Double -> IO (Ptr Double))) -cg = do - dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do - r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do - ai <- mul aStride i - bi <- mul bStride i - ap <- getElementPtr aPtr (ai, ()) - bp <- getElementPtr bPtr (bi, ()) - a <- load ap - b <- load bp - ab <- mul a b - add (s :: Value Double) ab - ret r - let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double) - - -- multiply a:[n x m], b:[m x l] - matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do - forLoop (valueOf 0) n () $ \ ni () -> do - forLoop (valueOf 0) l () $ \ li () -> do - ni' <- mul ni m - row <- getElementPtr aPtr (ni', ()) - col <- getElementPtr bPtr (li, ()) - x <- call dotProd m row (valueOf 1) col m - j <- add ni' li - p <- getElementPtr cPtr (j, ()) - store x p - return () - ret () - let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()) - - let fillArray _ [] = return () - fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs - - test <- createNamedFunction ExternalLinkage "test" $ \ x -> do - a <- arrayMalloc (4 :: Word32) - fillArray a $ map valueOf [1,2,3,4] - b <- arrayMalloc (4 :: Word32) - fillArray b [x,x,x,x] - c <- arrayMalloc (4 :: Word32) - _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c - ret c - let _ = test :: Function (Double -> IO (Ptr Double)) - - return test - -main :: IO () -main = do - -- Initialize jitter - initializeNativeTarget - m <- newModule - _f <- defineModule m cg - writeBitcodeToFile "Arr.bc" m - _ <- optimizeModule 3 m - writeBitcodeToFile "Arr-opt.bc" m diff --git a/examples/BrainF.hs b/examples/BrainF.hs deleted file mode 100644 --- a/examples/BrainF.hs +++ /dev/null @@ -1,157 +0,0 @@ -module BrainF where --- BrainF compiler example --- --- The BrainF language has 8 commands: --- Command Equivalent C Action --- ------- ------------ ------ --- , *h=getchar(); Read a character from stdin, 255 on EOF --- . putchar(*h); Write a character to stdout --- - --*h; Decrement tape --- + ++*h; Increment tape --- < --h; Move head left --- > ++h; Move head right --- [ while(*h) { Start loop --- ] } End loop --- -import Control.Monad(when) -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 () -main = do - -- Initialize jitter - initializeNativeTarget - - aargs <- getArgs - 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 - "[" ++ -- loop - "<<.+>>-" ++ -- back to 33, print, increment, forward, decrement loop counter - "]<-" ++ -- back to 4, decrement loop counter - "]" ++ - "++++++++++." - 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 - - bfprog <- simpleFunction $ brainCompile debug prog 65536 - when (prog == text) $ - putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:" - bfprog - -brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) -brainCompile _debug instrs wmemtotal = do - -- LLVM functions - memset <- Memory.memset - getchar <- newNamedFunction ExternalLinkage "getchar" - :: TFunction (IO Int32) - putchar <- newNamedFunction ExternalLinkage "putchar" - :: TFunction (Int32 -> IO Int32) - - -- Generate code, first argument is the list of commands, - -- second argument is a stack of loop contexts, and the - -- third argument is the current register for the head and - -- the current basic block. - -- A loop context is a triple of the phi node, the loop top label, - -- and the loop exit label. - let generate [] [] _ = - return () - generate [] (_:_) _ = error "Missing ]" - generate (']':_) [] _ = error "Missing [" - generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do - -- The loop has terminated, add the phi node at the top, - -- branch to the top, and set up the exit label. - addPhiInputs cphi [(cur, bb)] - br loop - defineBasicBlock exit - generate is bs (cphi, exit) - - generate ('[':is) bs curbb = do - -- Start a new loop. - loop <- newBasicBlock -- loop top - body <- newBasicBlock -- body of the loop - exit <- newBasicBlock -- loop exit label - br loop - - defineBasicBlock loop - cur <- phi [curbb] -- will get one more input from the loop terminator. - val <- load cur -- load head byte. - 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. - curhead' <- gen curhead i - generate is bs (curhead', bb) - - gen cur ',' = do - -- Read a character. - char32 <- call getchar - char8 <- trunc char32 - store char8 cur - return cur - gen cur '.' = do - -- Write a character. - char8 <- load cur - char32 <- zext char8 - _ <- call putchar char32 - return cur - gen cur '-' = do - -- Decrement byte at head. - val <- load cur - val' <- sub val (1 :: Word8) - store val' cur - return cur - gen cur '+' = do - -- Increment byte at head. - val <- load cur - val' <- add val (1 :: Word8) - store val' cur - return cur - gen cur '<' = - -- Decrement head. - getElementPtr cur ((-1) :: Word32, ()) - gen cur '>' = - -- Increment head. - getElementPtr cur (1 :: Word32, ()) - gen _ c = error $ "Bad character in program: " ++ show c - - - brainf <- createFunction ExternalLinkage $ do - ptr_arr <- arrayMalloc wmemtotal - _ <- 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, ()) - - bb <- getCurrentBasicBlock - generate instrs [] (curhead, bb) - - free ptr_arr - ret () - - return brainf diff --git a/examples/CallConv.hs b/examples/CallConv.hs deleted file mode 100644 --- a/examples/CallConv.hs +++ /dev/null @@ -1,33 +0,0 @@ -module CallConv where - -import LLVM.Core -import LLVM.FFI.Core (CallingConvention(GHC)) - -import Data.Word (Word32) - - --- Our module will have these two functions. -data Mod = Mod { - m1 :: Function (Word32 -> IO Word32), - m2 :: Function (Word32 -> Word32 -> IO Word32) - } - -main :: IO () -main = do - m <- newModule - _fns <- defineModule m buildMod - --_ <- optimizeModule 3 m - writeBitcodeToFile "CallConv.bc" m - return () - -buildMod :: CodeGenModule Mod -buildMod = do - mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do - r <- add x y - ret r - setFuncCallConv mod2 GHC - mod1 <- newNamedFunction ExternalLinkage "test" - defineFunction mod1 $ \ arg -> do - r <- callWithConv GHC mod2 arg (valueOf 1) - ret r - return $ Mod mod1 mod2 diff --git a/examples/Convert.hs b/examples/Convert.hs deleted file mode 100644 --- a/examples/Convert.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-} -module Convert(Convert(..)) where -import Data.Int -import Data.Word -import Foreign.Ptr (FunPtr) - -type Importer f = FunPtr f -> f - -class Convert f where - convert :: Importer f - -foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float) -instance Convert (IO Float) where convert = c_IOFloat - -foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float) -instance Convert (Float -> IO Float) where convert = c_Float_IOFloat - -foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float) -instance Convert (Float -> Float) where convert = c_Float_Float - -foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double) -instance Convert (IO Double) where convert = c_IODouble - -foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double) -instance Convert (Double -> IO Double) where convert = c_Double_IODouble - -foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double) -instance Convert (Double -> Double) where convert = c_Double_Double - -foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32) -instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32 - -foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32) -instance Convert (Word32 -> Word32) where convert = c_Word32_Word32 - -foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32) -instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32 - -foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32) -instance Convert (Int32 -> Int32) where convert = c_Int32_Int32 - diff --git a/examples/DotProd.hs b/examples/DotProd.hs deleted file mode 100644 --- a/examples/DotProd.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} -module DotProd where -import Data.Word -import Types.Data.Num(D2, D4, D8, fromIntegerT) -import LLVM.Core -import LLVM.ExecutionEngine -import LLVM.Util.Loop -import LLVM.Util.File(writeCodeGenModule) -import LLVM.Util.Foreign - -mDotProd :: forall n a . (PositiveT n, - IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a, - FunctionRet a - ) => - CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) -mDotProd = - createFunction ExternalLinkage $ \ size aPtr bPtr -> do - s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do - - ap <- getElementPtr aPtr (i, ()) -- index into aPtr - bp <- getElementPtr bPtr (i, ()) -- index into bPtr - a <- load ap -- load element from a vector - b <- load bp -- load element from b vector - ab <- mul a b -- multiply them - add s ab -- accumulate sum - - r <- forLoop (valueOf (0::Word32)) (valueOf (fromIntegerT (undefined :: n))) - (valueOf 0) $ \ i r -> do - ri <- extractelement s i - add r ri - ret (r :: Value a) - -type R = Float -type T = Vector D4 R - -main :: IO () -main = do - -- Initialize jitter - initializeNativeTarget - let mDotProd' = mDotProd - writeCodeGenModule "DotProd.bc" mDotProd' - - ioDotProd <- simpleFunction mDotProd' - let dotProd :: [T] -> [T] -> R - dotProd a b = - unsafeRemoveIO $ - withArrayLen a $ \ aLen aPtr -> - withArrayLen b $ \ bLen bPtr -> - ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr - - - let a = [1 .. 8] - b = [4 .. 11] - print $ dotProd (vectorize 0 a) (vectorize 0 b) - print $ sum $ zipWith (*) a b - -class Vectorize n a where - vectorize :: a -> [a] -> [Vector n a] - -{- -instance (IsPrimitive a) => Vectorize D1 a where - vectorize _ [] = [] - vectorize x (x1:xs) = toVector x1 : vectorize x xs --} - -instance (IsPrimitive a) => Vectorize D2 a where - vectorize _ [] = [] - vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs - vectorize x xs = vectorize x $ xs ++ [x] - -instance (IsPrimitive a) => Vectorize D4 a where - vectorize _ [] = [] - vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs - vectorize x xs = vectorize x $ xs ++ [x] - -instance (IsPrimitive a) => Vectorize D8 a where - vectorize _ [] = [] - vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs - vectorize x xs = vectorize x $ xs ++ [x] diff --git a/examples/Fibonacci.hs b/examples/Fibonacci.hs deleted file mode 100644 --- a/examples/Fibonacci.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Fibonacci where -import Prelude hiding(and, or) -import System.Environment(getArgs) -import Control.Monad(forM_) -import Data.Word - -import LLVM.Core -import LLVM.Util.Optimize -import LLVM.ExecutionEngine - --- Our module will have these two functions. -data Mod = Mod { - mfib :: Function (Word32 -> IO Word32), - mplus :: Function (Word32 -> Word32 -> IO Word32) - } - -main :: IO () -main = do - args <- getArgs - let args' = if null args then ["10"] else args - - -- Initialize jitter - initializeNativeTarget - -- Create a module, - m <- newNamedModule "fib" - -- and define its contents. - fns <- defineModule m buildMod - - -- Show the code for the two functions, just for fun. - --dumpValue $ mfib fns - --dumpValue $ mplus fns - -- Write the code to a file for later perusal. - -- Can be disassembled with llvm-dis. - writeBitcodeToFile "Fibonacci.bc" m - - _ <- optimizeModule 3 m - writeBitcodeToFile "Fibonacci-opt.bc" m - - -- Generate code for mfib, and then throw away the IO in the type. - -- The result is an ordinary Haskell function. - iofib <- runEngineAccess $ do - addModule m - generateFunction $ mfib fns - let fib = unsafeRemoveIO iofib - - -- Run fib for the arguments. - forM_ args' $ \num -> do - putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num)) - return () - -buildMod :: CodeGenModule Mod -buildMod = do - -- Add two numbers in a cumbersome way. - plus <- createFunction InternalLinkage $ \ x y -> do - -- Create three additional basic blocks, need to be created before being referred to. - l1 <- newBasicBlock - l2 <- newBasicBlock - l3 <- newBasicBlock - - -- Test if x is even/odd. - a <- and x (1 :: Word32) - c <- cmp CmpEQ a (0 :: Word32) - condBr c l1 l2 - - -- Do x+y if even. - defineBasicBlock l1 - r1 <- add x y - br l3 - - -- Do y+x if odd. - defineBasicBlock l2 - r2 <- add y x - br l3 - - defineBasicBlock l3 - -- Join the two execution paths with a phi instruction. - r <- phi [(r1, l1), (r2, l2)] - ret r - - -- The usual doubly recursive Fibonacci. - -- Use new&define so the name fib is defined in the body for recursive calls. - fib <- newNamedFunction ExternalLinkage "fib" - defineFunction fib $ \ arg -> do - -- Create the two basic blocks. - recurse <- newBasicBlock - exit <- newBasicBlock - - -- Test if arg > 2 - test <- cmp CmpGT arg (2::Word32) - condBr test recurse exit - - -- Just return 1 if not > 2 - defineBasicBlock exit - ret (valueOf (1::Word32)) - - -- Recurse if > 2, using the cumbersome plus to add the results. - defineBasicBlock recurse - x1 <- sub arg (1::Word32) - fibx1 <- call fib x1 - x2 <- sub arg (2::Word32) - fibx2 <- call fib x2 - r <- call plus fibx1 fibx2 - ret r - - -- Return the two functions. - return $ Mod fib plus diff --git a/examples/HelloJIT.hs b/examples/HelloJIT.hs deleted file mode 100644 --- a/examples/HelloJIT.hs +++ /dev/null @@ -1,24 +0,0 @@ -module HelloJIT (main) where - -import Data.Word - -import LLVM.Core -import LLVM.ExecutionEngine - -bldGreet :: CodeGenModule (Function (IO ())) -bldGreet = withStringNul "Hello, JIT!" (\greetz -> do - puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) - func <- createFunction ExternalLinkage $ do - tmp <- getElementPtr0 greetz (0::Word32, ()) - _ <- call puts tmp :: CodeGenFunction r (Value Word32) - ret () - return func) - -main :: IO () -main = do - initializeNativeTarget - greet <- simpleFunction bldGreet - greet - greet - greet - return () diff --git a/examples/List.hs b/examples/List.hs deleted file mode 100644 --- a/examples/List.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ForeignFunctionInterface #-} -module List(main) where - -import LLVM.Util.Loop (Phi, phis, addPhis, ) -import LLVM.ExecutionEngine (simpleFunction, ) -import LLVM.Core -import qualified System.IO as IO - -import Data.Word (Word32, ) -import Data.Int (Int32, ) -import Foreign.Marshal.Array (allocaArray, ) -import qualified Foreign.Storable as St - -import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) -import Foreign.Ptr (FunPtr, ) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) - - -{- -I had to export Phi's methods in llvm-0.6.8 -in order to be able to implement this function. --} -arrayLoop :: - (Phi a, IsType b, - Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) => - Value i -> Value (Ptr b) -> a -> - (Value (Ptr b) -> a -> CodeGenFunction r a) -> - CodeGenFunction r a -arrayLoop len ptr start loopBody = do - top <- getCurrentBasicBlock - loop <- newBasicBlock - body <- newBasicBlock - exit <- newBasicBlock - - br loop - - defineBasicBlock loop - i <- phi [(len, top)] - p <- phi [(ptr, top)] - vars <- phis top start - t <- cmp CmpNE i (valueOf 0 `asTypeOf` len) - condBr t body exit - - defineBasicBlock body - - vars' <- loopBody p vars - i' <- sub i (valueOf 1 `asTypeOf` len) - p' <- getElementPtr p (valueOf 1 :: Value Word32, ()) - - body' <- getCurrentBasicBlock - addPhis body' vars vars' - addPhiInputs i [(i', body')] - addPhiInputs p [(p', body')] - br loop - - defineBasicBlock exit - return vars - - -mList :: - CodeGenModule (Function - (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32)) -mList = - createFunction ExternalLinkage $ \ ref size ptr -> do - next <- staticFunction nelem - let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32) - s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do - flip store ptri =<< call next ref - return y - ret (s :: Value Int32) - -renderList :: IO () -renderList = do - m <- newModule - _f <- defineModule m mList - writeBitcodeToFile "List.bc" m - - fill <- simpleFunction mList - stable <- newStablePtr =<< newIORef [3,5..] - IO.withFile "listcontent.u32" IO.WriteMode $ \h -> - let len = 100 - in allocaArray len $ \ ptr -> - fill stable (fromIntegral len) ptr >> - IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32)) - freeStablePtr stable - - -foreign import ccall "&nextListElement" - nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) - -foreign export ccall - nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 - -nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 -nextListElement stable = - do ioRef <- deRefStablePtr stable - xt <- readIORef ioRef - case xt of - [] -> return 0 - (x:xs) -> writeIORef ioRef xs >> return x - - -main :: IO () -main = do - -- Initialize jitter - initializeNativeTarget - renderList diff --git a/examples/Struct.hs b/examples/Struct.hs deleted file mode 100644 --- a/examples/Struct.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, TypeOperators, ScopedTypeVariables #-} -module Struct (main) where - -import Data.Word -import Types.Data.Num(d0, d1, d2, D10) - -import LLVM.Core -import LLVM.Util.File -import LLVM.ExecutionEngine - -foreign import ccall structCheck :: Word32 -> Ptr S -> Int - --- Watch out for double! Alignment differs between platforms. --- struct S { uint32 x0; float x1; uint32 x2[10] }; -type S = Struct (Word32 :& Float :& Array D10 Word32 :& ()) - --- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s; -mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S))) -mStruct = do - createFunction ExternalLinkage $ \ x -> do - p :: Value (Ptr S) - <- malloc - p0 <- getElementPtr0 p (d0 & ()) - store x (p0 :: Value (Ptr Word32)) - p1 <- getElementPtr0 p (d1 & ()) - store (valueOf 1.5) p1 - x' <- add x (1 :: Word32) - p2 <- getElementPtr0 p (d2 & (5::Word32) & ()) - store x' p2 - ret p - -main :: IO () -main = do - initializeNativeTarget - writeCodeGenModule "Struct.bc" mStruct - struct <- simpleFunction mStruct - let a = 10 - p <- struct a - putStrLn $ if structCheck a p /= 0 then "OK" else "failed" - return () diff --git a/examples/Varargs.hs b/examples/Varargs.hs deleted file mode 100644 --- a/examples/Varargs.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Varargs (main) where - -import Data.Word - -import LLVM.Core -import LLVM.ExecutionEngine - -bldVarargs :: CodeGenModule (Function (Word32 -> IO ())) -bldVarargs = - withStringNul "Hello\n" (\fmt1 -> - withStringNul "A number %d\n" (\fmt2 -> - withStringNul "Two numbers %d %d\n" (\fmt3 -> do - printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32) - func <- createFunction ExternalLinkage $ \ x -> do - - tmp1 <- getElementPtr0 fmt1 (0::Word32, ()) - let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32) - _ <- call p1 tmp1 - - tmp2 <- getElementPtr0 fmt2 (0::Word32, ()) - let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32) - _ <- call p2 tmp2 x - - tmp3 <- getElementPtr0 fmt3 (0::Word32, ()) - let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32) - _ <- call p3 tmp3 x x - - ret () - return func - ))) - -main :: IO () -main = do - initializeNativeTarget - varargs <- simpleFunction bldVarargs - varargs 42 - return () diff --git a/examples/Vector.hs b/examples/Vector.hs deleted file mode 100644 --- a/examples/Vector.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -module Vector where - -import Convert - -import LLVM.Core -import LLVM.ExecutionEngine -import LLVM.Util.Optimize (optimizeModule, ) -import LLVM.Util.Loop (forLoop, ) - -import Control.Monad (liftM2, ) -import Types.Data.Num (D16, fromIntegerT, ) -import Data.Word (Word32, ) - --- Type of vector elements. -type T = Float - --- Number of vector elements. -type N = D16 - -cgvec :: CodeGenModule (Function (T -> IO T)) -cgvec = do - -- A global variable that vectest messes with. - acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T)) - - -- Return the global variable. - retAcc <- createNamedFunction ExternalLinkage "retacc" $ do - vacc <- load acc - ret vacc - let _ = retAcc :: Function (IO T) -- Force the type of retAcc. - - -- A function that tests vector opreations. - f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do - - let v = value (zero :: ConstValue (Vector N T)) - n = fromIntegerT (undefined :: N) :: Word32 - - -- Fill the vector with x, x+1, x+2, ... - (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do - x1' <- add x1 (1::T) - v1' <- insertelement v1 x1 i - return (x1', v1') - - -- Elementwise cubing of the vector. - vsq <- mul v1 v1 - vcb <- mul vsq v1 - - -- Sum the elements of the vector. - s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do - y <- extractelement vcb i - s' <- add s (y :: Value T) - return s' - - -- Update the global variable. - vacc <- load acc - vacc' <- add vacc s - store vacc' acc - - ret (s :: Value T) - --- liftIO $ dumpValue f - return f - -main :: IO () -main = do - -- Initialize jitter - initializeNativeTarget - -- First run standard code. - m <- newModule - iovec <- defineModule m cgvec - - fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec - let fvec = convert fptr - - fvec 10 >>= print - - vec <- runEngineAccess $ do addModule m; generateFunction iovec - - vec 10 >>= print - - -- And then optimize and run. - _ <- optimizeModule 1 m - - funcs <- getModuleValues m - print $ map fst funcs - - let iovec' :: Function (T -> IO T) - Just iovec' = castModuleValue =<< lookup "vectest" funcs - ioretacc' :: Function (IO T) - Just ioretacc' = castModuleValue =<< lookup "retacc" funcs - - (vec', retacc') <- runEngineAccess $ do - addModule m - liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') - - dumpValue iovec' - - vec' 10 >>= print - vec' 0 >>= print - retacc' >>= print diff --git a/examples/mainfib.c b/examples/mainfib.c deleted file mode 100644 --- a/examples/mainfib.c +++ /dev/null @@ -1,12 +0,0 @@ -#include -#include - -extern unsigned int fib(unsigned int); - -int -main(int argc, char **argv) -{ - int n = argc > 1 ? atoi(argv[1]) : 10; - printf("fib %d = %d\n", n, fib(n)); - exit(0); -} diff --git a/examples/structCheck.c b/examples/structCheck.c deleted file mode 100644 --- a/examples/structCheck.c +++ /dev/null @@ -1,9 +0,0 @@ -#include - -struct S { uint32_t x0; float x1; uint32_t x2[10]; }; - -int -structCheck(uint32_t a, struct S *s) -{ - return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1; -} diff --git a/llvm-tf.cabal b/llvm-tf.cabal --- a/llvm-tf.cabal +++ b/llvm-tf.cabal @@ -1,9 +1,9 @@ -name: llvm-tf -version: 3.0.1 -license: BSD3 -license-file: LICENSE -synopsis: Bindings to the LLVM compiler toolkit using type families. -description: +Name: llvm-tf +Version: 3.0.2 +License: BSD3 +License-File: LICENSE +Synopsis: Bindings to the LLVM compiler toolkit using type families. +Description: High-level bindings to the LLVM compiler toolkit using type families instead of functional dependencies. . @@ -23,48 +23,58 @@ That is, a bump from 3.0.0 to 3.0.1 may contain substantial API changes, a bump from 3.0.0.0 to 3.0.0.1 may contain API extensions, and a bump from 3.0.0.0.0 to 3.0.0.0.1 may contain API-preserving bugfixes. -author: Henning Thieleman, Bryan O'Sullivan, Lennart Augustsson -maintainer: Henning Thieleman -stability: experimental -category: Compilers/Interpreters, Code Generation -tested-with: GHC == 7.4.2 -cabal-version: >= 1.10 -build-type: Simple +Author: Henning Thieleman, Bryan O'Sullivan, Lennart Augustsson +Maintainer: Henning Thieleman +Stability: experimental +Category: Compilers/Interpreters, Code Generation +Tested-With: GHC == 7.4.2 +Cabal-Version: >= 1.14 +Build-Type: Simple -extra-source-files: +Extra-Source-Files: *.md - examples/*.c - examples/*.hs - tests/*.hs - tests/Makefile + test/*.hs + test/Makefile -flag developer - description: operate in developer mode - default: False +Source-Repository head + Type: darcs + Location: http://code.haskell.org/~thielema/llvm-tf/ -library - default-language: Haskell98 - build-depends: - base >= 3 && < 5, - bytestring >= 0.9, - directory, +Source-Repository this + Tag: 3.0.2 + Type: darcs + Location: http://code.haskell.org/~thielema/llvm-tf/ + +Flag developer + Description: operate in developer mode + Default: False + +Flag buildExamples + Description: Build example executables + Default: False + +Library + Default-Language: Haskell98 + Build-Depends: llvm-base == 3.0.*, - transformers >= 0.3 && < 0.4, - process, - tfp >= 0.7 && < 0.9, - containers + tfp >=0.7 && <0.9, + transformers >=0.3 && <0.4, + process >=1.1 && <1.3, + containers >=0.4 && <0.6, + base >=3 && <5 - ghc-options: -Wall + Hs-Source-Dirs: src + GHC-Options: -Wall - if flag(developer) - ghc-options: -Werror + If flag(developer) + GHC-Options: -Werror - if os(darwin) - ld-options: -w - frameworks: vecLib - cpp-options: -D__MACOS__ + If os(darwin) + Ld-Options: -w + Frameworks: vecLib + CPP-Options: -D__MACOS__ - exposed-modules: + Exposed-Modules: LLVM.Core LLVM.ExecutionEngine LLVM.Util.Arithmetic @@ -74,7 +84,7 @@ LLVM.Util.Memory LLVM.Util.Optimize - other-modules: + Other-Modules: LLVM.Core.CodeGen LLVM.Core.CodeGenMonad LLVM.Core.Data @@ -85,11 +95,162 @@ LLVM.ExecutionEngine.Engine LLVM.ExecutionEngine.Target -source-repository head - type: darcs - location: http://code.haskell.org/~thielema/llvm-tf/ +Executable llvm-align + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False -source-repository this - tag: 3.0.1 - type: darcs - location: http://code.haskell.org/~thielema/llvm-tf/ + Main-Is: example/Align.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-arith + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/Arith.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-array + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/Array.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-brainf + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/BrainF.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-call-conv + If flag(buildExamples) + Build-Depends: + llvm-tf, + llvm-base, + tfp, + base + Else + Buildable: False + + Main-Is: example/CallConv.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-dot-prod + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/DotProd.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-fibonacci + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/Fibonacci.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-hello-jit + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/HelloJIT.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-list + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/List.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-struct + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/Struct.hs + C-Sources: example/structCheck.c + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-varargs + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Main-Is: example/Varargs.hs + Default-Language: Haskell98 + GHC-Options: -Wall + +Executable llvm-vector + If flag(buildExamples) + Build-Depends: + llvm-tf, + tfp, + base + Else + Buildable: False + + Hs-Source-Dirs: example + Main-Is: Vector.hs + Other-Modules: Convert + Default-Language: Haskell98 + GHC-Options: -Wall diff --git a/src/LLVM/Core.hs b/src/LLVM/Core.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core.hs @@ -0,0 +1,116 @@ +-- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level. +-- It supports both stand alone code generation and JITing. +-- The Haskell llvm package is a (relatively) high level interface to the LLVM. +-- The high level interface makes it easy to construct LLVM code. +-- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface. +-- +-- LLVM code is organized into modules (type 'Module'). +-- Each module contains a number of global variables and functions (type 'Function'). +-- Each functions has a number of basic blocks (type 'BasicBlock'). +-- Each basic block has a number instructions, where each instruction produces +-- a value (type 'Value'). +-- +-- Unlike assembly code for a real processor the assembly code for LLVM is +-- in SSA (Static Single Assignment) form. This means that each instruction generates +-- a new bound variable which may not be assigned again. +-- A consequence of this is that where control flow joins from several execution +-- paths there has to be a phi pseudo instruction if you want different variables +-- to be joined into one. +-- +-- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock') +-- follow the same pattern. First the entity has to be created using @newX@ (where @X@ +-- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to +-- given its definition using @defineX@. The reason for splitting the creation and +-- definition is that you often need to be able to refer to an entity before giving +-- it's body, e.g., in two mutually recursive functions. +-- The the @newX@ and @defineX@ function can also be done at the same time by using +-- @createX@. Furthermore, an explicit name can be given to an entity by the +-- @newNamedX@ function; the @newX@ function just generates a fresh name. +module LLVM.Core( + -- * Initialize + initializeNativeTarget, + -- * Modules + Module, newModule, newNamedModule, defineModule, destroyModule, createModule, + ModuleProvider, createModuleProviderForExistingModule, + PassManager, createPassManager, createFunctionPassManager, + writeBitcodeToFile, readBitcodeFromFile, + getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue, + -- * Instructions + module LLVM.Core.Instructions, + -- * Types classification + module LLVM.Core.Type, + -- * Extra types + module LLVM.Core.Data, + -- * Values and constants + Value, ConstValue, valueOf, constOf, value, + zero, allOnes, undef, + createString, createStringNul, + withString, withStringNul, + --constString, constStringNul, + constVector, constArray, + constStruct, constPackedStruct, + toVector, fromVector, vector, + -- * Code generation + CodeGenFunction, CodeGenModule, + -- * Functions + Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, + TFunction, liftCodeGenModule, getParams, + -- * Global variable creation + Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, + externFunction, staticFunction, + externGlobal, staticGlobal, + GlobalMappings, getGlobalMappings, + TGlobal, + -- * Globals + Linkage(..), + -- * Basic blocks + BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + getBasicBlocks, + fromLabel, toLabel, + getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, + -- * Misc + addAttributes, Attribute(..), + castVarArgs, + -- * Debugging + dumpValue, dumpType, getValueName, annotateValueList + ) where + +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, liftCodeGenModule, + GlobalMappings, getGlobalMappings) +import LLVM.Core.Data +import LLVM.Core.Instructions +import LLVM.Core.Type +import LLVM.Core.Vector +import LLVM.Target.Native + +import qualified LLVM.FFI.Core as FFI + + +-- |Print a value. +dumpValue :: Value a -> IO () +dumpValue (Value v) = FFI.dumpValue v + +-- |Print a type. +dumpType :: Value a -> IO () +dumpType (Value v) = showTypeOf v >>= putStrLn + +-- |Get the name of a 'Value'. +getValueName :: Value a -> IO String +getValueName (Value a) = getValueNameU a + +-- |Convert a varargs function to a regular function. +castVarArgs :: (CastVarArgs a b) => Function a -> Function b +castVarArgs (Value a) = Value a + +-- TODO for types: +-- Enforce free is only called on malloc memory. (Enforce only one free?) +-- Enforce phi nodes a accessor of variables outside the bb +-- Enforce bb terminator +-- Enforce phi first +-- +-- TODO: +-- Add Struct, PackedStruct types +-- Get alignment from code gen diff --git a/src/LLVM/Core/CodeGen.hs b/src/LLVM/Core/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/CodeGen.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Core.CodeGen( + -- * Module creation + newModule, newNamedModule, defineModule, createModule, + getModuleValues, ModuleValue, castModuleValue, + -- * Globals + Linkage(..), + Visibility(..), + -- * Function creation + Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, + addAttributes, + FFI.Attribute(..), + externFunction, staticFunction, + FunctionArgs, FunctionCodeGen, FunctionResult, + TFunction, + -- * Global variable creation + Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal, + externGlobal, staticGlobal, + -- * Values + Value(..), ConstValue(..), + IsConst(..), valueOf, value, + zero, allOnes, undef, + createString, createStringNul, + withString, withStringNul, + constVector, constArray, constStruct, constPackedStruct, + -- * Basic blocks + BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + fromLabel, toLabel, + -- * Misc + withCurrentBuilder + ) where + +import qualified LLVM.Core.Util as U +import LLVM.Core.CodeGenMonad +import LLVM.Core.Type +import LLVM.Core.Data + +import qualified LLVM.FFI.Core as FFI +import LLVM.FFI.Core(Linkage(..), Visibility(..)) + +import Types.Data.Num + +import qualified Foreign.Storable as St +import Foreign.StablePtr (StablePtr, castStablePtrToPtr) +import Foreign.Ptr (minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr) + +import Control.Monad (liftM, when) + +import Data.Typeable (Typeable) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Maybe (fromMaybe) + +-------------------------------------- + +-- | Create a new module. +newModule :: IO U.Module +newModule = newNamedModule "_module" -- XXX should generate a name + +-- | Create a new explicitely named module. +newNamedModule :: String -- ^ module name + -> IO U.Module +newNamedModule = U.createModule + +-- | Give the body for a module. +defineModule :: U.Module -- ^ module that is defined + -> CodeGenModule a -- ^ module body + -> IO a +defineModule = runCodeGenModule + +-- | Create a new module with the given body. +createModule :: CodeGenModule a -- ^ module body + -> IO a +createModule cgm = newModule >>= \ m -> defineModule m cgm + +-------------------------------------- + +newtype ModuleValue = ModuleValue FFI.ValueRef + deriving (Show, Typeable) + +getModuleValues :: U.Module -> IO [(String, ModuleValue)] +getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues + +castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a) +castModuleValue (ModuleValue f) = + if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing + +-------------------------------------- + +newtype Value a = Value { unValue :: FFI.ValueRef } + deriving (Show, Typeable) + +newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef } + deriving (Show, Typeable) + +-- XXX merge with IsArithmetic? +class IsConst a where + constOf :: a -> ConstValue a + +instance IsConst Bool where constOf = constEnum (typeRef True) +--instance IsConst Char where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode +instance IsConst Word8 where constOf = constI +instance IsConst Word16 where constOf = constI +instance IsConst Word32 where constOf = constI +instance IsConst Word64 where constOf = constI +instance IsConst Int8 where constOf = constI +instance IsConst Int16 where constOf = constI +instance IsConst Int32 where constOf = constI +instance IsConst Int64 where constOf = constI +instance IsConst Float where constOf = constF +instance IsConst Double where constOf = constF +--instance IsConst FP128 where constOf = constF + +constOfPtr :: (IsType ptr) => + ptr -> Ptr b -> ConstValue ptr +constOfPtr proto p = + let ip = p `minusPtr` nullPtr + inttoptrC :: ConstValue int -> ConstValue ptr + inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto) + in if St.sizeOf p == 4 then + inttoptrC $ constOf (fromIntegral ip :: Word32) + else if St.sizeOf p == 8 then + inttoptrC $ constOf (fromIntegral ip :: Word64) + else + error "constOf Ptr: pointer size not 4 or 8" + +-- This instance doesn't belong here, but mutually recursive modules are painful. +instance (IsType a) => IsConst (Ptr a) where + constOf p = constOfPtr p p + +instance IsConst (StablePtr a) where + constOf p = constOfPtr p (castStablePtrToPtr p) + +instance (IsPrimitive a, IsConst a, PositiveT n) => IsConst (Vector n a) where + constOf (Vector xs) = constVector (map constOf xs) + +instance (IsConst a, IsSized a, NaturalT n) => IsConst (Array n a) where + constOf (Array xs) = constArray (map constOf xs) + +instance (IsConstFields a) => IsConst (Struct a) where + constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False +instance (IsConstFields a) => IsConst (PackedStruct a) where + constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True + +class IsConstFields a where + constFieldsOf :: a -> [FFI.ValueRef] + +instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where + constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as +instance IsConstFields () where + constFieldsOf _ = [] + +constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a +constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 + +constI :: (IsInteger a, Integral a) => a -> ConstValue a +constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i) + +constF :: (IsFloating a, Real a) => a -> ConstValue a +constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i) + +valueOf :: (IsConst a) => a -> Value a +valueOf = value . constOf + +value :: ConstValue a -> Value a +value (ConstValue a) = Value a + +zero :: forall a . (IsType a) => ConstValue a +zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a) + +allOnes :: forall a . (IsInteger a) => ConstValue a +allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a) + +undef :: forall a . (IsType a) => ConstValue a +undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a) + +{- +createString :: String -> ConstValue (DynamicArray Word8) +createString = ConstValue . U.constString + +constStringNul :: String -> ConstValue (DynamicArray Word8) +constStringNul = ConstValue . U.constStringNul +-} + +-------------------------------------- + + +-- |A function is simply a pointer to the function. +type Function a = Value (Ptr a) + +-- | Create a new named function. +newNamedFunction :: forall a . (IsFunction a) + => Linkage + -> String -- ^ Function name + -> CodeGenModule (Function a) +newNamedFunction linkage name = do + modul <- getModule + let typ = typeRef (undefined :: a) + liftIO $ liftM Value $ U.addFunction modul linkage name typ + +-- | Create a new function. Use 'newNamedFunction' to create a function with external linkage, since +-- it needs a known name. +newFunction :: forall a . (IsFunction a) + => Linkage + -> CodeGenModule (Function a) +newFunction linkage = genMSym "fun" >>= newNamedFunction linkage + +defineFunctionParam :: + Function f -- ^ Function to define (created by 'newFunction'). + -> Parameterized r f -- ^ Function body. + -> CodeGenModule () +defineFunctionParam fn p = do + bld <- liftIO $ U.createBuilder + let body' = do + newBasicBlock >>= defineBasicBlock + defineParameterized fn p + runCodeGenFunction bld (unValue fn) body' + +-- | Define a function body. The basic block returned by the function is the function entry point. +defineFunction :: forall f . (FunctionArgs f) + => Function f -- ^ Function to define (created by 'newFunction'). + -> FunctionCodeGen f -- ^ Function body. + -> CodeGenModule () +defineFunction fn body = + defineFunctionParam fn $ paramFunc body + +-- | Create a new function with the given body. +createFunction :: (FunctionArgs f) + => Linkage + -> FunctionCodeGen f -- ^ Function body. + -> CodeGenModule (Function f) +createFunction linkage body = do + f <- newFunction linkage + defineFunction f body + return f + +-- | Create a new function with the given body. +createNamedFunction :: (FunctionArgs f) + => Linkage + -> String + -> FunctionCodeGen f -- ^ Function body. + -> CodeGenModule (Function f) +createNamedFunction linkage name body = do + f <- newNamedFunction linkage name + defineFunction f body + return f + +-- | Set the calling convention of a function. By default it is the +-- C calling convention. +setFuncCallConv :: Function a + -> FFI.CallingConvention + -> CodeGenModule () +setFuncCallConv (Value f) cc = do + liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc) + +-- | Add attributes to a value. Beware, what attributes are allowed depends on +-- what kind of value it is. +addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r () +addAttributes (Value f) i as = do + liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as) + +-- Convert a function of type f = t1->t2->...-> IO r to +-- g = Value t1 -> Value t2 -> ... CodeGenFunction r () +class IsFunction f => FunctionArgs f where + type FunctionCodeGen f :: * + type FunctionResult f :: * + paramFunc :: FunctionCodeGen f -> Parameterized (FunctionResult f) f + +instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where + type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b + type FunctionResult (a -> b) = FunctionResult b + paramFunc f = param $ \x -> paramFunc (f x) + +instance IsFirstClass a => FunctionArgs (IO a) where + type FunctionCodeGen (IO a) = CodeGenFunction a () + type FunctionResult (IO a) = a + paramFunc = parameterized + + +newtype + Parameterized r f = + Parameterized (Int -> FFI.ValueRef -> CodeGenFunction r ()) + +parameterized :: CodeGenFunction r () -> Parameterized r (IO r) +parameterized code = Parameterized (const $ const code) + +param :: (Value a -> Parameterized r b) -> Parameterized r (a -> b) +param pf = + Parameterized $ \n f -> + case pf $ Value $ U.getParam f n of + Parameterized p -> p (n+1) f + +defineParameterized :: Function f -> Parameterized r f -> CodeGenFunction r () +defineParameterized f (Parameterized p) = p 0 $ unValue f + + +-------------------------------------- + +-- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction. +newtype BasicBlock = BasicBlock FFI.BasicBlockRef + deriving (Show, Typeable) + +createBasicBlock :: CodeGenFunction r BasicBlock +createBasicBlock = do + b <- newBasicBlock + defineBasicBlock b + return b + +newBasicBlock :: CodeGenFunction r BasicBlock +newBasicBlock = genFSym >>= newNamedBasicBlock + +newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock +newNamedBasicBlock name = do + fn <- getFunction + liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name + +defineBasicBlock :: BasicBlock -> CodeGenFunction r () +defineBasicBlock (BasicBlock l) = do + bld <- getBuilder + liftIO $ U.positionAtEnd bld l + +getCurrentBasicBlock :: CodeGenFunction r BasicBlock +getCurrentBasicBlock = do + bld <- getBuilder + liftIO $ liftM BasicBlock $ U.getInsertBlock bld + +toLabel :: BasicBlock -> Value Label +toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr) + +fromLabel :: Value Label -> BasicBlock +fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr) + +-------------------------------------- + +--- XXX: the functions in this section (and addGlobalMapping) don't actually use any +-- Function state so should really be in the CodeGenModule monad + +-- | Create a reference to an external function while code generating for a function. +-- If LLVM cannot resolve its name, then you may try 'staticFunction'. +externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a) +externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage + +-- | As 'externFunction', but for 'Global's rather than 'Function's +externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a) +externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage + +externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a) +externCore name act = do + es <- getExterns + case lookup name es of + Just f -> return $ Value f + Nothing -> do + f <- liftCodeGenModule $ act name + putExterns ((name, f) : es) + return $ Value f + +{- | +Make an external C function with a fixed address callable from LLVM code. +This callback function can also be a Haskell function, +that was imported like + +> foreign import ccall "&nextElement" +> nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) + +See @examples\/List.hs@. + +When you only use 'externFunction', then LLVM cannot resolve the name. +(However, I do not know why.) +Thus 'staticFunction' manages a list of static functions. +This list is automatically installed by 'ExecutionEngine.simpleFunction' +and can be manually obtained by 'getGlobalMappings' +and installed by 'ExecutionEngine.addGlobalMappings'. +\"Installing\" means calling LLVM's @addGlobalMapping@ according to +. +-} +staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f) +staticFunction func = liftCodeGenModule $ do + val <- newNamedFunction ExternalLinkage "" + addGlobalMapping (unValue (val :: Function f)) (castFunPtrToPtr func) + return val + +-- | As 'staticFunction', but for 'Global's rather than 'Function's +staticGlobal :: forall a r. (IsType a) => Bool -> Ptr a -> CodeGenFunction r (Global a) +staticGlobal isConst gbl = liftCodeGenModule $ do + val <- newNamedGlobal isConst ExternalLinkage "" + addGlobalMapping (unValue (val :: Global a)) (castPtr gbl) + return val + +-------------------------------------- + +withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a +withCurrentBuilder body = do + bld <- getBuilder + liftIO $ U.withBuilder bld body + +-------------------------------------- + +-- Mark all block terminating instructions. Not used yet. +--data Terminate = Terminate + +-------------------------------------- + +type Global a = Value (Ptr a) + +-- | Create a new named global variable. +newNamedGlobal :: forall a . (IsType a) + => Bool -- ^Constant? + -> Linkage -- ^Visibility + -> String -- ^Name + -> TGlobal a +newNamedGlobal isConst linkage name = do + modul <- getModule + let typ = typeRef (undefined :: a) + liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ + when isConst $ FFI.setGlobalConstant g 1 + return g + +-- | Create a new global variable. +newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a +newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage + +-- | Give a global variable a (constant) value. +defineGlobal :: Global a -> ConstValue a -> CodeGenModule () +defineGlobal (Value g) (ConstValue v) = + liftIO $ FFI.setInitializer g v + +-- | Create and define a global variable. +createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a +createGlobal isConst linkage con = do + g <- newGlobal isConst linkage + defineGlobal g con + return g + +-- | Create and define a named global variable. +createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a +createNamedGlobal isConst linkage name con = do + g <- newNamedGlobal isConst linkage name + defineGlobal g con + return g + +type TFunction a = CodeGenModule (Function a) +type TGlobal a = CodeGenModule (Global a) + +-- Special string creators +{-# DEPRECATED createString "use withString instead" #-} +createString :: String -> TGlobal (Array n Word8) +createString s = string (length s) (U.constString s) + +{-# DEPRECATED createStringNul "use withStringNul instead" #-} +createStringNul :: String -> TGlobal (Array n Word8) +createStringNul s = string (length s + 1) (U.constStringNul s) + +withString :: + String -> + (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) -> + CodeGenModule a +withString s act = + let n = length s + in fromMaybe (error "withString: length must always be non-negative") $ + reifyNaturalD (fromIntegral n) (\tn -> + do arr <- string n (U.constString s) + act (fixArraySize tn arr)) + +withStringNul :: + String -> + (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) -> + CodeGenModule a +withStringNul s act = + let n = length s + 1 + in fromMaybe (error "withStringNul: length must always be non-negative") $ + reifyNaturalD (fromIntegral n) (\tn -> + do arr <- string n (U.constStringNul s) + act (fixArraySize tn arr)) + +fixArraySize :: n -> Global (Array n a) -> Global (Array n a) +fixArraySize _ = id + +string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8) +string n s = do + modul <- getModule + name <- genMSym "str" + let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n) + liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ + FFI.setGlobalConstant g 1 + FFI.setInitializer g s + return g + +-------------------------------------- + +-- |Make a constant vector. Replicates or truncates the list to get length /n/. +constVector :: forall a n . (PositiveT n) => [ConstValue a] -> ConstValue (Vector n a) +constVector xs = + ConstValue $ U.constVector (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ] + +-- |Make a constant array. Replicates or truncates the list to get length /n/. +constArray :: forall a n . (IsSized a, NaturalT n) => [ConstValue a] -> ConstValue (Array n a) +constArray xs = + ConstValue $ U.constArray (typeRef (undefined :: a)) (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ] + +-- |Make a constant struct. +constStruct :: (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c)) +constStruct struct = + ConstValue $ U.constStruct (constValueFieldsOf struct) False + +-- |Make a constant packed struct. +constPackedStruct :: (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c)) +constPackedStruct struct = + ConstValue $ U.constStruct (constValueFieldsOf struct) True + +class IsConstStruct c where + type ConstStructOf c :: * + constValueFieldsOf :: c -> [FFI.ValueRef] + +instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where + type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs) + constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as +instance IsConstStruct () where + type ConstStructOf () = () + constValueFieldsOf _ = [] diff --git a/src/LLVM/Core/CodeGenMonad.hs b/src/LLVM/Core/CodeGenMonad.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/CodeGenMonad.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.Core.CodeGenMonad( + -- * Module code generation + CodeGenModule, runCodeGenModule, genMSym, getModule, + GlobalMappings(..), addGlobalMapping, getGlobalMappings, + -- * Function code generation + CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, + -- * Reexport + liftIO + ) where + +import LLVM.Core.Util(Module, Builder, Function) + +import Foreign.Ptr (Ptr, ) + +import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, ) +import Control.Monad.IO.Class (MonadIO, liftIO, ) +import Control.Applicative (Applicative, ) + +import Data.Typeable (Typeable) + +-------------------------------------- + +data CGMState = CGMState { + cgm_module :: Module, + cgm_externs :: [(String, Function)], + cgm_global_mappings :: [(Function, Ptr ())], + cgm_next :: !Int + } + deriving (Show, Typeable) +newtype CodeGenModule a = CGM (StateT CGMState IO a) + deriving (Functor, Applicative, Monad, MonadIO, Typeable) + +genMSym :: String -> CodeGenModule String +genMSym prefix = do + s <- CGM get + let n = cgm_next s + CGM $ put (s { cgm_next = n + 1 }) + return $ "_" ++ prefix ++ show n + +getModule :: CodeGenModule Module +getModule = CGM $ gets cgm_module + +runCodeGenModule :: Module -> CodeGenModule a -> IO a +runCodeGenModule m (CGM body) = do + let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] } + evalStateT body cgm + +-------------------------------------- + +data CGFState r = CGFState { + cgf_module :: CGMState, + cgf_builder :: Builder, + cgf_function :: Function, + cgf_next :: !Int + } + deriving (Show, Typeable) +newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a) + deriving (Functor, Applicative, Monad, MonadIO, Typeable) + +genFSym :: CodeGenFunction a String +genFSym = do + s <- CGF get + let n = cgf_next s + CGF $ put (s { cgf_next = n + 1 }) + return $ "_L" ++ show n + +getFunction :: CodeGenFunction a Function +getFunction = CGF $ gets cgf_function + +getBuilder :: CodeGenFunction a Builder +getBuilder = CGF $ gets cgf_builder + +getFunctionModule :: CodeGenFunction a Module +getFunctionModule = CGF $ gets (cgm_module . cgf_module) + +getExterns :: CodeGenFunction a [(String, Function)] +getExterns = CGF $ gets (cgm_externs . cgf_module) + +putExterns :: [(String, Function)] -> CodeGenFunction a () +putExterns es = do + cgf <- CGF get + let cgm' = (cgf_module cgf) { cgm_externs = es } + CGF $ put (cgf { cgf_module = cgm' }) + +addGlobalMapping :: + Function -> Ptr () -> CodeGenModule () +addGlobalMapping value func = CGM $ modify $ \cgm -> + cgm { cgm_global_mappings = + (value,func) : cgm_global_mappings cgm } + +newtype GlobalMappings = + GlobalMappings [(Function, Ptr ())] + +{- | +Get a list created by calls to 'staticFunction' +that must be passed to the execution engine +via 'LLVM.ExecutionEngine.addGlobalMappings'. +-} +getGlobalMappings :: + CodeGenModule GlobalMappings +getGlobalMappings = + CGM $ gets (GlobalMappings . cgm_global_mappings) + +runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a +runCodeGenFunction bld fn (CGF body) = do + cgm <- CGM get + let cgf = CGFState { cgf_module = cgm, + cgf_builder = bld, + cgf_function = fn, + cgf_next = 1 } + (a, cgf') <- liftIO $ runStateT body cgf + CGM $ put (cgf_module cgf') + return a + +-------------------------------------- + +-- | Allows you to define part of a module while in the middle of defining a function. +liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a +liftCodeGenModule (CGM act) = do + cgf <- CGF get + (a, cgm') <- liftIO $ runStateT act (cgf_module cgf) + CGF $ put (cgf { cgf_module = cgm' }) + return a diff --git a/src/LLVM/Core/Data.hs b/src/LLVM/Core/Data.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Data.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.Core.Data(IntN(..), WordN(..), FP128(..), + Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where + +import Foreign.Ptr (Ptr) +import Data.Typeable (Typeable) + + +-- TODO: +-- Make instances IntN, WordN to actually do the right thing. +-- Make FP128 do the right thing +-- Make Array functions. + +-- |Variable sized signed integer. +-- The /n/ parameter should belong to @PosI@. +newtype IntN n = IntN Integer + deriving (Show, Typeable) + +-- |Variable sized unsigned integer. +-- The /n/ parameter should belong to @PosI@. +newtype WordN n = WordN Integer + deriving (Show, Typeable) + +-- |128 bit floating point. +newtype FP128 = FP128 Rational + deriving (Show, Typeable) + +-- |Fixed sized arrays, the array size is encoded in the /n/ parameter. +newtype Array n a = Array [a] + deriving (Show, Typeable) + +-- |Fixed sized vector, the array size is encoded in the /n/ parameter. +newtype Vector n a = Vector [a] + deriving (Show, Typeable) + +-- |Label type, produced by a basic block. +data Label + deriving (Typeable) + +-- |Struct types; a list (nested tuple) of component types. +newtype Struct a = Struct a + deriving (Show, Typeable) +newtype PackedStruct a = PackedStruct a + deriving (Show, Typeable) diff --git a/src/LLVM/Core/Instructions.hs b/src/LLVM/Core/Instructions.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Instructions.hs @@ -0,0 +1,1308 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module LLVM.Core.Instructions( + -- * ADT representation of IR + BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc, + -- * Terminator instructions + ret, + condBr, + br, + switch, + invoke, invokeWithConv, + invokeFromFunction, invokeWithConvFromFunction, + unreachable, + -- * Arithmetic binary operations + -- | Arithmetic operations with the normal semantics. + -- The u instractions are unsigned, the s instructions are signed. + add, sub, mul, neg, + 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. + shl, lshr, ashr, and, or, xor, inv, + -- * Vector operations + extractelement, + insertelement, + shufflevector, + -- * Aggregate operation + extractvalue, + insertvalue, + -- * Memory access + malloc, arrayMalloc, + alloca, arrayAlloca, + free, + load, + store, + getElementPtr, getElementPtr0, + -- * Conversions + trunc, zext, sext, ext, zadapt, sadapt, adapt, + fptrunc, fpext, + fptoui, fptosi, fptoint, + uitofp, sitofp, inttofp, + ptrtoint, inttoptr, + bitcast, + bitcastElements, + -- * Comparison + CmpPredicate(..), IntPredicate(..), FPPredicate(..), + CmpOp, CmpRet, CmpResult, + cmp, pcmp, icmp, fcmp, + select, + -- * Other + phi, addPhiInputs, + call, callWithConv, + callFromFunction, callWithConvFromFunction, + Call, applyCall, runCall, + + -- * Classes and types + Terminate, + Ret, CallArgs, ABinOp, ABinOpResult, IsConst, + FunctionArgs, FunctionCodeGen, FunctionResult, + AllocArg, + GetElementPtr, ElementPtrType, IsIndexArg, + GetValue, ValueType + ) where + +import qualified LLVM.Core.Util as U +import LLVM.Core.Data +import LLVM.Core.Type +import LLVM.Core.CodeGenMonad +import LLVM.Core.CodeGen + +import qualified LLVM.FFI.Core as FFI + +import Types.Data.Num (Dec, DecN, (:.), d1, fromIntegerT, Pred) +import Types.Data.Ord (LTT, GTT) + +import Foreign.Ptr (FunPtr, ) +import Foreign.C (CInt, CUInt) + +import Control.Monad (liftM) + +import Data.Typeable (Typeable) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) +import Data.Map (fromList, (!)) + +import Prelude hiding (and, or) + + +-- TODO: +-- Add vector version of arithmetic +-- Add rest of instructions +-- Use Terminate to ensure bb termination (how?) +-- more intrinsics are needed to, e.g., create an empty vector + +data ArgDesc = AV String | AI Int | AL String | AE + +instance Show ArgDesc where + -- show (AV s) = "V_" ++ s + -- show (AI i) = "I_" ++ show i + -- show (AL l) = "L_" ++ l + show (AV s) = s + show (AI i) = show i + show (AL l) = l + show AE = "voidarg?" + +data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd + | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub + | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul + | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem + | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor + deriving Show + +-- FIXME: complete definitions for unimplemented instructions +data InstrDesc = + -- terminators + IDRet TypeDesc ArgDesc | IDRetVoid + | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc + | IDSwitch [(ArgDesc, ArgDesc)] + | IDIndirectBr + | IDInvoke + | IDUnwind + | IDUnreachable + -- binary operators (including bitwise) + | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc + -- memory access and addressing + | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc + | IDGetElementPtr TypeDesc [ArgDesc] + -- conversion + | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc + | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc + | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc + | IDSItoFP TypeDesc TypeDesc ArgDesc + | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc + | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc + | IDBitcast TypeDesc TypeDesc ArgDesc + -- other + | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc + | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc] + | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg + -- vector operators + | IDExtractElement | IDInsertElement | IDShuffleVector + -- aggregate operators + | IDExtractValue | IDInsertValue + -- invalid + | IDInvalidOp + deriving Show + +-- TODO: overflow support for binary operations (add/sub/mul) +getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc) +getInstrDesc v = do + valueName <- U.getValueNameU v + opcode <- FFI.instGetOpcode v + t <- FFI.typeOf v >>= typeDesc2 + -- FIXME: sizeof() does not work for types! + --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral + tsize <- return 1 + os <- U.getOperands v >>= mapM getArgDesc + os0 <- if length os > 0 then return $ os !! 0 else return AE + os1 <- if length os > 1 then return $ os !! 1 else return AE + t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41) + then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2 + else return TDVoid) + p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0 + let instr = + (if opcode >= 8 && opcode <= 25 -- binary arithmetic + then IDBinOp (getBinOp opcode) t os0 os1 + else if opcode >= 30 && opcode <= 41 -- conversion + then (getConvOp opcode) t2 t os0 + else case opcode of + { 1 -> if null os then IDRetVoid else IDRet t os0; + 2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1; + 3 -> IDSwitch $ toPairs os; + -- TODO (can skip for now) + -- 4 -> IndirectBr ; 5 -> Invoke ; + 6 -> IDUnwind; 7 -> IDUnreachable; + 26 -> IDAlloca (getPtrType t) tsize (getImmInt os0); + 27 -> IDLoad t os0; 28 -> IDStore t os0 os1; + 29 -> IDGetElementPtr t os; + 42 -> IDICmp (toIntPredicate p) os0 os1; + 43 -> IDFCmp (toFPPredicate p) os0 os1; + 44 -> IDPhi t $ toPairs os; + -- FIXME: getelementptr arguments are not handled + 45 -> IDCall t (last os) (init os); + 46 -> IDSelect t os0 os1; + -- TODO (can skip for now) + -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ; + -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ; + -- 53 -> ExtractValue ; 54 -> InsertValue ; + _ -> IDInvalidOp }) + return (valueName, instr) + --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode + where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub), + (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv), + (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem), + (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd), + (24, BOOr), (25, BOXor)] ! o + getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI), + (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc), + (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o + toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs)) + stride _ [] = [] + stride n (x:xs) = x : stride n (drop (n-1) xs) + getPtrType (TDPtr t) = t + getPtrType _ = TDVoid + getImmInt (AI i) = i + getImmInt _ = 0 + +-- TODO: fix for non-int constants +getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc +getArgDesc (vname, v) = do + isC <- U.isConstant v + t <- FFI.typeOf v >>= typeDesc2 + if isC + then case t of + TDInt _ _ -> do + cV <- FFI.constIntGetSExtValue v + return $ AI $ fromIntegral cV + _ -> return AE + else case t of + TDLabel -> return $ AL vname + _ -> return $ AV vname + +-------------------------------------- + +type Terminate = () +terminate :: Terminate +terminate = () + +-------------------------------------- + +-- |Acceptable arguments to the 'ret' instruction. +class Ret a r where + ret' :: a -> CodeGenFunction r Terminate + +-- | Return from the current function with the given value. Use () as the return value for what would be a void function in C. +ret :: (Ret a r) => a -> CodeGenFunction r Terminate +ret = ret' + +-- overlaps with Ret () ()! +{- +instance (IsFirstClass a, IsConst a) => Ret a a where + ret' = ret . valueOf +-} + +instance Ret (Value a) a where + ret' (Value a) = do + withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a + return terminate + +instance Ret () () where + ret' _ = do + withCurrentBuilder_ $ FFI.buildRetVoid + return terminate + +withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r () +withCurrentBuilder_ p = withCurrentBuilder p >> return () + +-------------------------------------- + +-- | Branch to the first basic block if the boolean is true, otherwise to the second basic block. +condBr :: Value Bool -- ^ Boolean to branch upon. + -> BasicBlock -- ^ Target for true. + -> BasicBlock -- ^ Target for false. + -> CodeGenFunction r Terminate +condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do + withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2 + return terminate + +-------------------------------------- + +-- | Unconditionally branch to the given basic block. +br :: BasicBlock -- ^ Branch target. + -> CodeGenFunction r Terminate +br (BasicBlock t) = do + withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t + return terminate + +-------------------------------------- + +-- | Branch table instruction. +switch :: (IsInteger a) + => Value a -- ^ Value to branch upon. + -> BasicBlock -- ^ Default branch target. + -> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets. + -> CodeGenFunction r Terminate +switch (Value val) (BasicBlock dflt) arms = do + withCurrentBuilder_ $ \ bldPtr -> do + inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms) + sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ] + return terminate + +-------------------------------------- + +-- |Inform the code generator that this code can never be reached. +unreachable :: CodeGenFunction r Terminate +unreachable = do + withCurrentBuilder_ FFI.buildUnreachable + return terminate + +-------------------------------------- + +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 where + type ABinOpResult a b :: * + abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b) + +add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +iadd = abinop FFI.constAdd FFI.buildAdd +isub :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +isub = abinop FFI.constSub FFI.buildSub +imul :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => 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 ~ ABinOpResult a b) => + 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 ~ ABinOpResult a b) => + 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 ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +udiv = abinop FFI.constUDiv FFI.buildUDiv +sdiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +sdiv = abinop FFI.constSDiv FFI.buildSDiv +urem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +urem = abinop FFI.constURem FFI.buildURem +srem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +srem = abinop FFI.constSRem FFI.buildSRem + +fadd :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fadd = abinop FFI.constFAdd FFI.buildFAdd +fsub :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fsub = abinop FFI.constFSub FFI.buildFSub +fmul :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fmul = abinop FFI.constFMul FFI.buildFMul + +-- | Floating point division. +fdiv :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fdiv = abinop FFI.constFDiv FFI.buildFDiv +-- | Floating point remainder. +frem :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +frem = abinop FFI.constFRem FFI.buildFRem + +shl :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +shl = abinop FFI.constShl FFI.buildShl +lshr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +lshr = abinop FFI.constLShr FFI.buildLShr +ashr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +ashr = abinop FFI.constAShr FFI.buildAShr +and :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +and = abinop FFI.constAnd FFI.buildAnd +or :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +or = abinop FFI.constOr FFI.buildOr +xor :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +xor = abinop FFI.constXor FFI.buildXor + +instance ABinOp (Value a) (Value a) where + type ABinOpResult (Value a) (Value a) = Value a + abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2 + +instance ABinOp (ConstValue a) (Value a) where + type ABinOpResult (ConstValue a) (Value a) = Value a + abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2 + +instance ABinOp (Value a) (ConstValue a) where + type ABinOpResult (Value a) (ConstValue a) = Value a + abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2 + +instance ABinOp (ConstValue a) (ConstValue a) where + type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a + abinop cop _ (ConstValue a1) (ConstValue a2) = + return $ ConstValue $ cop a1 a2 + +{- +instance (IsConst a) => ABinOp (Value a) a where + type ABinOpResult (Value a) a = Value a + abinop cop op a1 a2 = abinop cop op a1 (constOf a2) + +instance (IsConst a) => ABinOp a (Value a) where + type ABinOpResult a (Value a) = Value a + abinop cop op a1 a2 = abinop cop op (constOf a1) a2 +-} + +--instance (IsConst a) => ABinOp a a (ConstValue a) where +-- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2) + +buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a) +buildBinOp op a1 a2 = + liftM Value $ + withCurrentBuilder $ \ bld -> + U.withEmptyCString $ op bld a1 a2 + +type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef + +buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a) +buildUnOp op a = + liftM Value $ + withCurrentBuilder $ \ bld -> + U.withEmptyCString $ op bld a + +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 (Value x) = buildUnOp FFI.buildFNeg x +-} + +inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a) +inv (Value x) = buildUnOp FFI.buildNot x + +-------------------------------------- + +-- | Get a value from a vector. +extractelement :: (PositiveT n) + => Value (Vector n a) -- ^ Vector + -> Value Word32 -- ^ Index into the vector + -> CodeGenFunction r (Value a) +extractelement (Value vec) (Value i) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i + +-- | Insert a value into a vector, nondestructive. +insertelement :: (PositiveT n) + => Value (Vector n a) -- ^ Vector + -> Value a -- ^ Value to insert + -> Value Word32 -- ^ Index into the vector + -> CodeGenFunction r (Value (Vector n a)) +insertelement (Value vec) (Value e) (Value i) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i + +-- | Permute vector. +shufflevector :: (PositiveT n, PositiveT m) + => Value (Vector n a) + -> 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 -> + U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask + + +-- |Acceptable arguments to 'extractvalue' and 'insertvalue'. +class GetValue agg ix where + type ValueType agg ix :: * + getIx :: agg -> ix -> CUInt + +instance (GetField as i, NaturalT i) => GetValue (Struct as) i where + type ValueType (Struct as) i = FieldType as i + getIx _ n = fromIntegerT n + +instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where + type ValueType (Array n a) Word32 = a + getIx _ n = fromIntegral n + +instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where + type ValueType (Array n a) Word64 = a + getIx _ n = fromIntegral n + + +instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where + type ValueType (Array n a) (Dec i) = a + getIx _ n = fromIntegerT n + + +-- | Get a value from an aggregate. +extractvalue :: forall r agg i. + GetValue agg i + => Value agg -- ^ Aggregate + -> i -- ^ Index into the aggregate + -> CodeGenFunction r (Value (ValueType agg i)) +extractvalue (Value agg) i = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i) + +-- | Insert a value into an aggregate, nondestructive. +insertvalue :: forall r agg i. + GetValue agg i + => Value agg -- ^ Aggregate + -> Value (ValueType agg i) -- ^ Value to insert + -> i -- ^ Index into the aggregate + -> CodeGenFunction r (Value agg) +insertvalue (Value agg) (Value e) i = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i) + + +-------------------------------------- + +-- XXX should allows constants + +-- | Truncate a value to a shorter bit width. +trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +trunc = convert FFI.buildTrunc + +-- | Zero extend a value to a wider width. +-- If possible, use 'ext' that chooses the right padding according to the types +zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +zext = convert FFI.buildZExt + +-- | Sign extend a value to wider width. +-- If possible, use 'ext' that chooses the right padding according to the types +sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +sext = convert FFI.buildSExt + +-- | Extend a value to wider width. +-- If the target type is signed, then preserve the sign, +-- If the target type is unsigned, then extended by zeros. +ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +ext = + if isSigned (undefined :: b) + then convert FFI.buildSExt + else convert FFI.buildZExt + + +-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes. +zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) + => Value a -> CodeGenFunction r (Value b) +zadapt = + case compare (sizeOf (typeDesc (undefined :: a))) + (sizeOf (typeDesc (undefined :: b))) of + LT -> convert FFI.buildZExt + EQ -> convert FFI.buildBitCast + GT -> convert FFI.buildTrunc + +-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes. +sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) + => Value a -> CodeGenFunction r (Value b) +sadapt = + case compare (sizeOf (typeDesc (undefined :: a))) + (sizeOf (typeDesc (undefined :: b))) of + LT -> convert FFI.buildSExt + EQ -> convert FFI.buildBitCast + GT -> convert FFI.buildTrunc + +-- | It is 'sadapt' or 'zadapt' depending on the sign mode. +adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b) + => Value a -> CodeGenFunction r (Value b) +adapt = + case compare (sizeOf (typeDesc (undefined :: a))) + (sizeOf (typeDesc (undefined :: b))) of + LT -> + if isSigned (undefined :: b) + then convert FFI.buildSExt + else convert FFI.buildZExt + EQ -> convert FFI.buildBitCast + GT -> convert FFI.buildTrunc + +-- | Truncate a floating point value. +fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +fptrunc = convert FFI.buildFPTrunc + +-- | Extend a floating point value. +fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +fpext = convert FFI.buildFPExt + +{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-} +-- | Convert a floating point value to an unsigned integer. +fptoui :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +fptoui = convert FFI.buildFPToUI + +{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-} +-- | Convert a floating point value to a signed integer. +fptosi :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +fptosi = convert FFI.buildFPToSI + +-- | Convert a floating point value to an integer. +-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@. +fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +fptoint = + if isSigned (undefined :: b) + then convert FFI.buildFPToSI + else convert FFI.buildFPToUI + + +{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -} +-- | Convert an unsigned integer to a floating point value. +-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool. +uitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +uitofp = convert FFI.buildUIToFP + +{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -} +-- | Convert a signed integer to a floating point value. +-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool. +sitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +sitofp = convert FFI.buildSIToFP + +-- | Convert an integer to a floating point value. +-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@. +inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +inttofp = + if isSigned (undefined :: a) + then convert FFI.buildSIToFP + else convert FFI.buildUIToFP + + +-- | Convert a pointer to an integer. +ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b) +ptrtoint = convert FFI.buildPtrToInt + +-- | Convert an integer to a pointer. +inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b)) +inttoptr = convert FFI.buildIntToPtr + +-- | Convert between to values of the same size by just copying the bit pattern. +bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b) + => Value a -> CodeGenFunction r (Value b) +bitcast = convert FFI.buildBitCast + +-- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same. +bitcastElements :: (PositiveT n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b) + => Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) +bitcastElements = convert FFI.buildBitCast + + +type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef + +convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b) +convert conv (Value a) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b)) + +-------------------------------------- + +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 + | IntUGT -- ^ unsigned greater than + | IntUGE -- ^ unsigned greater or equal + | IntULT -- ^ unsigned less than + | IntULE -- ^ unsigned less or equal + | IntSGT -- ^ signed greater than + | IntSGE -- ^ signed greater or equal + | IntSLT -- ^ signed less than + | IntSLE -- ^ signed less or equal + deriving (Eq, Ord, Enum, Show, Typeable) + +fromIntPredicate :: IntPredicate -> CInt +fromIntPredicate p = fromIntegral (fromEnum p + 32) + +toIntPredicate :: CInt -> IntPredicate +toIntPredicate p = toEnum $ fromIntegral p - 32 + +data FPPredicate = + FPFalse -- ^ Always false (always folded) + | FPOEQ -- ^ True if ordered and equal + | FPOGT -- ^ True if ordered and greater than + | FPOGE -- ^ True if ordered and greater than or equal + | FPOLT -- ^ True if ordered and less than + | FPOLE -- ^ True if ordered and less than or equal + | FPONE -- ^ True if ordered and operands are unequal + | FPORD -- ^ True if ordered (no nans) + | FPUNO -- ^ True if unordered: isnan(X) | isnan(Y) + | FPUEQ -- ^ True if unordered or equal + | FPUGT -- ^ True if unordered or greater than + | FPUGE -- ^ True if unordered, greater than, or equal + | FPULT -- ^ True if unordered or less than + | FPULE -- ^ True if unordered, less than, or equal + | FPUNE -- ^ True if unordered or not equal + | FPT -- ^ Always true (always folded) + deriving (Eq, Ord, Enum, Show, Typeable) + +fromFPPredicate :: FPPredicate -> CInt +fromFPPredicate p = fromIntegral (fromEnum p) + +toFPPredicate :: CInt -> FPPredicate +toFPPredicate p = toEnum $ fromIntegral p + +-- |Acceptable operands to comparison instructions. +class CmpRet (CmpType a b) => CmpOp a b where + type CmpType a b :: * + cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (CmpType a b))) + +instance (CmpRet a) => CmpOp (Value a) (Value a) where + type CmpType (Value a) (Value a) = a + cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2 + +{- +instance (IsConst a, CmpRet a) => CmpOp a (Value a) where + type CmpType a (Value a) = a + cmpop op a1 a2 = cmpop op (valueOf a1) a2 + +instance (IsConst a, CmpRet a) => CmpOp (Value a) a where + type CmpType (Value a) a = a + cmpop op a1 a2 = cmpop op a1 (valueOf a2) +-} + +class CmpRet c where + type CmpResult c :: * + cmpBld :: c -> CmpPredicate -> FFIBinOp + +instance CmpRet Float where type CmpResult Float = Bool ; cmpBld _ = fcmpBld +instance CmpRet Double where type CmpResult Double = Bool ; cmpBld _ = fcmpBld +instance CmpRet FP128 where type CmpResult FP128 = Bool ; cmpBld _ = fcmpBld +instance CmpRet Bool where type CmpResult Bool = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word8 where type CmpResult Word8 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word16 where type CmpResult Word16 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word32 where type CmpResult Word32 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word64 where type CmpResult Word64 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Int8 where type CmpResult Int8 = Bool ; cmpBld _ = scmpBld +instance CmpRet Int16 where type CmpResult Int16 = Bool ; cmpBld _ = scmpBld +instance CmpRet Int32 where type CmpResult Int32 = Bool ; cmpBld _ = scmpBld +instance CmpRet Int64 where type CmpResult Int64 = Bool ; cmpBld _ = scmpBld +instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld +instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a) + where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; 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 r. + (CmpOp a b, c ~ CmpType a b) => + CmpPredicate -> a -> b -> + CodeGenFunction r (Value (CmpResult c)) +cmp p = cmpop (cmpBld (undefined :: CmpType a b) 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 ~ CmpType a b) => + CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))) + +_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) => + CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))) + +pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) => + IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c))) +pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) + + +{-# DEPRECATED icmp "use cmp or pcmp instead" #-} +-- | Compare integers. +icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) => + IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) + +-- | Compare floating point values. +fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) => + FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p)) + +-------------------------------------- + +-- XXX could do const song and dance +-- | Select between two values depending on a boolean. +select :: (IsFirstClass a, CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a) +select (Value cnd) (Value thn) (Value els) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildSelect bldPtr cnd thn els + +-------------------------------------- + +type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef + +{- +Function (a -> b -> IO c) +Value a -> Value b -> CodeGenFunction r c +-} + +-- |Acceptable arguments to 'call'. +class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) => + CallArgs f g r where + type CalledFunction g :: * + type CallerResult g :: * + type CallerFunction f r :: * + doCall :: Call f -> g + +instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where + type CalledFunction (Value a -> b') = a -> CalledFunction b' + type CallerResult (Value a -> b') = CallerResult b' + type CallerFunction (a -> b) r = Value a -> CallerFunction b r + doCall f a = doCall (applyCall f a) + +--instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where +-- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a)) + +instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where + type CalledFunction (CodeGenFunction r (Value a)) = IO a + type CallerResult (CodeGenFunction r (Value a)) = r + type CallerFunction (IO a) r = CodeGenFunction r (Value a) + doCall = runCall + +doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a) +doCallDef mkCall args _ = + 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 +-- it takes depends on the type of /f/. +call :: (CallArgs f g r) => Function f -> g +call = doCall . callFromFunction + +data Call a = Call Caller [FFI.ValueRef] + +callFromFunction :: Function a -> Call a +callFromFunction (Value f) = Call (U.makeCall f) [] + +-- like Applicative.<*> +infixl 4 `applyCall` + +applyCall :: Call (a -> b) -> Value a -> Call b +applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args) + +runCall :: Call (IO a) -> CodeGenFunction r (Value a) +runCall (Call mkCall args) = doCallDef mkCall args () + + +invokeFromFunction :: + BasicBlock -- ^Normal return point. + -> BasicBlock -- ^Exception return point. + -> Function f -- ^Function to call. + -> Call f +invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) = + Call (U.makeInvoke norm expt f) [] + +-- | Call a function with exception handling. +invoke :: (CallArgs f g r) + => BasicBlock -- ^Normal return point. + -> BasicBlock -- ^Exception return point. + -> Function f -- ^Function to call. + -> g +invoke norm expt f = doCall $ invokeFromFunction norm expt f + +callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f +callWithConvFromFunction cc (Value f) = + Call (U.makeCallWithCc cc f) [] + +-- | Call a function with the given arguments. The 'call' instruction +-- is variadic, i.e., the number of arguments it takes depends on the +-- type of /f/. +-- This also sets the calling convention of the call to the function. +-- As LLVM itself defines, if the calling conventions of the calling +-- /instruction/ and the function being /called/ are different, undefined +-- behavior results. +callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g +callWithConv cc f = doCall $ callWithConvFromFunction cc f + +invokeWithConvFromFunction :: + FFI.CallingConvention -- ^Calling convention + -> BasicBlock -- ^Normal return point. + -> BasicBlock -- ^Exception return point. + -> Function f -- ^Function to call. + -> Call f +invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) = + Call (U.makeInvokeWithCc cc norm expt f) [] + +-- | Call a function with exception handling. +-- This also sets the calling convention of the call to the function. +-- As LLVM itself defines, if the calling conventions of the calling +-- /instruction/ and the function being /called/ are different, undefined +-- behavior results. +invokeWithConv :: (CallArgs f g r) + => FFI.CallingConvention -- ^Calling convention + -> BasicBlock -- ^Normal return point. + -> BasicBlock -- ^Exception return point. + -> Function f -- ^Function to call. + -> g +invokeWithConv cc norm expt f = + doCall $ invokeWithConvFromFunction cc norm expt f + +-------------------------------------- + +-- XXX could do const song and dance +-- |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 = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> do + inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a)) + U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] + return inst + +-- |Add additional inputs to an existing phi node. +-- The reason for this instruction is that sometimes the structure of the code +-- makes it impossible to have all variables in scope at the point where you need the phi node. +addPhiInputs :: forall a r . (IsFirstClass a) + => Value a -- ^Must be a variable from a call to 'phi'. + -> [(Value a, BasicBlock)] -- ^Variables to add. + -> 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 -> Value Word32 +instance AllocArg (Value Word32) where + getAllocArg = id +instance AllocArg (ConstValue Word32) where + getAllocArg = value +instance AllocArg Word32 where + 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 . (IsSized a) => CodeGenFunction r (Value (Ptr 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 <- bitcast =<< + 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 r s . (IsSized a, AllocArg s) => + s -> CodeGenFunction r (Value (Ptr a)) -- XXX +arrayMalloc s = do + func <- staticFunction alignedMalloc +-- func <- externFunction "malloc" + + size <- sizeOfArray (undefined :: a) (getAllocArg s) + alignment <- alignOf (undefined :: a) + bitcast =<< + 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 . (IsSized a) => CodeGenFunction r (Value (Ptr a)) +alloca = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a)) + +-- XXX What's the type returned by arrayAlloca? +-- | Allocate stack (array) memory. +arrayAlloca :: forall a r s . (IsSized a, AllocArg s) => + s -> CodeGenFunction r (Value (Ptr a)) +arrayAlloca s = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + 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 :: (IsType a) => Value (Ptr a) -> CodeGenFunction r () +free ptr = do + func <- staticFunction alignedFree +-- func <- externFunction "free" + _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast 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 . (IsSized a) => a -> CodeGenFunction r (Value Word64) +_sizeOf a = + liftIO $ liftM Value $ + FFI.sizeOf (typeRef a) + +_alignOf :: forall a r . (IsSized a) => 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 . (IsSized a) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8)) +sizeOfArray _ len = + bitcast =<< + getElementPtr (value zero :: Value (Ptr a)) (len, ()) + +-- see ConstantExpr::getAlignOf +alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value (Ptr Word8)) +alignOf _ = + bitcast =<< + getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ()) + + +-- | Load a value from memory. +load :: Value (Ptr a) -- ^ Address to load from. + -> CodeGenFunction r (Value a) +load (Value p) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildLoad bldPtr p + +-- | Store a value in memory +store :: Value a -- ^ Value to store. + -> Value (Ptr a) -- ^ Address to store to. + -> CodeGenFunction r () +store (Value v) (Value p) = do + withCurrentBuilder_ $ \ bldPtr -> + FFI.buildStore bldPtr v p + return () + +{- +-- XXX type is wrong +-- | Address arithmetic. See LLVM description. +-- (The type isn't as accurate as it should be.) +getElementPtr :: (IsInteger i) => + Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b)) +getElementPtr (Value ptr) ixs = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr -> + U.withEmptyCString $ + FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) +-} + +-- |Acceptable arguments to 'getElementPointer'. +class GetElementPtr optr ixs where + type ElementPtrType optr ixs :: * + getIxList :: optr -> ixs -> [FFI.ValueRef] + +-- |Acceptable single index to 'getElementPointer'. +class IsIndexArg a where + getArg :: a -> FFI.ValueRef + +instance IsIndexArg (Value Word32) where + getArg (Value v) = v + +instance IsIndexArg (Value Word64) where + getArg (Value v) = v + +instance IsIndexArg (Value Int32) where + getArg (Value v) = v + +instance IsIndexArg (Value Int64) where + getArg (Value v) = v + +instance IsIndexArg (ConstValue Word32) where + getArg = unConst + +instance IsIndexArg (ConstValue Word64) where + getArg = unConst + +instance IsIndexArg (ConstValue Int32) where + getArg = unConst + +instance IsIndexArg (ConstValue Int64) where + getArg = unConst + +instance IsIndexArg Word32 where + getArg = unConst . constOf + +instance IsIndexArg Word64 where + getArg = unConst . constOf + +instance IsIndexArg Int32 where + getArg = unConst . constOf + +instance IsIndexArg Int64 where + getArg = unConst . constOf + +unConst :: ConstValue a -> FFI.ValueRef +unConst (ConstValue v) = v + +-- End of indexing +instance GetElementPtr a () where + type ElementPtrType a () = a + getIxList _ () = [] + +-- Index in Array +instance (GetElementPtr o i, IsIndexArg a, NaturalT k) => GetElementPtr (Array k o) (a, i) where + type ElementPtrType (Array k o) (a, i) = ElementPtrType o i + getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i + +-- Index in Vector +instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where + type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i + getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i + +-- Index in Struct and PackedStruct. +-- The index has to be a type level integer to statically determine the record field type +instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (Struct fs) (a, i) where + type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i + getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i +instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where + type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i + getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i + +class GetField as i where type FieldType as i :: * +instance GetField (a, as) (Dec DecN) where type FieldType (a, as) (Dec DecN) = a +instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0))) + +-- | Address arithmetic. See LLVM description. +-- The index is a nested tuple of the form @(i1,(i2,( ... ())))@. +-- (This is without a doubt the most confusing LLVM instruction, but the types help.) +getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) => + Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) +getElementPtr (Value ptr) (a, ixs) = + let ixl = getArg a : getIxList (undefined :: o) ixs in + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withArrayLen ixl $ \ idxLen idxPtr -> + U.withEmptyCString $ + FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) + +-- | Like getElementPtr, but with an initial index that is 0. +-- This is useful since any pointer first need to be indexed off the pointer, and then into +-- its actual value. This first indexing is often with 0. +getElementPtr0 :: (GetElementPtr o i) => + Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) +getElementPtr0 p i = getElementPtr p (0::Word32, i) + +-------------------------------------- +{- +instance (IsConst a) => Show (ConstValue a) -- XXX +instance (IsConst a) => Eq (ConstValue a) + +{- +instance (IsConst a) => Eq (ConstValue a) where + ConstValue x == ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOEQ) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y) + ConstValue x /= ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPONE) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y) + +instance (IsConst a) => Ord (ConstValue a) where + ConstValue x < ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLT) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y) + ConstValue x <= ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLE) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y) + ConstValue x > ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGT) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y) + ConstValue x >= ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGE) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y) +-} + +instance (Num a, IsConst a) => Num (ConstValue a) where + ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y) + ConstValue x - ConstValue y = ConstValue (FFI.constSub x y) + ConstValue x * ConstValue y = ConstValue (FFI.constMul x y) + negate (ConstValue x) = ConstValue (FFI.constNeg x) + fromInteger x = constOf (fromInteger x :: a) +-} diff --git a/src/LLVM/Core/Type.hs b/src/LLVM/Core/Type.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Type.hs @@ -0,0 +1,510 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +-- |The LLVM type system is captured with a number of Haskell type classes. +-- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type. +-- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for +-- those types that are LLVM first class types (passable as arguments etc). +-- All valid LLVM types belong to the 'IsType' class. +module LLVM.Core.Type( + -- * Type classifier + IsType(..), + -- ** Special type classifiers + NaturalT, + PositiveT, + IsArithmetic(arithmeticType), + ArithmeticType(IntegerType,FloatingType), + IsInteger, Signed, + IsIntegerOrPointer, + IsFloating, + IsPrimitive, + IsFirstClass, + IsSized, SizeOf, sizeOf, + IsFunction, + -- ** Others + IsScalarOrVector, NumberOfElements, + UnknownSize, -- needed for arrays of structs + -- ** Structs + (:&), (&), + -- ** Type tests + TypeDesc(..), + isFloating, + isSigned, + typeRef, + typeName, + intrinsicTypeName, + typeDesc2, + VarArgs, CastVarArgs, + ) where + +import qualified LLVM.FFI.Core as FFI + +import LLVM.Core.Util (functionType, structType) +import LLVM.Core.Data + +import Types.Data.Num +import Types.Data.Bool (True, False) + +import Foreign.StablePtr (StablePtr, ) + +import Data.Typeable (Typeable) +import Data.List (intercalate) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word8, Word16, Word32, Word64) + + +#include "MachDeps.h" + +-- TODO: +-- Move IntN, WordN to a special module that implements those types +-- properly in Haskell. +-- Also more Array and Vector to a Haskell module to implement them. +-- Add Label? +-- Add structures (using tuples, maybe nested). + +-- |The 'IsType' class classifies all types that have an LLVM representation. +class IsType a where + typeDesc :: a -> TypeDesc + +typeRef :: (IsType a) => a -> FFI.TypeRef -- ^The argument is never evaluated +typeRef = code . typeDesc + where code TDFloat = FFI.floatType + code TDDouble = FFI.doubleType + code TDFP128 = FFI.fP128Type + code TDVoid = FFI.voidType + code (TDInt _ n) = FFI.integerType (fromInteger n) + code (TDArray n a) = FFI.arrayType (code a) (fromInteger n) + code (TDVector n a) = FFI.vectorType (code a) (fromInteger n) + code (TDPtr a) = FFI.pointerType (code a) 0 + code (TDFunction va as b) = functionType va (code b) (map code as) + code TDLabel = FFI.labelType + code (TDStruct ts packed) = structType (map code ts) packed + code TDInvalidType = error "typeRef TDInvalidType" + +typeName :: (IsType a) => a -> String +typeName = code . typeDesc + where code TDFloat = "f32" + code TDDouble = "f64" + code TDFP128 = "f128" + code TDVoid = "void" + code (TDInt _ n) = "i" ++ show n + code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]" + code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">" + code (TDPtr a) = code a ++ "*" + code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")" + code TDLabel = "label" + code (TDStruct as packed) = (if packed then "<{" else "{") ++ + intercalate "," (map code as) ++ + (if packed then "}>" else "}") + code TDInvalidType = error "typeName TDInvalidType" + +intrinsicTypeName :: (IsType a) => a -> String +intrinsicTypeName = code . typeDesc + where code TDFloat = "f32" + code TDDouble = "f64" + code TDFP128 = "f128" + code (TDInt _ n) = "i" ++ show n + code (TDVector n a) = "v" ++ show n ++ code a + code _ = error "intrinsicTypeName: type not supported in intrinsics" + +typeDesc2 :: FFI.TypeRef -> IO TypeDesc +typeDesc2 t = do + tk <- FFI.getTypeKind t + case tk of + FFI.VoidTypeKind -> return TDVoid + FFI.FloatTypeKind -> return TDFloat + FFI.DoubleTypeKind -> return TDDouble + -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80" + FFI.FP128TypeKind -> return TDFP128 + -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128" + FFI.LabelTypeKind -> return TDLabel + FFI.IntegerTypeKind -> do + n <- FFI.getIntTypeWidth t + return $ TDInt False (fromIntegral n) + -- FIXME: FFI.FunctionTypeKind + -- FIXME: FFI.StructTypeKind -> return "(Struct ...)" + FFI.ArrayTypeKind -> do + n <- FFI.getArrayLength t + et <- FFI.getElementType t + etd <- typeDesc2 et + return $ TDArray (fromIntegral n) etd + FFI.PointerTypeKind -> do + et <- FFI.getElementType t + etd <- typeDesc2 et + return $ TDPtr etd + -- FIXME: FFI.OpaqueTypeKind -> return "Opaque" + FFI.VectorTypeKind -> do + n <- FFI.getVectorSize t + et <- FFI.getElementType t + etd <- typeDesc2 et + return $ TDVector (fromIntegral n) etd + -- FIXME: LLVMMetadataTypeKind, /**< Metadata */ + -- FIXME: LLVMX86_MMXTypeKind /**< X86 MMX */ + _ -> return TDInvalidType + +-- |Type descriptor, used to convey type information through the LLVM API. +data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer + | TDArray Integer TypeDesc | TDVector Integer TypeDesc + | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel + | TDStruct [TypeDesc] Bool | TDInvalidType + deriving (Eq, Ord, Show, Typeable) + +-- XXX isFloating and typeName could be extracted from typeRef +-- Usage: +-- superclass of IsConst +-- add, sub, mul, neg context +-- used to get type name to call intrinsic +-- |Arithmetic types, i.e., integral and floating types. +class IsFirstClass a => IsArithmetic a 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 +-- used to find signedness in Arithmetic +-- |Integral types. +class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where + type Signed a :: * + +-- Usage: +-- icmp +-- |Integral or pointer type. +class IsIntegerOrPointer a + +isSigned :: (IsInteger a) => a -> Bool +isSigned = is . typeDesc + where is (TDInt s _) = s + is (TDVector _ a) = is a + is _ = error "isSigned got impossible input" + +-- Usage: +-- constF +-- many instructions +-- |Floating types. +class IsArithmetic a => IsFloating a + +isFloating :: (IsArithmetic a) => a -> Bool +isFloating = is . typeDesc + where is TDFloat = True + is TDDouble = True + is TDFP128 = True + is (TDVector _ a) = is a + is _ = False + +-- Usage: +-- Precondition for Vector +-- |Primitive types. +-- class (IsType a) => IsPrimitive a +class (IsType a, NumberOfElements a ~ D1) => IsPrimitive a + +-- |Number of elements for instructions that handle both primitive and vector types +class (IsType a) => IsScalarOrVector a where + type NumberOfElements a :: * + + +-- Usage: +-- Precondition for function args and result. +-- Used by some instructions, like ret and phi. +-- XXX IsSized as precondition? +-- |First class types, i.e., the types that can be passed as arguments, etc. +class IsType a => IsFirstClass a + +-- Usage: +-- Context for Array being a type +-- thus, allocation instructions +-- |Types with a fixed size. +class (IsType a, PositiveT (SizeOf a)) => IsSized a where + type SizeOf a :: * + +sizeOf :: TypeDesc -> Integer +sizeOf TDFloat = 32 +sizeOf TDDouble = 64 +sizeOf TDFP128 = 128 +sizeOf (TDInt _ bits) = bits +sizeOf (TDArray n typ) = n * sizeOf typ +sizeOf (TDVector n typ) = n * sizeOf typ +sizeOf (TDStruct ts _packed) = sum (map sizeOf ts) +sizeOf _ = error "type has no size" + +-- |Function type. +class (IsType a) => IsFunction a where + funcType :: [TypeDesc] -> a -> TypeDesc + +-- Only make instances for types that make sense in Haskell +-- (i.e., some floating types are excluded). + +-- Floating point types. +instance IsType Float where typeDesc _ = TDFloat +instance IsType Double where typeDesc _ = TDDouble +instance IsType FP128 where typeDesc _ = TDFP128 + +-- Void type +instance IsType () where typeDesc _ = TDVoid + +-- Label type +instance IsType Label where typeDesc _ = TDLabel + +-- Variable size integer types +instance (PositiveT n) => IsType (IntN n) + where typeDesc _ = TDInt True (fromIntegerT (undefined :: n)) + +instance (PositiveT n) => IsType (WordN n) + where typeDesc _ = TDInt False (fromIntegerT (undefined :: n)) + +-- Fixed size integer types. +instance IsType Bool where typeDesc _ = TDInt False 1 +instance IsType Word8 where typeDesc _ = TDInt False 8 +instance IsType Word16 where typeDesc _ = TDInt False 16 +instance IsType Word32 where typeDesc _ = TDInt False 32 +instance IsType Word64 where typeDesc _ = TDInt False 64 +instance IsType Int8 where typeDesc _ = TDInt True 8 +instance IsType Int16 where typeDesc _ = TDInt True 16 +instance IsType Int32 where typeDesc _ = TDInt True 32 +instance IsType Int64 where typeDesc _ = TDInt True 64 + +-- Sequence types +instance (NaturalT n, IsSized a) => IsType (Array n a) + where typeDesc _ = TDArray (fromIntegerT (undefined :: n)) + (typeDesc (undefined :: a)) +instance (PositiveT n, IsPrimitive a) => IsType (Vector n a) + where typeDesc _ = TDVector (fromIntegerT (undefined :: n)) + (typeDesc (undefined :: a)) + +-- Pointer type. +instance (IsType a) => IsType (Ptr a) where + typeDesc _ = TDPtr (typeDesc (undefined :: a)) + +instance IsType (StablePtr a) where + typeDesc _ = TDPtr (typeDesc (undefined :: Int8)) +{- + typeDesc _ = TDPtr TDVoid + +List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed. +-} + + +-- Functions. +instance (IsFirstClass a, IsFunction b) => IsType (a->b) where + typeDesc = funcType [] + +-- Function base type, always IO. +instance (IsFirstClass a) => IsType (IO a) where + typeDesc = funcType [] + +-- Struct types, basically a list of component types. +instance (StructFields a) => IsType (Struct a) where + typeDesc ~(Struct a) = TDStruct (fieldTypes a) False + +instance (StructFields a) => IsType (PackedStruct a) where + typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True + +-- Use a nested tuples for struct fields. +class StructFields as where + fieldTypes :: as -> [TypeDesc] + +instance (IsSized a, StructFields as) => StructFields (a :& as) where + fieldTypes ~(a, as) = typeDesc a : fieldTypes as +instance StructFields () where + fieldTypes _ = [] + +-- An alias for pairs to make structs look nicer +infixr :& +type (:&) a as = (a, as) +infixr & +(&) :: a -> as -> a :& as +a & as = (a, as) + +--- Instances to classify types +instance IsArithmetic Float where arithmeticType = FloatingType +instance IsArithmetic Double where arithmeticType = FloatingType +instance IsArithmetic FP128 where arithmeticType = FloatingType +instance (PositiveT n) => IsArithmetic (IntN n) where arithmeticType = IntegerType +instance (PositiveT 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 (PositiveT n, IsPrimitive a, IsArithmetic a) => + IsArithmetic (Vector n a) where + arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType + +instance IsFloating Float +instance IsFloating Double +instance IsFloating FP128 +instance (PositiveT n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a) + +data NotANumber + +instance (PositiveT n) => IsInteger (IntN n) where type Signed (IntN n) = True +instance (PositiveT n) => IsInteger (WordN n) where type Signed (WordN n) = False +instance IsInteger Bool where type Signed Bool = NotANumber +instance IsInteger Int8 where type Signed Int8 = True +instance IsInteger Int16 where type Signed Int16 = True +instance IsInteger Int32 where type Signed Int32 = True +instance IsInteger Int64 where type Signed Int64 = True +instance IsInteger Word8 where type Signed Word8 = False +instance IsInteger Word16 where type Signed Word16 = False +instance IsInteger Word32 where type Signed Word32 = False +instance IsInteger Word64 where type Signed Word64 = False +instance (PositiveT n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a) + where type Signed (Vector n a) = Signed a + +instance (PositiveT n) => IsIntegerOrPointer (IntN n) +instance (PositiveT n) => IsIntegerOrPointer (WordN n) +instance IsIntegerOrPointer Bool +instance IsIntegerOrPointer Int8 +instance IsIntegerOrPointer Int16 +instance IsIntegerOrPointer Int32 +instance IsIntegerOrPointer Int64 +instance IsIntegerOrPointer Word8 +instance IsIntegerOrPointer Word16 +instance IsIntegerOrPointer Word32 +instance IsIntegerOrPointer Word64 +instance (PositiveT n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a) +instance (IsType a) => IsIntegerOrPointer (Ptr a) + +instance IsFirstClass Float +instance IsFirstClass Double +instance IsFirstClass FP128 +instance (PositiveT n) => IsFirstClass (IntN n) +instance (PositiveT n) => IsFirstClass (WordN n) +instance IsFirstClass Bool +instance IsFirstClass Int8 +instance IsFirstClass Int16 +instance IsFirstClass Int32 +instance IsFirstClass Int64 +instance IsFirstClass Word8 +instance IsFirstClass Word16 +instance IsFirstClass Word32 +instance IsFirstClass Word64 +instance (PositiveT n, IsPrimitive a) => IsFirstClass (Vector n a) +instance (NaturalT n, IsSized a) => IsFirstClass (Array n a) +instance (IsType a) => IsFirstClass (Ptr a) +instance IsFirstClass (StablePtr a) +instance IsFirstClass Label +instance IsFirstClass () -- XXX This isn't right, but () can be returned +instance (StructFields as) => IsFirstClass (Struct as) + +instance (PositiveT n) => IsSized (IntN n) where type SizeOf (IntN n) = n +instance (PositiveT n) => IsSized (WordN n) where type SizeOf (WordN n) = n +instance IsSized Float where type SizeOf Float = D32 +instance IsSized Double where type SizeOf Double = D64 +instance IsSized FP128 where type SizeOf FP128 = D128 +instance IsSized Bool where type SizeOf Bool = D1 +instance IsSized Int8 where type SizeOf Int8 = D8 +instance IsSized Int16 where type SizeOf Int16 = D16 +instance IsSized Int32 where type SizeOf Int32 = D32 +instance IsSized Int64 where type SizeOf Int64 = D64 +instance IsSized Word8 where type SizeOf Word8 = D8 +instance IsSized Word16 where type SizeOf Word16 = D16 +instance IsSized Word32 where type SizeOf Word32 = D32 +instance IsSized Word64 where type SizeOf Word64 = D64 +instance (NaturalT n, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Array n a) where + type SizeOf (Array n a) = n :*: SizeOf a +instance (PositiveT n, IsPrimitive a, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Vector n a) where + type SizeOf (Vector n a) = n :*: SizeOf a +instance (IsType a) => IsSized (Ptr a) where type SizeOf (Ptr a) = PtrSize +instance IsSized (StablePtr a) where type SizeOf (StablePtr a) = PtrSize +-- instance IsSized Label PtrSize -- labels are not quite first classed +-- We cannot compute the sizes statically :( +instance (StructFields as) => IsSized (Struct as) where + type SizeOf (Struct as) = UnknownSize +instance (StructFields as) => IsSized (PackedStruct as) where + type SizeOf (PackedStruct as) = UnknownSize + +type UnknownSize = D99 -- XXX this is wrong! + +#if WORD_SIZE_IN_BITS == 32 +type PtrSize = D32 +#elif WORD_SIZE_IN_BITS == 64 +type PtrSize = D64 +#else +#error cannot determine type of PtrSize +#endif + +instance IsPrimitive Float +instance IsPrimitive Double +instance IsPrimitive FP128 +instance (PositiveT n) => IsPrimitive (IntN n) +instance (PositiveT n) => IsPrimitive (WordN n) +instance IsPrimitive Bool +instance IsPrimitive Int8 +instance IsPrimitive Int16 +instance IsPrimitive Int32 +instance IsPrimitive Int64 +instance IsPrimitive Word8 +instance IsPrimitive Word16 +instance IsPrimitive Word32 +instance IsPrimitive Word64 +instance IsPrimitive Label +instance IsPrimitive () + + +instance (PositiveT n) => + IsScalarOrVector (IntN n) where type NumberOfElements (IntN n) = D1 +instance (PositiveT n) => + IsScalarOrVector (WordN n) where type NumberOfElements (WordN n) = D1 +instance IsScalarOrVector Float where type NumberOfElements Float = D1 +instance IsScalarOrVector Double where type NumberOfElements Double = D1 +instance IsScalarOrVector FP128 where type NumberOfElements FP128 = D1 +instance IsScalarOrVector Bool where type NumberOfElements Bool = D1 +instance IsScalarOrVector Int8 where type NumberOfElements Int8 = D1 +instance IsScalarOrVector Int16 where type NumberOfElements Int16 = D1 +instance IsScalarOrVector Int32 where type NumberOfElements Int32 = D1 +instance IsScalarOrVector Int64 where type NumberOfElements Int64 = D1 +instance IsScalarOrVector Word8 where type NumberOfElements Word8 = D1 +instance IsScalarOrVector Word16 where type NumberOfElements Word16 = D1 +instance IsScalarOrVector Word32 where type NumberOfElements Word32 = D1 +instance IsScalarOrVector Word64 where type NumberOfElements Word64 = D1 +instance IsScalarOrVector Label where type NumberOfElements Label = D1 +instance IsScalarOrVector () where type NumberOfElements () = D1 + +instance (PositiveT n, IsPrimitive a) => + IsScalarOrVector (Vector n a) where + type NumberOfElements (Vector n a) = n + + +-- Functions. +instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where + funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b) +instance (IsFirstClass a) => IsFunction (IO a) where + funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a)) +instance (IsFirstClass a) => IsFunction (VarArgs a) where + funcType ts _ = TDFunction True (reverse ts) (typeDesc (undefined :: a)) + +-- |The 'VarArgs' type is a placeholder for the real 'IO' type that +-- can be obtained with 'castVarArgs'. +data VarArgs a + deriving (Typeable) +instance IsType (VarArgs a) where + typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly" + +-- |Define what vararg types are permissible. +class CastVarArgs a b +instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c) +instance CastVarArgs (VarArgs a) (IO a) +instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c) + + + + +-- XXX Structures not implemented. Tuples is probably an easy way. + diff --git a/src/LLVM/Core/Util.hs b/src/LLVM/Core/Util.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Util.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.Core.Util( + -- * Module handling + Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile, + getModuleValues, getFunctions, getGlobalVariables, valueHasType, + -- * Module provider handling + ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule, + -- * Pass manager handling + PassManager(..), withPassManager, createPassManager, createFunctionPassManager, + runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager, + -- * Instruction builder + Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock, + -- * Basic blocks + BasicBlock, + appendBasicBlock, getBasicBlocks, + -- * Functions + Function, + addFunction, getParam, getParams, + -- * Structs + structType, + -- * Globals + addGlobal, + constString, constStringNul, constVector, constArray, constStruct, + -- * Instructions + makeCall, makeInvoke, + makeCallWithCc, makeInvokeWithCc, + withValue, getInstructions, getOperands, + -- * Uses and Users + hasUsers, getUsers, getUses, getUser, isChildOf, getDep, + -- * Misc + CString, withArrayLen, + withEmptyCString, + functionType, buildEmptyPhi, addPhiIns, + showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant, + -- * Transformation passes + addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, + addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, + addTargetData + ) where + +import qualified LLVM.FFI.Core as FFI +import qualified LLVM.FFI.Target as FFI +import qualified LLVM.FFI.BitWriter as FFI +import qualified LLVM.FFI.BitReader as FFI +import qualified LLVM.FFI.Transforms.Scalar as FFI + +import Foreign.C.String (withCString, withCStringLen, CString, peekCString) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Utils (fromBool) +import System.IO.Unsafe (unsafePerformIO) + +import Data.Typeable (Typeable) +import Data.List (intercalate) +import Control.Monad (liftM, filterM, when) + + +type Type = FFI.TypeRef + +-- unsafePerformIO just to wrap the non-effecting withArrayLen call +functionType :: Bool -> Type -> [Type] -> Type +functionType varargs retType paramTypes = unsafePerformIO $ + withArrayLen paramTypes $ \ len ptr -> + return $ FFI.functionType retType ptr (fromIntegral len) + (fromBool varargs) + +-- unsafePerformIO just to wrap the non-effecting withArrayLen call +structType :: [Type] -> Bool -> Type +structType types packed = unsafePerformIO $ + withArrayLen types $ \ len ptr -> + return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0) + +-------------------------------------- +-- Handle modules + +-- Don't use a finalizer for the module, but instead provide an +-- explicit destructor. This is because handing a module to +-- a module provider changes ownership of the module to the provider, +-- and we don't want to free it by mistake. + +-- | Type of top level modules. +newtype Module = Module { + fromModule :: FFI.ModuleRef + } + deriving (Show, Typeable) + +withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a +withModule modul f = f (fromModule modul) + +createModule :: String -> IO Module +createModule name = + withCString name $ \ namePtr -> do + liftM Module $ FFI.moduleCreateWithName namePtr + +-- | Free all storage related to a module. *Note*, this is a dangerous call, since referring +-- to the module after this call is an error. The reason for the explicit call to free +-- the module instead of an automatic lifetime management is that modules have a +-- somewhat complicated ownership. Handing a module to a module provider changes +-- the ownership of the module, and the module provider will free the module when necessary. +destroyModule :: Module -> IO () +destroyModule = FFI.disposeModule . fromModule + +-- |Write a module to a file. +writeBitcodeToFile :: String -> Module -> IO () +writeBitcodeToFile name mdl = + withCString name $ \ namePtr -> + withModule mdl $ \ mdlPtr -> do + rc <- FFI.writeBitcodeToFile mdlPtr namePtr + when (rc /= 0) $ + ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc + return () + +-- |Read a module from a file. +readBitcodeFromFile :: String -> IO Module +readBitcodeFromFile name = + withCString name $ \ namePtr -> + alloca $ \ bufPtr -> + alloca $ \ modPtr -> + alloca $ \ errStr -> do + rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr + if rrc /= 0 then do + msg <- peek errStr >>= peekCString + ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg + else do + buf <- peek bufPtr + prc <- FFI.parseBitcode buf modPtr errStr + if prc /= 0 then do + msg <- peek errStr >>= peekCString + ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg + else do + ptr <- peek modPtr + return $ Module ptr +{- + liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr +-} + +getModuleValues :: Module -> IO [(String, Value)] +getModuleValues mdl = do + fs <- getFunctions mdl + gs <- getGlobalVariables mdl + return (fs ++ gs) + +getFunctions :: Module -> IO [(String, Value)] +getFunctions mdl = getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl >>= filterM isIntrinsic >>= annotateValueList + +getGlobalVariables :: Module -> IO [(String, Value)] +getGlobalVariables mdl = getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl >>= annotateValueList + +-- This is safe because we just ask for the type of a value. +valueHasType :: Value -> Type -> Bool +valueHasType v t = unsafePerformIO $ do + vt <- FFI.typeOf v + return $ vt == t -- LLVM uses hash consing for types, so pointer equality works. + +showTypeOf :: Value -> IO String +showTypeOf v = FFI.typeOf v >>= showType' + +showType' :: Type -> IO String +showType' p = do + pk <- FFI.getTypeKind p + case pk of + FFI.VoidTypeKind -> return "()" + FFI.FloatTypeKind -> return "Float" + FFI.DoubleTypeKind -> return "Double" + FFI.X86_FP80TypeKind -> return "X86_FP80" + FFI.FP128TypeKind -> return "FP128" + FFI.PPC_FP128TypeKind -> return "PPC_FP128" + FFI.LabelTypeKind -> return "Label" + FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")" + FFI.FunctionTypeKind -> do + r <- FFI.getReturnType p + c <- FFI.countParamTypes p + let n = fromIntegral c + as <- allocaArray n $ \ args -> do + FFI.getParamTypes p args + peekArray n args + ts <- mapM showType' (as ++ [r]) + return $ "(" ++ intercalate " -> " ts ++ ")" + FFI.StructTypeKind -> return "(Struct ...)" + FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")" + FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")" + FFI.OpaqueTypeKind -> return "Opaque" + FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")" + +-------------------------------------- +-- Handle module providers + +-- | A module provider is used by the code generator to get access to a module. +newtype ModuleProvider = ModuleProvider { + fromModuleProvider :: ForeignPtr FFI.ModuleProvider + } + deriving (Show, Typeable) + +withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a) + -> IO a +withModuleProvider = withForeignPtr . fromModuleProvider + +-- | Turn a module into a module provider. +createModuleProviderForExistingModule :: Module -> IO ModuleProvider +createModuleProviderForExistingModule modul = + withModule modul $ \modulPtr -> do + ptr <- FFI.createModuleProviderForExistingModule modulPtr + -- MPs given to the EE get taken over, so we should not GC them. + liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr + + +-------------------------------------- +-- Handle instruction builders + +newtype Builder = Builder { + fromBuilder :: ForeignPtr FFI.Builder + } + deriving (Show, Typeable) + +withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a +withBuilder = withForeignPtr . fromBuilder + +createBuilder :: IO Builder +createBuilder = do + ptr <- FFI.createBuilder + liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr + +positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO () +positionAtEnd bld bblk = + withBuilder bld $ \ bldPtr -> + FFI.positionAtEnd bldPtr bblk + +getInsertBlock :: Builder -> IO FFI.BasicBlockRef +getInsertBlock bld = + withBuilder bld $ \ bldPtr -> + FFI.getInsertBlock bldPtr + +-------------------------------------- + +type BasicBlock = FFI.BasicBlockRef + +appendBasicBlock :: Function -> String -> IO BasicBlock +appendBasicBlock func name = + withCString name $ \ namePtr -> + FFI.appendBasicBlock func namePtr + +getBasicBlocks :: Value -> IO [(String, Value)] +getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v >>= annotateValueList + +-------------------------------------- + +type Function = FFI.ValueRef + +addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function +addFunction modul linkage name typ = + withModule modul $ \ modulPtr -> + withCString name $ \ namePtr -> do + f <- FFI.addFunction modulPtr namePtr typ + FFI.setLinkage f (FFI.fromLinkage linkage) + return f + +getParam :: Function -> Int -> Value +getParam f = FFI.getParam f . fromIntegral + +getParams :: Value -> IO [(String, Value)] +getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList + +-------------------------------------- + +addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value +addGlobal modul linkage name typ = + withModule modul $ \ modulPtr -> + withCString name $ \ namePtr -> do + v <- FFI.addGlobal modulPtr typ namePtr + FFI.setLinkage v (FFI.fromLinkage linkage) + return v + +-- unsafePerformIO is safe because it's only used for the withCStringLen conversion +constStringInternal :: Bool -> String -> Value +constStringInternal nulTerm s = unsafePerformIO $ + withCStringLen s $ \(sPtr, sLen) -> + return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm)) + +constString :: String -> Value +constString = constStringInternal False + +constStringNul :: String -> Value +constStringNul = constStringInternal True + +-------------------------------------- + +type Value = FFI.ValueRef + +withValue :: Value -> (Value -> IO a) -> IO a +withValue v f = f v + +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 +{- + print "makeCall" + FFI.dumpValue func + mapM_ FFI.dumpValue args + print "----------------------" +-} + withArrayLen args $ \ argLen argPtr -> + withEmptyCString $ \cstr -> do + i <- FFI.buildCall bldPtr func argPtr + (fromIntegral argLen) cstr + FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) + return i + +makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> + [Value] -> IO Value +makeInvoke = makeInvokeWithCc FFI.C + +makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> + [Value] -> IO Value +makeInvokeWithCc cc norm expt func bldPtr args = + withArrayLen args $ \ argLen argPtr -> + withEmptyCString $ \cstr -> do + i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr + FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) + return i + +getInstructions :: Value -> IO [(String, Value)] +getInstructions bb = getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList + +getOperands :: Value -> IO [(String, Value)] +getOperands ii = geto ii >>= annotateValueList + where geto i = do + num <- FFI.getNumOperands i + let oloop instr number total = if number >= total then return [] else do + o <- FFI.getOperand instr number + os <- oloop instr (number + 1) total + return (o : os) + oloop i 0 num + +-------------------------------------- + +buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value +buildEmptyPhi bldPtr typ = do + withEmptyCString $ FFI.buildPhi bldPtr typ + +withEmptyCString :: (CString -> IO a) -> IO a +withEmptyCString = withCString "" + +addPhiIns :: Value -> [(Value, BasicBlock)] -> IO () +addPhiIns inst incoming = do + let (vals, bblks) = unzip incoming + withArrayLen vals $ \ count valPtr -> + withArray bblks $ \ bblkPtr -> + FFI.addIncoming inst valPtr bblkPtr (fromIntegral count) + +-------------------------------------- + +-- | Manage compile passes. +newtype PassManager = PassManager { + fromPassManager :: ForeignPtr FFI.PassManager + } + deriving (Show, Typeable) + +withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a) + -> IO a +withPassManager = withForeignPtr . fromPassManager + +-- | Create a pass manager. +createPassManager :: IO PassManager +createPassManager = do + ptr <- FFI.createPassManager + liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr + +-- | Create a pass manager for a module. +createFunctionPassManager :: ModuleProvider -> IO PassManager +createFunctionPassManager modul = + withModuleProvider modul $ \modulPtr -> do + ptr <- FFI.createFunctionPassManager modulPtr + liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr + +-- | Add a control flow graph simplification pass to the manager. +addCFGSimplificationPass :: PassManager -> IO () +addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass + +-- | Add a constant propagation pass to the manager. +addConstantPropagationPass :: PassManager -> IO () +addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass + +addDemoteMemoryToRegisterPass :: PassManager -> IO () +addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass + +-- | Add a global value numbering pass to the manager. +addGVNPass :: PassManager -> IO () +addGVNPass pm = withPassManager pm FFI.addGVNPass + +addInstructionCombiningPass :: PassManager -> IO () +addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass + +addPromoteMemoryToRegisterPass :: PassManager -> IO () +addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass + +addReassociatePass :: PassManager -> IO () +addReassociatePass pm = withPassManager pm FFI.addReassociatePass + +addTargetData :: FFI.TargetDataRef -> PassManager -> IO () +addTargetData td pm = withPassManager pm $ FFI.addTargetData td + +runFunctionPassManager :: PassManager -> Function -> IO Int +runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn + +initializeFunctionPassManager :: PassManager -> IO Int +initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager + +finalizeFunctionPassManager :: PassManager -> IO Int +finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager + +-------------------------------------- + +-- The unsafePerformIO is just for the non-effecting withArrayLen +constVector :: Int -> [Value] -> Value +constVector n xs = unsafePerformIO $ do + 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) + withArrayLen xs' $ \ len ptr -> + return $ FFI.constArray t ptr (fromIntegral len) + +-- The unsafePerformIO is just for the non-effecting withArrayLen +constStruct :: [Value] -> Bool -> Value +constStruct xs packed = unsafePerformIO $ do + withArrayLen xs $ \ len ptr -> + return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0) + +-------------------------------------- + +getValueNameU :: Value -> IO String +getValueNameU a = do + -- sometimes void values need explicit names too + cs <- FFI.getValueName a + str <- peekCString cs + if str == "" then return (show a) else return str + +getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a)) + -> (Ptr a -> IO (Ptr a)) -> t1 -> t +getObjList withF firstF nextF obj = do + withF obj $ \ objPtr -> do + ofst <- firstF objPtr + let oloop p = if p == nullPtr then return [] else do + n <- nextF p + ps <- oloop n + return (p : ps) + oloop ofst + +annotateValueList :: [Value] -> IO [(String, Value)] +annotateValueList vs = do + names <- mapM getValueNameU vs + return $ zip names vs + +isConstant :: Value -> IO Bool +isConstant v = do + isC <- FFI.isConstant v + if isC == 0 then return False else return True + +isIntrinsic :: Value -> IO Bool +isIntrinsic v = do + if FFI.getIntrinsicID v == 0 then return True else return False + +-------------------------------------- + +type Use = FFI.UseRef + +hasUsers :: Value -> IO Bool +hasUsers v = do + nU <- FFI.getNumUses v + if nU == 0 then return False else return True + +getUses :: Value -> IO [Use] +getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse + +getUsers :: [Use] -> IO [(String, Value)] +getUsers us = mapM FFI.getUser us >>= annotateValueList + +getUser :: Use -> IO Value +getUser = FFI.getUser + +isChildOf :: BasicBlock -> Value -> IO Bool +isChildOf bb v = do + bb2 <- FFI.getInstructionParent v + if bb == bb2 then return True else return False + +getDep :: Use -> IO (String, String) +getDep u = do + producer <- FFI.getUsedValue u >>= getValueNameU + consumer <- FFI.getUser u >>= getValueNameU + return (producer, consumer) diff --git a/src/LLVM/Core/Vector.hs b/src/LLVM/Core/Vector.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Core/Vector.hs @@ -0,0 +1,156 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Core.Vector (MkVector(..), vector, ) where + +import LLVM.Core.Type +import LLVM.Core.Data +import LLVM.ExecutionEngine.Target + +import Types.Data.Num + +import Foreign.Ptr (castPtr) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Array (peekArray, pokeArray) + +import Data.Function (on) +import System.IO.Unsafe (unsafePerformIO) + + +-- XXX Should these really be here? +class (PositiveT n, IsPrimitive a) => MkVector n a where + type Tuple n a :: * + toVector :: Tuple n a -> Vector n a + fromVector :: Vector n a -> Tuple n a + +{- +instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where + toVector a = Vector [a] +-} + +instance (IsPrimitive a) => MkVector D2 a where + type Tuple D2 a = (a,a) + toVector (a1, a2) = Vector [a1, a2] + fromVector (Vector [a1, a2]) = (a1, a2) + fromVector _ = error "fromVector: impossible" + +instance (IsPrimitive a) => MkVector D4 a where + type Tuple D4 a = (a,a,a,a) + toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4] + fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4) + fromVector _ = error "fromVector: impossible" + +instance (IsPrimitive a) => MkVector D8 a where + type Tuple D8 a = (a,a,a,a,a,a,a,a) + toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8] + fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8) + fromVector _ = error "fromVector: impossible" + +instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where + sizeOf a = storeSizeOfType ourTargetData (typeRef a) + alignment a = aBIAlignmentOfType ourTargetData (typeRef a) + peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a) + poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs + +-- XXX The JITer target data. This isn't really right. +ourTargetData :: TargetData +ourTargetData = unsafePerformIO getTargetData + +-------------------------------------- + +unVector :: Vector n a -> [a] +unVector (Vector xs) = xs + +-- |Make a constant vector. Replicates or truncates the list to get length /n/. +-- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'. +vector :: forall a n. (PositiveT n) => [a] -> Vector n a +vector xs = + Vector (take (fromIntegerT (undefined :: n)) (cycle xs)) + +replic :: forall a n. (PositiveT n) => a -> Vector n a +replic = Vector . replicate (fromIntegerT (undefined :: n)) + + +binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c +binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys) + +unop :: (a -> b) -> Vector n a -> Vector n b +unop op = Vector . map op . unVector + +instance (Eq a, PositiveT n) => Eq (Vector n a) where + (==) = (==) `on` unVector + +instance (Ord a, PositiveT n) => Ord (Vector n a) where + compare = compare `on` unVector + +instance (Num a, PositiveT n) => Num (Vector n a) where + (+) = binop (+) + (-) = binop (-) + (*) = binop (*) + negate = unop negate + abs = unop abs + signum = unop signum + fromInteger = replic . fromInteger + +instance (Enum a, PositiveT n) => Enum (Vector n a) where + succ = unop succ + pred = unop pred + fromEnum = error "Vector fromEnum" + toEnum = replic . toEnum + +instance (Real a, PositiveT n) => Real (Vector n a) where + toRational = error "Vector toRational" + +instance (Integral a, PositiveT n) => Integral (Vector n a) where + quot = binop quot + rem = binop rem + div = binop div + mod = binop mod + quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys + divMod (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod xs ys + toInteger = error "Vector toInteger" + +instance (Fractional a, PositiveT n) => Fractional (Vector n a) where + (/) = binop (/) + fromRational = replic . fromRational + +instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where + properFraction = error "Vector properFraction" + +instance (Floating a, PositiveT n) => Floating (Vector n a) where + pi = replic pi + sqrt = unop sqrt + log = unop log + logBase = binop logBase + (**) = binop (**) + exp = unop exp + sin = unop sin + cos = unop cos + tan = unop tan + asin = unop asin + acos = unop acos + atan = unop atan + sinh = unop sinh + cosh = unop cosh + tanh = unop tanh + asinh = unop asinh + acosh = unop acosh + atanh = unop atanh + +instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where + floatRadix = floatRadix . head . unVector + floatDigits = floatDigits . head . unVector + floatRange = floatRange . head . unVector + decodeFloat = error "Vector decodeFloat" + encodeFloat = error "Vector encodeFloat" + exponent _ = 0 + scaleFloat 0 x = x + scaleFloat _ _ = error "Vector scaleFloat" + isNaN = error "Vector isNaN" + isInfinite = error "Vector isInfinite" + isDenormalized = error "Vector isDenormalized" + isNegativeZero = error "Vector isNegativeZero" + isIEEE = isIEEE . head . unVector diff --git a/src/LLVM/ExecutionEngine.hs b/src/LLVM/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/ExecutionEngine.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TypeFamilies #-} + -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. +module LLVM.ExecutionEngine( + -- * Execution engine + EngineAccess, + runEngineAccess, + addModuleProvider, + addModule, +{- + runStaticConstructors, + runStaticDestructors, +-} + getPointerToFunction, + addFunctionValue, + addGlobalMappings, + getFreePointers, FreePointers, + -- * Translation + Translatable, Generic, + generateFunction, + -- * Unsafe type conversion + Unsafe, + unsafeRemoveIO, + -- * Simplified interface. + simpleFunction, + unsafeGenerateFunction, + -- * Target information + module LLVM.ExecutionEngine.Target + ) where +import System.IO.Unsafe (unsafePerformIO) + +import LLVM.ExecutionEngine.Engine +import LLVM.ExecutionEngine.Target +import LLVM.Core.CodeGen (Value(..)) +import LLVM.Core +--import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) + +import LLVM.FFI.Core (ValueRef) + +import Control.Monad (liftM2, ) + + +-- |Class of LLVM function types that can be translated to the corresponding +-- Haskell type. +class Translatable f where + translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f + +instance (Generic a, Translatable b) => Translatable (a -> b) where + translate run args f = \ arg -> translate run (toGeneric arg : args) f + +instance (Generic a) => Translatable (IO a) where + translate run args f = fmap fromGeneric $ run f $ reverse args + +-- |Generate a Haskell function from an LLVM function. +-- +-- Note that the function is compiled for every call (Just-In-Time compilation). +-- If you want to compile the function once and call it a lot of times +-- then you should better use 'getPointerToFunction'. +generateFunction :: (Translatable f) => + Value (Ptr f) -> EngineAccess f +generateFunction (Value f) = do + run <- getRunFunction + return $ translate run [] f + +class Unsafe a where + type RemoveIO a :: * + unsafeRemoveIO :: a -> RemoveIO a -- ^Remove the IO from a function return type. This is unsafe in general. + +instance (Unsafe b) => Unsafe (a->b) where + type RemoveIO (a -> b) = a -> RemoveIO b + unsafeRemoveIO f = unsafeRemoveIO . f + +instance Unsafe (IO a) where + type RemoveIO (IO a) = a + unsafeRemoveIO = unsafePerformIO + +-- |Translate a function to Haskell code. This is a simplified interface to +-- the execution engine and module mechanism. +-- It is based on 'generateFunction', so see there for limitations. +simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f +simpleFunction bld = do + m <- newModule + (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) + prov <- createModuleProviderForExistingModule m + runEngineAccess $ do + addModuleProvider prov + addGlobalMappings mappings + generateFunction func + +{- + m <- newModule + func <- defineModule m bld +-- dumpValue func + prov <- createModuleProviderForExistingModule m + ee <- createExecutionEngine prov + pm <- createFunctionPassManager prov + td <- getExecutionEngineTargetData ee + addTargetData td pm + addInstructionCombiningPass pm + addReassociatePass pm + addGVNPass pm + addCFGSimplificationPass pm + addPromoteMemoryToRegisterPass pm + initializeFunctionPassManager pm +-- print ("rc1", rc1) + runFunctionPassManager pm (unValue func) +-- print ("rc2", rc2) + finalizeFunctionPassManager pm +-- print ("rc3", rc3) +-- dumpValue func + return $ generateFunction ee func +-} + +-- | Combine 'simpleFunction' and 'unsafeRemoveIO'. +unsafeGenerateFunction :: (Unsafe t, Translatable t) => + CodeGenModule (Function t) -> RemoveIO t +unsafeGenerateFunction bld = unsafePerformIO $ do + fun <- simpleFunction bld + return $ unsafeRemoveIO fun diff --git a/src/LLVM/ExecutionEngine/Engine.hs b/src/LLVM/ExecutionEngine/Engine.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/ExecutionEngine/Engine.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.ExecutionEngine.Engine( + EngineAccess, + runEngineAccess, +{- + ExecutionEngine, +-} + createExecutionEngine, addModuleProvider, addModule, + {- runStaticConstructors, runStaticDestructors, -} + getExecutionEngineTargetData, + getPointerToFunction, + addFunctionValue, addGlobalMappings, + getFreePointers, FreePointers, + runFunction, getRunFunction, + GenericValue, Generic(..) + ) where + +import LLVM.Core.CodeGen (Value(..), Function) +import LLVM.Core.CodeGenMonad (GlobalMappings(..)) +import LLVM.Core.Util + (Module, ModuleProvider, withModuleProvider, + createModule, createModuleProviderForExistingModule) +import LLVM.Core.Type (IsFirstClass, typeRef) + +import qualified LLVM.FFI.ExecutionEngine as FFI +import qualified LLVM.FFI.Target as FFI +import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef) +import qualified LLVM.Core.Util as U + +import qualified Control.Monad.Trans.State as MS +import Control.Monad.Trans.State (StateT, runStateT, ) +import Control.Monad.IO.Class (MonadIO, liftIO, ) +import Control.Monad (liftM, ) +import Control.Applicative (Applicative, ) +import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar, ) + +import Data.Typeable +import Data.Int +import Data.Word + +import Foreign.Marshal.Alloc (alloca, free) +import Foreign.Marshal.Array (withArrayLen) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Marshal.Utils (fromBool) +import Foreign.C.String (peekCString) +import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr) +import Foreign.Storable (peek) +import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, ) +import System.IO.Unsafe (unsafePerformIO) + +{- +-- |The type of the JITer. +newtype ExecutionEngine = ExecutionEngine { + fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine + } + +withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a) + -> IO a +withExecutionEngine = withForeignPtr . fromExecutionEngine + +-- |Create an execution engine for a module provider. +-- Warning, do not call this function more than once. +createExecutionEngine :: ModuleProvider -> IO ExecutionEngine +createExecutionEngine prov = + withModuleProvider prov $ \provPtr -> + alloca $ \eePtr -> + alloca $ \errPtr -> do + ret <- FFI.createExecutionEngine eePtr provPtr errPtr + if ret == 1 + then do err <- peek errPtr + errStr <- peekCString err + free err + ioError . userError $ errStr + else do ptr <- peek eePtr + liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr + +addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO () +addModuleProvider ee prov = + withExecutionEngine ee $ \ eePtr -> + withModuleProvider prov $ \ provPtr -> + FFI.addModuleProvider eePtr provPtr + +runStaticConstructors :: ExecutionEngine -> IO () +runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors + +runStaticDestructors :: ExecutionEngine -> IO () +runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors + +getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef +getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData + +getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f) +getPointerToFunction ee (Value f) = + withExecutionEngine ee $ \ eePtr -> + FFI.getPointerToGlobal eePtr f +-} + +-- This global variable holds the one and only execution engine. +-- It may be missing, but it never dies. +-- XXX We could provide a destructor, what about functions obtained by runFunction? +{-# NOINLINE theEngine #-} +theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine)) +theEngine = unsafePerformIO $ newMVar Nothing + +createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine) +createExecutionEngine prov = + withModuleProvider prov $ \provPtr -> + alloca $ \eePtr -> + alloca $ \errPtr -> do + ret <- FFI.createExecutionEngine eePtr provPtr errPtr + if ret == 1 + then do + err <- peek errPtr + errStr <- peekCString err + free err + ioError . userError $ errStr + else + peek eePtr + +getTheEngine :: IO (Ptr FFI.ExecutionEngine) +getTheEngine = do + mee <- takeMVar theEngine + case mee of + Just ee -> do putMVar theEngine mee; return ee + Nothing -> do + m <- createModule "__empty__" + mp <- createModuleProviderForExistingModule m + ee <- createExecutionEngine mp + putMVar theEngine (Just ee) + return ee + +data EAState = EAState { + ea_engine :: Ptr FFI.ExecutionEngine, + ea_providers :: [ModuleProvider] + } + deriving (Show, Typeable) + +newtype EngineAccess a = EA (StateT EAState IO a) + deriving (Functor, Applicative, Monad, 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, +-- so access to it is wrapped in a monad. +runEngineAccess :: EngineAccess a -> IO a +runEngineAccess (EA body) = do + eePtr <- getTheEngine + let ea = EAState { ea_engine = eePtr, ea_providers = [] } + (a, _ea') <- runStateT body ea + -- XXX should remove module providers again + return a + +addModuleProvider :: ModuleProvider -> EngineAccess () +addModuleProvider prov = do + ea <- EA MS.get + EA $ MS.put ea{ ea_providers = prov : ea_providers ea } + liftIO $ withModuleProvider prov $ \ provPtr -> + FFI.addModuleProvider (ea_engine ea) provPtr + + +getEngine :: EngineAccess (Ptr FFI.ExecutionEngine) +getEngine = EA $ MS.gets ea_engine + +getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef +getExecutionEngineTargetData = do + eePtr <- getEngine + liftIO $ FFI.getExecutionEngineTargetData eePtr + +{- | +In contrast to 'generateFunction' this compiles a function once. +Thus it is faster for many calls to the same function. +See @examples\/Vector.hs@. + +If the function calls back into Haskell code, +you also have to set the function addresses +using 'addFunctionValue' or 'addGlobalMappings'. +-} +getPointerToFunction :: Function f -> EngineAccess (FunPtr f) +getPointerToFunction (Value f) = do + eePtr <- getEngine + liftIO $ FFI.getPointerToGlobal eePtr f + +{- | +Tell LLVM the address of an external function +if it cannot resolve a name automatically. +Alternatively you may declare the function +with 'staticFunction' instead of 'externFunction'. +-} +addFunctionValue :: Function f -> FunPtr f -> EngineAccess () +addFunctionValue (Value g) f = + addFunctionValueCore g (castFunPtrToPtr f) + +{- | +Pass a list of global mappings to LLVM +that can be obtained from 'LLVM.Core.getGlobalMappings'. +-} +addGlobalMappings :: GlobalMappings -> EngineAccess () +addGlobalMappings (GlobalMappings gms) = + mapM_ (uncurry addFunctionValueCore) gms + +addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess () +addFunctionValueCore g f = do + eePtr <- getEngine + liftIO $ FFI.addGlobalMapping eePtr g f + +addModule :: Module -> EngineAccess () +addModule m = do + mp <- liftIO $ createModuleProviderForExistingModule m + addModuleProvider mp + +-- | Get all the information needed to free a function. +-- Freeing code might have to be done from a (C) finalizer, so it has to done from C. +-- The function c_freeFunctionObject take these pointers as arguments and frees the function. +type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef) +getFreePointers :: Function f -> EngineAccess FreePointers +getFreePointers (Value f) = do + ea <- EA MS.get + liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp -> + return (ea_engine ea, mpp, f) + +-------------------------------------- + +newtype GenericValue = GenericValue { + fromGenericValue :: ForeignPtr FFI.GenericValue + } + +withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a +withGenericValue = withForeignPtr . fromGenericValue + +createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue +createGenericValueWith f = do + ptr <- f + liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr + +withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a +withAll ps a = go [] ps + where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs + go ptrs _ = withArrayLen (reverse ptrs) a + +runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue +runFunction func args = do + eePtr <- getEngine + liftIO $ withAll args $ \argLen argPtr -> + createGenericValueWith $ FFI.runFunction eePtr func + (fromIntegral argLen) argPtr +getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) +getRunFunction = do + eePtr <- getEngine + return $ \ func args -> + withAll args $ \argLen argPtr -> + createGenericValueWith $ FFI.runFunction eePtr func + (fromIntegral argLen) argPtr + +class Generic a where + toGeneric :: a -> GenericValue + fromGeneric :: GenericValue -> a + +instance Generic () where + toGeneric _ = error "toGeneric ()" + fromGeneric _ = () + +toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue +toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ + FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed) + +fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a +fromGenericInt signed val = unsafePerformIO $ + withGenericValue val $ \ref -> + return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed) + +--instance Generic Bool where +-- toGeneric = toGenericInt False . fromBool +-- fromGeneric = toBool . fromGenericInt False + +instance Generic Int8 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +instance Generic Int16 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +instance Generic Int32 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +{- +instance Generic Int where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True +-} + +instance Generic Int64 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +instance Generic Word8 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +instance Generic Word16 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +instance Generic Word32 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +instance Generic Word64 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue +toGenericReal val = unsafePerformIO $ createGenericValueWith $ + FFI.createGenericValueOfFloat (typeRef val) (realToFrac val) + +fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a +fromGenericReal val = unsafePerformIO $ + withGenericValue val $ \ ref -> + return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref + +instance Generic Float where + toGeneric = toGenericReal + fromGeneric = fromGenericReal + +instance Generic Double where + toGeneric = toGenericReal + fromGeneric = fromGenericReal + +instance Generic (Ptr a) where + toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer + fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer + +instance Generic (StablePtr a) where + toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr + fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer diff --git a/src/LLVM/ExecutionEngine/Target.hs b/src/LLVM/ExecutionEngine/Target.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/ExecutionEngine/Target.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where + +import LLVM.Core.Data (WordN) +import LLVM.ExecutionEngine.Engine + (runEngineAccess, getExecutionEngineTargetData) + +import qualified LLVM.FFI.Core as FFI +import qualified LLVM.FFI.Target as FFI + +import Types.Data.Num (PositiveT, reifyPositiveD) + +import Foreign.C.String (withCString) +import Data.Typeable (Typeable) +import Data.Maybe (fromMaybe) +import System.IO.Unsafe (unsafePerformIO) + + +type Type = FFI.TypeRef + +data TargetData = TargetData { + aBIAlignmentOfType :: Type -> Int, + aBISizeOfType :: Type -> Int, + littleEndian :: Bool, + callFrameAlignmentOfType :: Type -> Int, +-- elementAtOffset :: Type -> Word64 -> Int, + intPtrType :: Type, +-- offsetOfElements :: Int -> Word64, + pointerSize :: Int, +-- preferredAlignmentOfGlobal :: Value a -> Int, + preferredAlignmentOfType :: Type -> Int, + sizeOfTypeInBits :: Type -> Int, + storeSizeOfType :: Type -> Int + } + deriving (Typeable) + +withIntPtrType :: (forall n . (PositiveT n) => WordN n -> a) -> a +withIntPtrType f = + fromMaybe (error "withIntPtrType: pointer size must be non-negative") $ + reifyPositiveD (fromIntegral sz) (\ n -> f (g n)) + where g :: n -> WordN n + g _ = error "withIntPtrType: argument used" + sz = pointerSize $ unsafePerformIO getTargetData + +-- Gets the target data for the JIT target. +getEngineTargetDataRef :: IO FFI.TargetDataRef +getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData + +-- Normally the TargetDataRef never changes, so the operation +-- are really pure functions. +makeTargetData :: FFI.TargetDataRef -> TargetData +makeTargetData r = TargetData { + aBIAlignmentOfType = fromIntegral . FFI.aBIAlignmentOfType r, + aBISizeOfType = fromIntegral . FFI.aBISizeOfType r, + littleEndian = FFI.byteOrder r /= 0, + callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r, + intPtrType = FFI.intPtrType r, + pointerSize = fromIntegral $ FFI.pointerSize r, + preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r, + sizeOfTypeInBits = fromIntegral . FFI.sizeOfTypeInBits r, + storeSizeOfType = fromIntegral . FFI.storeSizeOfType r + } + +getTargetData :: IO TargetData +getTargetData = fmap makeTargetData getEngineTargetDataRef + +targetDataFromString :: String -> TargetData +targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData diff --git a/src/LLVM/Util/Arithmetic.hs b/src/LLVM/Util/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Arithmetic.hs @@ -0,0 +1,302 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Util.Arithmetic( + TValue, + (%==), (%/=), (%<), (%<=), (%>), (%>=), + (%&&), (%||), + (?), (??), + retrn, set, + ArithFunction, arithFunction, + ToArithFunction, toArithFunction, recursiveFunction, + CallIntrinsic, + ) where + +import qualified LLVM.Core as LLVM +import LLVM.Util.Loop (mapVector, mapVector2) +import LLVM.Core + +import qualified Types.Data.Num as TypeNum + +import Control.Monad (liftM2) + +-- |Synonym for @CodeGenFunction r (Value a)@. +type TValue r a = CodeGenFunction r (Value a) + + +infix 4 %==, %/=, %<, %<=, %>=, %> +-- |Comparison functions. +(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a) => TValue r a -> TValue r a -> TValue r (CmpResult a) +(%==) = 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 %|| +-- |Lazy and. +(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool +a %&& b = a ? (b, return (valueOf False)) +-- |Lazy or. +(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool +a %|| b = a ? (return (valueOf True), b) + +infix 0 ? +-- |Conditional, returns first element of the pair when condition is true, otherwise second. +(?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a +c ? (t, f) = do + lt <- newBasicBlock + lf <- newBasicBlock + lj <- newBasicBlock + c' <- c + condBr c' lt lf + defineBasicBlock lt + rt <- t + lt' <- getCurrentBasicBlock + br lj + defineBasicBlock lf + rf <- f + lf' <- getCurrentBasicBlock + br lj + defineBasicBlock lj + phi [(rt, lt'), (rf, lf')] + +infix 0 ?? +(??) :: (IsFirstClass a, CmpRet a) => TValue r (CmpResult a) -> (TValue r a, TValue r a) -> TValue r a +c ?? (t, f) = do + c' <- c + t' <- t + f' <- f + select c' t' f' + +-- | Return a value from an 'arithFunction'. +retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r () +retrn x = x >>= ret + +-- | Use @x <- set $ ...@ to make a binding. +set :: TValue r a -> (CodeGenFunction r (TValue r a)) +set x = do x' <- x; return (return x') + +instance Eq (TValue r a) +instance Ord (TValue r a) + +instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where + (+) = binop add + (-) = binop sub + (*) = binop mul + negate = (>>= neg) + abs x = x %< 0 ?? (-x, x) + signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0)) + fromInteger = return . valueOf . fromInteger + +instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Enum (TValue r a) where + succ x = x + 1 + pred x = x - 1 + fromEnum _ = error "CodeGenFunction Value: fromEnum" + toEnum = fromIntegral + +instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Real (TValue r a) where + toRational _ = error "CodeGenFunction Value: toRational" + +instance (CmpRet a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where + quot = binop idiv + rem = binop irem + quotRem x y = (quot x y, rem x y) + toInteger _ = error "CodeGenFunction Value: toInteger" + +instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where + (/) = binop fdiv + fromRational = return . valueOf . fromRational + +instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where + properFraction _ = error "CodeGenFunction Value: properFraction" + +instance (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where + pi = return $ valueOf pi + sqrt = callIntrinsic1 "sqrt" + sin = callIntrinsic1 "sin" + cos = callIntrinsic1 "cos" + (**) = callIntrinsic2 "pow" + exp = callIntrinsic1 "exp" + log = callIntrinsic1 "log" + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 + +instance (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where + floatRadix _ = floatRadix (undefined :: a) + floatDigits _ = floatDigits (undefined :: a) + floatRange _ = floatRange (undefined :: a) + decodeFloat _ = error "CodeGenFunction Value: decodeFloat" + encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat" + exponent _ = 0 + scaleFloat 0 x = x + scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat" + isNaN _ = error "CodeGenFunction Value: isNaN" + isInfinite _ = error "CodeGenFunction Value: isInfinite" + isDenormalized _ = error "CodeGenFunction Value: isDenormalized" + isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero" + isIEEE _ = isIEEE (undefined :: a) + +binop :: (Value a -> Value b -> TValue r c) -> + TValue r a -> TValue r b -> TValue r c +binop op x y = do + x' <- x + 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 +callIntrinsicP1 fn x = do + op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a)) +{- +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] +-} + runCall (callFromFunction op `applyCall` x) >>= addReadNone + +callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) => + String -> Value a -> Value b -> TValue r c +callIntrinsicP2 fn x y = do + op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a)) + runCall (callFromFunction op `applyCall` x `applyCall` y) >>= addReadNone + +------------------------------------------- + +class ArithFunction r z a b | a -> b r z, b r z -> a where + arithFunction' :: a -> b + +instance + (Ret a r) => + ArithFunction r a (CodeGenFunction r a) (CodeGenFunction r ()) where + arithFunction' x = x >>= ret + +instance + (ArithFunction r z b0 b1) => + ArithFunction r z (CodeGenFunction r a -> b0) (a -> b1) where + arithFunction' f = arithFunction' . f . return + +-- |Unlift a function with @TValue@ to have @Value@ arguments. +arithFunction :: ArithFunction r z a b => a -> b +arithFunction = arithFunction' + + +class ToArithFunction r a b | a r -> b, b -> a r where + toArithFunction' :: CodeGenFunction r (Call a) -> b + +instance ToArithFunction r (IO b) (CodeGenFunction r (Value b)) where + toArithFunction' cl = cl >>= runCall + +instance + ToArithFunction r b0 b1 => + ToArithFunction r (a -> b0) (CodeGenFunction r (Value a) -> b1) where + toArithFunction' cl x = + toArithFunction' (liftM2 applyCall cl x) + + +_toArithFunction2 :: + Function (a -> b -> IO c) -> TValue r a -> TValue r b -> TValue r c +_toArithFunction2 f tx ty = do + x <- tx + y <- ty + runCall $ callFromFunction f `applyCall` x `applyCall` y + +-- |Lift a function from having @Value@ arguments to having @TValue@ arguments. +toArithFunction :: + (ToArithFunction r f g) => + Function f -> g +toArithFunction f = + toArithFunction' $ return $ callFromFunction f + +------------------------------------------- + +-- |Define a recursive 'arithFunction', gets passed itself as the first argument. +recursiveFunction :: + (IsFunction f, FunctionArgs f, code ~ FunctionCodeGen f, + ArithFunction r1 z arith code, + ToArithFunction r0 f g) => + (g -> arith) -> CodeGenModule (Function f) +recursiveFunction af = do + f <- newFunction ExternalLinkage + defineFunction f $ arithFunction $ af $ toArithFunction f + return f + + +------------------------------------------- + +class CallIntrinsic a where + callIntrinsic1' :: String -> Value a -> TValue r a + callIntrinsic2' :: String -> Value a -> Value a -> TValue r a + +instance CallIntrinsic Float where + callIntrinsic1' = callIntrinsicP1 + callIntrinsic2' = callIntrinsicP2 + +instance CallIntrinsic Double where + callIntrinsic1' = callIntrinsicP1 + callIntrinsic2' = callIntrinsicP2 + +{- +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 (PositiveT n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where + callIntrinsic1' s x = + if macOS && TypeNum.fromIntegerT (undefined :: n) == (4::Int) && + 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 = binop (callIntrinsic2' s) diff --git a/src/LLVM/Util/File.hs b/src/LLVM/Util/File.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/File.hs @@ -0,0 +1,49 @@ +module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where + +import System.Process (system) + +import LLVM.ExecutionEngine +import LLVM.Core + + +writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () +writeCodeGenModule name f = do + m <- newModule + _ <- defineModule m f + writeBitcodeToFile name m + +optimize :: FilePath -> IO () +optimize name = do + _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name + return () + +optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t) +optimizeFunction = fmap snd . optimizeFunction' + +optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t) +optimizeFunction' mdl = do + m <- newModule + mf <- defineModule m mdl + fName <- getValueName mf + + let name = "__tmp__" ++ fName ++ ".bc" + writeBitcodeToFile name m + + optimize name + + m' <- readBitcodeFromFile name + funcs <- getModuleValues m' + +-- removeFile name + + let Just mf' = castModuleValue =<< lookup fName funcs + + return (m', mf') + +optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t +optimizeFunctionCG mdl = do + (m', mf') <- optimizeFunction' mdl + rf <- runEngineAccess $ do + addModule m' + generateFunction mf' + return rf diff --git a/src/LLVM/Util/Foreign.hs b/src/LLVM/Util/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Foreign.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- These are replacements for the broken equivalents in Foreign.*. +-- The functions in Foreign.* do not obey the required alignment. +module LLVM.Util.Foreign where + +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Marshal.Array (allocaArray, pokeArray) +import Foreign.Storable (Storable(poke, sizeOf, alignment)) +import Foreign.Ptr (alignPtr, Ptr) + + +with :: Storable a => a -> (Ptr a -> IO b) -> IO b +with x act = + alloca $ \ p -> do + poke p x + act p + +alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b +alloca act = + allocaBytes (2 * sizeOf (undefined :: a)) $ \ p -> + act $ alignPtr p (alignment (undefined :: a)) + +withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b +withArrayLen xs act = + let l = length xs in + allocaArray (l+1) $ \ p -> do + let p' = alignPtr p (alignment (head xs)) + pokeArray p' xs + act l p' + diff --git a/src/LLVM/Util/Loop.hs b/src/LLVM/Util/Loop.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Loop.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where + +import LLVM.Core +import Types.Data.Num (fromIntegerT) + + +class Phi a where + phis :: BasicBlock -> a -> CodeGenFunction r a + addPhis :: BasicBlock -> a -> a -> CodeGenFunction r () + +{- +infixr 1 :* +-- XXX should use HList if it was packaged in a nice way. +data a :* b = a :* b + deriving (Eq, Ord, Show, Read) + +instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where + phis bb (a :* b) = do + a' <- phi [(a, bb)] + b' <- phis bb b + return (a' :* b') + addPhis bb (a :* b) (a' :* b') = do + addPhiInputs a [(a', bb)] + addPhis bb b b' +-} + +instance Phi () where + phis _ _ = return () + addPhis _ _ _ = return () + +instance (IsFirstClass a) => Phi (Value a) where + phis bb a = do + a' <- phi [(a, bb)] + return a' + addPhis bb a a' = do + addPhiInputs a [(a', bb)] + +instance (Phi a, Phi b) => Phi (a, b) where + phis bb (a, b) = do + a' <- phis bb a + b' <- phis bb b + return (a', b') + addPhis bb (a, b) (a', b') = do + addPhis bb a a' + addPhis bb b b' + +instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where + phis bb (a, b, c) = do + a' <- phis bb a + b' <- phis bb b + c' <- phis bb c + return (a', b', c') + addPhis bb (a, b, c) (a', b', c') = do + addPhis bb a a' + addPhis bb b b' + addPhis bb c c' + +-- Loop the index variable from low to high. The state in the loop starts as start, and is modified +-- by incr in each iteration. +forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) => + Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a +forLoop low high start incr = do + top <- getCurrentBasicBlock + loop <- newBasicBlock + body <- newBasicBlock + exit <- newBasicBlock + + br loop + + defineBasicBlock loop + i <- phi [(low, top)] + vars <- phis top start + t <- cmp CmpNE i high + condBr t body exit + + defineBasicBlock body + + vars' <- incr i vars + i' <- add i (valueOf 1 :: Value i) + + body' <- getCurrentBasicBlock + addPhis body' vars vars' + addPhiInputs i [(i', body')] + br loop + defineBasicBlock exit + + return vars + +-------------------------------------- + +mapVector :: forall a b n r . + (PositiveT n, IsPrimitive b) => + (Value a -> CodeGenFunction r (Value b)) -> + Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) +mapVector f v = + forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do + x <- extractelement v i + y <- f x + insertelement w y i + +mapVector2 :: forall a b c n r . + (PositiveT n, IsPrimitive c) => + (Value a -> Value b -> CodeGenFunction r (Value c)) -> + Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c)) +mapVector2 f v1 v2 = + forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do + x <- extractelement v1 i + y <- extractelement v2 i + z <- f x y + insertelement w z i diff --git a/src/LLVM/Util/Memory.hs b/src/LLVM/Util/Memory.hs new file mode 100644 --- /dev/null +++ b/src/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." ++ intrinsicTypeName (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." ++ intrinsicTypeName (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." ++ intrinsicTypeName (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/src/LLVM/Util/Optimize.hs b/src/LLVM/Util/Optimize.hs new file mode 100644 --- /dev/null +++ b/src/LLVM/Util/Optimize.hs @@ -0,0 +1,132 @@ +{- +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 LLVM.Core.Util (Module, withModule) + +import qualified LLVM.FFI.Core as FFI +import qualified LLVM.FFI.Support as FFI +import LLVM.FFI.Transforms.Scalar (addVerifierPass) + +import Control.Exception (bracket) + + +{- | +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 +-} + + {- + 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. + + fPasses <- FFI.createFunctionPassManager mp + -} + bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do + -- add module target data? + + -- tools/opt/opt.cpp: AddStandardCompilePasses + addVerifierPass passes + addOptimizationPasses passes fPasses optLevel + + {- if we wanted to do so, we could loop through all functions and optimize them. + initializeFunctionPassManager fPasses + runFunctionPassManager fPasses fcn + -} + + functionsModified <- FFI.runPassManager fPasses m + + moduleModified <- FFI.runPassManager passes m + + 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 + createStandardModulePasses passes optLevel True True (optLevel > 1) True True True + +createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () +createStandardFunctionPasses fPasses optLevel = + FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel) + +-- llvm/Support/StandardPasses.h: createStandardModulePasses +createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO () +createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = + FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize) + (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions) + (f (not inliningPass)) + where f True = 1 + f _ = 0 + + +{- +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 +-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/test/Makefile b/test/Makefile new file mode 100644 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,16 @@ +ghc := ghc +ghcflags := -Wall -Werror +tests := TestType TestValue + +all: $(tests:%=%.out) + +%.out: %.test + ./$< > $@ 2>&1; s=$$?; cat $@; \ + if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi + +.PRECIOUS: %.test +%.test: %.hs + $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< + +clean: + -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out) diff --git a/test/TestValue.hs b/test/TestValue.hs new file mode 100644 --- /dev/null +++ b/test/TestValue.hs @@ -0,0 +1,69 @@ +module TestValue (main) where + +import qualified LLVM.Core as Core +import qualified LLVM.Core.Type as T +import qualified LLVM.Core.Value as V + +testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v) + => T.Module -> String -> IO (V.Function r p) +testArguments m name = do + func <- Core.addFunction m name (T.function undefined undefined) + V.dumpValue func + let arg = V.params func + V.dumpValue arg + return func + +voidArguments :: T.Module -> IO () +voidArguments m = do + func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ()) + V.dumpValue func + return () + +type F a = V.Function a a +type P a = V.Function (T.Pointer a) (T.Pointer a) +type V a = V.Function (T.Vector a) (T.Vector a) + +arguments :: T.Module -> IO () +arguments m = do + voidArguments m + + testArguments m "int1" :: IO (F T.Int1) + testArguments m "int8" :: IO (F T.Int8) + testArguments m "int16" :: IO (F T.Int16) + testArguments m "int32" :: IO (F T.Int32) + testArguments m "int64" :: IO (F T.Int64) + testArguments m "float" :: IO (F T.Float) + testArguments m "double" :: IO (F T.Double) + testArguments m "float128" :: IO (F T.Float128) + testArguments m "x86Float80" :: IO (F T.X86Float80) + testArguments m "ppcFloat128" :: IO (F T.PPCFloat128) + + testArguments m "ptrInt1" :: IO (P T.Int1) + testArguments m "ptrInt8" :: IO (P T.Int8) + testArguments m "ptrInt16" :: IO (P T.Int16) + testArguments m "ptrInt32" :: IO (P T.Int32) + testArguments m "ptrInt64" :: IO (P T.Int64) + testArguments m "ptrFloat" :: IO (P T.Float) + testArguments m "ptrDouble" :: IO (P T.Double) + testArguments m "ptrFloat128" :: IO (P T.Float128) + testArguments m "ptrX86Float80" :: IO (P T.X86Float80) + testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128) + + testArguments m "vecInt1" :: IO (V T.Int1) + testArguments m "vecInt8" :: IO (V T.Int8) + testArguments m "vecInt16" :: IO (V T.Int16) + testArguments m "vecInt32" :: IO (V T.Int32) + testArguments m "vecInt64" :: IO (V T.Int64) + testArguments m "vecFloat" :: IO (V T.Float) + testArguments m "vecDouble" :: IO (V T.Double) + testArguments m "vecFloat128" :: IO (V T.Float128) + testArguments m "vecX86Float80" :: IO (V T.X86Float80) + testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128) + + return () + +main :: IO () +main = do + m <- Core.createModule "m" + arguments m + return () diff --git a/tests/Makefile b/tests/Makefile deleted file mode 100644 --- a/tests/Makefile +++ /dev/null @@ -1,16 +0,0 @@ -ghc := ghc -ghcflags := -Wall -Werror -tests := TestType TestValue - -all: $(tests:%=%.out) - -%.out: %.test - ./$< > $@ 2>&1; s=$$?; cat $@; \ - if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi - -.PRECIOUS: %.test -%.test: %.hs - $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< - -clean: - -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out) diff --git a/tests/TestValue.hs b/tests/TestValue.hs deleted file mode 100644 --- a/tests/TestValue.hs +++ /dev/null @@ -1,69 +0,0 @@ -module TestValue (main) where - -import qualified LLVM.Core as Core -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V - -testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v) - => T.Module -> String -> IO (V.Function r p) -testArguments m name = do - func <- Core.addFunction m name (T.function undefined undefined) - V.dumpValue func - let arg = V.params func - V.dumpValue arg - return func - -voidArguments :: T.Module -> IO () -voidArguments m = do - func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ()) - V.dumpValue func - return () - -type F a = V.Function a a -type P a = V.Function (T.Pointer a) (T.Pointer a) -type V a = V.Function (T.Vector a) (T.Vector a) - -arguments :: T.Module -> IO () -arguments m = do - voidArguments m - - testArguments m "int1" :: IO (F T.Int1) - testArguments m "int8" :: IO (F T.Int8) - testArguments m "int16" :: IO (F T.Int16) - testArguments m "int32" :: IO (F T.Int32) - testArguments m "int64" :: IO (F T.Int64) - testArguments m "float" :: IO (F T.Float) - testArguments m "double" :: IO (F T.Double) - testArguments m "float128" :: IO (F T.Float128) - testArguments m "x86Float80" :: IO (F T.X86Float80) - testArguments m "ppcFloat128" :: IO (F T.PPCFloat128) - - testArguments m "ptrInt1" :: IO (P T.Int1) - testArguments m "ptrInt8" :: IO (P T.Int8) - testArguments m "ptrInt16" :: IO (P T.Int16) - testArguments m "ptrInt32" :: IO (P T.Int32) - testArguments m "ptrInt64" :: IO (P T.Int64) - testArguments m "ptrFloat" :: IO (P T.Float) - testArguments m "ptrDouble" :: IO (P T.Double) - testArguments m "ptrFloat128" :: IO (P T.Float128) - testArguments m "ptrX86Float80" :: IO (P T.X86Float80) - testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128) - - testArguments m "vecInt1" :: IO (V T.Int1) - testArguments m "vecInt8" :: IO (V T.Int8) - testArguments m "vecInt16" :: IO (V T.Int16) - testArguments m "vecInt32" :: IO (V T.Int32) - testArguments m "vecInt64" :: IO (V T.Int64) - testArguments m "vecFloat" :: IO (V T.Float) - testArguments m "vecDouble" :: IO (V T.Double) - testArguments m "vecFloat128" :: IO (V T.Float128) - testArguments m "vecX86Float80" :: IO (V T.X86Float80) - testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128) - - return () - -main :: IO () -main = do - m <- Core.createModule "m" - arguments m - return ()