llvm 0.4.4.2 → 0.5.0.1

raw patch · 15 files changed

+531/−61 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• LLVM/Core.hs +1/−0
• LLVM/Core/CodeGen.hs +22/−1
• LLVM/Core/CodeGenMonad.hs +24/−6
• LLVM/Core/Instructions.hs +1/−1
• LLVM/Core/Type.hs +18/−16
• LLVM/ExecutionEngine.hs +22/−10
• LLVM/ExecutionEngine/Engine.hs +101/−12
• LLVM/FFI/ExecutionEngine.hsc +4/−1
• LLVM/Util/Arithmetic.hs +240/−0
• examples/Arith.hs +41/−0
• examples/Convert.hs +41/−0
• examples/DotProd.hs +1/−1
• examples/Fibonacci.hs +4/−4
• examples/Vector.hs +7/−8
• llvm.cabal +4/−1

@@ -52,6 +52,7 @@     TFunction,     -- * Global variable creation     Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal,+    externFunction,     TGlobal,     -- * Globals     Linkage(..),

@@ -7,7 +7,8 @@     Linkage(..),     -- * Function creation     Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction,-    FunctionArgs,+    externFunction,+    FunctionArgs, FunctionRet,     TFunction,     -- * Global variable creation     Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal,@@ -223,6 +224,10 @@ instance (IsType a) =>           FunctionArgs (IO (Ptr a))      (FA (Ptr a))      (FA (Ptr a))      where apArgs _ _ g = g +-- |This class is just to simplify contexts.+class (FunctionArgs (IO a) (CodeGenFunction a ()) (CodeGenFunction a ())) => FunctionRet a+instance (FunctionArgs (IO a) (CodeGenFunction a ()) (CodeGenFunction a ())) => FunctionRet a+ --------------------------------------  -- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction.@@ -251,6 +256,22 @@ getCurrentBasicBlock = do     bld <- getBuilder     liftIO $ liftM BasicBlock $ U.getInsertBlock bld++--------------------------------------++-- |Create a reference to an external function while code generating for a function.+externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a)+externFunction name = do+    es <- getExterns+    case lookup name es of+        Just f -> return $ Value f+        Nothing -> do+            let linkage = ExternalLinkage+            modul <- getFunctionModule+            let typ = typeRef (undefined :: a)+            f <- liftIO $ U.addFunction modul (fromIntegral $ fromEnum linkage) name typ+            putExterns ((name, f) : es)+	    return $ Value f  -------------------------------------- 

@@ -3,7 +3,7 @@     -- * Module code generation     CodeGenModule, runCodeGenModule, genMSym, getModule,     -- * Function code generation-    CodeGenFunction, runCodeGenFunction, genFSym, getFunction, getBuilder,+    CodeGenFunction, runCodeGenFunction, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns,     -- * Reexport     liftIO     ) where@@ -15,10 +15,11 @@  data CGMState = CGMState {     cgm_module :: Module,+    cgm_externs :: [(String, Function)],     cgm_next :: !Int     } newtype CodeGenModule a = CGM (StateT CGMState IO a)-    deriving (Monad, MonadState CGMState, MonadIO)+    deriving (Functor, Monad, MonadState CGMState, MonadIO)  genMSym :: String -> CodeGenModule String genMSym prefix = do@@ -32,18 +33,19 @@  runCodeGenModule :: Module -> CodeGenModule a -> IO a runCodeGenModule m (CGM body) = do-    let cgm = CGMState { cgm_module = m, cgm_next = 1 }+    let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [] }     evalStateT body cgm  --------------------------------------  data CGFState r = CGFState { +    cgf_module :: CGMState,     cgf_builder :: Builder,     cgf_function :: Function,     cgf_next :: !Int     } newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a)-    deriving (Monad, MonadState (CGFState r), MonadIO)+    deriving (Functor, Monad, MonadState (CGFState r), MonadIO)  genFSym :: CodeGenFunction a String genFSym = do@@ -58,9 +60,25 @@ getBuilder :: CodeGenFunction a Builder getBuilder = gets cgf_builder +getFunctionModule :: CodeGenFunction a Module+getFunctionModule = gets (cgm_module . cgf_module)++getExterns :: CodeGenFunction a [(String, Function)]+getExterns = gets (cgm_externs . cgf_module)++putExterns :: [(String, Function)] -> CodeGenFunction a ()+putExterns es = do+    cgf <- get+    let cgm' = (cgf_module cgf) { cgm_externs = es }+    put (cgf { cgf_module = cgm' })+ runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a runCodeGenFunction bld fn (CGF body) = do-    let cgf = CGFState { cgf_builder = bld,+    cgm <- get+    let cgf = CGFState { cgf_module = cgm,+                         cgf_builder = bld,     	      	       	 cgf_function = fn, 			 cgf_next = 1 }-    liftIO $ evalStateT body cgf+    (a, cgf') <- liftIO $ runStateT body cgf+    put (cgf_module cgf')+    return a

@@ -43,7 +43,7 @@     call,     -- * Classes and types     Terminate,-    Ret, CallArgs, ABinOp, CmpOp, FunctionArgs, IsConst,+    Ret, CallArgs, ABinOp, CmpOp, FunctionArgs, FunctionRet, IsConst,     AllocArg,     GetElementPtr, IsIndexArg     ) where

