diff --git a/Data/TypeNumbers.hs b/Data/TypeNumbers.hs new file mode 100644 --- /dev/null +++ b/Data/TypeNumbers.hs @@ -0,0 +1,56 @@ +-- |Type level decimal numbers. +module Data.TypeNumbers( + IsTypeNumber, typeNumber, + D0(..),D1(..),D2(..),D3(..),D4(..),D5(..),D6(..),D7(..),D8(..),D9(..), + End(..) + ) where + +-- |A type level number, i.e., a sequence of type level digits. +class IsTypeNumber ds where + typeNumber' :: (Num a) => ds -> a -> a + +-- |Get the numeric value of a type level number. +-- This function does not evaluate its argument. +typeNumber :: (IsTypeNumber ds, Num a) => ds -> a +typeNumber ds = typeNumber' ds 0 + +-- |Mark the end of a digit sequence. +data End = End +instance IsTypeNumber End where + typeNumber' _ a = a + +-- |The 'D0' - 'D9' types represent type level digits that form +-- a number by, e.g, @D1 (D0 (D5 End))@. +-- On the value level a slightly more palatable form can be used, +-- @D1$D0$D5$End@. +data D0 a = D0 a +data D1 a = D1 a +data D2 a = D2 a +data D3 a = D3 a +data D4 a = D4 a +data D5 a = D5 a +data D6 a = D6 a +data D7 a = D7 a +data D8 a = D8 a +data D9 a = D9 a + +instance (IsTypeNumber ds) => IsTypeNumber (D0 ds) where + typeNumber' ~(D0 ds) acc = typeNumber' ds (10*acc + 0) +instance (IsTypeNumber ds) => IsTypeNumber (D1 ds) where + typeNumber' ~(D1 ds) acc = typeNumber' ds (10*acc + 1) +instance (IsTypeNumber ds) => IsTypeNumber (D2 ds) where + typeNumber' ~(D2 ds) acc = typeNumber' ds (10*acc + 2) +instance (IsTypeNumber ds) => IsTypeNumber (D3 ds) where + typeNumber' ~(D3 ds) acc = typeNumber' ds (10*acc + 3) +instance (IsTypeNumber ds) => IsTypeNumber (D4 ds) where + typeNumber' ~(D4 ds) acc = typeNumber' ds (10*acc + 4) +instance (IsTypeNumber ds) => IsTypeNumber (D5 ds) where + typeNumber' ~(D5 ds) acc = typeNumber' ds (10*acc + 5) +instance (IsTypeNumber ds) => IsTypeNumber (D6 ds) where + typeNumber' ~(D6 ds) acc = typeNumber' ds (10*acc + 6) +instance (IsTypeNumber ds) => IsTypeNumber (D7 ds) where + typeNumber' ~(D7 ds) acc = typeNumber' ds (10*acc + 7) +instance (IsTypeNumber ds) => IsTypeNumber (D8 ds) where + typeNumber' ~(D8 ds) acc = typeNumber' ds (10*acc + 8) +instance (IsTypeNumber ds) => IsTypeNumber (D9 ds) where + typeNumber' ~(D9 ds) acc = typeNumber' ds (10*acc + 9) diff --git a/INSTALL.txt b/INSTALL.txt --- a/INSTALL.txt +++ b/INSTALL.txt @@ -9,63 +9,33 @@ Prerequisites ------------- -I'm using GHC 6.8.2 for development. 6.8.1 will probably work. I'll -be happy to accept patches to get things working with 6.6.x, provided -they don't pervert the code much :-) - -(My development environment is Fedora 8 x86_64, in case you're -curious.) - -Firstly, you'll need the SVN version of LLVM: - - svn co http://llvm.org/svn/llvm-project/llvm/trunk llvm-trunk +Firstly, you'll need to have LLVM. I recommend installing LLVM +version 2.4 which is what it's been tested with. -Build this and install it somewhere. Here's what I do: +Build this and install it somewhere. Follow the LLVM instructions, +or use this: - cd llvn-trunk - ./configure --prefix=$HOME + cd llvm + ./configure --prefix=$SOMEWHERE make make install -If you're building the Haskell bindings from the darcs repo (strongly -recommended from now), you'll also need a copy of GNU autoconf. - - -Using GNU Make --------------- - -There's a GNU Make Makefile in the top-level directory that builds the -LLVM bindings the way I want them built. In principle, you ought to -be able to simply run something like this: - - make llvm_prefix=/my/llvm/path prefix=/my/preferred/path - -These both default to $HOME. +It's a good idea to have $SOMEWHERE/bin is in your path. -Building by hand ----------------- - -If you want to avoid GNU Make, here's a recipe you can follow. Run -these in the root of your darcs repo or unpacked source tarball. - -If you're building from darcs, run this once (this is why you need -autoconf installed): - - autoreconf - -Configure the package. I'm assuming that LLVM is installed in $HOME, -and that you want the bindings installed in $HOME, too. +Building +-------- +It's normal cabal package, but using a configure script as well to +configure LLVM. It can be build and installed with the usual +three steps. - runhaskell Setup configure --prefix=$HOME \ - --configure-option --with-llvm-prefix=$HOME --user +Configure the package. + runhaskell Setup configure --configure-option --with-llvm-prefix=$SOMEWHERE Build. - runhaskell Setup build Install. - runhaskell Setup install @@ -75,3 +45,7 @@ In the examples directory are a few example programs. There's a GNU Make Makefile in there, so running "make" in that directory will build the examples, as will "make examples" in the top-level directory. +Doing "make run" will build and run the examples. + +Note: On MacOS X you get a lot of "atom sorting error" warnings. They +seem to be harmless. diff --git a/LLVM/Core.hs b/LLVM/Core.hs --- a/LLVM/Core.hs +++ b/LLVM/Core.hs @@ -1,117 +1,89 @@ -{-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-} - -module LLVM.Core - ( +-- |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( -- * Modules - createModule - - -- * Module providers - , createModuleProviderForExistingModule - - -- * Types - , addTypeName - , deleteTypeName - - -- * Values - , addGlobal - , setInitializer - - -- ** Operations on functions - , addFunction - , deleteFunction - , getNamedFunction - + Module, newModule, newNamedModule, defineModule, destroyModule, createModule, + ModuleProvider, createModuleProviderForExistingModule, + PassManager, createPassManager, createFunctionPassManager, + writeBitcodeToFile, + -- * 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, + -- * Code generation + CodeGenFunction, CodeGenModule, + -- * Functions + Function, newFunction, newNamedFunction, defineFunction, createFunction, + TFunction, + -- * Global variable creation + Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, + TGlobal, + -- * Globals + Linkage(..), -- * Basic blocks - , appendBasicBlock - , insertBasicBlock - , deleteBasicBlock + BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + -- * Debugging + dumpValue, + -- * Transformations + addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, + addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, + addTargetData ) where - -import Control.Applicative ((<$>)) -import Foreign.C.String (withCString) -import Foreign.Marshal.Utils (toBool) -import Foreign.ForeignPtr (FinalizerPtr, newForeignPtr) -import Foreign.Ptr (Ptr, nullPtr) -import Prelude hiding (mod) - -import qualified LLVM.Core.FFI as FFI -import qualified LLVM.Core.Builder as B -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V - - -createModule :: String -> IO T.Module -createModule name = - withCString name $ \namePtr -> do - ptr <- FFI.moduleCreateWithName namePtr - final <- h2c_module FFI.disposeModule - T.Module <$> newForeignPtr final ptr - -foreign import ccall "wrapper" h2c_module - :: (FFI.ModuleRef -> IO ()) -> IO (FinalizerPtr a) - - -createModuleProviderForExistingModule :: T.Module -> IO T.ModuleProvider -createModuleProviderForExistingModule mod = - T.withModule mod $ \modPtr -> do - ptr <- FFI.createModuleProviderForExistingModule modPtr - final <- h2c_moduleProvider FFI.disposeModuleProvider - T.ModuleProvider <$> newForeignPtr final ptr - -foreign import ccall "wrapper" h2c_moduleProvider - :: (FFI.ModuleProviderRef -> IO ()) -> IO (FinalizerPtr a) - - -addTypeName :: (T.Type t) => T.Module -> t -> String -> IO Bool -addTypeName mod typ name = - T.withModule mod $ \modPtr -> - withCString name $ \namePtr -> - toBool <$> FFI.addTypeName modPtr namePtr (T.typeRef typ) - -deleteTypeName :: T.Module -> String -> IO () -deleteTypeName mod name = - T.withModule mod $ \modPtr -> - withCString name $ FFI.deleteTypeName modPtr - -addGlobal :: (T.Type t) => T.Module -> t -> String -> IO (V.GlobalVar t) -addGlobal mod typ name = - T.withModule mod $ \modPtr -> - withCString name $ \namePtr -> - V.GlobalVar . V.mkAnyValue <$> FFI.addGlobal modPtr (T.typeRef typ) namePtr - -setInitializer :: V.ConstValue t => V.GlobalVar a -> t -> IO () -setInitializer global cnst = - FFI.setInitializer (V.valueRef global) (V.valueRef cnst) - -addFunction :: (T.Params p) => T.Module -> String -> T.Function r p - -> IO (V.Function r p) -addFunction mod name typ = - T.withModule mod $ \modPtr -> - withCString name $ \namePtr -> - V.Function . V.mkAnyValue <$> FFI.addFunction modPtr namePtr (T.typeRef typ) - -deleteFunction :: V.Function r p -> IO () -deleteFunction = FFI.deleteFunction . V.valueRef - -maybePtr :: (Ptr a -> b) -> Ptr a -> Maybe b -maybePtr f ptr | ptr /= nullPtr = Just (f ptr) - | otherwise = Nothing - -getNamedFunction :: T.Module -> String -> IO (Maybe (V.Function r p)) -getNamedFunction mod name = - T.withModule mod $ \modPtr -> - withCString name $ \namePtr -> - maybePtr (V.Function . V.mkAnyValue) <$> FFI.getNamedFunction modPtr namePtr +import qualified LLVM.FFI.Core as FFI +import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul) +import LLVM.Core.CodeGen +import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule) +import LLVM.Core.Data +import LLVM.Core.Instructions +import LLVM.Core.Type -appendBasicBlock :: V.Function r p -> String -> IO B.BasicBlock -appendBasicBlock func name = - withCString name $ \namePtr -> - B.BasicBlock . V.mkAnyValue <$> FFI.appendBasicBlock (V.valueRef func) namePtr +-- |Print a value. +dumpValue :: Value a -> IO () +dumpValue (Value v) = FFI.dumpValue v -insertBasicBlock :: B.BasicBlock -> String -> IO B.BasicBlock -insertBasicBlock before name = - withCString name $ \namePtr -> - B.BasicBlock . V.mkAnyValue <$> FFI.insertBasicBlock (V.valueRef before) namePtr +{- +dumpType :: forall a . (IsType a) => Value a -> IO () +dumpType _ = FFI.dumpValue (typeRef (undefined :: a)) +-} -deleteBasicBlock :: B.BasicBlock -> IO () -deleteBasicBlock = FFI.deleteBasicBlock . V.valueRef +-- TODO for types: +-- Enforce free is only called on malloc memory. (Enforce only one free?) +-- Enforce phi nodes a accessor of variables outside the bb +-- Enforce bb terminator +-- Enforce phi first +-- +-- TODO: +-- Add Struct, PackedStruct types +-- Get alignment from code gen diff --git a/LLVM/Core/Builder.hs b/LLVM/Core/Builder.hs deleted file mode 100644 --- a/LLVM/Core/Builder.hs +++ /dev/null @@ -1,498 +0,0 @@ -{-# LANGUAGE - DeriveDataTypeable - , FlexibleContexts - , FunctionalDependencies - , MultiParamTypeClasses - , UndecidableInstances - #-} - -module LLVM.Core.Builder - ( - Instruction(..) - , BasicBlock(..) - - -- * Instruction building - , createBuilder - - , positionBefore - , positionAtEnd - - -- * Terminators - , retVoid - , ret - , br - , condBr - , switch - , invoke - , unwind - , unreachable - - -- * Arithmetic - , add - , sub - , mul - , uDiv - , sDiv - , fDiv - , uRem - , sRem - , fRem - , shl - , lShr - , aShr - , and - , or - , xor - , neg - , not - - -- * Memory - , malloc - , arrayMalloc - , alloca - , arrayAlloca - , free - , load - , store - , getElementPtr - - -- * Casts - , trunc - , zExt - , sExt - , fpToUI - , fpToSI - , uiToFP - , siToFP - , fpTrunc - , fpExt - , ptrToInt - , intToPtr - , bitCast - - -- * Comparisons - , icmp - , fcmp - - -- * Miscellaneous instructions - , call - , call_ - , extractElement - , insertElement - , phi - , select - , vaArg - , shuffleVector - ) where - -import Control.Applicative ((<$>)) -import Control.Arrow ((***)) -import Control.Monad (forM_) -import Data.Typeable (Typeable) -import Foreign.C.String (CString, withCString) -import Foreign.ForeignPtr (FinalizerPtr, ForeignPtr, newForeignPtr, - withForeignPtr) -import Foreign.Marshal.Array (withArray, withArrayLen) -import Prelude hiding (and, not, or) - -import qualified LLVM.Core.FFI as FFI -import qualified LLVM.Core.Instruction as I -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V -import LLVM.Core.Type ((:->)(..)) -import LLVM.Core.Value (Instruction(..)) - - -newtype Builder = Builder { - fromBuilder :: ForeignPtr FFI.Builder - } - deriving (Typeable) - -newtype BasicBlock = BasicBlock V.AnyValue - deriving (V.DynamicValue, Typeable, V.Value) - -withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a -withBuilder = withForeignPtr . fromBuilder - -createBuilder :: IO Builder -createBuilder = do - final <- h2c_builder FFI.disposeBuilder - ptr <- FFI.createBuilder - Builder <$> newForeignPtr final ptr - -foreign import ccall "wrapper" h2c_builder - :: (FFI.BuilderRef -> IO ()) -> IO (FinalizerPtr a) - -positionBefore :: Builder -> Instruction a -> IO () -positionBefore bld insn = - withBuilder bld $ \bldPtr -> - FFI.positionBefore bldPtr (V.valueRef insn) - -positionAtEnd :: Builder -> BasicBlock -> IO () -positionAtEnd bld bblk = - withBuilder bld $ \bldPtr -> - FFI.positionAtEnd bldPtr (V.valueRef bblk) - -instruction :: IO FFI.ValueRef -> IO (Instruction t) -instruction = fmap (Instruction . V.mkAnyValue) - -unary :: (V.Value a) - => (FFI.BuilderRef -> FFI.ValueRef -> CString -> IO FFI.ValueRef) - -> Builder -> String -> a -> IO (Instruction t) -unary ffi bld name a = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - Instruction . V.mkAnyValue <$> - ffi bldPtr (V.valueRef a) namePtr - -binary :: (V.Value a, V.Value b) - => (FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> CString - -> IO FFI.ValueRef) - -> Builder -> String -> a -> b -> IO (Instruction t) -binary ffi bld name a b = - withBuilder bld $ \bldPtr -> - withCString name $ instruction . ffi bldPtr (V.valueRef a) (V.valueRef b) - -add :: (T.Arithmetic t, - V.Value a, V.TypedValue a t, - V.Value b, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -add = binary FFI.buildAdd - -sub :: (T.Arithmetic t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -sub = binary FFI.buildSub - -mul :: (T.Arithmetic t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -mul = binary FFI.buildSub - -uDiv :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -uDiv = binary FFI.buildUDiv - -sDiv :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -sDiv = binary FFI.buildSDiv - -fDiv :: (T.Real t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -fDiv = binary FFI.buildFDiv - -uRem :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -uRem = binary FFI.buildURem - -sRem :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -sRem = binary FFI.buildSRem - -fRem :: (T.Real t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -fRem = binary FFI.buildFRem - -shl :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -shl = binary FFI.buildShl - -lShr :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -lShr = binary FFI.buildLShr - -aShr :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -aShr = binary FFI.buildAShr - -and :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -and = binary FFI.buildAnd - -or :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -or = binary FFI.buildOr - -xor :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> a -> b -> IO (Instruction t) -xor = binary FFI.buildAnd - -neg :: (T.Arithmetic t, V.TypedValue v t) - => Builder -> String -> v -> IO (Instruction t) -neg = unary FFI.buildNeg - -not :: (T.Arithmetic t, V.TypedValue v t) - => Builder -> String -> v -> IO (Instruction t) -not = unary FFI.buildNot - -typed :: (V.Value v, T.Type s, T.Type t) - => (FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> CString - -> IO FFI.ValueRef) - -> Builder -> String -> v -> s -> IO (Instruction t) -typed ffi bld name a t = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - Instruction . V.mkAnyValue <$> ffi bldPtr (V.valueRef a) (T.typeRef t) namePtr - -trunc :: (T.Integer s, V.TypedValue v s, T.Integer t) - => Builder -> String -> v -> s -> IO (Instruction t) -trunc = typed FFI.buildTrunc - -zExt :: (T.Integer s, V.TypedValue v s, T.Integer t) - => Builder -> String -> v -> s -> IO (Instruction t) -zExt = typed FFI.buildZExt - -sExt :: (T.Integer s, V.TypedValue v s, T.Integer t) - => Builder -> String -> v -> s -> IO (Instruction t) -sExt = typed FFI.buildSExt - -fpToUI :: (T.Integer s, V.TypedValue v s, T.Real t) - => Builder -> String -> v -> s -> IO (Instruction t) -fpToUI = typed FFI.buildFPToUI - -fpToSI :: (T.Integer s, V.TypedValue v s, T.Real t) - => Builder -> String -> v -> s -> IO (Instruction t) -fpToSI = typed FFI.buildFPToSI - -uiToFP :: (T.Real s, V.TypedValue v s, T.Integer t) - => Builder -> String -> v -> s -> IO (Instruction t) -uiToFP = typed FFI.buildUIToFP - -siToFP :: (T.Real s, V.TypedValue v s, T.Integer t) - => Builder -> String -> v -> s -> IO (Instruction t) -siToFP = typed FFI.buildSIToFP - -fpTrunc :: (T.Real s, V.TypedValue v s, T.Real t) - => Builder -> String -> v -> s -> IO (Instruction t) -fpTrunc = typed FFI.buildFPTrunc - -fpExt :: (T.Real s, V.TypedValue v s, T.Real t) - => Builder -> String -> v -> s -> IO (Instruction t) -fpExt = typed FFI.buildFPExt - -ptrToInt :: (V.TypedValue (T.Pointer s) s, T.Integer t) - => Builder -> String -> T.Pointer s -> s -> IO (Instruction t) -ptrToInt = typed FFI.buildPtrToInt - -intToPtr :: (T.Integer s, V.TypedValue v s, T.Type t) - => Builder -> String -> v -> t -> IO (Instruction (T.Pointer t)) -intToPtr = typed FFI.buildIntToPtr - -bitCast :: (V.TypedValue v s, T.Type t) - => Builder -> String -> v -> s -> IO (Instruction t) -bitCast = typed FFI.buildBitCast - -fcmp :: (T.Real t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> I.RealPredicate -> a -> b - -> IO (Instruction T.Int1) -fcmp bld name p = binary (flip FFI.buildFCmp (I.fromRP p)) bld name - -icmp :: (T.Integer t, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> I.IntPredicate -> a -> b - -> IO (Instruction T.Int1) -icmp bld name p = binary (flip FFI.buildICmp (I.fromIP p)) bld name - -retVoid :: Builder -> IO (Instruction T.Void) -retVoid bld = withBuilder bld $ instruction . FFI.buildRetVoid - -ret :: (T.FirstClass t, V.TypedValue v t) => Builder -> v -> IO (Instruction t) -ret bld v = - withBuilder bld $ \bldPtr -> - instruction $ FFI.buildRet bldPtr (V.valueRef v) - -br :: Builder -> BasicBlock -> IO (Instruction T.Void) -br bld bblk = - withBuilder bld $ \bldPtr -> - instruction $ FFI.buildBr bldPtr (V.valueRef bblk) - -condBr :: (V.TypedValue v T.Int1) - => Builder -> v -> BasicBlock -> BasicBlock - -> IO (Instruction T.Void) -condBr bld bit true false = - withBuilder bld $ \bldPtr -> - instruction $ FFI.buildCondBr bldPtr (V.valueRef bit) - (V.valueRef true) (V.valueRef false) - -unwrap :: (V.Value a, V.Value b) => (a, b) -> (FFI.ValueRef, FFI.ValueRef) -unwrap = V.valueRef *** V.valueRef - -switch :: (T.Integer t, V.TypedValue v t) - => Builder -> v -> BasicBlock -> [(v, BasicBlock)] - -> IO (Instruction T.Void) -switch bld val noMatch cases = - withBuilder bld $ \bldPtr -> do - inst <- FFI.buildSwitch bldPtr (V.valueRef val) - (V.valueRef noMatch) (fromIntegral $ length cases) - forM_ (map unwrap cases) $ uncurry (FFI.addCase inst) - instruction $ return inst - -invoke :: (T.DynamicType r, T.Params p, Params p v, T.FirstClass r) - => Builder -> String -> V.Function r p -> v - -> BasicBlock -> BasicBlock -> IO (Instruction r) -invoke bld name func args thenBlk catchBlk = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - withArrayLen (argList func args) $ \argLen argPtr -> - instruction $ FFI.buildInvoke bldPtr (V.valueRef func) argPtr - (fromIntegral argLen) (V.valueRef thenBlk) - (V.valueRef catchBlk) namePtr - -unwind :: Builder -> IO (Instruction T.Void) -unwind bld = withBuilder bld $ instruction . FFI.buildUnwind - -unreachable :: Builder -> IO (Instruction T.Void) -unreachable bld = withBuilder bld $ instruction . FFI.buildUnreachable - -allocWith :: (T.Type t) - => (FFI.BuilderRef -> FFI.TypeRef -> CString -> IO FFI.ValueRef) - -> Builder -> String -> t -> IO FFI.ValueRef -allocWith ffi bld name typ = - withBuilder bld $ \bldPtr -> - withCString name $ ffi bldPtr (T.typeRef typ) - -arrayAllocWith :: (T.Type t, T.Integer n, V.TypedValue v n) - => (FFI.BuilderRef -> FFI.TypeRef -> FFI.ValueRef -> CString - -> IO FFI.ValueRef) - -> Builder -> String -> t -> v -> IO FFI.ValueRef -arrayAllocWith ffi bld name typ count = - withBuilder bld $ \bldPtr -> - withCString name $ ffi bldPtr (T.typeRef typ) (V.valueRef count) - -malloc :: (T.Type t) => Builder -> String -> t -> IO (Instruction (T.Array t)) -malloc bld name typ = instruction $ allocWith FFI.buildMalloc bld name typ - -arrayMalloc :: (T.Type t, V.TypedValue v T.Int32) - => Builder -> String -> t -> v -> IO (Instruction (T.Array t)) -arrayMalloc bld name typ count = - instruction $ arrayAllocWith FFI.buildArrayMalloc bld name typ count - -alloca :: (T.Type t) - => Builder -> String -> t -> IO (Instruction (T.Pointer t)) -alloca bld name typ = instruction $ allocWith FFI.buildAlloca bld name typ - -arrayAlloca :: (T.Type t, V.TypedValue v T.Int32) - => Builder -> String -> t -> v -> IO (Instruction (T.Pointer t)) -arrayAlloca bld name typ count = - instruction $ arrayAllocWith FFI.buildArrayAlloca bld name typ count - -free :: (V.TypedValue v (T.Pointer t)) - => Builder -> v -> IO (Instruction T.Void) -free bld ary = - withBuilder bld $ \bldPtr -> - instruction $ FFI.buildFree bldPtr (V.valueRef ary) - -load :: (V.TypedValue v (T.Pointer t)) - => Builder -> String -> v -> IO (Instruction t) -load bld name ptr = - withBuilder bld $ \bldPtr -> - instruction $ withCString name $ FFI.buildLoad bldPtr (V.valueRef ptr) - -store :: (V.TypedValue v t, V.TypedValue p (T.Pointer t)) - => Builder -> v -> p -> IO (Instruction T.Void) -store bld val ptr = - withBuilder bld $ \bldPtr -> - instruction $ FFI.buildStore bldPtr (V.valueRef val) (V.valueRef ptr) - -getElementPtr :: (T.Sequence s e, V.TypedValue p s, - T.Integer t, V.TypedValue i t) - => Builder -> String -> p -> [i] - -> IO (Instruction (T.Pointer e)) -getElementPtr bld name ptr idxs = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - withArrayLen (map V.valueRef idxs) $ \idxLen idxPtr -> - instruction $ FFI.buildGEP bldPtr (V.valueRef ptr) idxPtr - (fromIntegral idxLen) namePtr - -argList :: (Params p a, T.Params p, V.TypedValue v (T.Function r p)) - => v -> a -> [FFI.ValueRef] -argList func = map V.valueRef . toAnyList (T.params (V.typeOf func)) - -callRef :: (T.DynamicType r, T.Params p, Params p v) - => Builder -> String -> V.Function r p -> v -> IO FFI.ValueRef -callRef bld name func args = do - withBuilder bld $ \bldPtr -> - withArrayLen (argList func args) $ \argLen argPtr -> - withCString name $ \namePtr -> - FFI.buildCall bldPtr (V.valueRef func) argPtr - (fromIntegral argLen) namePtr - -class Params t v | t -> v where - toAnyList :: t -> v -> [V.AnyValue] - -listValue :: (V.TypedValue v t) => t -> v -> [V.AnyValue] -listValue _ v = [V.anyValue v] - -instance (V.TypedValue v a, Params b c) => Params (a :-> b) (v :-> c) where - toAnyList t (a :-> b) = V.anyValue a : toAnyList (T.cdr t) b - -instance (V.TypedValue v T.Int32) => Params T.Int32 v where - toAnyList = listValue - -instance (T.Type t, V.TypedValue v (T.Pointer t)) => Params (T.Pointer t) v where - toAnyList = listValue - -call :: (T.DynamicType r, T.Params p, Params p v, T.FirstClass r) - => Builder -> String -> V.Function r p -> v - -> IO (Instruction r) -call bld name func args = instruction $ callRef bld name func args - -call_ :: (T.DynamicType r, T.Params p, Params p v) - => Builder -> String -> V.Function r p -> v -> IO () -call_ bld name func args = callRef bld name func args >> return () - -extractElement :: (V.TypedValue v (T.Vector t), - V.TypedValue i T.Int32) - => Builder -> String -> v -> i -> IO (Instruction t) -extractElement bld name vec idx = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - instruction $ FFI.buildExtractElement bldPtr (V.valueRef vec) - (V.valueRef idx) namePtr - -insertElement :: (V.TypedValue v (T.Vector t), - V.TypedValue e t, - V.TypedValue i T.Int32) - => Builder -> String -> v -> e -> i -> IO (Instruction t) -insertElement bld name vec elt idx = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - instruction $ FFI.buildInsertElement bldPtr (V.valueRef vec) - (V.valueRef elt) (V.valueRef idx) namePtr - -phi :: (V.TypedValue v t) - => Builder -> String -> t -> [(v, BasicBlock)] -> IO (Instruction t) -phi bld name typ incoming = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> do - inst <- FFI.buildPhi bldPtr (T.typeRef typ) namePtr - let (vals, bblks) = unzip . map unwrap $ incoming - withArrayLen vals $ \count valPtr -> - withArray bblks $ \bblkPtr -> - FFI.addIncoming inst valPtr bblkPtr (fromIntegral count) - instruction $ return inst - -select :: (V.TypedValue p T.Int1, V.TypedValue a t, V.TypedValue b t) - => Builder -> String -> p -> a -> b -> IO (Instruction t) -select bld name bit true false = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> do - instruction $ FFI.buildSelect bldPtr (V.valueRef bit) - (V.valueRef true) (V.valueRef false) namePtr - -vaArg :: (V.Value v, T.Type t) - => Builder -> String -> v -> t -> IO (Instruction t) -vaArg bld name valist typ = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - instruction $ FFI.buildVAArg bldPtr (V.valueRef valist) - (T.typeRef typ) namePtr - -shuffleVector :: (V.TypedValue a (T.Vector t), - V.TypedValue b (T.Vector t), - V.TypedValue m (T.Vector T.Int32)) - => Builder -> String -> a -> b -> m - -> IO (Instruction (T.Vector t)) -shuffleVector bld name a b mask = - withBuilder bld $ \bldPtr -> - withCString name $ \namePtr -> - instruction $ FFI.buildShuffleVector bldPtr (V.valueRef a) - (V.valueRef b) (V.valueRef mask) namePtr diff --git a/LLVM/Core/CodeGen.hs b/LLVM/Core/CodeGen.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/CodeGen.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, TypeSynonymInstances, UndecidableInstances, FlexibleContexts #-} +module LLVM.Core.CodeGen( + -- * Module creation + newModule, newNamedModule, defineModule, createModule, + -- * Globals + Linkage(..), + -- * Function creation + Function, newFunction, newNamedFunction, defineFunction, createFunction, + FunctionArgs, + TFunction, + -- * Global variable creation + Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, TGlobal, + -- * Values + Value(..), ConstValue(..), + IsConst(..), valueOf, value, + zero, allOnes, undef, + createString, createStringNul, + -- * Basic blocks + BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + -- * Misc + withCurrentBuilder + ) where +import Control.Monad(liftM, when) +import Data.Int +import Data.Word +import Data.TypeNumbers +import LLVM.Core.CodeGenMonad +import qualified LLVM.FFI.Core as FFI +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 Value a = Value { unValue :: FFI.ValueRef } + +newtype ConstValue a = ConstValue FFI.ValueRef + +class (IsType a) => 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 False +instance IsConst Word16 where constOf = constI False +instance IsConst Word32 where constOf = constI False +instance IsConst Word64 where constOf = constI False +instance IsConst Int8 where constOf = constI True +instance IsConst Int16 where constOf = constI True +instance IsConst Int32 where constOf = constI True +instance IsConst Int64 where constOf = constI True +instance IsConst Float where constOf = constF +instance IsConst Double where constOf = constF +--instance IsConst FP128 where constOf = constF + +{- +instance IsConst (Array n a) where + constOf (Array xs) = + withArrayLen xs $ \ len ptr -> + constArray (typeRef (undefined :: a)) ??? len +-} + +constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a +constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 + +constI :: (IsType a, Integral a) => Bool -> a -> ConstValue a +constI signed i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) + (fromIntegral $ fromEnum signed) + +constF :: (IsType 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 + +-- Not unsafe, just generates a constant. +zero :: forall a . (IsType a) => ConstValue a +zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a) + +-- Not unsafe, just generates a constant. +allOnes :: forall a . (IsInteger a) => ConstValue a +allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a) + +-- Not unsafe, just generates a constant. +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 +-} + +-------------------------------------- + +type FunctionRef = FFI.ValueRef + +-- |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 (fromIntegral $ fromEnum 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 g r . (FunctionArgs f g (CodeGenFunction r ())) + => Function f -- ^ Function to define (created by 'newFunction'). + -> g -- ^ Function body. + -> CodeGenModule () +defineFunction (Value fn) body = do + bld <- liftIO $ U.createBuilder + let body' = do + l <- newBasicBlock + defineBasicBlock l + applyArgs fn body :: CodeGenFunction r () + runCodeGenFunction bld fn body' + return () + +-- | Create a new function with the given body. +createFunction :: (IsFunction f, FunctionArgs f g (CodeGenFunction r ())) + => Linkage + -> g -- ^ Function body. + -> CodeGenModule (Function f) +createFunction linkage body = do + f <- newFunction linkage + defineFunction f body + return f + +-- XXX This is ugly, it must be possible to make it simpler +-- Convert a function of type f = t1->t2->...-> IO r to +-- g = Value t1 -> Value t2 -> ... CodeGenFunction r () +class FunctionArgs f g r | f -> g r, g r -> f where + apArgs :: Int -> FunctionRef -> g -> r + +applyArgs :: (FunctionArgs f g r) => FunctionRef -> g -> r +applyArgs = apArgs 0 + +instance (FunctionArgs b b' r) => FunctionArgs (a -> b) (Value a -> b') r where + apArgs n f g = apArgs (n+1) f (g $ Value $ U.getParam f n) + +-- XXX instances for all IsFirstClass functions, +-- because Haskell can't deal with the context and the FD +type FA a = CodeGenFunction a () +instance FunctionArgs (IO Float) (FA Float) (FA Float) where apArgs _ _ g = g +instance FunctionArgs (IO Double) (FA Double) (FA Double) where apArgs _ _ g = g +instance FunctionArgs (IO FP128) (FA FP128) (FA FP128) where apArgs _ _ g = g +instance (IsTypeNumber n) => + FunctionArgs (IO (IntN n)) (FA (IntN n)) (FA (IntN n)) where apArgs _ _ g = g +instance (IsTypeNumber n) => + FunctionArgs (IO (WordN n)) (FA (WordN n)) (FA (WordN n)) where apArgs _ _ g = g +instance FunctionArgs (IO Bool) (FA Bool) (FA Bool) where apArgs _ _ g = g +instance FunctionArgs (IO Int8) (FA Int8) (FA Int8) where apArgs _ _ g = g +instance FunctionArgs (IO Int16) (FA Int16) (FA Int16) where apArgs _ _ g = g +instance FunctionArgs (IO Int32) (FA Int32) (FA Int32) where apArgs _ _ g = g +instance FunctionArgs (IO Int64) (FA Int64) (FA Int64) where apArgs _ _ g = g +instance FunctionArgs (IO Word8) (FA Word8) (FA Word8) where apArgs _ _ g = g +instance FunctionArgs (IO Word16) (FA Word16) (FA Word16) where apArgs _ _ g = g +instance FunctionArgs (IO Word32) (FA Word32) (FA Word32) where apArgs _ _ g = g +instance FunctionArgs (IO Word64) (FA Word64) (FA Word64) where apArgs _ _ g = g +instance FunctionArgs (IO ()) (FA ()) (FA ()) where apArgs _ _ g = g +instance (IsTypeNumber n, IsPrimitive a) => + FunctionArgs (IO (Vector n a)) (FA (Vector n a)) (FA (Vector n a)) where apArgs _ _ g = g +instance (IsType a) => + FunctionArgs (IO (Ptr a)) (FA (Ptr a)) (FA (Ptr a)) where apArgs _ _ g = g + +-------------------------------------- + +-- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction. +newtype BasicBlock = BasicBlock FFI.BasicBlockRef + +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 + +-------------------------------------- + +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 (fromIntegral $ fromEnum 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 + +type TFunction a = CodeGenModule (Function a) +type TGlobal a = CodeGenModule (Global a) + +-- Special string creators +createString :: String -> TGlobal (Array n Word8) +createString s = string (length s) (U.constString s) + +createStringNul :: String -> TGlobal (Array n Word8) +createStringNul s = string (length s + 1) (U.constStringNul s) + +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 (fromIntegral $ fromEnum InternalLinkage) name typ + FFI.setGlobalConstant g 1 + FFI.setInitializer g s + return g + +-------------------------------------- + +-- |An enumeration for the kinds of linkage for global values. +data Linkage + = ExternalLinkage -- ^Externally visible function + | LinkOnceLinkage -- ^Keep one copy of function when linking (inline) + | WeakLinkage -- ^Keep one copy of named function when linking (weak) + | AppendingLinkage -- ^Special purpose, only applies to global arrays + | InternalLinkage -- ^Rename collisions when linking (static functions) + | DLLImportLinkage -- ^Function to be imported from DLL + | DLLExportLinkage -- ^Function to be accessible from DLL + | ExternalWeakLinkage -- ^ExternalWeak linkage description + | GhostLinkage -- ^Stand-in functions for streaming fns from BC files + deriving (Show, Eq, Ord, Enum) + +{- +-- |An enumeration for the kinds of visibility of global values. +data VisibilityTypes + = DefaultVisibility -- ^The GV is visible + | HiddenVisibility -- ^The GV is hidden + | ProtectedVisibility -- ^The GV is protected + deriving (Show, Eq, Ord, Enum) +-} diff --git a/LLVM/Core/CodeGenMonad.hs b/LLVM/Core/CodeGenMonad.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/CodeGenMonad.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module LLVM.Core.CodeGenMonad( + -- * Module code generation + CodeGenModule, runCodeGenModule, genMSym, getModule, + -- * Function code generation + CodeGenFunction, runCodeGenFunction, genFSym, getFunction, getBuilder, + -- * Reexport + liftIO + ) where +import Control.Monad.State + +import LLVM.Core.Util(Module, Builder, Function) + +-------------------------------------- + +data CGMState = CGMState { + cgm_module :: Module, + cgm_next :: !Int + } +newtype CodeGenModule a = CGM (StateT CGMState IO a) + deriving (Monad, MonadState CGMState, MonadIO) + +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 } + evalStateT body cgm + +-------------------------------------- + +data CGFState r = CGFState { + cgf_builder :: Builder, + cgf_function :: Function, + cgf_next :: !Int + } +newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a) + deriving (Monad, MonadState (CGFState r), MonadIO) + +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 + +runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a +runCodeGenFunction bld fn (CGF body) = do + let cgf = CGFState { cgf_builder = bld, + cgf_function = fn, + cgf_next = 1 } + liftIO $ evalStateT body cgf diff --git a/LLVM/Core/Constant.hs b/LLVM/Core/Constant.hs deleted file mode 100644 --- a/LLVM/Core/Constant.hs +++ /dev/null @@ -1,338 +0,0 @@ -{-# LANGUAGE - DeriveDataTypeable - , FlexibleContexts - , FunctionalDependencies - , MultiParamTypeClasses - #-} - -module LLVM.Core.Constant - ( - -- * Constant expressions - ConstExpr(..) - - -- ** Arithmetic - , neg - , not - , add - , sub - , mul - , udiv - , sdiv - , fdiv - , urem - , srem - , frem - , and - , or - , xor - , shl - , lshr - , ashr - - -- ** Memory - , gep - - -- ** Conversions - , trunc - , sExt - , zExt - , fpTrunc - , fpExt - , uiToFP - , siToFP - , fpToUI - , fpToSI - , ptrToInt - , intToPtr - , bitCast - - -- ** Comparisons - , icmp - , fcmp - - -- ** Miscellaneous operations - , select - , extractElement - , insertElement - , shuffleVector - - -- * Constant values - , Const(..) - - -- ** Scalar constants - , constInt - , constWord - , constReal - - -- ** Composite constants - , constString - , constStringNul - ) where - -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Typeable (Typeable) -import Data.Word (Word8, Word16, Word32, Word64) -import Foreign.C.String (withCStringLen) -import Foreign.Marshal.Utils (fromBool) -import Prelude hiding (and, const, not, or) -import qualified Prelude as Prelude -import System.IO.Unsafe (unsafePerformIO) - -import qualified LLVM.Core.FFI as FFI -import qualified LLVM.Core.Instruction as I -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V - - -newtype ConstExpr t = ConstExpr V.AnyValue - deriving (V.ConstValue, V.DynamicValue, Typeable, V.Value) - -unary :: (V.ConstValue v) => - (FFI.ValueRef -> FFI.ValueRef) -> v -> ConstExpr t -unary ffi = ConstExpr . V.mkAnyValue . ffi . V.valueRef - -neg :: (V.ConstValue v, V.Arithmetic v, T.Arithmetic t) => v -> ConstExpr t -neg = unary FFI.constNeg - -not :: (V.ConstValue v, T.Integer t, V.TypedValue v t) => v -> ConstExpr t -not = unary FFI.constNot - -binary :: (V.ConstValue a, V.ConstValue b) - => (FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef) -> a -> b - -> ConstExpr t -binary ffi a b = ConstExpr . V.mkAnyValue $ ffi (V.valueRef a) (V.valueRef b) - -add :: (T.Arithmetic t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -add = binary FFI.constAdd - -sub :: (T.Arithmetic t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -sub = binary FFI.constSub - -mul :: (T.Arithmetic t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -mul = binary FFI.constMul - -udiv :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -udiv = binary FFI.constUDiv - -sdiv :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -sdiv = binary FFI.constSDiv - -fdiv :: (T.Real t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -fdiv = binary FFI.constFDiv - -urem :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -urem = binary FFI.constURem - -srem :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -srem = binary FFI.constURem - -frem :: (T.Real t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -frem = binary FFI.constFRem - -and :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -and = binary FFI.constAnd - -or :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -or = binary FFI.constOr - -xor :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -xor = binary FFI.constXor - -icmp :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => I.IntPredicate -> a -> b -> ConstExpr T.Int1 -icmp p = binary (FFI.constICmp (I.fromIP p)) - -fcmp :: (T.Real t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => I.RealPredicate -> a -> b -> ConstExpr T.Int1 -fcmp p = binary (FFI.constFCmp (I.fromRP p)) - -shl :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -shl = binary FFI.constShl - -lshr :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -lshr = binary FFI.constLShr - -ashr :: (T.Integer t, V.ConstValue a, V.TypedValue a t, - V.ConstValue b, V.TypedValue b t) - => a -> b -> ConstExpr t -ashr = binary FFI.constAShr - -gep :: (V.ConstValue v, T.Integer t, V.TypedValue v t) - => a -> b -> ConstExpr t -gep = undefined - -typed :: (V.ConstValue v, T.Type s, V.ConstValue w, V.DynamicValue w) - => (FFI.ValueRef -> FFI.TypeRef -> FFI.ValueRef) -> v -> s -> w -typed ffi a b = V.fromAnyValue . V.mkAnyValue $ ffi (V.valueRef a) (T.typeRef b) - -trunc :: (V.ConstValue v, T.Integer s, V.TypedValue v s, - V.ConstValue w, V.DynamicValue w, T.Integer t, V.TypedValue w t) - => v -> t -> w -trunc = typed FFI.constTrunc - -sExt :: (V.ConstValue v, T.Integer t, V.TypedValue v t) - => v -> t -> ConstExpr t -sExt = typed FFI.constSExt - -zExt :: (V.ConstValue v, T.Integer t, V.TypedValue v t) - => v -> t -> ConstExpr t -zExt = typed FFI.constZExt - -fpTrunc :: (V.ConstValue v, V.Real v, T.Real t) - => v -> t -> ConstExpr t -fpTrunc = typed FFI.constFPTrunc - -fpExt :: (V.ConstValue v, V.Real v, T.Real t) - => v -> t -> ConstExpr t -fpExt = typed FFI.constFPExt - --- XXX How to express the inability to cast from scalar to vector? - -uiToFP :: (V.ConstValue v, T.Integer s, V.TypedValue v s, T.Real t) - => v -> s -> ConstExpr t -uiToFP = typed FFI.constUIToFP - -siToFP :: (V.ConstValue v, V.Integer v, T.Integer s, T.Real t) - => v -> s -> ConstExpr t -siToFP = typed FFI.constSIToFP - -fpToUI :: (V.ConstValue v, V.Real v, T.Real s, T.Integer t) - => v -> s -> ConstExpr t -fpToUI = typed FFI.constFPToUI - -fpToSI :: (V.ConstValue v, V.Real v, T.Real s, T.Integer t) - => v -> s -> ConstExpr t -fpToSI = typed FFI.constFPToSI - -ptrToInt :: (V.ConstValue v, T.Integer t) - => v -> T.Pointer a -> ConstExpr t -ptrToInt = typed FFI.constPtrToInt - -intToPtr :: (V.ConstValue v, T.Integer t) - => v -> t -> ConstExpr (T.Pointer a) -intToPtr = typed FFI.constIntToPtr - --- XXX How to express pointer/non-pointer and bit-width constraints? -bitCast :: (V.ConstValue v, T.Type t, - V.ConstValue w, V.DynamicValue w) - => v -> t -> w -bitCast = typed FFI.constBitCast - -select :: (V.TypedValue k T.Int1, - V.ConstValue a, V.TypedValue a t, V.ConstValue b, V.TypedValue b t) - => k -> a -> b -> ConstExpr t -select k = binary (FFI.constSelect (V.valueRef k)) - -extractElement :: (V.ConstValue v, V.TypedValue v (T.Vector a), - V.ConstValue i, V.Integer i) => v -> i -> ConstExpr a -extractElement = binary FFI.constExtractElement - -ternary :: (V.ConstValue a, V.ConstValue b, V.ConstValue c) - => (FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef) - -> a -> b -> c -> ConstExpr t -ternary ffi a b c = ConstExpr . V.mkAnyValue $ - ffi (V.valueRef a) (V.valueRef b) (V.valueRef c) - -insertElement :: (V.ConstValue v, V.TypedValue v (T.Vector a), - V.ConstValue e, V.TypedValue e a, - V.ConstValue i, V.Integer i) - => v -> e -> i -> ConstExpr (T.Vector a) -insertElement = ternary FFI.constInsertElement - -shuffleVector :: (V.ConstValue v1, V.TypedValue v1 (T.Vector a), - V.ConstValue v2, V.TypedValue v2 (T.Vector a), - V.ConstValue m, V.TypedValue m (T.Vector T.Int32)) - => v1 -> v2 -> m -> ConstExpr (T.Vector a) -shuffleVector = ternary FFI.constShuffleVector - -constWord :: (T.Integer t, Integral a) => (b -> t) -> a -> V.ConstInt t -constWord typ val = - V.ConstInt . V.mkAnyValue $ FFI.constInt (T.typeRef (typ undefined)) - (fromIntegral val) 0 - -constInt :: (T.Integer t, Integral a) => (b -> t) -> a -> V.ConstInt t -constInt typ val = - V.ConstInt . V.mkAnyValue $ FFI.constInt (T.typeRef (typ undefined)) - (fromIntegral val) 1 - -constReal :: (T.Real t, RealFloat a) => (b -> t) -> a -> V.ConstReal t -constReal typ val = V.ConstReal . V.mkAnyValue $ FFI.constReal - (T.typeRef (typ undefined)) (realToFrac val) - -constStringInternal :: Bool -> String -> V.ConstArray T.Int8 -constStringInternal nulTerm s = unsafePerformIO $ - withCStringLen s $ \(sPtr, sLen) -> - return . V.ConstArray . V.mkAnyValue $ - FFI.constString sPtr (fromIntegral sLen) (fromBool (Prelude.not nulTerm)) - -constString :: String -> V.ConstArray T.Int8 -constString = constStringInternal False - -constStringNul :: String -> V.ConstArray T.Int8 -constStringNul = constStringInternal True - -class V.ConstValue t => Const a t | a -> t where - const :: a -> t - -instance Const String (V.ConstArray T.Int8) where - const = constStringNul - -instance Const Float (V.ConstReal T.Float) where - const = constReal T.float . fromRational . toRational - -instance Const Double (V.ConstReal T.Double) where - const = constReal T.double - -instance Const Int8 (V.ConstInt T.Int8) where - const = constInt T.int8 . fromIntegral - -instance Const Int16 (V.ConstInt T.Int16) where - const = constInt T.int16 . fromIntegral - -instance Const Int32 (V.ConstInt T.Int32) where - const = constInt T.int32 . fromIntegral - -instance Const Int64 (V.ConstInt T.Int64) where - const = constInt T.int64 - -instance Const Word8 (V.ConstInt T.Int8) where - const = constWord T.int8 . fromIntegral - -instance Const Word16 (V.ConstInt T.Int16) where - const = constWord T.int16 . fromIntegral - -instance Const Word32 (V.ConstInt T.Int32) where - const = constWord T.int32 . fromIntegral - -instance Const Word64 (V.ConstInt T.Int64) where - const = constWord T.int64 . fromIntegral diff --git a/LLVM/Core/Data.hs b/LLVM/Core/Data.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Data.hs @@ -0,0 +1,35 @@ +module LLVM.Core.Data(IntN(..), WordN(..), FP128(..), + Array(..), Vector(..), Ptr(..)) where +import Data.TypeNumbers + +-- 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 @IsTypeNumber@. +newtype (IsTypeNumber n) => IntN n = IntN Integer + deriving (Show) + +-- |Variable sized unsigned integer. +-- The /n/ parameter should belong to @IsTypeNumber@. +newtype (IsTypeNumber n) => WordN n = WordN Integer + deriving (Show) + +-- |128 bit floating point. +newtype FP128 = FP128 Rational + deriving (Show) + +-- |Fixed sized arrays, the array size is encoded in the /n/ parameter. +newtype (IsTypeNumber n) => Array n a = Array [a] + deriving (Show) + +-- XXX Power of 2 size constraint not enforced +-- |Fixed sized vector, the array size is encoded in the /n/ parameter. +newtype Vector n a = Vector (Array n a) + deriving (Show) + +-- |Pointer type. +newtype Ptr a = Ptr a + deriving (Show) diff --git a/LLVM/Core/FFI.hsc b/LLVM/Core/FFI.hsc deleted file mode 100644 --- a/LLVM/Core/FFI.hsc +++ /dev/null @@ -1,628 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} - -module LLVM.Core.FFI - ( - -- * Modules - Module - , ModuleRef - , moduleCreateWithName - , disposeModule - - -- * Module providers - , ModuleProvider - , ModuleProviderRef - , createModuleProviderForExistingModule - , disposeModuleProvider - - -- * Types - , Type - , TypeRef - , addTypeName - , deleteTypeName - , getElementType - - -- ** Integer types - , int1Type - , int8Type - , int16Type - , int32Type - , int64Type - , integerType - - -- ** Real types - , floatType - , doubleType - , x86FP80Type - , fp128Type - , ppcFP128Type - - -- ** Function types - , functionType - , isFunctionVarArg - , getReturnType - , countParamTypes - , getParamTypes - - -- ** Other types - , voidType - - -- ** Array, pointer, and vector types - , arrayType - , pointerType - , vectorType - - -- * Values - , Value - , ValueRef - , addGlobal - , deleteGlobal - , setInitializer - , typeOf - , getValueName - , setValueName - , dumpValue - - -- ** Functions - , addFunction - , deleteFunction - , getNamedFunction - , countParams - , getParam - , getParams - - -- * Constants - - -- ** Scalar constants - , constInt - , constReal - - -- ** Composite constants - , constString - - -- ** Constant expressions - , constNeg - , constNot - , constAdd - , constSub - , constMul - , constUDiv - , constSDiv - , constFDiv - , constURem - , constSRem - , constFRem - , constAnd - , constOr - , constXor - , constICmp - , constFCmp - , constShl - , constLShr - , constAShr - , constGEP - , constTrunc - , constSExt - , constZExt - , constFPTrunc - , constFPExt - , constUIToFP - , constSIToFP - , constFPToUI - , constFPToSI - , constPtrToInt - , constIntToPtr - , constBitCast - , constSelect - , constExtractElement - , constInsertElement - , constShuffleVector - - -- * Basic blocks - , BasicBlock - , BasicBlockRef - , appendBasicBlock - , insertBasicBlock - , deleteBasicBlock - , getEntryBasicBlock - - -- * Instruction building - , Builder - , BuilderRef - , createBuilder - , disposeBuilder - , positionBefore - , positionAtEnd - - -- ** Terminators - , buildRetVoid - , buildRet - , buildBr - , buildCondBr - , buildSwitch - , buildInvoke - , buildUnwind - , buildUnreachable - - -- ** Arithmetic - , buildAdd - , buildSub - , buildMul - , buildUDiv - , buildSDiv - , buildFDiv - , buildURem - , buildSRem - , buildFRem - , buildShl - , buildLShr - , buildAShr - , buildAnd - , buildOr - , buildXor - , buildNeg - , buildNot - - -- ** Memory - , buildMalloc - , buildArrayMalloc - , buildAlloca - , buildArrayAlloca - , buildFree - , buildLoad - , buildStore - , buildGEP - - -- ** Casts - , buildTrunc - , buildZExt - , buildSExt - , buildFPToUI - , buildFPToSI - , buildUIToFP - , buildSIToFP - , buildFPTrunc - , buildFPExt - , buildPtrToInt - , buildIntToPtr - , buildBitCast - - -- ** Comparisons - , buildICmp - , buildFCmp - - -- ** Miscellaneous instructions - , buildPhi - , buildCall - , buildSelect - , buildVAArg - , buildExtractElement - , buildInsertElement - , buildShuffleVector - - -- ** Other helpers - , addCase - , addIncoming - ) where - -import Foreign.C.String (CString) -import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) -import Foreign.Ptr (Ptr) - -#include - -data Module -type ModuleRef = Ptr Module - -foreign import ccall unsafe "LLVMModuleCreateWithName" moduleCreateWithName - :: CString -> IO ModuleRef - -foreign import ccall unsafe "LLVMDisposeModule" disposeModule - :: ModuleRef -> IO () - - -data ModuleProvider -type ModuleProviderRef = Ptr ModuleProvider - -foreign import ccall unsafe "LLVMCreateModuleProviderForExistingModule" - createModuleProviderForExistingModule - :: ModuleRef -> IO ModuleProviderRef - -foreign import ccall unsafe "LLVMDisposeModuleProvider" disposeModuleProvider - :: ModuleProviderRef -> IO () - - -data Type -type TypeRef = Ptr Type - -foreign import ccall unsafe "LLVMInt1Type" int1Type :: TypeRef - -foreign import ccall unsafe "LLVMInt8Type" int8Type :: TypeRef - -foreign import ccall unsafe "LLVMInt16Type" int16Type :: TypeRef - -foreign import ccall unsafe "LLVMInt32Type" int32Type :: TypeRef - -foreign import ccall unsafe "LLVMInt64Type" int64Type :: TypeRef - --- | An integer type of the given width. -foreign import ccall unsafe "LLVMIntType" integerType - :: CUInt -- ^ width in bits - -> TypeRef - -foreign import ccall unsafe "LLVMFloatType" floatType :: TypeRef - -foreign import ccall unsafe "LLVMDoubleType" doubleType :: TypeRef - -foreign import ccall unsafe "LLVMX86FP80Type" x86FP80Type :: TypeRef - -foreign import ccall unsafe "LLVMFP128Type" fp128Type :: TypeRef - -foreign import ccall unsafe "LLVMPPCFP128Type" ppcFP128Type :: TypeRef - -foreign import ccall unsafe "LLVMVoidType" voidType :: TypeRef - --- | Create a function type. -foreign import ccall unsafe "LLVMFunctionType" functionType - :: TypeRef -- ^ return type - -> Ptr TypeRef -- ^ array of argument types - -> CUInt -- ^ number of elements in array - -> CInt -- ^ non-zero if function is varargs - -> TypeRef - --- | Indicate whether a function takes varargs. -foreign import ccall unsafe "LLVMIsFunctionVarArg" isFunctionVarArg - :: TypeRef -> CInt - --- | Give a function's return type. -foreign import ccall unsafe "LLVMGetReturnType" getReturnType - :: TypeRef -> TypeRef - --- | Give the number of fixed parameters that a function takes. -foreign import ccall unsafe "LLVMCountParamTypes" countParamTypes - :: TypeRef -> CUInt - --- | Fill out an array with the types of a function's fixed --- parameters. -foreign import ccall unsafe "LLVMGetParamTypes" getParamTypes - :: TypeRef -> Ptr TypeRef -> IO () - -foreign import ccall unsafe "LLVMArrayType" arrayType - :: TypeRef -- ^ element type - -> CUInt -- ^ element count - -> TypeRef - -foreign import ccall unsafe "LLVMPointerType" pointerType - :: TypeRef -- ^ pointed-to type - -> CUInt -- ^ address space - -> TypeRef - -foreign import ccall unsafe "LLVMVectorType" vectorType - :: TypeRef -- ^ element type - -> CUInt -- ^ element count - -> TypeRef - -foreign import ccall unsafe "LLVMAddTypeName" addTypeName - :: ModuleRef -> CString -> TypeRef -> IO CInt - -foreign import ccall unsafe "LLVMDeleteTypeName" deleteTypeName - :: ModuleRef -> CString -> IO () - --- | Give the type of a sequential type's elements. -foreign import ccall unsafe "LLVMGetElementType" getElementType - :: TypeRef -> TypeRef - - -data Value -type ValueRef = Ptr Value - -foreign import ccall unsafe "LLVMAddGlobal" addGlobal - :: ModuleRef -> TypeRef -> CString -> IO ValueRef - -foreign import ccall unsafe "LLVMDeleteGlobal" deleteGlobal - :: ValueRef -> IO () - -foreign import ccall unsafe "LLVMSetInitializer" setInitializer - :: ValueRef -> ValueRef -> IO () - -foreign import ccall unsafe "LLVMTypeOf" typeOf - :: ValueRef -> IO TypeRef - -foreign import ccall unsafe "LLVMGetValueName" getValueName - :: ValueRef -> IO CString - -foreign import ccall unsafe "LLVMSetValueName" setValueName - :: ValueRef -> CString -> IO () - -foreign import ccall unsafe "LLVMDumpValue" dumpValue - :: ValueRef -> IO () - -foreign import ccall unsafe "LLVMGetNamedFunction" getNamedFunction - :: ModuleRef -> CString -> IO ValueRef - -foreign import ccall unsafe "LLVMAddFunction" addFunction - :: ModuleRef -> CString -> TypeRef -> IO ValueRef - -foreign import ccall unsafe "LLVMDeleteFunction" deleteFunction - :: ValueRef -> IO () - -foreign import ccall unsafe "LLVMCountParams" countParams - :: ValueRef -> CUInt - -foreign import ccall unsafe "LLVMGetParam" getParam - :: ValueRef -> CUInt -> ValueRef - -foreign import ccall unsafe "LLVMGetParams" getParams - :: ValueRef -> Ptr ValueRef -> IO () - -foreign import ccall unsafe "LLVMConstInt" constInt - :: TypeRef -> CULLong -> CInt -> ValueRef - -foreign import ccall unsafe "LLVMConstReal" constReal - :: TypeRef -> CDouble -> ValueRef - -foreign import ccall unsafe "LLVMConstString" constString - :: CString -> CUInt -> CInt -> ValueRef - -foreign import ccall unsafe "LLVMConstNeg" constNeg - :: ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstNot" constNot - :: ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstAdd" constAdd - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstSub" constSub - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstMul" constMul - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstUDiv" constUDiv - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstSDiv" constSDiv - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFDiv" constFDiv - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstURem" constURem - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstSRem" constSRem - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFRem" constFRem - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstAnd" constAnd - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstOr" constOr - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstXor" constXor - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstICmp" constICmp - :: CInt -> ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFCmp" constFCmp - :: CInt -> ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstShl" constShl - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstLShr" constLShr - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstAShr" constAShr - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstGEP" constGEP - :: ValueRef -> Ptr ValueRef -> CUInt -> ValueRef - -foreign import ccall unsafe "LLVMConstTrunc" constTrunc - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstSExt" constSExt - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstZExt" constZExt - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFPTrunc" constFPTrunc - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFPExt" constFPExt - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstUIToFP" constUIToFP - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstSIToFP" constSIToFP - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFPToUI" constFPToUI - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstFPToSI" constFPToSI - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstPtrToInt" constPtrToInt - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstIntToPtr" constIntToPtr - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstBitCast" constBitCast - :: ValueRef -> TypeRef -> ValueRef - -foreign import ccall unsafe "LLVMConstSelect" constSelect - :: ValueRef -> ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstExtractElement" constExtractElement - :: ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstInsertElement" constInsertElement - :: ValueRef -> ValueRef -> ValueRef -> ValueRef - -foreign import ccall unsafe "LLVMConstShuffleVector" constShuffleVector - :: ValueRef -> ValueRef -> ValueRef -> ValueRef - -type BasicBlock = Value -type BasicBlockRef = Ptr BasicBlock - -foreign import ccall unsafe "LLVMAppendBasicBlock" appendBasicBlock - :: ValueRef -> CString -> IO BasicBlockRef - -foreign import ccall unsafe "LLVMInsertBasicBlock" insertBasicBlock - :: BasicBlockRef -> CString -> IO BasicBlockRef - -foreign import ccall unsafe "LLVMDeleteBasicBlock" deleteBasicBlock - :: BasicBlockRef -> IO () - -foreign import ccall unsafe "LLVMGetEntryBasicBlock" getEntryBasicBlock - :: ValueRef -> IO BasicBlockRef - -data Builder -type BuilderRef = Ptr Builder - -foreign import ccall unsafe "LLVMCreateBuilder" createBuilder - :: IO BuilderRef - -foreign import ccall unsafe "LLVMDisposeBuilder" disposeBuilder - :: BuilderRef -> IO () - -foreign import ccall unsafe "LLVMPositionBuilderBefore" positionBefore - :: BuilderRef -> ValueRef -> IO () - -foreign import ccall unsafe "LLVMPositionBuilderAtEnd" positionAtEnd - :: BuilderRef -> BasicBlockRef -> IO () - -foreign import ccall unsafe "LLVMBuildRetVoid" buildRetVoid - :: BuilderRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildRet" buildRet - :: BuilderRef -> ValueRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildBr" buildBr - :: BuilderRef -> BasicBlockRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildCondBr" buildCondBr - :: BuilderRef -> ValueRef -> BasicBlockRef -> BasicBlockRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSwitch" buildSwitch - :: BuilderRef -> ValueRef -> BasicBlockRef -> CUInt -> IO ValueRef -foreign import ccall unsafe "LLVMBuildInvoke" buildInvoke - :: BuilderRef -> ValueRef -> Ptr ValueRef -> CUInt - -> BasicBlockRef -> BasicBlockRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildUnwind" buildUnwind - :: BuilderRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildUnreachable" buildUnreachable - :: BuilderRef -> IO ValueRef - -foreign import ccall unsafe "LLVMBuildAdd" buildAdd - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSub" buildSub - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildMul" buildMul - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildUDiv" buildUDiv - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSDiv" buildSDiv - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFDiv" buildFDiv - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildURem" buildURem - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSRem" buildSRem - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFRem" buildFRem - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildShl" buildShl - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildLShr" buildLShr - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildAShr" buildAShr - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildAnd" buildAnd - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildOr" buildOr - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildXor" buildXor - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildNeg" buildNeg - :: BuilderRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildNot" buildNot - :: BuilderRef -> ValueRef -> CString -> IO ValueRef - --- Memory -foreign import ccall unsafe "LLVMBuildMalloc" buildMalloc - :: BuilderRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildArrayMalloc" buildArrayMalloc - :: BuilderRef -> TypeRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildAlloca" buildAlloca - :: BuilderRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildArrayAlloca" buildArrayAlloca - :: BuilderRef -> TypeRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFree" buildFree - :: BuilderRef -> ValueRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildLoad" buildLoad - :: BuilderRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildStore" buildStore - :: BuilderRef -> ValueRef -> ValueRef -> IO ValueRef -foreign import ccall unsafe "LLVMBuildGEP" buildGEP - :: BuilderRef -> ValueRef -> Ptr ValueRef -> CUInt -> CString - -> IO ValueRef - --- Casts -foreign import ccall unsafe "LLVMBuildTrunc" buildTrunc - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildZExt" buildZExt - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSExt" buildSExt - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFPToUI" buildFPToUI - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFPToSI" buildFPToSI - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildUIToFP" buildUIToFP - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSIToFP" buildSIToFP - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFPTrunc" buildFPTrunc - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFPExt" buildFPExt - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildPtrToInt" buildPtrToInt - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildIntToPtr" buildIntToPtr - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildBitCast" buildBitCast - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef - --- Comparisons -foreign import ccall unsafe "LLVMBuildICmp" buildICmp - :: BuilderRef -> CInt -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildFCmp" buildFCmp - :: BuilderRef -> CInt -> ValueRef -> ValueRef -> CString -> IO ValueRef - --- Miscellaneous instructions -foreign import ccall unsafe "LLVMBuildPhi" buildPhi - :: BuilderRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildCall" buildCall - :: BuilderRef -> ValueRef -> Ptr ValueRef -> CUInt -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildSelect" buildSelect - :: BuilderRef -> ValueRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildVAArg" buildVAArg - :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildExtractElement" buildExtractElement - :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildInsertElement" buildInsertElement - :: BuilderRef -> ValueRef -> ValueRef -> ValueRef -> CString -> IO ValueRef -foreign import ccall unsafe "LLVMBuildShuffleVector" buildShuffleVector - :: BuilderRef -> ValueRef -> ValueRef -> ValueRef -> CString -> IO ValueRef - -foreign import ccall unsafe "LLVMAddCase" addCase - :: ValueRef -> ValueRef -> BasicBlockRef -> IO () - -foreign import ccall unsafe "LLVMAddIncoming" addIncoming - :: ValueRef -> Ptr ValueRef -> Ptr ValueRef -> CUInt -> IO () diff --git a/LLVM/Core/Instruction.hs b/LLVM/Core/Instruction.hs deleted file mode 100644 --- a/LLVM/Core/Instruction.hs +++ /dev/null @@ -1,47 +0,0 @@ -module LLVM.Core.Instruction - ( - IntPredicate(..) - , RealPredicate(..) - , fromIP - , fromRP - ) where - -import Foreign.C.Types (CInt) - -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) - -fromIP :: IntPredicate -> CInt -fromIP ip = fromIntegral (fromEnum ip + 32) - -data RealPredicate = - RealFalse -- ^ Always false (always folded) - | RealOEQ -- ^ True if ordered and equal - | RealOGT -- ^ True if ordered and greater than - | RealOGE -- ^ True if ordered and greater than or equal - | RealOLT -- ^ True if ordered and less than - | RealOLE -- ^ True if ordered and less than or equal - | RealONE -- ^ True if ordered and operands are unequal - | RealORD -- ^ True if ordered (no nans) - | RealUNO -- ^ True if unordered: isnan(X) | isnan(Y) - | RealUEQ -- ^ True if unordered or equal - | RealUGT -- ^ True if unordered or greater than - | RealUGE -- ^ True if unordered, greater than, or equal - | RealULT -- ^ True if unordered or less than - | RealULE -- ^ True if unordered, less than, or equal - | RealUNE -- ^ True if unordered or not equal - | RealT -- ^ Always true (always folded) - deriving (Eq, Ord, Enum, Show) - -fromRP :: RealPredicate -> CInt -fromRP = fromIntegral . fromEnum diff --git a/LLVM/Core/Instructions.hs b/LLVM/Core/Instructions.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Instructions.hs @@ -0,0 +1,601 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, FlexibleContexts #-} +module LLVM.Core.Instructions( + -- * Terminator instructions + ret, + condBr, + br, + switch, + invoke, + unwind, + unreachable, + -- * Arithmetic binary operations + -- | Arithmetic operations with the normal semantics. + -- The u instractions are unsigned, the s instructions are signed. + add, sub, mul, + udiv, sdiv, fdiv, urem, srem, frem, + -- * Logical binary operations + -- |Logical instructions with the normal semantics. + shl, lshr, ashr, and, or, xor, + -- * Vector operations + extractelement, + insertelement, + shufflevector, + -- * Memory access + malloc, arrayMalloc, + alloca, arrayAlloca, + free, + load, + store, + getElementPtr, + -- * Conversions + trunc, zext, sext, + fptrunc, fpext, + fptoui, fptosi, + uitofp, sitofp, + ptrtoint, inttoptr, + bitcast, + -- * Comparison + IntPredicate(..), RealPredicate(..), + icmp, fcmp, + select, + -- * Other + phi, addPhiInputs, + call, + -- * Classes and types + Terminate, + Ret, CallArgs, ABinOp, CmpOp, FunctionArgs, IsConst, + AllocArg, + GetElementPtr, IsIndexArg + ) where +import Prelude hiding (and, or) +import Control.Monad(liftM) +import Data.Int +import Data.Word +--import Data.TypeNumbers +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 + +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 is C. +ret :: (Ret a r) => a -> CodeGenFunction r Terminate +ret = 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 + +-------------------------------------- + +-- | 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 + +-------------------------------------- + +-- |Unwind the call stack until a function call performed with 'invoke' is reached. +-- I.e., throw a non-local exception. +unwind :: CodeGenFunction r Terminate +unwind = do + withCurrentBuilder FFI.buildUnwind + return terminate + +-- |Inform the code generator that this code can never be reached. +unreachable :: CodeGenFunction r Terminate +unreachable = do + withCurrentBuilder FFI.buildUnreachable + return terminate + +-------------------------------------- + +-- XXX Vector ops not implemented + +type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef +type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef + +-- |Acceptable arguments to arithmetic binary instructions. +class ABinOp a b c | a b -> c where + abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r c + +add :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +add = abinop FFI.constAdd FFI.buildAdd +sub :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +sub = abinop FFI.constSub FFI.buildSub +mul :: (IsArithmetic c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +mul = abinop FFI.constMul FFI.buildMul + +udiv :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +udiv = abinop FFI.constUDiv FFI.buildUDiv +sdiv :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +sdiv = abinop FFI.constSDiv FFI.buildSDiv +urem :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +urem = abinop FFI.constURem FFI.buildURem +srem :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +srem = abinop FFI.constSRem FFI.buildSRem + +-- | Floating point division. +fdiv :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +fdiv = abinop FFI.constFDiv FFI.buildFDiv +-- | Floating point remainder. +frem :: (IsFloating c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +frem = abinop FFI.constFRem FFI.buildFRem + +shl :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +shl = abinop FFI.constShl FFI.buildShl +lshr :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +lshr = abinop FFI.constLShr FFI.buildLShr +ashr :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +ashr = abinop FFI.constAShr FFI.buildAShr +and :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +and = abinop FFI.constAnd FFI.buildAnd +or :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +or = abinop FFI.constOr FFI.buildOr +xor :: (IsInteger c, ABinOp a b (v c)) => a -> b -> CodeGenFunction r (v c) +xor = abinop FFI.constXor FFI.buildXor + +instance ABinOp (Value a) (Value a) (Value a) where + abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2 + +instance ABinOp (ConstValue a) (Value a) (Value a) where + abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2 + +instance ABinOp (Value a) (ConstValue a) (Value a) where + abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2 + +instance ABinOp (ConstValue a) (ConstValue a) (ConstValue a) where + abinop cop _ (ConstValue a1) (ConstValue a2) = + return $ ConstValue $ cop a1 a2 + +instance (IsConst a) => ABinOp (Value a) a (Value a) where + abinop cop op a1 a2 = abinop cop op a1 (constOf a2) + +instance (IsConst a) => ABinOp a (Value a) (Value a) where + 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 + +-------------------------------------- + +-- | Get a value from a vector. +extractelement :: 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, nondescructive. +insertelement :: 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 :: Value (Vector n a) + -> Value (Vector n a) + -> ConstValue (Vector n Word32) + -> CodeGenFunction r (Value (Vector n a)) +shufflevector (Value a) (Value b) (ConstValue mask) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask + + +-------------------------------------- + +-- XXX should allows constants + +-- XXX size a > size b not enforced +-- | Truncate a value to a shorter bit width. +trunc :: (IsInteger a, IsInteger b) => Value a -> CodeGenFunction r (Value b) +trunc = convert FFI.buildTrunc + +-- XXX size a < size b not enforced +-- | Zero extend a value to a wider width. +zext :: (IsInteger a, IsInteger b) => Value a -> CodeGenFunction r (Value b) +zext = convert FFI.buildZExt + +-- XXX size a < size b not enforced +-- | Sign extend a value to wider width. +sext :: (IsInteger a, IsInteger b) => Value a -> CodeGenFunction r (Value b) +sext = convert FFI.buildSExt + +-- XXX size a > size b not enforced +-- | Truncate a floating point value. +fptrunc :: (IsFloating a, IsFloating b) => Value a -> CodeGenFunction r (Value b) +fptrunc = convert FFI.buildFPTrunc + +-- XXX size a < size b not enforced +-- | Extend a floating point value. +fpext :: (IsFloating a, IsFloating b) => Value a -> CodeGenFunction r (Value b) +fpext = convert FFI.buildFPExt + +-- | Convert a floating point value to an unsigned integer. +fptoui :: (IsFloating a, IsInteger b) => Value a -> CodeGenFunction r (Value b) +fptoui = convert FFI.buildFPToUI + +-- | Convert a floating point value to a signed integer. +fptosi :: (IsFloating a, IsInteger b) => Value a -> CodeGenFunction r (Value b) +fptosi = convert FFI.buildFPToSI + +-- | Convert an unsigned integer to a floating point value. +uitofp :: (IsInteger a, IsFloating b) => Value a -> CodeGenFunction r (Value b) +uitofp = convert FFI.buildUIToFP + +-- | Convert a signed integer to a floating point value. +sitofp :: (IsInteger a, IsFloating b) => Value a -> CodeGenFunction r (Value b) +sitofp = convert FFI.buildSIToFP + +-- | Convert a pointer to an integer. +ptrtoint :: (IsInteger b) => Value (Ptr a) -> CodeGenFunction r (Value b) +ptrtoint = convert FFI.buildPtrToInt + +-- | Convert an integer to a pointer. +inttoptr :: (IsInteger a, IsType b) => Value (Ptr a) -> CodeGenFunction r (Value (Ptr b)) +inttoptr = convert FFI.buildIntToPtr + +-- XXX a and b must use the same space, and there are also pointer restrictions +-- | Convert between to values of the same size by just copying the bit pattern. +bitcast :: (IsFirstClass a, IsFirstClass b) => Value a -> CodeGenFunction r (Value b) +bitcast = 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 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) + +data RealPredicate = + RealFalse -- ^ Always false (always folded) + | RealOEQ -- ^ True if ordered and equal + | RealOGT -- ^ True if ordered and greater than + | RealOGE -- ^ True if ordered and greater than or equal + | RealOLT -- ^ True if ordered and less than + | RealOLE -- ^ True if ordered and less than or equal + | RealONE -- ^ True if ordered and operands are unequal + | RealORD -- ^ True if ordered (no nans) + | RealUNO -- ^ True if unordered: isnan(X) | isnan(Y) + | RealUEQ -- ^ True if unordered or equal + | RealUGT -- ^ True if unordered or greater than + | RealUGE -- ^ True if unordered, greater than, or equal + | RealULT -- ^ True if unordered or less than + | RealULE -- ^ True if unordered, less than, or equal + | RealUNE -- ^ True if unordered or not equal + | RealT -- ^ Always true (always folded) + deriving (Eq, Ord, Enum, Show) + +-- |Acceptable operands to comparison instructions. +class CmpOp a b c | a b -> c where + cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value Bool) + +instance CmpOp (Value a) (Value a) a where + cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2 + +instance (IsConst a) => CmpOp a (Value a) a where + cmpop op a1 a2 = cmpop op (valueOf a1) a2 + +instance (IsConst a) => CmpOp (Value a) a a where + cmpop op a1 a2 = cmpop op a1 (valueOf a2) + +-- | Compare integers. +icmp :: (IsInteger c, CmpOp a b c) => + IntPredicate -> a -> b -> CodeGenFunction r (Value Bool) +icmp p = cmpop (flip FFI.buildICmp (fromIntegral (fromEnum p + 32))) + +-- | Compare floating point values. +fcmp :: (IsFloating c, CmpOp a b c) => + RealPredicate -> a -> b -> CodeGenFunction r (Value Bool) +fcmp p = cmpop (flip FFI.buildFCmp (fromIntegral (fromEnum p))) + +-------------------------------------- + +-- XXX could do const song and dance +-- | Select between two values depending on a boolean. +select :: (IsFirstClass a) => Value Bool -> Value a -> Value a -> CodeGenFunction r (Value a) +select (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 CallArgs f g | f -> g, g -> f where + doCall :: Caller -> [FFI.ValueRef] -> f -> g + +instance (CallArgs b b') => CallArgs (a -> b) (Value a -> b') where + 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)) where + 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) => Function f -> g +call (Value f) = doCall (U.makeCall f) [] (undefined :: f) + +-- | Call a function with exception handling. +invoke :: (CallArgs f g) + => 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) + +-------------------------------------- + +-- 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 -> FFI.ValueRef +instance AllocArg (Value Word32) where + getAllocArg (Value v) = v +instance AllocArg (ConstValue Word32) where + getAllocArg = unConst +instance AllocArg Word32 where + getAllocArg = unConst . constOf + +-- XXX What's the type returned by malloc +-- | Allocate heap memory. +malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a)) +malloc = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildMalloc bldPtr (typeRef (undefined :: a)) + +-- 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 = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildArrayMalloc bldPtr (typeRef (undefined :: a)) (getAllocArg s) + +-- 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)) (getAllocArg s) + +-- XXX What's the type of free? +-- | Free heap memory. +free :: Value (Ptr a) -> CodeGenFunction r (Value ()) +free (Value a) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> FFI.buildFree bldPtr a + +-- | 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 (Value ()) +store (Value v) (Value p) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + FFI.buildStore bldPtr v p + +{- +-- 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 nptr | optr ixs -> nptr {-, ixs nptr -> optr, nptr optr -> ixs-} where + 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 () a where + getIxList _ () = [] + +-- Index in Array +instance (GetElementPtr o i n, IsIndexArg a) => GetElementPtr (Array k o) (a, i) n where + getIxList ~(Array (a:_)) (v, i) = getArg v : getIxList a i + +-- Index in Vector +instance (GetElementPtr o i n, IsIndexArg a) => GetElementPtr (Vector k o) (a, i) n where + getIxList ~(Vector (Array (a:_))) (v, i) = getArg v : getIxList a i + +-- | 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 n r . (GetElementPtr o i n, IsIndexArg a) => + Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr n)) +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) diff --git a/LLVM/Core/Type.hs b/LLVM/Core/Type.hs --- a/LLVM/Core/Type.hs +++ b/LLVM/Core/Type.hs @@ -1,547 +1,212 @@ -{-# LANGUAGE - DeriveDataTypeable - , ExistentialQuantification - , FunctionalDependencies - , MultiParamTypeClasses - #-} - -module LLVM.Core.Type - ( - Module(..) - , withModule - , ModuleProvider(..) - , withModuleProvider - - -- * Types - , Type(..) - , TypeValue(..) - , AnyType - , HasAnyType(..) - , DynamicType(..) - , mkAnyType - - -- ** Integer types - , Arithmetic - , FirstClass - , Integer - , integer - , Int1(..) - , int1 - , Int8(..) - , int8 - , Int16(..) - , int16 - , Int32(..) - , int32 - , Int64(..) - , int64 - , IntWidth(..) - - -- ** Real types - , Real - , Float(..) - , float - , Double(..) - , double - - -- *** Machine-specific real types - , X86Float80(..) - , x86Float80 - , Float128(..) - , float128 - , PPCFloat128(..) - , ppcFloat128 - - -- ** Array, pointer, and vector types - , Sequence(..) - , elementTypeDyn - , Array(..) - , array - , arrayElementType - , Pointer(..) - , AddressSpace - , addressSpace - , fromAddressSpace - , genericAddressSpace - , pointerIn - , pointer - , pointerElementType - , Vector(..) - , vector - , vectorElementType - - -- ** Function-related types - , Function(..) - , function - , params - , functionVarArg - , isFunctionVarArg - , getReturnType - , getParamTypes - - -- *** Type hackery - , functionParams - , Params(..) - , (:->)(..) - , car - , cdr - - -- ** Other types - , Void(..) +{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, FlexibleInstances, IncoherentInstances #-} +-- |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 + IsArithmetic, + IsInteger, + IsFloating, + IsPrimitive, + IsFirstClass, + IsSized, + IsFunction, +-- IsFunctionRet, + IsSequence ) where - -import Control.Applicative ((<$>)) -import Data.Typeable (Typeable) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Marshal.Array (allocaArray, peekArray, withArrayLen) -import Foreign.Marshal.Utils (fromBool, toBool) -import Prelude hiding (Double, Float, Integer, Real, mod) -import System.IO.Unsafe (unsafePerformIO) - -import qualified LLVM.Core.FFI as FFI - -import Debug.Trace - - -newtype Module = Module { - fromModule :: ForeignPtr FFI.Module - } - deriving (Typeable) - -withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a -withModule mod = withForeignPtr (fromModule mod) - -newtype ModuleProvider = ModuleProvider { - fromModuleProvider :: ForeignPtr FFI.ModuleProvider - } - deriving (Typeable) - -withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a) - -> IO a -withModuleProvider prov = withForeignPtr (fromModuleProvider prov) - -class Type a where - typeRef :: a -> FFI.TypeRef - anyType :: a -> AnyType - -class Type t => TypeValue t where - typeValue :: a -> t - -class Type a => Arithmetic a -class Arithmetic a => Integer a -class Arithmetic a => Real a - -class FirstClass a -instance FirstClass AnyType - -class HasAnyType a where - fromAnyType :: AnyType -> a - -instance Type FFI.TypeRef where - anyType = AnyType - typeRef = id - -data AnyType = forall a. Type a => AnyType a - deriving (Typeable) - -instance Eq AnyType where - a == b = typeRef a == typeRef b - -instance Show AnyType where - show a = "AnyType " ++ show (typeRef a) - -mkAnyType :: Type a => a -> AnyType -mkAnyType = AnyType - -instance Type AnyType where - typeRef (AnyType a) = typeRef a - anyType = id - -instance HasAnyType AnyType where - fromAnyType = id - -class Params a where - toAnyList :: a -> [AnyType] - fromAnyList :: [AnyType] -> (a, [AnyType]) - -instance Integer AnyType - -newtype Int1 = Int1 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Integer, Type, Typeable) - -instance Show Int1 where - show _ = "Int1" - -newtype Int8 = Int8 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Integer, Type, Typeable) - -instance Show Int8 where - show _ = "Int8" - -newtype Int16 = Int16 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Integer, Type, Typeable) - -instance Show Int16 where - show _ = "Int16" - -newtype Int32 = Int32 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Integer, Type, Typeable) - -instance Show Int32 where - show _ = "Int32" - -newtype Int64 = Int64 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Integer, Type, Typeable) - -instance Show Int64 where - show _ = "Int64" - -newtype IntWidth a = IntWidth AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Integer, Type, Typeable) - -instance Show (IntWidth a) where - show _ = "IntWidth" - -instance Real AnyType -instance Arithmetic AnyType - -newtype Float = Float AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Real, Type, Typeable) - -instance Show Float where - show _ = "Float" - -newtype Double = Double AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Real, Type, Typeable) - -instance Show Double where - show _ = "Double" - -newtype X86Float80 = X86Float80 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Real, Type, Typeable) - -instance Show X86Float80 where - show _ = "X86Float80" - -newtype Float128 = Float128 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Real, Type, Typeable) - -instance Show Float128 where - show _ = "Float128" - -newtype PPCFloat128 = PPCFloat128 AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Real, Type, Typeable) - -instance Show PPCFloat128 where - show _ = "PPCFloat128" - -class (Type a, Type t) => Sequence a t | a -> t where - elementType :: a -> t - -instance Sequence AnyType AnyType where - elementType = elementTypeDyn - -newtype Array a = Array AnyType - deriving (HasAnyType, Type, Typeable) - -arrayElementType :: Array a -> a -arrayElementType _ = undefined - -instance Type a => Sequence (Array a) a where - elementType = arrayElementType - -instance (Show a) => Show (Array a) where - show a = "Array " ++ show (arrayElementType a) - -newtype Pointer a = Pointer AnyType - deriving (FirstClass, HasAnyType, Type, Typeable) - -pointerElementType :: Pointer a -> a -pointerElementType _ = undefined - -instance Type a => Sequence (Pointer a) a where - elementType = pointerElementType - -instance (Show a) => Show (Pointer a) where - show a = "Pointer " ++ show (pointerElementType a) - -newtype Vector a = Vector AnyType - deriving (Arithmetic, FirstClass, HasAnyType, Type, Typeable) - -vectorElementType :: Vector a -> a -vectorElementType _ = undefined - -instance Type a => Sequence (Vector a) a where - elementType = vectorElementType - -instance (Show a) => Show (Vector a) where - show a = "Vector " ++ show (vectorElementType a) - -newtype Void = Void AnyType - deriving (HasAnyType, Type, Typeable) - -instance Show Void where - show _ = "Void" - -class Type a => DynamicType a where - toAnyType :: a -- ^ not inspected - -> AnyType - -data Function r p = Function { - fromNewFunction :: AnyType - } - deriving (Typeable) - -instance HasAnyType (Function r p) where - fromAnyType = Function - -instance Type (Function r p) where - typeRef = typeRef . fromNewFunction - anyType = fromNewFunction - -instance (Show r, Show p, Params p) => Show (Function r p) where - show a = "Function " ++ show (functionResult a) ++ " " ++ show (params a) - -functionParams :: Function r p -> p -functionParams _ = undefined - -functionResult :: Function r p -> r -functionResult _ = undefined - -instance (DynamicType r, Params p) => DynamicType (Function r p) where - toAnyType f = let parms = toAnyList . functionParams $ f - ret = toAnyType . functionResult $ f - in functionType False ret parms - -instance DynamicType AnyType where - toAnyType = id - -data a :-> b = a :-> b -infixr 6 :-> - -car :: (a :-> b) -> a -car _ = undefined - -cdr :: (a :-> b) -> b -cdr _ = undefined - -instance (Show a, Show b) => Show (a :-> b) where - show a = show (car a) ++ " :-> " ++ show (cdr a) - -int1 :: a -> Int1 -int1 _ = Int1 $ mkAnyType FFI.int1Type - -fromAny :: HasAnyType a => [AnyType] -> (a, [AnyType]) -fromAny e | trace ("eee " ++ show (length e) ) False = undefined -fromAny (x:xs) = (fromAnyType x,xs) -fromAny _ = error "LLVM.Core.Type.fromAny: empty list" - -instance Params () where - toAnyList _ = [] - fromAnyList _ = error "fromAnyList ()" - -instance Params Int1 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance TypeValue Int1 where - typeValue = int1 - -instance DynamicType Int1 where - toAnyType = mkAnyType . int1 - -int8 :: a -> Int8 -int8 _ = Int8 $ mkAnyType FFI.int8Type - -instance Params Int8 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance Params AnyType where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance DynamicType Int8 where - toAnyType = mkAnyType . int8 - -int16 :: a -> Int16 -int16 _ = Int16 $ mkAnyType FFI.int16Type - -instance Params Int16 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance DynamicType Int16 where - toAnyType = mkAnyType . int16 - -int32 :: a -> Int32 -int32 _ = Int32 $ mkAnyType FFI.int32Type - -instance Params Int32 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance DynamicType Int32 where - toAnyType = mkAnyType . int32 - -int64 :: a -> Int64 -int64 _ = Int64 $ mkAnyType FFI.int64Type - -instance Params Int64 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance DynamicType Int64 where - toAnyType = mkAnyType . int64 - -integer :: Int -> b -> IntWidth a -integer width _ = IntWidth . mkAnyType . FFI.integerType $ fromIntegral width - --- Not possible: --- --- instance Params (IntWidth a) where --- toAnyList a = [toAnyType a] --- --- instance DynamicType (IntWidth a) where --- toAnyType _ = mkAnyType integerType - -float :: a -> Float -float _ = Float $ mkAnyType FFI.floatType - -instance Params Float where - toAnyList a = [toAnyType a] - fromAnyList = fromAny - -instance DynamicType Float where - toAnyType = mkAnyType . float - -double :: a -> Double -double _ = Double $ mkAnyType FFI.doubleType - -instance Params Double where - toAnyList a = [toAnyType a] - fromAnyList = fromAny +import Data.Int +import Data.Word +import Data.TypeNumbers +import LLVM.Core.Util(functionType) +import LLVM.Core.Data +import qualified LLVM.FFI.Core as FFI -instance DynamicType Double where - toAnyType = mkAnyType . double +-- 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). -x86Float80 :: a -> X86Float80 -x86Float80 _ = X86Float80 $ mkAnyType FFI.x86FP80Type +-- |The 'IsType' class classifies all types that have an LLVM representation. +class IsType a where + typeRef :: a -> FFI.TypeRef -- ^The argument is never evaluated -instance Params X86Float80 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny +-- |Arithmetic types, i.e., integral and floating types. +class IsType a => IsArithmetic a -instance DynamicType X86Float80 where - toAnyType = mkAnyType . x86Float80 +-- |Integral types. +class IsArithmetic a => IsInteger a -float128 :: a -> Float128 -float128 _ = Float128 $ mkAnyType FFI.fp128Type +-- |Floating types. +class IsArithmetic a => IsFloating a -instance Params Float128 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny +-- |Primitive types. +class IsType a => IsPrimitive a -instance DynamicType Float128 where - toAnyType = mkAnyType . float128 +-- |First class types, i.e., the types that can be passed as arguments, etc. +class IsType a => IsFirstClass a -ppcFloat128 :: a -> PPCFloat128 -ppcFloat128 _ = PPCFloat128 $ mkAnyType FFI.ppcFP128Type +-- XXX use kind annotation +-- |Sequence types, i.e., vectors and arrays +class IsSequence c where dummy__ :: c a -> a; dummy__ = undefined -instance Params PPCFloat128 where - toAnyList a = [toAnyType a] - fromAnyList = fromAny +-- |Types with a fixed size. +class (IsType a) => IsSized a -instance DynamicType PPCFloat128 where - toAnyType = mkAnyType . ppcFloat128 +-- |Function type. +class (IsType a) => IsFunction a where + funcType :: [FFI.TypeRef] -> a -> FFI.TypeRef -void :: a -> Void -void _ = Void $ mkAnyType FFI.voidType +-- Only make instances for types that make sense in Haskell +-- (i.e., some floating types are excluded). -instance Params Void where - toAnyList a = [toAnyType a] - fromAnyList = fromAny +-- Floating point types. +instance IsType Float where typeRef _ = FFI.floatType +instance IsType Double where typeRef _ = FFI.doubleType +instance IsType FP128 where typeRef _ = FFI.fp128Type -instance DynamicType Void where - toAnyType = mkAnyType . void +-- Void type +instance IsType () where typeRef _ = FFI.voidType -instance (DynamicType a, HasAnyType a, Params b) => Params (a :-> b) where - toAnyList a = toAnyType (car a) : toAnyList (cdr a) - fromAnyList (x:xs) = let (y,ys) = fromAnyList xs - in (fromAnyType x :-> y,ys) - fromAnyList _ = error "LLVM.Core.Type.fromAnyList(:->): empty list" +-- Label type +--data Label +--instance IsType Label where typeRef _ = FFI.labelType -functionType :: Bool -> AnyType -> [AnyType] -> AnyType -functionType varargs retType paramTypes = unsafePerformIO $ - withArrayLen (map typeRef paramTypes) $ \len ptr -> - return . mkAnyType $ FFI.functionType (typeRef retType) ptr - (fromIntegral len) (fromBool varargs) +-- Variable size integer types +instance (IsTypeNumber n) => IsType (IntN n) + where typeRef _ = FFI.integerType (typeNumber (undefined :: n)) -params :: Params p => Function r p -> p -params f = case fromAnyList . toAnyList . functionParams $ f of - (p, []) -> p - _ -> error "LLVM.Core.Type.newParams: incompletely consumed params" +instance (IsTypeNumber n) => IsType (WordN n) + where typeRef _ = FFI.integerType (typeNumber (undefined :: n)) -function :: (DynamicType r, Params p) => r -> p -> Function r p -function r p = Function . functionType False (toAnyType r) $ toAnyList p +-- Fixed size integer types. +instance IsType Bool where typeRef _ = FFI.int1Type +instance IsType Word8 where typeRef _ = FFI.int8Type +instance IsType Word16 where typeRef _ = FFI.int16Type +instance IsType Word32 where typeRef _ = FFI.int32Type +instance IsType Word64 where typeRef _ = FFI.int64Type +instance IsType Int8 where typeRef _ = FFI.int8Type +instance IsType Int16 where typeRef _ = FFI.int16Type +instance IsType Int32 where typeRef _ = FFI.int32Type +instance IsType Int64 where typeRef _ = FFI.int64Type -instance DynamicType p => Params (Function r p) where - toAnyList a = [toAnyType (functionParams a)] - fromAnyList = fromAny - -functionVarArg :: (DynamicType r, Params p) => r -> p -> Function r p -functionVarArg r p = Function . functionType True (toAnyType r) $ toAnyList p - -isFunctionVarArg :: Function r p -> Bool -isFunctionVarArg = toBool . FFI.isFunctionVarArg . typeRef +-- Sequence types +instance (IsTypeNumber n, IsSized a) => IsType (Array n a) + where typeRef _ = FFI.arrayType (typeRef (undefined :: a)) + (typeNumber (undefined :: n)) -getReturnType :: (Params p) => Function r p -> AnyType -getReturnType = mkAnyType . FFI.getReturnType . typeRef +instance (IsTypeNumber n, IsPrimitive a) => IsType (Vector n a) + where typeRef _ = FFI.arrayType (typeRef (undefined :: a)) + (typeNumber (undefined :: n)) -getParamTypes :: (Params p) => Function r p -> [AnyType] -getParamTypes typ = unsafePerformIO $ do - let typ' = typeRef typ - count = FFI.countParamTypes typ' - len = fromIntegral count - allocaArray len $ \ptr -> do - FFI.getParamTypes typ' ptr - map mkAnyType <$> peekArray len ptr +instance (IsType a) => IsType (Ptr a) where + typeRef ~(Ptr a) = FFI.pointerType (typeRef a) 0 -array :: (DynamicType t) => t -> Int -> Array t -array typ len = Array . mkAnyType $ FFI.arrayType (typeRef (toAnyType typ)) (fromIntegral len) +-- Functions. +instance (IsFirstClass a, IsFunction b) => IsType (a->b) where + typeRef = funcType [] -instance (DynamicType t) => DynamicType (Array t) where - toAnyType = mkAnyType . flip array 0 . toAnyType . arrayElementType +instance (IsFirstClass a) => IsType (IO a) where + typeRef = funcType [] -newtype AddressSpace = AddressSpace { - fromAddressSpace :: Int - } - deriving (Eq, Ord, Show, Read) +--- Instances to classify types +instance IsArithmetic Float +instance IsArithmetic Double +instance IsArithmetic FP128 +instance (IsTypeNumber n) => IsArithmetic (IntN n) +instance (IsTypeNumber n) => IsArithmetic (WordN n) +instance IsArithmetic Bool +instance IsArithmetic Int8 +instance IsArithmetic Int16 +instance IsArithmetic Int32 +instance IsArithmetic Int64 +instance IsArithmetic Word8 +instance IsArithmetic Word16 +instance IsArithmetic Word32 +instance IsArithmetic Word64 -addressSpace :: Int -> AddressSpace -addressSpace = AddressSpace +instance IsFloating Float +instance IsFloating Double +instance IsFloating FP128 -genericAddressSpace :: AddressSpace -genericAddressSpace = addressSpace 0 +instance (IsTypeNumber n) => IsInteger (IntN n) +instance (IsTypeNumber n) => IsInteger (WordN n) +instance IsInteger Bool +instance IsInteger Int8 +instance IsInteger Int16 +instance IsInteger Int32 +instance IsInteger Int64 +instance IsInteger Word8 +instance IsInteger Word16 +instance IsInteger Word32 +instance IsInteger Word64 -pointerIn :: (DynamicType t) => t -> AddressSpace -> Pointer t -pointerIn typ space = Pointer . mkAnyType $ FFI.pointerType (typeRef (toAnyType typ)) (fromIntegral . fromAddressSpace $ space) +instance IsFirstClass Float +instance IsFirstClass Double +instance IsFirstClass FP128 +instance (IsTypeNumber n) => IsFirstClass (IntN n) +instance (IsTypeNumber 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 (IsTypeNumber n, IsPrimitive a) => IsFirstClass (Vector n a) +instance (IsType a) => IsFirstClass (Ptr a) +instance IsFirstClass () -- XXX This isn't right, but () can be returned -pointer :: (DynamicType t) => t -> Pointer t -pointer typ = pointerIn typ genericAddressSpace +instance (IsTypeNumber n) => IsSequence (Array n) +--instance (IsTypeNumber n, IsPrimitive a) => IsSequence (Vector n) a -instance (DynamicType t) => DynamicType (Pointer t) where - toAnyType = mkAnyType . pointer . toAnyType . pointerElementType +instance IsSized Float +instance IsSized Double +instance IsSized FP128 +instance (IsTypeNumber n) => IsSized (IntN n) +instance (IsTypeNumber n) => IsSized (WordN n) +instance IsSized Bool +instance IsSized Int8 +instance IsSized Int16 +instance IsSized Int32 +instance IsSized Int64 +instance IsSized Word8 +instance IsSized Word16 +instance IsSized Word32 +instance IsSized Word64 +instance (IsTypeNumber n, IsSized a) => IsSized (Array n a) +instance (IsTypeNumber n, IsPrimitive a) => IsSized (Vector n a) +instance (IsType a) => IsSized (Ptr a) -instance (DynamicType t) => Params (Pointer t) where - toAnyList a = [toAnyType a] - fromAnyList = fromAny +instance IsPrimitive Float +instance IsPrimitive Double +instance IsPrimitive FP128 +instance (IsTypeNumber n) => IsPrimitive (IntN n) +instance (IsTypeNumber 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 () -vector :: (DynamicType t) => t -> Int -> Vector t -vector typ len = Vector . mkAnyType $ FFI.vectorType (typeRef (toAnyType typ)) (fromIntegral len) +-- Functions. +instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where + funcType ts _ = funcType (typeRef (undefined :: a) : ts) (undefined :: b) +instance (IsFirstClass a) => IsFunction (IO a) where + funcType ts _ = functionType False (typeRef (undefined :: a)) (reverse ts) -instance (DynamicType t) => DynamicType (Vector t) where - toAnyType = mkAnyType . flip vector 0 . toAnyType . vectorElementType +-- XXX Structures not implemented. Tuples is probably an easy way. -elementTypeDyn :: Type a => a -> AnyType -elementTypeDyn = mkAnyType . FFI.getElementType . typeRef diff --git a/LLVM/Core/Util.hs b/LLVM/Core/Util.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Util.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module LLVM.Core.Util( + -- * Module handling + Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, + -- * 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, + -- * Functions + Function, + addFunction, getParam, + -- * Globals + addGlobal, + constString, constStringNul, + -- * Instructions + makeCall, makeInvoke, + -- * Misc + CString, withArrayLen, + withEmptyCString, + functionType, buildEmptyPhi, addPhiIns, + -- * Transformation passes + addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, + addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, + addTargetData + ) where +import Control.Monad(liftM, when) +import Foreign.C.String (withCString, withCStringLen, CString) +import Foreign.ForeignPtr (ForeignPtr, FinalizerPtr, newForeignPtr, withForeignPtr) +import Foreign.Marshal.Array (withArrayLen, withArray) +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.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) + +-------------------------------------- +-- Handle modules +{- +newtype Module = Module { + fromModule :: ForeignPtr FFI.Module + } +-- deriving (Typeable) + +withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a +withModule modul = withForeignPtr (fromModule modul) + +createModule :: String -> IO Module +createModule name = + withCString name $ \namePtr -> do + ptr <- FFI.moduleCreateWithName namePtr + final <- h2c_module FFI.disposeModule + liftM Module $ newForeignPtr final ptr + +foreign import ccall "wrapper" h2c_module + :: (FFI.ModuleRef -> IO ()) -> IO (FinalizerPtr a) +-} + +-- 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 + } + +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 () + +-------------------------------------- +-- 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 + } + +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 + final <- h2c_moduleProvider FFI.disposeModuleProvider + liftM ModuleProvider $ newForeignPtr final ptr + +foreign import ccall "wrapper" h2c_moduleProvider + :: (FFI.ModuleProviderRef -> IO ()) -> IO (FinalizerPtr a) + + +-------------------------------------- +-- Handle instruction builders + +newtype Builder = Builder { + fromBuilder :: ForeignPtr FFI.Builder + } + +withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a +withBuilder = withForeignPtr . fromBuilder + +createBuilder :: IO Builder +createBuilder = do + final <- h2c_builder FFI.disposeBuilder + ptr <- FFI.createBuilder + liftM Builder $ newForeignPtr final ptr + +foreign import ccall "wrapper" h2c_builder + :: (FFI.BuilderRef -> IO ()) -> IO (FinalizerPtr a) + +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 + +-------------------------------------- + +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 linkage + return f + +getParam :: Function -> Int -> Value +getParam f = FFI.getParam f . fromIntegral + +-------------------------------------- + +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 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 + +makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value +makeCall func bldPtr args = do +{- + print "makeCall" + FFI.dumpValue func + mapM_ FFI.dumpValue args + print "----------------------" +-} + withArrayLen args $ \ argLen argPtr -> + withEmptyCString $ + FFI.buildCall bldPtr func argPtr + (fromIntegral argLen) + +makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> + [Value] -> IO Value +makeInvoke norm expt func bldPtr args = + withArrayLen args $ \ argLen argPtr -> + withEmptyCString $ + FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt + +-------------------------------------- + +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 + } + +withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a) + -> IO a +withPassManager = withForeignPtr . fromPassManager + +-- | Create a pass manager. +createPassManager :: IO PassManager +createPassManager = do + ptr <- FFI.createPassManager + final <- h2c_passManager FFI.disposePassManager + liftM PassManager $ newForeignPtr final ptr + +-- | Create a pass manager for a module. +createFunctionPassManager :: ModuleProvider -> IO PassManager +createFunctionPassManager modul = + withModuleProvider modul $ \modulPtr -> do + ptr <- FFI.createFunctionPassManager modulPtr + final <- h2c_passManager FFI.disposePassManager + liftM PassManager $ newForeignPtr final ptr + +foreign import ccall "wrapper" h2c_passManager + :: (FFI.PassManagerRef -> IO ()) -> IO (FinalizerPtr a) + +-- | 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 diff --git a/LLVM/Core/Utils.hs b/LLVM/Core/Utils.hs deleted file mode 100644 --- a/LLVM/Core/Utils.hs +++ /dev/null @@ -1,41 +0,0 @@ -module LLVM.Core.Utils - ( - defineGlobal - , declareFunction - , defineFunction - ) where - -import Prelude hiding (mod) - -import qualified LLVM.Core as Core -import qualified LLVM.Core.Builder as B -import qualified LLVM.Core.Constant as C -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V - - -defineGlobal :: (V.ConstValue a, V.TypedValue a t) => T.Module -> String -> a - -> IO (V.GlobalVar t) -defineGlobal mod name val = do - global <- Core.addGlobal mod (V.typeOf val) name - Core.setInitializer global val - return global - -declareFunction :: (T.DynamicType r, T.Params p) - => T.Module -> String -> T.Function r p - -> IO (V.Function r p) -declareFunction mod name typ = do - maybeFunc <- Core.getNamedFunction mod name - case maybeFunc of - Nothing -> Core.addFunction mod name typ - Just func -> return $ let t = V.typeOf func - in if T.elementTypeDyn t /= T.toAnyType typ - then C.bitCast func (T.pointer typ) - else func - -defineFunction :: T.Params p => T.Module -> String -> T.Function r p - -> IO (V.Function r p, B.BasicBlock) -defineFunction mod name typ = do - func <- Core.addFunction mod name typ - bblk <- Core.appendBasicBlock func "entry" - return (func, bblk) diff --git a/LLVM/Core/Value.hs b/LLVM/Core/Value.hs deleted file mode 100644 --- a/LLVM/Core/Value.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE - DeriveDataTypeable - , ExistentialQuantification - , FunctionalDependencies - , MultiParamTypeClasses - , UndecidableInstances - #-} - -module LLVM.Core.Value - ( - -- * Values - - -- * Opaque wrapper for LLVM's basic value type - AnyValue - , DynamicValue(..) - , mkAnyValue - , typeOfDyn - - -- ** Type classes - , Value(..) - , Params(..) - , ConstValue - , GlobalValue - , GlobalVariable - , Arithmetic - , Integer - , Real - , Vector - - , Global(..) - , GlobalVar(..) - , Function(..) - , TypedValue(..) - , Argument(..) - - , Instruction(..) - - -- * Constants - , ConstInt(..) - , ConstReal(..) - , ConstArray(..) - - -- ** Useful functions - , params - , getName - , setName - , dumpValue - ) where - -import Control.Applicative ((<$>)) -import Data.Typeable (Typeable) -import Foreign.C.String (peekCString, withCString) -import Foreign.Marshal.Array (allocaArray, peekArray) -import Foreign.Ptr (nullPtr) -import Prelude hiding (Integer, Real) -import System.IO.Unsafe (unsafePerformIO) - -import qualified LLVM.Core.FFI as FFI -import LLVM.Core.Type ((:->)(..)) -import qualified LLVM.Core.Type as T - --- import Debug.Trace - - -class Value a where - valueRef :: a -> FFI.ValueRef - anyValue :: a -> AnyValue - -class DynamicValue a where - fromAnyValue :: AnyValue -> a - -class Params t v | t -> v where - fromAnyList :: t -> [AnyValue] -> (v, [AnyValue]) - --- | Recover the type of a value in a manner that preserves static --- type safety. -class (T.Type t, Value v) => TypedValue v t | v -> t where - typeOf :: v -- ^ value is not inspected - -> t - -data AnyValue = forall a. Value a => AnyValue a - deriving (Typeable) - -instance DynamicValue AnyValue where - fromAnyValue = id - -instance Value FFI.ValueRef where - valueRef = id - anyValue = AnyValue - -mkAnyValue :: Value a => a -> AnyValue -mkAnyValue = AnyValue - -class Value a => ConstValue a -class Value a => Arithmetic a -class Arithmetic a => Integer a -class Arithmetic a => Real a -class Arithmetic a => Vector a -class ConstValue a => GlobalValue a -class GlobalValue a => GlobalVariable a - -instance Value AnyValue where - valueRef (AnyValue a) = valueRef a - anyValue = id - -instance ConstValue AnyValue -instance GlobalValue AnyValue -instance GlobalVariable AnyValue -instance Arithmetic AnyValue -instance Integer AnyValue -instance Real AnyValue - -getName :: Value v => v -> IO String -getName v = do - namePtr <- FFI.getValueName (valueRef v) - if namePtr == nullPtr - then return [] - else peekCString namePtr - -setName :: Value v => v -> String -> IO () -setName v name = withCString name (FFI.setValueName (valueRef v)) - -dumpValue :: Value v => v -> IO () -dumpValue = FFI.dumpValue . valueRef - -newtype Instruction a = Instruction AnyValue - deriving (DynamicValue, Typeable, Value) - -newtype Global t = Global AnyValue - deriving (ConstValue, DynamicValue, GlobalValue, Typeable, Value) - -newtype GlobalVar t = GlobalVar AnyValue - deriving (ConstValue, DynamicValue, GlobalValue, GlobalVariable, - Typeable, Value) - -fromAny :: (DynamicValue v, TypedValue v t, T.Type t) => t -> [AnyValue] -> (v, [AnyValue]) -fromAny _ (x:xs) = (fromAnyValue x,xs) -fromAny _ _ = error "LLVM.Core.Value.fromAny: empty list" - -globalVarType :: GlobalVar t -> t -globalVarType _ = undefined - -instance T.Type t => TypedValue (GlobalVar t) t where - typeOf = globalVarType - -data Function r p = Function { - fromFunction :: AnyValue - } - deriving (Typeable) - -instance ConstValue (Function r p) -instance GlobalValue (Function r p) -instance GlobalVariable (Function r p) - -instance DynamicValue (Function r p) where - fromAnyValue = Function - -instance Value (Function r p) where - valueRef = valueRef . anyValue - anyValue = fromFunction - -newtype Argument t = Argument AnyValue - deriving (DynamicValue, Typeable, Value) - -instance (T.DynamicType r, T.Params p) => TypedValue (Function r p) (T.Function r p) where - typeOf _ = T.function undefined undefined - -instance (Params b c) => Params (a :-> b) (Argument a :-> c) where - fromAnyList t (x:xs) = let (y,ys) = fromAnyList (T.cdr t) xs - in (Argument x :-> y,ys) - fromAnyList _ _ = error "LLVM.Core.Value.fromAnyList(:->): empty list" - -newtype ConstInt t = ConstInt AnyValue - deriving (Arithmetic, ConstValue, DynamicValue, Integer, Typeable, Value) - -instance TypedValue (ConstInt T.Int1) T.Int1 where - typeOf = T.int1 - -instance TypedValue (Argument T.Int1) T.Int1 where - typeOf = T.int1 - -instance TypedValue (Instruction T.Int1) T.Int1 where - typeOf = T.int1 - -instance Params T.Int1 (Argument T.Int1) where - fromAnyList = fromAny - -instance TypedValue (ConstInt T.Int8) T.Int8 where - typeOf = T.int8 - -instance TypedValue (Argument T.Int8) T.Int8 where - typeOf = T.int8 - -instance TypedValue (Instruction T.Int8) T.Int8 where - typeOf = T.int8 - -instance Params T.Int8 (Argument T.Int8) where - fromAnyList = fromAny - -instance TypedValue (ConstInt T.Int16) T.Int16 where - typeOf = T.int16 - -instance TypedValue (Argument T.Int16) T.Int16 where - typeOf = T.int16 - -instance Params T.Int16 (Argument T.Int16) where - fromAnyList = fromAny - -instance TypedValue (ConstInt T.Int32) T.Int32 where - typeOf = T.int32 - -instance TypedValue (Argument T.Int32) T.Int32 where - typeOf = T.int32 - -instance TypedValue (Instruction T.Int32) T.Int32 where - typeOf = T.int32 - -instance Params T.Int32 (Argument T.Int32) where - fromAnyList = fromAny - -instance TypedValue (ConstInt T.Int64) T.Int64 where - typeOf = T.int64 - -instance TypedValue (Argument T.Int64) T.Int64 where - typeOf = T.int64 - -instance TypedValue (Instruction T.Int64) T.Int64 where - typeOf = T.int64 - -instance Params T.Int64 (Argument T.Int64) where - fromAnyList = fromAny - -newtype ConstArray t = ConstArray AnyValue - deriving (ConstValue, DynamicValue, Typeable, Value) - -instance (T.DynamicType a) => TypedValue (ConstArray a) (T.Array a) where - typeOf _ = T.array undefined 0 - -instance (T.DynamicType t) => TypedValue (Instruction (T.Array t)) (T.Array t) where - typeOf _ = T.array undefined 0 - -instance (T.DynamicType t) => TypedValue (Instruction (T.Pointer t)) (T.Pointer t) where - typeOf _ = T.pointer undefined - -instance (T.DynamicType t) => Params (T.Pointer t) (Instruction (T.Pointer t)) where - fromAnyList = fromAny - -newtype ConstReal t = ConstReal AnyValue - deriving (Arithmetic, ConstValue, DynamicValue, Real, Typeable, Value) - -instance TypedValue (ConstReal T.Float) T.Float where - typeOf = T.float - -instance TypedValue (Argument T.Float) T.Float where - typeOf = T.float - -instance Params T.Float (Argument T.Float) where - fromAnyList = fromAny - -instance TypedValue (ConstReal T.Double) T.Double where - typeOf = T.double - -instance TypedValue (Argument T.Double) T.Double where - typeOf = T.double - -instance Params T.Double (Argument T.Double) where - fromAnyList = fromAny - -instance TypedValue (ConstReal T.X86Float80) T.X86Float80 where - typeOf = T.x86Float80 - -instance TypedValue (Argument T.X86Float80) T.X86Float80 where - typeOf = T.x86Float80 - -instance Params T.X86Float80 (Argument T.X86Float80) where - fromAnyList = fromAny - -instance TypedValue (ConstReal T.Float128) T.Float128 where - typeOf = T.float128 - -instance TypedValue (Argument T.Float128) T.Float128 where - typeOf = T.float128 - -instance Params T.Float128 (Argument T.Float128) where - fromAnyList = fromAny - -instance TypedValue (ConstReal T.PPCFloat128) T.PPCFloat128 where - typeOf = T.ppcFloat128 - -instance TypedValue (Argument T.PPCFloat128) T.PPCFloat128 where - typeOf = T.ppcFloat128 - -instance Params T.PPCFloat128 (Argument T.PPCFloat128) where - fromAnyList = fromAny - -countParams :: Function r p -> Int -countParams = fromIntegral . FFI.countParams . valueRef - -listParams :: Function r p -> [AnyValue] -listParams f = unsafePerformIO $ do - let len = countParams f - allocaArray len $ \ptr -> do - FFI.getParams (valueRef f) ptr - map mkAnyValue <$> peekArray len ptr - -params :: (T.DynamicType r, T.Params p, Params p v) => Function r p -> v -params f = case fromAnyList (T.params (typeOf f)) (listParams f) of - (p, []) -> p - _ -> error "LLVM.Core.Value.params: incompletely consumed params" - -typeOfDyn :: Value a => a -> T.AnyType -typeOfDyn val = unsafePerformIO $ T.mkAnyType <$> FFI.typeOf (valueRef val) diff --git a/LLVM/ExecutionEngine.hs b/LLVM/ExecutionEngine.hs --- a/LLVM/ExecutionEngine.hs +++ b/LLVM/ExecutionEngine.hs @@ -1,173 +1,85 @@ -{-# LANGUAGE - DeriveDataTypeable - , FunctionalDependencies - , MultiParamTypeClasses - #-} - -module LLVM.ExecutionEngine - ( - -- * Execution engines - ExecutionEngine - , createExecutionEngine - , runStaticConstructors - , runStaticDestructors - , runFunction - - -- * Generic values - , GenericValue - , Generic(..) +{-# LANGUAGE FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} + -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. +module LLVM.ExecutionEngine( + -- * Execution engine + ExecutionEngine, + createExecutionEngine, + runStaticConstructors, + runStaticDestructors, + -- * Translation + Translatable, Generic, + generateFunction, + -- * Unsafe type conversion + Unsafe, + unsafePurify, + -- * Simplified interface. + simpleFunction, + unsafeGenerateFunction ) where - -import Control.Applicative ((<$>)) -import Control.Exception (ioError) -import Data.Int (Int8, Int16, Int32, Int64) -import Data.Typeable (Typeable) -import Data.Word (Word8, Word16, Word32, Word64) -import Foreign.ForeignPtr (FinalizerPtr, ForeignPtr, newForeignPtr, - withForeignPtr) -import Foreign.C.String (peekCString) -import Foreign.Marshal.Alloc (alloca, free) -import Foreign.Marshal.Array (withArrayLen) -import Foreign.Marshal.Utils (fromBool, toBool) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) -import System.IO.Error (userError) import System.IO.Unsafe (unsafePerformIO) -import qualified LLVM.ExecutionEngine.FFI as FFI -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V - -newtype ExecutionEngine = ExecutionEngine { - fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine - } - -withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a) - -> IO a -withExecutionEngine ee = withForeignPtr (fromExecutionEngine ee) - -createExecutionEngine :: T.ModuleProvider -> IO ExecutionEngine -createExecutionEngine prov = - T.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 - final <- h2c_ee FFI.disposeExecutionEngine - ExecutionEngine <$> newForeignPtr final ptr - -foreign import ccall "wrapper" h2c_ee - :: (Ptr FFI.ExecutionEngine -> IO ()) -> IO (FinalizerPtr a) - -runStaticConstructors :: ExecutionEngine -> IO () -runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors - -runStaticDestructors :: ExecutionEngine -> IO () -runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors - - -newtype GenericValue t = GenericValue { - fromGenericValue :: ForeignPtr FFI.GenericValue - } - deriving (Typeable) - -withGenericValue :: GenericValue t -> (FFI.GenericValueRef -> IO a) -> IO a -withGenericValue = withForeignPtr . fromGenericValue - -createGenericValueWith :: IO FFI.GenericValueRef -> IO (GenericValue t) -createGenericValueWith f = do - final <- h2c_genericValue FFI.disposeGenericValue - ptr <- f - GenericValue <$> newForeignPtr final ptr - -foreign import ccall "wrapper" h2c_genericValue - :: (FFI.GenericValueRef -> IO ()) -> IO (FinalizerPtr a) - -withAll :: [GenericValue t] -> (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 :: ExecutionEngine -> V.Function r p -> [GenericValue t] - -> IO (GenericValue r) -runFunction ee func args = - withExecutionEngine ee $ \eePtr -> - withAll args $ \argLen argPtr -> - createGenericValueWith $ FFI.runFunction eePtr (V.valueRef func) - (fromIntegral argLen) argPtr - -class Generic a t | a -> t where - createGeneric :: a -> IO (GenericValue t) - fromGeneric :: GenericValue t -> a - -toGenericInt :: (Integral a, T.Type t) => (b -> t) -> Bool -> a -> IO (GenericValue t) -toGenericInt typf signed val = createGenericValueWith $ - FFI.createGenericValueOfInt (T.typeRef (typf undefined)) - (fromIntegral val) (fromBool signed) - -fromGenericInt :: (Integral a, T.Type t) => Bool -> GenericValue t -> a -fromGenericInt signed val = unsafePerformIO $ - withGenericValue val $ \ref -> - return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed) - -instance Generic Bool T.Int1 where - createGeneric = toGenericInt T.int1 False . fromBool - fromGeneric = toBool . fromGenericInt False - -instance Generic Int8 T.Int8 where - createGeneric = toGenericInt T.int8 True . fromIntegral - fromGeneric = fromIntegral . fromGenericInt True - -instance Generic Int16 T.Int16 where - createGeneric = toGenericInt T.int16 True . fromIntegral - fromGeneric = fromIntegral . fromGenericInt True +import LLVM.ExecutionEngine.Engine +import LLVM.FFI.Core(ValueRef) +import LLVM.Core.CodeGen(Value(..)) +import LLVM.Core +import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) -instance Generic Int32 T.Int32 where - createGeneric = toGenericInt T.int32 True . fromIntegral - fromGeneric = fromIntegral . fromGenericInt True +-- |Class of LLVM function types that can be translated to the corresponding +-- Haskell type. +class Translatable f where + translate :: ExecutionEngine -> [GenericValue] -> ValueRef -> f -instance Generic Int T.Int32 where - createGeneric = toGenericInt T.int32 True . fromIntegral - fromGeneric = fromIntegral . fromGenericInt True +instance (Generic a, Translatable b) => Translatable (a -> b) where + translate ee args f = \ arg -> translate ee (toGeneric arg : args) f -instance Generic Int64 T.Int64 where - createGeneric = toGenericInt T.int64 True . fromIntegral - fromGeneric = fromIntegral . fromGenericInt True +instance (Generic a) => Translatable (IO a) where + translate ee args f = fmap fromGeneric $ runFunction ee f $ reverse args -instance Generic Word8 T.Int8 where - createGeneric = toGenericInt T.int8 False . fromIntegral - fromGeneric = fromIntegral . fromGenericInt False +-- |Generate a Haskell function from an LLVM function. +generateFunction :: (Translatable f) => + ExecutionEngine -> Value (Ptr f) -> f +generateFunction ee (Value f) = translate ee [] f -instance Generic Word16 T.Int16 where - createGeneric = toGenericInt T.int16 False . fromIntegral - fromGeneric = fromIntegral . fromGenericInt False +class Unsafe a b | a -> b where + unsafePurify :: a -> b -- ^Remove the IO from a function return type. This is unsafe in general. -instance Generic Word32 T.Int32 where - createGeneric = toGenericInt T.int32 False . fromIntegral - fromGeneric = fromIntegral . fromGenericInt False +instance (Unsafe b b') => Unsafe (a->b) (a->b') where + unsafePurify f = unsafePurify . f -instance Generic Word64 T.Int64 where - createGeneric = toGenericInt T.int64 False . fromIntegral - fromGeneric = fromIntegral . fromGenericInt False +instance Unsafe (IO a) a where + unsafePurify = unsafePerformIO -toGenericReal :: (Real a, T.Type t) => t -> a -> IO (GenericValue t) -toGenericReal typ val = createGenericValueWith $ - FFI.createGenericValueOfFloat (T.typeRef typ) (realToFrac val) +-- |Translate a function to Haskell code. This is a simplified interface to +-- the execution engine and module mechanism. +simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f +simpleFunction bld = do + m <- newModule + func <- defineModule m bld +-- dumpValue func + prov <- createModuleProviderForExistingModule m + ee <- createExecutionEngine prov -fromGenericReal :: (Fractional a, T.Type t) => GenericValue t -> a -fromGenericReal val = unsafePerformIO $ - withGenericValue val $ \ref -> - return . realToFrac $ FFI.genericValueToFloat ref + 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 -instance Generic Float T.Float where - createGeneric = toGenericReal undefined - fromGeneric = fromGenericReal + return $ generateFunction ee func -instance Generic Double T.Double where - createGeneric = toGenericReal undefined - fromGeneric = fromGenericReal +-- | Combine 'simpleFunction' and 'unsafePurify'. +unsafeGenerateFunction :: (Unsafe t a, Translatable t) => + CodeGenModule (Function t) -> a +unsafeGenerateFunction bld = unsafePerformIO $ do + fun <- simpleFunction bld + return $ unsafePurify fun diff --git a/LLVM/ExecutionEngine/Engine.hs b/LLVM/ExecutionEngine/Engine.hs new file mode 100644 --- /dev/null +++ b/LLVM/ExecutionEngine/Engine.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances #-} +module LLVM.ExecutionEngine.Engine( + ExecutionEngine, + createExecutionEngine, runStaticConstructors, runStaticDestructors, + getExecutionEngineTargetData, + runFunction, + GenericValue, Generic(..) + ) where +import Control.Monad +import Data.Int +import Data.Word +import Foreign.Marshal.Alloc (alloca, free) +import Foreign.Marshal.Array (withArrayLen) +import Foreign.ForeignPtr (FinalizerPtr, ForeignPtr, newForeignPtr, + withForeignPtr) +import Foreign.Marshal.Utils (fromBool) +import Foreign.C.String (peekCString) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) +import System.IO.Unsafe (unsafePerformIO) + +import LLVM.Core.Util(ModuleProvider, withModuleProvider) +import qualified LLVM.FFI.ExecutionEngine as FFI +import qualified LLVM.FFI.Target as FFI +import LLVM.Core.Util(Function) +import LLVM.Core.Type(IsFirstClass, IsType(..)) + +-- |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. +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 + final <- h2c_ee FFI.disposeExecutionEngine + liftM ExecutionEngine $ newForeignPtr final ptr + +foreign import ccall "wrapper" h2c_ee + :: (Ptr FFI.ExecutionEngine -> IO ()) -> IO (FinalizerPtr a) + +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 + +-------------------------------------- + +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 + final <- h2c_genericValue FFI.disposeGenericValue + ptr <- f + liftM GenericValue $ newForeignPtr final ptr + +foreign import ccall "wrapper" h2c_genericValue + :: (FFI.GenericValueRef -> IO ()) -> IO (FinalizerPtr a) + +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 :: ExecutionEngine -> LLVM.Core.Util.Function -> [GenericValue] + -> IO GenericValue +runFunction ee func args = + withExecutionEngine ee $ \eePtr -> + 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 :: (Fractional a, IsFirstClass a) => GenericValue -> a +fromGenericReal val = unsafePerformIO $ + withGenericValue val $ \ ref -> + return . realToFrac $ FFI.genericValueToFloat ref + +instance Generic Float where + toGeneric = toGenericReal + fromGeneric = fromGenericReal + +instance Generic Double where + toGeneric = toGenericReal + fromGeneric = fromGenericReal diff --git a/LLVM/ExecutionEngine/FFI.hsc b/LLVM/ExecutionEngine/FFI.hsc deleted file mode 100644 --- a/LLVM/ExecutionEngine/FFI.hsc +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} - -module LLVM.ExecutionEngine.FFI - ( - -- * Execution engines - ExecutionEngine - , createExecutionEngine - , disposeExecutionEngine - , runStaticConstructors - , runStaticDestructors - , runFunction - - -- * Generic values - , GenericValue - , GenericValueRef - , createGenericValueOfInt - , genericValueToInt - , createGenericValueOfFloat - , genericValueToFloat - , disposeGenericValue - ) where - -import Foreign.C.String (CString) -import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) -import Foreign.Ptr (Ptr) - -import LLVM.Core.FFI (ModuleProviderRef, TypeRef, ValueRef) - -#include - -data ExecutionEngine -type ExecutionEngineRef = Ptr ExecutionEngine - -foreign import ccall unsafe "LLVMCreateExecutionEngine" createExecutionEngine - :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString - -> IO CInt - -foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine - :: ExecutionEngineRef -> IO () - -foreign import ccall unsafe "LLVMRunStaticConstructors" runStaticConstructors - :: ExecutionEngineRef -> IO () - -foreign import ccall unsafe "LLVMRunStaticDestructors" runStaticDestructors - :: ExecutionEngineRef -> IO () - - -data GenericValue -type GenericValueRef = Ptr GenericValue - -foreign import ccall unsafe "LLVMCreateGenericValueOfInt" - createGenericValueOfInt :: TypeRef -> CULLong -> CInt - -> IO GenericValueRef - -foreign import ccall unsafe "LLVMGenericValueToInt" genericValueToInt - :: GenericValueRef -> CInt -> CULLong - -foreign import ccall unsafe "LLVMCreateGenericValueOfFloat" - createGenericValueOfFloat :: TypeRef -> CDouble -> IO GenericValueRef - -foreign import ccall unsafe "LLVMGenericValueToFloat" genericValueToFloat - :: GenericValueRef -> CDouble - -foreign import ccall unsafe "LLVMDisposeGenericValue" disposeGenericValue - :: GenericValueRef -> IO () - -foreign import ccall unsafe "LLVMRunFunction" runFunction - :: ExecutionEngineRef -> ValueRef -> CUInt - -> Ptr GenericValueRef -> IO GenericValueRef diff --git a/LLVM/FFI/Analysis.hsc b/LLVM/FFI/Analysis.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/Analysis.hsc @@ -0,0 +1,19 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module LLVM.FFI.Analysis where +import Foreign.C.String(CString) +import Foreign.C.Types(CInt) +import Foreign.Ptr(Ptr) + +import LLVM.FFI.Core + +type VerifierFailureAction = CInt + +foreign import ccall unsafe "LLVMVerifyFunction" verifyFunction + :: ValueRef -> VerifierFailureAction -> IO CInt +foreign import ccall unsafe "LLVMVerifyModule" verifyModule + :: ModuleRef -> VerifierFailureAction -> (Ptr CString) -> IO CInt +foreign import ccall unsafe "LLVMViewFunctionCFG" viewFunctionCFG + :: ValueRef -> IO () +foreign import ccall unsafe "LLVMViewFunctionCFGOnly" viewFunctionCFGOnly + :: ValueRef -> IO () diff --git a/LLVM/FFI/BitReader.hsc b/LLVM/FFI/BitReader.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/BitReader.hsc @@ -0,0 +1,13 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module LLVM.FFI.BitReader where +import Foreign.C.String(CString) +import Foreign.C.Types(CInt) +import Foreign.Ptr(Ptr) + +import LLVM.FFI.Core + +foreign import ccall unsafe "LLVMGetBitcodeModuleProvider" getBitcodeModuleProvider + :: MemoryBufferRef -> (Ptr ModuleProviderRef) -> (Ptr CString) -> IO CInt +foreign import ccall unsafe "LLVMParseBitcode" parseBitcode + :: MemoryBufferRef -> (Ptr ModuleRef) -> (Ptr CString) -> IO CInt diff --git a/LLVM/FFI/BitWriter.hsc b/LLVM/FFI/BitWriter.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/BitWriter.hsc @@ -0,0 +1,12 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module LLVM.FFI.BitWriter where +import Foreign.C.String(CString) +import Foreign.C.Types(CInt) + +import LLVM.FFI.Core + +foreign import ccall unsafe "LLVMWriteBitcodeToFile" writeBitcodeToFile + :: ModuleRef -> CString -> IO CInt +foreign import ccall unsafe "LLVMWriteBitcodeToFileHandle" writeBitcodeToFileHandle + :: ModuleRef -> CInt -> IO CInt diff --git a/LLVM/FFI/Core.hsc b/LLVM/FFI/Core.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/Core.hsc @@ -0,0 +1,1112 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +-- | +-- Module: LLVM.FFI.Core +-- Copyright: Bryan O'Sullivan 2007, 2008 +-- License: BSD-style (see the file LICENSE) +-- +-- Maintainer: bos@serpentine.com +-- Stability: experimental +-- Portability: requires GHC 6.8, LLVM +-- +-- This module provides direct access to the LLVM C bindings. + +module LLVM.FFI.Core + ( + -- * Modules + Module + , ModuleRef + , moduleCreateWithName + , disposeModule + + , getDataLayout + , setDataLayout + + , getTarget + , setTarget + + -- * Module providers + , ModuleProvider + , ModuleProviderRef + , createModuleProviderForExistingModule + , disposeModuleProvider + + -- * Types + , Type + , TypeRef + , addTypeName + , deleteTypeName + + , getTypeKind + + -- ** Integer types + , int1Type + , int8Type + , int16Type + , int32Type + , int64Type + , integerType + , getIntTypeWidth + + -- ** Real types + , floatType + , doubleType + , x86FP80Type + , fp128Type + , ppcFP128Type + + -- ** Function types + , functionType + , isFunctionVarArg + , getReturnType + , countParamTypes + , getParamTypes + + -- ** Other types + , voidType + , labelType + , opaqueType + + -- ** Array, pointer, and vector types + , arrayType + , pointerType + , vectorType + , getElementType + , getArrayLength + , getPointerAddressSpace + , getVectorSize + + -- ** Struct types + , structType + , countStructElementTypes + , getStructElementTypes + , isPackedStruct + + -- * Type handles + , createTypeHandle + , refineType + , resolveTypeHandle + , disposeTypeHandle + + -- * Values + , Value + , ValueRef + , typeOf + , getValueName + , setValueName + , dumpValue + + -- ** Constants + , constNull + , constAllOnes + , getUndef + , isConstant + , isNull + , isUndef + + -- ** Global variables, functions, and aliases (globals) + , Linkage + , Visibility + , isDeclaration + , getLinkage + , setLinkage + , getSection + , setSection + , getVisibility + , setVisibility + , getAlignment + , setAlignment + + -- ** Global variables + , addGlobal + , getNamedGlobal + , deleteGlobal + , getInitializer + , setInitializer + , isThreadLocal + , setThreadLocal + , isGlobalConstant + , setGlobalConstant + , getFirstGlobal + , getNextGlobal + , getPreviousGlobal + , getLastGlobal + , getGlobalParent + + -- ** Functions + , addFunction + , getNamedFunction + , deleteFunction + , countParams + , getParams + , getParam + , getIntrinsicID + , getGC + , setGC + , getFirstFunction + , getNextFunction + , getPreviousFunction + , getLastFunction + , getFirstParam + , getNextParam + , getPreviousParam + , getLastParam + , getParamParent + , isTailCall + , setTailCall + + -- ** Phi nodes + , addIncoming + , countIncoming + , getIncomingValue + , getIncomingBlock + + -- ** Calling conventions + , CallingConvention(..) + , fromCallingConvention + , toCallingConvention + , getFunctionCallConv + , setFunctionCallConv + , getInstructionCallConv + , setInstructionCallConv + + -- * Constants + + -- ** Scalar constants + , constInt + , constReal + + -- ** Composite constants + , constArray + , constString + , constStruct + , constVector + + -- ** Constant expressions + , sizeOf + , constNeg + , constNot + , constAdd + , constSub + , constMul + , constUDiv + , constSDiv + , constFDiv + , constURem + , constSRem + , constFRem + , constAnd + , constOr + , constXor + , constICmp + , constFCmp + , constShl + , constLShr + , constAShr + , constGEP + , constTrunc + , constSExt + , constZExt + , constFPTrunc + , constFPExt + , constUIToFP + , constSIToFP + , constFPToUI + , constFPToSI + , constPtrToInt + , constIntToPtr + , constBitCast + , constSelect + , constExtractElement + , constInsertElement + , constShuffleVector + , constRealOfString + + -- * Basic blocks + , BasicBlock + , BasicBlockRef + , basicBlockAsValue + , valueIsBasicBlock + , valueAsBasicBlock + , countBasicBlocks + , getBasicBlocks + , getEntryBasicBlock + , appendBasicBlock + , insertBasicBlock + , deleteBasicBlock + , getFirstBasicBlock + , getNextBasicBlock + , getPreviousBasicBlock + , getLastBasicBlock + , getInsertBlock + , getBasicBlockParent + + -- * Instruction building + , Builder + , BuilderRef + , createBuilder + , disposeBuilder + , positionBuilder + , positionBefore + , positionAtEnd + , getFirstInstruction + , getNextInstruction + , getPreviousInstruction + , getLastInstruction + , getInstructionParent + + -- ** Terminators + , buildRetVoid + , buildRet + , buildBr + , buildCondBr + , buildSwitch + , buildInvoke + , buildUnwind + , buildUnreachable + + -- ** Arithmetic + , buildAdd + , buildSub + , buildMul + , buildUDiv + , buildSDiv + , buildFDiv + , buildURem + , buildSRem + , buildFRem + , buildShl + , buildLShr + , buildAShr + , buildAnd + , buildOr + , buildXor + , buildNeg + , buildNot + + -- ** Memory + , buildMalloc + , buildArrayMalloc + , buildAlloca + , buildArrayAlloca + , buildFree + , buildLoad + , buildStore + , buildGEP + + -- ** Casts + , buildTrunc + , buildZExt + , buildSExt + , buildFPToUI + , buildFPToSI + , buildUIToFP + , buildSIToFP + , buildFPTrunc + , buildFPExt + , buildPtrToInt + , buildIntToPtr + , buildBitCast + + -- ** Comparisons + , buildICmp + , buildFCmp + + -- ** Miscellaneous instructions + , buildPhi + , buildCall + , buildSelect + , buildVAArg + , buildExtractElement + , buildInsertElement + , buildShuffleVector + + -- ** Other helpers + , addCase + + -- * Memory buffers + , MemoryBuffer + , MemoryBufferRef + , createMemoryBufferWithContentsOfFile + , createMemoryBufferWithSTDIN + , disposeMemoryBuffer + + -- * Error handling + , disposeMessage + + -- * Parameter passing + , addInstrAttribute + , addAttribute + , removeInstrAttribute + , removeAttribute + , setInstrParamAlignment + , setParamAlignment + + -- * Pass manager + , PassManager + , PassManagerRef + , createFunctionPassManager + , createPassManager + , disposePassManager + , finalizeFunctionPassManager + , initializeFunctionPassManager + , runFunctionPassManager + , runPassManager + + , dumpModule + ) where + +import Foreign.C.String (CString) +import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) +import Foreign.Ptr (Ptr) + +#include + +data Module +type ModuleRef = Ptr Module + +foreign import ccall unsafe "LLVMModuleCreateWithName" moduleCreateWithName + :: CString -> IO ModuleRef + +foreign import ccall unsafe "LLVMDisposeModule" disposeModule + :: ModuleRef -> IO () + +foreign import ccall unsafe "LLVMGetDataLayout" getDataLayout + :: ModuleRef -> IO CString + +foreign import ccall unsafe "LLVMSetDataLayout" setDataLayout + :: ModuleRef -> CString -> IO () + + +data ModuleProvider +type ModuleProviderRef = Ptr ModuleProvider + +foreign import ccall unsafe "LLVMCreateModuleProviderForExistingModule" + createModuleProviderForExistingModule + :: ModuleRef -> IO ModuleProviderRef + +foreign import ccall unsafe "LLVMDisposeModuleProvider" disposeModuleProvider + :: ModuleProviderRef -> IO () + + +data Type +type TypeRef = Ptr Type + +foreign import ccall unsafe "LLVMInt1Type" int1Type :: TypeRef + +foreign import ccall unsafe "LLVMInt8Type" int8Type :: TypeRef + +foreign import ccall unsafe "LLVMInt16Type" int16Type :: TypeRef + +foreign import ccall unsafe "LLVMInt32Type" int32Type :: TypeRef + +foreign import ccall unsafe "LLVMInt64Type" int64Type :: TypeRef + +-- | An integer type of the given width. +foreign import ccall unsafe "LLVMIntType" integerType + :: CUInt -- ^ width in bits + -> TypeRef + +foreign import ccall unsafe "LLVMFloatType" floatType :: TypeRef + +foreign import ccall unsafe "LLVMDoubleType" doubleType :: TypeRef + +foreign import ccall unsafe "LLVMX86FP80Type" x86FP80Type :: TypeRef + +foreign import ccall unsafe "LLVMFP128Type" fp128Type :: TypeRef + +foreign import ccall unsafe "LLVMPPCFP128Type" ppcFP128Type :: TypeRef + +foreign import ccall unsafe "LLVMVoidType" voidType :: TypeRef + +-- | Create a function type. +foreign import ccall unsafe "LLVMFunctionType" functionType + :: TypeRef -- ^ return type + -> Ptr TypeRef -- ^ array of argument types + -> CUInt -- ^ number of elements in array + -> CInt -- ^ non-zero if function is varargs + -> TypeRef + +-- | Indicate whether a function takes varargs. +foreign import ccall unsafe "LLVMIsFunctionVarArg" isFunctionVarArg + :: TypeRef -> CInt + +-- | Give a function's return type. +foreign import ccall unsafe "LLVMGetReturnType" getReturnType + :: TypeRef -> TypeRef + +-- | Give the number of fixed parameters that a function takes. +foreign import ccall unsafe "LLVMCountParamTypes" countParamTypes + :: TypeRef -> CUInt + +-- | Fill out an array with the types of a function's fixed +-- parameters. +foreign import ccall unsafe "LLVMGetParamTypes" getParamTypes + :: TypeRef -> Ptr TypeRef -> IO () + +foreign import ccall unsafe "LLVMArrayType" arrayType + :: TypeRef -- ^ element type + -> CUInt -- ^ element count + -> TypeRef + +foreign import ccall unsafe "LLVMPointerType" pointerType + :: TypeRef -- ^ pointed-to type + -> CUInt -- ^ address space + -> TypeRef + +foreign import ccall unsafe "LLVMVectorType" vectorType + :: TypeRef -- ^ element type + -> CUInt -- ^ element count + -> TypeRef + +foreign import ccall unsafe "LLVMAddTypeName" addTypeName + :: ModuleRef -> CString -> TypeRef -> IO CInt + +foreign import ccall unsafe "LLVMDeleteTypeName" deleteTypeName + :: ModuleRef -> CString -> IO () + +-- | Give the type of a sequential type's elements. +foreign import ccall unsafe "LLVMGetElementType" getElementType + :: TypeRef -> TypeRef + + +data Value +type ValueRef = Ptr Value + +foreign import ccall unsafe "LLVMAddGlobal" addGlobal + :: ModuleRef -> TypeRef -> CString -> IO ValueRef + +foreign import ccall unsafe "LLVMDeleteGlobal" deleteGlobal + :: ValueRef -> IO () + +foreign import ccall unsafe "LLVMSetInitializer" setInitializer + :: ValueRef -> ValueRef -> IO () + +foreign import ccall unsafe "LLVMGetNamedGlobal" getNamedGlobal + :: ModuleRef -> CString -> IO ValueRef + +foreign import ccall unsafe "LLVMGetInitializer" getInitializer + :: ValueRef -> IO ValueRef + +foreign import ccall unsafe "LLVMIsThreadLocal" isThreadLocal + :: ValueRef -> IO CInt + +foreign import ccall unsafe "LLVMSetThreadLocal" setThreadLocal + :: ValueRef -> CInt -> IO () + +foreign import ccall unsafe "LLVMIsGlobalConstant" isGlobalConstant + :: ValueRef -> IO CInt + +foreign import ccall unsafe "LLVMSetGlobalConstant" setGlobalConstant + :: ValueRef -> CInt -> IO () + +foreign import ccall unsafe "LLVMTypeOf" typeOf + :: ValueRef -> IO TypeRef + +foreign import ccall unsafe "LLVMGetValueName" getValueName + :: ValueRef -> IO CString + +foreign import ccall unsafe "LLVMSetValueName" setValueName + :: ValueRef -> CString -> IO () + +foreign import ccall unsafe "LLVMDumpValue" dumpValue + :: ValueRef -> IO () + +foreign import ccall unsafe "LLVMConstAllOnes" constAllOnes + :: TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstArray" constArray + :: TypeRef -> Ptr ValueRef -> CUInt -> ValueRef + +foreign import ccall unsafe "LLVMConstNull" constNull + :: TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMIsConstant" isConstant + :: ValueRef -> IO CInt + +foreign import ccall unsafe "LLVMGetUndef" getUndef + :: TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMIsNull" isNull + :: ValueRef -> IO CInt + +foreign import ccall unsafe "LLVMIsUndef" isUndef + :: ValueRef -> IO CInt + +foreign import ccall unsafe "LLVMGetNamedFunction" getNamedFunction + :: ModuleRef -- ^ module + -> CString -- ^ name + -> IO ValueRef -- ^ function (@nullPtr@ if not found) + +foreign import ccall unsafe "LLVMAddFunction" addFunction + :: ModuleRef -- ^ module + -> CString -- ^ name + -> TypeRef -- ^ type + -> IO ValueRef + +foreign import ccall unsafe "LLVMDeleteFunction" deleteFunction + :: ValueRef -- ^ function + -> IO () + +foreign import ccall unsafe "LLVMCountParams" countParams + :: ValueRef -- ^ function + -> CUInt + +foreign import ccall unsafe "LLVMGetParam" getParam + :: ValueRef -- ^ function + -> CUInt -- ^ offset into array + -> ValueRef + +foreign import ccall unsafe "LLVMGetParams" getParams + :: ValueRef -- ^ function + -> Ptr ValueRef -- ^ array to fill out + -> IO () + +foreign import ccall unsafe "LLVMGetIntrinsicID" getIntrinsicID + :: ValueRef -- ^ function + -> CUInt + +data CallingConvention = C + | Fast + | Cold + | X86StdCall + | X86FastCall + deriving (Eq, Show) + +fromCallingConvention :: CallingConvention -> CUInt +fromCallingConvention C = (#const LLVMCCallConv) +fromCallingConvention Fast = (#const LLVMFastCallConv) +fromCallingConvention Cold = (#const LLVMColdCallConv) +fromCallingConvention X86StdCall = (#const LLVMX86FastcallCallConv) +fromCallingConvention X86FastCall = (#const LLVMX86StdcallCallConv) + +toCallingConvention :: CUInt -> CallingConvention +toCallingConvention c | c == (#const LLVMCCallConv) = C +toCallingConvention c | c == (#const LLVMFastCallConv) = Fast +toCallingConvention c | c == (#const LLVMColdCallConv) = Cold +toCallingConvention c | c == (#const LLVMX86StdcallCallConv) = X86StdCall +toCallingConvention c | c == (#const LLVMX86FastcallCallConv) = X86FastCall +toCallingConvention c = error $ "LLVM.Core.FFI.toCallingConvention: " ++ + "unsupported calling convention" ++ show c + +foreign import ccall unsafe "LLVMGetFunctionCallConv" getFunctionCallConv + :: ValueRef -- ^ function + -> IO CUInt + +foreign import ccall unsafe "LLVMSetFunctionCallConv" setFunctionCallConv + :: ValueRef -- ^ function + -> CUInt + -> IO () + +foreign import ccall unsafe "LLVMGetGC" getGC + :: ValueRef -> IO CString + +foreign import ccall unsafe "LLVMSetGC" setGC + :: ValueRef -> CString -> IO () + +foreign import ccall unsafe "LLVMIsDeclaration" isDeclaration + :: ValueRef -> IO CInt + +type Linkage = CUInt + +foreign import ccall unsafe "LLVMGetLinkage" getLinkage + :: ValueRef -> IO Linkage + +foreign import ccall unsafe "LLVMSetLinkage" setLinkage + :: ValueRef -> Linkage -> IO () + +foreign import ccall unsafe "LLVMGetSection" getSection + :: ValueRef -> IO CString + +foreign import ccall unsafe "LLVMSetSection" setSection + :: ValueRef -> CString -> IO () + +type Visibility = CUInt + +foreign import ccall unsafe "LLVMGetVisibility" getVisibility + :: ValueRef -> IO Visibility + +foreign import ccall unsafe "LLVMSetVisibility" setVisibility + :: ValueRef -> Visibility -> IO () + +foreign import ccall unsafe "LLVMGetAlignment" getAlignment + :: ValueRef -> IO CUInt + +foreign import ccall unsafe "LLVMSetAlignment" setAlignment + :: ValueRef -> CUInt -> IO () + + +foreign import ccall unsafe "LLVMConstInt" constInt + :: TypeRef -> CULLong -> CInt -> ValueRef + +foreign import ccall unsafe "LLVMConstReal" constReal + :: TypeRef -> CDouble -> ValueRef + +foreign import ccall unsafe "LLVMConstString" constString + :: CString -> CUInt -> CInt -> ValueRef + +foreign import ccall unsafe "LLVMConstStruct" constStruct + :: Ptr ValueRef -> CUInt -> CInt -> ValueRef + +foreign import ccall unsafe "LLVMConstVector" constVector + :: Ptr ValueRef -> CUInt -> ValueRef + +foreign import ccall unsafe "LLVMConstNeg" constNeg + :: ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstNot" constNot + :: ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstAdd" constAdd + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstSub" constSub + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstMul" constMul + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstUDiv" constUDiv + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstSDiv" constSDiv + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFDiv" constFDiv + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstURem" constURem + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstSRem" constSRem + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFRem" constFRem + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstAnd" constAnd + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstOr" constOr + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstXor" constXor + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstICmp" constICmp + :: CInt -> ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFCmp" constFCmp + :: CInt -> ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstShl" constShl + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstLShr" constLShr + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstAShr" constAShr + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstGEP" constGEP + :: ValueRef -> Ptr ValueRef -> CUInt -> ValueRef + +foreign import ccall unsafe "LLVMConstTrunc" constTrunc + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstSExt" constSExt + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstZExt" constZExt + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFPTrunc" constFPTrunc + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFPExt" constFPExt + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstUIToFP" constUIToFP + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstSIToFP" constSIToFP + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFPToUI" constFPToUI + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstFPToSI" constFPToSI + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstPtrToInt" constPtrToInt + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstIntToPtr" constIntToPtr + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstBitCast" constBitCast + :: ValueRef -> TypeRef -> ValueRef + +foreign import ccall unsafe "LLVMConstSelect" constSelect + :: ValueRef -> ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstExtractElement" constExtractElement + :: ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstInsertElement" constInsertElement + :: ValueRef -> ValueRef -> ValueRef -> ValueRef + +foreign import ccall unsafe "LLVMConstShuffleVector" constShuffleVector + :: ValueRef -> ValueRef -> ValueRef -> ValueRef + +type BasicBlock = Value +type BasicBlockRef = Ptr BasicBlock + +foreign import ccall unsafe "LLVMBasicBlockAsValue" basicBlockAsValue + :: BasicBlockRef -> ValueRef + +foreign import ccall unsafe "LLVMValueIsBasicBlock" valueIsBasicBlock + :: ValueRef -> Bool + +foreign import ccall unsafe "LLVMValueAsBasicBlock" valueAsBasicBlock + :: ValueRef -- ^ basic block + -> BasicBlockRef + +foreign import ccall unsafe "LLVMCountBasicBlocks" countBasicBlocks + :: ValueRef -- ^ function + -> IO CUInt + +foreign import ccall unsafe "LLVMGetBasicBlocks" getBasicBlocks + :: ValueRef -- ^ function + -> Ptr BasicBlockRef -- ^ array to fill out + -> IO () + +foreign import ccall unsafe "LLVMGetEntryBasicBlock" getEntryBasicBlock + :: ValueRef -- ^ function + -> IO BasicBlockRef + +foreign import ccall unsafe "LLVMAppendBasicBlock" appendBasicBlock + :: ValueRef -- ^ function + -> CString -- ^ name for label + -> IO BasicBlockRef + +foreign import ccall unsafe "LLVMInsertBasicBlock" insertBasicBlock + :: BasicBlockRef -- ^ insert before this one + -> CString -- ^ name for label + -> IO BasicBlockRef + +foreign import ccall unsafe "LLVMDeleteBasicBlock" deleteBasicBlock + :: BasicBlockRef -> IO () + +data Builder +type BuilderRef = Ptr Builder + +foreign import ccall unsafe "LLVMCreateBuilder" createBuilder + :: IO BuilderRef + +foreign import ccall unsafe "LLVMDisposeBuilder" disposeBuilder + :: BuilderRef -> IO () + +foreign import ccall unsafe "LLVMPositionBuilderBefore" positionBefore + :: BuilderRef -> ValueRef -> IO () + +foreign import ccall unsafe "LLVMPositionBuilderAtEnd" positionAtEnd + :: BuilderRef -> BasicBlockRef -> IO () + +foreign import ccall unsafe "LLVMBuildRetVoid" buildRetVoid + :: BuilderRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildRet" buildRet + :: BuilderRef -> ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildBr" buildBr + :: BuilderRef -> BasicBlockRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildCondBr" buildCondBr + :: BuilderRef -> ValueRef -> BasicBlockRef -> BasicBlockRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSwitch" buildSwitch + :: BuilderRef -> ValueRef -> BasicBlockRef -> CUInt -> IO ValueRef +foreign import ccall unsafe "LLVMBuildInvoke" buildInvoke + :: BuilderRef -> ValueRef -> Ptr ValueRef -> CUInt + -> BasicBlockRef -> BasicBlockRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildUnwind" buildUnwind + :: BuilderRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildUnreachable" buildUnreachable + :: BuilderRef -> IO ValueRef + +foreign import ccall unsafe "LLVMBuildAdd" buildAdd + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSub" buildSub + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildMul" buildMul + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildUDiv" buildUDiv + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSDiv" buildSDiv + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFDiv" buildFDiv + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildURem" buildURem + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSRem" buildSRem + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFRem" buildFRem + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildShl" buildShl + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildLShr" buildLShr + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildAShr" buildAShr + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildAnd" buildAnd + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildOr" buildOr + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildXor" buildXor + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildNeg" buildNeg + :: BuilderRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildNot" buildNot + :: BuilderRef -> ValueRef -> CString -> IO ValueRef + +-- Memory +foreign import ccall unsafe "LLVMBuildMalloc" buildMalloc + :: BuilderRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildArrayMalloc" buildArrayMalloc + :: BuilderRef -> TypeRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildAlloca" buildAlloca + :: BuilderRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildArrayAlloca" buildArrayAlloca + :: BuilderRef -> TypeRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFree" buildFree + :: BuilderRef -> ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildLoad" buildLoad + :: BuilderRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildStore" buildStore + :: BuilderRef -> ValueRef -> ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMBuildGEP" buildGEP + :: BuilderRef -> ValueRef -> Ptr ValueRef -> CUInt -> CString + -> IO ValueRef + +-- Casts +foreign import ccall unsafe "LLVMBuildTrunc" buildTrunc + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildZExt" buildZExt + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSExt" buildSExt + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFPToUI" buildFPToUI + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFPToSI" buildFPToSI + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildUIToFP" buildUIToFP + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSIToFP" buildSIToFP + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFPTrunc" buildFPTrunc + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFPExt" buildFPExt + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildPtrToInt" buildPtrToInt + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildIntToPtr" buildIntToPtr + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildBitCast" buildBitCast + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef + +-- Comparisons +foreign import ccall unsafe "LLVMBuildICmp" buildICmp + :: BuilderRef -> CInt -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildFCmp" buildFCmp + :: BuilderRef -> CInt -> ValueRef -> ValueRef -> CString -> IO ValueRef + +-- Miscellaneous instructions +foreign import ccall unsafe "LLVMBuildPhi" buildPhi + :: BuilderRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildCall" buildCall + :: BuilderRef -> ValueRef -> Ptr ValueRef -> CUInt -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildSelect" buildSelect + :: BuilderRef -> ValueRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildVAArg" buildVAArg + :: BuilderRef -> ValueRef -> TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildExtractElement" buildExtractElement + :: BuilderRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildInsertElement" buildInsertElement + :: BuilderRef -> ValueRef -> ValueRef -> ValueRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMBuildShuffleVector" buildShuffleVector + :: BuilderRef -> ValueRef -> ValueRef -> ValueRef -> CString -> IO ValueRef + +foreign import ccall unsafe "LLVMAddCase" addCase + :: ValueRef -> ValueRef -> BasicBlockRef -> IO () + +foreign import ccall unsafe "LLVMCountIncoming" countIncoming + :: ValueRef -> IO CUInt +foreign import ccall unsafe "LLVMAddIncoming" addIncoming + :: ValueRef -> Ptr ValueRef -> Ptr ValueRef -> CUInt -> IO () +foreign import ccall unsafe "LLVMGetIncomingValue" getIncomingValue + :: ValueRef -> CUInt -> IO ValueRef +foreign import ccall unsafe "LLVMGetIncomingBlock" getIncomingBlock + :: ValueRef -> CUInt -> IO BasicBlockRef + +foreign import ccall unsafe "LLVMGetInstructionCallConv" getInstructionCallConv + :: ValueRef -> IO CUInt +foreign import ccall unsafe "LLVMSetInstructionCallConv" setInstructionCallConv + :: ValueRef -> CUInt -> IO () + +foreign import ccall unsafe "LLVMStructType" structType + :: (Ptr TypeRef) -> CUInt -> CInt -> IO TypeRef +foreign import ccall unsafe "LLVMCountStructElementTypes" + countStructElementTypes :: TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMGetStructElementTypes" getStructElementTypes + :: TypeRef -> (Ptr TypeRef) -> IO () +foreign import ccall unsafe "LLVMIsPackedStruct" isPackedStruct + :: TypeRef -> IO CInt + +data MemoryBuffer +type MemoryBufferRef = Ptr MemoryBuffer + +data TypeHandle +type TypeHandleRef = Ptr TypeHandle + +type TypeKind = CUInt + +foreign import ccall unsafe "LLVMCreateMemoryBufferWithContentsOfFile" createMemoryBufferWithContentsOfFile + :: CString -> Ptr MemoryBufferRef -> Ptr CString -> IO CInt +foreign import ccall unsafe "LLVMCreateMemoryBufferWithSTDIN" createMemoryBufferWithSTDIN + :: Ptr MemoryBufferRef -> Ptr CString -> IO CInt +foreign import ccall unsafe "LLVMCreateTypeHandle" createTypeHandle + :: TypeRef -> IO TypeHandleRef +foreign import ccall unsafe "LLVMDisposeMemoryBuffer" disposeMemoryBuffer + :: MemoryBufferRef -> IO () +foreign import ccall unsafe "LLVMDisposeMessage" disposeMessage + :: CString -> IO () +foreign import ccall unsafe "LLVMDisposeTypeHandle" disposeTypeHandle + :: TypeHandleRef -> IO () +foreign import ccall unsafe "LLVMGetArrayLength" getArrayLength + :: TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMGetIntTypeWidth" getIntTypeWidth + :: TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMGetPointerAddressSpace" getPointerAddressSpace + :: TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMGetTarget" getTarget + :: ModuleRef -> IO CString +foreign import ccall unsafe "LLVMGetTypeKind" getTypeKind + :: TypeRef -> IO TypeKind +foreign import ccall unsafe "LLVMGetVectorSize" getVectorSize + :: TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMRefineType" refineType + :: TypeRef -> TypeRef -> IO () +foreign import ccall unsafe "LLVMResolveTypeHandle" resolveTypeHandle + :: TypeHandleRef -> IO TypeRef +foreign import ccall unsafe "LLVMSetTarget" setTarget + :: ModuleRef -> CString -> IO () +foreign import ccall unsafe "LLVMSizeOf" sizeOf + :: TypeRef -> IO ValueRef + +{- +typedef enum { + LLVMZExtAttribute = 1<<0, + LLVMSExtAttribute = 1<<1, + LLVMNoReturnAttribute = 1<<2, + LLVMInRegAttribute = 1<<3, + LLVMStructRetAttribute = 1<<4, + LLVMNoUnwindAttribute = 1<<5, + LLVMNoAliasAttribute = 1<<6, + LLVMByValAttribute = 1<<7, + LLVMNestAttribute = 1<<8, + LLVMReadNoneAttribute = 1<<9, + LLVMReadOnlyAttribute = 1<<10 +} LLVMAttribute; +-} +type Attribute = CInt + +data PassManager +type PassManagerRef = Ptr PassManager + +foreign import ccall unsafe "LLVMConstRealOfString" constRealOfString + :: TypeRef -> CString -> IO ValueRef +foreign import ccall unsafe "LLVMCreateFunctionPassManager" createFunctionPassManager + :: ModuleProviderRef -> IO PassManagerRef +foreign import ccall unsafe "LLVMCreatePassManager" createPassManager + :: IO PassManagerRef +foreign import ccall unsafe "LLVMDisposePassManager" disposePassManager + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMDumpModule" dumpModule + :: ModuleRef -> IO () +foreign import ccall unsafe "LLVMFinalizeFunctionPassManager" finalizeFunctionPassManager + :: PassManagerRef -> IO CInt +foreign import ccall unsafe "LLVMGetBasicBlockParent" getBasicBlockParent + :: BasicBlockRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetFirstBasicBlock" getFirstBasicBlock + :: ValueRef -> IO BasicBlockRef +foreign import ccall unsafe "LLVMGetFirstFunction" getFirstFunction + :: ModuleRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetFirstGlobal" getFirstGlobal + :: ModuleRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetFirstInstruction" getFirstInstruction + :: BasicBlockRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetFirstParam" getFirstParam + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetGlobalParent" getGlobalParent + :: ValueRef -> IO ModuleRef +foreign import ccall unsafe "LLVMGetInsertBlock" getInsertBlock + :: BuilderRef -> IO BasicBlockRef +foreign import ccall unsafe "LLVMGetInstructionParent" getInstructionParent + :: ValueRef -> IO BasicBlockRef +foreign import ccall unsafe "LLVMGetLastBasicBlock" getLastBasicBlock + :: ValueRef -> IO BasicBlockRef +foreign import ccall unsafe "LLVMGetLastFunction" getLastFunction + :: ModuleRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetLastGlobal" getLastGlobal + :: ModuleRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetLastInstruction" getLastInstruction + :: BasicBlockRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetLastParam" getLastParam + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetNextBasicBlock" getNextBasicBlock + :: BasicBlockRef -> IO BasicBlockRef +foreign import ccall unsafe "LLVMGetNextFunction" getNextFunction + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetNextGlobal" getNextGlobal + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetNextInstruction" getNextInstruction + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetNextParam" getNextParam + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetParamParent" getParamParent + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetPreviousBasicBlock" getPreviousBasicBlock + :: BasicBlockRef -> IO BasicBlockRef +foreign import ccall unsafe "LLVMGetPreviousFunction" getPreviousFunction + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetPreviousGlobal" getPreviousGlobal + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetPreviousInstruction" getPreviousInstruction + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMGetPreviousParam" getPreviousParam + :: ValueRef -> IO ValueRef +foreign import ccall unsafe "LLVMInitializeFunctionPassManager" initializeFunctionPassManager + :: PassManagerRef -> IO CInt +foreign import ccall unsafe "LLVMLabelType" labelType + :: IO TypeRef +foreign import ccall unsafe "LLVMOpaqueType" opaqueType + :: IO TypeRef +foreign import ccall unsafe "LLVMPositionBuilder" positionBuilder + :: BuilderRef -> BasicBlockRef -> ValueRef -> IO () +foreign import ccall unsafe "LLVMRunFunctionPassManager" runFunctionPassManager + :: PassManagerRef -> ValueRef -> IO CInt +foreign import ccall unsafe "LLVMRunPassManager" runPassManager + :: PassManagerRef -> ModuleRef -> IO CInt +foreign import ccall unsafe "LLVMSetInstrParamAlignment" setInstrParamAlignment + :: ValueRef -> CUInt -> CUInt -> IO () +foreign import ccall unsafe "LLVMSetParamAlignment" setParamAlignment + :: ValueRef -> CUInt -> IO () +foreign import ccall unsafe "LLVMAddAttribute" addAttribute + :: ValueRef -> Attribute -> IO () +foreign import ccall unsafe "LLVMAddInstrAttribute" addInstrAttribute + :: ValueRef -> CUInt -> Attribute -> IO () +foreign import ccall unsafe "LLVMIsTailCall" isTailCall + :: ValueRef -> IO CInt +foreign import ccall unsafe "LLVMRemoveAttribute" removeAttribute + :: ValueRef -> Attribute -> IO () +foreign import ccall unsafe "LLVMRemoveInstrAttribute" removeInstrAttribute + :: ValueRef -> CUInt -> Attribute -> IO () +foreign import ccall unsafe "LLVMSetTailCall" setTailCall + :: ValueRef -> CInt -> IO () diff --git a/LLVM/FFI/ExecutionEngine.hsc b/LLVM/FFI/ExecutionEngine.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/ExecutionEngine.hsc @@ -0,0 +1,110 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module LLVM.FFI.ExecutionEngine + ( + -- * Execution engines + ExecutionEngine + , createExecutionEngine + , disposeExecutionEngine + , createInterpreter + , createJITCompiler + , addModuleProvider + , removeModuleProvider + , findFunction + , freeMachineCodeForFunction + , runStaticConstructors + , runStaticDestructors + , runFunction + , runFunctionAsMain + , getExecutionEngineTargetData + , addGlobalMapping + + -- * Generic values + , GenericValue + , GenericValueRef + , createGenericValueOfInt + , genericValueToInt + , genericValueIntWidth + , createGenericValueOfFloat + , genericValueToFloat + , createGenericValueOfPointer + , genericValueToPointer + , disposeGenericValue + ) where + +import Foreign.C.String (CString) +import Foreign.C.Types (CDouble, CInt, CUInt, CULLong) +import Foreign.Ptr (Ptr) + +import LLVM.FFI.Core (ModuleRef, ModuleProviderRef, TypeRef, ValueRef) +import LLVM.FFI.Target(TargetDataRef) + +data ExecutionEngine +type ExecutionEngineRef = Ptr ExecutionEngine + +foreign import ccall unsafe "LLVMCreateExecutionEngine" createExecutionEngine + :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString + -> IO CInt + +foreign import ccall unsafe "LLVMDisposeExecutionEngine" disposeExecutionEngine + :: ExecutionEngineRef -> IO () + +foreign import ccall unsafe "LLVMRunStaticConstructors" runStaticConstructors + :: ExecutionEngineRef -> IO () + +foreign import ccall unsafe "LLVMRunStaticDestructors" runStaticDestructors + :: ExecutionEngineRef -> IO () + + +data GenericValue +type GenericValueRef = Ptr GenericValue + +foreign import ccall unsafe "LLVMCreateGenericValueOfInt" + createGenericValueOfInt :: TypeRef -> CULLong -> CInt + -> IO GenericValueRef + +foreign import ccall unsafe "LLVMGenericValueToInt" genericValueToInt + :: GenericValueRef -> CInt -> CULLong + +foreign import ccall unsafe "LLVMCreateGenericValueOfFloat" + createGenericValueOfFloat :: TypeRef -> CDouble -> IO GenericValueRef + +foreign import ccall unsafe "LLVMGenericValueToFloat" genericValueToFloat + :: GenericValueRef -> CDouble + +foreign import ccall unsafe "LLVMDisposeGenericValue" disposeGenericValue + :: GenericValueRef -> IO () + +foreign import ccall unsafe "LLVMRunFunction" runFunction + :: ExecutionEngineRef -> ValueRef -> CUInt + -> Ptr GenericValueRef -> IO GenericValueRef + +foreign import ccall unsafe "LLVMAddModuleProvider" addModuleProvider + :: ExecutionEngineRef -> ModuleProviderRef -> IO () +foreign import ccall unsafe "LLVMCreateGenericValueOfPointer" + createGenericValueOfPointer :: Ptr a -> IO GenericValueRef +foreign import ccall unsafe "LLVMCreateInterpreter" createInterpreter + :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString -> IO CInt +foreign import ccall unsafe "LLVMCreateJITCompiler" createJITCompiler + :: Ptr ExecutionEngineRef -> ModuleProviderRef -> Ptr CString -> IO CInt +foreign import ccall unsafe "LLVMFindFunction" findFunction + :: ExecutionEngineRef -> CString -> Ptr ValueRef -> IO CInt +foreign import ccall unsafe "LLVMFreeMachineCodeForFunction" + freeMachineCodeForFunction :: ExecutionEngineRef -> ValueRef -> IO () +foreign import ccall unsafe "LLVMGenericValueIntWidth" genericValueIntWidth + :: GenericValueRef -> IO CUInt +foreign import ccall unsafe "LLVMGenericValueToPointer" genericValueToPointer + :: GenericValueRef -> IO (Ptr a) +foreign import ccall unsafe "LLVMRemoveModuleProvider" removeModuleProvider + :: ExecutionEngineRef -> ModuleProviderRef -> Ptr ModuleRef -> Ptr CString + -> IO CInt +foreign import ccall unsafe "LLVMRunFunctionAsMain" runFunctionAsMain + :: ExecutionEngineRef -> ValueRef -> CUInt + -> Ptr CString -- ^ argv + -> Ptr CString -- ^ envp + -> IO CInt + +foreign import ccall unsafe "LLVMGetExecutionEngineTargetData" getExecutionEngineTargetData + :: ExecutionEngineRef -> IO TargetDataRef +foreign import ccall unsafe "LLVMAddGlobalMapping" addGlobalMapping + :: ExecutionEngineRef -> ValueRef -> Ptr () -> IO () diff --git a/LLVM/FFI/Target.hsc b/LLVM/FFI/Target.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/Target.hsc @@ -0,0 +1,50 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module LLVM.FFI.Target where +import Foreign.C.String (CString) +import Foreign.C.Types (CInt, CUInt, CULLong) +import Foreign.Ptr (Ptr) + +import LLVM.FFI.Core + +-- enum { LLVMBigEndian, LLVMLittleEndian }; +type ByteOrdering = CInt; + +data TargetData +type TargetDataRef = Ptr TargetData + +foreign import ccall unsafe "LLVMABIAlignmentOfType" aBIAlignmentOfType + :: TargetDataRef -> TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMABISizeOfType" aBISizeOfType + :: TargetDataRef -> TypeRef -> IO CULLong +foreign import ccall unsafe "LLVMAddTargetData" addTargetData + :: TargetDataRef -> PassManagerRef -> IO () +foreign import ccall unsafe "LLVMByteOrder" byteOrder + :: TargetDataRef -> IO ByteOrdering +foreign import ccall unsafe "LLVMCallFrameAlignmentOfType" callFrameAlignmentOfType + :: TargetDataRef -> TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMCopyStringRepOfTargetData" copyStringRepOfTargetData + :: TargetDataRef -> IO CString +foreign import ccall unsafe "LLVMCreateTargetData" createTargetData + :: CString -> IO TargetDataRef +foreign import ccall unsafe "LLVMDisposeTargetData" disposeTargetData + :: TargetDataRef -> IO () +foreign import ccall unsafe "LLVMElementAtOffset" elementAtOffset + :: TargetDataRef -> TypeRef -> CULLong -> IO CUInt +foreign import ccall unsafe "LLVMIntPtrType" intPtrType + :: TargetDataRef -> IO TypeRef +foreign import ccall unsafe "LLVMInvalidateStructLayout" invalidateStructLayout + :: TargetDataRef -> TypeRef -> IO () +foreign import ccall unsafe "LLVMOffsetOfElement" offsetOfElement + :: TargetDataRef -> TypeRef -> CUInt -> IO CULLong +foreign import ccall unsafe "LLVMPointerSize" pointerSize + :: TargetDataRef -> IO CUInt +foreign import ccall unsafe "LLVMPreferredAlignmentOfGlobal" preferredAlignmentOfGlobal + :: TargetDataRef -> ValueRef -> IO CUInt +foreign import ccall unsafe "LLVMPreferredAlignmentOfType" preferredAlignmentOfType + :: TargetDataRef -> TypeRef -> IO CUInt +foreign import ccall unsafe "LLVMSizeOfTypeInBits" sizeOfTypeInBits + :: TargetDataRef -> TypeRef -> IO CULLong +foreign import ccall unsafe "LLVMStoreSizeOfType" storeSizeOfType + :: TargetDataRef -> TypeRef -> IO CULLong + diff --git a/LLVM/FFI/Transforms/Scalar.hsc b/LLVM/FFI/Transforms/Scalar.hsc new file mode 100644 --- /dev/null +++ b/LLVM/FFI/Transforms/Scalar.hsc @@ -0,0 +1,29 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} + +module LLVM.FFI.Transforms.Scalar( + addCFGSimplificationPass + , addConstantPropagationPass + , addDemoteMemoryToRegisterPass + , addGVNPass + , addInstructionCombiningPass + , addPromoteMemoryToRegisterPass + , addReassociatePass + ) where + +import LLVM.FFI.Core + +foreign import ccall unsafe "LLVMAddCFGSimplificationPass" addCFGSimplificationPass + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddConstantPropagationPass" addConstantPropagationPass + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddDemoteMemoryToRegisterPass" addDemoteMemoryToRegisterPass + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddGVNPass" addGVNPass + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddInstructionCombiningPass" addInstructionCombiningPass + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddPromoteMemoryToRegisterPass" addPromoteMemoryToRegisterPass + :: PassManagerRef -> IO () +foreign import ccall unsafe "LLVMAddReassociatePass" addReassociatePass + :: PassManagerRef -> IO () + diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,8 +1,9 @@ ghc := ghc ghcflags := -Wall -Werror -llvm_prefix ?= $(HOME) -prefix ?= $(HOME) +LLVMLIB=/usr/local +llvm_prefix ?= $(LLVMLIB) +prefix ?= $(LLVMLIB) _lib := $(shell test -d /usr/lib64 && echo lib64 || echo lib) ifeq ($(prefix),$(HOME)) @@ -29,6 +30,13 @@ examples: $(MAKE) -C examples +.PHONY: tests +tests: + $(MAKE) -C tests + +doc haddock: dist/setup-config + ./setup haddock + sdist: dist/setup-config ./setup sdist @@ -37,8 +45,11 @@ ./setup install clean: - -rm -f Setup.hi Setup.hi + -$(MAKE) -C examples clean + -$(MAKE) -C tests clean + -rm -f Setup.hi Setup.o -./setup clean + -rm setup distclean: clean -rm -f setup configure diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -11,29 +11,24 @@ Package status - what to expect ------------------------------- -This package is under heavy development. I've released it quite early -in order to solicit comments and help from interested parties. - -The bindings are currently incomplete, so there are some severe limits -on what you can do. Adding new functions is generally easy, though, -so don't be afraid to get your hands dirty. +This package is still under development. -Also, the type safety of various functions is a bit dubious. The -underlying C bindings to LLVM throw away almost all type information, -so we have to reconstruct types in Haskell. I'm still working on -straightening things out. +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. -Please expect the sands to shift under your feet quite rapidly for a -little while as I add functionality, improve the interfaces, and -generally flesh the bindings out to be thoroughly useful. +The high level interface is mostly safe, but the type system does not +protect against anything that can go wrong, so take care. +And, of course, there's no way to guarantee anything about the +generated code. Jump in and help! ----------------- -I welcome your comments and contributions. You can send email to me -at . If you want to send patches, please get a -copy of the darcs repository: +We welcome your comments and contributions. You can send email to us +at or . If you want to +send patches, please get a copy of the darcs repository: darcs get http://darcs.serpentine.com/llvm diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell > import Distribution.Simple -> main = defaultMainWithHooks defaultUserHooks +> main = defaultMainWithHooks autoconfUserHooks diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.61 for Haskell LLVM bindings 0.0.2. +# Generated by GNU Autoconf 2.61 for Haskell LLVM bindings 0.4.0.0. # # Report bugs to . # @@ -574,8 +574,8 @@ # Identity of this package. PACKAGE_NAME='Haskell LLVM bindings' PACKAGE_TARNAME='llvm' -PACKAGE_VERSION='0.0.2' -PACKAGE_STRING='Haskell LLVM bindings 0.0.2' +PACKAGE_VERSION='0.4.0.0' +PACKAGE_STRING='Haskell LLVM bindings 0.4.0.0' PACKAGE_BUGREPORT='bos@serpentine.com' ac_unique_file="LLVM/ExecutionEngine.hs" @@ -666,7 +666,10 @@ CPP GREP EGREP -llvm_cppflags llvm_engine_libs llvm_includedir llvm_ldflags +llvm_cppflags +llvm_engine_libs +llvm_includedir +llvm_ldflags LIBOBJS LTLIBOBJS' ac_subst_files='' @@ -1184,7 +1187,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures Haskell LLVM bindings 0.0.2 to adapt to many kinds of systems. +\`configure' configures Haskell LLVM bindings 0.4.0.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1245,13 +1248,14 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of Haskell LLVM bindings 0.0.2:";; + short | recursive ) echo "Configuration of Haskell LLVM bindings 0.4.0.0:";; esac cat <<\_ACEOF Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-compiler use the given Haskell compiler --with-llvm-prefix use the version of LLVM at the given location --with-llvm-bindir use LLVM binaries at the given location @@ -1331,7 +1335,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -Haskell LLVM bindings configure 0.0.2 +Haskell LLVM bindings configure 0.4.0.0 generated by GNU Autoconf 2.61 Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, @@ -1345,7 +1349,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell LLVM bindings $as_me 0.0.2, which was +It was created by Haskell LLVM bindings $as_me 0.4.0.0, which was generated by GNU Autoconf 2.61. Invocation command line was $ $0 $@ @@ -2313,11 +2317,19 @@ +# Check whether --with-compiler was given. +if test "${with_compiler+set}" = set; then + withval=$with_compiler; compiler="$withval" +else + compiler=ghc +fi + + # Check whether --with-llvm_prefix was given. if test "${with_llvm_prefix+set}" = set; then withval=$with_llvm_prefix; llvm_prefix="$withval" else - llvm_prefix=/usr/local + llvm_prefix="$prefix" fi @@ -3927,6 +3939,9 @@ + + + cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure @@ -4353,7 +4368,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by Haskell LLVM bindings $as_me 0.0.2, which was +This file was extended by Haskell LLVM bindings $as_me 0.4.0.0, which was generated by GNU Autoconf 2.61. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -4396,7 +4411,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF ac_cs_version="\\ -Haskell LLVM bindings config.status 0.0.2 +Haskell LLVM bindings config.status 0.4.0.0 configured by $0, generated by GNU Autoconf 2.61, with options \\"`echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell LLVM bindings], [0.0.2], [bos@serpentine.com], [llvm]) +AC_INIT([Haskell LLVM bindings], [0.4.0.0], [bos@serpentine.com], [llvm]) AC_CONFIG_SRCDIR([LLVM/ExecutionEngine.hs]) @@ -6,11 +6,17 @@ AC_PROG_CXX +AC_ARG_WITH(compiler, + [AS_HELP_STRING([--with-compiler], + [use the given Haskell compiler])], + compiler="$withval", + compiler=ghc)dnl + AC_ARG_WITH(llvm_prefix, [AS_HELP_STRING([--with-llvm-prefix], [use the version of LLVM at the given location])], llvm_prefix="$withval", - llvm_prefix=/usr/local)dnl + llvm_prefix="$prefix")dnl AC_ARG_WITH(llvm_bindir, [AS_HELP_STRING([--with-llvm-bindir], @@ -42,6 +48,9 @@ AC_CHECK_LIB(LLVMCore, LLVMModuleCreateWithName, [], [AC_MSG_ERROR(could not find LLVM C bindings)]) -AC_SUBST([llvm_cppflags llvm_engine_libs llvm_includedir llvm_ldflags]) +AC_SUBST([llvm_cppflags]) +AC_SUBST([llvm_engine_libs]) +AC_SUBST([llvm_includedir]) +AC_SUBST([llvm_ldflags]) AC_OUTPUT diff --git a/examples/BrainF.hs b/examples/BrainF.hs new file mode 100644 --- /dev/null +++ b/examples/BrainF.hs @@ -0,0 +1,143 @@ +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 Control.Monad.Trans +import Data.Word +import Data.Int +import System.Environment(getArgs) + +import LLVM.Core +import LLVM.ExecutionEngine + +main :: IO () +main = do + aargs <- getArgs + let (args, debug) = if take 1 aargs == ["-"] then (tail aargs, True) else (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 <- if length args == 1 then readFile (head args) else return text + + 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 <- newNamedFunction ExternalLinkage "llvm.memset.i32" + :: TFunction (Ptr Word8 -> Word8 -> Word32 -> Word32 -> IO ()) + 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 <- icmp IntEQ 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 InternalLinkage $ do + ptr_arr <- arrayMalloc wmemtotal + call memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) +-- _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 () + + when (debug) $ + liftIO $ dumpValue brainf + + return brainf diff --git a/examples/Fibonacci.hs b/examples/Fibonacci.hs --- a/examples/Fibonacci.hs +++ b/examples/Fibonacci.hs @@ -1,61 +1,100 @@ -{-# LANGUAGE TypeOperators #-} +module Fibonacci where +import Prelude hiding(and, or) +import System.Environment(getArgs) +import Control.Monad(forM_) +import Data.Word -module Fibonacci (main) where +import LLVM.Core +import LLVM.ExecutionEngine -import Control.Monad (forM_) -import Data.Int (Int32) -import System.Environment (getArgs) +-- Our module will have these two functions. +data Mod = Mod { + mfib :: Function (Word32 -> IO Word32), + mplus :: Function (Word32 -> Word32 -> IO Word32) + } -import qualified LLVM.Core as Core -import qualified LLVM.Core.Builder as B -import qualified LLVM.Core.Constant as C -import qualified LLVM.Core.Instruction as I -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V -import qualified LLVM.Core.Utils as U -import qualified LLVM.ExecutionEngine as EE +main :: IO () +main = do + args <- getArgs + let args' = if null args then ["10"] else args -buildFib :: T.Module -> IO (V.Function T.Int32 T.Int32) -buildFib m = do - let one = C.const (1::Int32) - two = C.const (2::Int32) - (fib, entry) <- U.defineFunction m "fib" (T.function undefined undefined) - bld <- B.createBuilder - exit <- Core.appendBasicBlock fib "return" - recurse <- Core.appendBasicBlock fib "recurse" - let arg = V.params fib + -- Create a module, + m <- newNamedModule "fib" + -- and define its contents. + fns <- defineModule m buildMod - B.positionAtEnd bld entry - test <- B.icmp bld "" I.IntSLE arg two - B.condBr bld test exit recurse + -- 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 - B.positionAtEnd bld exit - B.ret bld one + -- Create a JIT execution engine for the module. + ee <- createModuleProviderForExistingModule m >>= createExecutionEngine - B.positionAtEnd bld recurse - x1 <- B.sub bld "" arg one - fibx1 <- B.call bld "" fib x1 + -- Generate code for mfib, and then throw away the IO in the type. + -- The result is an ordinary Haskell function. + let fib = unsafePurify $ generateFunction ee $ mfib fns - x2 <- B.sub bld "" arg two - fibx2 <- B.call bld "" fib x2 + -- Run fib for the arguments. + forM_ args' $ \num -> do + putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num)) + return () - B.add bld "" fibx1 fibx2 >>= B.ret bld - return fib +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 -main :: IO () -main = do - args <- getArgs - let args' = if null args then ["10"] else args + -- Test if x is even/odd. + a <- and x (1 :: Word32) + c <- icmp IntEQ a (0 :: Word32) + condBr c l1 l2 - m <- Core.createModule "fib" - fib <- buildFib m - V.dumpValue fib + -- Do x+y if even. + defineBasicBlock l1 + r1 <- add x y + br l3 - prov <- Core.createModuleProviderForExistingModule m - ee <- EE.createExecutionEngine prov - - forM_ args' $ \num -> do - putStr $ "fib " ++ num ++ " = " - parm <- EE.createGeneric (read num :: Int) - gv <- EE.runFunction ee fib [parm] - print (EE.fromGeneric gv :: Int) + -- 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 <- icmp IntUGT arg (2::Word32) + condBr test recurse exit + + -- Just return 1 if not > 2 + defineBasicBlock exit + ret (1::Word32) + + -- Recurse if > 2, using the cumbersome plus to add the results. + defineBasicBlock recurse + x1 <- sub arg (1::Word32) + fibx1 <- call fib x1 + x2 <- sub arg (2::Word32) + fibx2 <- call fib x2 + r <- call plus fibx1 fibx2 + ret r + + -- Return the two functions. + return $ Mod fib plus diff --git a/examples/HelloJIT.hs b/examples/HelloJIT.hs --- a/examples/HelloJIT.hs +++ b/examples/HelloJIT.hs @@ -1,44 +1,24 @@ -{-# LANGUAGE TypeOperators #-} module HelloJIT (main) where -import Data.Int (Int32) -import Prelude hiding (mod) - -import qualified LLVM.Core as Core -import qualified LLVM.Core.Builder as B -import qualified LLVM.Core.Constant as C -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V -import qualified LLVM.Core.Utils as U -import qualified LLVM.ExecutionEngine as EE - +import Data.Word -buildModule :: IO (T.Module, V.Function T.Int32 ()) -buildModule = do - mod <- Core.createModule "hello" - greetz <- U.defineGlobal mod "greeting" (C.const "hello jit!") - let t = T.function (undefined :: T.Int32) (undefined :: T.Pointer T.Int8) - putStrLn $ "type of puts: " ++ show t - puts <- U.declareFunction mod "puts" t - (func, entry) <- U.defineFunction mod "main" - (T.function (undefined :: T.Int32) ()) - bld <- B.createBuilder - B.positionAtEnd bld entry - let zero = C.const (0::Int32) - tmp <- B.getElementPtr bld "tmp" greetz [zero, zero] - B.call_ bld "" puts tmp - B.ret bld zero - return (mod, func) +import LLVM.Core +import LLVM.ExecutionEngine -execute :: T.Module -> V.Function T.Int32 () -> IO () -execute mod func = do - prov <- Core.createModuleProviderForExistingModule mod - ee <- EE.createExecutionEngine prov - EE.runStaticConstructors ee - gv <- EE.runFunction ee func [] - print (EE.fromGeneric gv :: Int32) - EE.runStaticDestructors ee - return () +bldGreet :: CodeGenModule (Function (IO ())) +bldGreet = do + puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) + greetz <- createStringNul "Hello, JIT!" + func <- createFunction ExternalLinkage $ do + tmp <- getElementPtr greetz (0::Word32, (0::Word32, ())) + call puts tmp -- Throw away return value. + ret () + return func main :: IO () -main = buildModule >>= uncurry execute +main = do + greet <- simpleFunction bldGreet + greet + greet + greet + return () diff --git a/examples/HowToUseJIT.hs b/examples/HowToUseJIT.hs deleted file mode 100644 --- a/examples/HowToUseJIT.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -module HowToUseJIT (main) where - -import LLVM.Core.Type ((:->)(..)) -import qualified LLVM.Core as Core -import qualified LLVM.Core.Builder as B -import qualified LLVM.Core.Constant as C -import qualified LLVM.Core.Type as T -import qualified LLVM.Core.Value as V -import qualified LLVM.Core.Utils as U -import qualified LLVM.ExecutionEngine as EE -import Data.Int (Int32) - -main :: IO () -main = do - m <- Core.createModule "test" - let t = T.function (undefined :: T.Int32) (undefined :: T.Int32 :-> T.Int32) - - (add1, addEntry) <- U.defineFunction m "add1" t - let a :-> b = V.params add1 - V.setName a "a" - - bld <- B.createBuilder - B.positionAtEnd bld addEntry - v1 <- B.add bld "" (C.const (1::Int32)) a - v2 <- B.add bld "" v1 b - B.ret bld v2 - V.dumpValue add1 - - (foo, fooEntry) <- U.defineFunction m "foo" (T.function (undefined :: T.Int32) ()) - B.positionAtEnd bld fooEntry - c <- B.call bld "wibble" add1 (C.const (1::Int32) :-> C.const (10::Int32)) - B.ret bld c - V.dumpValue foo - - prov <- Core.createModuleProviderForExistingModule m - ee <- EE.createExecutionEngine prov - EE.runStaticConstructors ee - gv <- EE.runFunction ee foo [] - EE.runStaticDestructors ee - print (EE.fromGeneric gv :: Int32) - return () diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -1,11 +1,26 @@ ghc := ghc -ghcflags := -Wall -Werror -examples := Fibonacci HelloJIT HowToUseJIT +ghcflags := -Wall +examples := HelloJIT Fibonacci BrainF all: $(examples) %: %.hs $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< +%.run: % + ./$< + +run: $(examples:%=%.run) + +N=40 +fastfib: Fibonacci + @rm -f Fib.bc Fib.s + time ./Fibonacci $(N) + opt -std-compile-opts Fibonacci.bc -o Fib.bc + llc Fib.bc + $(CC) mainfib.c Fib.s -o Fib + time ./Fib $(N) + @echo Have a look at Fib.s if you like to see clever code. + clean: - -rm -f *.o *.hi $(examples) + rm -f $(examples) *.o *.hi *.s *.bc Fib diff --git a/llvm.buildinfo.in b/llvm.buildinfo.in --- a/llvm.buildinfo.in +++ b/llvm.buildinfo.in @@ -1,4 +1,4 @@ ghc-options: @llvm_cppflags@ -pgml @CXX@ ld-options: @llvm_ldflags@ @llvm_engine_libs@ -lstdc++ include-dirs: @llvm_includedir@ -extra-libraries: LLVMCore LLVMTarget LLVMSupport LLVMSystem +extra-libraries: LLVMAnalysis LLVMBitWriter LLVMBitReader LLVMCore LLVMTarget LLVMSupport LLVMSystem diff --git a/llvm.cabal b/llvm.cabal --- a/llvm.cabal +++ b/llvm.cabal @@ -1,13 +1,19 @@ name: llvm -version: 0.0.2 +version: 0.4.0.0 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit description: Bindings to the LLVM compiler toolkit author: Bryan O'Sullivan +author: Lennart Augustsson maintainer: Bryan O'Sullivan -category: Compilers/Interpreters -cabal-version: >= 1.2.1 +maintainer: Lennart Augustsson +homepage: http://www.serpentine.com/blog/software/llvm/ +stability: experimental +category: Compilers/Interpreters, Code Generation +tested-with: GHC == 6.8.2, GHC == 6.10.1 +cabal-version: >= 1.2.3 +build-type: Configure extra-source-files: INSTALL.txt @@ -16,10 +22,14 @@ README.txt configure configure.ac + examples/BrainF.hs examples/Fibonacci.hs examples/HelloJIT.hs - examples/HowToUseJIT.hs examples/Makefile + tests/Makefile + tests/TestValue.hs + tools/Makefile + tools/IntrinsicMangler.hs llvm.buildinfo.in extra-tmp-files: @@ -40,25 +50,27 @@ build-depends: base >= 2.0 && < 2.2 cpp-options: -DBYTESTRING_IN_BASE else - build-depends: base < 2.0 || >= 2.2, bytestring >= 0.9 + build-depends: base < 2.0 || >= 2.2, bytestring >= 0.9, mtl - extensions: - EmptyDataDecls - FlexibleInstances - ForeignFunctionInterface - GeneralizedNewtypeDeriving - TypeOperators - TypeSynonymInstances - ghc-options: -Wall -Werror + ghc-options: -Wall exposed-modules: + Data.TypeNumbers LLVM.Core - LLVM.Core.FFI - LLVM.Core.Builder - LLVM.Core.Constant - LLVM.Core.Instruction - LLVM.Core.Type - LLVM.Core.Utils - LLVM.Core.Value LLVM.ExecutionEngine - LLVM.ExecutionEngine.FFI + LLVM.FFI.Analysis + LLVM.FFI.BitReader + LLVM.FFI.BitWriter + LLVM.FFI.Core + LLVM.FFI.ExecutionEngine + LLVM.FFI.Target + LLVM.FFI.Transforms.Scalar + + other-modules: + LLVM.Core.CodeGen + LLVM.Core.CodeGenMonad + LLVM.Core.Data + LLVM.Core.Instructions + LLVM.Core.Type + LLVM.Core.Util + LLVM.ExecutionEngine.Engine diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,16 @@ +ghc := ghc +ghcflags := -Wall -Werror +tests := TestType TestValue + +all: $(tests:%=%.out) + +%.out: %.test + ./$< > $@ 2>&1; s=$$?; cat $@; \ + if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi + +.PRECIOUS: %.test +%.test: %.hs + $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< + +clean: + -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out) diff --git a/tests/TestValue.hs b/tests/TestValue.hs new file mode 100644 --- /dev/null +++ b/tests/TestValue.hs @@ -0,0 +1,69 @@ +module TestValue (main) where + +import qualified LLVM.Core as Core +import qualified LLVM.Core.Type as T +import qualified LLVM.Core.Value as V + +testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v) + => T.Module -> String -> IO (V.Function r p) +testArguments m name = do + func <- Core.addFunction m name (T.function undefined undefined) + V.dumpValue func + let arg = V.params func + V.dumpValue arg + return func + +voidArguments :: T.Module -> IO () +voidArguments m = do + func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ()) + V.dumpValue func + return () + +type F a = V.Function a a +type P a = V.Function (T.Pointer a) (T.Pointer a) +type V a = V.Function (T.Vector a) (T.Vector a) + +arguments :: T.Module -> IO () +arguments m = do + voidArguments m + + testArguments m "int1" :: IO (F T.Int1) + testArguments m "int8" :: IO (F T.Int8) + testArguments m "int16" :: IO (F T.Int16) + testArguments m "int32" :: IO (F T.Int32) + testArguments m "int64" :: IO (F T.Int64) + testArguments m "float" :: IO (F T.Float) + testArguments m "double" :: IO (F T.Double) + testArguments m "float128" :: IO (F T.Float128) + testArguments m "x86Float80" :: IO (F T.X86Float80) + testArguments m "ppcFloat128" :: IO (F T.PPCFloat128) + + testArguments m "ptrInt1" :: IO (P T.Int1) + testArguments m "ptrInt8" :: IO (P T.Int8) + testArguments m "ptrInt16" :: IO (P T.Int16) + testArguments m "ptrInt32" :: IO (P T.Int32) + testArguments m "ptrInt64" :: IO (P T.Int64) + testArguments m "ptrFloat" :: IO (P T.Float) + testArguments m "ptrDouble" :: IO (P T.Double) + testArguments m "ptrFloat128" :: IO (P T.Float128) + testArguments m "ptrX86Float80" :: IO (P T.X86Float80) + testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128) + + testArguments m "vecInt1" :: IO (V T.Int1) + testArguments m "vecInt8" :: IO (V T.Int8) + testArguments m "vecInt16" :: IO (V T.Int16) + testArguments m "vecInt32" :: IO (V T.Int32) + testArguments m "vecInt64" :: IO (V T.Int64) + testArguments m "vecFloat" :: IO (V T.Float) + testArguments m "vecDouble" :: IO (V T.Double) + testArguments m "vecFloat128" :: IO (V T.Float128) + testArguments m "vecX86Float80" :: IO (V T.X86Float80) + testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128) + + return () + +main :: IO () +main = do + m <- Core.createModule "m" + arguments m + return () diff --git a/tools/IntrinsicMangler.hs b/tools/IntrinsicMangler.hs new file mode 100644 --- /dev/null +++ b/tools/IntrinsicMangler.hs @@ -0,0 +1,22 @@ +module IntrinsicMangler (main) where + +import Control.Monad (forM_) +import qualified Data.ByteString.Char8 as C +import Data.Maybe (catMaybes) +import Text.Regex.Posix ((=~~)) + +maybeName :: C.ByteString -> Maybe C.ByteString +maybeName line = do + ((_:name:_):_) <- line =~~ "^[ \t]*([a-z0-9_]+),[ \t]*//[ \t]*llvm\\." + return name + +main :: IO () +main = do + input <- (catMaybes . map maybeName . C.lines) `fmap` C.getContents + + putStrLn "-- automatically generated file - do not edit!" + putStrLn "module LLVM.Core.Intrinsics (Intrinsic(..)) where" + putStrLn "data Intrinsic =" + putStrLn " NotIntrinsic" + forM_ input $ C.putStrLn . (C.append (C.pack " | I_")) + putStrLn " deriving (Eq, Ord, Enum, Show)" diff --git a/tools/Makefile b/tools/Makefile new file mode 100644 --- /dev/null +++ b/tools/Makefile @@ -0,0 +1,11 @@ +ghc := ghc +ghcflags := -O -Wall -Werror +tools := DiffFFI FunctionMangler IntrinsicMangler + +all: $(tools) + +%: %.hs + $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< + +clean: + -rm -f *.o *.hi $(tools)