packages feed

llvm 0.0.2 → 0.4.0.0

raw patch · 41 files changed

+3742/−2950 lines, 41 filesdep +mtlsetup-changednew-uploader

Dependencies added: mtl

Files

+ Data/TypeNumbers.hs view
@@ -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)
INSTALL.txt view
@@ -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.
LLVM/Core.hs view
@@ -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
− LLVM/Core/Builder.hs 
@@ -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
+ LLVM/Core/CodeGen.hs view
@@ -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)+-}
+ LLVM/Core/CodeGenMonad.hs view
@@ -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
− LLVM/Core/Constant.hs 
@@ -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
+ LLVM/Core/Data.hs view
@@ -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)
− LLVM/Core/FFI.hsc 
@@ -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 <llvm-c/Core.h>--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 ()
− LLVM/Core/Instruction.hs 
@@ -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
+ LLVM/Core/Instructions.hs view
@@ -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)
LLVM/Core/Type.hs view
@@ -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
+ LLVM/Core/Util.hs view
@@ -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
− LLVM/Core/Utils.hs 
@@ -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)
− LLVM/Core/Value.hs 
@@ -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)
LLVM/ExecutionEngine.hs view
@@ -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
+ LLVM/ExecutionEngine/Engine.hs view
@@ -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
− LLVM/ExecutionEngine/FFI.hsc 
@@ -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 <llvm-c/ExecutionEngine.h>--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
+ LLVM/FFI/Analysis.hsc view
@@ -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 ()
+ LLVM/FFI/BitReader.hsc view
@@ -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
+ LLVM/FFI/BitWriter.hsc view
@@ -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
+ LLVM/FFI/Core.hsc view
@@ -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 <llvm-c/Core.h>++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 ()
+ LLVM/FFI/ExecutionEngine.hsc view
@@ -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 ()
+ LLVM/FFI/Target.hsc view
@@ -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+
+ LLVM/FFI/Transforms/Scalar.hsc view
@@ -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 ()+
Makefile view
@@ -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
README.txt view
@@ -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 <bos@serpentine.com>.  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 <bos@serpentine.com> or <lennart@augustsson.net>.  If you want to+send patches, please get a copy of the darcs repository:    darcs get http://darcs.serpentine.com/llvm
Setup.lhs view
@@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell > import Distribution.Simple-> main = defaultMainWithHooks defaultUserHooks+> main = defaultMainWithHooks autoconfUserHooks
configure view
@@ -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 <bos@serpentine.com>. #@@ -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'`\\"
configure.ac view
@@ -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
+ examples/BrainF.hs view
@@ -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
examples/Fibonacci.hs view
@@ -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
examples/HelloJIT.hs view
@@ -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 ()
− examples/HowToUseJIT.hs 
@@ -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 ()
examples/Makefile view
@@ -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
llvm.buildinfo.in view
@@ -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
llvm.cabal view
@@ -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 <bos@serpentine.com>-category: Compilers/Interpreters-cabal-version: >= 1.2.1+maintainer: Lennart Augustsson <lennart@augustsson.net>+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
+ tests/Makefile view
@@ -0,0 +1,16 @@+ghc := ghc+ghcflags := -Wall -Werror+tests := TestType TestValue++all: $(tests:%=%.out)++%.out: %.test+	./$< > $@ 2>&1; s=$$?; cat $@; \+	if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi++.PRECIOUS: %.test+%.test: %.hs+	$(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<++clean:+	-rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out)
+ tests/TestValue.hs view
@@ -0,0 +1,69 @@+module TestValue (main) where+    +import qualified LLVM.Core as Core+import qualified LLVM.Core.Type as T+import qualified LLVM.Core.Value as V+  +testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v)+                 => T.Module -> String -> IO (V.Function r p)+testArguments m name = do+  func <- Core.addFunction m name (T.function undefined undefined)+  V.dumpValue func+  let arg = V.params func+  V.dumpValue arg+  return func+  +voidArguments :: T.Module -> IO ()+voidArguments m = do+  func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ())+  V.dumpValue func+  return ()   ++type F a = V.Function a a+type P a = V.Function (T.Pointer a) (T.Pointer a)+type V a = V.Function (T.Vector a) (T.Vector a)++arguments :: T.Module -> IO ()+arguments m = do+  voidArguments m++  testArguments m "int1" :: IO (F T.Int1)+  testArguments m "int8" :: IO (F T.Int8)+  testArguments m "int16" :: IO (F T.Int16)+  testArguments m "int32" :: IO (F T.Int32)+  testArguments m "int64" :: IO (F T.Int64)+  testArguments m "float" :: IO (F T.Float)+  testArguments m "double" :: IO (F T.Double)+  testArguments m "float128" :: IO (F T.Float128)+  testArguments m "x86Float80" :: IO (F T.X86Float80)+  testArguments m "ppcFloat128" :: IO (F T.PPCFloat128)++  testArguments m "ptrInt1" :: IO (P T.Int1)+  testArguments m "ptrInt8" :: IO (P T.Int8)+  testArguments m "ptrInt16" :: IO (P T.Int16)+  testArguments m "ptrInt32" :: IO (P T.Int32)+  testArguments m "ptrInt64" :: IO (P T.Int64)+  testArguments m "ptrFloat" :: IO (P T.Float)+  testArguments m "ptrDouble" :: IO (P T.Double)+  testArguments m "ptrFloat128" :: IO (P T.Float128)+  testArguments m "ptrX86Float80" :: IO (P T.X86Float80)+  testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128)++  testArguments m "vecInt1" :: IO (V T.Int1)+  testArguments m "vecInt8" :: IO (V T.Int8)+  testArguments m "vecInt16" :: IO (V T.Int16)+  testArguments m "vecInt32" :: IO (V T.Int32)+  testArguments m "vecInt64" :: IO (V T.Int64)+  testArguments m "vecFloat" :: IO (V T.Float)+  testArguments m "vecDouble" :: IO (V T.Double)+  testArguments m "vecFloat128" :: IO (V T.Float128)+  testArguments m "vecX86Float80" :: IO (V T.X86Float80)+  testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128)++  return ()++main :: IO ()+main = do+  m <- Core.createModule "m"+  arguments m+  return ()
+ tools/IntrinsicMangler.hs view
@@ -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)"
+ tools/Makefile view
@@ -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)