@@ -52,10 +52,12 @@     typeRef :: a -> FFI.TypeRef  -- ^The argument is never evaluated  -- |Arithmetic types, i.e., integral and floating types.-class IsType a => IsArithmetic a where+class IsFirstClass a => IsArithmetic a where     isFloating :: a -> Bool     isFloating _ = False+    typeName :: a -> String -- XXX could be in IsType + -- |Integral types. class IsArithmetic a => IsInteger a where     isSigned :: a -> Bool@@ -133,21 +135,21 @@     typeRef = funcType []  --- Instances to classify types-instance IsArithmetic Float where isFloating _ = True-instance IsArithmetic Double where isFloating _ = True-instance IsArithmetic FP128 where isFloating _ = True-instance (IsTypeNumber n) => IsArithmetic (IntN n)-instance (IsTypeNumber n) => IsArithmetic (WordN n)-instance IsArithmetic Bool-instance IsArithmetic Int8-instance IsArithmetic Int16-instance IsArithmetic Int32-instance IsArithmetic Int64-instance IsArithmetic Word8-instance IsArithmetic Word16-instance IsArithmetic Word32-instance IsArithmetic Word64-instance (IsPowerOf2 n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a)+instance IsArithmetic Float where isFloating _ = True; typeName _ = "f32"+instance IsArithmetic Double where isFloating _ = True; typeName _ = "f64"+instance IsArithmetic FP128 where isFloating _ = True; typeName _ = "f128"+instance (IsTypeNumber n) => IsArithmetic (IntN n) where typeName _ = "i" ++ show (typeNumber (undefined :: n) :: Int)+instance (IsTypeNumber n) => IsArithmetic (WordN n) where typeName _ = "i" ++ show (typeNumber (undefined :: n) :: Int)+instance IsArithmetic Bool where typeName _ = "i1"+instance IsArithmetic Int8 where typeName _ = "i8"+instance IsArithmetic Int16 where typeName _ = "i16"+instance IsArithmetic Int32 where typeName _ = "i32"+instance IsArithmetic Int64 where typeName _ = "i64"+instance IsArithmetic Word8 where typeName _ = "i8"+instance IsArithmetic Word16 where typeName _ = "i16"+instance IsArithmetic Word32 where typeName _ = "i32"+instance IsArithmetic Word64 where typeName _ = "i64"+instance (IsPowerOf2 n, IsPrimitive a, IsArithmetic a) => IsArithmetic (Vector n a) where typeName _ = error "vector type name"  instance IsFloating Float instance IsFloating Double

