packages feed

llvm-tf 3.0.1 → 3.0.2

raw patch · 68 files changed

+5759/−5522 lines, 68 filesdep +llvm-tfdep −bytestringdep −directorydep ~basedep ~containersdep ~llvm-basenew-component:exe:llvm-alignnew-component:exe:llvm-arithnew-component:exe:llvm-arraynew-component:exe:llvm-brainfnew-component:exe:llvm-call-convnew-component:exe:llvm-dot-prodnew-component:exe:llvm-fibonaccinew-component:exe:llvm-hello-jitnew-component:exe:llvm-listnew-component:exe:llvm-structnew-component:exe:llvm-varargsnew-component:exe:llvm-vector

Dependencies added: llvm-tf

Dependencies removed: bytestring, directory

Dependency ranges changed: base, containers, llvm-base, process, tfp

Files

− LLVM/Core.hs 
@@ -1,111 +0,0 @@--- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level.--- It supports both stand alone code generation and JITing.--- The Haskell llvm package is a (relatively) high level interface to the LLVM.--- The high level interface makes it easy to construct LLVM code.--- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface.------ LLVM code is organized into modules (type 'Module').--- Each module contains a number of global variables and functions (type 'Function').--- Each functions has a number of basic blocks (type 'BasicBlock').--- Each basic block has a number instructions, where each instruction produces--- a value (type 'Value').------ Unlike assembly code for a real processor the assembly code for LLVM is--- in SSA (Static Single Assignment) form.  This means that each instruction generates--- a new bound variable which may not be assigned again.--- A consequence of this is that where control flow joins from several execution--- paths there has to be a phi pseudo instruction if you want different variables--- to be joined into one.------ The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock')--- follow the same pattern.  First the entity has to be created using @newX@ (where @X@--- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to--- given its definition using @defineX@.  The reason for splitting the creation and--- definition is that you often need to be able to refer to an entity before giving--- it's body, e.g., in two mutually recursive functions.--- The the @newX@ and @defineX@ function can also be done at the same time by using--- @createX@.  Furthermore, an explicit name can be given to an entity by the--- @newNamedX@ function; the @newX@ function just generates a fresh name.-module LLVM.Core(-    -- * Initialize-    initializeNativeTarget,-    -- * Modules-    Module, newModule, newNamedModule, defineModule, destroyModule, createModule,-    ModuleProvider, createModuleProviderForExistingModule,-    PassManager, createPassManager, createFunctionPassManager,-    writeBitcodeToFile, readBitcodeFromFile,-    getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue,-    -- * Instructions-    module LLVM.Core.Instructions,-    -- * Types classification-    module LLVM.Core.Type,-    -- * Extra types-    module LLVM.Core.Data,-    -- * Values and constants-    Value, ConstValue, valueOf, constOf, value,-    zero, allOnes, undef,-    createString, createStringNul,-    withString, withStringNul,-    --constString, constStringNul,-    constVector, constArray,-    constStruct, constPackedStruct,-    toVector, fromVector, vector,-    -- * Code generation-    CodeGenFunction, CodeGenModule,-    -- * Functions-    Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,-    TFunction, liftCodeGenModule, getParams,-    -- * Global variable creation-    Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal,-    externFunction, staticFunction,-    externGlobal, staticGlobal,-    GlobalMappings, getGlobalMappings,-    TGlobal,-    -- * Globals-    Linkage(..),-    -- * Basic blocks-    BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,-    getBasicBlocks,              -    fromLabel, toLabel,-    getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep,-    -- * Misc-    addAttributes, Attribute(..),-    castVarArgs,-    -- * Debugging-    dumpValue, dumpType, getValueName, annotateValueList-    ) where-import qualified LLVM.FFI.Core as FFI-import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType)-import LLVM.Core.CodeGen-import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule, liftCodeGenModule, GlobalMappings, getGlobalMappings)-import LLVM.Core.Data-import LLVM.Core.Instructions-import LLVM.Core.Type-import LLVM.Core.Vector-import LLVM.Target.Native---- |Print a value.-dumpValue :: Value a -> IO ()-dumpValue (Value v) = FFI.dumpValue v---- |Print a type.-dumpType :: Value a -> IO ()-dumpType (Value v) = showTypeOf v >>= putStrLn---- |Get the name of a 'Value'.-getValueName :: Value a -> IO String-getValueName (Value a) = getValueNameU a---- |Convert a varargs function to a regular function.-castVarArgs :: (CastVarArgs a b) => Function a -> Function b-castVarArgs (Value a) = Value a---- TODO for types:--- Enforce free is only called on malloc memory.  (Enforce only one free?)--- Enforce phi nodes a accessor of variables outside the bb--- Enforce bb terminator--- Enforce phi first------ TODO:--- Add Struct, PackedStruct types--- Get alignment from code gen
− LLVM/Core/CodeGen.hs 
@@ -1,513 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TypeFamilies #-}-module LLVM.Core.CodeGen(-    -- * Module creation-    newModule, newNamedModule, defineModule, createModule,-    getModuleValues, ModuleValue, castModuleValue,-    -- * Globals-    Linkage(..),-    Visibility(..),-    -- * Function creation-    Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,-    addAttributes,-    FFI.Attribute(..),-    externFunction, staticFunction,-    FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult,-    TFunction,-    -- * Global variable creation-    Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal,-    externGlobal, staticGlobal,-    -- * Values-    Value(..), ConstValue(..),-    IsConst(..), valueOf, value,-    zero, allOnes, undef,-    createString, createStringNul,-    withString, withStringNul,-    constVector, constArray, constStruct, constPackedStruct,-    -- * Basic blocks-    BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,-    fromLabel, toLabel,-    -- * Misc-    withCurrentBuilder-    ) where-import Data.Typeable-import Control.Monad(liftM, when)-import Data.Int-import Data.Word-import Data.Maybe(fromMaybe)-import Foreign.StablePtr (StablePtr, castStablePtrToPtr)-import Foreign.Ptr(minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr)-import qualified Foreign.Storable as St-import Types.Data.Num-import LLVM.Core.CodeGenMonad-import qualified LLVM.FFI.Core as FFI-import LLVM.FFI.Core(Linkage(..), Visibility(..))-import qualified LLVM.Core.Util as U-import LLVM.Core.Type-import LLVM.Core.Data-------------------------------------------- | Create a new module.-newModule :: IO U.Module-newModule = newNamedModule "_module"  -- XXX should generate a name---- | Create a new explicitely named module.-newNamedModule :: String              -- ^ module name-               -> IO U.Module-newNamedModule = U.createModule---- | Give the body for a module.-defineModule :: U.Module              -- ^ module that is defined-             -> CodeGenModule a       -- ^ module body-             -> IO a-defineModule = runCodeGenModule---- | Create a new module with the given body.-createModule :: CodeGenModule a       -- ^ module body-             -> IO a-createModule cgm = newModule >>= \ m -> defineModule m cgm------------------------------------------newtype ModuleValue = ModuleValue FFI.ValueRef-    deriving (Show, Typeable)--getModuleValues :: U.Module -> IO [(String, ModuleValue)]-getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues--castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a)-castModuleValue (ModuleValue f) =-    if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing------------------------------------------newtype Value a = Value { unValue :: FFI.ValueRef }-    deriving (Show, Typeable)--newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef }-    deriving (Show, Typeable)---- XXX merge with IsArithmetic?-class IsConst a where-    constOf :: a -> ConstValue a--instance IsConst Bool   where constOf = constEnum (typeRef True)---instance IsConst Char   where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode-instance IsConst Word8  where constOf = constI-instance IsConst Word16 where constOf = constI-instance IsConst Word32 where constOf = constI-instance IsConst Word64 where constOf = constI-instance IsConst Int8   where constOf = constI-instance IsConst Int16  where constOf = constI-instance IsConst Int32  where constOf = constI-instance IsConst Int64  where constOf = constI-instance IsConst Float  where constOf = constF-instance IsConst Double where constOf = constF---instance IsConst FP128  where constOf = constF--constOfPtr :: (IsType ptr) =>-    ptr -> Ptr b -> ConstValue ptr-constOfPtr proto p =-    let ip = p `minusPtr` nullPtr-        inttoptrC :: ConstValue int -> ConstValue ptr-        inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto)-    in  if St.sizeOf p == 4 then-            inttoptrC $ constOf (fromIntegral ip :: Word32)-        else if St.sizeOf p == 8 then-            inttoptrC $ constOf (fromIntegral ip :: Word64)-        else-            error "constOf Ptr: pointer size not 4 or 8"---- This instance doesn't belong here, but mutually recursive modules are painful.-instance (IsType a) => IsConst (Ptr a) where-    constOf p = constOfPtr p p--instance IsConst (StablePtr a) where-    constOf p = constOfPtr p (castStablePtrToPtr p)--instance (IsPrimitive a, IsConst a, PositiveT n) => IsConst (Vector n a) where-    constOf (Vector xs) = constVector (map constOf xs)--instance (IsConst a, IsSized a, NaturalT n) => IsConst (Array n a) where-    constOf (Array xs) = constArray (map constOf xs)--instance (IsConstFields a) => IsConst (Struct a) where-    constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False-instance (IsConstFields a) => IsConst (PackedStruct a) where-    constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True--class IsConstFields a where-    constFieldsOf :: a -> [FFI.ValueRef]--instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where-    constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as-instance IsConstFields () where-    constFieldsOf _ = []--constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a-constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0--constI :: (IsInteger a, Integral a) => a -> ConstValue a-constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i)--constF :: (IsFloating a, Real a) => a -> ConstValue a-constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i)--valueOf :: (IsConst a) => a -> Value a-valueOf = value . constOf--value :: ConstValue a -> Value a-value (ConstValue a) = Value a--zero :: forall a . (IsType a) => ConstValue a-zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a)--allOnes :: forall a . (IsInteger a) => ConstValue a-allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a)--undef :: forall a . (IsType a) => ConstValue a-undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a)--{--createString :: String -> ConstValue (DynamicArray Word8)-createString = ConstValue . U.constString--constStringNul :: String -> ConstValue (DynamicArray Word8)-constStringNul = ConstValue . U.constStringNul--}--------------------------------------------- |A function is simply a pointer to the function.-type Function a = Value (Ptr a)---- | Create a new named function.-newNamedFunction :: forall a . (IsFunction a)-                 => Linkage-                 -> String   -- ^ Function name-                 -> CodeGenModule (Function a)-newNamedFunction linkage name = do-    modul <- getModule-    let typ = typeRef (undefined :: a)-    liftIO $ liftM Value $ U.addFunction modul linkage name typ---- | Create a new function.  Use 'newNamedFunction' to create a function with external linkage, since--- it needs a known name.-newFunction :: forall a . (IsFunction a)-            => Linkage-            -> CodeGenModule (Function a)-newFunction linkage = genMSym "fun" >>= newNamedFunction linkage---- | Define a function body.  The basic block returned by the function is the function entry point.-defineFunction :: forall f . (FunctionArgs f)-               => Function f        -- ^ Function to define (created by 'newFunction').-               -> FunctionCodeGen f -- ^ Function body.-               -> CodeGenModule ()-defineFunction fn body = do-    bld <- liftIO $ U.createBuilder-    let body' = do-	    l <- newBasicBlock-	    defineBasicBlock l-	    applyArgs fn body :: CodeGenFunction (FunctionResult f) ()-    runCodeGenFunction bld (unValue fn) body'-    return ()---- | Create a new function with the given body.-createFunction :: (FunctionArgs f)-               => Linkage-               -> FunctionCodeGen f  -- ^ Function body.-               -> CodeGenModule (Function f)-createFunction linkage body = do-    f <- newFunction linkage-    defineFunction f body-    return f---- | Create a new function with the given body.-createNamedFunction :: (FunctionArgs f)-               => Linkage-	       -> String-               -> FunctionCodeGen f  -- ^ Function body.-               -> CodeGenModule (Function f)-createNamedFunction linkage name body = do-    f <- newNamedFunction linkage name-    defineFunction f body-    return f---- | Set the calling convention of a function. By default it is the--- C calling convention.-setFuncCallConv :: Function a-                -> FFI.CallingConvention-                -> CodeGenModule ()-setFuncCallConv (Value f) cc = do-  liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc)-  return ()---- | Add attributes to a value.  Beware, what attributes are allowed depends on--- what kind of value it is.-addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r ()-addAttributes (Value f) i as = do-    liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as)---- Convert a function of type f = t1->t2->...-> IO r to--- g = Value t1 -> Value t2 -> ... CodeGenFunction r ()-class IsFunction f => FunctionArgs f where-    type FunctionCodeGen f :: *-    type FunctionResult  f :: *-    apArgs :: Int -> Function f -> FunctionCodeGen f -> CodeGenFunction (FunctionResult f) ()--applyArgs ::-    (FunctionArgs f) =>-    Function f -> FunctionCodeGen f -> CodeGenFunction (FunctionResult f) ()-applyArgs = apArgs 0--removeArg :: Function (a -> b) -> Function b-removeArg (Value f) = Value f--instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where-    type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b-    type FunctionResult  (a -> b) = FunctionResult b-    apArgs n f g = apArgs (n+1) (removeArg f) (g $ Value $ U.getParam (unValue f) n)--instance IsFirstClass a => FunctionArgs (IO a) where-    type FunctionCodeGen (IO a) = CodeGenFunction a ()-    type FunctionResult (IO a) = a-    apArgs _ _ g = g---- | This class is just to simplify contexts.--- May be less useful since we convert functional dependencies to type families-class (FunctionArgs (IO a)) => FunctionRet a-instance (FunctionArgs (IO a)) => FunctionRet a-------------------------------------------- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction.-newtype BasicBlock = BasicBlock FFI.BasicBlockRef-    deriving (Show, Typeable)--createBasicBlock :: CodeGenFunction r BasicBlock-createBasicBlock = do-    b <- newBasicBlock-    defineBasicBlock b-    return b--newBasicBlock :: CodeGenFunction r BasicBlock-newBasicBlock = genFSym >>= newNamedBasicBlock--newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock-newNamedBasicBlock name = do-    fn <- getFunction-    liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name--defineBasicBlock :: BasicBlock -> CodeGenFunction r ()-defineBasicBlock (BasicBlock l) = do-    bld <- getBuilder-    liftIO $ U.positionAtEnd bld l--getCurrentBasicBlock :: CodeGenFunction r BasicBlock-getCurrentBasicBlock = do-    bld <- getBuilder-    liftIO $ liftM BasicBlock $ U.getInsertBlock bld--toLabel :: BasicBlock -> Value Label-toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr)--fromLabel :: Value Label -> BasicBlock-fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr)--------------------------------------------- XXX: the functions in this section (and addGlobalMapping) don't actually use any--- Function state so should really be in the CodeGenModule monad---- | Create a reference to an external function while code generating for a function.--- If LLVM cannot resolve its name, then you may try 'staticFunction'.-externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a)-externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage---- | As 'externFunction', but for 'Global's rather than 'Function's-externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a)-externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage--externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a)-externCore name act = do-    es <- getExterns-    case lookup name es of-        Just f -> return $ Value f-        Nothing -> do-            f <- liftCodeGenModule $ act name-            putExterns ((name, f) : es)-	    return $ Value f--{- |-Make an external C function with a fixed address callable from LLVM code.-This callback function can also be a Haskell function,-that was imported like--> foreign import ccall "&nextElement"->    nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)--See @examples\/List.hs@.--When you only use 'externFunction', then LLVM cannot resolve the name.-(However, I do not know why.)-Thus 'staticFunction' manages a list of static functions.-This list is automatically installed by 'ExecutionEngine.simpleFunction'-and can be manually obtained by 'getGlobalMappings'-and installed by 'ExecutionEngine.addGlobalMappings'.-\"Installing\" means calling LLVM's @addGlobalMapping@ according to-<http://old.nabble.com/jit-with-external-functions-td7769793.html>.--}-staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f)-staticFunction func = liftCodeGenModule $ do-    val <- newNamedFunction ExternalLinkage ""-    addGlobalMapping (unValue (val :: Function f)) (castFunPtrToPtr func)-    return val---- | As 'staticFunction', but for 'Global's rather than 'Function's-staticGlobal :: forall a r. (IsType a) => Bool -> Ptr a -> CodeGenFunction r (Global a)-staticGlobal isConst gbl = liftCodeGenModule $ do-    val <- newNamedGlobal isConst ExternalLinkage ""-    addGlobalMapping (unValue (val :: Global a)) (castPtr gbl)-    return val------------------------------------------withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a-withCurrentBuilder body = do-    bld <- getBuilder-    liftIO $ U.withBuilder bld body-------------------------------------------- Mark all block terminating instructions.  Not used yet.---data Terminate = Terminate------------------------------------------type Global a = Value (Ptr a)---- | Create a new named global variable.-newNamedGlobal :: forall a . (IsType a)-               => Bool         -- ^Constant?-               -> Linkage      -- ^Visibility-               -> String       -- ^Name-               -> TGlobal a-newNamedGlobal isConst linkage name = do-    modul <- getModule-    let typ = typeRef (undefined :: a)-    liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ-    	     	   	      when isConst $ FFI.setGlobalConstant g 1-			      return g---- | Create a new global variable.-newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a-newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage---- | Give a global variable a (constant) value.-defineGlobal :: Global a -> ConstValue a -> CodeGenModule ()-defineGlobal (Value g) (ConstValue v) =-    liftIO $ FFI.setInitializer g v---- | Create and define a global variable.-createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a-createGlobal isConst linkage con = do-    g <- newGlobal isConst linkage-    defineGlobal g con-    return g---- | Create and define a named global variable.-createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a-createNamedGlobal isConst linkage name con = do-    g <- newNamedGlobal isConst linkage name-    defineGlobal g con-    return g--type TFunction a = CodeGenModule (Function a)-type TGlobal a = CodeGenModule (Global a)---- Special string creators-{-# DEPRECATED createString "use withString instead" #-}-createString :: String -> TGlobal (Array n Word8)-createString s = string (length s) (U.constString s)--{-# DEPRECATED createStringNul "use withStringNul instead" #-}-createStringNul :: String -> TGlobal (Array n Word8)-createStringNul s = string (length s + 1) (U.constStringNul s)--withString ::-   String ->-   (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) ->-   CodeGenModule a-withString s act =-   let n = length s-   in  fromMaybe (error "withString: length must always be non-negative") $-       reifyNaturalD (fromIntegral n) (\tn ->-          do arr <- string n (U.constString s)-             act (fixArraySize tn arr))--withStringNul ::-   String ->-   (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) ->-   CodeGenModule a-withStringNul s act =-   let n = length s + 1-   in  fromMaybe (error "withStringNul: length must always be non-negative") $-       reifyNaturalD (fromIntegral n) (\tn ->-          do arr <- string n (U.constStringNul s)-             act (fixArraySize tn arr))--fixArraySize :: n -> Global (Array n a) -> Global (Array n a)-fixArraySize _ = id--string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8)-string n s = do-    modul <- getModule-    name <- genMSym "str"-    let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n)-    liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ-    	     	   	      FFI.setGlobalConstant g 1-			      FFI.setInitializer g s-			      return g-------------------------------------------- |Make a constant vector.  Replicates or truncates the list to get length /n/.-constVector :: forall a n . (PositiveT n) => [ConstValue a] -> ConstValue (Vector n a)-constVector xs =-    ConstValue $ U.constVector (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ]---- |Make a constant array.  Replicates or truncates the list to get length /n/.-constArray :: forall a n . (IsSized a, NaturalT n) => [ConstValue a] -> ConstValue (Array n a)-constArray xs =-    ConstValue $ U.constArray (typeRef (undefined :: a)) (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ]---- |Make a constant struct.-constStruct :: (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c))-constStruct struct =-    ConstValue $ U.constStruct (constValueFieldsOf struct) False---- |Make a constant packed struct.-constPackedStruct :: (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c))-constPackedStruct struct =-    ConstValue $ U.constStruct (constValueFieldsOf struct) True--class IsConstStruct c where-    type ConstStructOf c :: *-    constValueFieldsOf :: c -> [FFI.ValueRef]--instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where-    type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs)-    constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as-instance IsConstStruct () where-    type ConstStructOf () = ()-    constValueFieldsOf _ = []
− LLVM/Core/CodeGenMonad.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.Core.CodeGenMonad(-    -- * Module code generation-    CodeGenModule, runCodeGenModule, genMSym, getModule,-    GlobalMappings(..), addGlobalMapping, getGlobalMappings,-    -- * Function code generation-    CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns,-    -- * Reexport-    liftIO-    ) where-import Data.Typeable-import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, )-import Control.Monad.IO.Class (MonadIO, liftIO, )-import Control.Applicative (Applicative, )--import Foreign.Ptr (Ptr, )--import LLVM.Core.Util(Module, Builder, Function)------------------------------------------data CGMState = CGMState {-    cgm_module :: Module,-    cgm_externs :: [(String, Function)],-    cgm_global_mappings :: [(Function, Ptr ())],-    cgm_next :: !Int-    }-    deriving (Show, Typeable)-newtype CodeGenModule a = CGM (StateT CGMState IO a)-    deriving (Functor, Applicative, Monad, MonadIO, Typeable)--genMSym :: String -> CodeGenModule String-genMSym prefix = do-    s <- CGM get-    let n = cgm_next s-    CGM $ put (s { cgm_next = n + 1 })-    return $ "_" ++ prefix ++ show n--getModule :: CodeGenModule Module-getModule = CGM $ gets cgm_module--runCodeGenModule :: Module -> CodeGenModule a -> IO a-runCodeGenModule m (CGM body) = do-    let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] }-    evalStateT body cgm------------------------------------------data CGFState r = CGFState { -    cgf_module :: CGMState,-    cgf_builder :: Builder,-    cgf_function :: Function,-    cgf_next :: !Int-    }-    deriving (Show, Typeable)-newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)-    deriving (Functor, Applicative, Monad, MonadIO, Typeable)--genFSym :: CodeGenFunction a String-genFSym = do-    s <- CGF get-    let n = cgf_next s-    CGF $ put (s { cgf_next = n + 1 })-    return $ "_L" ++ show n--getFunction :: CodeGenFunction a Function-getFunction = CGF $ gets cgf_function--getBuilder :: CodeGenFunction a Builder-getBuilder = CGF $ gets cgf_builder--getFunctionModule :: CodeGenFunction a Module-getFunctionModule = CGF $ gets (cgm_module . cgf_module)--getExterns :: CodeGenFunction a [(String, Function)]-getExterns = CGF $ gets (cgm_externs . cgf_module)--putExterns :: [(String, Function)] -> CodeGenFunction a ()-putExterns es = do-    cgf <- CGF get-    let cgm' = (cgf_module cgf) { cgm_externs = es }-    CGF $ put (cgf { cgf_module = cgm' })--addGlobalMapping ::-    Function -> Ptr () -> CodeGenModule ()-addGlobalMapping value func = CGM $ modify $ \cgm ->-        cgm { cgm_global_mappings =-                 (value,func) : cgm_global_mappings cgm }--newtype GlobalMappings =-   GlobalMappings [(Function, Ptr ())]--{- |-Get a list created by calls to 'staticFunction'-that must be passed to the execution engine-via 'LLVM.ExecutionEngine.addGlobalMappings'.--}-getGlobalMappings ::-    CodeGenModule GlobalMappings-getGlobalMappings =-   CGM $ gets (GlobalMappings . cgm_global_mappings)--runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a-runCodeGenFunction bld fn (CGF body) = do-    cgm <- CGM get-    let cgf = CGFState { cgf_module = cgm,-                         cgf_builder = bld,-    	      	       	 cgf_function = fn,-			 cgf_next = 1 }-    (a, cgf') <- liftIO $ runStateT body cgf-    CGM $ put (cgf_module cgf')-    return a-------------------------------------------- | Allows you to define part of a module while in the middle of defining a function.-liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a-liftCodeGenModule (CGM act) = do-    cgf <- CGF get-    (a, cgm') <- liftIO $ runStateT act (cgf_module cgf)-    CGF $ put (cgf { cgf_module = cgm' })-    return a
− LLVM/Core/Data.hs 
@@ -1,43 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.Core.Data(IntN(..), WordN(..), FP128(..),-       		      Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where-import Data.Typeable-import Foreign.Ptr(Ptr)---- TODO:--- Make instances IntN, WordN to actually do the right thing.--- Make FP128 do the right thing--- Make Array functions.---- |Variable sized signed integer.--- The /n/ parameter should belong to @PosI@.-newtype IntN n = IntN Integer-    deriving (Show, Typeable)---- |Variable sized unsigned integer.--- The /n/ parameter should belong to @PosI@.-newtype WordN n = WordN Integer-    deriving (Show, Typeable)---- |128 bit floating point.-newtype FP128 = FP128 Rational-    deriving (Show, Typeable)---- |Fixed sized arrays, the array size is encoded in the /n/ parameter.-newtype Array n a = Array [a]-    deriving (Show, Typeable)---- |Fixed sized vector, the array size is encoded in the /n/ parameter.-newtype Vector n a = Vector [a]-    deriving (Show, Typeable)---- |Label type, produced by a basic block.-data Label-    deriving (Typeable)---- |Struct types; a list (nested tuple) of component types.-newtype Struct a = Struct a-    deriving (Show, Typeable)-newtype PackedStruct a = PackedStruct a-    deriving (Show, Typeable)
− LLVM/Core/Instructions.hs 
@@ -1,1300 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module LLVM.Core.Instructions(-    -- * ADT representation of IR-    BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,-    -- * Terminator instructions-    ret,-    condBr,-    br,-    switch,-    invoke, invokeWithConv,-    invokeFromFunction, invokeWithConvFromFunction,-    unreachable,-    -- * Arithmetic binary operations-    -- | Arithmetic operations with the normal semantics.-    -- The u instractions are unsigned, the s instructions are signed.-    add, sub, mul, neg,-    iadd, isub, imul, ineg,-    fadd, fsub, fmul, fneg,-    idiv, irem,-    udiv, sdiv, fdiv, urem, srem, frem,-    -- * Logical binary operations-    -- |Logical instructions with the normal semantics.-    shl, lshr, ashr, and, or, xor, inv,-    -- * Vector operations-    extractelement,-    insertelement,-    shufflevector,-    -- * Aggregate operation-    extractvalue,-    insertvalue,-    -- * Memory access-    malloc, arrayMalloc,-    alloca, arrayAlloca,-    free,-    load,-    store,-    getElementPtr, getElementPtr0,-    -- * Conversions-    trunc, zext, sext, ext, zadapt, sadapt, adapt,-    fptrunc, fpext,-    fptoui, fptosi, fptoint,-    uitofp, sitofp, inttofp,-    ptrtoint, inttoptr,-    bitcast,-    bitcastElements,-    -- * Comparison-    CmpPredicate(..), IntPredicate(..), FPPredicate(..),-    CmpOp, CmpRet, CmpResult,-    cmp, pcmp, icmp, fcmp,-    select,-    -- * Other-    phi, addPhiInputs,-    call, callWithConv,-    callFromFunction, callWithConvFromFunction,-    Call, applyCall, runCall,--    -- * Classes and types-    Terminate,-    Ret, CallArgs, ABinOp, ABinOpResult, IsConst,-    FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult,-    AllocArg,-    GetElementPtr, ElementPtrType, IsIndexArg,-    GetValue, ValueType-    ) where-import Prelude hiding (and, or)-import Data.Typeable-import Control.Monad(liftM)-import Data.Int-import Data.Word-import Data.Map(fromList, (!))-import Foreign.Ptr (FunPtr, )-import Foreign.C(CInt, CUInt)-import Types.Data.Ord(LTT, GTT)-import Types.Data.Num(Dec, DecN, (:.), d1, fromIntegerT, Pred)-import qualified LLVM.FFI.Core as FFI-import LLVM.Core.Data-import LLVM.Core.Type-import LLVM.Core.CodeGenMonad-import LLVM.Core.CodeGen-import qualified LLVM.Core.Util as U---- TODO:--- Add vector version of arithmetic--- Add rest of instructions--- Use Terminate to ensure bb termination (how?)--- more intrinsics are needed to, e.g., create an empty vector--data ArgDesc = AV String | AI Int | AL String | AE--instance Show ArgDesc where-    -- show (AV s) = "V_" ++ s-    -- show (AI i) = "I_" ++ show i-    -- show (AL l) = "L_" ++ l-    show (AV s) = s-    show (AI i) = show i-    show (AL l) = l-    show AE = "voidarg?"--data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd-               | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub-               | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul-               | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem-               | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor-    deriving Show---- FIXME: complete definitions for unimplemented instructions-data InstrDesc =-    -- terminators-    IDRet TypeDesc ArgDesc | IDRetVoid-  | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc-  | IDSwitch [(ArgDesc, ArgDesc)]-  | IDIndirectBr-  | IDInvoke-  | IDUnwind-  | IDUnreachable-    -- binary operators (including bitwise)-  | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc-    -- memory access and addressing-  | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc-  | IDGetElementPtr TypeDesc [ArgDesc]-    -- conversion-  | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc-  | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc-  | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc-  | IDSItoFP TypeDesc TypeDesc ArgDesc-  | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc-  | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc-  | IDBitcast TypeDesc TypeDesc ArgDesc-    -- other-  | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc-  | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]-  | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg-    -- vector operators-  | IDExtractElement | IDInsertElement | IDShuffleVector-    -- aggregate operators-  | IDExtractValue | IDInsertValue-    -- invalid-  | IDInvalidOp-    deriving Show---- TODO: overflow support for binary operations (add/sub/mul)-getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)-getInstrDesc v = do-    valueName <- U.getValueNameU v-    opcode <- FFI.instGetOpcode v-    t <- FFI.typeOf v >>= typeDesc2-    -- FIXME: sizeof() does not work for types!-    --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral-    tsize <- return 1-    os <- U.getOperands v >>= mapM getArgDesc-    os0 <- if length os > 0 then return $ os !! 0 else return AE-    os1 <- if length os > 1 then return $ os !! 1 else return AE-    t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41)-            then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2-            else return TDVoid)-    p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0-    let instr =-            (if opcode >= 8 && opcode <= 25 -- binary arithmetic-             then IDBinOp (getBinOp opcode) t os0 os1-             else if opcode >= 30 && opcode <= 41 -- conversion-                  then (getConvOp opcode) t2 t os0-                  else case opcode of-                         { 1 -> if null os then IDRetVoid else IDRet t os0;-                           2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1;-                           3 -> IDSwitch $ toPairs os;-                           -- TODO (can skip for now)-                           -- 4 -> IndirectBr ; 5 -> Invoke ;-                           6 -> IDUnwind; 7 -> IDUnreachable;-                           26 -> IDAlloca (getPtrType t) tsize (getImmInt os0);-                           27 -> IDLoad t os0; 28 -> IDStore t os0 os1;-                           29 -> IDGetElementPtr t os;-                           42 -> IDICmp (toIntPredicate p) os0 os1;-                           43 -> IDFCmp (toFPPredicate p) os0 os1;-                           44 -> IDPhi t $ toPairs os;-                           -- FIXME: getelementptr arguments are not handled-                           45 -> IDCall t (last os) (init os);-                           46 -> IDSelect t os0 os1;-                           -- TODO (can skip for now)-                           -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ;-                           -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ;-                           -- 53 -> ExtractValue ; 54 -> InsertValue ;-                           _ -> IDInvalidOp })-    return (valueName, instr)-    --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode-        where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),-                                     (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),-                                     (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),-                                     (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),-                                     (24, BOOr), (25, BOXor)] ! o-              getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),-                                      (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),-                                      (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o-              toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))-              stride _ [] = []-              stride n (x:xs) = x : stride n (drop (n-1) xs)-              getPtrType (TDPtr t) = t-              getPtrType _ = TDVoid-              getImmInt (AI i) = i-              getImmInt _ = 0---- TODO: fix for non-int constants-getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc-getArgDesc (vname, v) = do-    isC <- U.isConstant v-    t <- FFI.typeOf v >>= typeDesc2-    if isC-      then case t of-             TDInt _ _ -> do-                          cV <- FFI.constIntGetSExtValue v-                          return $ AI $ fromIntegral cV-             _ -> return AE-      else case t of-             TDLabel -> return $ AL vname-             _ -> return $ AV vname------------------------------------------type Terminate = ()-terminate :: Terminate-terminate = ()-------------------------------------------- |Acceptable arguments to the 'ret' instruction.-class Ret a r where-    ret' :: a -> CodeGenFunction r Terminate---- | Return from the current function with the given value.  Use () as the return value for what would be a void function in C.-ret :: (Ret a r) => a -> CodeGenFunction r Terminate-ret = ret'---- overlaps with Ret () ()!-{--instance (IsFirstClass a, IsConst a) => Ret a a where-    ret' = ret . valueOf--}--instance Ret (Value a) a where-    ret' (Value a) = do-        withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a-        return terminate--instance Ret () () where-    ret' _ = do-        withCurrentBuilder_ $ FFI.buildRetVoid-        return terminate--withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r ()-withCurrentBuilder_ p = withCurrentBuilder p >> return ()-------------------------------------------- | Branch to the first basic block if the boolean is true, otherwise to the second basic block.-condBr :: Value Bool -- ^ Boolean to branch upon.-       -> BasicBlock -- ^ Target for true.-       -> BasicBlock -- ^ Target for false.-       -> CodeGenFunction r Terminate-condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do-    withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2-    return terminate-------------------------------------------- | Unconditionally branch to the given basic block.-br :: BasicBlock  -- ^ Branch target.-   -> CodeGenFunction r Terminate-br (BasicBlock t) = do-    withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t-    return terminate-------------------------------------------- | Branch table instruction.-switch :: (IsInteger a)-       => Value a                        -- ^ Value to branch upon.-       -> BasicBlock                     -- ^ Default branch target.-       -> [(ConstValue a, BasicBlock)]   -- ^ Labels and corresponding branch targets.-       -> CodeGenFunction r Terminate-switch (Value val) (BasicBlock dflt) arms = do-    withCurrentBuilder_ $ \ bldPtr -> do-        inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms)-        sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ]-    return terminate-------------------------------------------- |Inform the code generator that this code can never be reached.-unreachable :: CodeGenFunction r Terminate-unreachable = do-    withCurrentBuilder_ FFI.buildUnreachable-    return terminate------------------------------------------type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef-type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef---withArithmeticType ::-    (IsArithmetic c) =>-    (ArithmeticType c -> a -> CodeGenFunction r (v c)) ->-    (a -> CodeGenFunction r (v c))-withArithmeticType f = f arithmeticType---- |Acceptable arguments to arithmetic binary instructions.-class ABinOp a b where-    type ABinOpResult a b :: *-    abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b)--add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-add =-    curry $ withArithmeticType $ \typ -> uncurry $ case typ of-      IntegerType  -> abinop FFI.constAdd  FFI.buildAdd-      FloatingType -> abinop FFI.constFAdd FFI.buildFAdd--sub :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-sub =-    curry $ withArithmeticType $ \typ -> uncurry $ case typ of-      IntegerType  -> abinop FFI.constSub  FFI.buildSub-      FloatingType -> abinop FFI.constFSub FFI.buildFSub--mul :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-mul =-    curry $ withArithmeticType $ \typ -> uncurry $ case typ of-      IntegerType  -> abinop FFI.constMul  FFI.buildMul-      FloatingType -> abinop FFI.constFMul FFI.buildFMul--iadd :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-iadd = abinop FFI.constAdd FFI.buildAdd-isub :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-isub = abinop FFI.constSub FFI.buildSub-imul :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-imul = abinop FFI.constMul FFI.buildMul---- | signed or unsigned integer division depending on the type-idiv ::-   forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) =>-   a -> b -> CodeGenFunction r (v c)-idiv =-   if isSigned (undefined :: c)-     then abinop FFI.constSDiv FFI.buildSDiv-     else abinop FFI.constUDiv FFI.buildUDiv--- | signed or unsigned remainder depending on the type-irem ::-   forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) =>-   a -> b -> CodeGenFunction r (v c)-irem =-   if isSigned (undefined :: c)-     then abinop FFI.constSRem FFI.buildSRem-     else abinop FFI.constURem FFI.buildURem--{-# DEPRECATED udiv "use idiv instead" #-}-{-# DEPRECATED sdiv "use idiv instead" #-}-{-# DEPRECATED urem "use irem instead" #-}-{-# DEPRECATED srem "use irem instead" #-}-udiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-udiv = abinop FFI.constUDiv FFI.buildUDiv-sdiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-sdiv = abinop FFI.constSDiv FFI.buildSDiv-urem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-urem = abinop FFI.constURem FFI.buildURem-srem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-srem = abinop FFI.constSRem FFI.buildSRem--fadd :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-fadd = abinop FFI.constFAdd FFI.buildFAdd-fsub :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-fsub = abinop FFI.constFSub FFI.buildFSub-fmul :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-fmul = abinop FFI.constFMul FFI.buildFMul---- | Floating point division.-fdiv :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-fdiv = abinop FFI.constFDiv FFI.buildFDiv--- | Floating point remainder.-frem :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-frem = abinop FFI.constFRem FFI.buildFRem--shl :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-shl  = abinop FFI.constShl  FFI.buildShl-lshr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-lshr = abinop FFI.constLShr FFI.buildLShr-ashr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-ashr = abinop FFI.constAShr FFI.buildAShr-and :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-and  = abinop FFI.constAnd  FFI.buildAnd-or :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-or   = abinop FFI.constOr   FFI.buildOr-xor :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)-xor  = abinop FFI.constXor  FFI.buildXor--instance ABinOp (Value a) (Value a) where-    type ABinOpResult (Value a) (Value a) = Value a-    abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2--instance ABinOp (ConstValue a) (Value a) where-    type ABinOpResult (ConstValue a) (Value a) = Value a-    abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2--instance ABinOp (Value a) (ConstValue a) where-    type ABinOpResult (Value a) (ConstValue a) = Value a-    abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2--instance ABinOp (ConstValue a) (ConstValue a) where-    type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a-    abinop cop _ (ConstValue a1) (ConstValue a2) =-        return $ ConstValue $ cop a1 a2--{--instance (IsConst a) => ABinOp (Value a) a where-    type ABinOpResult (Value a) a = Value a-    abinop cop op a1 a2 = abinop cop op a1 (constOf a2)--instance (IsConst a) => ABinOp a (Value a) where-    type ABinOpResult a (Value a) = Value a-    abinop cop op a1 a2 = abinop cop op (constOf a1) a2--}----instance (IsConst a) => ABinOp a a (ConstValue a) where---    abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2)--buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)-buildBinOp op a1 a2 =-    liftM Value $-    withCurrentBuilder $ \ bld ->-      U.withEmptyCString $ op bld a1 a2--type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef--buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a)-buildUnOp op a =-    liftM Value $-    withCurrentBuilder $ \ bld ->-      U.withEmptyCString $ op bld a--neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)-neg =-    withArithmeticType $ \typ -> case typ of-      IntegerType  -> \(Value x) -> buildUnOp FFI.buildNeg x-      FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a)--ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)-ineg (Value x) = buildUnOp FFI.buildNeg x--fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a)-fneg = fsub (value zero :: Value a)-{--fneg (Value x) = buildUnOp FFI.buildFNeg x--}--inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)-inv (Value x) = buildUnOp FFI.buildNot x-------------------------------------------- | Get a value from a vector.-extractelement :: (PositiveT n)-               => Value (Vector n a)               -- ^ Vector-               -> Value Word32                     -- ^ Index into the vector-               -> CodeGenFunction r (Value a)-extractelement (Value vec) (Value i) =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i---- | Insert a value into a vector, nondestructive.-insertelement :: (PositiveT n)-              => Value (Vector n a)                -- ^ Vector-              -> Value a                           -- ^ Value to insert-              -> Value Word32                      -- ^ Index into the vector-              -> CodeGenFunction r (Value (Vector n a))-insertelement (Value vec) (Value e) (Value i) =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i---- | Permute vector.-shufflevector :: (PositiveT n, PositiveT m)-              => Value (Vector n a)-              -> Value (Vector n a)-              -> ConstValue (Vector m Word32)-              -> CodeGenFunction r (Value (Vector m a))-shufflevector (Value a) (Value b) (ConstValue mask) =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask----- |Acceptable arguments to 'extractvalue' and 'insertvalue'.-class GetValue agg ix where-    type ValueType agg ix :: *-    getIx :: agg -> ix -> CUInt--instance (GetField as i, NaturalT i) => GetValue (Struct as) i where-    type ValueType (Struct as) i = FieldType as i-    getIx _ n = fromIntegerT n--instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where-    type ValueType (Array n a) Word32 = a-    getIx _ n = fromIntegral n--instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where-    type ValueType (Array n a) Word64 = a-    getIx _ n = fromIntegral n---instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where-    type ValueType (Array n a) (Dec i) = a-    getIx _ n = fromIntegerT n----- | Get a value from an aggregate.-extractvalue :: forall r agg i.-                GetValue agg i-             => Value agg                   -- ^ Aggregate-             -> i                           -- ^ Index into the aggregate-             -> CodeGenFunction r (Value (ValueType agg i))-extractvalue (Value agg) i =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $-        FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i)---- | Insert a value into an aggregate, nondestructive.-insertvalue :: forall r agg i.-               GetValue agg i-            => Value agg                   -- ^ Aggregate-            -> Value (ValueType agg i)     -- ^ Value to insert-            -> i                           -- ^ Index into the aggregate-            -> CodeGenFunction r (Value agg)-insertvalue (Value agg) (Value e) i =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $-        FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i)--------------------------------------------- XXX should allows constants---- | Truncate a value to a shorter bit width.-trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))-      => Value a -> CodeGenFunction r (Value b)-trunc = convert FFI.buildTrunc---- | Zero extend a value to a wider width.--- If possible, use 'ext' that chooses the right padding according to the types-zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))-     => Value a -> CodeGenFunction r (Value b)-zext = convert FFI.buildZExt---- | Sign extend a value to wider width.--- If possible, use 'ext' that chooses the right padding according to the types-sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))-     => Value a -> CodeGenFunction r (Value b)-sext = convert FFI.buildSExt---- | Extend a value to wider width.--- If the target type is signed, then preserve the sign,--- If the target type is unsigned, then extended by zeros.-ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))-     => Value a -> CodeGenFunction r (Value b)-ext =-   if isSigned (undefined :: b)-     then convert FFI.buildSExt-     else convert FFI.buildZExt----- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.-zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b)-     => Value a -> CodeGenFunction r (Value b)-zadapt =-   case compare (sizeOf (typeDesc (undefined :: a)))-                (sizeOf (typeDesc (undefined :: b))) of-      LT -> convert FFI.buildZExt-      EQ -> convert FFI.buildBitCast-      GT -> convert FFI.buildTrunc---- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.-sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b)-     => Value a -> CodeGenFunction r (Value b)-sadapt =-   case compare (sizeOf (typeDesc (undefined :: a)))-                (sizeOf (typeDesc (undefined :: b))) of-      LT -> convert FFI.buildSExt-      EQ -> convert FFI.buildBitCast-      GT -> convert FFI.buildTrunc---- | It is 'sadapt' or 'zadapt' depending on the sign mode.-adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b)-     => Value a -> CodeGenFunction r (Value b)-adapt =-   case compare (sizeOf (typeDesc (undefined :: a)))-                (sizeOf (typeDesc (undefined :: b))) of-      LT ->-         if isSigned (undefined :: b)-           then convert FFI.buildSExt-           else convert FFI.buildZExt-      EQ -> convert FFI.buildBitCast-      GT -> convert FFI.buildTrunc---- | Truncate a floating point value.-fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))-        => Value a -> CodeGenFunction r (Value b)-fptrunc = convert FFI.buildFPTrunc---- | Extend a floating point value.-fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))-      => Value a -> CodeGenFunction r (Value b)-fpext = convert FFI.buildFPExt--{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-}--- | Convert a floating point value to an unsigned integer.-fptoui :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)-fptoui = convert FFI.buildFPToUI--{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-}--- | Convert a floating point value to a signed integer.-fptosi :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)-fptosi = convert FFI.buildFPToSI---- | Convert a floating point value to an integer.--- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.-fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)-fptoint =-   if isSigned (undefined :: b)-     then convert FFI.buildFPToSI-     else convert FFI.buildFPToUI---{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -}--- | Convert an unsigned integer to a floating point value.--- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.-uitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)-uitofp = convert FFI.buildUIToFP--{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -}--- | Convert a signed integer to a floating point value.--- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.-sitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)-sitofp = convert FFI.buildSIToFP---- | Convert an integer to a floating point value.--- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.-inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)-inttofp =-   if isSigned (undefined :: a)-     then convert FFI.buildSIToFP-     else convert FFI.buildUIToFP----- | Convert a pointer to an integer.-ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b)-ptrtoint = convert FFI.buildPtrToInt---- | Convert an integer to a pointer.-inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b))-inttoptr = convert FFI.buildIntToPtr---- | Convert between to values of the same size by just copying the bit pattern.-bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)-        => Value a -> CodeGenFunction r (Value b)-bitcast = convert FFI.buildBitCast---- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same.-bitcastElements :: (PositiveT n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)-        => Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))-bitcastElements = convert FFI.buildBitCast---type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef--convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b)-convert conv (Value a) =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b))------------------------------------------data CmpPredicate =-    CmpEQ                       -- ^ equal-  | CmpNE                       -- ^ not equal-  | CmpGT                       -- ^ greater than-  | CmpGE                       -- ^ greater or equal-  | CmpLT                       -- ^ less than-  | CmpLE                       -- ^ less or equal-    deriving (Eq, Ord, Enum, Show, Typeable)--uintFromCmpPredicate :: CmpPredicate -> IntPredicate-uintFromCmpPredicate p =-   case p of-      CmpEQ -> IntEQ-      CmpNE -> IntNE-      CmpGT -> IntUGT-      CmpGE -> IntUGE-      CmpLT -> IntULT-      CmpLE -> IntULE--sintFromCmpPredicate :: CmpPredicate -> IntPredicate-sintFromCmpPredicate p =-   case p of-      CmpEQ -> IntEQ-      CmpNE -> IntNE-      CmpGT -> IntSGT-      CmpGE -> IntSGE-      CmpLT -> IntSLT-      CmpLE -> IntSLE--fpFromCmpPredicate :: CmpPredicate -> FPPredicate-fpFromCmpPredicate p =-   case p of-      CmpEQ -> FPOEQ-      CmpNE -> FPONE-      CmpGT -> FPOGT-      CmpGE -> FPOGE-      CmpLT -> FPOLT-      CmpLE -> FPOLE---data IntPredicate =-    IntEQ                       -- ^ equal-  | IntNE                       -- ^ not equal-  | IntUGT                      -- ^ unsigned greater than-  | IntUGE                      -- ^ unsigned greater or equal-  | IntULT                      -- ^ unsigned less than-  | IntULE                      -- ^ unsigned less or equal-  | IntSGT                      -- ^ signed greater than-  | IntSGE                      -- ^ signed greater or equal-  | IntSLT                      -- ^ signed less than-  | IntSLE                      -- ^ signed less or equal-    deriving (Eq, Ord, Enum, Show, Typeable)--fromIntPredicate :: IntPredicate -> CInt-fromIntPredicate p = fromIntegral (fromEnum p + 32)--toIntPredicate :: CInt -> IntPredicate-toIntPredicate p = toEnum $ fromIntegral p - 32--data FPPredicate =-    FPFalse           -- ^ Always false (always folded)-  | FPOEQ             -- ^ True if ordered and equal-  | FPOGT             -- ^ True if ordered and greater than-  | FPOGE             -- ^ True if ordered and greater than or equal-  | FPOLT             -- ^ True if ordered and less than-  | FPOLE             -- ^ True if ordered and less than or equal-  | FPONE             -- ^ True if ordered and operands are unequal-  | FPORD             -- ^ True if ordered (no nans)-  | FPUNO             -- ^ True if unordered: isnan(X) | isnan(Y)-  | FPUEQ             -- ^ True if unordered or equal-  | FPUGT             -- ^ True if unordered or greater than-  | FPUGE             -- ^ True if unordered, greater than, or equal-  | FPULT             -- ^ True if unordered or less than-  | FPULE             -- ^ True if unordered, less than, or equal-  | FPUNE             -- ^ True if unordered or not equal-  | FPT               -- ^ Always true (always folded)-    deriving (Eq, Ord, Enum, Show, Typeable)--fromFPPredicate :: FPPredicate -> CInt-fromFPPredicate p = fromIntegral (fromEnum p)--toFPPredicate :: CInt -> FPPredicate-toFPPredicate p = toEnum $ fromIntegral p---- |Acceptable operands to comparison instructions.-class CmpRet (CmpType a b) => CmpOp a b where-    type CmpType a b :: *-    cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (CmpType a b)))--instance (CmpRet a) => CmpOp (Value a) (Value a) where-    type CmpType (Value a) (Value a) = a-    cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2--{--instance (IsConst a, CmpRet a) => CmpOp a (Value a) where-    type CmpType a (Value a) = a-    cmpop op a1 a2 = cmpop op (valueOf a1) a2--instance (IsConst a, CmpRet a) => CmpOp (Value a) a where-    type CmpType (Value a) a = a-    cmpop op a1 a2 = cmpop op a1 (valueOf a2)--}--class CmpRet c where-    type CmpResult c :: *-    cmpBld :: c -> CmpPredicate -> FFIBinOp--instance CmpRet Float   where type CmpResult Float   = Bool ; cmpBld _ = fcmpBld-instance CmpRet Double  where type CmpResult Double  = Bool ; cmpBld _ = fcmpBld-instance CmpRet FP128   where type CmpResult FP128   = Bool ; cmpBld _ = fcmpBld-instance CmpRet Bool    where type CmpResult Bool    = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word8   where type CmpResult Word8   = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word16  where type CmpResult Word16  = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word32  where type CmpResult Word32  = Bool ; cmpBld _ = ucmpBld-instance CmpRet Word64  where type CmpResult Word64  = Bool ; cmpBld _ = ucmpBld-instance CmpRet Int8    where type CmpResult Int8    = Bool ; cmpBld _ = scmpBld-instance CmpRet Int16   where type CmpResult Int16   = Bool ; cmpBld _ = scmpBld-instance CmpRet Int32   where type CmpResult Int32   = Bool ; cmpBld _ = scmpBld-instance CmpRet Int64   where type CmpResult Int64   = Bool ; cmpBld _ = scmpBld-instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld-instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a)-    where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; cmpBld _ = cmpBld (undefined :: a)---{- |-Compare values of ordered types-and choose predicates according to the compared types.-Floating point numbers are compared in \"ordered\" mode,-that is @NaN@ operands yields 'False' as result.-Pointers are compared unsigned.-These choices are consistent with comparison in plain Haskell.--}-cmp :: forall a b c r.-   (CmpOp a b, c ~ CmpType a b) =>-   CmpPredicate -> a -> b ->-   CodeGenFunction r (Value (CmpResult c))-cmp p = cmpop (cmpBld (undefined :: CmpType a b) p)--ucmpBld :: CmpPredicate -> FFIBinOp-ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))--scmpBld :: CmpPredicate -> FFIBinOp-scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))--fcmpBld :: CmpPredicate -> FFIBinOp-fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p))---_ucmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>-        CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)))--_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>-        CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)))--pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) =>-        IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c)))-pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))---{-# DEPRECATED icmp "use cmp or pcmp instead" #-}--- | Compare integers.-icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) =>-        IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))---- | Compare floating point values.-fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) =>-        FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))-fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p))-------------------------------------------- XXX could do const song and dance--- | Select between two values depending on a boolean.-select :: (IsFirstClass a, CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a)-select (Value cnd) (Value thn) (Value els) =-    liftM Value $-      withCurrentBuilder $ \ bldPtr ->-        U.withEmptyCString $-          FFI.buildSelect bldPtr cnd thn els------------------------------------------type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef--{--Function (a -> b -> IO c)-Value a -> Value b -> CodeGenFunction r c--}---- |Acceptable arguments to 'call'.-class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>-         CallArgs f g r where-    type CalledFunction g :: *-    type CallerResult g :: *-    type CallerFunction f r :: *-    doCall :: Call f -> g--instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where-    type CalledFunction (Value a -> b') = a -> CalledFunction b'-    type CallerResult (Value a -> b') = CallerResult b'-    type CallerFunction (a -> b) r = Value a -> CallerFunction b r-    doCall f a = doCall (applyCall f a)----instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where---    doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a))--instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where-    type CalledFunction (CodeGenFunction r (Value a)) = IO a-    type CallerResult (CodeGenFunction r (Value a)) = r-    type CallerFunction (IO a) r = CodeGenFunction r (Value a)-    doCall = runCall--doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a)-doCallDef mkCall args _ =-    withCurrentBuilder $ \ bld ->-      liftM Value $ mkCall bld (reverse args)---- | Call a function with the given arguments.  The 'call' instruction is variadic, i.e., the number of arguments--- it takes depends on the type of /f/.-call :: (CallArgs f g r) => Function f -> g-call = doCall . callFromFunction--data Call a = Call Caller [FFI.ValueRef]--callFromFunction :: Function a -> Call a-callFromFunction (Value f) = Call (U.makeCall f) []---- like Applicative.<*>-infixl 4 `applyCall`--applyCall :: Call (a -> b) -> Value a -> Call b-applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args)--runCall :: Call (IO a) -> CodeGenFunction r (Value a)-runCall (Call mkCall args) = doCallDef mkCall args ()---invokeFromFunction ::-          BasicBlock         -- ^Normal return point.-       -> BasicBlock         -- ^Exception return point.-       -> Function f         -- ^Function to call.-       -> Call f-invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) =-    Call (U.makeInvoke norm expt f) []---- | Call a function with exception handling.-invoke :: (CallArgs f g r)-       => BasicBlock         -- ^Normal return point.-       -> BasicBlock         -- ^Exception return point.-       -> Function f         -- ^Function to call.-       -> g-invoke norm expt f = doCall $ invokeFromFunction norm expt f--callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f-callWithConvFromFunction cc (Value f) =-    Call (U.makeCallWithCc cc f) []---- | Call a function with the given arguments.  The 'call' instruction--- is variadic, i.e., the number of arguments it takes depends on the--- type of /f/.--- This also sets the calling convention of the call to the function.--- As LLVM itself defines, if the calling conventions of the calling--- /instruction/ and the function being /called/ are different, undefined--- behavior results.-callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g-callWithConv cc f = doCall $ callWithConvFromFunction cc f--invokeWithConvFromFunction ::-          FFI.CallingConvention -- ^Calling convention-       -> BasicBlock         -- ^Normal return point.-       -> BasicBlock         -- ^Exception return point.-       -> Function f         -- ^Function to call.-       -> Call f-invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) =-    Call (U.makeInvokeWithCc cc norm expt f) []---- | Call a function with exception handling.--- This also sets the calling convention of the call to the function.--- As LLVM itself defines, if the calling conventions of the calling--- /instruction/ and the function being /called/ are different, undefined--- behavior results.-invokeWithConv :: (CallArgs f g r)-               => FFI.CallingConvention -- ^Calling convention-               -> BasicBlock         -- ^Normal return point.-               -> BasicBlock         -- ^Exception return point.-               -> Function f         -- ^Function to call.-               -> g-invokeWithConv cc norm expt f =-    doCall $ invokeWithConvFromFunction cc norm expt f-------------------------------------------- XXX could do const song and dance--- |Join several variables (virtual registers) from different basic blocks into one.--- All of the variables in the list are joined.  See also 'addPhiInputs'.-phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)-phi incoming =-    liftM Value $-      withCurrentBuilder $ \ bldPtr -> do-        inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a))-        U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]-        return inst---- |Add additional inputs to an existing phi node.--- The reason for this instruction is that sometimes the structure of the code--- makes it impossible to have all variables in scope at the point where you need the phi node.-addPhiInputs :: forall a r . (IsFirstClass a)-             => Value a                      -- ^Must be a variable from a call to 'phi'.-             -> [(Value a, BasicBlock)]      -- ^Variables to add.-             -> CodeGenFunction r ()-addPhiInputs (Value inst) incoming =-    liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]--------------------------------------------- | Acceptable argument to array memory allocation.-class AllocArg a where-    getAllocArg :: a -> Value Word32-instance AllocArg (Value Word32) where-    getAllocArg = id-instance AllocArg (ConstValue Word32) where-    getAllocArg = value-instance AllocArg Word32 where-    getAllocArg = valueOf---- could be moved to Util.Memory--- FFI.buildMalloc deprecated since LLVM-2.7--- XXX What's the type returned by malloc--- | Allocate heap memory.-malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))-malloc = arrayMalloc (1::Word32)--{--I use a pointer type as size parameter of 'malloc'.-This way I hope that the parameter has always the correct size (32 or 64 bit).-A side effect is that we can convert the result of 'getelementptr' using 'bitcast',-that does not suffer from the slow assembly problem. (bug #8281)--}-foreign import ccall "&aligned_malloc_sizeptr"-   alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))--foreign import ccall "&aligned_free"-   alignedFree :: FunPtr (Ptr Word8 -> IO ())---{--There is a bug in LLVM-2.7 and LLVM-2.8-(http://llvm.org/bugs/show_bug.cgi?id=8281)-that causes huge assembly times for expressions like-ptrtoint(getelementptr(zero,..)).-If you break those expressions into two statements-at separate lines, everything is fine.-But the C interface is too clever,-and rewrites two separate statements into a functional expression on a single line.-Such code is generated whenever you call-buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.-One possible way is to write a getelementptr expression-containing a nullptr in a way-that hides the constant nature of nullptr.--    ptr <- alloca-    store (value zero) ptr-    z <- load ptr-    size <- bitcast =<<-       getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())--However, I found that bitcast on pointers causes no problems.-Thus I switched to using pointers for size quantities.-This still allows for optimizations involving pointers.--}---- XXX What's the type returned by arrayMalloc?--- | Allocate heap (array) memory.-arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>-               s -> CodeGenFunction r (Value (Ptr a)) -- XXX-arrayMalloc s = do-    func <- staticFunction alignedMalloc---    func <- externFunction "malloc"--    size <- sizeOfArray (undefined :: a) (getAllocArg s)-    alignment <- alignOf (undefined :: a)-    bitcast =<<-       call-          (func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)))-          size-          alignment---- XXX What's the type returned by malloc--- | Allocate stack memory.-alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))-alloca =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a))---- XXX What's the type returned by arrayAlloca?--- | Allocate stack (array) memory.-arrayAlloca :: forall a r s . (IsSized a, AllocArg s) =>-               s -> CodeGenFunction r (Value (Ptr a))-arrayAlloca s =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $-        FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (case getAllocArg s of Value v -> v)---- FFI.buildFree deprecated since LLVM-2.7--- XXX What's the type of free?--- | Free heap memory.-free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()-free ptr = do-    func <- staticFunction alignedFree---    func <- externFunction "free"-    _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr-    return ()----- | If we want to export that, then we should have a Size type--- This is the official implementation,--- but it suffers from the ptrtoint(gep) bug.-_sizeOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64)-_sizeOf a =-    liftIO $ liftM Value $-    FFI.sizeOf (typeRef a)--_alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64)-_alignOf a =-    liftIO $ liftM Value $-    FFI.alignOf (typeRef a)----- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.--- see ConstantExpr::getSizeOf-sizeOfArray :: forall a r . (IsSized a) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8))-sizeOfArray _ len =-    bitcast =<<-       getElementPtr (value zero :: Value (Ptr a)) (len, ())---- see ConstantExpr::getAlignOf-alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value (Ptr Word8))-alignOf _ =-    bitcast =<<-       getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())----- | Load a value from memory.-load :: Value (Ptr a)                   -- ^ Address to load from.-     -> CodeGenFunction r (Value a)-load (Value p) =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withEmptyCString $ FFI.buildLoad bldPtr p---- | Store a value in memory-store :: Value a                        -- ^ Value to store.-      -> Value (Ptr a)                  -- ^ Address to store to.-      -> CodeGenFunction r ()-store (Value v) (Value p) = do-    withCurrentBuilder_ $ \ bldPtr ->-      FFI.buildStore bldPtr v p-    return ()--{---- XXX type is wrong--- | Address arithmetic.  See LLVM description.--- (The type isn't as accurate as it should be.)-getElementPtr :: (IsInteger i) =>-                 Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))-getElementPtr (Value ptr) ixs =-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->-        U.withEmptyCString $-          FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)--}---- |Acceptable arguments to 'getElementPointer'.-class GetElementPtr optr ixs where-    type ElementPtrType optr ixs :: *-    getIxList :: optr -> ixs -> [FFI.ValueRef]---- |Acceptable single index to 'getElementPointer'.-class IsIndexArg a where-    getArg :: a -> FFI.ValueRef--instance IsIndexArg (Value Word32) where-    getArg (Value v) = v--instance IsIndexArg (Value Word64) where-    getArg (Value v) = v--instance IsIndexArg (Value Int32) where-    getArg (Value v) = v--instance IsIndexArg (Value Int64) where-    getArg (Value v) = v--instance IsIndexArg (ConstValue Word32) where-    getArg = unConst--instance IsIndexArg (ConstValue Word64) where-    getArg = unConst--instance IsIndexArg (ConstValue Int32) where-    getArg = unConst--instance IsIndexArg (ConstValue Int64) where-    getArg = unConst--instance IsIndexArg Word32 where-    getArg = unConst . constOf--instance IsIndexArg Word64 where-    getArg = unConst . constOf--instance IsIndexArg Int32 where-    getArg = unConst . constOf--instance IsIndexArg Int64 where-    getArg = unConst . constOf--unConst :: ConstValue a -> FFI.ValueRef-unConst (ConstValue v) = v---- End of indexing-instance GetElementPtr a () where-    type ElementPtrType a () = a-    getIxList _ () = []---- Index in Array-instance (GetElementPtr o i, IsIndexArg a, NaturalT k) => GetElementPtr (Array k o) (a, i) where-    type ElementPtrType (Array k o) (a, i) = ElementPtrType o i-    getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i---- Index in Vector-instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where-    type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i-    getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i---- Index in Struct and PackedStruct.--- The index has to be a type level integer to statically determine the record field type-instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (Struct fs) (a, i) where-    type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i-    getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i-instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where-    type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i-    getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i--class GetField as i where type FieldType as i :: *-instance GetField (a, as) (Dec DecN) where type FieldType (a, as) (Dec DecN) = a-instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0)))---- | Address arithmetic.  See LLVM description.--- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.--- (This is without a doubt the most confusing LLVM instruction, but the types help.)-getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) =>-                 Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))-getElementPtr (Value ptr) (a, ixs) =-    let ixl = getArg a : getIxList (undefined :: o) ixs in-    liftM Value $-    withCurrentBuilder $ \ bldPtr ->-      U.withArrayLen ixl $ \ idxLen idxPtr ->-        U.withEmptyCString $-          FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)---- | Like getElementPtr, but with an initial index that is 0.--- This is useful since any pointer first need to be indexed off the pointer, and then into--- its actual value.  This first indexing is often with 0.-getElementPtr0 :: (GetElementPtr o i) =>-                  Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))-getElementPtr0 p i = getElementPtr p (0::Word32, i)-----------------------------------------{--instance (IsConst a) => Show (ConstValue a) -- XXX-instance (IsConst a) => Eq (ConstValue a)--{--instance (IsConst a) => Eq (ConstValue a) where-    ConstValue x == ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOEQ) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y)-    ConstValue x /= ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPONE) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y)--instance (IsConst a) => Ord (ConstValue a) where-    ConstValue x <  ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOLT) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y)-    ConstValue x <= ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOLE) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y)-    ConstValue x >  ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOGT) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y)-    ConstValue x >= ConstValue y  =-        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOGE) x y)-                        else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y)--}--instance (Num a, IsConst a) => Num (ConstValue a) where-    ConstValue x + ConstValue y  =  ConstValue (FFI.constAdd x y)-    ConstValue x - ConstValue y  =  ConstValue (FFI.constSub x y)-    ConstValue x * ConstValue y  =  ConstValue (FFI.constMul x y)-    negate (ConstValue x)        =  ConstValue (FFI.constNeg x)-    fromInteger x                =  constOf (fromInteger x :: a)--}
− LLVM/Core/Type.hs 
@@ -1,504 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}--- |The LLVM type system is captured with a number of Haskell type classes.--- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type.--- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for--- those types that are LLVM first class types (passable as arguments etc).--- All valid LLVM types belong to the 'IsType' class.-module LLVM.Core.Type(-    -- * Type classifier-    IsType(..),-    -- ** Special type classifiers-    NaturalT,-    PositiveT,-    IsArithmetic(arithmeticType),-    ArithmeticType(IntegerType,FloatingType),-    IsInteger, Signed,-    IsIntegerOrPointer,-    IsFloating,-    IsPrimitive,-    IsFirstClass,-    IsSized, SizeOf, sizeOf,-    IsFunction,-    -- ** Others-    IsScalarOrVector, NumberOfElements,-    UnknownSize, -- needed for arrays of structs-    -- ** Structs-    (:&), (&),-    -- ** Type tests-    TypeDesc(..),-    isFloating,-    isSigned,-    typeRef,-    typeName,-    intrinsicTypeName,-    typeDesc2,-    VarArgs, CastVarArgs,-    ) where-import Data.Typeable-import Data.List(intercalate)-import Data.Int-import Data.Word-import Types.Data.Num-import Types.Data.Bool (True, False)-import Foreign.StablePtr (StablePtr, )-import LLVM.Core.Util(functionType, structType)-import LLVM.Core.Data-import qualified LLVM.FFI.Core as FFI--#include "MachDeps.h"---- TODO:--- Move IntN, WordN to a special module that implements those types---   properly in Haskell.--- Also more Array and Vector to a Haskell module to implement them.--- Add Label?--- Add structures (using tuples, maybe nested).---- |The 'IsType' class classifies all types that have an LLVM representation.-class IsType a where-    typeDesc :: a -> TypeDesc--typeRef :: (IsType a) => a -> FFI.TypeRef  -- ^The argument is never evaluated-typeRef = code . typeDesc-  where code TDFloat  = FFI.floatType-  	code TDDouble = FFI.doubleType-	code TDFP128  = FFI.fP128Type-	code TDVoid   = FFI.voidType-	code (TDInt _ n)  = FFI.integerType (fromInteger n)-	code (TDArray n a) = FFI.arrayType (code a) (fromInteger n)-	code (TDVector n a) = FFI.vectorType (code a) (fromInteger n)-	code (TDPtr a) = FFI.pointerType (code a) 0-	code (TDFunction va as b) = functionType va (code b) (map code as)-	code TDLabel = FFI.labelType-        code (TDStruct ts packed) = structType (map code ts) packed-        code TDInvalidType = error "typeRef TDInvalidType"--typeName :: (IsType a) => a -> String-typeName = code . typeDesc-  where code TDFloat  = "f32"-  	code TDDouble = "f64"-	code TDFP128  = "f128"-	code TDVoid   = "void"-	code (TDInt _ n)  = "i" ++ show n-	code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"-	code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"-	code (TDPtr a) = code a ++ "*"-	code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"-        code TDLabel = "label"-        code (TDStruct as packed) = (if packed then "<{" else "{") ++-                                    intercalate "," (map code as) ++-                                    (if packed then "}>" else "}")-        code TDInvalidType = error "typeName TDInvalidType"--intrinsicTypeName :: (IsType a) => a -> String-intrinsicTypeName = code . typeDesc-  where code TDFloat  = "f32"-        code TDDouble = "f64"-        code TDFP128  = "f128"-        code (TDInt _ n)  = "i" ++ show n-        code (TDVector n a) = "v" ++ show n ++ code a-        code _ = error "intrinsicTypeName: type not supported in intrinsics"--typeDesc2 :: FFI.TypeRef -> IO TypeDesc-typeDesc2 t = do-    tk <- FFI.getTypeKind t-    case tk of-      FFI.VoidTypeKind -> return TDVoid-      FFI.FloatTypeKind -> return TDFloat-      FFI.DoubleTypeKind -> return TDDouble-      -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80"-      FFI.FP128TypeKind -> return TDFP128-      -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128"-      FFI.LabelTypeKind -> return TDLabel-      FFI.IntegerTypeKind -> do-                n <- FFI.getIntTypeWidth t-                return $ TDInt False (fromIntegral n)-      -- FIXME: FFI.FunctionTypeKind-      -- FIXME: FFI.StructTypeKind -> return "(Struct ...)"-      FFI.ArrayTypeKind -> do-                n <- FFI.getArrayLength t-                et <- FFI.getElementType t-                etd <- typeDesc2 et-                return $ TDArray (fromIntegral n) etd-      FFI.PointerTypeKind -> do-                et <- FFI.getElementType t-                etd <- typeDesc2 et-                return $ TDPtr etd-      -- FIXME: FFI.OpaqueTypeKind -> return "Opaque"-      FFI.VectorTypeKind -> do-                n <- FFI.getVectorSize t-                et <- FFI.getElementType t-                etd <- typeDesc2 et-                return $ TDVector (fromIntegral n) etd-      -- FIXME: LLVMMetadataTypeKind,    /**< Metadata */-      -- FIXME: LLVMX86_MMXTypeKind      /**< X86 MMX */-      _ -> return TDInvalidType---- |Type descriptor, used to convey type information through the LLVM API.-data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer-              | TDArray Integer TypeDesc | TDVector Integer TypeDesc-	      | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel-              | TDStruct [TypeDesc] Bool | TDInvalidType-    deriving (Eq, Ord, Show, Typeable)---- XXX isFloating and typeName could be extracted from typeRef--- Usage:---   superclass of IsConst---   add, sub, mul, neg context---   used to get type name to call intrinsic--- |Arithmetic types, i.e., integral and floating types.-class IsFirstClass a => IsArithmetic a where-    arithmeticType :: ArithmeticType a--data ArithmeticType a = IntegerType | FloatingType--instance Functor ArithmeticType where-    fmap _ IntegerType  = IntegerType-    fmap _ FloatingType = FloatingType---- Usage:---  constI, allOnes---  many instructions.  XXX some need vector---  used to find signedness in Arithmetic--- |Integral types.-class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where-   type Signed a :: *---- Usage:---  icmp--- |Integral or pointer type.-class IsIntegerOrPointer a--isSigned :: (IsInteger a) => a -> Bool-isSigned = is . typeDesc-  where is (TDInt s _) = s-  	is (TDVector _ a) = is a-	is _ = error "isSigned got impossible input"---- Usage:---  constF---  many instructions--- |Floating types.-class IsArithmetic a => IsFloating a--isFloating :: (IsArithmetic a) => a -> Bool-isFloating = is . typeDesc-  where is TDFloat = True-  	is TDDouble = True-	is TDFP128 = True-	is (TDVector _ a) = is a-	is _ = False---- Usage:---  Precondition for Vector--- |Primitive types.--- class (IsType a) => IsPrimitive a-class (IsType a, NumberOfElements a ~ D1) => IsPrimitive a---- |Number of elements for instructions that handle both primitive and vector types-class (IsType a) => IsScalarOrVector a where-    type NumberOfElements a :: *----- Usage:---  Precondition for function args and result.---  Used by some instructions, like ret and phi.---  XXX IsSized as precondition?--- |First class types, i.e., the types that can be passed as arguments, etc.-class IsType a => IsFirstClass a---- Usage:---  Context for Array being a type---  thus, allocation instructions--- |Types with a fixed size.-class (IsType a, PositiveT (SizeOf a)) => IsSized a where-    type SizeOf a :: *--sizeOf :: TypeDesc -> Integer-sizeOf TDFloat  = 32-sizeOf TDDouble = 64-sizeOf TDFP128  = 128-sizeOf (TDInt _ bits) = bits-sizeOf (TDArray n typ) = n * sizeOf typ-sizeOf (TDVector n typ) = n * sizeOf typ-sizeOf (TDStruct ts _packed) = sum (map sizeOf ts)-sizeOf _ = error "type has no size"---- |Function type.-class (IsType a) => IsFunction a where-    funcType :: [TypeDesc] -> a -> TypeDesc---- Only make instances for types that make sense in Haskell--- (i.e., some floating types are excluded).---- Floating point types.-instance IsType Float  where typeDesc _ = TDFloat-instance IsType Double where typeDesc _ = TDDouble-instance IsType FP128  where typeDesc _ = TDFP128---- Void type-instance IsType ()     where typeDesc _ = TDVoid---- Label type-instance IsType Label  where typeDesc _ = TDLabel---- Variable size integer types-instance (PositiveT n) => IsType (IntN n)-    where typeDesc _ = TDInt True  (fromIntegerT (undefined :: n))--instance (PositiveT n) => IsType (WordN n)-    where typeDesc _ = TDInt False (fromIntegerT (undefined :: n))---- Fixed size integer types.-instance IsType Bool   where typeDesc _ = TDInt False  1-instance IsType Word8  where typeDesc _ = TDInt False  8-instance IsType Word16 where typeDesc _ = TDInt False 16-instance IsType Word32 where typeDesc _ = TDInt False 32-instance IsType Word64 where typeDesc _ = TDInt False 64-instance IsType Int8   where typeDesc _ = TDInt True   8-instance IsType Int16  where typeDesc _ = TDInt True  16-instance IsType Int32  where typeDesc _ = TDInt True  32-instance IsType Int64  where typeDesc _ = TDInt True  64---- Sequence types-instance (NaturalT n, IsSized a) => IsType (Array n a)-    where typeDesc _ = TDArray (fromIntegerT (undefined :: n))-    	  	               (typeDesc (undefined :: a))-instance (PositiveT n, IsPrimitive a) => IsType (Vector n a)-    where typeDesc _ = TDVector (fromIntegerT (undefined :: n))-    	  	       		(typeDesc (undefined :: a))---- Pointer type.-instance (IsType a) => IsType (Ptr a) where-    typeDesc _ = TDPtr (typeDesc (undefined :: a))--instance IsType (StablePtr a) where-    typeDesc _ = TDPtr (typeDesc (undefined :: Int8))-{--    typeDesc _ = TDPtr TDVoid--List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed.--}----- Functions.-instance (IsFirstClass a, IsFunction b) => IsType (a->b) where-    typeDesc = funcType []---- Function base type, always IO.-instance (IsFirstClass a) => IsType (IO a) where-    typeDesc = funcType []---- Struct types, basically a list of component types.-instance (StructFields a) => IsType (Struct a) where-    typeDesc ~(Struct a) = TDStruct (fieldTypes a) False--instance (StructFields a) => IsType (PackedStruct a) where-    typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True---- Use a nested tuples for struct fields.-class StructFields as where-    fieldTypes :: as -> [TypeDesc]--instance (IsSized a, StructFields as) => StructFields (a :& as) where-    fieldTypes ~(a, as) = typeDesc a : fieldTypes as-instance StructFields () where-    fieldTypes _ = []---- An alias for pairs to make structs look nicer-infixr :&-type (:&) a as = (a, as)-infixr &-(&) :: a -> as -> a :& as-a & as = (a, as)----- Instances to classify types-instance IsArithmetic Float  where arithmeticType = FloatingType-instance IsArithmetic Double where arithmeticType = FloatingType-instance IsArithmetic FP128  where arithmeticType = FloatingType-instance (PositiveT n) => IsArithmetic (IntN n)  where arithmeticType = IntegerType-instance (PositiveT n) => IsArithmetic (WordN n) where arithmeticType = IntegerType-instance IsArithmetic Bool   where arithmeticType = IntegerType-instance IsArithmetic Int8   where arithmeticType = IntegerType-instance IsArithmetic Int16  where arithmeticType = IntegerType-instance IsArithmetic Int32  where arithmeticType = IntegerType-instance IsArithmetic Int64  where arithmeticType = IntegerType-instance IsArithmetic Word8  where arithmeticType = IntegerType-instance IsArithmetic Word16 where arithmeticType = IntegerType-instance IsArithmetic Word32 where arithmeticType = IntegerType-instance IsArithmetic Word64 where arithmeticType = IntegerType-instance (PositiveT n, IsPrimitive a, IsArithmetic a) =>-         IsArithmetic (Vector n a) where-   arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType--instance IsFloating Float-instance IsFloating Double-instance IsFloating FP128-instance (PositiveT n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)--data NotANumber--instance (PositiveT n) => IsInteger (IntN  n) where type Signed (IntN  n) = True-instance (PositiveT n) => IsInteger (WordN n) where type Signed (WordN n) = False-instance IsInteger Bool   where type Signed Bool = NotANumber-instance IsInteger Int8   where type Signed Int8 = True-instance IsInteger Int16  where type Signed Int16 = True-instance IsInteger Int32  where type Signed Int32 = True-instance IsInteger Int64  where type Signed Int64 = True-instance IsInteger Word8  where type Signed Word8 = False-instance IsInteger Word16 where type Signed Word16 = False-instance IsInteger Word32 where type Signed Word32 = False-instance IsInteger Word64 where type Signed Word64 = False-instance (PositiveT n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)-                          where type Signed (Vector n a) = Signed a--instance (PositiveT n) => IsIntegerOrPointer (IntN n)-instance (PositiveT n) => IsIntegerOrPointer (WordN n)-instance IsIntegerOrPointer Bool-instance IsIntegerOrPointer Int8-instance IsIntegerOrPointer Int16-instance IsIntegerOrPointer Int32-instance IsIntegerOrPointer Int64-instance IsIntegerOrPointer Word8-instance IsIntegerOrPointer Word16-instance IsIntegerOrPointer Word32-instance IsIntegerOrPointer Word64-instance (PositiveT n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a)-instance (IsType a) => IsIntegerOrPointer (Ptr a)--instance IsFirstClass Float-instance IsFirstClass Double-instance IsFirstClass FP128-instance (PositiveT n) => IsFirstClass (IntN n)-instance (PositiveT n) => IsFirstClass (WordN n)-instance IsFirstClass Bool-instance IsFirstClass Int8-instance IsFirstClass Int16-instance IsFirstClass Int32-instance IsFirstClass Int64-instance IsFirstClass Word8-instance IsFirstClass Word16-instance IsFirstClass Word32-instance IsFirstClass Word64-instance (PositiveT n, IsPrimitive a) => IsFirstClass (Vector n a)-instance (NaturalT n, IsSized a) => IsFirstClass (Array n a)-instance (IsType a) => IsFirstClass (Ptr a)-instance IsFirstClass (StablePtr a)-instance IsFirstClass Label-instance IsFirstClass () -- XXX This isn't right, but () can be returned-instance (StructFields as) => IsFirstClass (Struct as)--instance (PositiveT n) => IsSized (IntN n)  where type SizeOf (IntN  n) = n-instance (PositiveT n) => IsSized (WordN n) where type SizeOf (WordN n) = n-instance IsSized Float  where type SizeOf Float  = D32-instance IsSized Double where type SizeOf Double = D64-instance IsSized FP128  where type SizeOf FP128  = D128-instance IsSized Bool   where type SizeOf Bool   = D1-instance IsSized Int8   where type SizeOf Int8   = D8-instance IsSized Int16  where type SizeOf Int16  = D16-instance IsSized Int32  where type SizeOf Int32  = D32-instance IsSized Int64  where type SizeOf Int64  = D64-instance IsSized Word8  where type SizeOf Word8  = D8-instance IsSized Word16 where type SizeOf Word16 = D16-instance IsSized Word32 where type SizeOf Word32 = D32-instance IsSized Word64 where type SizeOf Word64 = D64-instance (NaturalT n, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Array n a) where-    type SizeOf (Array n a) = n :*: SizeOf a-instance (PositiveT n, IsPrimitive a, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Vector n a) where-    type SizeOf (Vector n a) = n :*: SizeOf a-instance (IsType a) => IsSized (Ptr a) where type SizeOf (Ptr a) = PtrSize-instance IsSized (StablePtr a) where type SizeOf (StablePtr a) =  PtrSize--- instance IsSized Label PtrSize -- labels are not quite first classed--- We cannot compute the sizes statically :(-instance (StructFields as) => IsSized (Struct as) where-    type SizeOf (Struct as) = UnknownSize-instance (StructFields as) => IsSized (PackedStruct as) where-    type SizeOf (PackedStruct as) = UnknownSize--type UnknownSize = D99   -- XXX this is wrong!--#if WORD_SIZE_IN_BITS == 32-type PtrSize = D32-#elif WORD_SIZE_IN_BITS == 64-type PtrSize = D64-#else-#error cannot determine type of PtrSize-#endif--instance IsPrimitive Float-instance IsPrimitive Double-instance IsPrimitive FP128-instance (PositiveT n) => IsPrimitive (IntN n)-instance (PositiveT n) => IsPrimitive (WordN n)-instance IsPrimitive Bool-instance IsPrimitive Int8-instance IsPrimitive Int16-instance IsPrimitive Int32-instance IsPrimitive Int64-instance IsPrimitive Word8-instance IsPrimitive Word16-instance IsPrimitive Word32-instance IsPrimitive Word64-instance IsPrimitive Label-instance IsPrimitive ()---instance (PositiveT n) =>-         IsScalarOrVector (IntN n)  where type NumberOfElements (IntN n)  = D1-instance (PositiveT n) =>-         IsScalarOrVector (WordN n) where type NumberOfElements (WordN n) = D1-instance IsScalarOrVector Float  where type NumberOfElements Float  = D1-instance IsScalarOrVector Double where type NumberOfElements Double = D1-instance IsScalarOrVector FP128  where type NumberOfElements FP128  = D1-instance IsScalarOrVector Bool   where type NumberOfElements Bool   = D1-instance IsScalarOrVector Int8   where type NumberOfElements Int8   = D1-instance IsScalarOrVector Int16  where type NumberOfElements Int16  = D1-instance IsScalarOrVector Int32  where type NumberOfElements Int32  = D1-instance IsScalarOrVector Int64  where type NumberOfElements Int64  = D1-instance IsScalarOrVector Word8  where type NumberOfElements Word8  = D1-instance IsScalarOrVector Word16 where type NumberOfElements Word16 = D1-instance IsScalarOrVector Word32 where type NumberOfElements Word32 = D1-instance IsScalarOrVector Word64 where type NumberOfElements Word64 = D1-instance IsScalarOrVector Label  where type NumberOfElements Label  = D1-instance IsScalarOrVector ()     where type NumberOfElements ()     = D1--instance (PositiveT n, IsPrimitive a) =>-         IsScalarOrVector (Vector n a) where-    type NumberOfElements (Vector n a) = n----- Functions.-instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where-    funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b)-instance (IsFirstClass a) => IsFunction (IO a) where-    funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a))-instance (IsFirstClass a) => IsFunction (VarArgs a) where-    funcType ts _ = TDFunction True  (reverse ts) (typeDesc (undefined :: a))---- |The 'VarArgs' type is a placeholder for the real 'IO' type that--- can be obtained with 'castVarArgs'.-data VarArgs a-    deriving (Typeable)-instance IsType (VarArgs a) where-    typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly"---- |Define what vararg types are permissible.-class CastVarArgs a b-instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c)-instance CastVarArgs (VarArgs a) (IO a)-instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c)------- XXX Structures not implemented.  Tuples is probably an easy way.-
− LLVM/Core/Util.hs 
@@ -1,498 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.Core.Util(-    -- * Module handling-    Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,-    getModuleValues, getFunctions, getGlobalVariables, valueHasType,-    -- * Module provider handling-    ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule,-    -- * Pass manager handling-    PassManager(..), withPassManager, createPassManager, createFunctionPassManager,-    runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager,-    -- * Instruction builder-    Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock,-    -- * Basic blocks-    BasicBlock,-    appendBasicBlock, getBasicBlocks,-    -- * Functions-    Function,-    addFunction, getParam, getParams,-    -- * Structs-    structType,-    -- * Globals-    addGlobal,-    constString, constStringNul, constVector, constArray, constStruct,-    -- * Instructions-    makeCall, makeInvoke,-    makeCallWithCc, makeInvokeWithCc,-    withValue, getInstructions, getOperands,-    -- * Uses and Users-    hasUsers, getUsers, getUses, getUser, isChildOf, getDep,-    -- * Misc-    CString, withArrayLen,-    withEmptyCString,-    functionType, buildEmptyPhi, addPhiIns,-    showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant,-    -- * Transformation passes-    addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,-    addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,-    addTargetData-    ) where-import Data.Typeable-import Data.List(intercalate)-import Control.Monad(liftM, filterM, when)-import Foreign.C.String (withCString, withCStringLen, CString, peekCString)-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr)-import Foreign.Ptr (Ptr, nullPtr)-import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray)-import Foreign.Marshal.Alloc (alloca)-import Foreign.Storable (Storable(..))-import Foreign.Marshal.Utils (fromBool)-import System.IO.Unsafe (unsafePerformIO)--import qualified LLVM.FFI.Core as FFI-import qualified LLVM.FFI.Target as FFI-import qualified LLVM.FFI.BitWriter as FFI-import qualified LLVM.FFI.BitReader as FFI-import qualified LLVM.FFI.Transforms.Scalar as FFI--type Type = FFI.TypeRef---- unsafePerformIO just to wrap the non-effecting withArrayLen call-functionType :: Bool -> Type -> [Type] -> Type-functionType varargs retType paramTypes = unsafePerformIO $-    withArrayLen paramTypes $ \ len ptr ->-        return $ FFI.functionType retType ptr (fromIntegral len)-	       	 		  (fromBool varargs)---- unsafePerformIO just to wrap the non-effecting withArrayLen call-structType :: [Type] -> Bool -> Type-structType types packed = unsafePerformIO $-    withArrayLen types $ \ len ptr ->-        return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0)------------------------------------------- Handle modules---- Don't use a finalizer for the module, but instead provide an--- explicit destructor.  This is because handing a module to--- a module provider changes ownership of the module to the provider,--- and we don't want to free it by mistake.---- | Type of top level modules.-newtype Module = Module {-      fromModule :: FFI.ModuleRef-    }-    deriving (Show, Typeable)--withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a-withModule modul f = f (fromModule modul)--createModule :: String -> IO Module-createModule name =-    withCString name $ \ namePtr -> do-      liftM Module $ FFI.moduleCreateWithName namePtr---- | Free all storage related to a module.  *Note*, this is a dangerous call, since referring--- to the module after this call is an error.  The reason for the explicit call to free--- the module instead of an automatic lifetime management is that modules have a--- somewhat complicated ownership.  Handing a module to a module provider changes--- the ownership of the module, and the module provider will free the module when necessary.-destroyModule :: Module -> IO ()-destroyModule = FFI.disposeModule . fromModule---- |Write a module to a file.-writeBitcodeToFile :: String -> Module -> IO ()-writeBitcodeToFile name mdl =-    withCString name $ \ namePtr ->-      withModule mdl $ \ mdlPtr -> do-        rc <- FFI.writeBitcodeToFile mdlPtr namePtr-        when (rc /= 0) $-          ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc-        return ()---- |Read a module from a file.-readBitcodeFromFile :: String -> IO Module-readBitcodeFromFile name =-    withCString name $ \ namePtr ->-      alloca $ \ bufPtr ->-      alloca $ \ modPtr ->-      alloca $ \ errStr -> do-        rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr-        if rrc /= 0 then do-            msg <- peek errStr >>= peekCString-            ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg-         else do-            buf <- peek bufPtr-            prc <- FFI.parseBitcode buf modPtr errStr-	    if prc /= 0 then do-                msg <- peek errStr >>= peekCString-                ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg-             else do-                ptr <- peek modPtr-                return $ Module ptr-{--                liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr--}--getModuleValues :: Module -> IO [(String, Value)]-getModuleValues mdl = do-  fs <- getFunctions mdl-  gs <- getGlobalVariables mdl-  return (fs ++ gs)--getFunctions :: Module -> IO [(String, Value)]-getFunctions mdl = getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl >>= filterM isIntrinsic >>= annotateValueList--getGlobalVariables :: Module -> IO [(String, Value)]-getGlobalVariables mdl = getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl >>= annotateValueList---- This is safe because we just ask for the type of a value.-valueHasType :: Value -> Type -> Bool-valueHasType v t = unsafePerformIO $ do-    vt <- FFI.typeOf v-    return $ vt == t  -- LLVM uses hash consing for types, so pointer equality works.--showTypeOf :: Value -> IO String-showTypeOf v = FFI.typeOf v >>= showType'--showType' :: Type -> IO String-showType' p = do-    pk <- FFI.getTypeKind p-    case pk of-        FFI.VoidTypeKind -> return "()"-	FFI.FloatTypeKind -> return "Float"-	FFI.DoubleTypeKind -> return "Double"-	FFI.X86_FP80TypeKind -> return "X86_FP80"-	FFI.FP128TypeKind -> return "FP128"-	FFI.PPC_FP128TypeKind -> return "PPC_FP128"-	FFI.LabelTypeKind -> return "Label"-	FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"-	FFI.FunctionTypeKind -> do-            r <- FFI.getReturnType p-	    c <- FFI.countParamTypes p-	    let n = fromIntegral c-	    as <- allocaArray n $ \ args -> do-		     FFI.getParamTypes p args-		     peekArray n args-	    ts <- mapM showType' (as ++ [r])-	    return $ "(" ++ intercalate " -> " ts ++ ")"-	FFI.StructTypeKind -> return "(Struct ...)"-	FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"-	FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"-	FFI.OpaqueTypeKind -> return "Opaque"-	FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")"------------------------------------------- Handle module providers---- | A module provider is used by the code generator to get access to a module.-newtype ModuleProvider = ModuleProvider {-      fromModuleProvider :: ForeignPtr FFI.ModuleProvider-    }-    deriving (Show, Typeable)--withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a)-                   -> IO a-withModuleProvider = withForeignPtr . fromModuleProvider---- | Turn a module into a module provider.-createModuleProviderForExistingModule :: Module -> IO ModuleProvider-createModuleProviderForExistingModule modul =-    withModule modul $ \modulPtr -> do-        ptr <- FFI.createModuleProviderForExistingModule modulPtr-        -- MPs given to the EE get taken over, so we should not GC them.-        liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr-------------------------------------------- Handle instruction builders--newtype Builder = Builder {-      fromBuilder :: ForeignPtr FFI.Builder-    }-    deriving (Show, Typeable)--withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a-withBuilder = withForeignPtr . fromBuilder--createBuilder :: IO Builder-createBuilder = do-    ptr <- FFI.createBuilder-    liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr--positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO ()-positionAtEnd bld bblk =-    withBuilder bld $ \ bldPtr ->-      FFI.positionAtEnd bldPtr bblk--getInsertBlock :: Builder -> IO FFI.BasicBlockRef-getInsertBlock bld =-    withBuilder bld $ \ bldPtr ->-      FFI.getInsertBlock bldPtr------------------------------------------type BasicBlock = FFI.BasicBlockRef--appendBasicBlock :: Function -> String -> IO BasicBlock-appendBasicBlock func name =-    withCString name $ \ namePtr ->-      FFI.appendBasicBlock func namePtr--getBasicBlocks :: Value -> IO [(String, Value)]-getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v >>= annotateValueList------------------------------------------type Function = FFI.ValueRef--addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function-addFunction modul linkage name typ =-    withModule modul $ \ modulPtr ->-      withCString name $ \ namePtr -> do-        f <- FFI.addFunction modulPtr namePtr typ-        FFI.setLinkage f (FFI.fromLinkage linkage)-        return f--getParam :: Function -> Int -> Value-getParam f = FFI.getParam f . fromIntegral--getParams :: Value -> IO [(String, Value)]-getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList------------------------------------------addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value-addGlobal modul linkage name typ =-    withModule modul $ \ modulPtr ->-      withCString name $ \ namePtr -> do-        v <- FFI.addGlobal modulPtr typ namePtr-        FFI.setLinkage v (FFI.fromLinkage linkage)-        return v---- unsafePerformIO is safe because it's only used for the withCStringLen conversion-constStringInternal :: Bool -> String -> Value-constStringInternal nulTerm s = unsafePerformIO $-    withCStringLen s $ \(sPtr, sLen) ->-      return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm))--constString :: String -> Value-constString = constStringInternal False--constStringNul :: String -> Value-constStringNul = constStringInternal True------------------------------------------type Value = FFI.ValueRef--withValue :: Value -> (Value -> IO a) -> IO a-withValue v f = f v--makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value-makeCall = makeCallWithCc FFI.C--makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value-makeCallWithCc cc func bldPtr args = do-{--      print "makeCall"-      FFI.dumpValue func-      mapM_ FFI.dumpValue args-      print "----------------------"--}-      withArrayLen args $ \ argLen argPtr ->-        withEmptyCString $ \cstr -> do-          i <- FFI.buildCall bldPtr func argPtr-                             (fromIntegral argLen) cstr-          FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)-          return i--makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->-              [Value] -> IO Value-makeInvoke = makeInvokeWithCc FFI.C--makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->-              [Value] -> IO Value-makeInvokeWithCc cc norm expt func bldPtr args =-      withArrayLen args $ \ argLen argPtr ->-        withEmptyCString $ \cstr -> do-          i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr-          FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)-          return i--getInstructions :: Value -> IO [(String, Value)]-getInstructions bb = getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList--getOperands :: Value -> IO [(String, Value)]-getOperands ii = geto ii >>= annotateValueList-    where geto i = do-            num <- FFI.getNumOperands i-            let oloop instr number total = if number >= total then return [] else do-                    o <- FFI.getOperand instr number-                    os <- oloop instr (number + 1) total-                    return (o : os)-            oloop i 0 num------------------------------------------buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value-buildEmptyPhi bldPtr typ = do-    withEmptyCString $ FFI.buildPhi bldPtr typ--withEmptyCString :: (CString -> IO a) -> IO a-withEmptyCString = withCString ""--addPhiIns :: Value -> [(Value, BasicBlock)] -> IO ()-addPhiIns inst incoming = do-    let (vals, bblks) = unzip incoming-    withArrayLen vals $ \ count valPtr ->-      withArray bblks $ \ bblkPtr ->-        FFI.addIncoming inst valPtr bblkPtr (fromIntegral count)-------------------------------------------- | Manage compile passes.-newtype PassManager = PassManager {-      fromPassManager :: ForeignPtr FFI.PassManager-    }-    deriving (Show, Typeable)--withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)-                   -> IO a-withPassManager = withForeignPtr . fromPassManager---- | Create a pass manager.-createPassManager :: IO PassManager-createPassManager = do-    ptr <- FFI.createPassManager-    liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr---- | Create a pass manager for a module.-createFunctionPassManager :: ModuleProvider -> IO PassManager-createFunctionPassManager modul =-    withModuleProvider modul $ \modulPtr -> do-        ptr <- FFI.createFunctionPassManager modulPtr-        liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr---- | Add a control flow graph simplification pass to the manager.-addCFGSimplificationPass :: PassManager -> IO ()-addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass---- | Add a constant propagation pass to the manager.-addConstantPropagationPass :: PassManager -> IO ()-addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass--addDemoteMemoryToRegisterPass :: PassManager -> IO ()-addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass---- | Add a global value numbering pass to the manager.-addGVNPass :: PassManager -> IO ()-addGVNPass pm = withPassManager pm FFI.addGVNPass--addInstructionCombiningPass :: PassManager -> IO ()-addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass--addPromoteMemoryToRegisterPass :: PassManager -> IO ()-addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass--addReassociatePass :: PassManager -> IO ()-addReassociatePass pm = withPassManager pm FFI.addReassociatePass--addTargetData :: FFI.TargetDataRef -> PassManager -> IO ()-addTargetData td pm = withPassManager pm $ FFI.addTargetData td--runFunctionPassManager :: PassManager -> Function -> IO Int-runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn--initializeFunctionPassManager :: PassManager -> IO Int-initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager--finalizeFunctionPassManager :: PassManager -> IO Int-finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager-------------------------------------------- The unsafePerformIO is just for the non-effecting withArrayLen-constVector :: Int -> [Value] -> Value-constVector n xs = unsafePerformIO $ do-    let xs' = take n (cycle xs)-    withArrayLen xs' $ \ len ptr ->-        return $ FFI.constVector ptr (fromIntegral len)---- The unsafePerformIO is just for the non-effecting withArrayLen-constArray :: Type -> Int -> [Value] -> Value-constArray t n xs = unsafePerformIO $ do-    let xs' = take n (cycle xs)-    withArrayLen xs' $ \ len ptr ->-        return $ FFI.constArray t ptr (fromIntegral len)---- The unsafePerformIO is just for the non-effecting withArrayLen-constStruct :: [Value] -> Bool -> Value-constStruct xs packed = unsafePerformIO $ do-    withArrayLen xs $ \ len ptr ->-        return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0)------------------------------------------getValueNameU :: Value -> IO String-getValueNameU a = do-    -- sometimes void values need explicit names too-    cs <- FFI.getValueName a-    str <- peekCString cs-    if str == "" then return (show a) else return str--getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a))-           -> (Ptr a -> IO (Ptr a)) -> t1 -> t-getObjList withF firstF nextF obj = do-    withF obj $ \ objPtr -> do-      ofst <- firstF objPtr -      let oloop p = if p == nullPtr then return [] else do-              n <- nextF p-              ps <- oloop n-              return (p : ps)-      oloop ofst--annotateValueList :: [Value] -> IO [(String, Value)]-annotateValueList vs = do-  names <- mapM getValueNameU vs-  return $ zip names vs--isConstant :: Value -> IO Bool-isConstant v = do-  isC <- FFI.isConstant v-  if isC == 0 then return False else return True--isIntrinsic :: Value -> IO Bool-isIntrinsic v = do-  if FFI.getIntrinsicID v == 0 then return True else return False------------------------------------------type Use = FFI.UseRef--hasUsers :: Value -> IO Bool-hasUsers v = do-  nU <- FFI.getNumUses v-  if nU == 0 then return False else return True--getUses :: Value -> IO [Use]-getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse--getUsers :: [Use] -> IO [(String, Value)]-getUsers us = mapM FFI.getUser us >>= annotateValueList--getUser :: Use -> IO Value-getUser = FFI.getUser--isChildOf :: BasicBlock -> Value -> IO Bool-isChildOf bb v = do-  bb2 <- FFI.getInstructionParent v-  if bb == bb2 then return True else return False--getDep :: Use -> IO (String, String)-getDep u = do-  producer <- FFI.getUsedValue u >>= getValueNameU-  consumer <- FFI.getUser u >>= getValueNameU-  return (producer, consumer)
− LLVM/Core/Vector.hs 
@@ -1,148 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-module LLVM.Core.Vector(MkVector(..), vector, ) where-import Data.Function-import Types.Data.Num-import LLVM.Core.Type-import LLVM.Core.Data-import LLVM.ExecutionEngine.Target-import Foreign.Ptr(castPtr)-import Foreign.Storable(Storable(..))-import Foreign.Marshal.Array(peekArray, pokeArray)-import System.IO.Unsafe(unsafePerformIO)---- XXX Should these really be here?-class (PositiveT n, IsPrimitive a) => MkVector n a where-    type Tuple n a :: *-    toVector :: Tuple n a -> Vector n a-    fromVector :: Vector n a -> Tuple n a--{--instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where-    toVector a = Vector [a]--}--instance (IsPrimitive a) => MkVector D2 a where-    type Tuple D2 a = (a,a)-    toVector (a1, a2) = Vector [a1, a2]-    fromVector (Vector [a1, a2]) = (a1, a2)-    fromVector _ = error "fromVector: impossible"--instance (IsPrimitive a) => MkVector D4 a where-    type Tuple D4 a = (a,a,a,a)-    toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]-    fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4)-    fromVector _ = error "fromVector: impossible"--instance (IsPrimitive a) => MkVector D8 a where-    type Tuple D8 a = (a,a,a,a,a,a,a,a)-    toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]-    fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8)-    fromVector _ = error "fromVector: impossible"--instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where-    sizeOf a = storeSizeOfType ourTargetData (typeRef a)-    alignment a = aBIAlignmentOfType ourTargetData (typeRef a)-    peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a)-    poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs---- XXX The JITer target data.  This isn't really right.-ourTargetData :: TargetData-ourTargetData = unsafePerformIO getTargetData------------------------------------------unVector :: Vector n a -> [a]-unVector (Vector xs) = xs---- |Make a constant vector.  Replicates or truncates the list to get length /n/.--- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'.-vector :: forall a n. (PositiveT n) => [a] -> Vector n a-vector xs =-   Vector (take (fromIntegerT (undefined :: n)) (cycle xs))---binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c-binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys)--unop :: (a -> b) -> Vector n a -> Vector n b-unop op = Vector . map op . unVector--instance (Eq a, PositiveT n) => Eq (Vector n a) where-    (==) = (==) `on` unVector--instance (Ord a, PositiveT n) => Ord (Vector n a) where-    compare = compare `on` unVector--instance (Num a, PositiveT n) => Num (Vector n a) where-    (+) = binop (+)-    (-) = binop (-)-    (*) = binop (*)-    negate = unop negate-    abs = unop abs-    signum = unop signum-    fromInteger = Vector . replicate (fromIntegerT (undefined :: n)) . fromInteger--instance (Enum a, PositiveT n) => Enum (Vector n a) where-    succ = unop succ-    pred = unop pred-    fromEnum = error "Vector fromEnum"-    toEnum = Vector . map toEnum . replicate (fromIntegerT (undefined :: n))--instance (Real a, PositiveT n) => Real (Vector n a) where-    toRational = error "Vector toRational"--instance (Integral a, PositiveT n) => Integral (Vector n a) where-    quot = binop quot-    rem  = binop rem-    div  = binop div-    mod  = binop mod-    quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys-    divMod  (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod  xs ys-    toInteger = error "Vector toInteger"--instance (Fractional a, PositiveT n) => Fractional (Vector n a) where-    (/) = binop (/)-    fromRational = Vector . replicate (fromIntegerT (undefined :: n)) . fromRational--instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where-    properFraction = error "Vector properFraction"--instance (Floating a, PositiveT n) => Floating (Vector n a) where-    pi = Vector $ replicate (fromIntegerT (undefined :: n)) pi-    sqrt = unop sqrt-    log = unop log-    logBase = binop logBase-    (**) = binop (**)-    exp = unop exp-    sin = unop sin-    cos = unop cos-    tan = unop tan-    asin = unop asin-    acos = unop acos-    atan = unop atan-    sinh = unop sinh-    cosh = unop cosh-    tanh = unop tanh-    asinh = unop asinh-    acosh = unop acosh-    atanh = unop atanh--instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where-    floatRadix = floatRadix . head . unVector-    floatDigits = floatDigits . head . unVector-    floatRange = floatRange . head . unVector-    decodeFloat = error "Vector decodeFloat"-    encodeFloat = error "Vector encodeFloat"-    exponent _ = 0-    scaleFloat 0 x = x-    scaleFloat _ _ = error "Vector scaleFloat"-    isNaN = error "Vector isNaN"-    isInfinite = error "Vector isInfinite"-    isDenormalized = error "Vector isDenormalized"-    isNegativeZero = error "Vector isNegativeZero"-    isIEEE = isIEEE . head . unVector
− LLVM/ExecutionEngine.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE TypeFamilies #-}- -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module.-module LLVM.ExecutionEngine(-    -- * Execution engine-    EngineAccess,-    runEngineAccess,-    addModuleProvider,-    addModule,-{--    runStaticConstructors,-    runStaticDestructors,--}-    getPointerToFunction,-    addFunctionValue,-    addGlobalMappings,-    getFreePointers, FreePointers,-    -- * Translation-    Translatable, Generic,-    generateFunction,-    -- * Unsafe type conversion-    Unsafe,-    unsafeRemoveIO,-    -- * Simplified interface.-    simpleFunction,-    unsafeGenerateFunction,-    -- * Target information-    module LLVM.ExecutionEngine.Target-    ) where-import System.IO.Unsafe (unsafePerformIO)--import LLVM.ExecutionEngine.Engine-import LLVM.FFI.Core(ValueRef)-import LLVM.Core.CodeGen(Value(..))-import LLVM.Core-import LLVM.ExecutionEngine.Target---import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager)-import Control.Monad (liftM2, )---- |Class of LLVM function types that can be translated to the corresponding--- Haskell type.-class Translatable f where-    translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f--instance (Generic a, Translatable b) => Translatable (a -> b) where-    translate run args f = \ arg -> translate run (toGeneric arg : args) f--instance (Generic a) => Translatable (IO a) where-    translate run args f = fmap fromGeneric $ run f $ reverse args---- |Generate a Haskell function from an LLVM function.------ Note that the function is compiled for every call (Just-In-Time compilation).--- If you want to compile the function once and call it a lot of times--- then you should better use 'getPointerToFunction'.-generateFunction :: (Translatable f) =>-                    Value (Ptr f) -> EngineAccess f-generateFunction (Value f) = do-    run <- getRunFunction-    return $ translate run [] f--class Unsafe a where-    type RemoveIO a :: *-    unsafeRemoveIO :: a -> RemoveIO a  -- ^Remove the IO from a function return type.  This is unsafe in general.--instance (Unsafe b) => Unsafe (a->b) where-    type RemoveIO (a -> b) = a -> RemoveIO b-    unsafeRemoveIO f = unsafeRemoveIO . f--instance Unsafe (IO a) where-    type RemoveIO (IO a) = a-    unsafeRemoveIO = unsafePerformIO---- |Translate a function to Haskell code.  This is a simplified interface to--- the execution engine and module mechanism.--- It is based on 'generateFunction', so see there for limitations.-simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f-simpleFunction bld = do-    m <- newModule-    (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings)-    prov <- createModuleProviderForExistingModule m-    runEngineAccess $ do-        addModuleProvider prov-        addGlobalMappings mappings-        generateFunction func--{--    m <- newModule-    func <- defineModule m bld---    dumpValue func-    prov <- createModuleProviderForExistingModule m-    ee <- createExecutionEngine prov-    pm <- createFunctionPassManager prov-    td <- getExecutionEngineTargetData ee-    addTargetData td pm-    addInstructionCombiningPass pm-    addReassociatePass pm-    addGVNPass pm-    addCFGSimplificationPass pm-    addPromoteMemoryToRegisterPass pm-    initializeFunctionPassManager pm---    print ("rc1", rc1)-    runFunctionPassManager pm (unValue func)---    print ("rc2", rc2)-    finalizeFunctionPassManager pm---    print ("rc3", rc3)---    dumpValue func-    return $ generateFunction ee func--}---- | Combine 'simpleFunction' and 'unsafeRemoveIO'.-unsafeGenerateFunction :: (Unsafe t, Translatable t) =>-                          CodeGenModule (Function t) -> RemoveIO t-unsafeGenerateFunction bld = unsafePerformIO $ do-    fun <- simpleFunction bld-    return $ unsafeRemoveIO fun
− LLVM/ExecutionEngine/Engine.hs 
@@ -1,335 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.ExecutionEngine.Engine(-       EngineAccess,-       runEngineAccess,-{--       ExecutionEngine,--}-       createExecutionEngine, addModuleProvider, addModule,-       {- runStaticConstructors, runStaticDestructors, -}-       getExecutionEngineTargetData,-       getPointerToFunction,-       addFunctionValue, addGlobalMappings,-       getFreePointers, FreePointers,-       runFunction, getRunFunction,-       GenericValue, Generic(..)-       ) where-import qualified Control.Monad.Trans.State as MS-import Control.Monad.Trans.State (StateT, runStateT, )-import Control.Monad.IO.Class (MonadIO, liftIO, )-import Control.Monad (liftM, )-import Control.Applicative (Applicative, )-import Control.Concurrent.MVar-import Data.Typeable-import Data.Int-import Data.Word-import Foreign.Marshal.Alloc (alloca, free)-import Foreign.Marshal.Array (withArrayLen)-import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)-import Foreign.Marshal.Utils (fromBool)-import Foreign.C.String (peekCString)-import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr)-import LLVM.Core.CodeGen(Value(..), Function)-import LLVM.Core.CodeGenMonad(GlobalMappings(..))-import Foreign.Storable (peek)-import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )-import System.IO.Unsafe (unsafePerformIO)--import LLVM.Core.Util(Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule)-import qualified LLVM.FFI.ExecutionEngine as FFI-import qualified LLVM.FFI.Target as FFI-import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef)-import qualified LLVM.Core.Util as U-import LLVM.Core.Type(IsFirstClass, typeRef)--{---- |The type of the JITer.-newtype ExecutionEngine = ExecutionEngine {-      fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine-    }--withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a)-                    -> IO a-withExecutionEngine = withForeignPtr . fromExecutionEngine---- |Create an execution engine for a module provider.--- Warning, do not call this function more than once.-createExecutionEngine :: ModuleProvider -> IO ExecutionEngine-createExecutionEngine prov =-    withModuleProvider prov $ \provPtr ->-      alloca $ \eePtr ->-        alloca $ \errPtr -> do-          ret <- FFI.createExecutionEngine eePtr provPtr errPtr-          if ret == 1-            then do err <- peek errPtr-                    errStr <- peekCString err-                    free err-                    ioError . userError $ errStr-            else do ptr <- peek eePtr-                    liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr--addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO ()-addModuleProvider ee prov =-    withExecutionEngine ee $ \ eePtr ->-      withModuleProvider prov $ \ provPtr ->-        FFI.addModuleProvider eePtr provPtr--runStaticConstructors :: ExecutionEngine -> IO ()-runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors--runStaticDestructors :: ExecutionEngine -> IO ()-runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors--getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef-getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData--getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f)-getPointerToFunction ee (Value f) =-    withExecutionEngine ee $ \ eePtr ->-      FFI.getPointerToGlobal eePtr f--}---- This global variable holds the one and only execution engine.--- It may be missing, but it never dies.--- XXX We could provide a destructor, what about functions obtained by runFunction?-{-# NOINLINE theEngine #-}-theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine))-theEngine = unsafePerformIO $ newMVar Nothing--createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine)-createExecutionEngine prov =-    withModuleProvider prov $ \provPtr ->-      alloca $ \eePtr ->-        alloca $ \errPtr -> do-          ret <- FFI.createExecutionEngine eePtr provPtr errPtr-          if ret == 1-            then do-                err <- peek errPtr-                errStr <- peekCString err-                free err-                ioError . userError $ errStr-            else-                peek eePtr--getTheEngine :: IO (Ptr FFI.ExecutionEngine)-getTheEngine = do-    mee <- takeMVar theEngine-    case mee of-        Just ee -> do putMVar theEngine mee; return ee-        Nothing -> do-            m <- createModule "__empty__"-            mp <- createModuleProviderForExistingModule m-            ee <- createExecutionEngine mp-            putMVar theEngine (Just ee)-            return ee--data EAState = EAState {-    ea_engine :: Ptr FFI.ExecutionEngine,-    ea_providers :: [ModuleProvider]-    }-    deriving (Show, Typeable)--newtype EngineAccess a = EA (StateT EAState IO a)-    deriving (Functor, Applicative, Monad, MonadIO)---- |The LLVM execution engine is encapsulated so it cannot be accessed directly.--- The reason is that (currently) there must only ever be one engine,--- so access to it is wrapped in a monad.-runEngineAccess :: EngineAccess a -> IO a-runEngineAccess (EA body) = do-    eePtr <- getTheEngine-    let ea = EAState { ea_engine = eePtr, ea_providers = [] }-    (a, _ea') <- runStateT body ea-    -- XXX should remove module providers again-    return a--addModuleProvider :: ModuleProvider -> EngineAccess ()-addModuleProvider prov = do-    ea <- EA MS.get-    EA $ MS.put ea{ ea_providers = prov : ea_providers ea }-    liftIO $ withModuleProvider prov $ \ provPtr ->-                 FFI.addModuleProvider (ea_engine ea) provPtr---getEngine :: EngineAccess (Ptr FFI.ExecutionEngine)-getEngine = EA $ MS.gets ea_engine--getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef-getExecutionEngineTargetData = do-    eePtr <- getEngine-    liftIO $ FFI.getExecutionEngineTargetData eePtr--{- |-In contrast to 'generateFunction' this compiles a function once.-Thus it is faster for many calls to the same function.-See @examples\/Vector.hs@.--If the function calls back into Haskell code,-you also have to set the function addresses-using 'addFunctionValue' or 'addGlobalMappings'.--}-getPointerToFunction :: Function f -> EngineAccess (FunPtr f)-getPointerToFunction (Value f) = do-    eePtr <- getEngine-    liftIO $ FFI.getPointerToGlobal eePtr f--{- |-Tell LLVM the address of an external function-if it cannot resolve a name automatically.-Alternatively you may declare the function-with 'staticFunction' instead of 'externFunction'.--}-addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()-addFunctionValue (Value g) f =-    addFunctionValueCore g (castFunPtrToPtr f)--{- |-Pass a list of global mappings to LLVM-that can be obtained from 'LLVM.Core.getGlobalMappings'.--}-addGlobalMappings :: GlobalMappings -> EngineAccess ()-addGlobalMappings (GlobalMappings gms) =-    mapM_ (uncurry addFunctionValueCore) gms--addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess ()-addFunctionValueCore g f = do-    eePtr <- getEngine-    liftIO $ FFI.addGlobalMapping eePtr g f--addModule :: Module -> EngineAccess ()-addModule m = do-    mp <- liftIO $ createModuleProviderForExistingModule m-    addModuleProvider mp---- | Get all the information needed to free a function.--- Freeing code might have to be done from a (C) finalizer, so it has to done from C.--- The function c_freeFunctionObject take these pointers as arguments and frees the function.-type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef)-getFreePointers :: Function f -> EngineAccess FreePointers-getFreePointers (Value f) = do-    ea <- EA MS.get-    liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp ->-        return (ea_engine ea, mpp, f)------------------------------------------newtype GenericValue = GenericValue {-      fromGenericValue :: ForeignPtr FFI.GenericValue-    }--withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a-withGenericValue = withForeignPtr . fromGenericValue--createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue-createGenericValueWith f = do-  ptr <- f-  liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr--withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a-withAll ps a = go [] ps-    where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs-          go ptrs _ = withArrayLen (reverse ptrs) a-                   -runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue-runFunction func args = do-    eePtr <- getEngine-    liftIO $ withAll args $ \argLen argPtr ->-                 createGenericValueWith $ FFI.runFunction eePtr func-                                              (fromIntegral argLen) argPtr-getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)-getRunFunction = do-    eePtr <- getEngine-    return $ \ func args -> -             withAll args $ \argLen argPtr ->-                 createGenericValueWith $ FFI.runFunction eePtr func-                                              (fromIntegral argLen) argPtr--class Generic a where-    toGeneric :: a -> GenericValue-    fromGeneric :: GenericValue -> a--instance Generic () where-    toGeneric _ = error "toGeneric ()"-    fromGeneric _ = ()--toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue-toGenericInt signed val = unsafePerformIO $ createGenericValueWith $-    FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed)--fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a-fromGenericInt signed val = unsafePerformIO $-    withGenericValue val $ \ref ->-      return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed)----instance Generic Bool where---    toGeneric = toGenericInt False . fromBool---    fromGeneric = toBool . fromGenericInt False--instance Generic Int8 where-    toGeneric = toGenericInt True-    fromGeneric = fromGenericInt True--instance Generic Int16 where-    toGeneric = toGenericInt True-    fromGeneric = fromGenericInt True--instance Generic Int32 where-    toGeneric = toGenericInt True-    fromGeneric = fromGenericInt True--{--instance Generic Int where-    toGeneric = toGenericInt True-    fromGeneric = fromGenericInt True--}--instance Generic Int64 where-    toGeneric = toGenericInt True-    fromGeneric = fromGenericInt True--instance Generic Word8 where-    toGeneric = toGenericInt False-    fromGeneric = fromGenericInt False--instance Generic Word16 where-    toGeneric = toGenericInt False-    fromGeneric = fromGenericInt False--instance Generic Word32 where-    toGeneric = toGenericInt False-    fromGeneric = fromGenericInt False--instance Generic Word64 where-    toGeneric = toGenericInt False-    fromGeneric = fromGenericInt False--toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue-toGenericReal val = unsafePerformIO $ createGenericValueWith $-    FFI.createGenericValueOfFloat (typeRef val) (realToFrac val)--fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a-fromGenericReal val = unsafePerformIO $-    withGenericValue val $ \ ref ->-      return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref--instance Generic Float where-    toGeneric = toGenericReal-    fromGeneric = fromGenericReal--instance Generic Double where-    toGeneric = toGenericReal-    fromGeneric = fromGenericReal--instance Generic (Ptr a) where-    toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer-    fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer--instance Generic (StablePtr a) where-    toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr-    fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer
− LLVM/ExecutionEngine/Target.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DeriveDataTypeable #-}-module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where-import Data.Typeable-import Types.Data.Num(PositiveT, reifyPositiveD)-import Data.Maybe(fromMaybe)-import Foreign.C.String-import System.IO.Unsafe(unsafePerformIO)--import LLVM.Core.Data(WordN)-import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData)--import qualified LLVM.FFI.Core as FFI-import qualified LLVM.FFI.Target as FFI--type Type = FFI.TypeRef--data TargetData = TargetData {-    aBIAlignmentOfType         :: Type -> Int,-    aBISizeOfType              :: Type -> Int,-    littleEndian               :: Bool,-    callFrameAlignmentOfType   :: Type -> Int,---  elementAtOffset            :: Type -> Word64 -> Int,-    intPtrType                 :: Type,---  offsetOfElements           :: Int -> Word64,-    pointerSize                :: Int,---  preferredAlignmentOfGlobal :: Value a -> Int,-    preferredAlignmentOfType   :: Type -> Int,-    sizeOfTypeInBits           :: Type -> Int,-    storeSizeOfType            :: Type -> Int-    }-    deriving (Typeable)--withIntPtrType :: (forall n . (PositiveT n) => WordN n -> a) -> a-withIntPtrType f =-    fromMaybe (error "withIntPtrType: pointer size must be non-negative") $-        reifyPositiveD (fromIntegral sz) (\ n -> f (g n))-  where g :: n -> WordN n-        g _ = error "withIntPtrType: argument used"-        sz = pointerSize $ unsafePerformIO getTargetData---- Gets the target data for the JIT target.-getEngineTargetDataRef :: IO FFI.TargetDataRef-getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData---- Normally the TargetDataRef never changes, so the operation--- are really pure functions.-makeTargetData :: FFI.TargetDataRef -> TargetData-makeTargetData r = TargetData {-    aBIAlignmentOfType       = fromIntegral . FFI.aBIAlignmentOfType r,-    aBISizeOfType            = fromIntegral . FFI.aBISizeOfType r,-    littleEndian             = FFI.byteOrder r /= 0,-    callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r,-    intPtrType               = FFI.intPtrType r,-    pointerSize              = fromIntegral $ FFI.pointerSize r,-    preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r,-    sizeOfTypeInBits         = fromIntegral . FFI.sizeOfTypeInBits r,-    storeSizeOfType          = fromIntegral . FFI.storeSizeOfType r-    }--getTargetData :: IO TargetData-getTargetData = fmap makeTargetData getEngineTargetDataRef--targetDataFromString :: String -> TargetData-targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData
− LLVM/Util/Arithmetic.hs 
@@ -1,311 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeFamilies #-}-module LLVM.Util.Arithmetic(-    TValue,-    (%==), (%/=), (%<), (%<=), (%>), (%>=),-    (%&&), (%||),-    (?), (??),-    retrn, set,-{--    ArithFunction, arithFunction,-    UnwrapArgs, toArithFunction,-    recursiveFunction,--}-    CallIntrinsic,-    ) where--import qualified Types.Data.Num as TypeNum-import qualified LLVM.Core as LLVM-import LLVM.Core hiding (cmp, )-import LLVM.Util.Loop(mapVector, mapVector2)---- |Synonym for @CodeGenFunction r (Value a)@.-type TValue r a = CodeGenFunction r (Value a)---infix  4  %==, %/=, %<, %<=, %>=, %>--- |Comparison functions.-(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a) => TValue r a -> TValue r a -> TValue r (CmpResult a)-(%==) = binop $ LLVM.cmp CmpEQ-(%/=) = binop $ LLVM.cmp CmpNE-(%>)  = binop $ LLVM.cmp CmpGT-(%>=) = binop $ LLVM.cmp CmpGE-(%<)  = binop $ LLVM.cmp CmpLT-(%<=) = binop $ LLVM.cmp CmpLE--infixr 3  %&&-infixr 2  %||--- |Lazy and.-(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool-a %&& b = a ? (b, return (valueOf False))--- |Lazy or.-(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool-a %|| b = a ? (return (valueOf True), b)--infix  0 ?--- |Conditional, returns first element of the pair when condition is true, otherwise second.-(?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a-c ? (t, f) = do-    lt <- newBasicBlock-    lf <- newBasicBlock-    lj <- newBasicBlock-    c' <- c-    condBr c' lt lf-    defineBasicBlock lt-    rt <- t-    lt' <- getCurrentBasicBlock-    br lj-    defineBasicBlock lf-    rf <- f-    lf' <- getCurrentBasicBlock-    br lj-    defineBasicBlock lj-    phi [(rt, lt'), (rf, lf')]--infix 0 ??-(??) :: (IsFirstClass a, CmpRet a) => TValue r (CmpResult a) -> (TValue r a, TValue r a) -> TValue r a-c ?? (t, f) = do-    c' <- c-    t' <- t-    f' <- f-    select c' t' f'---- | Return a value from an 'arithFunction'.-retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r ()-retrn x = x >>= ret---- | Use @x <- set $ ...@ to make a binding.-set :: TValue r a -> (CodeGenFunction r (TValue r a))-set x = do x' <- x; return (return x')--instance (Show (TValue r a))-instance (Eq (TValue r a))-instance (Ord (TValue r a))--instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where-    (+) = binop add-    (-) = binop sub-    (*) = binop mul-    negate = (>>= neg)-    abs x = x %< 0 ?? (-x, x)-    signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0))-    fromInteger = return . valueOf . fromInteger--instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Enum (TValue r a) where-    succ x = x + 1-    pred x = x - 1-    fromEnum _ = error "CodeGenFunction Value: fromEnum"-    toEnum = fromIntegral--instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Real (TValue r a) where-    toRational _ = error "CodeGenFunction Value: toRational"--instance (CmpRet a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where-    quot = binop idiv-    rem  = binop irem-    quotRem x y = (quot x y, rem x y)-    toInteger _ = error "CodeGenFunction Value: toInteger"--instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where-    (/) = binop fdiv-    fromRational = return . valueOf . fromRational--instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where-    properFraction _ = error "CodeGenFunction Value: properFraction"--instance (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where-    pi = return $ valueOf pi-    sqrt = callIntrinsic1 "sqrt"-    sin = callIntrinsic1 "sin"-    cos = callIntrinsic1 "cos"-    (**) = callIntrinsic2 "pow"-    exp = callIntrinsic1 "exp"-    log = callIntrinsic1 "log"--    asin _ = error "LLVM missing intrinsic: asin"-    acos _ = error "LLVM missing intrinsic: acos"-    atan _ = error "LLVM missing intrinsic: atan"--    sinh x           = (exp x - exp (-x)) / 2-    cosh x           = (exp x + exp (-x)) / 2-    asinh x          = log (x + sqrt (x*x + 1))-    acosh x          = log (x + sqrt (x*x - 1))-    atanh x          = (log (1 + x) - log (1 - x)) / 2--instance (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where-    floatRadix _ = floatRadix (undefined :: a)-    floatDigits _ = floatDigits (undefined :: a)-    floatRange _ = floatRange (undefined :: a)-    decodeFloat _ = error "CodeGenFunction Value: decodeFloat"-    encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat"-    exponent _ = 0-    scaleFloat 0 x = x-    scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat"-    isNaN _ = error "CodeGenFunction Value: isNaN"-    isInfinite _ = error "CodeGenFunction Value: isInfinite"-    isDenormalized _ = error "CodeGenFunction Value: isDenormalized"-    isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero"-    isIEEE _ = isIEEE (undefined :: a)--binop :: (Value a -> Value b -> TValue r c) ->-         TValue r a -> TValue r b -> TValue r c-binop op x y = do-    x' <- x-    y' <- y-    op x' y'--{--If we add the ReadNone attribute, then LLVM-2.8 complains:--llvm/examples$ Arith_dyn.exe-Attribute readnone only applies to the function!-  %2 = call readnone double @llvm.sin.f64(double %0)-Attribute readnone only applies to the function!-  %3 = call readnone double @llvm.exp.f64(double %2)-Broken module found, compilation aborted!-Stack dump:-0.      Running pass 'Function Pass Manager' on module '_module'.-1.      Running pass 'Module Verifier' on function '@_fun1'-Aborted--}-addReadNone :: Value a -> CodeGenFunction r (Value a)-addReadNone x = do---   addAttributes x 0 [ReadNoneAttribute]-   return x--callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) =>-                   String -> Value a -> TValue r b-callIntrinsicP1 fn x = do-    op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a))-{--You can add these attributes,-but the verifier pass in the optimizer checks whether they match-the attributes that are declared for that intrinsic.-If we omit adding attributes then the right attributes are added automatically.-    addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute]--}-    runCall (callFromFunction op `applyCall` x) >>= addReadNone--callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) =>-                   String -> Value a -> Value b -> TValue r c-callIntrinsicP2 fn x y = do-    op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a))-    runCall (callFromFunction op `applyCall` x `applyCall` y) >>= addReadNone--{-----------------------------------------------class ArithFunction a b | a -> b, b -> a where-    arithFunction' :: a -> b--instance (Ret a r) => ArithFunction (CodeGenFunction r a) (CodeGenFunction r ()) where-    arithFunction' x = x >>= ret--instance (ArithFunction b b') => ArithFunction (CodeGenFunction r a -> b) (a -> b') where-    arithFunction' f = arithFunction' . f . return---- |Unlift a function with @TValue@ to have @Value@ arguments.-arithFunction :: ArithFunction a b => a -> b-arithFunction = arithFunction'-----------------------------------------------class UncurryN a b | a -> b, b -> a where-    uncurryN :: a -> b-    curryN :: b -> a--instance UncurryN (CodeGenFunction r a) (() -> CodeGenFunction r a) where-    uncurryN i = \ () -> i-    curryN f = f ()--instance (UncurryN t (b -> c)) => UncurryN (a -> t) ((a, b) -> c) where-    uncurryN f = \ (a, b) -> uncurryN (f a) b-    curryN f = \ a -> curryN (\ b -> f (a, b))--class LiftTuple r a b | a -> b, b -> a where-    liftTuple :: a -> CodeGenFunction r b--instance LiftTuple r () () where-    liftTuple = return--instance (LiftTuple r b b') => LiftTuple r (CodeGenFunction r a, b) (a, b') where-    liftTuple (a, b) = liftM2 (,) a (liftTuple b)--class (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) =>-      UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b1 -> a2 where-    unwrapArgs :: a2 -> a-instance (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) =>-         UnwrapArgs a a1 b1 b a2 r where-    unwrapArgs f = curryN $ \ x -> uncurryN f =<< liftTuple x---- |Lift a function from having @Value@ arguments to having @TValue@ arguments.-toArithFunction :: (CallArgs f g r, UnwrapArgs a a1 b1 b g r) =>-                    Function f -> a-toArithFunction f = unwrapArgs (call f)------------------------------------------------- |Define a recursive 'arithFunction', gets passed itself as the first argument.-recursiveFunction ::-        (CallArgs a g r0,-         UnwrapArgs a11 a1 b1 b g r0,-         FunctionArgs a, a2 ~ FunctionCodeGen a, r1 ~ FunctionResult a,-         ArithFunction a3 a2,-         IsFunction a) =>-        (a11 -> a3) -> CodeGenModule (Function a)-recursiveFunction af = do-    f <- newFunction ExternalLinkage-    let f' = toArithFunction f-    defineFunction f $ arithFunction (af f')-    return f--}-----------------------------------------------class CallIntrinsic a where-    callIntrinsic1' :: String -> Value a -> TValue r a-    callIntrinsic2' :: String -> Value a -> Value a -> TValue r a--instance CallIntrinsic Float where-    callIntrinsic1' = callIntrinsicP1-    callIntrinsic2' = callIntrinsicP2--instance CallIntrinsic Double where-    callIntrinsic1' = callIntrinsicP1-    callIntrinsic2' = callIntrinsicP2--{--I think such a special case for certain systems-would be better handled as in LLVM.Extra.Extension.-(lemming)--}-macOS :: Bool-#if defined(__MACOS__)-macOS = True-#else-macOS = False-#endif--instance (PositiveT n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where-    callIntrinsic1' s x =-       if macOS && TypeNum.fromIntegerT (undefined :: n) == (4::Int) &&-          elem s ["sqrt", "log", "exp", "sin", "cos", "tan"]-         then do-            op <- externFunction ("v" ++ s ++ "f")-            call op x >>= addReadNone-         else mapVector (callIntrinsic1' s) x-    callIntrinsic2' s = mapVector2 (callIntrinsic2' s)--callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a-callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x'--callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a-callIntrinsic2 s = binop (callIntrinsic2' s)
− LLVM/Util/File.hs 
@@ -1,47 +0,0 @@-module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where-import System.Process (system)--import LLVM.Core-import LLVM.ExecutionEngine--writeCodeGenModule :: FilePath -> CodeGenModule a -> IO ()-writeCodeGenModule name f = do-    m <- newModule-    _ <- defineModule m f-    writeBitcodeToFile name m--optimize :: FilePath -> IO ()-optimize name = do-    _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name-    return ()--optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t)-optimizeFunction = fmap snd . optimizeFunction'--optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t)-optimizeFunction' mdl = do-    m <- newModule-    mf <- defineModule m mdl-    fName <- getValueName mf--    let name = "__tmp__" ++ fName ++ ".bc"-    writeBitcodeToFile name m--    optimize name--    m' <- readBitcodeFromFile name-    funcs <- getModuleValues m'----    removeFile name--    let Just mf' = castModuleValue =<< lookup fName funcs--    return (m', mf')--optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t-optimizeFunctionCG mdl = do-    (m', mf') <- optimizeFunction' mdl-    rf <- runEngineAccess $ do-        addModule m'-        generateFunction mf'-    return rf
− LLVM/Util/Foreign.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- These are replacements for the broken equivalents in Foreign.*.--- The functions in Foreign.* do not obey the required alignment.-module LLVM.Util.Foreign where--import Foreign.Ptr(alignPtr, Ptr)-import Foreign.Storable(Storable(poke, sizeOf, alignment))-import Foreign.Marshal.Alloc(allocaBytes)-import Foreign.Marshal.Array(allocaArray, pokeArray)--with :: Storable a => a -> (Ptr a -> IO b) -> IO b-with x act =-    alloca $ \ p -> do-    poke p x-    act p--alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b-alloca act =-    allocaBytes (2 * sizeOf (undefined :: a)) $ \ p ->-       act $ alignPtr p (alignment (undefined :: a))--withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b-withArrayLen xs act =-    let l = length xs in-    allocaArray (l+1) $ \ p -> do-    let p' = alignPtr p (alignment (head xs))-    pokeArray p' xs-    act l p'-
− LLVM/Util/Loop.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where-import Types.Data.Num-import LLVM.Core--class Phi a where-    phis :: BasicBlock -> a -> CodeGenFunction r a-    addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()--{--infixr 1 :*--- XXX should use HList if it was packaged in a nice way.-data a :* b = a :* b-    deriving (Eq, Ord, Show, Read)--instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where-    phis bb (a :* b) = do-        a' <- phi [(a, bb)]-        b' <- phis bb b-        return (a' :* b')-    addPhis bb (a :* b) (a' :* b') = do-        addPhiInputs a [(a', bb)]-        addPhis bb b b'--}--instance Phi () where-    phis _ _ = return ()-    addPhis _ _ _ = return ()--instance (IsFirstClass a) => Phi (Value a) where-    phis bb a = do-        a' <- phi [(a, bb)]-        return a'-    addPhis bb a a' = do-        addPhiInputs a [(a', bb)]--instance (Phi a, Phi b) => Phi (a, b) where-    phis bb (a, b) = do-        a' <- phis bb a-        b' <- phis bb b-        return (a', b')-    addPhis bb (a, b) (a', b') = do-        addPhis bb a a'-        addPhis bb b b'--instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where-    phis bb (a, b, c) = do-        a' <- phis bb a-        b' <- phis bb b-        c' <- phis bb c-        return (a', b', c')-    addPhis bb (a, b, c) (a', b', c') = do-        addPhis bb a a'-        addPhis bb b b'-        addPhis bb c c'---- Loop the index variable from low to high.  The state in the loop starts as start, and is modified--- by incr in each iteration.-forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>-           Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a-forLoop low high start incr = do-    top <- getCurrentBasicBlock-    loop <- newBasicBlock-    body <- newBasicBlock-    exit <- newBasicBlock--    br loop--    defineBasicBlock loop-    i <- phi [(low, top)]-    vars <- phis top start-    t <- cmp CmpNE i high-    condBr t body exit--    defineBasicBlock body--    vars' <- incr i vars-    i' <- add i (valueOf 1 :: Value i)--    body' <- getCurrentBasicBlock-    addPhis body' vars vars'-    addPhiInputs i [(i', body')]-    br loop-    defineBasicBlock exit--    return vars------------------------------------------mapVector :: forall a b n r .-             (PositiveT n, IsPrimitive b) =>-             (Value a -> CodeGenFunction r (Value b)) ->-             Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))-mapVector f v =-    forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do-        x <- extractelement v i-        y <- f x-        insertelement w y i--mapVector2 :: forall a b c n r .-             (PositiveT n, IsPrimitive c) =>-             (Value a -> Value b -> CodeGenFunction r (Value c)) ->-             Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c))-mapVector2 f v1 v2 =-    forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do-        x <- extractelement v1 i-        y <- extractelement v2 i-        z <- f x y-        insertelement w z i
− LLVM/Util/Memory.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module LLVM.Util.Memory (-    memcpy,-    memmove,-    memset,-    IsLengthType,-    ) where--import LLVM.Core--import Data.Word (Word8, Word32, Word64, )---class IsFirstClass len => IsLengthType len where--instance IsLengthType Word32 where-instance IsLengthType Word64 where---memcpyFunc ::-   forall len.-   IsLengthType len =>-   TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())-memcpyFunc =-   newNamedFunction ExternalLinkage $-      "llvm.memcpy.p0i8.p0i8." ++ intrinsicTypeName (undefined :: len)--memcpy ::-   IsLengthType len =>-   CodeGenModule-      (Value (Ptr Word8) ->-       Value (Ptr Word8) ->-       Value len ->-       Value Word32 ->-       Value Bool ->-       CodeGenFunction r ())-memcpy =-   fmap-      (\f dest src len align volatile ->-          fmap (const()) $ call f dest src len align volatile)-      memcpyFunc---memmoveFunc ::-   forall len.-   IsLengthType len =>-   TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())-memmoveFunc =-   newNamedFunction ExternalLinkage $-      "llvm.memmove.p0i8.p0i8." ++ intrinsicTypeName (undefined :: len)--memmove ::-   IsLengthType len =>-   CodeGenModule-      (Value (Ptr Word8) ->-       Value (Ptr Word8) ->-       Value len ->-       Value Word32 ->-       Value Bool ->-       CodeGenFunction r ())-memmove =-   fmap-      (\f dest src len align volatile ->-          fmap (const()) $ call f dest src len align volatile)-      memmoveFunc---memsetFunc ::-   forall len.-   IsLengthType len =>-   TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ())-memsetFunc =-   newNamedFunction ExternalLinkage $-      "llvm.memset.p0i8." ++ intrinsicTypeName (undefined :: len)--memset ::-   IsLengthType len =>-   CodeGenModule-      (Value (Ptr Word8) ->-       Value Word8 ->-       Value len ->-       Value Word32 ->-       Value Bool ->-       CodeGenFunction r ())-memset =-   fmap-      (\f dest val len align volatile ->-          fmap (const()) $ call f dest val len align volatile)-      memsetFunc
− LLVM/Util/Optimize.hs 
@@ -1,130 +0,0 @@-{--LLVM does not export its functions-@createStandardFunctionPasses@ and-@createStandardModulePasses@ via its C interface-and interfacing to C-C++ wrappers is not very portable.-Thus we reimplement these functions-from @opt.cpp@ and @StandardPasses.h@ in Haskell.-However this way we risk inconsistencies-between 'optimizeModule' and the @opt@ shell command.--}-module LLVM.Util.Optimize(optimizeModule) where--import LLVM.Core.Util(Module, withModule)-import qualified LLVM.FFI.Core as FFI-import qualified LLVM.FFI.Support as FFI-import LLVM.FFI.Transforms.Scalar-import Control.Exception (bracket)---{- |-Result tells whether the module was modified by any of the passes.--}-optimizeModule :: Int -> Module -> IO Bool-optimizeModule optLevel mdl =-    withModule mdl $ \ m ->-    {--    Core.Util.createPassManager would provide a finalizer for us,-    but I think it is better here to immediately dispose the manager-    when we need it no longer.-    -}-    bracket FFI.createPassManager FFI.disposePassManager $ \ passes ->--{--Note on LLVM-2.6 to 2.8 (at least):-As far as I understand, if we do not set target data,-then the optimizer will only perform machine independent optimizations.-If we set target data-(e.g. an empty layout string obtained from a module without 'target data' specification.)-we risk that the optimizer switches to a wrong layout-(e.g. to 64 bit pointers on a 32 bit machine for empty layout string)-and thus generates corrupt code.--Currently it seems to be safer to disable-machine dependent optimization completely.--http://llvm.org/bugs/show_bug.cgi?id=6394--    -- Pass the module target data to the pass manager.-    target <- FFI.getDataLayout m >>= createTargetData-    addTargetData target passes--}--    {--    opt.cpp does not use a FunctionPassManager for function optimization,-    but a module PassManager.-    Thus we do it the same way.-    I assume that we would need a FunctionPassManager-    only if we wanted to apply individual optimizations to functions.--    fPasses <- FFI.createFunctionPassManager mp-    -}-    bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do-    -- add module target data?--    -- tools/opt/opt.cpp: AddStandardCompilePasses-    addVerifierPass passes-    addOptimizationPasses passes fPasses optLevel--    {- if we wanted to do so, we could loop through all functions and optimize them.-    initializeFunctionPassManager fPasses-    runFunctionPassManager fPasses fcn-    -}--    functionsModified <- FFI.runPassManager fPasses m--    moduleModified <- FFI.runPassManager passes m--    return $-       toEnum (fromIntegral moduleModified) ||-       toEnum (fromIntegral functionsModified)---- tools/opt/opt.cpp: AddOptimizationPasses-addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO ()-addOptimizationPasses passes fPasses optLevel = do-  createStandardFunctionPasses fPasses optLevel-  createStandardModulePasses passes optLevel True True (optLevel > 1) True True True--createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO ()-createStandardFunctionPasses fPasses optLevel =-    FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel)---- llvm/Support/StandardPasses.h: createStandardModulePasses-createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO ()-createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass =-  FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize)-     (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions)-     (f (not inliningPass))-  where f True = 1-        f _    = 0---{--ToDo:-Function that adds passes according to a list of opt-options.-This would simplify to get consistent behaviour between opt and optimizeModule.---adce                      addAggressiveDCEPass--deadargelim               addDeadArgEliminationPass--deadtypeelim              addDeadTypeEliminationPass--dse                       addDeadStoreEliminationPass--functionattrs             addFunctionAttrsPass--globalopt                 addGlobalOptimizerPass--indvars                   addIndVarSimplifyPass--instcombine               addInstructionCombiningPass--ipsccp                    addIPSCCPPass--jump-threading            addJumpThreadingPass--licm                      addLICMPass--loop-deletion             addLoopDeletionPass--loop-rotate               addLoopRotatePass--memcpyopt                 addMemCpyOptPass--prune-eh                  addPruneEHPass--reassociate               addReassociatePass--scalarrepl                addScalarReplAggregatesPass--sccp                      addSCCPPass--simplifycfg               addCFGSimplificationPass--simplify-libcalls         addSimplifyLibCallsPass--strip-dead-prototypes     addStripDeadPrototypesPass--tailcallelim              addTailCallEliminationPass--verify                    addVerifierPass--}
+ example/Align.hs view
@@ -0,0 +1,24 @@+module Main (main) where++import LLVM.ExecutionEngine+import LLVM.Core++import Types.Data.Num (D1, D4)++import Data.Word (Word32, Word64)+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    td <- getTargetData+    print (littleEndian td,+           aBIAlignmentOfType td $ typeRef (undefined :: Word32),+           aBIAlignmentOfType td $ typeRef (undefined :: Word64),+	   aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float),+	   aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double),+	   storeSizeOfType td $ typeRef (undefined :: Vector D4 Float),+           intPtrType td+	   )
+ example/Arith.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++import qualified LLVM.Util.Arithmetic as A+import qualified LLVM.Util.Foreign as F+import LLVM.Util.Arithmetic (CallIntrinsic, arithFunction, (%<), (?))+import LLVM.Util.File (writeCodeGenModule)++import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO)+import LLVM.Core++import Types.Data.Num (D4)++import Data.Int (Int32)++import Foreign.Storable (peek)+{-+import Foreign.Ptr+import Foreign.Marshal.Utils+import Foreign.Marshal.Alloc as F+-}++mSomeFn :: forall a.+    (IsConst a, Floating a, IsFloating a, CallIntrinsic a, CmpRet a) =>+    CodeGenModule (Function (a -> IO a))+mSomeFn = do+    foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y+    let foo' = A.toArithFunction foo+    createFunction ExternalLinkage $ arithFunction $ \ x -> do+        y <- A.set $ x^3+        sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y++mFib :: CodeGenModule (Function (Int32 -> IO Int32))+mFib = A.recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2))++type V = Vector D4 Float++mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+mVFun = do+    fn :: Function (V -> IO V)+       <- createFunction ExternalLinkage $ arithFunction $ \ x ->+            log x * exp x * x - 16++    vectorToPtr fn+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    let mSomeFn' = mSomeFn+    ioSomeFn <- simpleFunction mSomeFn'+    let someFn :: Double -> Double+        someFn = unsafeRemoveIO ioSomeFn++    writeCodeGenModule "Arith.bc" mSomeFn'++    print (someFn 10)+    print (someFn 2)++    writeCodeGenModule "ArithFib.bc" mFib++    fib <- simpleFunction mFib+    fib 22 >>= print++    writeCodeGenModule "VArith.bc" mVFun++    ioVFun <- simpleFunction mVFun+    let v = toVector (1,2,3,4)++    r <- vectorPtrWrap ioVFun v+    print r+++vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))+vectorToPtr f =+    createFunction ExternalLinkage $ \ px py -> do+        x <- load px+        y <- call f x+        store y py+	ret ()++vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V+vectorPtrWrap f v =+    F.with v $ \ aPtr ->+        F.alloca $ \ bPtr -> do+             f aPtr bPtr+             peek bPtr
+ example/Array.hs view
@@ -0,0 +1,63 @@+module Main (main) where++import LLVM.Util.Loop (forLoop)+import LLVM.Util.Optimize (optimizeModule)+import LLVM.Core++import Data.Word (Word32)+++cg :: CodeGenModule (Function (Double -> IO (Ptr Double)))+cg = do+    dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do+        r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do+	    ai <- mul aStride i+	    bi <- mul bStride i+            ap <- getElementPtr aPtr (ai, ())+            bp <- getElementPtr bPtr (bi, ())+            a <- load ap+            b <- load bp+            ab <- mul a b+            add (s :: Value Double) ab+	ret r+    let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double)++    -- multiply a:[n x m], b:[m x l]+    matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do+        forLoop (valueOf 0) n () $ \ ni () -> do+           forLoop (valueOf 0) l () $ \ li () -> do+	      ni' <- mul ni m+	      row <- getElementPtr aPtr (ni', ())+	      col <- getElementPtr bPtr (li, ())+              x <- call dotProd m row (valueOf 1) col m+	      j <- add ni' li+	      p <- getElementPtr cPtr (j, ())+	      store x p+	      return ()+        ret ()+    let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ())++    let fillArray _ [] = return ()+        fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs++    test <- createNamedFunction ExternalLinkage "test" $ \ x -> do+        a <- arrayMalloc (4 :: Word32)+	fillArray a $ map valueOf [1,2,3,4]+	b <- arrayMalloc (4 :: Word32)+	fillArray b [x,x,x,x]+	c <- arrayMalloc (4 :: Word32)+	_ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c+	ret c+    let _ = test :: Function (Double -> IO (Ptr Double))++    return test++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    m <- newModule+    _f <- defineModule m cg+    writeBitcodeToFile "Arr.bc" m+    _ <- optimizeModule 3 m+    writeBitcodeToFile "Arr-opt.bc" m
+ example/BrainF.hs view
@@ -0,0 +1,160 @@+module Main (main) where+-- BrainF compiler example+--+-- The BrainF language has 8 commands:+-- Command   Equivalent C    Action+-- -------   ------------    ------+-- ,         *h=getchar();   Read a character from stdin, 255 on EOF+-- .         putchar(*h);    Write a character to stdout+-- -         --*h;           Decrement tape+-- +         ++*h;           Increment tape+-- <         --h;            Move head left+-- >         ++h;            Move head right+-- [         while(*h) {     Start loop+-- ]         }               End loop+--++import qualified LLVM.Util.Memory as Memory+import LLVM.ExecutionEngine (simpleFunction)+import LLVM.Util.File (writeCodeGenModule)+import LLVM.Core++import qualified System.IO as IO+import System.Environment (getArgs)+import System.Exit (exitFailure)++import Control.Monad (when)+import Data.Word (Word8, Word32)+import Data.Int (Int32)+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget++    aargs <- getArgs+    let (args, debug) =+           case aargs of+              "-":rargs -> (rargs, True)+              _ -> (aargs, False)+    let text = "+++++++++++++++++++++++++++++++++" ++  -- constant 33+               ">++++" ++                              -- next cell, loop counter, constant 4+               "[>++++++++++" ++                       -- loop, loop counter, constant 10+                 "[" ++                                -- loop+                   "<<.+>>-" ++                        -- back to 33, print, increment, forward, decrement loop counter+                 "]<-" ++                              -- back to 4, decrement loop counter+               "]" +++               "++++++++++."+    prog <-+       case args of+          [] -> return text+          fileName:[] -> readFile fileName+          _ ->+             IO.hPutStrLn IO.stderr "too many arguments" >>+             exitFailure++    when debug $+       writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536++    bfprog <- simpleFunction $ brainCompile debug prog 65536+    when (prog == text) $+        putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:"+    bfprog++brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ()))+brainCompile _debug instrs wmemtotal = do+    -- LLVM functions+    memset    <- Memory.memset+    getchar   <- newNamedFunction ExternalLinkage "getchar"+              :: TFunction (IO Int32)+    putchar   <- newNamedFunction ExternalLinkage "putchar"+              :: TFunction (Int32 -> IO Int32)++    -- Generate code, first argument is the list of commands,+    -- second argument is a stack of loop contexts, and the+    -- third argument is the current register for the head and+    -- the current basic block.+    -- A loop context is a triple of the phi node, the loop top label,+    -- and the loop exit label.+    let generate [] [] _ =+            return ()+        generate [] (_:_) _ = error "Missing ]"+        generate (']':_) [] _ = error "Missing ["+        generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do+            -- The loop has terminated, add the phi node at the top,+            -- branch to the top, and set up the exit label.+            addPhiInputs cphi [(cur, bb)]+            br loop+            defineBasicBlock exit+            generate is bs (cphi, exit)++        generate ('[':is) bs curbb = do+            -- Start a new loop.+            loop <- newBasicBlock    -- loop top+            body <- newBasicBlock    -- body of the loop+            exit <- newBasicBlock    -- loop exit label+            br loop++            defineBasicBlock loop+            cur <- phi [curbb]       -- will get one more input from the loop terminator.+            val <- load cur          -- load head byte.+            eqz <- cmp CmpEQ val (valueOf (0::Word8)) -- test if it is 0.+            condBr eqz exit body     -- and branch accordingly.++            defineBasicBlock body+            generate is ((cur, loop, exit) : bs) (cur, body)++        generate (i:is) bs (curhead, bb) = do+            -- A simple command, with no new basic blocks.+            -- Just update which register the head is in.+            curhead' <- gen curhead i+            generate is bs (curhead', bb)++        gen cur ',' = do+            -- Read a character.+            char32 <- call getchar+            char8  <- trunc char32+            store char8 cur+            return cur+        gen cur '.' = do+            -- Write a character.+            char8 <- load cur+            char32 <- zext char8+            _ <- call putchar char32+            return cur+        gen cur '-' = do+            -- Decrement byte at head.+            val <- load cur+            val' <- sub val (valueOf (1 :: Word8))+            store val' cur+            return cur+        gen cur '+' = do+            -- Increment byte at head.+            val <- load cur+            val' <- add val (valueOf (1 :: Word8))+            store val' cur+            return cur+        gen cur '<' =+            -- Decrement head.+            getElementPtr cur ((-1) :: Word32, ())+        gen cur '>' =+            -- Increment head.+            getElementPtr cur (1 :: Word32, ())+        gen _ c = error $ "Bad character in program: " ++ show c+++    brainf <- createFunction ExternalLinkage $ do+        ptr_arr <- arrayMalloc wmemtotal+        _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False)+--        _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ())+        -- Start head in the middle.+        curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ())++        bb <- getCurrentBasicBlock+        generate instrs [] (curhead, bb)++        free ptr_arr+        ret ()++    return brainf
+ example/CallConv.hs view
@@ -0,0 +1,33 @@+module Main (main) where++import LLVM.Core+import LLVM.FFI.Core (CallingConvention(GHC))++import Data.Word (Word32)+++-- Our module will have these two functions.+data Mod = Mod {+    m1 :: Function (Word32 -> IO Word32),+    m2 :: Function (Word32 -> Word32 -> IO Word32)+    }++main :: IO ()+main = do+    m <- newModule+    _fns <- defineModule m buildMod+    --_ <- optimizeModule 3 m+    writeBitcodeToFile "CallConv.bc" m+    return ()++buildMod :: CodeGenModule Mod+buildMod = do+    mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do+      r <- add x y+      ret r+    setFuncCallConv mod2 GHC+    mod1 <- newNamedFunction ExternalLinkage "test"+    defineFunction mod1 $ \ arg -> do+      r <- callWithConv GHC mod2 arg (valueOf 1)+      ret r+    return $ Mod {m1 = mod1, m2 = mod2}
+ example/Convert.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleInstances #-}+module Convert(Convert(..)) where++import Foreign.Ptr (FunPtr)+import Data.Int (Int32)+import Data.Word (Word32)++type Importer f = FunPtr f -> f++class Convert f where+    convert :: Importer f++foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float)+instance Convert (IO Float) where convert = c_IOFloat++foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float)+instance Convert (Float -> IO Float) where convert = c_Float_IOFloat++foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float)+instance Convert (Float -> Float) where convert = c_Float_Float+ +foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double)+instance Convert (IO Double) where convert = c_IODouble++foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double)+instance Convert (Double -> IO Double) where convert = c_Double_IODouble++foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double)+instance Convert (Double -> Double) where convert = c_Double_Double+ +foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32)+instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32++foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32)+instance Convert (Word32 -> Word32) where convert = c_Word32_Word32++foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32)+instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32++foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32)+instance Convert (Int32 -> Int32) where convert = c_Int32_Int32+
+ example/DotProd.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Main (main) where++import LLVM.ExecutionEngine (simpleFunction, unsafeRemoveIO)+import LLVM.Core++import LLVM.Util.Loop (forLoop)+import LLVM.Util.File (writeCodeGenModule)+import LLVM.Util.Foreign (withArrayLen)++import Types.Data.Num(D2, D4, D8, fromIntegerT)++import Data.Word (Word32)+++mDotProd :: forall n a .+   (PositiveT n,+    IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a) =>+   CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a))+mDotProd =+  createFunction ExternalLinkage $ \ size aPtr bPtr -> do+    s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do++        ap <- getElementPtr aPtr (i, ()) -- index into aPtr+        bp <- getElementPtr bPtr (i, ()) -- index into bPtr+        a <- load ap                     -- load element from a vector+        b <- load bp                     -- load element from b vector+        ab <- mul a b                    -- multiply them+        add s ab                         -- accumulate sum++    r <- forLoop (valueOf (0::Word32)) (valueOf (fromIntegerT (undefined :: n)))+              (valueOf 0) $ \ i r -> do+              ri <- extractelement s i+              add r ri+    ret (r :: Value a)++type R = Float+type T = Vector D4 R++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    let mDotProd' = mDotProd+    writeCodeGenModule "DotProd.bc" mDotProd'++    ioDotProd <- simpleFunction mDotProd'+    let dotProd :: [T] -> [T] -> R+        dotProd a b =+         unsafeRemoveIO $+         withArrayLen a $ \ aLen aPtr ->+         withArrayLen b $ \ bLen bPtr ->+         ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr+++    let a = [1 .. 8]+        b = [4 .. 11]+    print $ dotProd (vectorize 0 a) (vectorize 0 b)+    print $ sum $ zipWith (*) a b++class Vectorize n a where+    vectorize :: a -> [a] -> [Vector n a]++{-+instance (IsPrimitive a) => Vectorize D1 a where+    vectorize _ [] = []+    vectorize x (x1:xs) = toVector x1 : vectorize x xs+-}++instance (IsPrimitive a) => Vectorize D2 a where+    vectorize _ [] = []+    vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs+    vectorize x xs = vectorize x $ xs ++ [x]++instance (IsPrimitive a) => Vectorize D4 a where+    vectorize _ [] = []+    vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs+    vectorize x xs = vectorize x $ xs ++ [x]++instance (IsPrimitive a) => Vectorize D8 a where+    vectorize _ [] = []+    vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs+    vectorize x xs = vectorize x $ xs ++ [x]
+ example/Fibonacci.hs view
@@ -0,0 +1,109 @@+module Main (main) where++import qualified LLVM.ExecutionEngine as EE+import LLVM.Util.Optimize (optimizeModule)+import LLVM.Core++import System.Environment (getArgs)+import Control.Monad (forM_)+import Data.Word (Word32)++import Prelude hiding(and, or)+++-- Our module will have these two functions.+data Mod = Mod {+    mfib :: Function (Word32 -> IO Word32),+    _mplus :: Function (Word32 -> Word32 -> IO Word32)+    }++main :: IO ()+main = do+    args <- getArgs+    let args' = if null args then ["10"] else args++    -- Initialize jitter+    initializeNativeTarget+    -- Create a module,+    m <- newNamedModule "fib"+    -- and define its contents.+    fns <- defineModule m buildMod++    -- Show the code for the two functions, just for fun.+    --dumpValue $ mfib fns+    --dumpValue $ mplus fns+    -- Write the code to a file for later perusal.+    -- Can be disassembled with llvm-dis.+    writeBitcodeToFile "Fibonacci.bc" m++    _ <- optimizeModule 3 m+    writeBitcodeToFile "Fibonacci-opt.bc" m++    -- Generate code for mfib, and then throw away the IO in the type.+    -- The result is an ordinary Haskell function.+    iofib <- EE.runEngineAccess $ do+                 EE.addModule m+                 EE.generateFunction $ mfib fns+    let fib = EE.unsafeRemoveIO iofib++    -- Run fib for the arguments.+    forM_ args' $ \num -> do+        putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num))+    return ()++buildMod :: CodeGenModule Mod+buildMod = do+    -- Add two numbers in a cumbersome way.+    plus <- createFunction InternalLinkage $ \ x y -> do+        -- Create three additional basic blocks, need to be created before being referred to.+        l1 <- newBasicBlock+        l2 <- newBasicBlock+        l3 <- newBasicBlock++        -- Test if x is even/odd.+        a <- and x (valueOf (1 :: Word32))+        c <- cmp CmpEQ a (valueOf (0 :: Word32))+        condBr c l1 l2++        -- Do x+y if even.+        defineBasicBlock l1+        r1 <- add x y+        br l3++        -- Do y+x if odd.+        defineBasicBlock l2+        r2 <- add y x+        br l3++        defineBasicBlock l3+        -- Join the two execution paths with a phi instruction.+        r <- phi [(r1, l1), (r2, l2)]+        ret r++    -- The usual doubly recursive Fibonacci.+    -- Use new&define so the name fib is defined in the body for recursive calls.+    fib <- newNamedFunction ExternalLinkage "fib"+    defineFunction fib $ \ arg -> do+        -- Create the two basic blocks.+        recurse <- newBasicBlock+        exit <- newBasicBlock++        -- Test if arg > 2+        test <- cmp CmpGT arg (valueOf (2::Word32))+        condBr test recurse exit++        -- Just return 1 if not > 2+        defineBasicBlock exit+        ret (valueOf (1::Word32))++        -- Recurse if > 2, using the cumbersome plus to add the results.+        defineBasicBlock recurse+        x1 <- sub arg (valueOf (1::Word32))+        fibx1 <- call fib x1+        x2 <- sub arg (valueOf (2::Word32))+        fibx2 <- call fib x2+        r <- call plus fibx1 fibx2+        ret r++    -- Return the two functions.+    return $ Mod fib plus
+ example/HelloJIT.hs view
@@ -0,0 +1,25 @@+module Main (main) where++import LLVM.ExecutionEngine (simpleFunction)+import LLVM.Core++import Data.Word (Word8, Word32)+++bldGreet :: CodeGenModule (Function (IO ()))+bldGreet = withStringNul "Hello, JIT!" (\greetz -> do+    puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32)+    func <- createFunction ExternalLinkage $ do+      tmp <- getElementPtr0 greetz (0::Word32, ())+      _ <- call puts tmp :: CodeGenFunction r (Value Word32)+      ret ()+    return func)++main :: IO ()+main = do+    initializeNativeTarget+    greet <- simpleFunction bldGreet+    greet+    greet+    greet+    return ()
+ example/List.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module Main (main) where++import LLVM.Util.Loop (Phi, phis, addPhis, )+import LLVM.ExecutionEngine (simpleFunction, )+import LLVM.Core+import qualified System.IO as IO++import Data.Word (Word32, )+import Data.Int (Int32, )+import Foreign.Marshal.Array (allocaArray, )+import qualified Foreign.Storable as St++import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )+import Foreign.Ptr (FunPtr, )+import Data.IORef (IORef, newIORef, readIORef, writeIORef, )+++{-+I had to export Phi's methods in llvm-0.6.8+in order to be able to implement this function.+-}+arrayLoop ::+   (Phi a, IsType b,+    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>+   Value i -> Value (Ptr b) -> a ->+   (Value (Ptr b) -> a -> CodeGenFunction r a) ->+   CodeGenFunction r a+arrayLoop len ptr start loopBody = do+   top <- getCurrentBasicBlock+   loop <- newBasicBlock+   body <- newBasicBlock+   exit <- newBasicBlock++   br loop++   defineBasicBlock loop+   i <- phi [(len, top)]+   p <- phi [(ptr, top)]+   vars <- phis top start+   t <- cmp CmpNE i (valueOf 0 `asTypeOf` len)+   condBr t body exit++   defineBasicBlock body++   vars' <- loopBody p vars+   i' <- sub i (valueOf 1 `asTypeOf` len)+   p' <- getElementPtr p (valueOf 1 :: Value Word32, ())++   body' <- getCurrentBasicBlock+   addPhis body' vars vars'+   addPhiInputs i [(i', body')]+   addPhiInputs p [(p', body')]+   br loop++   defineBasicBlock exit+   return vars+++mList ::+   CodeGenModule (Function+      (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32))+mList =+   createFunction ExternalLinkage $ \ ref size ptr -> do+     next <- staticFunction nelem+     let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32)+     s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do+       flip store ptri =<< call next ref+       return y+     ret (s :: Value Int32)++renderList :: IO ()+renderList = do+   m <- newModule+   _f <- defineModule m mList+   writeBitcodeToFile "List.bc" m++   fill <- simpleFunction mList+   stable <- newStablePtr =<< newIORef [3,5..]+   IO.withFile "listcontent.u32" IO.WriteMode $ \h ->+     let len = 100+     in  allocaArray len $ \ ptr ->+           fill stable (fromIntegral len) ptr >>+           IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32))+   freeStablePtr stable+++foreign import ccall "&nextListElement"+   nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)++foreign export ccall+   nextListElement :: StablePtr (IORef [Word32]) -> IO Word32++nextListElement :: StablePtr (IORef [Word32]) -> IO Word32+nextListElement stable =+   do ioRef <- deRefStablePtr stable+      xt <- readIORef ioRef+      case xt of+         [] -> return 0+         (x:xs) -> writeIORef ioRef xs >> return x+++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    renderList
+ example/Struct.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++import LLVM.ExecutionEngine (simpleFunction)+import LLVM.Util.File (writeCodeGenModule)+import LLVM.Core++import Types.Data.Num (D10, d0, d1, d2)++import Data.Word (Word32)+++foreign import ccall structCheck :: Word32 -> Ptr S -> Int++-- Watch out for double!  Alignment differs between platforms.+-- struct S { uint32 x0; float x1; uint32 x2[10] };+type S = Struct (Word32 :& Float :& Array D10 Word32 :& ())++-- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s;+mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S)))+mStruct = do+    createFunction ExternalLinkage $ \ x -> do+      p  :: Value (Ptr S)+         <- malloc+      p0 <- getElementPtr0 p (d0 & ())+      store x (p0 :: Value (Ptr Word32))+      p1 <- getElementPtr0 p (d1 & ())+      store (valueOf 1.5) p1+      x' <- add x (valueOf (1 :: Word32))+      p2 <- getElementPtr0 p (d2 & (5::Word32) & ())+      store x' p2+      ret p++main :: IO ()+main = do+    initializeNativeTarget+    writeCodeGenModule "Struct.bc" mStruct+    struct <- simpleFunction mStruct+    let a = 10+    p <- struct a+    putStrLn $ if structCheck a p /= 0 then "OK" else "failed"+    return ()
+ example/Varargs.hs view
@@ -0,0 +1,38 @@+module Main (main) where++import LLVM.ExecutionEngine (simpleFunction)+import LLVM.Core++import Data.Word (Word8, Word32)+++bldVarargs :: CodeGenModule (Function (Word32 -> IO ()))+bldVarargs =+   withStringNul "Hello\n" (\fmt1 ->+   withStringNul "A number %d\n" (\fmt2 ->+   withStringNul "Two numbers %d %d\n" (\fmt3 -> do+      printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32)+      func <- createFunction ExternalLinkage $ \ x -> do++        tmp1 <- getElementPtr0 fmt1 (0::Word32, ())+        let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32)+        _ <- call p1 tmp1++        tmp2 <- getElementPtr0 fmt2 (0::Word32, ())+        let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32)+        _ <- call p2 tmp2 x++        tmp3 <- getElementPtr0 fmt3 (0::Word32, ())+        let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32)+        _ <- call p3 tmp3 x x++        ret ()+      return func+   )))++main :: IO ()+main = do+    initializeNativeTarget+    varargs <- simpleFunction bldVarargs+    varargs 42+    return ()
+ example/Vector.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TypeOperators #-}+module Main (main) where++import Convert++import LLVM.ExecutionEngine+          (runEngineAccess, addModule, generateFunction, getPointerToFunction)+import LLVM.Util.Optimize (optimizeModule, )+import LLVM.Util.Loop (forLoop, )+import LLVM.Core++import Types.Data.Num (D16, fromIntegerT, )++import Control.Monad (liftM2, )+import Data.Word (Word32, )++-- Type of vector elements.+type T = Float++-- Number of vector elements.+type N = D16++cgvec :: CodeGenModule (Function (T -> IO T))+cgvec = do+    -- A global variable that vectest messes with.+    acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T))++    -- Return the global variable.+    retAcc <- createNamedFunction ExternalLinkage "retacc" $ do+        vacc <- load acc+        ret vacc+    let _ = retAcc :: Function (IO T)  -- Force the type of retAcc.++    -- A function that tests vector opreations.+    f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do++        let v = value (zero :: ConstValue (Vector N T))+	    n = fromIntegerT (undefined :: N) :: Word32++        -- Fill the vector with x, x+1, x+2, ...+        (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do+            x1' <- add x1 (valueOf (1::T))+	    v1' <- insertelement v1 x1 i+	    return (x1', v1')++	-- Elementwise cubing of the vector.+	vsq <- mul v1 v1+        vcb <- mul vsq v1++        -- Sum the elements of the vector.+        s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do+            y <- extractelement vcb i+     	    s' <- add s (y :: Value T)+	    return s'++        -- Update the global variable.+        vacc <- load acc+        vacc' <- add vacc s+        store vacc' acc++        ret (s :: Value T)++--    liftIO $ dumpValue f+    return f++main :: IO ()+main = do+    -- Initialize jitter+    initializeNativeTarget+    -- First run standard code.+    m <- newModule+    iovec <- defineModule m cgvec++    fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec+    let fvec = convert fptr++    fvec 10 >>= print++    vec <- runEngineAccess $ do addModule m; generateFunction iovec++    vec 10 >>= print++    -- And then optimize and run.+    _ <- optimizeModule 1 m++    funcs <- getModuleValues m+    print $ map fst funcs++    let iovec' :: Function (T -> IO T)+        Just iovec' = castModuleValue =<< lookup "vectest" funcs+	ioretacc' :: Function (IO T)+        Just ioretacc' = castModuleValue =<< lookup "retacc" funcs++    (vec', retacc') <- runEngineAccess $ do+        addModule m+        liftM2 (,) (generateFunction iovec') (generateFunction ioretacc')++    dumpValue iovec'++    vec' 10 >>= print+    vec' 0 >>= print+    retacc' >>= print
+ example/structCheck.c view
@@ -0,0 +1,9 @@+#include <stdint.h>++struct S { uint32_t x0; float x1; uint32_t x2[10]; };++int+structCheck(uint32_t a, struct S *s)+{+  return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1;+}
− examples/Align.hs 
@@ -1,21 +0,0 @@-module Align (main) where-import Types.Data.Num(D1, D4)-import Data.Word--import LLVM.Core-import LLVM.ExecutionEngine--main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget--    td <- getTargetData-    print (littleEndian td,-           aBIAlignmentOfType td $ typeRef (undefined :: Word32),-           aBIAlignmentOfType td $ typeRef (undefined :: Word64),-	   aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float),-	   aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double),-	   storeSizeOfType td $ typeRef (undefined :: Vector D4 Float),-           intPtrType td-	   )
− examples/Arith.hs 
@@ -1,86 +0,0 @@-{-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Arith where-import Data.Int-import Types.Data.Num(D4)-import LLVM.Core-import LLVM.ExecutionEngine-import LLVM.Util.Arithmetic-import LLVM.Util.Foreign as F-import LLVM.Util.File(writeCodeGenModule)--import Foreign.Storable-{--import Foreign.Ptr-import Foreign.Marshal.Utils-import Foreign.Marshal.Alloc as F--}--mSomeFn :: forall a . (IsConst a, Floating a, IsFloating a, CallIntrinsic a,-	                 FunctionRet a, CmpRet a-                        ) => CodeGenModule (Function (a -> IO a))-mSomeFn = do-    foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y-    let foo' = toArithFunction foo-    createFunction ExternalLinkage $ arithFunction $ \ x -> do-        y <- set $ x^3-        sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y--mFib :: CodeGenModule (Function (Int32 -> IO Int32))-mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2))--type V = Vector D4 Float--mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))-mVFun = do-    fn :: Function (V -> IO V)-       <- createFunction ExternalLinkage $ arithFunction $ \ x ->-            log x * exp x * x - 16--    vectorToPtr fn---main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget--    let mSomeFn' = mSomeFn-    ioSomeFn <- simpleFunction mSomeFn'-    let someFn :: Double -> Double-        someFn = unsafeRemoveIO ioSomeFn--    writeCodeGenModule "Arith.bc" mSomeFn'--    print (someFn 10)-    print (someFn 2)--    writeCodeGenModule "ArithFib.bc" mFib--    fib <- simpleFunction mFib-    fib 22 >>= print--{--    writeCodeGenModule "VArith.bc" mVFun--    ioVFun <- simpleFunction mVFun-    let v = toVector (1,2,3,4)--    r <- vectorPtrWrap ioVFun v-    print r--}--vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ()))-vectorToPtr f =-    createFunction ExternalLinkage $ \ px py -> do-        x <- load px-        y <- call f x-        store y py-	ret ()--vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V-vectorPtrWrap f v =-    with v $ \ aPtr ->-        F.alloca $ \ bPtr -> do-             f aPtr bPtr-             peek bPtr
− examples/Array.hs 
@@ -1,62 +0,0 @@-module Array where-import Data.Word--import LLVM.Core---import LLVM.ExecutionEngine-import LLVM.Util.Loop-import LLVM.Util.Optimize--cg :: CodeGenModule (Function (Double -> IO (Ptr Double)))-cg = do-    dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do-        r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do-	    ai <- mul aStride i-	    bi <- mul bStride i-            ap <- getElementPtr aPtr (ai, ())-            bp <- getElementPtr bPtr (bi, ())-            a <- load ap-            b <- load bp-            ab <- mul a b-            add (s :: Value Double) ab-	ret r-    let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double)--    -- multiply a:[n x m], b:[m x l]-    matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do-        forLoop (valueOf 0) n () $ \ ni () -> do-           forLoop (valueOf 0) l () $ \ li () -> do-	      ni' <- mul ni m-	      row <- getElementPtr aPtr (ni', ())-	      col <- getElementPtr bPtr (li, ())-              x <- call dotProd m row (valueOf 1) col m-	      j <- add ni' li-	      p <- getElementPtr cPtr (j, ())-	      store x p-	      return ()-        ret ()-    let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ())--    let fillArray _ [] = return ()-        fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs--    test <- createNamedFunction ExternalLinkage "test" $ \ x -> do-        a <- arrayMalloc (4 :: Word32)-	fillArray a $ map valueOf [1,2,3,4]-	b <- arrayMalloc (4 :: Word32)-	fillArray b [x,x,x,x]-	c <- arrayMalloc (4 :: Word32)-	_ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c-	ret c-    let _ = test :: Function (Double -> IO (Ptr Double))--    return test--main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget-    m <- newModule-    _f <- defineModule m cg-    writeBitcodeToFile "Arr.bc" m-    _ <- optimizeModule 3 m-    writeBitcodeToFile "Arr-opt.bc" m
− examples/BrainF.hs 
@@ -1,157 +0,0 @@-module BrainF where--- BrainF compiler example------ The BrainF language has 8 commands:--- Command   Equivalent C    Action--- -------   ------------    --------- ,         *h=getchar();   Read a character from stdin, 255 on EOF--- .         putchar(*h);    Write a character to stdout--- -         --*h;           Decrement tape--- +         ++*h;           Increment tape--- <         --h;            Move head left--- >         ++h;            Move head right--- [         while(*h) {     Start loop--- ]         }               End loop----import Control.Monad(when)-import Data.Word-import Data.Int-import System.Environment(getArgs)-import System.Exit(exitFailure)-import qualified System.IO as IO--import LLVM.Core-import LLVM.Util.File(writeCodeGenModule)-import qualified LLVM.Util.Memory as Memory-import LLVM.ExecutionEngine--main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget--    aargs <- getArgs-    let (args, debug) =-           case aargs of-              "-":rargs -> (rargs, True)-              _ -> (aargs, False)-    let text = "+++++++++++++++++++++++++++++++++" ++  -- constant 33-               ">++++" ++                              -- next cell, loop counter, constant 4-               "[>++++++++++" ++                       -- loop, loop counter, constant 10-                 "[" ++                                -- loop-                   "<<.+>>-" ++                        -- back to 33, print, increment, forward, decrement loop counter-                 "]<-" ++                              -- back to 4, decrement loop counter-               "]" ++-               "++++++++++."-    prog <--       case args of-          [] -> return text-          fileName:[] -> readFile fileName-          _ ->-             IO.hPutStrLn IO.stderr "too many arguments" >>-             exitFailure--    when debug $-       writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536--    bfprog <- simpleFunction $ brainCompile debug prog 65536-    when (prog == text) $-        putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:"-    bfprog--brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ()))-brainCompile _debug instrs wmemtotal = do-    -- LLVM functions-    memset    <- Memory.memset-    getchar   <- newNamedFunction ExternalLinkage "getchar"-              :: TFunction (IO Int32)-    putchar   <- newNamedFunction ExternalLinkage "putchar"-              :: TFunction (Int32 -> IO Int32)--    -- Generate code, first argument is the list of commands,-    -- second argument is a stack of loop contexts, and the-    -- third argument is the current register for the head and-    -- the current basic block.-    -- A loop context is a triple of the phi node, the loop top label,-    -- and the loop exit label.-    let generate [] [] _ =-            return ()-        generate [] (_:_) _ = error "Missing ]"-        generate (']':_) [] _ = error "Missing ["-        generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do-            -- The loop has terminated, add the phi node at the top,-            -- branch to the top, and set up the exit label.-            addPhiInputs cphi [(cur, bb)]-            br loop-            defineBasicBlock exit-            generate is bs (cphi, exit)--        generate ('[':is) bs curbb = do-            -- Start a new loop.-            loop <- newBasicBlock    -- loop top-            body <- newBasicBlock    -- body of the loop-            exit <- newBasicBlock    -- loop exit label-            br loop--            defineBasicBlock loop-            cur <- phi [curbb]       -- will get one more input from the loop terminator.-            val <- load cur          -- load head byte.-            eqz <- cmp CmpEQ val (0::Word8) -- test if it is 0.-            condBr eqz exit body     -- and branch accordingly.--            defineBasicBlock body-            generate is ((cur, loop, exit) : bs) (cur, body)--        generate (i:is) bs (curhead, bb) = do-            -- A simple command, with no new basic blocks.-            -- Just update which register the head is in.-            curhead' <- gen curhead i-            generate is bs (curhead', bb)--        gen cur ',' = do-            -- Read a character.-            char32 <- call getchar-            char8  <- trunc char32-            store char8 cur-            return cur-        gen cur '.' = do-            -- Write a character.-            char8 <- load cur-            char32 <- zext char8-            _ <- call putchar char32-            return cur-        gen cur '-' = do-            -- Decrement byte at head.-            val <- load cur-            val' <- sub val (1 :: Word8)-            store val' cur-            return cur-        gen cur '+' = do-            -- Increment byte at head.-            val <- load cur-            val' <- add val (1 :: Word8)-            store val' cur-            return cur-        gen cur '<' =-            -- Decrement head.-            getElementPtr cur ((-1) :: Word32, ())-        gen cur '>' =-            -- Increment head.-            getElementPtr cur (1 :: Word32, ())-        gen _ c = error $ "Bad character in program: " ++ show c---    brainf <- createFunction ExternalLinkage $ do-        ptr_arr <- arrayMalloc wmemtotal-        _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False)---        _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ())-        -- Start head in the middle.-        curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ())--        bb <- getCurrentBasicBlock-        generate instrs [] (curhead, bb)--        free ptr_arr-        ret ()--    return brainf
− examples/CallConv.hs 
@@ -1,33 +0,0 @@-module CallConv where--import LLVM.Core-import LLVM.FFI.Core (CallingConvention(GHC))--import Data.Word (Word32)----- Our module will have these two functions.-data Mod = Mod {-    m1 :: Function (Word32 -> IO Word32),-    m2 :: Function (Word32 -> Word32 -> IO Word32)-    }--main :: IO ()-main = do-    m <- newModule-    _fns <- defineModule m buildMod-    --_ <- optimizeModule 3 m-    writeBitcodeToFile "CallConv.bc" m-    return ()--buildMod :: CodeGenModule Mod-buildMod = do-    mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do-      r <- add x y-      ret r-    setFuncCallConv mod2 GHC-    mod1 <- newNamedFunction ExternalLinkage "test"-    defineFunction mod1 $ \ arg -> do-      r <- callWithConv GHC mod2 arg (valueOf 1)-      ret r-    return $ Mod mod1 mod2
− examples/Convert.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-}-module Convert(Convert(..)) where-import Data.Int-import Data.Word-import Foreign.Ptr (FunPtr)--type Importer f = FunPtr f -> f--class Convert f where-    convert :: Importer f--foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float)-instance Convert (IO Float) where convert = c_IOFloat--foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float)-instance Convert (Float -> IO Float) where convert = c_Float_IOFloat--foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float)-instance Convert (Float -> Float) where convert = c_Float_Float- -foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double)-instance Convert (IO Double) where convert = c_IODouble--foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double)-instance Convert (Double -> IO Double) where convert = c_Double_IODouble--foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double)-instance Convert (Double -> Double) where convert = c_Double_Double- -foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32)-instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32--foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32)-instance Convert (Word32 -> Word32) where convert = c_Word32_Word32--foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32)-instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32--foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32)-instance Convert (Int32 -> Int32) where convert = c_Int32_Int32-
− examples/DotProd.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-}-module DotProd where-import Data.Word-import Types.Data.Num(D2, D4, D8, fromIntegerT)-import LLVM.Core-import LLVM.ExecutionEngine-import LLVM.Util.Loop-import LLVM.Util.File(writeCodeGenModule)-import LLVM.Util.Foreign--mDotProd :: forall n a . (PositiveT n,-	                  IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a,-	                  FunctionRet a-	                 ) =>-            CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a))-mDotProd =-  createFunction ExternalLinkage $ \ size aPtr bPtr -> do-    s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do--        ap <- getElementPtr aPtr (i, ()) -- index into aPtr-        bp <- getElementPtr bPtr (i, ()) -- index into bPtr-        a <- load ap                     -- load element from a vector-        b <- load bp                     -- load element from b vector-        ab <- mul a b                    -- multiply them-        add s ab                         -- accumulate sum--    r <- forLoop (valueOf (0::Word32)) (valueOf (fromIntegerT (undefined :: n)))-              (valueOf 0) $ \ i r -> do-              ri <- extractelement s i-              add r ri-    ret (r :: Value a)--type R = Float-type T = Vector D4 R--main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget-    let mDotProd' = mDotProd-    writeCodeGenModule "DotProd.bc" mDotProd'--    ioDotProd <- simpleFunction mDotProd'-    let dotProd :: [T] -> [T] -> R-        dotProd a b =-         unsafeRemoveIO $-         withArrayLen a $ \ aLen aPtr ->-         withArrayLen b $ \ bLen bPtr ->-         ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr---    let a = [1 .. 8]-        b = [4 .. 11]-    print $ dotProd (vectorize 0 a) (vectorize 0 b)-    print $ sum $ zipWith (*) a b--class Vectorize n a where-    vectorize :: a -> [a] -> [Vector n a]--{--instance (IsPrimitive a) => Vectorize D1 a where-    vectorize _ [] = []-    vectorize x (x1:xs) = toVector x1 : vectorize x xs--}--instance (IsPrimitive a) => Vectorize D2 a where-    vectorize _ [] = []-    vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs-    vectorize x xs = vectorize x $ xs ++ [x]--instance (IsPrimitive a) => Vectorize D4 a where-    vectorize _ [] = []-    vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs-    vectorize x xs = vectorize x $ xs ++ [x]--instance (IsPrimitive a) => Vectorize D8 a where-    vectorize _ [] = []-    vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs-    vectorize x xs = vectorize x $ xs ++ [x]
− examples/Fibonacci.hs 
@@ -1,106 +0,0 @@-module Fibonacci where-import Prelude hiding(and, or)-import System.Environment(getArgs)-import Control.Monad(forM_)-import Data.Word--import LLVM.Core-import LLVM.Util.Optimize-import LLVM.ExecutionEngine---- Our module will have these two functions.-data Mod = Mod {-    mfib :: Function (Word32 -> IO Word32),-    mplus :: Function (Word32 -> Word32 -> IO Word32)-    }--main :: IO ()-main = do-    args <- getArgs-    let args' = if null args then ["10"] else args--    -- Initialize jitter-    initializeNativeTarget-    -- Create a module,-    m <- newNamedModule "fib"-    -- and define its contents.-    fns <- defineModule m buildMod--    -- Show the code for the two functions, just for fun.-    --dumpValue $ mfib fns-    --dumpValue $ mplus fns-    -- Write the code to a file for later perusal.-    -- Can be disassembled with llvm-dis.-    writeBitcodeToFile "Fibonacci.bc" m--    _ <- optimizeModule 3 m-    writeBitcodeToFile "Fibonacci-opt.bc" m--    -- Generate code for mfib, and then throw away the IO in the type.-    -- The result is an ordinary Haskell function.-    iofib <- runEngineAccess $ do-                 addModule m-                 generateFunction $ mfib fns-    let fib = unsafeRemoveIO iofib--    -- Run fib for the arguments.-    forM_ args' $ \num -> do-        putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num))-    return ()--buildMod :: CodeGenModule Mod-buildMod = do-    -- Add two numbers in a cumbersome way.-    plus <- createFunction InternalLinkage $ \ x y -> do-        -- Create three additional basic blocks, need to be created before being referred to.-        l1 <- newBasicBlock-        l2 <- newBasicBlock-        l3 <- newBasicBlock--        -- Test if x is even/odd.-        a <- and x (1 :: Word32)-        c <- cmp CmpEQ a (0 :: Word32)-        condBr c l1 l2--        -- Do x+y if even.-        defineBasicBlock l1-        r1 <- add x y-        br l3--        -- Do y+x if odd.-        defineBasicBlock l2-        r2 <- add y x-        br l3--        defineBasicBlock l3-        -- Join the two execution paths with a phi instruction.-        r <- phi [(r1, l1), (r2, l2)]-        ret r--    -- The usual doubly recursive Fibonacci.-    -- Use new&define so the name fib is defined in the body for recursive calls.-    fib <- newNamedFunction ExternalLinkage "fib"-    defineFunction fib $ \ arg -> do-        -- Create the two basic blocks.-        recurse <- newBasicBlock-        exit <- newBasicBlock--        -- Test if arg > 2-        test <- cmp CmpGT arg (2::Word32)-        condBr test recurse exit--        -- Just return 1 if not > 2-        defineBasicBlock exit-        ret (valueOf (1::Word32))--        -- Recurse if > 2, using the cumbersome plus to add the results.-        defineBasicBlock recurse-        x1 <- sub arg (1::Word32)-        fibx1 <- call fib x1-        x2 <- sub arg (2::Word32)-        fibx2 <- call fib x2-        r <- call plus fibx1 fibx2-        ret r--    -- Return the two functions.-    return $ Mod fib plus
− examples/HelloJIT.hs 
@@ -1,24 +0,0 @@-module HelloJIT (main) where--import Data.Word--import LLVM.Core-import LLVM.ExecutionEngine--bldGreet :: CodeGenModule (Function (IO ()))-bldGreet = withStringNul "Hello, JIT!" (\greetz -> do-    puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32)-    func <- createFunction ExternalLinkage $ do-      tmp <- getElementPtr0 greetz (0::Word32, ())-      _ <- call puts tmp :: CodeGenFunction r (Value Word32)-      ret ()-    return func)--main :: IO ()-main = do-    initializeNativeTarget-    greet <- simpleFunction bldGreet-    greet-    greet-    greet-    return ()
− examples/List.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ForeignFunctionInterface #-}-module List(main) where--import LLVM.Util.Loop (Phi, phis, addPhis, )-import LLVM.ExecutionEngine (simpleFunction, )-import LLVM.Core-import qualified System.IO as IO--import Data.Word (Word32, )-import Data.Int (Int32, )-import Foreign.Marshal.Array (allocaArray, )-import qualified Foreign.Storable as St--import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, )-import Foreign.Ptr (FunPtr, )-import Data.IORef (IORef, newIORef, readIORef, writeIORef, )---{--I had to export Phi's methods in llvm-0.6.8-in order to be able to implement this function.--}-arrayLoop ::-   (Phi a, IsType b,-    Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>-   Value i -> Value (Ptr b) -> a ->-   (Value (Ptr b) -> a -> CodeGenFunction r a) ->-   CodeGenFunction r a-arrayLoop len ptr start loopBody = do-   top <- getCurrentBasicBlock-   loop <- newBasicBlock-   body <- newBasicBlock-   exit <- newBasicBlock--   br loop--   defineBasicBlock loop-   i <- phi [(len, top)]-   p <- phi [(ptr, top)]-   vars <- phis top start-   t <- cmp CmpNE i (valueOf 0 `asTypeOf` len)-   condBr t body exit--   defineBasicBlock body--   vars' <- loopBody p vars-   i' <- sub i (valueOf 1 `asTypeOf` len)-   p' <- getElementPtr p (valueOf 1 :: Value Word32, ())--   body' <- getCurrentBasicBlock-   addPhis body' vars vars'-   addPhiInputs i [(i', body')]-   addPhiInputs p [(p', body')]-   br loop--   defineBasicBlock exit-   return vars---mList ::-   CodeGenModule (Function-      (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32))-mList =-   createFunction ExternalLinkage $ \ ref size ptr -> do-     next <- staticFunction nelem-     let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32)-     s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do-       flip store ptri =<< call next ref-       return y-     ret (s :: Value Int32)--renderList :: IO ()-renderList = do-   m <- newModule-   _f <- defineModule m mList-   writeBitcodeToFile "List.bc" m--   fill <- simpleFunction mList-   stable <- newStablePtr =<< newIORef [3,5..]-   IO.withFile "listcontent.u32" IO.WriteMode $ \h ->-     let len = 100-     in  allocaArray len $ \ ptr ->-           fill stable (fromIntegral len) ptr >>-           IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32))-   freeStablePtr stable---foreign import ccall "&nextListElement"-   nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)--foreign export ccall-   nextListElement :: StablePtr (IORef [Word32]) -> IO Word32--nextListElement :: StablePtr (IORef [Word32]) -> IO Word32-nextListElement stable =-   do ioRef <- deRefStablePtr stable-      xt <- readIORef ioRef-      case xt of-         [] -> return 0-         (x:xs) -> writeIORef ioRef xs >> return x---main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget-    renderList
− examples/Struct.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, TypeOperators, ScopedTypeVariables #-}-module Struct (main) where--import Data.Word-import Types.Data.Num(d0, d1, d2, D10)--import LLVM.Core-import LLVM.Util.File-import LLVM.ExecutionEngine--foreign import ccall structCheck :: Word32 -> Ptr S -> Int---- Watch out for double!  Alignment differs between platforms.--- struct S { uint32 x0; float x1; uint32 x2[10] };-type S = Struct (Word32 :& Float :& Array D10 Word32 :& ())---- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s;-mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S)))-mStruct = do-    createFunction ExternalLinkage $ \ x -> do-      p  :: Value (Ptr S)-         <- malloc-      p0 <- getElementPtr0 p (d0 & ())-      store x (p0 :: Value (Ptr Word32))-      p1 <- getElementPtr0 p (d1 & ())-      store (valueOf 1.5) p1-      x' <- add x (1 :: Word32)-      p2 <- getElementPtr0 p (d2 & (5::Word32) & ())-      store x' p2-      ret p--main :: IO ()-main = do-    initializeNativeTarget-    writeCodeGenModule "Struct.bc" mStruct-    struct <- simpleFunction mStruct-    let a = 10-    p <- struct a-    putStrLn $ if structCheck a p /= 0 then "OK" else "failed"-    return ()
− examples/Varargs.hs 
@@ -1,37 +0,0 @@-module Varargs (main) where--import Data.Word--import LLVM.Core-import LLVM.ExecutionEngine--bldVarargs :: CodeGenModule (Function (Word32 -> IO ()))-bldVarargs =-   withStringNul "Hello\n" (\fmt1 ->-   withStringNul "A number %d\n" (\fmt2 ->-   withStringNul "Two numbers %d %d\n" (\fmt3 -> do-      printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32)-      func <- createFunction ExternalLinkage $ \ x -> do--        tmp1 <- getElementPtr0 fmt1 (0::Word32, ())-        let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32)-        _ <- call p1 tmp1--        tmp2 <- getElementPtr0 fmt2 (0::Word32, ())-        let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32)-        _ <- call p2 tmp2 x--        tmp3 <- getElementPtr0 fmt3 (0::Word32, ())-        let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32)-        _ <- call p3 tmp3 x x--        ret ()-      return func-   )))--main :: IO ()-main = do-    initializeNativeTarget-    varargs <- simpleFunction bldVarargs-    varargs 42-    return ()
− examples/Vector.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Vector where--import Convert--import LLVM.Core-import LLVM.ExecutionEngine-import LLVM.Util.Optimize (optimizeModule, )-import LLVM.Util.Loop (forLoop, )--import Control.Monad (liftM2, )-import Types.Data.Num (D16, fromIntegerT, )-import Data.Word (Word32, )---- Type of vector elements.-type T = Float---- Number of vector elements.-type N = D16--cgvec :: CodeGenModule (Function (T -> IO T))-cgvec = do-    -- A global variable that vectest messes with.-    acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T))--    -- Return the global variable.-    retAcc <- createNamedFunction ExternalLinkage "retacc" $ do-        vacc <- load acc-        ret vacc-    let _ = retAcc :: Function (IO T)  -- Force the type of retAcc.--    -- A function that tests vector opreations.-    f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do--        let v = value (zero :: ConstValue (Vector N T))-	    n = fromIntegerT (undefined :: N) :: Word32--        -- Fill the vector with x, x+1, x+2, ...-        (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do-            x1' <- add x1 (1::T)-	    v1' <- insertelement v1 x1 i-	    return (x1', v1')--	-- Elementwise cubing of the vector.-	vsq <- mul v1 v1-        vcb <- mul vsq v1--        -- Sum the elements of the vector.-        s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do-            y <- extractelement vcb i-     	    s' <- add s (y :: Value T)-	    return s'--        -- Update the global variable.-        vacc <- load acc-        vacc' <- add vacc s-        store vacc' acc--        ret (s :: Value T)----    liftIO $ dumpValue f-    return f--main :: IO ()-main = do-    -- Initialize jitter-    initializeNativeTarget-    -- First run standard code.-    m <- newModule-    iovec <- defineModule m cgvec--    fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec-    let fvec = convert fptr--    fvec 10 >>= print--    vec <- runEngineAccess $ do addModule m; generateFunction iovec--    vec 10 >>= print--    -- And then optimize and run.-    _ <- optimizeModule 1 m--    funcs <- getModuleValues m-    print $ map fst funcs--    let iovec' :: Function (T -> IO T)-        Just iovec' = castModuleValue =<< lookup "vectest" funcs-	ioretacc' :: Function (IO T)-        Just ioretacc' = castModuleValue =<< lookup "retacc" funcs--    (vec', retacc') <- runEngineAccess $ do-        addModule m-        liftM2 (,) (generateFunction iovec') (generateFunction ioretacc')--    dumpValue iovec'--    vec' 10 >>= print-    vec' 0 >>= print-    retacc' >>= print
− examples/mainfib.c 
@@ -1,12 +0,0 @@-#include <stdio.h>-#include <stdlib.h>--extern unsigned int fib(unsigned int);--int-main(int argc, char **argv)-{-  int n = argc > 1 ? atoi(argv[1]) : 10;-  printf("fib %d = %d\n", n, fib(n));-  exit(0);-}
− examples/structCheck.c 
@@ -1,9 +0,0 @@-#include <stdint.h>--struct S { uint32_t x0; float x1; uint32_t x2[10]; };--int-structCheck(uint32_t a, struct S *s)-{-  return s->x0 == a && s->x1 == 1.5 && s->x2[5] == a+1;-}
llvm-tf.cabal view
@@ -1,9 +1,9 @@-name:          llvm-tf-version:       3.0.1-license:       BSD3-license-file:  LICENSE-synopsis:      Bindings to the LLVM compiler toolkit using type families.-description:+Name:          llvm-tf+Version:       3.0.2+License:       BSD3+License-File:  LICENSE+Synopsis:      Bindings to the LLVM compiler toolkit using type families.+Description:   High-level bindings to the LLVM compiler toolkit   using type families instead of functional dependencies.   .@@ -23,48 +23,58 @@   That is, a bump from 3.0.0 to 3.0.1 may contain substantial API changes,   a bump from 3.0.0.0 to 3.0.0.1 may contain API extensions,   and a bump from 3.0.0.0.0 to 3.0.0.0.1 may contain API-preserving bugfixes.-author:        Henning Thieleman, Bryan O'Sullivan, Lennart Augustsson-maintainer:    Henning Thieleman <llvm@henning-thielemann.de>-stability:     experimental-category:      Compilers/Interpreters, Code Generation-tested-with:   GHC == 7.4.2-cabal-version: >= 1.10-build-type:    Simple+Author:        Henning Thieleman, Bryan O'Sullivan, Lennart Augustsson+Maintainer:    Henning Thieleman <llvm@henning-thielemann.de>+Stability:     experimental+Category:      Compilers/Interpreters, Code Generation+Tested-With:   GHC == 7.4.2+Cabal-Version: >= 1.14+Build-Type:    Simple -extra-source-files:+Extra-Source-Files:     *.md-    examples/*.c-    examples/*.hs-    tests/*.hs-    tests/Makefile+    test/*.hs+    test/Makefile -flag developer-  description: operate in developer mode-  default: False+Source-Repository head+  Type:     darcs+  Location: http://code.haskell.org/~thielema/llvm-tf/ -library-  default-language: Haskell98-  build-depends:-    base >= 3 && < 5,-    bytestring >= 0.9,-    directory,+Source-Repository this+  Tag:      3.0.2+  Type:     darcs+  Location: http://code.haskell.org/~thielema/llvm-tf/++Flag developer+  Description: operate in developer mode+  Default: False++Flag buildExamples+  Description: Build example executables+  Default:     False++Library+  Default-Language: Haskell98+  Build-Depends:     llvm-base == 3.0.*,-    transformers >= 0.3 && < 0.4,-    process,-    tfp >= 0.7 && < 0.9,-    containers+    tfp >=0.7 && <0.9,+    transformers >=0.3 && <0.4,+    process >=1.1 && <1.3,+    containers >=0.4 && <0.6,+    base >=3 && <5 -  ghc-options: -Wall+  Hs-Source-Dirs: src+  GHC-Options: -Wall -  if flag(developer)-    ghc-options: -Werror+  If flag(developer)+    GHC-Options: -Werror -  if os(darwin)-    ld-options: -w -    frameworks: vecLib-    cpp-options: -D__MACOS__+  If os(darwin)+    Ld-Options: -w+    Frameworks: vecLib+    CPP-Options: -D__MACOS__ -  exposed-modules:+  Exposed-Modules:       LLVM.Core       LLVM.ExecutionEngine       LLVM.Util.Arithmetic@@ -74,7 +84,7 @@       LLVM.Util.Memory       LLVM.Util.Optimize -  other-modules:+  Other-Modules:       LLVM.Core.CodeGen       LLVM.Core.CodeGenMonad       LLVM.Core.Data@@ -85,11 +95,162 @@       LLVM.ExecutionEngine.Engine       LLVM.ExecutionEngine.Target -source-repository head-  type:     darcs-  location: http://code.haskell.org/~thielema/llvm-tf/+Executable llvm-align+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False -source-repository this-  tag:      3.0.1-  type:     darcs-  location: http://code.haskell.org/~thielema/llvm-tf/+  Main-Is: example/Align.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-arith+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Arith.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-array+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Array.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-brainf+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/BrainF.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-call-conv+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      llvm-base,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/CallConv.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-dot-prod+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/DotProd.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-fibonacci+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Fibonacci.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-hello-jit+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/HelloJIT.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-list+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/List.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-struct+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Struct.hs+  C-Sources: example/structCheck.c+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-varargs+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Main-Is: example/Varargs.hs+  Default-Language: Haskell98+  GHC-Options: -Wall++Executable llvm-vector+  If flag(buildExamples)+    Build-Depends:+      llvm-tf,+      tfp,+      base+  Else+    Buildable: False++  Hs-Source-Dirs: example+  Main-Is: Vector.hs+  Other-Modules: Convert+  Default-Language: Haskell98+  GHC-Options: -Wall
+ src/LLVM/Core.hs view
@@ -0,0 +1,116 @@+-- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level.+-- It supports both stand alone code generation and JITing.+-- The Haskell llvm package is a (relatively) high level interface to the LLVM.+-- The high level interface makes it easy to construct LLVM code.+-- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface.+--+-- LLVM code is organized into modules (type 'Module').+-- Each module contains a number of global variables and functions (type 'Function').+-- Each functions has a number of basic blocks (type 'BasicBlock').+-- Each basic block has a number instructions, where each instruction produces+-- a value (type 'Value').+--+-- Unlike assembly code for a real processor the assembly code for LLVM is+-- in SSA (Static Single Assignment) form.  This means that each instruction generates+-- a new bound variable which may not be assigned again.+-- A consequence of this is that where control flow joins from several execution+-- paths there has to be a phi pseudo instruction if you want different variables+-- to be joined into one.+--+-- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock')+-- follow the same pattern.  First the entity has to be created using @newX@ (where @X@+-- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to+-- given its definition using @defineX@.  The reason for splitting the creation and+-- definition is that you often need to be able to refer to an entity before giving+-- it's body, e.g., in two mutually recursive functions.+-- The the @newX@ and @defineX@ function can also be done at the same time by using+-- @createX@.  Furthermore, an explicit name can be given to an entity by the+-- @newNamedX@ function; the @newX@ function just generates a fresh name.+module LLVM.Core(+    -- * Initialize+    initializeNativeTarget,+    -- * Modules+    Module, newModule, newNamedModule, defineModule, destroyModule, createModule,+    ModuleProvider, createModuleProviderForExistingModule,+    PassManager, createPassManager, createFunctionPassManager,+    writeBitcodeToFile, readBitcodeFromFile,+    getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue,+    -- * Instructions+    module LLVM.Core.Instructions,+    -- * Types classification+    module LLVM.Core.Type,+    -- * Extra types+    module LLVM.Core.Data,+    -- * Values and constants+    Value, ConstValue, valueOf, constOf, value,+    zero, allOnes, undef,+    createString, createStringNul,+    withString, withStringNul,+    --constString, constStringNul,+    constVector, constArray,+    constStruct, constPackedStruct,+    toVector, fromVector, vector,+    -- * Code generation+    CodeGenFunction, CodeGenModule,+    -- * Functions+    Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,+    TFunction, liftCodeGenModule, getParams,+    -- * Global variable creation+    Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal,+    externFunction, staticFunction,+    externGlobal, staticGlobal,+    GlobalMappings, getGlobalMappings,+    TGlobal,+    -- * Globals+    Linkage(..),+    -- * Basic blocks+    BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,+    getBasicBlocks,              +    fromLabel, toLabel,+    getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep,+    -- * Misc+    addAttributes, Attribute(..),+    castVarArgs,+    -- * Debugging+    dumpValue, dumpType, getValueName, annotateValueList+    ) where++import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType)+import LLVM.Core.CodeGen+import LLVM.Core.CodeGenMonad+          (CodeGenFunction, CodeGenModule, liftCodeGenModule,+           GlobalMappings, getGlobalMappings)+import LLVM.Core.Data+import LLVM.Core.Instructions+import LLVM.Core.Type+import LLVM.Core.Vector+import LLVM.Target.Native++import qualified LLVM.FFI.Core as FFI+++-- |Print a value.+dumpValue :: Value a -> IO ()+dumpValue (Value v) = FFI.dumpValue v++-- |Print a type.+dumpType :: Value a -> IO ()+dumpType (Value v) = showTypeOf v >>= putStrLn++-- |Get the name of a 'Value'.+getValueName :: Value a -> IO String+getValueName (Value a) = getValueNameU a++-- |Convert a varargs function to a regular function.+castVarArgs :: (CastVarArgs a b) => Function a -> Function b+castVarArgs (Value a) = Value a++-- TODO for types:+-- Enforce free is only called on malloc memory.  (Enforce only one free?)+-- Enforce phi nodes a accessor of variables outside the bb+-- Enforce bb terminator+-- Enforce phi first+--+-- TODO:+-- Add Struct, PackedStruct types+-- Get alignment from code gen
+ src/LLVM/Core/CodeGen.hs view
@@ -0,0 +1,524 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Core.CodeGen(+    -- * Module creation+    newModule, newNamedModule, defineModule, createModule,+    getModuleValues, ModuleValue, castModuleValue,+    -- * Globals+    Linkage(..),+    Visibility(..),+    -- * Function creation+    Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,+    addAttributes,+    FFI.Attribute(..),+    externFunction, staticFunction,+    FunctionArgs, FunctionCodeGen, FunctionResult,+    TFunction,+    -- * Global variable creation+    Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal,+    externGlobal, staticGlobal,+    -- * Values+    Value(..), ConstValue(..),+    IsConst(..), valueOf, value,+    zero, allOnes, undef,+    createString, createStringNul,+    withString, withStringNul,+    constVector, constArray, constStruct, constPackedStruct,+    -- * Basic blocks+    BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,+    fromLabel, toLabel,+    -- * Misc+    withCurrentBuilder+    ) where++import qualified LLVM.Core.Util as U+import LLVM.Core.CodeGenMonad+import LLVM.Core.Type+import LLVM.Core.Data++import qualified LLVM.FFI.Core as FFI+import LLVM.FFI.Core(Linkage(..), Visibility(..))++import Types.Data.Num++import qualified Foreign.Storable as St+import Foreign.StablePtr (StablePtr, castStablePtrToPtr)+import Foreign.Ptr (minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr)++import Control.Monad (liftM, when)++import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Maybe (fromMaybe)++--------------------------------------++-- | Create a new module.+newModule :: IO U.Module+newModule = newNamedModule "_module"  -- XXX should generate a name++-- | Create a new explicitely named module.+newNamedModule :: String              -- ^ module name+               -> IO U.Module+newNamedModule = U.createModule++-- | Give the body for a module.+defineModule :: U.Module              -- ^ module that is defined+             -> CodeGenModule a       -- ^ module body+             -> IO a+defineModule = runCodeGenModule++-- | Create a new module with the given body.+createModule :: CodeGenModule a       -- ^ module body+             -> IO a+createModule cgm = newModule >>= \ m -> defineModule m cgm++--------------------------------------++newtype ModuleValue = ModuleValue FFI.ValueRef+    deriving (Show, Typeable)++getModuleValues :: U.Module -> IO [(String, ModuleValue)]+getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues++castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a)+castModuleValue (ModuleValue f) =+    if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing++--------------------------------------++newtype Value a = Value { unValue :: FFI.ValueRef }+    deriving (Show, Typeable)++newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef }+    deriving (Show, Typeable)++-- XXX merge with IsArithmetic?+class IsConst a where+    constOf :: a -> ConstValue a++instance IsConst Bool   where constOf = constEnum (typeRef True)+--instance IsConst Char   where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode+instance IsConst Word8  where constOf = constI+instance IsConst Word16 where constOf = constI+instance IsConst Word32 where constOf = constI+instance IsConst Word64 where constOf = constI+instance IsConst Int8   where constOf = constI+instance IsConst Int16  where constOf = constI+instance IsConst Int32  where constOf = constI+instance IsConst Int64  where constOf = constI+instance IsConst Float  where constOf = constF+instance IsConst Double where constOf = constF+--instance IsConst FP128  where constOf = constF++constOfPtr :: (IsType ptr) =>+    ptr -> Ptr b -> ConstValue ptr+constOfPtr proto p =+    let ip = p `minusPtr` nullPtr+        inttoptrC :: ConstValue int -> ConstValue ptr+        inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto)+    in  if St.sizeOf p == 4 then+            inttoptrC $ constOf (fromIntegral ip :: Word32)+        else if St.sizeOf p == 8 then+            inttoptrC $ constOf (fromIntegral ip :: Word64)+        else+            error "constOf Ptr: pointer size not 4 or 8"++-- This instance doesn't belong here, but mutually recursive modules are painful.+instance (IsType a) => IsConst (Ptr a) where+    constOf p = constOfPtr p p++instance IsConst (StablePtr a) where+    constOf p = constOfPtr p (castStablePtrToPtr p)++instance (IsPrimitive a, IsConst a, PositiveT n) => IsConst (Vector n a) where+    constOf (Vector xs) = constVector (map constOf xs)++instance (IsConst a, IsSized a, NaturalT n) => IsConst (Array n a) where+    constOf (Array xs) = constArray (map constOf xs)++instance (IsConstFields a) => IsConst (Struct a) where+    constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False+instance (IsConstFields a) => IsConst (PackedStruct a) where+    constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True++class IsConstFields a where+    constFieldsOf :: a -> [FFI.ValueRef]++instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where+    constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as+instance IsConstFields () where+    constFieldsOf _ = []++constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a+constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0++constI :: (IsInteger a, Integral a) => a -> ConstValue a+constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i)++constF :: (IsFloating a, Real a) => a -> ConstValue a+constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i)++valueOf :: (IsConst a) => a -> Value a+valueOf = value . constOf++value :: ConstValue a -> Value a+value (ConstValue a) = Value a++zero :: forall a . (IsType a) => ConstValue a+zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a)++allOnes :: forall a . (IsInteger a) => ConstValue a+allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a)++undef :: forall a . (IsType a) => ConstValue a+undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a)++{-+createString :: String -> ConstValue (DynamicArray Word8)+createString = ConstValue . U.constString++constStringNul :: String -> ConstValue (DynamicArray Word8)+constStringNul = ConstValue . U.constStringNul+-}++--------------------------------------+++-- |A function is simply a pointer to the function.+type Function a = Value (Ptr a)++-- | Create a new named function.+newNamedFunction :: forall a . (IsFunction a)+                 => Linkage+                 -> String   -- ^ Function name+                 -> CodeGenModule (Function a)+newNamedFunction linkage name = do+    modul <- getModule+    let typ = typeRef (undefined :: a)+    liftIO $ liftM Value $ U.addFunction modul linkage name typ++-- | Create a new function.  Use 'newNamedFunction' to create a function with external linkage, since+-- it needs a known name.+newFunction :: forall a . (IsFunction a)+            => Linkage+            -> CodeGenModule (Function a)+newFunction linkage = genMSym "fun" >>= newNamedFunction linkage++defineFunctionParam ::+                  Function f        -- ^ Function to define (created by 'newFunction').+               -> Parameterized r f -- ^ Function body.+               -> CodeGenModule ()+defineFunctionParam fn p = do+    bld <- liftIO $ U.createBuilder+    let body' = do+	    newBasicBlock >>= defineBasicBlock+	    defineParameterized fn p+    runCodeGenFunction bld (unValue fn) body'++-- | Define a function body.  The basic block returned by the function is the function entry point.+defineFunction :: forall f . (FunctionArgs f)+               => Function f        -- ^ Function to define (created by 'newFunction').+               -> FunctionCodeGen f -- ^ Function body.+               -> CodeGenModule ()+defineFunction fn body =+    defineFunctionParam fn $ paramFunc body++-- | Create a new function with the given body.+createFunction :: (FunctionArgs f)+               => Linkage+               -> FunctionCodeGen f  -- ^ Function body.+               -> CodeGenModule (Function f)+createFunction linkage body = do+    f <- newFunction linkage+    defineFunction f body+    return f++-- | Create a new function with the given body.+createNamedFunction :: (FunctionArgs f)+               => Linkage+	       -> String+               -> FunctionCodeGen f  -- ^ Function body.+               -> CodeGenModule (Function f)+createNamedFunction linkage name body = do+    f <- newNamedFunction linkage name+    defineFunction f body+    return f++-- | Set the calling convention of a function. By default it is the+-- C calling convention.+setFuncCallConv :: Function a+                -> FFI.CallingConvention+                -> CodeGenModule ()+setFuncCallConv (Value f) cc = do+  liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc)++-- | Add attributes to a value.  Beware, what attributes are allowed depends on+-- what kind of value it is.+addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r ()+addAttributes (Value f) i as = do+    liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as)++-- Convert a function of type f = t1->t2->...-> IO r to+-- g = Value t1 -> Value t2 -> ... CodeGenFunction r ()+class IsFunction f => FunctionArgs f where+    type FunctionCodeGen f :: *+    type FunctionResult  f :: *+    paramFunc :: FunctionCodeGen f -> Parameterized (FunctionResult f) f++instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where+    type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b+    type FunctionResult  (a -> b) = FunctionResult b+    paramFunc f = param $ \x -> paramFunc (f x)++instance IsFirstClass a => FunctionArgs (IO a) where+    type FunctionCodeGen (IO a) = CodeGenFunction a ()+    type FunctionResult (IO a) = a+    paramFunc = parameterized+++newtype+   Parameterized r f =+      Parameterized (Int -> FFI.ValueRef -> CodeGenFunction r ())++parameterized :: CodeGenFunction r () -> Parameterized r (IO r)+parameterized code = Parameterized (const $ const code)++param :: (Value a -> Parameterized r b) -> Parameterized r (a -> b)+param pf =+   Parameterized $ \n f ->+      case pf $ Value $ U.getParam f n of+         Parameterized p -> p (n+1) f++defineParameterized :: Function f -> Parameterized r f -> CodeGenFunction r ()+defineParameterized f (Parameterized p) = p 0 $ unValue f+++--------------------------------------++-- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction.+newtype BasicBlock = BasicBlock FFI.BasicBlockRef+    deriving (Show, Typeable)++createBasicBlock :: CodeGenFunction r BasicBlock+createBasicBlock = do+    b <- newBasicBlock+    defineBasicBlock b+    return b++newBasicBlock :: CodeGenFunction r BasicBlock+newBasicBlock = genFSym >>= newNamedBasicBlock++newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock+newNamedBasicBlock name = do+    fn <- getFunction+    liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name++defineBasicBlock :: BasicBlock -> CodeGenFunction r ()+defineBasicBlock (BasicBlock l) = do+    bld <- getBuilder+    liftIO $ U.positionAtEnd bld l++getCurrentBasicBlock :: CodeGenFunction r BasicBlock+getCurrentBasicBlock = do+    bld <- getBuilder+    liftIO $ liftM BasicBlock $ U.getInsertBlock bld++toLabel :: BasicBlock -> Value Label+toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr)++fromLabel :: Value Label -> BasicBlock+fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr)++--------------------------------------++--- XXX: the functions in this section (and addGlobalMapping) don't actually use any+-- Function state so should really be in the CodeGenModule monad++-- | Create a reference to an external function while code generating for a function.+-- If LLVM cannot resolve its name, then you may try 'staticFunction'.+externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a)+externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage++-- | As 'externFunction', but for 'Global's rather than 'Function's+externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a)+externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage++externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a)+externCore name act = do+    es <- getExterns+    case lookup name es of+        Just f -> return $ Value f+        Nothing -> do+            f <- liftCodeGenModule $ act name+            putExterns ((name, f) : es)+	    return $ Value f++{- |+Make an external C function with a fixed address callable from LLVM code.+This callback function can also be a Haskell function,+that was imported like++> foreign import ccall "&nextElement"+>    nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32)++See @examples\/List.hs@.++When you only use 'externFunction', then LLVM cannot resolve the name.+(However, I do not know why.)+Thus 'staticFunction' manages a list of static functions.+This list is automatically installed by 'ExecutionEngine.simpleFunction'+and can be manually obtained by 'getGlobalMappings'+and installed by 'ExecutionEngine.addGlobalMappings'.+\"Installing\" means calling LLVM's @addGlobalMapping@ according to+<http://old.nabble.com/jit-with-external-functions-td7769793.html>.+-}+staticFunction :: forall f r. (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f)+staticFunction func = liftCodeGenModule $ do+    val <- newNamedFunction ExternalLinkage ""+    addGlobalMapping (unValue (val :: Function f)) (castFunPtrToPtr func)+    return val++-- | As 'staticFunction', but for 'Global's rather than 'Function's+staticGlobal :: forall a r. (IsType a) => Bool -> Ptr a -> CodeGenFunction r (Global a)+staticGlobal isConst gbl = liftCodeGenModule $ do+    val <- newNamedGlobal isConst ExternalLinkage ""+    addGlobalMapping (unValue (val :: Global a)) (castPtr gbl)+    return val++--------------------------------------++withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a+withCurrentBuilder body = do+    bld <- getBuilder+    liftIO $ U.withBuilder bld body++--------------------------------------++-- Mark all block terminating instructions.  Not used yet.+--data Terminate = Terminate++--------------------------------------++type Global a = Value (Ptr a)++-- | Create a new named global variable.+newNamedGlobal :: forall a . (IsType a)+               => Bool         -- ^Constant?+               -> Linkage      -- ^Visibility+               -> String       -- ^Name+               -> TGlobal a+newNamedGlobal isConst linkage name = do+    modul <- getModule+    let typ = typeRef (undefined :: a)+    liftIO $ liftM Value $ do g <- U.addGlobal modul linkage name typ+    	     	   	      when isConst $ FFI.setGlobalConstant g 1+			      return g++-- | Create a new global variable.+newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a+newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage++-- | Give a global variable a (constant) value.+defineGlobal :: Global a -> ConstValue a -> CodeGenModule ()+defineGlobal (Value g) (ConstValue v) =+    liftIO $ FFI.setInitializer g v++-- | Create and define a global variable.+createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a+createGlobal isConst linkage con = do+    g <- newGlobal isConst linkage+    defineGlobal g con+    return g++-- | Create and define a named global variable.+createNamedGlobal :: (IsType a) => Bool -> Linkage -> String -> ConstValue a -> TGlobal a+createNamedGlobal isConst linkage name con = do+    g <- newNamedGlobal isConst linkage name+    defineGlobal g con+    return g++type TFunction a = CodeGenModule (Function a)+type TGlobal a = CodeGenModule (Global a)++-- Special string creators+{-# DEPRECATED createString "use withString instead" #-}+createString :: String -> TGlobal (Array n Word8)+createString s = string (length s) (U.constString s)++{-# DEPRECATED createStringNul "use withStringNul instead" #-}+createStringNul :: String -> TGlobal (Array n Word8)+createStringNul s = string (length s + 1) (U.constStringNul s)++withString ::+   String ->+   (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) ->+   CodeGenModule a+withString s act =+   let n = length s+   in  fromMaybe (error "withString: length must always be non-negative") $+       reifyNaturalD (fromIntegral n) (\tn ->+          do arr <- string n (U.constString s)+             act (fixArraySize tn arr))++withStringNul ::+   String ->+   (forall n. (NaturalT n) => Global (Array n Word8) -> CodeGenModule a) ->+   CodeGenModule a+withStringNul s act =+   let n = length s + 1+   in  fromMaybe (error "withStringNul: length must always be non-negative") $+       reifyNaturalD (fromIntegral n) (\tn ->+          do arr <- string n (U.constStringNul s)+             act (fixArraySize tn arr))++fixArraySize :: n -> Global (Array n a) -> Global (Array n a)+fixArraySize _ = id++string :: Int -> FFI.ValueRef -> TGlobal (Array n Word8)+string n s = do+    modul <- getModule+    name <- genMSym "str"+    let typ = FFI.arrayType (typeRef (undefined :: Word8)) (fromIntegral n)+    liftIO $ liftM Value $ do g <- U.addGlobal modul InternalLinkage name typ+    	     	   	      FFI.setGlobalConstant g 1+			      FFI.setInitializer g s+			      return g++--------------------------------------++-- |Make a constant vector.  Replicates or truncates the list to get length /n/.+constVector :: forall a n . (PositiveT n) => [ConstValue a] -> ConstValue (Vector n a)+constVector xs =+    ConstValue $ U.constVector (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ]++-- |Make a constant array.  Replicates or truncates the list to get length /n/.+constArray :: forall a n . (IsSized a, NaturalT n) => [ConstValue a] -> ConstValue (Array n a)+constArray xs =+    ConstValue $ U.constArray (typeRef (undefined :: a)) (fromIntegerT (undefined :: n)) [ v | ConstValue v <- xs ]++-- |Make a constant struct.+constStruct :: (IsConstStruct c) => c -> ConstValue (Struct (ConstStructOf c))+constStruct struct =+    ConstValue $ U.constStruct (constValueFieldsOf struct) False++-- |Make a constant packed struct.+constPackedStruct :: (IsConstStruct c) => c -> ConstValue (PackedStruct (ConstStructOf c))+constPackedStruct struct =+    ConstValue $ U.constStruct (constValueFieldsOf struct) True++class IsConstStruct c where+    type ConstStructOf c :: *+    constValueFieldsOf :: c -> [FFI.ValueRef]++instance (IsConst a, IsConstStruct cs) => IsConstStruct (ConstValue a, cs) where+    type ConstStructOf (ConstValue a, cs) = (a, ConstStructOf cs)+    constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as+instance IsConstStruct () where+    type ConstStructOf () = ()+    constValueFieldsOf _ = []
+ src/LLVM/Core/CodeGenMonad.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.CodeGenMonad(+    -- * Module code generation+    CodeGenModule, runCodeGenModule, genMSym, getModule,+    GlobalMappings(..), addGlobalMapping, getGlobalMappings,+    -- * Function code generation+    CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns,+    -- * Reexport+    liftIO+    ) where++import LLVM.Core.Util(Module, Builder, Function)++import Foreign.Ptr (Ptr, )++import Control.Monad.Trans.State (StateT, runStateT, evalStateT, get, gets, put, modify, )+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Applicative (Applicative, )++import Data.Typeable (Typeable)++--------------------------------------++data CGMState = CGMState {+    cgm_module :: Module,+    cgm_externs :: [(String, Function)],+    cgm_global_mappings :: [(Function, Ptr ())],+    cgm_next :: !Int+    }+    deriving (Show, Typeable)+newtype CodeGenModule a = CGM (StateT CGMState IO a)+    deriving (Functor, Applicative, Monad, MonadIO, Typeable)++genMSym :: String -> CodeGenModule String+genMSym prefix = do+    s <- CGM get+    let n = cgm_next s+    CGM $ put (s { cgm_next = n + 1 })+    return $ "_" ++ prefix ++ show n++getModule :: CodeGenModule Module+getModule = CGM $ gets cgm_module++runCodeGenModule :: Module -> CodeGenModule a -> IO a+runCodeGenModule m (CGM body) = do+    let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] }+    evalStateT body cgm++--------------------------------------++data CGFState r = CGFState { +    cgf_module :: CGMState,+    cgf_builder :: Builder,+    cgf_function :: Function,+    cgf_next :: !Int+    }+    deriving (Show, Typeable)+newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)+    deriving (Functor, Applicative, Monad, MonadIO, Typeable)++genFSym :: CodeGenFunction a String+genFSym = do+    s <- CGF get+    let n = cgf_next s+    CGF $ put (s { cgf_next = n + 1 })+    return $ "_L" ++ show n++getFunction :: CodeGenFunction a Function+getFunction = CGF $ gets cgf_function++getBuilder :: CodeGenFunction a Builder+getBuilder = CGF $ gets cgf_builder++getFunctionModule :: CodeGenFunction a Module+getFunctionModule = CGF $ gets (cgm_module . cgf_module)++getExterns :: CodeGenFunction a [(String, Function)]+getExterns = CGF $ gets (cgm_externs . cgf_module)++putExterns :: [(String, Function)] -> CodeGenFunction a ()+putExterns es = do+    cgf <- CGF get+    let cgm' = (cgf_module cgf) { cgm_externs = es }+    CGF $ put (cgf { cgf_module = cgm' })++addGlobalMapping ::+    Function -> Ptr () -> CodeGenModule ()+addGlobalMapping value func = CGM $ modify $ \cgm ->+        cgm { cgm_global_mappings =+                 (value,func) : cgm_global_mappings cgm }++newtype GlobalMappings =+   GlobalMappings [(Function, Ptr ())]++{- |+Get a list created by calls to 'staticFunction'+that must be passed to the execution engine+via 'LLVM.ExecutionEngine.addGlobalMappings'.+-}+getGlobalMappings ::+    CodeGenModule GlobalMappings+getGlobalMappings =+   CGM $ gets (GlobalMappings . cgm_global_mappings)++runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a+runCodeGenFunction bld fn (CGF body) = do+    cgm <- CGM get+    let cgf = CGFState { cgf_module = cgm,+                         cgf_builder = bld,+    	      	       	 cgf_function = fn,+			 cgf_next = 1 }+    (a, cgf') <- liftIO $ runStateT body cgf+    CGM $ put (cgf_module cgf')+    return a++--------------------------------------++-- | Allows you to define part of a module while in the middle of defining a function.+liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a+liftCodeGenModule (CGM act) = do+    cgf <- CGF get+    (a, cgm') <- liftIO $ runStateT act (cgf_module cgf)+    CGF $ put (cgf { cgf_module = cgm' })+    return a
+ src/LLVM/Core/Data.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.Data(IntN(..), WordN(..), FP128(..),+       		      Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where++import Foreign.Ptr (Ptr)+import Data.Typeable (Typeable)+++-- TODO:+-- Make instances IntN, WordN to actually do the right thing.+-- Make FP128 do the right thing+-- Make Array functions.++-- |Variable sized signed integer.+-- The /n/ parameter should belong to @PosI@.+newtype IntN n = IntN Integer+    deriving (Show, Typeable)++-- |Variable sized unsigned integer.+-- The /n/ parameter should belong to @PosI@.+newtype WordN n = WordN Integer+    deriving (Show, Typeable)++-- |128 bit floating point.+newtype FP128 = FP128 Rational+    deriving (Show, Typeable)++-- |Fixed sized arrays, the array size is encoded in the /n/ parameter.+newtype Array n a = Array [a]+    deriving (Show, Typeable)++-- |Fixed sized vector, the array size is encoded in the /n/ parameter.+newtype Vector n a = Vector [a]+    deriving (Show, Typeable)++-- |Label type, produced by a basic block.+data Label+    deriving (Typeable)++-- |Struct types; a list (nested tuple) of component types.+newtype Struct a = Struct a+    deriving (Show, Typeable)+newtype PackedStruct a = PackedStruct a+    deriving (Show, Typeable)
+ src/LLVM/Core/Instructions.hs view
@@ -0,0 +1,1308 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-}+module LLVM.Core.Instructions(+    -- * ADT representation of IR+    BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc,+    -- * Terminator instructions+    ret,+    condBr,+    br,+    switch,+    invoke, invokeWithConv,+    invokeFromFunction, invokeWithConvFromFunction,+    unreachable,+    -- * Arithmetic binary operations+    -- | Arithmetic operations with the normal semantics.+    -- The u instractions are unsigned, the s instructions are signed.+    add, sub, mul, neg,+    iadd, isub, imul, ineg,+    fadd, fsub, fmul, fneg,+    idiv, irem,+    udiv, sdiv, fdiv, urem, srem, frem,+    -- * Logical binary operations+    -- |Logical instructions with the normal semantics.+    shl, lshr, ashr, and, or, xor, inv,+    -- * Vector operations+    extractelement,+    insertelement,+    shufflevector,+    -- * Aggregate operation+    extractvalue,+    insertvalue,+    -- * Memory access+    malloc, arrayMalloc,+    alloca, arrayAlloca,+    free,+    load,+    store,+    getElementPtr, getElementPtr0,+    -- * Conversions+    trunc, zext, sext, ext, zadapt, sadapt, adapt,+    fptrunc, fpext,+    fptoui, fptosi, fptoint,+    uitofp, sitofp, inttofp,+    ptrtoint, inttoptr,+    bitcast,+    bitcastElements,+    -- * Comparison+    CmpPredicate(..), IntPredicate(..), FPPredicate(..),+    CmpOp, CmpRet, CmpResult,+    cmp, pcmp, icmp, fcmp,+    select,+    -- * Other+    phi, addPhiInputs,+    call, callWithConv,+    callFromFunction, callWithConvFromFunction,+    Call, applyCall, runCall,++    -- * Classes and types+    Terminate,+    Ret, CallArgs, ABinOp, ABinOpResult, IsConst,+    FunctionArgs, FunctionCodeGen, FunctionResult,+    AllocArg,+    GetElementPtr, ElementPtrType, IsIndexArg,+    GetValue, ValueType+    ) where++import qualified LLVM.Core.Util as U+import LLVM.Core.Data+import LLVM.Core.Type+import LLVM.Core.CodeGenMonad+import LLVM.Core.CodeGen++import qualified LLVM.FFI.Core as FFI++import Types.Data.Num (Dec, DecN, (:.), d1, fromIntegerT, Pred)+import Types.Data.Ord (LTT, GTT)++import Foreign.Ptr (FunPtr, )+import Foreign.C (CInt, CUInt)++import Control.Monad (liftM)++import Data.Typeable (Typeable)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Map (fromList, (!))++import Prelude hiding (and, or)+++-- TODO:+-- Add vector version of arithmetic+-- Add rest of instructions+-- Use Terminate to ensure bb termination (how?)+-- more intrinsics are needed to, e.g., create an empty vector++data ArgDesc = AV String | AI Int | AL String | AE++instance Show ArgDesc where+    -- show (AV s) = "V_" ++ s+    -- show (AI i) = "I_" ++ show i+    -- show (AL l) = "L_" ++ l+    show (AV s) = s+    show (AI i) = show i+    show (AL l) = l+    show AE = "voidarg?"++data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd+               | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub+               | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul+               | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem+               | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor+    deriving Show++-- FIXME: complete definitions for unimplemented instructions+data InstrDesc =+    -- terminators+    IDRet TypeDesc ArgDesc | IDRetVoid+  | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc+  | IDSwitch [(ArgDesc, ArgDesc)]+  | IDIndirectBr+  | IDInvoke+  | IDUnwind+  | IDUnreachable+    -- binary operators (including bitwise)+  | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc+    -- memory access and addressing+  | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc+  | IDGetElementPtr TypeDesc [ArgDesc]+    -- conversion+  | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc+  | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc+  | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc+  | IDSItoFP TypeDesc TypeDesc ArgDesc+  | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc+  | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc+  | IDBitcast TypeDesc TypeDesc ArgDesc+    -- other+  | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc+  | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc]+  | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg+    -- vector operators+  | IDExtractElement | IDInsertElement | IDShuffleVector+    -- aggregate operators+  | IDExtractValue | IDInsertValue+    -- invalid+  | IDInvalidOp+    deriving Show++-- TODO: overflow support for binary operations (add/sub/mul)+getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc)+getInstrDesc v = do+    valueName <- U.getValueNameU v+    opcode <- FFI.instGetOpcode v+    t <- FFI.typeOf v >>= typeDesc2+    -- FIXME: sizeof() does not work for types!+    --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral+    tsize <- return 1+    os <- U.getOperands v >>= mapM getArgDesc+    os0 <- if length os > 0 then return $ os !! 0 else return AE+    os1 <- if length os > 1 then return $ os !! 1 else return AE+    t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41)+            then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2+            else return TDVoid)+    p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0+    let instr =+            (if opcode >= 8 && opcode <= 25 -- binary arithmetic+             then IDBinOp (getBinOp opcode) t os0 os1+             else if opcode >= 30 && opcode <= 41 -- conversion+                  then (getConvOp opcode) t2 t os0+                  else case opcode of+                         { 1 -> if null os then IDRetVoid else IDRet t os0;+                           2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1;+                           3 -> IDSwitch $ toPairs os;+                           -- TODO (can skip for now)+                           -- 4 -> IndirectBr ; 5 -> Invoke ;+                           6 -> IDUnwind; 7 -> IDUnreachable;+                           26 -> IDAlloca (getPtrType t) tsize (getImmInt os0);+                           27 -> IDLoad t os0; 28 -> IDStore t os0 os1;+                           29 -> IDGetElementPtr t os;+                           42 -> IDICmp (toIntPredicate p) os0 os1;+                           43 -> IDFCmp (toFPPredicate p) os0 os1;+                           44 -> IDPhi t $ toPairs os;+                           -- FIXME: getelementptr arguments are not handled+                           45 -> IDCall t (last os) (init os);+                           46 -> IDSelect t os0 os1;+                           -- TODO (can skip for now)+                           -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ;+                           -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ;+                           -- 53 -> ExtractValue ; 54 -> InsertValue ;+                           _ -> IDInvalidOp })+    return (valueName, instr)+    --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode+        where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub),+                                     (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv),+                                     (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem),+                                     (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd),+                                     (24, BOOr), (25, BOXor)] ! o+              getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI),+                                      (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc),+                                      (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o+              toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs))+              stride _ [] = []+              stride n (x:xs) = x : stride n (drop (n-1) xs)+              getPtrType (TDPtr t) = t+              getPtrType _ = TDVoid+              getImmInt (AI i) = i+              getImmInt _ = 0++-- TODO: fix for non-int constants+getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc+getArgDesc (vname, v) = do+    isC <- U.isConstant v+    t <- FFI.typeOf v >>= typeDesc2+    if isC+      then case t of+             TDInt _ _ -> do+                          cV <- FFI.constIntGetSExtValue v+                          return $ AI $ fromIntegral cV+             _ -> return AE+      else case t of+             TDLabel -> return $ AL vname+             _ -> return $ AV vname++--------------------------------------++type Terminate = ()+terminate :: Terminate+terminate = ()++--------------------------------------++-- |Acceptable arguments to the 'ret' instruction.+class Ret a r where+    ret' :: a -> CodeGenFunction r Terminate++-- | Return from the current function with the given value.  Use () as the return value for what would be a void function in C.+ret :: (Ret a r) => a -> CodeGenFunction r Terminate+ret = ret'++-- overlaps with Ret () ()!+{-+instance (IsFirstClass a, IsConst a) => Ret a a where+    ret' = ret . valueOf+-}++instance Ret (Value a) a where+    ret' (Value a) = do+        withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a+        return terminate++instance Ret () () where+    ret' _ = do+        withCurrentBuilder_ $ FFI.buildRetVoid+        return terminate++withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r ()+withCurrentBuilder_ p = withCurrentBuilder p >> return ()++--------------------------------------++-- | Branch to the first basic block if the boolean is true, otherwise to the second basic block.+condBr :: Value Bool -- ^ Boolean to branch upon.+       -> BasicBlock -- ^ Target for true.+       -> BasicBlock -- ^ Target for false.+       -> CodeGenFunction r Terminate+condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do+    withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2+    return terminate++--------------------------------------++-- | Unconditionally branch to the given basic block.+br :: BasicBlock  -- ^ Branch target.+   -> CodeGenFunction r Terminate+br (BasicBlock t) = do+    withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t+    return terminate++--------------------------------------++-- | Branch table instruction.+switch :: (IsInteger a)+       => Value a                        -- ^ Value to branch upon.+       -> BasicBlock                     -- ^ Default branch target.+       -> [(ConstValue a, BasicBlock)]   -- ^ Labels and corresponding branch targets.+       -> CodeGenFunction r Terminate+switch (Value val) (BasicBlock dflt) arms = do+    withCurrentBuilder_ $ \ bldPtr -> do+        inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms)+        sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ]+    return terminate++--------------------------------------++-- |Inform the code generator that this code can never be reached.+unreachable :: CodeGenFunction r Terminate+unreachable = do+    withCurrentBuilder_ FFI.buildUnreachable+    return terminate++--------------------------------------++type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef+type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef+++withArithmeticType ::+    (IsArithmetic c) =>+    (ArithmeticType c -> a -> CodeGenFunction r (v c)) ->+    (a -> CodeGenFunction r (v c))+withArithmeticType f = f arithmeticType++-- |Acceptable arguments to arithmetic binary instructions.+class ABinOp a b where+    type ABinOpResult a b :: *+    abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b)++add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+add =+    curry $ withArithmeticType $ \typ -> uncurry $ case typ of+      IntegerType  -> abinop FFI.constAdd  FFI.buildAdd+      FloatingType -> abinop FFI.constFAdd FFI.buildFAdd++sub :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+sub =+    curry $ withArithmeticType $ \typ -> uncurry $ case typ of+      IntegerType  -> abinop FFI.constSub  FFI.buildSub+      FloatingType -> abinop FFI.constFSub FFI.buildFSub++mul :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+mul =+    curry $ withArithmeticType $ \typ -> uncurry $ case typ of+      IntegerType  -> abinop FFI.constMul  FFI.buildMul+      FloatingType -> abinop FFI.constFMul FFI.buildFMul++iadd :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+iadd = abinop FFI.constAdd FFI.buildAdd+isub :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+isub = abinop FFI.constSub FFI.buildSub+imul :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+imul = abinop FFI.constMul FFI.buildMul++-- | signed or unsigned integer division depending on the type+idiv ::+   forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) =>+   a -> b -> CodeGenFunction r (v c)+idiv =+   if isSigned (undefined :: c)+     then abinop FFI.constSDiv FFI.buildSDiv+     else abinop FFI.constUDiv FFI.buildUDiv+-- | signed or unsigned remainder depending on the type+irem ::+   forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) =>+   a -> b -> CodeGenFunction r (v c)+irem =+   if isSigned (undefined :: c)+     then abinop FFI.constSRem FFI.buildSRem+     else abinop FFI.constURem FFI.buildURem++{-# DEPRECATED udiv "use idiv instead" #-}+{-# DEPRECATED sdiv "use idiv instead" #-}+{-# DEPRECATED urem "use irem instead" #-}+{-# DEPRECATED srem "use irem instead" #-}+udiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+udiv = abinop FFI.constUDiv FFI.buildUDiv+sdiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+sdiv = abinop FFI.constSDiv FFI.buildSDiv+urem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+urem = abinop FFI.constURem FFI.buildURem+srem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+srem = abinop FFI.constSRem FFI.buildSRem++fadd :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+fadd = abinop FFI.constFAdd FFI.buildFAdd+fsub :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+fsub = abinop FFI.constFSub FFI.buildFSub+fmul :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+fmul = abinop FFI.constFMul FFI.buildFMul++-- | Floating point division.+fdiv :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+fdiv = abinop FFI.constFDiv FFI.buildFDiv+-- | Floating point remainder.+frem :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+frem = abinop FFI.constFRem FFI.buildFRem++shl :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+shl  = abinop FFI.constShl  FFI.buildShl+lshr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+lshr = abinop FFI.constLShr FFI.buildLShr+ashr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+ashr = abinop FFI.constAShr FFI.buildAShr+and :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+and  = abinop FFI.constAnd  FFI.buildAnd+or :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+or   = abinop FFI.constOr   FFI.buildOr+xor :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c)+xor  = abinop FFI.constXor  FFI.buildXor++instance ABinOp (Value a) (Value a) where+    type ABinOpResult (Value a) (Value a) = Value a+    abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2++instance ABinOp (ConstValue a) (Value a) where+    type ABinOpResult (ConstValue a) (Value a) = Value a+    abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2++instance ABinOp (Value a) (ConstValue a) where+    type ABinOpResult (Value a) (ConstValue a) = Value a+    abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2++instance ABinOp (ConstValue a) (ConstValue a) where+    type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a+    abinop cop _ (ConstValue a1) (ConstValue a2) =+        return $ ConstValue $ cop a1 a2++{-+instance (IsConst a) => ABinOp (Value a) a where+    type ABinOpResult (Value a) a = Value a+    abinop cop op a1 a2 = abinop cop op a1 (constOf a2)++instance (IsConst a) => ABinOp a (Value a) where+    type ABinOpResult a (Value a) = Value a+    abinop cop op a1 a2 = abinop cop op (constOf a1) a2+-}++--instance (IsConst a) => ABinOp a a (ConstValue a) where+--    abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2)++buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a)+buildBinOp op a1 a2 =+    liftM Value $+    withCurrentBuilder $ \ bld ->+      U.withEmptyCString $ op bld a1 a2++type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef++buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a)+buildUnOp op a =+    liftM Value $+    withCurrentBuilder $ \ bld ->+      U.withEmptyCString $ op bld a++neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a)+neg =+    withArithmeticType $ \typ -> case typ of+      IntegerType  -> \(Value x) -> buildUnOp FFI.buildNeg x+      FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a)++ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)+ineg (Value x) = buildUnOp FFI.buildNeg x++fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a)+fneg = fsub (value zero :: Value a)+{-+fneg (Value x) = buildUnOp FFI.buildFNeg x+-}++inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a)+inv (Value x) = buildUnOp FFI.buildNot x++--------------------------------------++-- | Get a value from a vector.+extractelement :: (PositiveT n)+               => Value (Vector n a)               -- ^ Vector+               -> Value Word32                     -- ^ Index into the vector+               -> CodeGenFunction r (Value a)+extractelement (Value vec) (Value i) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i++-- | Insert a value into a vector, nondestructive.+insertelement :: (PositiveT n)+              => Value (Vector n a)                -- ^ Vector+              -> Value a                           -- ^ Value to insert+              -> Value Word32                      -- ^ Index into the vector+              -> CodeGenFunction r (Value (Vector n a))+insertelement (Value vec) (Value e) (Value i) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i++-- | Permute vector.+shufflevector :: (PositiveT n, PositiveT m)+              => Value (Vector n a)+              -> Value (Vector n a)+              -> ConstValue (Vector m Word32)+              -> CodeGenFunction r (Value (Vector m a))+shufflevector (Value a) (Value b) (ConstValue mask) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask+++-- |Acceptable arguments to 'extractvalue' and 'insertvalue'.+class GetValue agg ix where+    type ValueType agg ix :: *+    getIx :: agg -> ix -> CUInt++instance (GetField as i, NaturalT i) => GetValue (Struct as) i where+    type ValueType (Struct as) i = FieldType as i+    getIx _ n = fromIntegerT n++instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where+    type ValueType (Array n a) Word32 = a+    getIx _ n = fromIntegral n++instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where+    type ValueType (Array n a) Word64 = a+    getIx _ n = fromIntegral n+++instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where+    type ValueType (Array n a) (Dec i) = a+    getIx _ n = fromIntegerT n+++-- | Get a value from an aggregate.+extractvalue :: forall r agg i.+                GetValue agg i+             => Value agg                   -- ^ Aggregate+             -> i                           -- ^ Index into the aggregate+             -> CodeGenFunction r (Value (ValueType agg i))+extractvalue (Value agg) i =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $+        FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i)++-- | Insert a value into an aggregate, nondestructive.+insertvalue :: forall r agg i.+               GetValue agg i+            => Value agg                   -- ^ Aggregate+            -> Value (ValueType agg i)     -- ^ Value to insert+            -> i                           -- ^ Index into the aggregate+            -> CodeGenFunction r (Value agg)+insertvalue (Value agg) (Value e) i =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $+        FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i)+++--------------------------------------++-- XXX should allows constants++-- | Truncate a value to a shorter bit width.+trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))+      => Value a -> CodeGenFunction r (Value b)+trunc = convert FFI.buildTrunc++-- | Zero extend a value to a wider width.+-- If possible, use 'ext' that chooses the right padding according to the types+zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+     => Value a -> CodeGenFunction r (Value b)+zext = convert FFI.buildZExt++-- | Sign extend a value to wider width.+-- If possible, use 'ext' that chooses the right padding according to the types+sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+     => Value a -> CodeGenFunction r (Value b)+sext = convert FFI.buildSExt++-- | Extend a value to wider width.+-- If the target type is signed, then preserve the sign,+-- If the target type is unsigned, then extended by zeros.+ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+     => Value a -> CodeGenFunction r (Value b)+ext =+   if isSigned (undefined :: b)+     then convert FFI.buildSExt+     else convert FFI.buildZExt+++-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes.+zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b)+     => Value a -> CodeGenFunction r (Value b)+zadapt =+   case compare (sizeOf (typeDesc (undefined :: a)))+                (sizeOf (typeDesc (undefined :: b))) of+      LT -> convert FFI.buildZExt+      EQ -> convert FFI.buildBitCast+      GT -> convert FFI.buildTrunc++-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes.+sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b)+     => Value a -> CodeGenFunction r (Value b)+sadapt =+   case compare (sizeOf (typeDesc (undefined :: a)))+                (sizeOf (typeDesc (undefined :: b))) of+      LT -> convert FFI.buildSExt+      EQ -> convert FFI.buildBitCast+      GT -> convert FFI.buildTrunc++-- | It is 'sadapt' or 'zadapt' depending on the sign mode.+adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b)+     => Value a -> CodeGenFunction r (Value b)+adapt =+   case compare (sizeOf (typeDesc (undefined :: a)))+                (sizeOf (typeDesc (undefined :: b))) of+      LT ->+         if isSigned (undefined :: b)+           then convert FFI.buildSExt+           else convert FFI.buildZExt+      EQ -> convert FFI.buildBitCast+      GT -> convert FFI.buildTrunc++-- | Truncate a floating point value.+fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b))+        => Value a -> CodeGenFunction r (Value b)+fptrunc = convert FFI.buildFPTrunc++-- | Extend a floating point value.+fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b))+      => Value a -> CodeGenFunction r (Value b)+fpext = convert FFI.buildFPExt++{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-}+-- | Convert a floating point value to an unsigned integer.+fptoui :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)+fptoui = convert FFI.buildFPToUI++{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-}+-- | Convert a floating point value to a signed integer.+fptosi :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)+fptosi = convert FFI.buildFPToSI++-- | Convert a floating point value to an integer.+-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@.+fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)+fptoint =+   if isSigned (undefined :: b)+     then convert FFI.buildFPToSI+     else convert FFI.buildFPToUI+++{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -}+-- | Convert an unsigned integer to a floating point value.+-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.+uitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)+uitofp = convert FFI.buildUIToFP++{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -}+-- | Convert a signed integer to a floating point value.+-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool.+sitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)+sitofp = convert FFI.buildSIToFP++-- | Convert an integer to a floating point value.+-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@.+inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b)+inttofp =+   if isSigned (undefined :: a)+     then convert FFI.buildSIToFP+     else convert FFI.buildUIToFP+++-- | Convert a pointer to an integer.+ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b)+ptrtoint = convert FFI.buildPtrToInt++-- | Convert an integer to a pointer.+inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b))+inttoptr = convert FFI.buildIntToPtr++-- | Convert between to values of the same size by just copying the bit pattern.+bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)+        => Value a -> CodeGenFunction r (Value b)+bitcast = convert FFI.buildBitCast++-- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same.+bitcastElements :: (PositiveT n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b)+        => Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))+bitcastElements = convert FFI.buildBitCast+++type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef++convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b)+convert conv (Value a) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b))++--------------------------------------++data CmpPredicate =+    CmpEQ                       -- ^ equal+  | CmpNE                       -- ^ not equal+  | CmpGT                       -- ^ greater than+  | CmpGE                       -- ^ greater or equal+  | CmpLT                       -- ^ less than+  | CmpLE                       -- ^ less or equal+    deriving (Eq, Ord, Enum, Show, Typeable)++uintFromCmpPredicate :: CmpPredicate -> IntPredicate+uintFromCmpPredicate p =+   case p of+      CmpEQ -> IntEQ+      CmpNE -> IntNE+      CmpGT -> IntUGT+      CmpGE -> IntUGE+      CmpLT -> IntULT+      CmpLE -> IntULE++sintFromCmpPredicate :: CmpPredicate -> IntPredicate+sintFromCmpPredicate p =+   case p of+      CmpEQ -> IntEQ+      CmpNE -> IntNE+      CmpGT -> IntSGT+      CmpGE -> IntSGE+      CmpLT -> IntSLT+      CmpLE -> IntSLE++fpFromCmpPredicate :: CmpPredicate -> FPPredicate+fpFromCmpPredicate p =+   case p of+      CmpEQ -> FPOEQ+      CmpNE -> FPONE+      CmpGT -> FPOGT+      CmpGE -> FPOGE+      CmpLT -> FPOLT+      CmpLE -> FPOLE+++data IntPredicate =+    IntEQ                       -- ^ equal+  | IntNE                       -- ^ not equal+  | IntUGT                      -- ^ unsigned greater than+  | IntUGE                      -- ^ unsigned greater or equal+  | IntULT                      -- ^ unsigned less than+  | IntULE                      -- ^ unsigned less or equal+  | IntSGT                      -- ^ signed greater than+  | IntSGE                      -- ^ signed greater or equal+  | IntSLT                      -- ^ signed less than+  | IntSLE                      -- ^ signed less or equal+    deriving (Eq, Ord, Enum, Show, Typeable)++fromIntPredicate :: IntPredicate -> CInt+fromIntPredicate p = fromIntegral (fromEnum p + 32)++toIntPredicate :: CInt -> IntPredicate+toIntPredicate p = toEnum $ fromIntegral p - 32++data FPPredicate =+    FPFalse           -- ^ Always false (always folded)+  | FPOEQ             -- ^ True if ordered and equal+  | FPOGT             -- ^ True if ordered and greater than+  | FPOGE             -- ^ True if ordered and greater than or equal+  | FPOLT             -- ^ True if ordered and less than+  | FPOLE             -- ^ True if ordered and less than or equal+  | FPONE             -- ^ True if ordered and operands are unequal+  | FPORD             -- ^ True if ordered (no nans)+  | FPUNO             -- ^ True if unordered: isnan(X) | isnan(Y)+  | FPUEQ             -- ^ True if unordered or equal+  | FPUGT             -- ^ True if unordered or greater than+  | FPUGE             -- ^ True if unordered, greater than, or equal+  | FPULT             -- ^ True if unordered or less than+  | FPULE             -- ^ True if unordered, less than, or equal+  | FPUNE             -- ^ True if unordered or not equal+  | FPT               -- ^ Always true (always folded)+    deriving (Eq, Ord, Enum, Show, Typeable)++fromFPPredicate :: FPPredicate -> CInt+fromFPPredicate p = fromIntegral (fromEnum p)++toFPPredicate :: CInt -> FPPredicate+toFPPredicate p = toEnum $ fromIntegral p++-- |Acceptable operands to comparison instructions.+class CmpRet (CmpType a b) => CmpOp a b where+    type CmpType a b :: *+    cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (CmpType a b)))++instance (CmpRet a) => CmpOp (Value a) (Value a) where+    type CmpType (Value a) (Value a) = a+    cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2++{-+instance (IsConst a, CmpRet a) => CmpOp a (Value a) where+    type CmpType a (Value a) = a+    cmpop op a1 a2 = cmpop op (valueOf a1) a2++instance (IsConst a, CmpRet a) => CmpOp (Value a) a where+    type CmpType (Value a) a = a+    cmpop op a1 a2 = cmpop op a1 (valueOf a2)+-}++class CmpRet c where+    type CmpResult c :: *+    cmpBld :: c -> CmpPredicate -> FFIBinOp++instance CmpRet Float   where type CmpResult Float   = Bool ; cmpBld _ = fcmpBld+instance CmpRet Double  where type CmpResult Double  = Bool ; cmpBld _ = fcmpBld+instance CmpRet FP128   where type CmpResult FP128   = Bool ; cmpBld _ = fcmpBld+instance CmpRet Bool    where type CmpResult Bool    = Bool ; cmpBld _ = ucmpBld+instance CmpRet Word8   where type CmpResult Word8   = Bool ; cmpBld _ = ucmpBld+instance CmpRet Word16  where type CmpResult Word16  = Bool ; cmpBld _ = ucmpBld+instance CmpRet Word32  where type CmpResult Word32  = Bool ; cmpBld _ = ucmpBld+instance CmpRet Word64  where type CmpResult Word64  = Bool ; cmpBld _ = ucmpBld+instance CmpRet Int8    where type CmpResult Int8    = Bool ; cmpBld _ = scmpBld+instance CmpRet Int16   where type CmpResult Int16   = Bool ; cmpBld _ = scmpBld+instance CmpRet Int32   where type CmpResult Int32   = Bool ; cmpBld _ = scmpBld+instance CmpRet Int64   where type CmpResult Int64   = Bool ; cmpBld _ = scmpBld+instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld+instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a)+    where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; cmpBld _ = cmpBld (undefined :: a)+++{- |+Compare values of ordered types+and choose predicates according to the compared types.+Floating point numbers are compared in \"ordered\" mode,+that is @NaN@ operands yields 'False' as result.+Pointers are compared unsigned.+These choices are consistent with comparison in plain Haskell.+-}+cmp :: forall a b c r.+   (CmpOp a b, c ~ CmpType a b) =>+   CmpPredicate -> a -> b ->+   CodeGenFunction r (Value (CmpResult c))+cmp p = cmpop (cmpBld (undefined :: CmpType a b) p)++ucmpBld :: CmpPredicate -> FFIBinOp+ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))++scmpBld :: CmpPredicate -> FFIBinOp+scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))++fcmpBld :: CmpPredicate -> FFIBinOp+fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p))+++_ucmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>+        CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))+_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)))++_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) =>+        CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))+_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)))++pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) =>+        IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c)))+pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))+++{-# DEPRECATED icmp "use cmp or pcmp instead" #-}+-- | Compare integers.+icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) =>+        IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))+icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p))++-- | Compare floating point values.+fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) =>+        FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c))+fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p))++--------------------------------------++-- XXX could do const song and dance+-- | Select between two values depending on a boolean.+select :: (IsFirstClass a, CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a)+select (Value cnd) (Value thn) (Value els) =+    liftM Value $+      withCurrentBuilder $ \ bldPtr ->+        U.withEmptyCString $+          FFI.buildSelect bldPtr cnd thn els++--------------------------------------++type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef++{-+Function (a -> b -> IO c)+Value a -> Value b -> CodeGenFunction r c+-}++-- |Acceptable arguments to 'call'.+class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>+         CallArgs f g r where+    type CalledFunction g :: *+    type CallerResult g :: *+    type CallerFunction f r :: *+    doCall :: Call f -> g++instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where+    type CalledFunction (Value a -> b') = a -> CalledFunction b'+    type CallerResult (Value a -> b') = CallerResult b'+    type CallerFunction (a -> b) r = Value a -> CallerFunction b r+    doCall f a = doCall (applyCall f a)++--instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where+--    doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a))++instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where+    type CalledFunction (CodeGenFunction r (Value a)) = IO a+    type CallerResult (CodeGenFunction r (Value a)) = r+    type CallerFunction (IO a) r = CodeGenFunction r (Value a)+    doCall = runCall++doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a)+doCallDef mkCall args _ =+    withCurrentBuilder $ \ bld ->+      liftM Value $ mkCall bld (reverse args)++-- | Call a function with the given arguments.  The 'call' instruction is variadic, i.e., the number of arguments+-- it takes depends on the type of /f/.+call :: (CallArgs f g r) => Function f -> g+call = doCall . callFromFunction++data Call a = Call Caller [FFI.ValueRef]++callFromFunction :: Function a -> Call a+callFromFunction (Value f) = Call (U.makeCall f) []++-- like Applicative.<*>+infixl 4 `applyCall`++applyCall :: Call (a -> b) -> Value a -> Call b+applyCall (Call mkCall args) (Value arg) = Call mkCall (arg:args)++runCall :: Call (IO a) -> CodeGenFunction r (Value a)+runCall (Call mkCall args) = doCallDef mkCall args ()+++invokeFromFunction ::+          BasicBlock         -- ^Normal return point.+       -> BasicBlock         -- ^Exception return point.+       -> Function f         -- ^Function to call.+       -> Call f+invokeFromFunction (BasicBlock norm) (BasicBlock expt) (Value f) =+    Call (U.makeInvoke norm expt f) []++-- | Call a function with exception handling.+invoke :: (CallArgs f g r)+       => BasicBlock         -- ^Normal return point.+       -> BasicBlock         -- ^Exception return point.+       -> Function f         -- ^Function to call.+       -> g+invoke norm expt f = doCall $ invokeFromFunction norm expt f++callWithConvFromFunction :: FFI.CallingConvention -> Function f -> Call f+callWithConvFromFunction cc (Value f) =+    Call (U.makeCallWithCc cc f) []++-- | Call a function with the given arguments.  The 'call' instruction+-- is variadic, i.e., the number of arguments it takes depends on the+-- type of /f/.+-- This also sets the calling convention of the call to the function.+-- As LLVM itself defines, if the calling conventions of the calling+-- /instruction/ and the function being /called/ are different, undefined+-- behavior results.+callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g+callWithConv cc f = doCall $ callWithConvFromFunction cc f++invokeWithConvFromFunction ::+          FFI.CallingConvention -- ^Calling convention+       -> BasicBlock         -- ^Normal return point.+       -> BasicBlock         -- ^Exception return point.+       -> Function f         -- ^Function to call.+       -> Call f+invokeWithConvFromFunction cc (BasicBlock norm) (BasicBlock expt) (Value f) =+    Call (U.makeInvokeWithCc cc norm expt f) []++-- | Call a function with exception handling.+-- This also sets the calling convention of the call to the function.+-- As LLVM itself defines, if the calling conventions of the calling+-- /instruction/ and the function being /called/ are different, undefined+-- behavior results.+invokeWithConv :: (CallArgs f g r)+               => FFI.CallingConvention -- ^Calling convention+               -> BasicBlock         -- ^Normal return point.+               -> BasicBlock         -- ^Exception return point.+               -> Function f         -- ^Function to call.+               -> g+invokeWithConv cc norm expt f =+    doCall $ invokeWithConvFromFunction cc norm expt f++--------------------------------------++-- XXX could do const song and dance+-- |Join several variables (virtual registers) from different basic blocks into one.+-- All of the variables in the list are joined.  See also 'addPhiInputs'.+phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a)+phi incoming =+    liftM Value $+      withCurrentBuilder $ \ bldPtr -> do+        inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a))+        U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]+        return inst++-- |Add additional inputs to an existing phi node.+-- The reason for this instruction is that sometimes the structure of the code+-- makes it impossible to have all variables in scope at the point where you need the phi node.+addPhiInputs :: forall a r . (IsFirstClass a)+             => Value a                      -- ^Must be a variable from a call to 'phi'.+             -> [(Value a, BasicBlock)]      -- ^Variables to add.+             -> CodeGenFunction r ()+addPhiInputs (Value inst) incoming =+    liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ]+++--------------------------------------++-- | Acceptable argument to array memory allocation.+class AllocArg a where+    getAllocArg :: a -> Value Word32+instance AllocArg (Value Word32) where+    getAllocArg = id+instance AllocArg (ConstValue Word32) where+    getAllocArg = value+instance AllocArg Word32 where+    getAllocArg = valueOf++-- could be moved to Util.Memory+-- FFI.buildMalloc deprecated since LLVM-2.7+-- XXX What's the type returned by malloc+-- | Allocate heap memory.+malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))+malloc = arrayMalloc (1::Word32)++{-+I use a pointer type as size parameter of 'malloc'.+This way I hope that the parameter has always the correct size (32 or 64 bit).+A side effect is that we can convert the result of 'getelementptr' using 'bitcast',+that does not suffer from the slow assembly problem. (bug #8281)+-}+foreign import ccall "&aligned_malloc_sizeptr"+   alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))++foreign import ccall "&aligned_free"+   alignedFree :: FunPtr (Ptr Word8 -> IO ())+++{-+There is a bug in LLVM-2.7 and LLVM-2.8+(http://llvm.org/bugs/show_bug.cgi?id=8281)+that causes huge assembly times for expressions like+ptrtoint(getelementptr(zero,..)).+If you break those expressions into two statements+at separate lines, everything is fine.+But the C interface is too clever,+and rewrites two separate statements into a functional expression on a single line.+Such code is generated whenever you call+buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf.+One possible way is to write a getelementptr expression+containing a nullptr in a way+that hides the constant nature of nullptr.++    ptr <- alloca+    store (value zero) ptr+    z <- load ptr+    size <- bitcast =<<+       getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ())++However, I found that bitcast on pointers causes no problems.+Thus I switched to using pointers for size quantities.+This still allows for optimizations involving pointers.+-}++-- XXX What's the type returned by arrayMalloc?+-- | Allocate heap (array) memory.+arrayMalloc :: forall a r s . (IsSized a, AllocArg s) =>+               s -> CodeGenFunction r (Value (Ptr a)) -- XXX+arrayMalloc s = do+    func <- staticFunction alignedMalloc+--    func <- externFunction "malloc"++    size <- sizeOfArray (undefined :: a) (getAllocArg s)+    alignment <- alignOf (undefined :: a)+    bitcast =<<+       call+          (func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)))+          size+          alignment++-- XXX What's the type returned by malloc+-- | Allocate stack memory.+alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a))+alloca =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a))++-- XXX What's the type returned by arrayAlloca?+-- | Allocate stack (array) memory.+arrayAlloca :: forall a r s . (IsSized a, AllocArg s) =>+               s -> CodeGenFunction r (Value (Ptr a))+arrayAlloca s =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $+        FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (case getAllocArg s of Value v -> v)++-- FFI.buildFree deprecated since LLVM-2.7+-- XXX What's the type of free?+-- | Free heap memory.+free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r ()+free ptr = do+    func <- staticFunction alignedFree+--    func <- externFunction "free"+    _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr+    return ()+++-- | If we want to export that, then we should have a Size type+-- This is the official implementation,+-- but it suffers from the ptrtoint(gep) bug.+_sizeOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64)+_sizeOf a =+    liftIO $ liftM Value $+    FFI.sizeOf (typeRef a)++_alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64)+_alignOf a =+    liftIO $ liftM Value $+    FFI.alignOf (typeRef a)+++-- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281.+-- see ConstantExpr::getSizeOf+sizeOfArray :: forall a r . (IsSized a) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8))+sizeOfArray _ len =+    bitcast =<<+       getElementPtr (value zero :: Value (Ptr a)) (len, ())++-- see ConstantExpr::getAlignOf+alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value (Ptr Word8))+alignOf _ =+    bitcast =<<+       getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ())+++-- | Load a value from memory.+load :: Value (Ptr a)                   -- ^ Address to load from.+     -> CodeGenFunction r (Value a)+load (Value p) =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withEmptyCString $ FFI.buildLoad bldPtr p++-- | Store a value in memory+store :: Value a                        -- ^ Value to store.+      -> Value (Ptr a)                  -- ^ Address to store to.+      -> CodeGenFunction r ()+store (Value v) (Value p) = do+    withCurrentBuilder_ $ \ bldPtr ->+      FFI.buildStore bldPtr v p+    return ()++{-+-- XXX type is wrong+-- | Address arithmetic.  See LLVM description.+-- (The type isn't as accurate as it should be.)+getElementPtr :: (IsInteger i) =>+                 Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b))+getElementPtr (Value ptr) ixs =+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr ->+        U.withEmptyCString $+          FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)+-}++-- |Acceptable arguments to 'getElementPointer'.+class GetElementPtr optr ixs where+    type ElementPtrType optr ixs :: *+    getIxList :: optr -> ixs -> [FFI.ValueRef]++-- |Acceptable single index to 'getElementPointer'.+class IsIndexArg a where+    getArg :: a -> FFI.ValueRef++instance IsIndexArg (Value Word32) where+    getArg (Value v) = v++instance IsIndexArg (Value Word64) where+    getArg (Value v) = v++instance IsIndexArg (Value Int32) where+    getArg (Value v) = v++instance IsIndexArg (Value Int64) where+    getArg (Value v) = v++instance IsIndexArg (ConstValue Word32) where+    getArg = unConst++instance IsIndexArg (ConstValue Word64) where+    getArg = unConst++instance IsIndexArg (ConstValue Int32) where+    getArg = unConst++instance IsIndexArg (ConstValue Int64) where+    getArg = unConst++instance IsIndexArg Word32 where+    getArg = unConst . constOf++instance IsIndexArg Word64 where+    getArg = unConst . constOf++instance IsIndexArg Int32 where+    getArg = unConst . constOf++instance IsIndexArg Int64 where+    getArg = unConst . constOf++unConst :: ConstValue a -> FFI.ValueRef+unConst (ConstValue v) = v++-- End of indexing+instance GetElementPtr a () where+    type ElementPtrType a () = a+    getIxList _ () = []++-- Index in Array+instance (GetElementPtr o i, IsIndexArg a, NaturalT k) => GetElementPtr (Array k o) (a, i) where+    type ElementPtrType (Array k o) (a, i) = ElementPtrType o i+    getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i++-- Index in Vector+instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where+    type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i+    getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i++-- Index in Struct and PackedStruct.+-- The index has to be a type level integer to statically determine the record field type+instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (Struct fs) (a, i) where+    type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i+    getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i+instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where+    type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i+    getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i++class GetField as i where type FieldType as i :: *+instance GetField (a, as) (Dec DecN) where type FieldType (a, as) (Dec DecN) = a+instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0)))++-- | Address arithmetic.  See LLVM description.+-- The index is a nested tuple of the form @(i1,(i2,( ... ())))@.+-- (This is without a doubt the most confusing LLVM instruction, but the types help.)+getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) =>+                 Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))+getElementPtr (Value ptr) (a, ixs) =+    let ixl = getArg a : getIxList (undefined :: o) ixs in+    liftM Value $+    withCurrentBuilder $ \ bldPtr ->+      U.withArrayLen ixl $ \ idxLen idxPtr ->+        U.withEmptyCString $+          FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen)++-- | Like getElementPtr, but with an initial index that is 0.+-- This is useful since any pointer first need to be indexed off the pointer, and then into+-- its actual value.  This first indexing is often with 0.+getElementPtr0 :: (GetElementPtr o i) =>+                  Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i)))+getElementPtr0 p i = getElementPtr p (0::Word32, i)++--------------------------------------+{-+instance (IsConst a) => Show (ConstValue a) -- XXX+instance (IsConst a) => Eq (ConstValue a)++{-+instance (IsConst a) => Eq (ConstValue a) where+    ConstValue x == ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOEQ) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y)+    ConstValue x /= ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPONE) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y)++instance (IsConst a) => Ord (ConstValue a) where+    ConstValue x <  ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOLT) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y)+    ConstValue x <= ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOLE) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y)+    ConstValue x >  ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOGT) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y)+    ConstValue x >= ConstValue y  =+        if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate  FPOGE) x y)+                        else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y)+-}++instance (Num a, IsConst a) => Num (ConstValue a) where+    ConstValue x + ConstValue y  =  ConstValue (FFI.constAdd x y)+    ConstValue x - ConstValue y  =  ConstValue (FFI.constSub x y)+    ConstValue x * ConstValue y  =  ConstValue (FFI.constMul x y)+    negate (ConstValue x)        =  ConstValue (FFI.constNeg x)+    fromInteger x                =  constOf (fromInteger x :: a)+-}
+ src/LLVM/Core/Type.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+-- |The LLVM type system is captured with a number of Haskell type classes.+-- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type.+-- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for+-- those types that are LLVM first class types (passable as arguments etc).+-- All valid LLVM types belong to the 'IsType' class.+module LLVM.Core.Type(+    -- * Type classifier+    IsType(..),+    -- ** Special type classifiers+    NaturalT,+    PositiveT,+    IsArithmetic(arithmeticType),+    ArithmeticType(IntegerType,FloatingType),+    IsInteger, Signed,+    IsIntegerOrPointer,+    IsFloating,+    IsPrimitive,+    IsFirstClass,+    IsSized, SizeOf, sizeOf,+    IsFunction,+    -- ** Others+    IsScalarOrVector, NumberOfElements,+    UnknownSize, -- needed for arrays of structs+    -- ** Structs+    (:&), (&),+    -- ** Type tests+    TypeDesc(..),+    isFloating,+    isSigned,+    typeRef,+    typeName,+    intrinsicTypeName,+    typeDesc2,+    VarArgs, CastVarArgs,+    ) where++import qualified LLVM.FFI.Core as FFI++import LLVM.Core.Util (functionType, structType)+import LLVM.Core.Data++import Types.Data.Num+import Types.Data.Bool (True, False)++import Foreign.StablePtr (StablePtr, )++import Data.Typeable (Typeable)+import Data.List (intercalate)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Word (Word8, Word16, Word32, Word64)+++#include "MachDeps.h"++-- TODO:+-- Move IntN, WordN to a special module that implements those types+--   properly in Haskell.+-- Also more Array and Vector to a Haskell module to implement them.+-- Add Label?+-- Add structures (using tuples, maybe nested).++-- |The 'IsType' class classifies all types that have an LLVM representation.+class IsType a where+    typeDesc :: a -> TypeDesc++typeRef :: (IsType a) => a -> FFI.TypeRef  -- ^The argument is never evaluated+typeRef = code . typeDesc+  where code TDFloat  = FFI.floatType+  	code TDDouble = FFI.doubleType+	code TDFP128  = FFI.fP128Type+	code TDVoid   = FFI.voidType+	code (TDInt _ n)  = FFI.integerType (fromInteger n)+	code (TDArray n a) = FFI.arrayType (code a) (fromInteger n)+	code (TDVector n a) = FFI.vectorType (code a) (fromInteger n)+	code (TDPtr a) = FFI.pointerType (code a) 0+	code (TDFunction va as b) = functionType va (code b) (map code as)+	code TDLabel = FFI.labelType+        code (TDStruct ts packed) = structType (map code ts) packed+        code TDInvalidType = error "typeRef TDInvalidType"++typeName :: (IsType a) => a -> String+typeName = code . typeDesc+  where code TDFloat  = "f32"+  	code TDDouble = "f64"+	code TDFP128  = "f128"+	code TDVoid   = "void"+	code (TDInt _ n)  = "i" ++ show n+	code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]"+	code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">"+	code (TDPtr a) = code a ++ "*"+	code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")"+        code TDLabel = "label"+        code (TDStruct as packed) = (if packed then "<{" else "{") +++                                    intercalate "," (map code as) +++                                    (if packed then "}>" else "}")+        code TDInvalidType = error "typeName TDInvalidType"++intrinsicTypeName :: (IsType a) => a -> String+intrinsicTypeName = code . typeDesc+  where code TDFloat  = "f32"+        code TDDouble = "f64"+        code TDFP128  = "f128"+        code (TDInt _ n)  = "i" ++ show n+        code (TDVector n a) = "v" ++ show n ++ code a+        code _ = error "intrinsicTypeName: type not supported in intrinsics"++typeDesc2 :: FFI.TypeRef -> IO TypeDesc+typeDesc2 t = do+    tk <- FFI.getTypeKind t+    case tk of+      FFI.VoidTypeKind -> return TDVoid+      FFI.FloatTypeKind -> return TDFloat+      FFI.DoubleTypeKind -> return TDDouble+      -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80"+      FFI.FP128TypeKind -> return TDFP128+      -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128"+      FFI.LabelTypeKind -> return TDLabel+      FFI.IntegerTypeKind -> do+                n <- FFI.getIntTypeWidth t+                return $ TDInt False (fromIntegral n)+      -- FIXME: FFI.FunctionTypeKind+      -- FIXME: FFI.StructTypeKind -> return "(Struct ...)"+      FFI.ArrayTypeKind -> do+                n <- FFI.getArrayLength t+                et <- FFI.getElementType t+                etd <- typeDesc2 et+                return $ TDArray (fromIntegral n) etd+      FFI.PointerTypeKind -> do+                et <- FFI.getElementType t+                etd <- typeDesc2 et+                return $ TDPtr etd+      -- FIXME: FFI.OpaqueTypeKind -> return "Opaque"+      FFI.VectorTypeKind -> do+                n <- FFI.getVectorSize t+                et <- FFI.getElementType t+                etd <- typeDesc2 et+                return $ TDVector (fromIntegral n) etd+      -- FIXME: LLVMMetadataTypeKind,    /**< Metadata */+      -- FIXME: LLVMX86_MMXTypeKind      /**< X86 MMX */+      _ -> return TDInvalidType++-- |Type descriptor, used to convey type information through the LLVM API.+data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer+              | TDArray Integer TypeDesc | TDVector Integer TypeDesc+	      | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel+              | TDStruct [TypeDesc] Bool | TDInvalidType+    deriving (Eq, Ord, Show, Typeable)++-- XXX isFloating and typeName could be extracted from typeRef+-- Usage:+--   superclass of IsConst+--   add, sub, mul, neg context+--   used to get type name to call intrinsic+-- |Arithmetic types, i.e., integral and floating types.+class IsFirstClass a => IsArithmetic a where+    arithmeticType :: ArithmeticType a++data ArithmeticType a = IntegerType | FloatingType++instance Functor ArithmeticType where+    fmap _ IntegerType  = IntegerType+    fmap _ FloatingType = FloatingType++-- Usage:+--  constI, allOnes+--  many instructions.  XXX some need vector+--  used to find signedness in Arithmetic+-- |Integral types.+class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where+   type Signed a :: *++-- Usage:+--  icmp+-- |Integral or pointer type.+class IsIntegerOrPointer a++isSigned :: (IsInteger a) => a -> Bool+isSigned = is . typeDesc+  where is (TDInt s _) = s+  	is (TDVector _ a) = is a+	is _ = error "isSigned got impossible input"++-- Usage:+--  constF+--  many instructions+-- |Floating types.+class IsArithmetic a => IsFloating a++isFloating :: (IsArithmetic a) => a -> Bool+isFloating = is . typeDesc+  where is TDFloat = True+  	is TDDouble = True+	is TDFP128 = True+	is (TDVector _ a) = is a+	is _ = False++-- Usage:+--  Precondition for Vector+-- |Primitive types.+-- class (IsType a) => IsPrimitive a+class (IsType a, NumberOfElements a ~ D1) => IsPrimitive a++-- |Number of elements for instructions that handle both primitive and vector types+class (IsType a) => IsScalarOrVector a where+    type NumberOfElements a :: *+++-- Usage:+--  Precondition for function args and result.+--  Used by some instructions, like ret and phi.+--  XXX IsSized as precondition?+-- |First class types, i.e., the types that can be passed as arguments, etc.+class IsType a => IsFirstClass a++-- Usage:+--  Context for Array being a type+--  thus, allocation instructions+-- |Types with a fixed size.+class (IsType a, PositiveT (SizeOf a)) => IsSized a where+    type SizeOf a :: *++sizeOf :: TypeDesc -> Integer+sizeOf TDFloat  = 32+sizeOf TDDouble = 64+sizeOf TDFP128  = 128+sizeOf (TDInt _ bits) = bits+sizeOf (TDArray n typ) = n * sizeOf typ+sizeOf (TDVector n typ) = n * sizeOf typ+sizeOf (TDStruct ts _packed) = sum (map sizeOf ts)+sizeOf _ = error "type has no size"++-- |Function type.+class (IsType a) => IsFunction a where+    funcType :: [TypeDesc] -> a -> TypeDesc++-- Only make instances for types that make sense in Haskell+-- (i.e., some floating types are excluded).++-- Floating point types.+instance IsType Float  where typeDesc _ = TDFloat+instance IsType Double where typeDesc _ = TDDouble+instance IsType FP128  where typeDesc _ = TDFP128++-- Void type+instance IsType ()     where typeDesc _ = TDVoid++-- Label type+instance IsType Label  where typeDesc _ = TDLabel++-- Variable size integer types+instance (PositiveT n) => IsType (IntN n)+    where typeDesc _ = TDInt True  (fromIntegerT (undefined :: n))++instance (PositiveT n) => IsType (WordN n)+    where typeDesc _ = TDInt False (fromIntegerT (undefined :: n))++-- Fixed size integer types.+instance IsType Bool   where typeDesc _ = TDInt False  1+instance IsType Word8  where typeDesc _ = TDInt False  8+instance IsType Word16 where typeDesc _ = TDInt False 16+instance IsType Word32 where typeDesc _ = TDInt False 32+instance IsType Word64 where typeDesc _ = TDInt False 64+instance IsType Int8   where typeDesc _ = TDInt True   8+instance IsType Int16  where typeDesc _ = TDInt True  16+instance IsType Int32  where typeDesc _ = TDInt True  32+instance IsType Int64  where typeDesc _ = TDInt True  64++-- Sequence types+instance (NaturalT n, IsSized a) => IsType (Array n a)+    where typeDesc _ = TDArray (fromIntegerT (undefined :: n))+    	  	               (typeDesc (undefined :: a))+instance (PositiveT n, IsPrimitive a) => IsType (Vector n a)+    where typeDesc _ = TDVector (fromIntegerT (undefined :: n))+    	  	       		(typeDesc (undefined :: a))++-- Pointer type.+instance (IsType a) => IsType (Ptr a) where+    typeDesc _ = TDPtr (typeDesc (undefined :: a))++instance IsType (StablePtr a) where+    typeDesc _ = TDPtr (typeDesc (undefined :: Int8))+{-+    typeDesc _ = TDPtr TDVoid++List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed.+-}+++-- Functions.+instance (IsFirstClass a, IsFunction b) => IsType (a->b) where+    typeDesc = funcType []++-- Function base type, always IO.+instance (IsFirstClass a) => IsType (IO a) where+    typeDesc = funcType []++-- Struct types, basically a list of component types.+instance (StructFields a) => IsType (Struct a) where+    typeDesc ~(Struct a) = TDStruct (fieldTypes a) False++instance (StructFields a) => IsType (PackedStruct a) where+    typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True++-- Use a nested tuples for struct fields.+class StructFields as where+    fieldTypes :: as -> [TypeDesc]++instance (IsSized a, StructFields as) => StructFields (a :& as) where+    fieldTypes ~(a, as) = typeDesc a : fieldTypes as+instance StructFields () where+    fieldTypes _ = []++-- An alias for pairs to make structs look nicer+infixr :&+type (:&) a as = (a, as)+infixr &+(&) :: a -> as -> a :& as+a & as = (a, as)++--- Instances to classify types+instance IsArithmetic Float  where arithmeticType = FloatingType+instance IsArithmetic Double where arithmeticType = FloatingType+instance IsArithmetic FP128  where arithmeticType = FloatingType+instance (PositiveT n) => IsArithmetic (IntN n)  where arithmeticType = IntegerType+instance (PositiveT n) => IsArithmetic (WordN n) where arithmeticType = IntegerType+instance IsArithmetic Bool   where arithmeticType = IntegerType+instance IsArithmetic Int8   where arithmeticType = IntegerType+instance IsArithmetic Int16  where arithmeticType = IntegerType+instance IsArithmetic Int32  where arithmeticType = IntegerType+instance IsArithmetic Int64  where arithmeticType = IntegerType+instance IsArithmetic Word8  where arithmeticType = IntegerType+instance IsArithmetic Word16 where arithmeticType = IntegerType+instance IsArithmetic Word32 where arithmeticType = IntegerType+instance IsArithmetic Word64 where arithmeticType = IntegerType+instance (PositiveT n, IsPrimitive a, IsArithmetic a) =>+         IsArithmetic (Vector n a) where+   arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType++instance IsFloating Float+instance IsFloating Double+instance IsFloating FP128+instance (PositiveT n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a)++data NotANumber++instance (PositiveT n) => IsInteger (IntN  n) where type Signed (IntN  n) = True+instance (PositiveT n) => IsInteger (WordN n) where type Signed (WordN n) = False+instance IsInteger Bool   where type Signed Bool = NotANumber+instance IsInteger Int8   where type Signed Int8 = True+instance IsInteger Int16  where type Signed Int16 = True+instance IsInteger Int32  where type Signed Int32 = True+instance IsInteger Int64  where type Signed Int64 = True+instance IsInteger Word8  where type Signed Word8 = False+instance IsInteger Word16 where type Signed Word16 = False+instance IsInteger Word32 where type Signed Word32 = False+instance IsInteger Word64 where type Signed Word64 = False+instance (PositiveT n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a)+                          where type Signed (Vector n a) = Signed a++instance (PositiveT n) => IsIntegerOrPointer (IntN n)+instance (PositiveT n) => IsIntegerOrPointer (WordN n)+instance IsIntegerOrPointer Bool+instance IsIntegerOrPointer Int8+instance IsIntegerOrPointer Int16+instance IsIntegerOrPointer Int32+instance IsIntegerOrPointer Int64+instance IsIntegerOrPointer Word8+instance IsIntegerOrPointer Word16+instance IsIntegerOrPointer Word32+instance IsIntegerOrPointer Word64+instance (PositiveT n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a)+instance (IsType a) => IsIntegerOrPointer (Ptr a)++instance IsFirstClass Float+instance IsFirstClass Double+instance IsFirstClass FP128+instance (PositiveT n) => IsFirstClass (IntN n)+instance (PositiveT n) => IsFirstClass (WordN n)+instance IsFirstClass Bool+instance IsFirstClass Int8+instance IsFirstClass Int16+instance IsFirstClass Int32+instance IsFirstClass Int64+instance IsFirstClass Word8+instance IsFirstClass Word16+instance IsFirstClass Word32+instance IsFirstClass Word64+instance (PositiveT n, IsPrimitive a) => IsFirstClass (Vector n a)+instance (NaturalT n, IsSized a) => IsFirstClass (Array n a)+instance (IsType a) => IsFirstClass (Ptr a)+instance IsFirstClass (StablePtr a)+instance IsFirstClass Label+instance IsFirstClass () -- XXX This isn't right, but () can be returned+instance (StructFields as) => IsFirstClass (Struct as)++instance (PositiveT n) => IsSized (IntN n)  where type SizeOf (IntN  n) = n+instance (PositiveT n) => IsSized (WordN n) where type SizeOf (WordN n) = n+instance IsSized Float  where type SizeOf Float  = D32+instance IsSized Double where type SizeOf Double = D64+instance IsSized FP128  where type SizeOf FP128  = D128+instance IsSized Bool   where type SizeOf Bool   = D1+instance IsSized Int8   where type SizeOf Int8   = D8+instance IsSized Int16  where type SizeOf Int16  = D16+instance IsSized Int32  where type SizeOf Int32  = D32+instance IsSized Int64  where type SizeOf Int64  = D64+instance IsSized Word8  where type SizeOf Word8  = D8+instance IsSized Word16 where type SizeOf Word16 = D16+instance IsSized Word32 where type SizeOf Word32 = D32+instance IsSized Word64 where type SizeOf Word64 = D64+instance (NaturalT n, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Array n a) where+    type SizeOf (Array n a) = n :*: SizeOf a+instance (PositiveT n, IsPrimitive a, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Vector n a) where+    type SizeOf (Vector n a) = n :*: SizeOf a+instance (IsType a) => IsSized (Ptr a) where type SizeOf (Ptr a) = PtrSize+instance IsSized (StablePtr a) where type SizeOf (StablePtr a) =  PtrSize+-- instance IsSized Label PtrSize -- labels are not quite first classed+-- We cannot compute the sizes statically :(+instance (StructFields as) => IsSized (Struct as) where+    type SizeOf (Struct as) = UnknownSize+instance (StructFields as) => IsSized (PackedStruct as) where+    type SizeOf (PackedStruct as) = UnknownSize++type UnknownSize = D99   -- XXX this is wrong!++#if WORD_SIZE_IN_BITS == 32+type PtrSize = D32+#elif WORD_SIZE_IN_BITS == 64+type PtrSize = D64+#else+#error cannot determine type of PtrSize+#endif++instance IsPrimitive Float+instance IsPrimitive Double+instance IsPrimitive FP128+instance (PositiveT n) => IsPrimitive (IntN n)+instance (PositiveT n) => IsPrimitive (WordN n)+instance IsPrimitive Bool+instance IsPrimitive Int8+instance IsPrimitive Int16+instance IsPrimitive Int32+instance IsPrimitive Int64+instance IsPrimitive Word8+instance IsPrimitive Word16+instance IsPrimitive Word32+instance IsPrimitive Word64+instance IsPrimitive Label+instance IsPrimitive ()+++instance (PositiveT n) =>+         IsScalarOrVector (IntN n)  where type NumberOfElements (IntN n)  = D1+instance (PositiveT n) =>+         IsScalarOrVector (WordN n) where type NumberOfElements (WordN n) = D1+instance IsScalarOrVector Float  where type NumberOfElements Float  = D1+instance IsScalarOrVector Double where type NumberOfElements Double = D1+instance IsScalarOrVector FP128  where type NumberOfElements FP128  = D1+instance IsScalarOrVector Bool   where type NumberOfElements Bool   = D1+instance IsScalarOrVector Int8   where type NumberOfElements Int8   = D1+instance IsScalarOrVector Int16  where type NumberOfElements Int16  = D1+instance IsScalarOrVector Int32  where type NumberOfElements Int32  = D1+instance IsScalarOrVector Int64  where type NumberOfElements Int64  = D1+instance IsScalarOrVector Word8  where type NumberOfElements Word8  = D1+instance IsScalarOrVector Word16 where type NumberOfElements Word16 = D1+instance IsScalarOrVector Word32 where type NumberOfElements Word32 = D1+instance IsScalarOrVector Word64 where type NumberOfElements Word64 = D1+instance IsScalarOrVector Label  where type NumberOfElements Label  = D1+instance IsScalarOrVector ()     where type NumberOfElements ()     = D1++instance (PositiveT n, IsPrimitive a) =>+         IsScalarOrVector (Vector n a) where+    type NumberOfElements (Vector n a) = n+++-- Functions.+instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where+    funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b)+instance (IsFirstClass a) => IsFunction (IO a) where+    funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a))+instance (IsFirstClass a) => IsFunction (VarArgs a) where+    funcType ts _ = TDFunction True  (reverse ts) (typeDesc (undefined :: a))++-- |The 'VarArgs' type is a placeholder for the real 'IO' type that+-- can be obtained with 'castVarArgs'.+data VarArgs a+    deriving (Typeable)+instance IsType (VarArgs a) where+    typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly"++-- |Define what vararg types are permissible.+class CastVarArgs a b+instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c)+instance CastVarArgs (VarArgs a) (IO a)+instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c)+++++-- XXX Structures not implemented.  Tuples is probably an easy way.+
+ src/LLVM/Core/Util.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.Core.Util(+    -- * Module handling+    Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile,+    getModuleValues, getFunctions, getGlobalVariables, valueHasType,+    -- * Module provider handling+    ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule,+    -- * Pass manager handling+    PassManager(..), withPassManager, createPassManager, createFunctionPassManager,+    runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager,+    -- * Instruction builder+    Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock,+    -- * Basic blocks+    BasicBlock,+    appendBasicBlock, getBasicBlocks,+    -- * Functions+    Function,+    addFunction, getParam, getParams,+    -- * Structs+    structType,+    -- * Globals+    addGlobal,+    constString, constStringNul, constVector, constArray, constStruct,+    -- * Instructions+    makeCall, makeInvoke,+    makeCallWithCc, makeInvokeWithCc,+    withValue, getInstructions, getOperands,+    -- * Uses and Users+    hasUsers, getUsers, getUses, getUser, isChildOf, getDep,+    -- * Misc+    CString, withArrayLen,+    withEmptyCString,+    functionType, buildEmptyPhi, addPhiIns,+    showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant,+    -- * Transformation passes+    addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass,+    addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass,+    addTargetData+    ) where++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.Target as FFI+import qualified LLVM.FFI.BitWriter as FFI+import qualified LLVM.FFI.BitReader as FFI+import qualified LLVM.FFI.Transforms.Scalar as FFI++import Foreign.C.String (withCString, withCStringLen, CString, peekCString)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Utils (fromBool)+import System.IO.Unsafe (unsafePerformIO)++import Data.Typeable (Typeable)+import Data.List (intercalate)+import Control.Monad (liftM, filterM, when)+++type Type = FFI.TypeRef++-- unsafePerformIO just to wrap the non-effecting withArrayLen call+functionType :: Bool -> Type -> [Type] -> Type+functionType varargs retType paramTypes = unsafePerformIO $+    withArrayLen paramTypes $ \ len ptr ->+        return $ FFI.functionType retType ptr (fromIntegral len)+	       	 		  (fromBool varargs)++-- unsafePerformIO just to wrap the non-effecting withArrayLen call+structType :: [Type] -> Bool -> Type+structType types packed = unsafePerformIO $+    withArrayLen types $ \ len ptr ->+        return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0)++--------------------------------------+-- Handle modules++-- Don't use a finalizer for the module, but instead provide an+-- explicit destructor.  This is because handing a module to+-- a module provider changes ownership of the module to the provider,+-- and we don't want to free it by mistake.++-- | Type of top level modules.+newtype Module = Module {+      fromModule :: FFI.ModuleRef+    }+    deriving (Show, Typeable)++withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a+withModule modul f = f (fromModule modul)++createModule :: String -> IO Module+createModule name =+    withCString name $ \ namePtr -> do+      liftM Module $ FFI.moduleCreateWithName namePtr++-- | Free all storage related to a module.  *Note*, this is a dangerous call, since referring+-- to the module after this call is an error.  The reason for the explicit call to free+-- the module instead of an automatic lifetime management is that modules have a+-- somewhat complicated ownership.  Handing a module to a module provider changes+-- the ownership of the module, and the module provider will free the module when necessary.+destroyModule :: Module -> IO ()+destroyModule = FFI.disposeModule . fromModule++-- |Write a module to a file.+writeBitcodeToFile :: String -> Module -> IO ()+writeBitcodeToFile name mdl =+    withCString name $ \ namePtr ->+      withModule mdl $ \ mdlPtr -> do+        rc <- FFI.writeBitcodeToFile mdlPtr namePtr+        when (rc /= 0) $+          ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc+        return ()++-- |Read a module from a file.+readBitcodeFromFile :: String -> IO Module+readBitcodeFromFile name =+    withCString name $ \ namePtr ->+      alloca $ \ bufPtr ->+      alloca $ \ modPtr ->+      alloca $ \ errStr -> do+        rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr+        if rrc /= 0 then do+            msg <- peek errStr >>= peekCString+            ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg+         else do+            buf <- peek bufPtr+            prc <- FFI.parseBitcode buf modPtr errStr+	    if prc /= 0 then do+                msg <- peek errStr >>= peekCString+                ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg+             else do+                ptr <- peek modPtr+                return $ Module ptr+{-+                liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr+-}++getModuleValues :: Module -> IO [(String, Value)]+getModuleValues mdl = do+  fs <- getFunctions mdl+  gs <- getGlobalVariables mdl+  return (fs ++ gs)++getFunctions :: Module -> IO [(String, Value)]+getFunctions mdl = getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl >>= filterM isIntrinsic >>= annotateValueList++getGlobalVariables :: Module -> IO [(String, Value)]+getGlobalVariables mdl = getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl >>= annotateValueList++-- This is safe because we just ask for the type of a value.+valueHasType :: Value -> Type -> Bool+valueHasType v t = unsafePerformIO $ do+    vt <- FFI.typeOf v+    return $ vt == t  -- LLVM uses hash consing for types, so pointer equality works.++showTypeOf :: Value -> IO String+showTypeOf v = FFI.typeOf v >>= showType'++showType' :: Type -> IO String+showType' p = do+    pk <- FFI.getTypeKind p+    case pk of+        FFI.VoidTypeKind -> return "()"+	FFI.FloatTypeKind -> return "Float"+	FFI.DoubleTypeKind -> return "Double"+	FFI.X86_FP80TypeKind -> return "X86_FP80"+	FFI.FP128TypeKind -> return "FP128"+	FFI.PPC_FP128TypeKind -> return "PPC_FP128"+	FFI.LabelTypeKind -> return "Label"+	FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")"+	FFI.FunctionTypeKind -> do+            r <- FFI.getReturnType p+	    c <- FFI.countParamTypes p+	    let n = fromIntegral c+	    as <- allocaArray n $ \ args -> do+		     FFI.getParamTypes p args+		     peekArray n args+	    ts <- mapM showType' (as ++ [r])+	    return $ "(" ++ intercalate " -> " ts ++ ")"+	FFI.StructTypeKind -> return "(Struct ...)"+	FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")"+	FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")"+	FFI.OpaqueTypeKind -> return "Opaque"+	FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")"++--------------------------------------+-- Handle module providers++-- | A module provider is used by the code generator to get access to a module.+newtype ModuleProvider = ModuleProvider {+      fromModuleProvider :: ForeignPtr FFI.ModuleProvider+    }+    deriving (Show, Typeable)++withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a)+                   -> IO a+withModuleProvider = withForeignPtr . fromModuleProvider++-- | Turn a module into a module provider.+createModuleProviderForExistingModule :: Module -> IO ModuleProvider+createModuleProviderForExistingModule modul =+    withModule modul $ \modulPtr -> do+        ptr <- FFI.createModuleProviderForExistingModule modulPtr+        -- MPs given to the EE get taken over, so we should not GC them.+        liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr+++--------------------------------------+-- Handle instruction builders++newtype Builder = Builder {+      fromBuilder :: ForeignPtr FFI.Builder+    }+    deriving (Show, Typeable)++withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a+withBuilder = withForeignPtr . fromBuilder++createBuilder :: IO Builder+createBuilder = do+    ptr <- FFI.createBuilder+    liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr++positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO ()+positionAtEnd bld bblk =+    withBuilder bld $ \ bldPtr ->+      FFI.positionAtEnd bldPtr bblk++getInsertBlock :: Builder -> IO FFI.BasicBlockRef+getInsertBlock bld =+    withBuilder bld $ \ bldPtr ->+      FFI.getInsertBlock bldPtr++--------------------------------------++type BasicBlock = FFI.BasicBlockRef++appendBasicBlock :: Function -> String -> IO BasicBlock+appendBasicBlock func name =+    withCString name $ \ namePtr ->+      FFI.appendBasicBlock func namePtr++getBasicBlocks :: Value -> IO [(String, Value)]+getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v >>= annotateValueList++--------------------------------------++type Function = FFI.ValueRef++addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function+addFunction modul linkage name typ =+    withModule modul $ \ modulPtr ->+      withCString name $ \ namePtr -> do+        f <- FFI.addFunction modulPtr namePtr typ+        FFI.setLinkage f (FFI.fromLinkage linkage)+        return f++getParam :: Function -> Int -> Value+getParam f = FFI.getParam f . fromIntegral++getParams :: Value -> IO [(String, Value)]+getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList++--------------------------------------++addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value+addGlobal modul linkage name typ =+    withModule modul $ \ modulPtr ->+      withCString name $ \ namePtr -> do+        v <- FFI.addGlobal modulPtr typ namePtr+        FFI.setLinkage v (FFI.fromLinkage linkage)+        return v++-- unsafePerformIO is safe because it's only used for the withCStringLen conversion+constStringInternal :: Bool -> String -> Value+constStringInternal nulTerm s = unsafePerformIO $+    withCStringLen s $ \(sPtr, sLen) ->+      return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm))++constString :: String -> Value+constString = constStringInternal False++constStringNul :: String -> Value+constStringNul = constStringInternal True++--------------------------------------++type Value = FFI.ValueRef++withValue :: Value -> (Value -> IO a) -> IO a+withValue v f = f v++makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value+makeCall = makeCallWithCc FFI.C++makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value+makeCallWithCc cc func bldPtr args = do+{-+      print "makeCall"+      FFI.dumpValue func+      mapM_ FFI.dumpValue args+      print "----------------------"+-}+      withArrayLen args $ \ argLen argPtr ->+        withEmptyCString $ \cstr -> do+          i <- FFI.buildCall bldPtr func argPtr+                             (fromIntegral argLen) cstr+          FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)+          return i++makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->+              [Value] -> IO Value+makeInvoke = makeInvokeWithCc FFI.C++makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef ->+              [Value] -> IO Value+makeInvokeWithCc cc norm expt func bldPtr args =+      withArrayLen args $ \ argLen argPtr ->+        withEmptyCString $ \cstr -> do+          i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr+          FFI.setInstructionCallConv i (FFI.fromCallingConvention cc)+          return i++getInstructions :: Value -> IO [(String, Value)]+getInstructions bb = getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList++getOperands :: Value -> IO [(String, Value)]+getOperands ii = geto ii >>= annotateValueList+    where geto i = do+            num <- FFI.getNumOperands i+            let oloop instr number total = if number >= total then return [] else do+                    o <- FFI.getOperand instr number+                    os <- oloop instr (number + 1) total+                    return (o : os)+            oloop i 0 num++--------------------------------------++buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value+buildEmptyPhi bldPtr typ = do+    withEmptyCString $ FFI.buildPhi bldPtr typ++withEmptyCString :: (CString -> IO a) -> IO a+withEmptyCString = withCString ""++addPhiIns :: Value -> [(Value, BasicBlock)] -> IO ()+addPhiIns inst incoming = do+    let (vals, bblks) = unzip incoming+    withArrayLen vals $ \ count valPtr ->+      withArray bblks $ \ bblkPtr ->+        FFI.addIncoming inst valPtr bblkPtr (fromIntegral count)++--------------------------------------++-- | Manage compile passes.+newtype PassManager = PassManager {+      fromPassManager :: ForeignPtr FFI.PassManager+    }+    deriving (Show, Typeable)++withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a)+                   -> IO a+withPassManager = withForeignPtr . fromPassManager++-- | Create a pass manager.+createPassManager :: IO PassManager+createPassManager = do+    ptr <- FFI.createPassManager+    liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr++-- | Create a pass manager for a module.+createFunctionPassManager :: ModuleProvider -> IO PassManager+createFunctionPassManager modul =+    withModuleProvider modul $ \modulPtr -> do+        ptr <- FFI.createFunctionPassManager modulPtr+        liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr++-- | Add a control flow graph simplification pass to the manager.+addCFGSimplificationPass :: PassManager -> IO ()+addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass++-- | Add a constant propagation pass to the manager.+addConstantPropagationPass :: PassManager -> IO ()+addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass++addDemoteMemoryToRegisterPass :: PassManager -> IO ()+addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass++-- | Add a global value numbering pass to the manager.+addGVNPass :: PassManager -> IO ()+addGVNPass pm = withPassManager pm FFI.addGVNPass++addInstructionCombiningPass :: PassManager -> IO ()+addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass++addPromoteMemoryToRegisterPass :: PassManager -> IO ()+addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass++addReassociatePass :: PassManager -> IO ()+addReassociatePass pm = withPassManager pm FFI.addReassociatePass++addTargetData :: FFI.TargetDataRef -> PassManager -> IO ()+addTargetData td pm = withPassManager pm $ FFI.addTargetData td++runFunctionPassManager :: PassManager -> Function -> IO Int+runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn++initializeFunctionPassManager :: PassManager -> IO Int+initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager++finalizeFunctionPassManager :: PassManager -> IO Int+finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager++--------------------------------------++-- The unsafePerformIO is just for the non-effecting withArrayLen+constVector :: Int -> [Value] -> Value+constVector n xs = unsafePerformIO $ do+    let xs' = take n (cycle xs)+    withArrayLen xs' $ \ len ptr ->+        return $ FFI.constVector ptr (fromIntegral len)++-- The unsafePerformIO is just for the non-effecting withArrayLen+constArray :: Type -> Int -> [Value] -> Value+constArray t n xs = unsafePerformIO $ do+    let xs' = take n (cycle xs)+    withArrayLen xs' $ \ len ptr ->+        return $ FFI.constArray t ptr (fromIntegral len)++-- The unsafePerformIO is just for the non-effecting withArrayLen+constStruct :: [Value] -> Bool -> Value+constStruct xs packed = unsafePerformIO $ do+    withArrayLen xs $ \ len ptr ->+        return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0)++--------------------------------------++getValueNameU :: Value -> IO String+getValueNameU a = do+    -- sometimes void values need explicit names too+    cs <- FFI.getValueName a+    str <- peekCString cs+    if str == "" then return (show a) else return str++getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a))+           -> (Ptr a -> IO (Ptr a)) -> t1 -> t+getObjList withF firstF nextF obj = do+    withF obj $ \ objPtr -> do+      ofst <- firstF objPtr +      let oloop p = if p == nullPtr then return [] else do+              n <- nextF p+              ps <- oloop n+              return (p : ps)+      oloop ofst++annotateValueList :: [Value] -> IO [(String, Value)]+annotateValueList vs = do+  names <- mapM getValueNameU vs+  return $ zip names vs++isConstant :: Value -> IO Bool+isConstant v = do+  isC <- FFI.isConstant v+  if isC == 0 then return False else return True++isIntrinsic :: Value -> IO Bool+isIntrinsic v = do+  if FFI.getIntrinsicID v == 0 then return True else return False++--------------------------------------++type Use = FFI.UseRef++hasUsers :: Value -> IO Bool+hasUsers v = do+  nU <- FFI.getNumUses v+  if nU == 0 then return False else return True++getUses :: Value -> IO [Use]+getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse++getUsers :: [Use] -> IO [(String, Value)]+getUsers us = mapM FFI.getUser us >>= annotateValueList++getUser :: Use -> IO Value+getUser = FFI.getUser++isChildOf :: BasicBlock -> Value -> IO Bool+isChildOf bb v = do+  bb2 <- FFI.getInstructionParent v+  if bb == bb2 then return True else return False++getDep :: Use -> IO (String, String)+getDep u = do+  producer <- FFI.getUsedValue u >>= getValueNameU+  consumer <- FFI.getUser u >>= getValueNameU+  return (producer, consumer)
+ src/LLVM/Core/Vector.hs view
@@ -0,0 +1,156 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Core.Vector (MkVector(..), vector, ) where++import LLVM.Core.Type+import LLVM.Core.Data+import LLVM.ExecutionEngine.Target++import Types.Data.Num++import Foreign.Ptr (castPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (peekArray, pokeArray)++import Data.Function (on)+import System.IO.Unsafe (unsafePerformIO)+++-- XXX Should these really be here?+class (PositiveT n, IsPrimitive a) => MkVector n a where+    type Tuple n a :: *+    toVector :: Tuple n a -> Vector n a+    fromVector :: Vector n a -> Tuple n a++{-+instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where+    toVector a = Vector [a]+-}++instance (IsPrimitive a) => MkVector D2 a where+    type Tuple D2 a = (a,a)+    toVector (a1, a2) = Vector [a1, a2]+    fromVector (Vector [a1, a2]) = (a1, a2)+    fromVector _ = error "fromVector: impossible"++instance (IsPrimitive a) => MkVector D4 a where+    type Tuple D4 a = (a,a,a,a)+    toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4]+    fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4)+    fromVector _ = error "fromVector: impossible"++instance (IsPrimitive a) => MkVector D8 a where+    type Tuple D8 a = (a,a,a,a,a,a,a,a)+    toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8]+    fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8)+    fromVector _ = error "fromVector: impossible"++instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where+    sizeOf a = storeSizeOfType ourTargetData (typeRef a)+    alignment a = aBIAlignmentOfType ourTargetData (typeRef a)+    peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a)+    poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs++-- XXX The JITer target data.  This isn't really right.+ourTargetData :: TargetData+ourTargetData = unsafePerformIO getTargetData++--------------------------------------++unVector :: Vector n a -> [a]+unVector (Vector xs) = xs++-- |Make a constant vector.  Replicates or truncates the list to get length /n/.+-- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'.+vector :: forall a n. (PositiveT n) => [a] -> Vector n a+vector xs =+   Vector (take (fromIntegerT (undefined :: n)) (cycle xs))++replic :: forall a n. (PositiveT n) => a -> Vector n a+replic = Vector . replicate (fromIntegerT (undefined :: n))+++binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c+binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys)++unop :: (a -> b) -> Vector n a -> Vector n b+unop op = Vector . map op . unVector++instance (Eq a, PositiveT n) => Eq (Vector n a) where+    (==) = (==) `on` unVector++instance (Ord a, PositiveT n) => Ord (Vector n a) where+    compare = compare `on` unVector++instance (Num a, PositiveT n) => Num (Vector n a) where+    (+) = binop (+)+    (-) = binop (-)+    (*) = binop (*)+    negate = unop negate+    abs = unop abs+    signum = unop signum+    fromInteger = replic . fromInteger++instance (Enum a, PositiveT n) => Enum (Vector n a) where+    succ = unop succ+    pred = unop pred+    fromEnum = error "Vector fromEnum"+    toEnum = replic . toEnum++instance (Real a, PositiveT n) => Real (Vector n a) where+    toRational = error "Vector toRational"++instance (Integral a, PositiveT n) => Integral (Vector n a) where+    quot = binop quot+    rem  = binop rem+    div  = binop div+    mod  = binop mod+    quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys+    divMod  (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod  xs ys+    toInteger = error "Vector toInteger"++instance (Fractional a, PositiveT n) => Fractional (Vector n a) where+    (/) = binop (/)+    fromRational = replic . fromRational++instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where+    properFraction = error "Vector properFraction"++instance (Floating a, PositiveT n) => Floating (Vector n a) where+    pi = replic pi+    sqrt = unop sqrt+    log = unop log+    logBase = binop logBase+    (**) = binop (**)+    exp = unop exp+    sin = unop sin+    cos = unop cos+    tan = unop tan+    asin = unop asin+    acos = unop acos+    atan = unop atan+    sinh = unop sinh+    cosh = unop cosh+    tanh = unop tanh+    asinh = unop asinh+    acosh = unop acosh+    atanh = unop atanh++instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where+    floatRadix = floatRadix . head . unVector+    floatDigits = floatDigits . head . unVector+    floatRange = floatRange . head . unVector+    decodeFloat = error "Vector decodeFloat"+    encodeFloat = error "Vector encodeFloat"+    exponent _ = 0+    scaleFloat 0 x = x+    scaleFloat _ _ = error "Vector scaleFloat"+    isNaN = error "Vector isNaN"+    isInfinite = error "Vector isInfinite"+    isDenormalized = error "Vector isDenormalized"+    isNegativeZero = error "Vector isNegativeZero"+    isIEEE = isIEEE . head . unVector
+ src/LLVM/ExecutionEngine.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TypeFamilies #-}+ -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module.+module LLVM.ExecutionEngine(+    -- * Execution engine+    EngineAccess,+    runEngineAccess,+    addModuleProvider,+    addModule,+{-+    runStaticConstructors,+    runStaticDestructors,+-}+    getPointerToFunction,+    addFunctionValue,+    addGlobalMappings,+    getFreePointers, FreePointers,+    -- * Translation+    Translatable, Generic,+    generateFunction,+    -- * Unsafe type conversion+    Unsafe,+    unsafeRemoveIO,+    -- * Simplified interface.+    simpleFunction,+    unsafeGenerateFunction,+    -- * Target information+    module LLVM.ExecutionEngine.Target+    ) where+import System.IO.Unsafe (unsafePerformIO)++import LLVM.ExecutionEngine.Engine+import LLVM.ExecutionEngine.Target+import LLVM.Core.CodeGen (Value(..))+import LLVM.Core+--import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager)++import LLVM.FFI.Core (ValueRef)++import Control.Monad (liftM2, )+++-- |Class of LLVM function types that can be translated to the corresponding+-- Haskell type.+class Translatable f where+    translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f++instance (Generic a, Translatable b) => Translatable (a -> b) where+    translate run args f = \ arg -> translate run (toGeneric arg : args) f++instance (Generic a) => Translatable (IO a) where+    translate run args f = fmap fromGeneric $ run f $ reverse args++-- |Generate a Haskell function from an LLVM function.+--+-- Note that the function is compiled for every call (Just-In-Time compilation).+-- If you want to compile the function once and call it a lot of times+-- then you should better use 'getPointerToFunction'.+generateFunction :: (Translatable f) =>+                    Value (Ptr f) -> EngineAccess f+generateFunction (Value f) = do+    run <- getRunFunction+    return $ translate run [] f++class Unsafe a where+    type RemoveIO a :: *+    unsafeRemoveIO :: a -> RemoveIO a  -- ^Remove the IO from a function return type.  This is unsafe in general.++instance (Unsafe b) => Unsafe (a->b) where+    type RemoveIO (a -> b) = a -> RemoveIO b+    unsafeRemoveIO f = unsafeRemoveIO . f++instance Unsafe (IO a) where+    type RemoveIO (IO a) = a+    unsafeRemoveIO = unsafePerformIO++-- |Translate a function to Haskell code.  This is a simplified interface to+-- the execution engine and module mechanism.+-- It is based on 'generateFunction', so see there for limitations.+simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f+simpleFunction bld = do+    m <- newModule+    (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings)+    prov <- createModuleProviderForExistingModule m+    runEngineAccess $ do+        addModuleProvider prov+        addGlobalMappings mappings+        generateFunction func++{-+    m <- newModule+    func <- defineModule m bld+--    dumpValue func+    prov <- createModuleProviderForExistingModule m+    ee <- createExecutionEngine prov+    pm <- createFunctionPassManager prov+    td <- getExecutionEngineTargetData ee+    addTargetData td pm+    addInstructionCombiningPass pm+    addReassociatePass pm+    addGVNPass pm+    addCFGSimplificationPass pm+    addPromoteMemoryToRegisterPass pm+    initializeFunctionPassManager pm+--    print ("rc1", rc1)+    runFunctionPassManager pm (unValue func)+--    print ("rc2", rc2)+    finalizeFunctionPassManager pm+--    print ("rc3", rc3)+--    dumpValue func+    return $ generateFunction ee func+-}++-- | Combine 'simpleFunction' and 'unsafeRemoveIO'.+unsafeGenerateFunction :: (Unsafe t, Translatable t) =>+                          CodeGenModule (Function t) -> RemoveIO t+unsafeGenerateFunction bld = unsafePerformIO $ do+    fun <- simpleFunction bld+    return $ unsafeRemoveIO fun
+ src/LLVM/ExecutionEngine/Engine.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.ExecutionEngine.Engine(+       EngineAccess,+       runEngineAccess,+{-+       ExecutionEngine,+-}+       createExecutionEngine, addModuleProvider, addModule,+       {- runStaticConstructors, runStaticDestructors, -}+       getExecutionEngineTargetData,+       getPointerToFunction,+       addFunctionValue, addGlobalMappings,+       getFreePointers, FreePointers,+       runFunction, getRunFunction,+       GenericValue, Generic(..)+       ) where++import LLVM.Core.CodeGen (Value(..), Function)+import LLVM.Core.CodeGenMonad (GlobalMappings(..))+import LLVM.Core.Util+          (Module, ModuleProvider, withModuleProvider,+           createModule, createModuleProviderForExistingModule)+import LLVM.Core.Type (IsFirstClass, typeRef)++import qualified LLVM.FFI.ExecutionEngine as FFI+import qualified LLVM.FFI.Target as FFI+import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef)+import qualified LLVM.Core.Util as U++import qualified Control.Monad.Trans.State as MS+import Control.Monad.Trans.State (StateT, runStateT, )+import Control.Monad.IO.Class (MonadIO, liftIO, )+import Control.Monad (liftM, )+import Control.Applicative (Applicative, )+import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar, )++import Data.Typeable+import Data.Int+import Data.Word++import Foreign.Marshal.Alloc (alloca, free)+import Foreign.Marshal.Array (withArrayLen)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)+import Foreign.Marshal.Utils (fromBool)+import Foreign.C.String (peekCString)+import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr)+import Foreign.Storable (peek)+import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, )+import System.IO.Unsafe (unsafePerformIO)++{-+-- |The type of the JITer.+newtype ExecutionEngine = ExecutionEngine {+      fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine+    }++withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a)+                    -> IO a+withExecutionEngine = withForeignPtr . fromExecutionEngine++-- |Create an execution engine for a module provider.+-- Warning, do not call this function more than once.+createExecutionEngine :: ModuleProvider -> IO ExecutionEngine+createExecutionEngine prov =+    withModuleProvider prov $ \provPtr ->+      alloca $ \eePtr ->+        alloca $ \errPtr -> do+          ret <- FFI.createExecutionEngine eePtr provPtr errPtr+          if ret == 1+            then do err <- peek errPtr+                    errStr <- peekCString err+                    free err+                    ioError . userError $ errStr+            else do ptr <- peek eePtr+                    liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr++addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO ()+addModuleProvider ee prov =+    withExecutionEngine ee $ \ eePtr ->+      withModuleProvider prov $ \ provPtr ->+        FFI.addModuleProvider eePtr provPtr++runStaticConstructors :: ExecutionEngine -> IO ()+runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors++runStaticDestructors :: ExecutionEngine -> IO ()+runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors++getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef+getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData++getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f)+getPointerToFunction ee (Value f) =+    withExecutionEngine ee $ \ eePtr ->+      FFI.getPointerToGlobal eePtr f+-}++-- This global variable holds the one and only execution engine.+-- It may be missing, but it never dies.+-- XXX We could provide a destructor, what about functions obtained by runFunction?+{-# NOINLINE theEngine #-}+theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine))+theEngine = unsafePerformIO $ newMVar Nothing++createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine)+createExecutionEngine prov =+    withModuleProvider prov $ \provPtr ->+      alloca $ \eePtr ->+        alloca $ \errPtr -> do+          ret <- FFI.createExecutionEngine eePtr provPtr errPtr+          if ret == 1+            then do+                err <- peek errPtr+                errStr <- peekCString err+                free err+                ioError . userError $ errStr+            else+                peek eePtr++getTheEngine :: IO (Ptr FFI.ExecutionEngine)+getTheEngine = do+    mee <- takeMVar theEngine+    case mee of+        Just ee -> do putMVar theEngine mee; return ee+        Nothing -> do+            m <- createModule "__empty__"+            mp <- createModuleProviderForExistingModule m+            ee <- createExecutionEngine mp+            putMVar theEngine (Just ee)+            return ee++data EAState = EAState {+    ea_engine :: Ptr FFI.ExecutionEngine,+    ea_providers :: [ModuleProvider]+    }+    deriving (Show, Typeable)++newtype EngineAccess a = EA (StateT EAState IO a)+    deriving (Functor, Applicative, Monad, MonadIO)++-- |The LLVM execution engine is encapsulated so it cannot be accessed directly.+-- The reason is that (currently) there must only ever be one engine,+-- so access to it is wrapped in a monad.+runEngineAccess :: EngineAccess a -> IO a+runEngineAccess (EA body) = do+    eePtr <- getTheEngine+    let ea = EAState { ea_engine = eePtr, ea_providers = [] }+    (a, _ea') <- runStateT body ea+    -- XXX should remove module providers again+    return a++addModuleProvider :: ModuleProvider -> EngineAccess ()+addModuleProvider prov = do+    ea <- EA MS.get+    EA $ MS.put ea{ ea_providers = prov : ea_providers ea }+    liftIO $ withModuleProvider prov $ \ provPtr ->+                 FFI.addModuleProvider (ea_engine ea) provPtr+++getEngine :: EngineAccess (Ptr FFI.ExecutionEngine)+getEngine = EA $ MS.gets ea_engine++getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef+getExecutionEngineTargetData = do+    eePtr <- getEngine+    liftIO $ FFI.getExecutionEngineTargetData eePtr++{- |+In contrast to 'generateFunction' this compiles a function once.+Thus it is faster for many calls to the same function.+See @examples\/Vector.hs@.++If the function calls back into Haskell code,+you also have to set the function addresses+using 'addFunctionValue' or 'addGlobalMappings'.+-}+getPointerToFunction :: Function f -> EngineAccess (FunPtr f)+getPointerToFunction (Value f) = do+    eePtr <- getEngine+    liftIO $ FFI.getPointerToGlobal eePtr f++{- |+Tell LLVM the address of an external function+if it cannot resolve a name automatically.+Alternatively you may declare the function+with 'staticFunction' instead of 'externFunction'.+-}+addFunctionValue :: Function f -> FunPtr f -> EngineAccess ()+addFunctionValue (Value g) f =+    addFunctionValueCore g (castFunPtrToPtr f)++{- |+Pass a list of global mappings to LLVM+that can be obtained from 'LLVM.Core.getGlobalMappings'.+-}+addGlobalMappings :: GlobalMappings -> EngineAccess ()+addGlobalMappings (GlobalMappings gms) =+    mapM_ (uncurry addFunctionValueCore) gms++addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess ()+addFunctionValueCore g f = do+    eePtr <- getEngine+    liftIO $ FFI.addGlobalMapping eePtr g f++addModule :: Module -> EngineAccess ()+addModule m = do+    mp <- liftIO $ createModuleProviderForExistingModule m+    addModuleProvider mp++-- | Get all the information needed to free a function.+-- Freeing code might have to be done from a (C) finalizer, so it has to done from C.+-- The function c_freeFunctionObject take these pointers as arguments and frees the function.+type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef)+getFreePointers :: Function f -> EngineAccess FreePointers+getFreePointers (Value f) = do+    ea <- EA MS.get+    liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp ->+        return (ea_engine ea, mpp, f)++--------------------------------------++newtype GenericValue = GenericValue {+      fromGenericValue :: ForeignPtr FFI.GenericValue+    }++withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a+withGenericValue = withForeignPtr . fromGenericValue++createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue+createGenericValueWith f = do+  ptr <- f+  liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr++withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a+withAll ps a = go [] ps+    where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs+          go ptrs _ = withArrayLen (reverse ptrs) a+                   +runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue+runFunction func args = do+    eePtr <- getEngine+    liftIO $ withAll args $ \argLen argPtr ->+                 createGenericValueWith $ FFI.runFunction eePtr func+                                              (fromIntegral argLen) argPtr+getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue)+getRunFunction = do+    eePtr <- getEngine+    return $ \ func args -> +             withAll args $ \argLen argPtr ->+                 createGenericValueWith $ FFI.runFunction eePtr func+                                              (fromIntegral argLen) argPtr++class Generic a where+    toGeneric :: a -> GenericValue+    fromGeneric :: GenericValue -> a++instance Generic () where+    toGeneric _ = error "toGeneric ()"+    fromGeneric _ = ()++toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue+toGenericInt signed val = unsafePerformIO $ createGenericValueWith $+    FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed)++fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a+fromGenericInt signed val = unsafePerformIO $+    withGenericValue val $ \ref ->+      return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed)++--instance Generic Bool where+--    toGeneric = toGenericInt False . fromBool+--    fromGeneric = toBool . fromGenericInt False++instance Generic Int8 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Int16 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Int32 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++{-+instance Generic Int where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True+-}++instance Generic Int64 where+    toGeneric = toGenericInt True+    fromGeneric = fromGenericInt True++instance Generic Word8 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word16 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word32 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++instance Generic Word64 where+    toGeneric = toGenericInt False+    fromGeneric = fromGenericInt False++toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue+toGenericReal val = unsafePerformIO $ createGenericValueWith $+    FFI.createGenericValueOfFloat (typeRef val) (realToFrac val)++fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a+fromGenericReal val = unsafePerformIO $+    withGenericValue val $ \ ref ->+      return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref++instance Generic Float where+    toGeneric = toGenericReal+    fromGeneric = fromGenericReal++instance Generic Double where+    toGeneric = toGenericReal+    fromGeneric = fromGenericReal++instance Generic (Ptr a) where+    toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer+    fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer++instance Generic (StablePtr a) where+    toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr+    fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer
+ src/LLVM/ExecutionEngine/Target.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DeriveDataTypeable #-}+module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where++import LLVM.Core.Data (WordN)+import LLVM.ExecutionEngine.Engine+          (runEngineAccess, getExecutionEngineTargetData)++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.Target as FFI++import Types.Data.Num (PositiveT, reifyPositiveD)++import Foreign.C.String (withCString)+import Data.Typeable (Typeable)+import Data.Maybe (fromMaybe)+import System.IO.Unsafe (unsafePerformIO)+++type Type = FFI.TypeRef++data TargetData = TargetData {+    aBIAlignmentOfType         :: Type -> Int,+    aBISizeOfType              :: Type -> Int,+    littleEndian               :: Bool,+    callFrameAlignmentOfType   :: Type -> Int,+--  elementAtOffset            :: Type -> Word64 -> Int,+    intPtrType                 :: Type,+--  offsetOfElements           :: Int -> Word64,+    pointerSize                :: Int,+--  preferredAlignmentOfGlobal :: Value a -> Int,+    preferredAlignmentOfType   :: Type -> Int,+    sizeOfTypeInBits           :: Type -> Int,+    storeSizeOfType            :: Type -> Int+    }+    deriving (Typeable)++withIntPtrType :: (forall n . (PositiveT n) => WordN n -> a) -> a+withIntPtrType f =+    fromMaybe (error "withIntPtrType: pointer size must be non-negative") $+        reifyPositiveD (fromIntegral sz) (\ n -> f (g n))+  where g :: n -> WordN n+        g _ = error "withIntPtrType: argument used"+        sz = pointerSize $ unsafePerformIO getTargetData++-- Gets the target data for the JIT target.+getEngineTargetDataRef :: IO FFI.TargetDataRef+getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData++-- Normally the TargetDataRef never changes, so the operation+-- are really pure functions.+makeTargetData :: FFI.TargetDataRef -> TargetData+makeTargetData r = TargetData {+    aBIAlignmentOfType       = fromIntegral . FFI.aBIAlignmentOfType r,+    aBISizeOfType            = fromIntegral . FFI.aBISizeOfType r,+    littleEndian             = FFI.byteOrder r /= 0,+    callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r,+    intPtrType               = FFI.intPtrType r,+    pointerSize              = fromIntegral $ FFI.pointerSize r,+    preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r,+    sizeOfTypeInBits         = fromIntegral . FFI.sizeOfTypeInBits r,+    storeSizeOfType          = fromIntegral . FFI.storeSizeOfType r+    }++getTargetData :: IO TargetData+getTargetData = fmap makeTargetData getEngineTargetDataRef++targetDataFromString :: String -> TargetData+targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData
+ src/LLVM/Util/Arithmetic.hs view
@@ -0,0 +1,302 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Util.Arithmetic(+    TValue,+    (%==), (%/=), (%<), (%<=), (%>), (%>=),+    (%&&), (%||),+    (?), (??),+    retrn, set,+    ArithFunction, arithFunction,+    ToArithFunction, toArithFunction, recursiveFunction,+    CallIntrinsic,+    ) where++import qualified LLVM.Core as LLVM+import LLVM.Util.Loop (mapVector, mapVector2)+import LLVM.Core++import qualified Types.Data.Num as TypeNum++import Control.Monad (liftM2)++-- |Synonym for @CodeGenFunction r (Value a)@.+type TValue r a = CodeGenFunction r (Value a)+++infix  4  %==, %/=, %<, %<=, %>=, %>+-- |Comparison functions.+(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a) => TValue r a -> TValue r a -> TValue r (CmpResult a)+(%==) = binop $ LLVM.cmp CmpEQ+(%/=) = binop $ LLVM.cmp CmpNE+(%>)  = binop $ LLVM.cmp CmpGT+(%>=) = binop $ LLVM.cmp CmpGE+(%<)  = binop $ LLVM.cmp CmpLT+(%<=) = binop $ LLVM.cmp CmpLE++infixr 3  %&&+infixr 2  %||+-- |Lazy and.+(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool+a %&& b = a ? (b, return (valueOf False))+-- |Lazy or.+(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool+a %|| b = a ? (return (valueOf True), b)++infix  0 ?+-- |Conditional, returns first element of the pair when condition is true, otherwise second.+(?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a+c ? (t, f) = do+    lt <- newBasicBlock+    lf <- newBasicBlock+    lj <- newBasicBlock+    c' <- c+    condBr c' lt lf+    defineBasicBlock lt+    rt <- t+    lt' <- getCurrentBasicBlock+    br lj+    defineBasicBlock lf+    rf <- f+    lf' <- getCurrentBasicBlock+    br lj+    defineBasicBlock lj+    phi [(rt, lt'), (rf, lf')]++infix 0 ??+(??) :: (IsFirstClass a, CmpRet a) => TValue r (CmpResult a) -> (TValue r a, TValue r a) -> TValue r a+c ?? (t, f) = do+    c' <- c+    t' <- t+    f' <- f+    select c' t' f'++-- | Return a value from an 'arithFunction'.+retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r ()+retrn x = x >>= ret++-- | Use @x <- set $ ...@ to make a binding.+set :: TValue r a -> (CodeGenFunction r (TValue r a))+set x = do x' <- x; return (return x')++instance Eq (TValue r a)+instance Ord (TValue r a)++instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where+    (+) = binop add+    (-) = binop sub+    (*) = binop mul+    negate = (>>= neg)+    abs x = x %< 0 ?? (-x, x)+    signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0))+    fromInteger = return . valueOf . fromInteger++instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Enum (TValue r a) where+    succ x = x + 1+    pred x = x - 1+    fromEnum _ = error "CodeGenFunction Value: fromEnum"+    toEnum = fromIntegral++instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Real (TValue r a) where+    toRational _ = error "CodeGenFunction Value: toRational"++instance (CmpRet a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where+    quot = binop idiv+    rem  = binop irem+    quotRem x y = (quot x y, rem x y)+    toInteger _ = error "CodeGenFunction Value: toInteger"++instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where+    (/) = binop fdiv+    fromRational = return . valueOf . fromRational++instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where+    properFraction _ = error "CodeGenFunction Value: properFraction"++instance (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where+    pi = return $ valueOf pi+    sqrt = callIntrinsic1 "sqrt"+    sin = callIntrinsic1 "sin"+    cos = callIntrinsic1 "cos"+    (**) = callIntrinsic2 "pow"+    exp = callIntrinsic1 "exp"+    log = callIntrinsic1 "log"++    asin _ = error "LLVM missing intrinsic: asin"+    acos _ = error "LLVM missing intrinsic: acos"+    atan _ = error "LLVM missing intrinsic: atan"++    sinh x           = (exp x - exp (-x)) / 2+    cosh x           = (exp x + exp (-x)) / 2+    asinh x          = log (x + sqrt (x*x + 1))+    acosh x          = log (x + sqrt (x*x - 1))+    atanh x          = (log (1 + x) - log (1 - x)) / 2++instance (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where+    floatRadix _ = floatRadix (undefined :: a)+    floatDigits _ = floatDigits (undefined :: a)+    floatRange _ = floatRange (undefined :: a)+    decodeFloat _ = error "CodeGenFunction Value: decodeFloat"+    encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat"+    exponent _ = 0+    scaleFloat 0 x = x+    scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat"+    isNaN _ = error "CodeGenFunction Value: isNaN"+    isInfinite _ = error "CodeGenFunction Value: isInfinite"+    isDenormalized _ = error "CodeGenFunction Value: isDenormalized"+    isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero"+    isIEEE _ = isIEEE (undefined :: a)++binop :: (Value a -> Value b -> TValue r c) ->+         TValue r a -> TValue r b -> TValue r c+binop op x y = do+    x' <- x+    y' <- y+    op x' y'++{-+If we add the ReadNone attribute, then LLVM-2.8 complains:++llvm/examples$ Arith_dyn.exe+Attribute readnone only applies to the function!+  %2 = call readnone double @llvm.sin.f64(double %0)+Attribute readnone only applies to the function!+  %3 = call readnone double @llvm.exp.f64(double %2)+Broken module found, compilation aborted!+Stack dump:+0.      Running pass 'Function Pass Manager' on module '_module'.+1.      Running pass 'Module Verifier' on function '@_fun1'+Aborted+-}+addReadNone :: Value a -> CodeGenFunction r (Value a)+addReadNone x = do+--   addAttributes x 0 [ReadNoneAttribute]+   return x++callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) =>+                   String -> Value a -> TValue r b+callIntrinsicP1 fn x = do+    op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a))+{-+You can add these attributes,+but the verifier pass in the optimizer checks whether they match+the attributes that are declared for that intrinsic.+If we omit adding attributes then the right attributes are added automatically.+    addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute]+-}+    runCall (callFromFunction op `applyCall` x) >>= addReadNone++callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) =>+                   String -> Value a -> Value b -> TValue r c+callIntrinsicP2 fn x y = do+    op <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a))+    runCall (callFromFunction op `applyCall` x `applyCall` y) >>= addReadNone++-------------------------------------------++class ArithFunction r z a b | a -> b r z, b r z -> a where+    arithFunction' :: a -> b++instance+    (Ret a r) =>+        ArithFunction r a (CodeGenFunction r a) (CodeGenFunction r ()) where+    arithFunction' x = x >>= ret++instance+    (ArithFunction r z b0 b1) =>+        ArithFunction r z (CodeGenFunction r a -> b0) (a -> b1) where+    arithFunction' f = arithFunction' . f . return++-- |Unlift a function with @TValue@ to have @Value@ arguments.+arithFunction :: ArithFunction r z a b => a -> b+arithFunction = arithFunction'+++class ToArithFunction r a b | a r -> b, b -> a r where+    toArithFunction' :: CodeGenFunction r (Call a) -> b++instance ToArithFunction r (IO b) (CodeGenFunction r (Value b)) where+    toArithFunction' cl = cl >>= runCall++instance+    ToArithFunction r b0 b1 =>+        ToArithFunction r (a -> b0) (CodeGenFunction r (Value a) -> b1) where+    toArithFunction' cl x =+        toArithFunction' (liftM2 applyCall cl x)+++_toArithFunction2 ::+   Function (a -> b -> IO c) -> TValue r a -> TValue r b -> TValue r c+_toArithFunction2 f tx ty = do+    x <- tx+    y <- ty+    runCall $ callFromFunction f `applyCall` x `applyCall` y++-- |Lift a function from having @Value@ arguments to having @TValue@ arguments.+toArithFunction ::+    (ToArithFunction r f g) =>+    Function f -> g+toArithFunction f =+    toArithFunction' $ return $ callFromFunction f++-------------------------------------------++-- |Define a recursive 'arithFunction', gets passed itself as the first argument.+recursiveFunction ::+    (IsFunction f, FunctionArgs f, code ~ FunctionCodeGen f,+     ArithFunction r1 z arith code,+     ToArithFunction r0 f g) =>+    (g -> arith) -> CodeGenModule (Function f)+recursiveFunction af = do+    f <- newFunction ExternalLinkage+    defineFunction f $ arithFunction $ af $ toArithFunction f+    return f+++-------------------------------------------++class CallIntrinsic a where+    callIntrinsic1' :: String -> Value a -> TValue r a+    callIntrinsic2' :: String -> Value a -> Value a -> TValue r a++instance CallIntrinsic Float where+    callIntrinsic1' = callIntrinsicP1+    callIntrinsic2' = callIntrinsicP2++instance CallIntrinsic Double where+    callIntrinsic1' = callIntrinsicP1+    callIntrinsic2' = callIntrinsicP2++{-+I think such a special case for certain systems+would be better handled as in LLVM.Extra.Extension.+(lemming)+-}+macOS :: Bool+#if defined(__MACOS__)+macOS = True+#else+macOS = False+#endif++instance (PositiveT n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where+    callIntrinsic1' s x =+       if macOS && TypeNum.fromIntegerT (undefined :: n) == (4::Int) &&+          elem s ["sqrt", "log", "exp", "sin", "cos", "tan"]+         then do+            op <- externFunction ("v" ++ s ++ "f")+            call op x >>= addReadNone+         else mapVector (callIntrinsic1' s) x+    callIntrinsic2' s = mapVector2 (callIntrinsic2' s)++callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a+callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x'++callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a+callIntrinsic2 s = binop (callIntrinsic2' s)
+ src/LLVM/Util/File.hs view
@@ -0,0 +1,49 @@+module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where++import System.Process (system)++import LLVM.ExecutionEngine+import LLVM.Core+++writeCodeGenModule :: FilePath -> CodeGenModule a -> IO ()+writeCodeGenModule name f = do+    m <- newModule+    _ <- defineModule m f+    writeBitcodeToFile name m++optimize :: FilePath -> IO ()+optimize name = do+    _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name+    return ()++optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t)+optimizeFunction = fmap snd . optimizeFunction'++optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t)+optimizeFunction' mdl = do+    m <- newModule+    mf <- defineModule m mdl+    fName <- getValueName mf++    let name = "__tmp__" ++ fName ++ ".bc"+    writeBitcodeToFile name m++    optimize name++    m' <- readBitcodeFromFile name+    funcs <- getModuleValues m'++--    removeFile name++    let Just mf' = castModuleValue =<< lookup fName funcs++    return (m', mf')++optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t+optimizeFunctionCG mdl = do+    (m', mf') <- optimizeFunction' mdl+    rf <- runEngineAccess $ do+        addModule m'+        generateFunction mf'+    return rf
+ src/LLVM/Util/Foreign.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- These are replacements for the broken equivalents in Foreign.*.+-- The functions in Foreign.* do not obey the required alignment.+module LLVM.Util.Foreign where++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Marshal.Array (allocaArray, pokeArray)+import Foreign.Storable (Storable(poke, sizeOf, alignment))+import Foreign.Ptr (alignPtr, Ptr)+++with :: Storable a => a -> (Ptr a -> IO b) -> IO b+with x act =+    alloca $ \ p -> do+    poke p x+    act p++alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b+alloca act =+    allocaBytes (2 * sizeOf (undefined :: a)) $ \ p ->+       act $ alignPtr p (alignment (undefined :: a))++withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b+withArrayLen xs act =+    let l = length xs in+    allocaArray (l+1) $ \ p -> do+    let p' = alignPtr p (alignment (head xs))+    pokeArray p' xs+    act l p'+
+ src/LLVM/Util/Loop.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where++import LLVM.Core+import Types.Data.Num (fromIntegerT)+++class Phi a where+    phis :: BasicBlock -> a -> CodeGenFunction r a+    addPhis :: BasicBlock -> a -> a -> CodeGenFunction r ()++{-+infixr 1 :*+-- XXX should use HList if it was packaged in a nice way.+data a :* b = a :* b+    deriving (Eq, Ord, Show, Read)++instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where+    phis bb (a :* b) = do+        a' <- phi [(a, bb)]+        b' <- phis bb b+        return (a' :* b')+    addPhis bb (a :* b) (a' :* b') = do+        addPhiInputs a [(a', bb)]+        addPhis bb b b'+-}++instance Phi () where+    phis _ _ = return ()+    addPhis _ _ _ = return ()++instance (IsFirstClass a) => Phi (Value a) where+    phis bb a = do+        a' <- phi [(a, bb)]+        return a'+    addPhis bb a a' = do+        addPhiInputs a [(a', bb)]++instance (Phi a, Phi b) => Phi (a, b) where+    phis bb (a, b) = do+        a' <- phis bb a+        b' <- phis bb b+        return (a', b')+    addPhis bb (a, b) (a', b') = do+        addPhis bb a a'+        addPhis bb b b'++instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where+    phis bb (a, b, c) = do+        a' <- phis bb a+        b' <- phis bb b+        c' <- phis bb c+        return (a', b', c')+    addPhis bb (a, b, c) (a', b', c') = do+        addPhis bb a a'+        addPhis bb b b'+        addPhis bb c c'++-- Loop the index variable from low to high.  The state in the loop starts as start, and is modified+-- by incr in each iteration.+forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) =>+           Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a+forLoop low high start incr = do+    top <- getCurrentBasicBlock+    loop <- newBasicBlock+    body <- newBasicBlock+    exit <- newBasicBlock++    br loop++    defineBasicBlock loop+    i <- phi [(low, top)]+    vars <- phis top start+    t <- cmp CmpNE i high+    condBr t body exit++    defineBasicBlock body++    vars' <- incr i vars+    i' <- add i (valueOf 1 :: Value i)++    body' <- getCurrentBasicBlock+    addPhis body' vars vars'+    addPhiInputs i [(i', body')]+    br loop+    defineBasicBlock exit++    return vars++--------------------------------------++mapVector :: forall a b n r .+             (PositiveT n, IsPrimitive b) =>+             (Value a -> CodeGenFunction r (Value b)) ->+             Value (Vector n a) -> CodeGenFunction r (Value (Vector n b))+mapVector f v =+    forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do+        x <- extractelement v i+        y <- f x+        insertelement w y i++mapVector2 :: forall a b c n r .+             (PositiveT n, IsPrimitive c) =>+             (Value a -> Value b -> CodeGenFunction r (Value c)) ->+             Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c))+mapVector2 f v1 v2 =+    forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do+        x <- extractelement v1 i+        y <- extractelement v2 i+        z <- f x y+        insertelement w z i
+ src/LLVM/Util/Memory.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE ScopedTypeVariables #-}+module LLVM.Util.Memory (+    memcpy,+    memmove,+    memset,+    IsLengthType,+    ) where++import LLVM.Core++import Data.Word (Word8, Word32, Word64, )+++class IsFirstClass len => IsLengthType len where++instance IsLengthType Word32 where+instance IsLengthType Word64 where+++memcpyFunc ::+   forall len.+   IsLengthType len =>+   TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memcpyFunc =+   newNamedFunction ExternalLinkage $+      "llvm.memcpy.p0i8.p0i8." ++ intrinsicTypeName (undefined :: len)++memcpy ::+   IsLengthType len =>+   CodeGenModule+      (Value (Ptr Word8) ->+       Value (Ptr Word8) ->+       Value len ->+       Value Word32 ->+       Value Bool ->+       CodeGenFunction r ())+memcpy =+   fmap+      (\f dest src len align volatile ->+          fmap (const()) $ call f dest src len align volatile)+      memcpyFunc+++memmoveFunc ::+   forall len.+   IsLengthType len =>+   TFunction (Ptr Word8 -> Ptr Word8 -> len -> Word32 -> Bool -> IO ())+memmoveFunc =+   newNamedFunction ExternalLinkage $+      "llvm.memmove.p0i8.p0i8." ++ intrinsicTypeName (undefined :: len)++memmove ::+   IsLengthType len =>+   CodeGenModule+      (Value (Ptr Word8) ->+       Value (Ptr Word8) ->+       Value len ->+       Value Word32 ->+       Value Bool ->+       CodeGenFunction r ())+memmove =+   fmap+      (\f dest src len align volatile ->+          fmap (const()) $ call f dest src len align volatile)+      memmoveFunc+++memsetFunc ::+   forall len.+   IsLengthType len =>+   TFunction (Ptr Word8 -> Word8 -> len -> Word32 -> Bool -> IO ())+memsetFunc =+   newNamedFunction ExternalLinkage $+      "llvm.memset.p0i8." ++ intrinsicTypeName (undefined :: len)++memset ::+   IsLengthType len =>+   CodeGenModule+      (Value (Ptr Word8) ->+       Value Word8 ->+       Value len ->+       Value Word32 ->+       Value Bool ->+       CodeGenFunction r ())+memset =+   fmap+      (\f dest val len align volatile ->+          fmap (const()) $ call f dest val len align volatile)+      memsetFunc
+ src/LLVM/Util/Optimize.hs view
@@ -0,0 +1,132 @@+{-+LLVM does not export its functions+@createStandardFunctionPasses@ and+@createStandardModulePasses@ via its C interface+and interfacing to C-C++ wrappers is not very portable.+Thus we reimplement these functions+from @opt.cpp@ and @StandardPasses.h@ in Haskell.+However this way we risk inconsistencies+between 'optimizeModule' and the @opt@ shell command.+-}+module LLVM.Util.Optimize(optimizeModule) where++import LLVM.Core.Util (Module, withModule)++import qualified LLVM.FFI.Core as FFI+import qualified LLVM.FFI.Support as FFI+import LLVM.FFI.Transforms.Scalar (addVerifierPass)++import Control.Exception (bracket)+++{- |+Result tells whether the module was modified by any of the passes.+-}+optimizeModule :: Int -> Module -> IO Bool+optimizeModule optLevel mdl =+    withModule mdl $ \ m ->+    {-+    Core.Util.createPassManager would provide a finalizer for us,+    but I think it is better here to immediately dispose the manager+    when we need it no longer.+    -}+    bracket FFI.createPassManager FFI.disposePassManager $ \ passes ->++{-+Note on LLVM-2.6 to 2.8 (at least):+As far as I understand, if we do not set target data,+then the optimizer will only perform machine independent optimizations.+If we set target data+(e.g. an empty layout string obtained from a module without 'target data' specification.)+we risk that the optimizer switches to a wrong layout+(e.g. to 64 bit pointers on a 32 bit machine for empty layout string)+and thus generates corrupt code.++Currently it seems to be safer to disable+machine dependent optimization completely.++http://llvm.org/bugs/show_bug.cgi?id=6394++    -- Pass the module target data to the pass manager.+    target <- FFI.getDataLayout m >>= createTargetData+    addTargetData target passes+-}++    {-+    opt.cpp does not use a FunctionPassManager for function optimization,+    but a module PassManager.+    Thus we do it the same way.+    I assume that we would need a FunctionPassManager+    only if we wanted to apply individual optimizations to functions.++    fPasses <- FFI.createFunctionPassManager mp+    -}+    bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do+    -- add module target data?++    -- tools/opt/opt.cpp: AddStandardCompilePasses+    addVerifierPass passes+    addOptimizationPasses passes fPasses optLevel++    {- if we wanted to do so, we could loop through all functions and optimize them.+    initializeFunctionPassManager fPasses+    runFunctionPassManager fPasses fcn+    -}++    functionsModified <- FFI.runPassManager fPasses m++    moduleModified <- FFI.runPassManager passes m++    return $+       toEnum (fromIntegral moduleModified) ||+       toEnum (fromIntegral functionsModified)++-- tools/opt/opt.cpp: AddOptimizationPasses+addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO ()+addOptimizationPasses passes fPasses optLevel = do+  createStandardFunctionPasses fPasses optLevel+  createStandardModulePasses passes optLevel True True (optLevel > 1) True True True++createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO ()+createStandardFunctionPasses fPasses optLevel =+    FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel)++-- llvm/Support/StandardPasses.h: createStandardModulePasses+createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO ()+createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass =+  FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize)+     (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions)+     (f (not inliningPass))+  where f True = 1+        f _    = 0+++{-+ToDo:+Function that adds passes according to a list of opt-options.+This would simplify to get consistent behaviour between opt and optimizeModule.++-adce                      addAggressiveDCEPass+-deadargelim               addDeadArgEliminationPass+-deadtypeelim              addDeadTypeEliminationPass+-dse                       addDeadStoreEliminationPass+-functionattrs             addFunctionAttrsPass+-globalopt                 addGlobalOptimizerPass+-indvars                   addIndVarSimplifyPass+-instcombine               addInstructionCombiningPass+-ipsccp                    addIPSCCPPass+-jump-threading            addJumpThreadingPass+-licm                      addLICMPass+-loop-deletion             addLoopDeletionPass+-loop-rotate               addLoopRotatePass+-memcpyopt                 addMemCpyOptPass+-prune-eh                  addPruneEHPass+-reassociate               addReassociatePass+-scalarrepl                addScalarReplAggregatesPass+-sccp                      addSCCPPass+-simplifycfg               addCFGSimplificationPass+-simplify-libcalls         addSimplifyLibCallsPass+-strip-dead-prototypes     addStripDeadPrototypesPass+-tailcallelim              addTailCallEliminationPass+-verify                    addVerifierPass+-}
+ test/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)
+ test/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 ()
− tests/Makefile 
@@ -1,16 +0,0 @@-ghc := ghc-ghcflags := -Wall -Werror-tests := TestType TestValue--all: $(tests:%=%.out)--%.out: %.test-	./$< > $@ 2>&1; s=$$?; cat $@; \-	if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi--.PRECIOUS: %.test-%.test: %.hs-	$(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<--clean:-	-rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out)
− tests/TestValue.hs 
@@ -1,69 +0,0 @@-module TestValue (main) where-    -import qualified LLVM.Core as Core-import qualified LLVM.Core.Type as T-import qualified LLVM.Core.Value as V-  -testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v)-                 => T.Module -> String -> IO (V.Function r p)-testArguments m name = do-  func <- Core.addFunction m name (T.function undefined undefined)-  V.dumpValue func-  let arg = V.params func-  V.dumpValue arg-  return func-  -voidArguments :: T.Module -> IO ()-voidArguments m = do-  func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ())-  V.dumpValue func-  return ()   --type F a = V.Function a a-type P a = V.Function (T.Pointer a) (T.Pointer a)-type V a = V.Function (T.Vector a) (T.Vector a)--arguments :: T.Module -> IO ()-arguments m = do-  voidArguments m--  testArguments m "int1" :: IO (F T.Int1)-  testArguments m "int8" :: IO (F T.Int8)-  testArguments m "int16" :: IO (F T.Int16)-  testArguments m "int32" :: IO (F T.Int32)-  testArguments m "int64" :: IO (F T.Int64)-  testArguments m "float" :: IO (F T.Float)-  testArguments m "double" :: IO (F T.Double)-  testArguments m "float128" :: IO (F T.Float128)-  testArguments m "x86Float80" :: IO (F T.X86Float80)-  testArguments m "ppcFloat128" :: IO (F T.PPCFloat128)--  testArguments m "ptrInt1" :: IO (P T.Int1)-  testArguments m "ptrInt8" :: IO (P T.Int8)-  testArguments m "ptrInt16" :: IO (P T.Int16)-  testArguments m "ptrInt32" :: IO (P T.Int32)-  testArguments m "ptrInt64" :: IO (P T.Int64)-  testArguments m "ptrFloat" :: IO (P T.Float)-  testArguments m "ptrDouble" :: IO (P T.Double)-  testArguments m "ptrFloat128" :: IO (P T.Float128)-  testArguments m "ptrX86Float80" :: IO (P T.X86Float80)-  testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128)--  testArguments m "vecInt1" :: IO (V T.Int1)-  testArguments m "vecInt8" :: IO (V T.Int8)-  testArguments m "vecInt16" :: IO (V T.Int16)-  testArguments m "vecInt32" :: IO (V T.Int32)-  testArguments m "vecInt64" :: IO (V T.Int64)-  testArguments m "vecFloat" :: IO (V T.Float)-  testArguments m "vecDouble" :: IO (V T.Double)-  testArguments m "vecFloat128" :: IO (V T.Float128)-  testArguments m "vecX86Float80" :: IO (V T.X86Float80)-  testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128)--  return ()--main :: IO ()-main = do-  m <- Core.createModule "m"-  arguments m-  return ()