llvm-tf (empty) → 3.0.0.0
raw patch · 39 files changed
+5664/−0 lines, 39 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, directory, llvm-base, mtl, process, tfp
Files
- LICENSE +69/−0
- LLVM/Core.hs +111/−0
- LLVM/Core/CodeGen.hs +513/−0
- LLVM/Core/CodeGenMonad.hs +122/−0
- LLVM/Core/Data.hs +43/−0
- LLVM/Core/Instructions.hs +1253/−0
- LLVM/Core/Type.hs +506/−0
- LLVM/Core/Util.hs +498/−0
- LLVM/Core/Vector.hs +148/−0
- LLVM/ExecutionEngine.hs +115/−0
- LLVM/ExecutionEngine/Engine.hs +328/−0
- LLVM/ExecutionEngine/Target.hs +65/−0
- LLVM/Util/Arithmetic.hs +308/−0
- LLVM/Util/File.hs +47/−0
- LLVM/Util/Foreign.hs +29/−0
- LLVM/Util/Loop.hs +113/−0
- LLVM/Util/Memory.hs +89/−0
- LLVM/Util/Optimize.hs +130/−0
- PROBLEMS.md +20/−0
- README.md +58/−0
- Setup.lhs +3/−0
- examples/Align.hs +21/−0
- examples/Arith.hs +86/−0
- examples/Array.hs +62/−0
- examples/BrainF.hs +157/−0
- examples/CallConv.hs +33/−0
- examples/Convert.hs +41/−0
- examples/DotProd.hs +79/−0
- examples/Fibonacci.hs +106/−0
- examples/HelloJIT.hs +24/−0
- examples/List.hs +109/−0
- examples/Struct.hs +40/−0
- examples/Varargs.hs +37/−0
- examples/Vector.hs +100/−0
- examples/mainfib.c +12/−0
- examples/structCheck.c +9/−0
- llvm-tf.cabal +95/−0
- tests/Makefile +16/−0
- tests/TestValue.hs +69/−0
+ LICENSE view
@@ -0,0 +1,69 @@+======================================================================+Haskell LLVM Bindings Release License+======================================================================+University of Illinois/NCSA+Open Source License++Copyright (c) 2007-2009 Bryan O'Sullivan+All rights reserved.++Developed by:++ Bryan O'Sullivan <bos@serpentine.com>+ http://www.serpentine.com/blog/++ Lennart Augustsson <lennart@augustsson.net>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal with the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimers.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimers in the documentation and/or other materials provided+ with the distribution.++ * Neither the names of Bryan O'Sullivan, University of Illinois at+ Urbana-Champaign, nor the names of its contributors may be used+ to endorse or promote products derived from this Software+ without specific prior written permission.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR+ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE.++======================================================================+Copyrights and Licenses for Third Party Software Distributed with+Haskell LLVM Bindings:+======================================================================++The Haskell LLVM Bindings software may contain code written by third+parties. Any such software will have its own individual license file+in the directory in which it appears. This file will describe the+copyrights, license, and restrictions which apply to that code.++The disclaimer of warranty in the University of Illinois Open Source+License applies to all code in the Haskell LLVM Bindings Distribution,+and nothing in any of the other licenses gives permission to use the+name of Bryan O'Sullivan or the University of Illinois to endorse or+promote products derived from this Software.++The following pieces of software have additional or alternate+copyrights, licenses, and/or restrictions:++Program Directory+------- ---------+configure .++
+ LLVM/Core.hs view
@@ -0,0 +1,111 @@+-- |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
+ LLVM/Core/CodeGen.hs view
@@ -0,0 +1,513 @@+{-# 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+<http://old.nabble.com/jit-with-external-functions-td7769793.html>.+-}+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 _ = []
+ LLVM/Core/CodeGenMonad.hs view
@@ -0,0 +1,122 @@+{-# 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.State+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, MonadState CGMState, MonadIO, Typeable)++genMSym :: String -> CodeGenModule String+genMSym prefix = do+ s <- get+ let n = cgm_next s+ put (s { cgm_next = n + 1 })+ return $ "_" ++ prefix ++ show n++getModule :: CodeGenModule Module+getModule = 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, MonadState (CGFState r), MonadIO, Typeable)++genFSym :: CodeGenFunction a String+genFSym = do+ s <- get+ let n = cgf_next s+ put (s { cgf_next = n + 1 })+ return $ "_L" ++ show n++getFunction :: CodeGenFunction a Function+getFunction = gets cgf_function++getBuilder :: CodeGenFunction a Builder+getBuilder = gets cgf_builder++getFunctionModule :: CodeGenFunction a Module+getFunctionModule = gets (cgm_module . cgf_module)++getExterns :: CodeGenFunction a [(String, Function)]+getExterns = gets (cgm_externs . cgf_module)++putExterns :: [(String, Function)] -> CodeGenFunction a ()+putExterns es = do+ cgf <- get+ let cgm' = (cgf_module cgf) { cgm_externs = es }+ put (cgf { cgf_module = cgm' })++addGlobalMapping ::+ Function -> Ptr () -> CodeGenModule ()+addGlobalMapping value func = 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 =+ gets (GlobalMappings . cgm_global_mappings)++runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a+runCodeGenFunction bld fn (CGF body) = do+ cgm <- get+ let cgf = CGFState { cgf_module = cgm,+ cgf_builder = bld,+ cgf_function = fn,+ cgf_next = 1 }+ (a, cgf') <- liftIO $ runStateT body cgf+ 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 <- get+ (a, cgm') <- liftIO $ runStateT act (cgf_module cgf)+ put (cgf { cgf_module = cgm' })+ return a
+ LLVM/Core/Data.hs view
@@ -0,0 +1,43 @@+{-# 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)
+ LLVM/Core/Instructions.hs view
@@ -0,0 +1,1253 @@+{-# 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,+ 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,++ -- * 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++-- |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 :: Caller -> [FFI.ValueRef] -> 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 mkCall args f (Value arg) = doCall mkCall (arg : args) (f (undefined :: 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 = doCallDef++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 (Value f) = doCall (U.makeCall f) [] (undefined :: 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 (BasicBlock norm) (BasicBlock expt) (Value f) =+ doCall (U.makeInvoke norm expt f) [] (undefined :: 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 (Value f) = doCall (U.makeCallWithCc cc f) [] (undefined :: 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 (BasicBlock norm) (BasicBlock expt) (Value f) =+ doCall (U.makeInvokeWithCc cc norm expt f) [] (undefined :: 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)+-}
+ LLVM/Core/Type.hs view
@@ -0,0 +1,506 @@+{-# 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++-- do we really need IsScalarOrVector?+-- proposal: either associate NumberOfElements with IsType or make it a non-associated type family+-- |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.+
+ LLVM/Core/Util.hs view
@@ -0,0 +1,498 @@+{-# 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)
+ LLVM/Core/Vector.hs view
@@ -0,0 +1,148 @@+{-# 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
+ LLVM/ExecutionEngine.hs view
@@ -0,0 +1,115 @@+{-# 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
+ LLVM/ExecutionEngine/Engine.hs view
@@ -0,0 +1,328 @@+{-# 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 Control.Monad.State+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, MonadState EAState, MonadIO)++-- |The LLVM execution engine is encapsulated so it cannot be accessed directly.+-- The reason is that (currently) there must only ever be one engine,+-- 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 <- get+ put ea{ ea_providers = prov : ea_providers ea }+ liftIO $ withModuleProvider prov $ \ provPtr ->+ FFI.addModuleProvider (ea_engine ea) provPtr++getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef+getExecutionEngineTargetData = do+ eePtr <- gets ea_engine+ 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 <- gets ea_engine+ 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 <- gets ea_engine+ 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 <- 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 <- gets ea_engine+ liftIO $ withAll args $ \argLen argPtr ->+ createGenericValueWith $ FFI.runFunction eePtr func+ (fromIntegral argLen) argPtr+getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)+getRunFunction = do+ eePtr <- gets ea_engine+ 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
+ LLVM/ExecutionEngine/Target.hs view
@@ -0,0 +1,65 @@+{-# 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
+ LLVM/Util/Arithmetic.hs view
@@ -0,0 +1,308 @@+{-# 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)+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 (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 :: Function (a -> IO b) <- 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]+-}+ call op x >>= addReadNone++callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) =>+ String -> Value a -> Value b -> TValue r c+callIntrinsicP2 fn x y = do+ op :: Function (a -> b -> IO c) <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a))+ call op x 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)
+ LLVM/Util/File.hs view
@@ -0,0 +1,47 @@+module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where+import System.Cmd(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
+ LLVM/Util/Foreign.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- These are replacements for the broken equivalents in Foreign.*.+-- The functions in Foreign.* do not obey the required alignment.+module LLVM.Util.Foreign where++import Foreign.Ptr(alignPtr, Ptr)+import Foreign.Storable(Storable(poke, sizeOf, alignment))+import Foreign.Marshal.Alloc(allocaBytes)+import Foreign.Marshal.Array(allocaArray, pokeArray)++with :: Storable a => a -> (Ptr a -> IO b) -> IO b+with x act =+ alloca $ \ p -> do+ poke p x+ act p++alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b+alloca act =+ allocaBytes (2 * sizeOf (undefined :: a)) $ \ p ->+ act $ alignPtr p (alignment (undefined :: a))++withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen xs act =+ let l = length xs in+ allocaArray (l+1) $ \ p -> do+ let p' = alignPtr p (alignment (head xs))+ pokeArray p' xs+ act l p'+
+ LLVM/Util/Loop.hs view
@@ -0,0 +1,113 @@+{-# 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
+ LLVM/Util/Memory.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}+module LLVM.Util.Memory (+ memcpy,+ memmove,+ memset,+ IsLengthType,+ ) where++import LLVM.Core++import Data.Word (Word8, Word32, Word64, )+++class IsFirstClass len => IsLengthType len where++instance IsLengthType Word32 where+instance IsLengthType Word64 where+++memcpyFunc ::+ forall len.+ IsLengthType len =>+ TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memcpyFunc =+ newNamedFunction ExternalLinkage $+ "llvm.memcpy.p0i8.p0i8." ++ 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
+ LLVM/Util/Optimize.hs view
@@ -0,0 +1,130 @@+{-+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+-}
+ PROBLEMS.md view
@@ -0,0 +1,20 @@+Known problems+--------------++If you have solutions to any of the problems listed below, please let+me know, or better yet, send a patch. Thanks!+++Can't use LLVM bindings from ghci+---------------------------------++When I try to use the LLVM bindings in `ghci`, on Linux, loading the+bindings succeeds, but trying to do anything fails:++ $ ghci+ Prelude> :m +LLVM.Core+ Prelude LLVM.Core> m <- createModule "foo"+ can't load .so/.DLL for: stdc++ (libstdc++.so: cannot open shared+ object file: No such file or directory)++I don't know why this happens, but it looks like a `ghci` bug.
+ README.md view
@@ -0,0 +1,58 @@+Haskell LLVM bindings+---------------------++This package provides Haskell bindings for the popular+[LLVM](http://llvm.org/) compiler infrastructure project.+++Compatibility+-------------++We try to stay up to date with LLVM releases. The current version of+this package is compatible with LLVM 2.9 and 2.8. Please understand+that the package may or may not work against older LLVM releases; we+don't have the time or resources to test across multiple releases.+++Configuration+-------------++By default, when you run `cabal install`, the Haskell bindings will be+configured to look for LLVM in `/usr/local`.++If you have LLVM installed in a different location, e.g. `/usr`, you+can tell the `configure` script where to find it as follows:++ cabal install --configure-option=--with-llvm-prefix=/usr+++Package status - what to expect+-------------------------------++This package is still under development.++The high level bindings are currently incomplete, so there are some+limits on what you can do. Adding new functions is generally easy,+though, so don't be afraid to get your hands dirty.++The high level interface is mostly safe, but the type system cannot+protect against everything that can go wrong, so take care. And, of+course, there's no way to guarantee anything about the generated code.+++Staying in touch+----------------++There is a low-volume mailing list named+[haskell-llvm@projects.haskellorg](http://projects.haskell.org/cgi-bin/mailman/listinfo/haskell-llvm).+If you use the LLVM bindings, you should think about joining.++If you want to contribute patches, please clone a copy of the+[git repository](https://github.com/bos/llvm):++ git clone git://github.com/bos/llvm++Patches are best submitted via the github "pull request" interface.++To file a bug or a request for an enhancement, please use the+[github issue tracker](https://github.com/bos/llvm/issues).
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ examples/Align.hs view
@@ -0,0 +1,21 @@+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+ )
+ examples/Arith.hs view
@@ -0,0 +1,86 @@+{-# 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
+ examples/Array.hs view
@@ -0,0 +1,62 @@+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
+ examples/BrainF.hs view
@@ -0,0 +1,157 @@+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
+ examples/CallConv.hs view
@@ -0,0 +1,33 @@+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
+ examples/Convert.hs view
@@ -0,0 +1,41 @@+{-# 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+
+ examples/DotProd.hs view
@@ -0,0 +1,79 @@+{-# 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]
+ examples/Fibonacci.hs view
@@ -0,0 +1,106 @@+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
+ examples/HelloJIT.hs view
@@ -0,0 +1,24 @@+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 ()
+ examples/List.hs view
@@ -0,0 +1,109 @@+{-# 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
+ examples/Struct.hs view
@@ -0,0 +1,40 @@+{-# 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 ()
+ examples/Varargs.hs view
@@ -0,0 +1,37 @@+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 ()
+ examples/Vector.hs view
@@ -0,0 +1,100 @@+{-# 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
+ examples/mainfib.c view
@@ -0,0 +1,12 @@+#include <stdio.h>+#include <stdlib.h>++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);+}
+ examples/structCheck.c view
@@ -0,0 +1,9 @@+#include <stdint.h>++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;+}
+ llvm-tf.cabal view
@@ -0,0 +1,95 @@+name: llvm-tf+version: 3.0.0.0+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.+ .+ * New in 3.0.0.0:+ The low-level bindings have been split into the llvm-base package.+ .+ We use the same module names as the @llvm@ package,+ which makes it harder to work with both packages from GHCi.+ You may use the @-hide-package@ option.+ We may change the module names later.+ .+ A note on versioning:+ The first two version numbers match the version of LLVM.+ In order to be able to improve the Haskell API for the same version of LLVM,+ I use the first three numbers of the Cabal package version+ as the major version in the sense of the Package Versioning Policy PVP.+ 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 <llvm@henning-thielemann.de>+stability: experimental+category: Compilers/Interpreters, Code Generation+tested-with: GHC == 7.4.2+cabal-version: >= 1.10+build-type: Simple++extra-source-files:+ *.md+ examples/*.c+ examples/*.hs+ tests/*.hs+ tests/Makefile++flag developer+ description: operate in developer mode+ default: False++library+ default-language: Haskell98+ build-depends:+ base >= 3 && < 5,+ bytestring >= 0.9,+ directory,+ llvm-base == 3.0.*,+ mtl,+ process,+ tfp >= 0.7 && < 0.8,+ containers++ ghc-options: -Wall++ if flag(developer)+ ghc-options: -Werror++ if os(darwin)+ ld-options: -w + frameworks: vecLib+ cpp-options: -D__MACOS__++ exposed-modules:+ LLVM.Core+ LLVM.ExecutionEngine+ LLVM.Util.Arithmetic+ LLVM.Util.File+ LLVM.Util.Foreign+ LLVM.Util.Loop+ LLVM.Util.Memory+ LLVM.Util.Optimize++ other-modules:+ LLVM.Core.CodeGen+ LLVM.Core.CodeGenMonad+ LLVM.Core.Data+ LLVM.Core.Instructions+ LLVM.Core.Type+ LLVM.Core.Util+ LLVM.Core.Vector+ LLVM.ExecutionEngine.Engine+ LLVM.ExecutionEngine.Target++source-repository head+ type: darcs+ location: http://code.haskell.org/~thielema/llvm-tf/++source-repository this+ tag: 3.0.0.0+ type: darcs+ location: http://code.haskell.org/~thielema/llvm-tf/
+ tests/Makefile view
@@ -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)
+ tests/TestValue.hs view
@@ -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 ()