@@ -2,11 +2,14 @@  -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. module LLVM.ExecutionEngine(     -- * Execution engine-    ExecutionEngine,-    createExecutionEngine,+    EngineAccess,+    runEngineAccess,     addModuleProvider,+    addModule,+{-     runStaticConstructors,     runStaticDestructors,+-} #if HAS_GETPOINTERTOGLOBAL     getPointerToFunction, #endif@@ -26,23 +29,25 @@ import LLVM.FFI.Core(ValueRef) import LLVM.Core.CodeGen(Value(..)) import LLVM.Core-import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager)+--import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager)  -- |Class of LLVM function types that can be translated to the corresponding -- Haskell type. class Translatable f where-    translate :: ExecutionEngine -> [GenericValue] -> ValueRef -> f+    translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f  instance (Generic a, Translatable b) => Translatable (a -> b) where-    translate ee args f = \ arg -> translate ee (toGeneric arg : args) f+    translate run args f = \ arg -> translate run (toGeneric arg : args) f  instance (Generic a) => Translatable (IO a) where-    translate ee args f = fmap fromGeneric $ runFunction ee f $ reverse args+    translate run args f = fmap fromGeneric $ run f $ reverse args  -- |Generate a Haskell function from an LLVM function. generateFunction :: (Translatable f) =>-                    ExecutionEngine -> Value (Ptr f) -> f-generateFunction ee (Value f) = translate ee [] f+                    Value (Ptr f) -> EngineAccess f+generateFunction (Value f) = do+    run <- getRunFunction+    return $ translate run [] f  class Unsafe a b | a -> b where     unsafePurify :: a -> b  -- ^Remove the IO from a function return type.  This is unsafe in general.@@ -59,10 +64,17 @@ simpleFunction bld = do     m <- newModule     func <- defineModule m bld+    prov <- createModuleProviderForExistingModule m+    runEngineAccess $ do+        addModuleProvider prov+        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@@ -78,8 +90,8 @@     finalizeFunctionPassManager pm --    print ("rc3", rc3) --    dumpValue func-     return $ generateFunction ee func+-}  -- | Combine 'simpleFunction' and 'unsafePurify'. unsafeGenerateFunction :: (Unsafe t a, Translatable t) =>

@@ -1,15 +1,21 @@-{-# LANGUAGE CPP, ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, FlexibleInstances, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GeneralizedNewtypeDeriving #-} module LLVM.ExecutionEngine.Engine(+       EngineAccess,+       runEngineAccess,+{-        ExecutionEngine,-       createExecutionEngine, addModuleProvider, runStaticConstructors, runStaticDestructors,+-}+       createExecutionEngine, addModuleProvider, addModule,+       {- runStaticConstructors, runStaticDestructors, -}        getExecutionEngineTargetData, #if HAS_GETPOINTERTOGLOBAL        getPointerToFunction, #endif-       runFunction,+       runFunction, getRunFunction,        GenericValue, Generic(..)        ) where-import Control.Monad+import Control.Monad.State+import Control.Concurrent.MVar import Data.Int import Data.Word import Foreign.Marshal.Alloc (alloca, free)@@ -26,12 +32,13 @@ import Foreign.Storable (peek) import System.IO.Unsafe (unsafePerformIO) -import LLVM.Core.Util(ModuleProvider, withModuleProvider)+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.Core.Util(Function) import LLVM.Core.Type(IsFirstClass, IsType(..)) +{- -- |The type of the JITer. newtype ExecutionEngine = ExecutionEngine {       fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine@@ -82,7 +89,83 @@     withExecutionEngine ee $ \ eePtr ->       FFI.getPointerToGlobal eePtr f #endif+-} +-- 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 do 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]+    }++newtype EngineAccess a = EA (StateT EAState IO a)+    deriving (Functor, Monad, MonadState EAState, MonadIO)++-- |The LLVM execution engine is encapsulated so it cannot be accessed directly.+-- The reason is that (currently) there must only ever be one engine,+-- so access to it is wrapped ina monad.+runEngineAccess :: EngineAccess a -> IO a+runEngineAccess (EA body) = do+    eePtr <- getTheEngine+    let ea = EAState { ea_engine = eePtr, ea_providers = [] }+    (a, _ea') <- runStateT body ea+    -- XXX should remove module providers again+    return a++addModuleProvider :: ModuleProvider -> EngineAccess ()+addModuleProvider prov = do+    ea <- get+    put ea{ ea_providers = prov : ea_providers ea }+    liftIO $ withModuleProvider prov $ \ provPtr ->+                 FFI.addModuleProvider (ea_engine ea) provPtr++getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef+getExecutionEngineTargetData = do+    eePtr <- gets ea_engine+    liftIO $ FFI.getExecutionEngineTargetData eePtr++#if HAS_GETPOINTERTOGLOBAL+getPointerToFunction :: Function f -> IO (FunPtr f)+getPointerToFunction (Value f) = do+    eePtr <- gets ea_engine+    liftIO $ FFI.getPointerToGlobal eePtr f+#endif++addModule :: Module -> EngineAccess ()+addModule m = do+    mp <- liftIO $ createModuleProviderForExistingModule m+    addModuleProvider mp+ --------------------------------------  newtype GenericValue = GenericValue {@@ -106,13 +189,19 @@     where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs           go ptrs _ = withArrayLen (reverse ptrs) a                    -runFunction :: ExecutionEngine -> LLVM.Core.Util.Function -> [GenericValue]-            -> IO GenericValue-runFunction ee func args =-    withExecutionEngine ee $ \eePtr ->-      withAll args $ \argLen argPtr ->-        createGenericValueWith $ FFI.runFunction eePtr func-                                        (fromIntegral argLen) argPtr+runFunction :: LLVM.Core.Util.Function -> [GenericValue] -> EngineAccess GenericValue+runFunction func args = do+    eePtr <- gets ea_engine+    liftIO $ withAll args $ \argLen argPtr ->+                 createGenericValueWith $ FFI.runFunction eePtr func+                                              (fromIntegral argLen) argPtr+getRunFunction :: EngineAccess (LLVM.Core.Util.Function -> [GenericValue] -> IO GenericValue)+getRunFunction = do+    eePtr <- gets ea_engine+    return $ \ func args -> +             withAll args $ \argLen argPtr ->+                 createGenericValueWith $ FFI.runFunction eePtr func+                                              (fromIntegral argLen) argPtr  class Generic a where     toGeneric :: a -> GenericValue

@@ -37,7 +37,10 @@  import Foreign.C.String (CString) import Foreign.C.Types (CDouble, CInt, CUInt, CULLong)-import Foreign.Ptr (Ptr, FunPtr)+import Foreign.Ptr (Ptr)+#if HAS_GETPOINTERTOGLOBAL+import Foreign.Ptr (FunPtr)+#endif  import LLVM.FFI.Core (ModuleRef, ModuleProviderRef, TypeRef, ValueRef) import LLVM.FFI.Target(TargetDataRef)

@@ -0,0 +1,240 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, FlexibleContexts, UndecidableInstances, TypeSynonymInstances, MultiParamTypeClasses, FunctionalDependencies #-}+module LLVM.Util.Arithmetic(+    TValue,+    Cmp,+    (%==), (%/=), (%<), (%<=), (%>), (%>=),+    (%&&), (%||),+    (?),+    retrn,+    ArithFunction(..), UnwrapArgs, toArithFunction, recursiveFunction+    ) where+import Data.Word+import Data.Int+import LLVM.Core++type TValue r a = CodeGenFunction r (Value a)++class Cmp a where+    cmp :: IntPredicate -> Value a -> Value a -> TValue r Bool++instance Cmp Bool where cmp = icmp+instance Cmp Word8 where cmp = icmp+instance Cmp Word16 where cmp = icmp+instance Cmp Word32 where cmp = icmp+instance Cmp Word64 where cmp = icmp+instance Cmp Int8 where cmp = icmp . adjSigned+instance Cmp Int16 where cmp = icmp . adjSigned+instance Cmp Int32 where cmp = icmp . adjSigned+instance Cmp Int64 where cmp = icmp . adjSigned+instance Cmp Float where cmp = fcmp . adjFloat+instance Cmp Double where cmp = fcmp . adjFloat+instance Cmp FP128 where cmp = fcmp . adjFloat++adjSigned :: IntPredicate -> IntPredicate+adjSigned IntUGT = IntSGT+adjSigned IntUGE = IntSGE+adjSigned IntULT = IntSLT+adjSigned IntULE = IntSLE+adjSigned p = p++adjFloat :: IntPredicate -> RealPredicate+adjFloat IntEQ  = RealOEQ+adjFloat IntNE  = RealONE+adjFloat IntUGT = RealOGT+adjFloat IntUGE = RealOGE+adjFloat IntULT = RealOLT+adjFloat IntULE = RealOLE+adjFloat _ = error "adjFloat"++infix  4  %==, %/=, %<, %<=, %>=, %>+(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (Cmp a) => TValue r a -> TValue r a -> TValue r Bool+(%==) = binop $ cmp IntEQ+(%/=) = binop $ cmp IntNE+(%>)  = binop $ cmp IntUGT+(%>=) = binop $ cmp IntUGE+(%<)  = binop $ cmp IntULT+(%<=) = binop $ cmp IntULE++infixr 3  %&&+infixr 2  %||+(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool+a %&& b = a ? (b, return (valueOf False))+(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool+a %|| b = a ? (return (valueOf True), b)++infix  0 ?+(?) :: (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')]++retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r ()+retrn x = x >>= ret++instance (Show (TValue r a))+instance (Eq (TValue r a))+instance (Ord (TValue r a))++instance (Cmp a, Num a, IsArithmetic 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 (Cmp a, Num a, IsConst a, IsArithmetic a) => Enum (TValue r a) where+    succ x = x + 1+    pred x = x - 1+    fromEnum _ = error "CodeGenFunction Value: fromEnum"+    toEnum = fromIntegral++instance (Cmp a, Num a, IsConst a, IsArithmetic a) => Real (TValue r a) where+    toRational _ = error "CodeGenFunction Value: toRational"++instance (Cmp a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where+    quot = binop (if (isSigned (undefined :: a)) then sdiv else udiv)+    rem  = binop (if (isSigned (undefined :: a)) then srem else urem)+    quotRem x y = (quot x y, rem x y)+    toInteger _ = error "CodeGenFunction Value: toInteger"++instance (Cmp a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where+    (/) = binop fdiv+    fromRational = return . valueOf . fromRational++instance (Cmp a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where+    properFraction _ = error "CodeGenFunction Value: properFraction"++instance (Cmp 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: atab"++    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 (Cmp 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'++callIntrinsic1 :: forall a b r . (IsArithmetic a, IsFirstClass b) =>+	          String -> TValue r a -> TValue r b+callIntrinsic1 fn x = do+    x' <- x+    op <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a))+    let _ = op :: Function (a -> IO b)+    call op x'++callIntrinsic2 :: forall a b c r . (IsArithmetic a, IsFirstClass b, IsFirstClass c) =>+	          String -> TValue r a -> TValue r b -> TValue r c+callIntrinsic2 fn x y = do+    x' <- x+    y' <- y+    op <- externFunction ("llvm." ++ fn ++ "." ++ typeName (undefined :: a))+    let _ = op :: Function (a -> b -> IO c)+    call op x' y'++-------------------------------------------++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++-------------------------------------------++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) = do a' <- a; b' <- liftTuple b; return (a', 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 b -> a 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 -> do x' <- liftTuple x; uncurryN f x'++toArithFunction :: (CallArgs f g, UnwrapArgs a a1 b1 b g r) =>+                    Function f -> a+toArithFunction f = unwrapArgs (call f)++-------------------------------------------++recursiveFunction ::+        (CallArgs a g,+         UnwrapArgs a11 a1 b1 b g r,+         FunctionArgs a a2 (CodeGenFunction r1 ()),+         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+

@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Arith where+import Data.Int+import LLVM.Core+import LLVM.ExecutionEngine+import LLVM.Util.Arithmetic++mSomeFn :: forall a . (IsConst a, Floating a, IsFloating a, Cmp a,+	      FunctionRet a+	     ) => CodeGenModule (Function (a -> IO a))+mSomeFn = do+    foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y+    createFunction ExternalLinkage $ arithFunction $ \ x ->+        sqrt (x^2 - 5 * x + 6) + toArithFunction foo x x++mFib :: CodeGenModule (Function (Int32 -> IO Int32))+mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2))++writeFunction :: String -> CodeGenModule a -> IO ()+writeFunction name f = do+    m <- newModule+    defineModule m f+    writeBitcodeToFile name m++main :: IO ()+main = do+    let mSomeFn' = mSomeFn+    ioSomeFn <- simpleFunction mSomeFn'+    let someFn :: Double -> Double+        someFn = unsafePurify ioSomeFn++    writeFunction "Arith.bc" mSomeFn'++    print (someFn 10)+    print (someFn 2)++    writeFunction "ArithFib.bc" mFib++    fib <- simpleFunction mFib+    fib 22 >>= print

@@ -0,0 +1,41 @@+{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-}+module Convert(Convert(..)) where+import Data.Int+import Data.Word+import Foreign.Ptr (FunPtr)++type Importer f = FunPtr f -> f++class Convert f where+    convert :: Importer f++foreign import ccall safe "dynamic" c_IOFloat :: Importer (IO Float)+instance Convert (IO Float) where convert = c_IOFloat++foreign import ccall safe "dynamic" c_Float_IOFloat :: Importer (Float -> IO Float)+instance Convert (Float -> IO Float) where convert = c_Float_IOFloat++foreign import ccall safe "dynamic" c_Float_Float :: Importer (Float -> Float)+instance Convert (Float -> Float) where convert = c_Float_Float+ +foreign import ccall safe "dynamic" c_IODouble :: Importer (IO Double)+instance Convert (IO Double) where convert = c_IODouble++foreign import ccall safe "dynamic" c_Double_IODouble :: Importer (Double -> IO Double)+instance Convert (Double -> IO Double) where convert = c_Double_IODouble++foreign import ccall safe "dynamic" c_Double_Double :: Importer (Double -> Double)+instance Convert (Double -> Double) where convert = c_Double_Double+ +foreign import ccall safe "dynamic" c_Word32_IOWord32 :: Importer (Word32 -> IO Word32)+instance Convert (Word32 -> IO Word32) where convert = c_Word32_IOWord32++foreign import ccall safe "dynamic" c_Word32_Word32 :: Importer (Word32 -> Word32)+instance Convert (Word32 -> Word32) where convert = c_Word32_Word32++foreign import ccall safe "dynamic" c_Int32_IOInt32 :: Importer (Int32 -> IO Int32)+instance Convert (Int32 -> IO Int32) where convert = c_Int32_IOInt32++foreign import ccall safe "dynamic" c_Int32_Int32 :: Importer (Int32 -> Int32)+instance Convert (Int32 -> Int32) where convert = c_Int32_Int32+

@@ -12,7 +12,7 @@  mDotProd :: forall n a . (IsPowerOf2 n, IsTypeNumber n, 	                  IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a,-	                  FunctionArgs (IO a) (CodeGenFunction a ()) (CodeGenFunction a ())+	                  FunctionRet a 	                 ) =>             CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) mDotProd =

@@ -30,12 +30,12 @@     -- Can be disassembled with llvm-dis.     writeBitcodeToFile "Fibonacci.bc" m -    -- Create a JIT execution engine for the module.-    ee <- createModuleProviderForExistingModule m >>= createExecutionEngine-     -- Generate code for mfib, and then throw away the IO in the type.     -- The result is an ordinary Haskell function.-    let fib = unsafePurify $ generateFunction ee $ mfib fns+    iofib <- runEngineAccess $ do+                 addModule m+                 generateFunction $ mfib fns+    let fib = unsafePurify iofib      -- Run fib for the arguments.     forM_ args' $ \num -> do

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} module Vector where import System.Process(system)---import Control.Monad.Trans(liftIO)+import Control.Monad import Data.TypeNumbers import Data.Word @@ -74,16 +74,14 @@     m <- newModule     iovec <- defineModule m cgvec -    ee <- createModuleProviderForExistingModule m >>= createExecutionEngine- #if HAS_GETPOINTERTOGLOBAL-    fptr <- getPointerToFunction ee iovec+    fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec     let fvec = convert fptr      fvec 10 >>= print #endif -    let vec = generateFunction ee iovec+    vec <- runEngineAccess $ do addModule m; generateFunction iovec      vec 10 >>= print @@ -100,9 +98,10 @@         Just iovec' = castModuleValue =<< lookup "vectest" funcs 	ioretacc' :: Function (IO T)         Just ioretacc' = castModuleValue =<< lookup "retacc" funcs-    createModuleProviderForExistingModule m' >>= addModuleProvider ee-    let vec' = generateFunction ee iovec'-        retacc' = generateFunction ee ioretacc'+    +    (vec', retacc') <- runEngineAccess $ do+        addModule m'+        liftM2 (,) (generateFunction iovec') (generateFunction ioretacc')      dumpValue iovec' 

@@ -1,5 +1,5 @@ name: llvm-version: 0.4.4.2+version: 0.5.0.1 license: BSD3 license-file: LICENSE synopsis: Bindings to the LLVM compiler toolkit@@ -20,8 +20,10 @@     README.txt     configure     configure.ac+    examples/Arith.hs     examples/Array.hs     examples/BrainF.hs+    examples/Convert.hs     examples/DotProd.hs     examples/Fibonacci.hs     examples/HelloJIT.hs@@ -69,6 +71,7 @@       LLVM.FFI.ExecutionEngine       LLVM.FFI.Target       LLVM.FFI.Transforms.Scalar+      LLVM.Util.Arithmetic    other-modules:       LLVM.Core.CodeGen