diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,69 @@ +====================================================================== +Haskell LLVM Bindings Release License +====================================================================== +University of Illinois/NCSA +Open Source License + +Copyright (c) 2007-2009 Bryan O'Sullivan +All rights reserved. + +Developed by: + + Bryan O'Sullivan + http://www.serpentine.com/blog/ + + Lennart Augustsson + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimers in the documentation and/or other materials provided + with the distribution. + + * Neither the names of Bryan O'Sullivan, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used + to endorse or promote products derived from this Software + without specific prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + +====================================================================== +Copyrights and Licenses for Third Party Software Distributed with +Haskell LLVM Bindings: +====================================================================== + +The Haskell LLVM Bindings software may contain code written by third +parties. Any such software will have its own individual license file +in the directory in which it appears. This file will describe the +copyrights, license, and restrictions which apply to that code. + +The disclaimer of warranty in the University of Illinois Open Source +License applies to all code in the Haskell LLVM Bindings Distribution, +and nothing in any of the other licenses gives permission to use the +name of Bryan O'Sullivan or the University of Illinois to endorse or +promote products derived from this Software. + +The following pieces of software have additional or alternate +copyrights, licenses, and/or restrictions: + +Program Directory +------- --------- +configure . + + diff --git a/LLVM/Core.hs b/LLVM/Core.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core.hs @@ -0,0 +1,111 @@ +-- |The LLVM (Low Level Virtual Machine) is virtual machine at a machine code level. +-- It supports both stand alone code generation and JITing. +-- The Haskell llvm package is a (relatively) high level interface to the LLVM. +-- The high level interface makes it easy to construct LLVM code. +-- There is also an interface to the raw low level LLVM API as exposed by the LLVM C interface. +-- +-- LLVM code is organized into modules (type 'Module'). +-- Each module contains a number of global variables and functions (type 'Function'). +-- Each functions has a number of basic blocks (type 'BasicBlock'). +-- Each basic block has a number instructions, where each instruction produces +-- a value (type 'Value'). +-- +-- Unlike assembly code for a real processor the assembly code for LLVM is +-- in SSA (Static Single Assignment) form. This means that each instruction generates +-- a new bound variable which may not be assigned again. +-- A consequence of this is that where control flow joins from several execution +-- paths there has to be a phi pseudo instruction if you want different variables +-- to be joined into one. +-- +-- The definition of several of the LLVM entities ('Module', 'Function', and 'BasicBlock') +-- follow the same pattern. First the entity has to be created using @newX@ (where @X@ +-- is one of @Module@, @Function@, or @BasicBlock@), then at some later point it has to +-- given its definition using @defineX@. The reason for splitting the creation and +-- definition is that you often need to be able to refer to an entity before giving +-- it's body, e.g., in two mutually recursive functions. +-- The the @newX@ and @defineX@ function can also be done at the same time by using +-- @createX@. Furthermore, an explicit name can be given to an entity by the +-- @newNamedX@ function; the @newX@ function just generates a fresh name. +module LLVM.Core( + -- * Initialize + initializeNativeTarget, + -- * Modules + Module, newModule, newNamedModule, defineModule, destroyModule, createModule, + ModuleProvider, createModuleProviderForExistingModule, + PassManager, createPassManager, createFunctionPassManager, + writeBitcodeToFile, readBitcodeFromFile, + getModuleValues, getFunctions, getGlobalVariables, ModuleValue, castModuleValue, + -- * Instructions + module LLVM.Core.Instructions, + -- * Types classification + module LLVM.Core.Type, + -- * Extra types + module LLVM.Core.Data, + -- * Values and constants + Value, ConstValue, valueOf, constOf, value, + zero, allOnes, undef, + createString, createStringNul, + withString, withStringNul, + --constString, constStringNul, + constVector, constArray, + constStruct, constPackedStruct, + toVector, fromVector, vector, + -- * Code generation + CodeGenFunction, CodeGenModule, + -- * Functions + Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, + TFunction, liftCodeGenModule, getParams, + -- * Global variable creation + Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, + externFunction, staticFunction, + externGlobal, staticGlobal, + GlobalMappings, getGlobalMappings, + TGlobal, + -- * Globals + Linkage(..), + -- * Basic blocks + BasicBlock, newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + getBasicBlocks, + fromLabel, toLabel, + getInstructions, getOperands, hasUsers, getUsers, getUses, getUser, isChildOf, getDep, + -- * Misc + addAttributes, Attribute(..), + castVarArgs, + -- * Debugging + dumpValue, dumpType, getValueName, annotateValueList + ) where +import qualified LLVM.FFI.Core as FFI +import LLVM.Core.Util hiding (Function, BasicBlock, createModule, constString, constStringNul, constVector, constArray, constStruct, getModuleValues, valueHasType) +import LLVM.Core.CodeGen +import LLVM.Core.CodeGenMonad(CodeGenFunction, CodeGenModule, liftCodeGenModule, GlobalMappings, getGlobalMappings) +import LLVM.Core.Data +import LLVM.Core.Instructions +import LLVM.Core.Type +import LLVM.Core.Vector +import LLVM.Target.Native + +-- |Print a value. +dumpValue :: Value a -> IO () +dumpValue (Value v) = FFI.dumpValue v + +-- |Print a type. +dumpType :: Value a -> IO () +dumpType (Value v) = showTypeOf v >>= putStrLn + +-- |Get the name of a 'Value'. +getValueName :: Value a -> IO String +getValueName (Value a) = getValueNameU a + +-- |Convert a varargs function to a regular function. +castVarArgs :: (CastVarArgs a b) => Function a -> Function b +castVarArgs (Value a) = Value a + +-- TODO for types: +-- Enforce free is only called on malloc memory. (Enforce only one free?) +-- Enforce phi nodes a accessor of variables outside the bb +-- Enforce bb terminator +-- Enforce phi first +-- +-- TODO: +-- Add Struct, PackedStruct types +-- Get alignment from code gen diff --git a/LLVM/Core/CodeGen.hs b/LLVM/Core/CodeGen.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/CodeGen.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Core.CodeGen( + -- * Module creation + newModule, newNamedModule, defineModule, createModule, + getModuleValues, ModuleValue, castModuleValue, + -- * Globals + Linkage(..), + Visibility(..), + -- * Function creation + Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv, + addAttributes, + FFI.Attribute(..), + externFunction, staticFunction, + FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult, + TFunction, + -- * Global variable creation + Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal, + externGlobal, staticGlobal, + -- * Values + Value(..), ConstValue(..), + IsConst(..), valueOf, value, + zero, allOnes, undef, + createString, createStringNul, + withString, withStringNul, + constVector, constArray, constStruct, constPackedStruct, + -- * Basic blocks + BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock, + fromLabel, toLabel, + -- * Misc + withCurrentBuilder + ) where +import Data.Typeable +import Control.Monad(liftM, when) +import Data.Int +import Data.Word +import Data.Maybe(fromMaybe) +import Foreign.StablePtr (StablePtr, castStablePtrToPtr) +import Foreign.Ptr(minusPtr, nullPtr, castPtr, FunPtr, castFunPtrToPtr) +import qualified Foreign.Storable as St +import Types.Data.Num +import LLVM.Core.CodeGenMonad +import qualified LLVM.FFI.Core as FFI +import LLVM.FFI.Core(Linkage(..), Visibility(..)) +import qualified LLVM.Core.Util as U +import LLVM.Core.Type +import LLVM.Core.Data + +-------------------------------------- + +-- | Create a new module. +newModule :: IO U.Module +newModule = newNamedModule "_module" -- XXX should generate a name + +-- | Create a new explicitely named module. +newNamedModule :: String -- ^ module name + -> IO U.Module +newNamedModule = U.createModule + +-- | Give the body for a module. +defineModule :: U.Module -- ^ module that is defined + -> CodeGenModule a -- ^ module body + -> IO a +defineModule = runCodeGenModule + +-- | Create a new module with the given body. +createModule :: CodeGenModule a -- ^ module body + -> IO a +createModule cgm = newModule >>= \ m -> defineModule m cgm + +-------------------------------------- + +newtype ModuleValue = ModuleValue FFI.ValueRef + deriving (Show, Typeable) + +getModuleValues :: U.Module -> IO [(String, ModuleValue)] +getModuleValues = liftM (map (\ (s,p) -> (s, ModuleValue p))) . U.getModuleValues + +castModuleValue :: forall a . (IsType a) => ModuleValue -> Maybe (Value a) +castModuleValue (ModuleValue f) = + if U.valueHasType f (typeRef (undefined :: a)) then Just (Value f) else Nothing + +-------------------------------------- + +newtype Value a = Value { unValue :: FFI.ValueRef } + deriving (Show, Typeable) + +newtype ConstValue a = ConstValue { unConstValue :: FFI.ValueRef } + deriving (Show, Typeable) + +-- XXX merge with IsArithmetic? +class IsConst a where + constOf :: a -> ConstValue a + +instance IsConst Bool where constOf = constEnum (typeRef True) +--instance IsConst Char where constOf = constEnum (typeRef (0::Word8)) -- XXX Unicode +instance IsConst Word8 where constOf = constI +instance IsConst Word16 where constOf = constI +instance IsConst Word32 where constOf = constI +instance IsConst Word64 where constOf = constI +instance IsConst Int8 where constOf = constI +instance IsConst Int16 where constOf = constI +instance IsConst Int32 where constOf = constI +instance IsConst Int64 where constOf = constI +instance IsConst Float where constOf = constF +instance IsConst Double where constOf = constF +--instance IsConst FP128 where constOf = constF + +constOfPtr :: (IsType ptr) => + ptr -> Ptr b -> ConstValue ptr +constOfPtr proto p = + let ip = p `minusPtr` nullPtr + inttoptrC :: ConstValue int -> ConstValue ptr + inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto) + in if St.sizeOf p == 4 then + inttoptrC $ constOf (fromIntegral ip :: Word32) + else if St.sizeOf p == 8 then + inttoptrC $ constOf (fromIntegral ip :: Word64) + else + error "constOf Ptr: pointer size not 4 or 8" + +-- This instance doesn't belong here, but mutually recursive modules are painful. +instance (IsType a) => IsConst (Ptr a) where + constOf p = constOfPtr p p + +instance IsConst (StablePtr a) where + constOf p = constOfPtr p (castStablePtrToPtr p) + +instance (IsPrimitive a, IsConst a, PositiveT n) => IsConst (Vector n a) where + constOf (Vector xs) = constVector (map constOf xs) + +instance (IsConst a, IsSized a, NaturalT n) => IsConst (Array n a) where + constOf (Array xs) = constArray (map constOf xs) + +instance (IsConstFields a) => IsConst (Struct a) where + constOf (Struct a) = ConstValue $ U.constStruct (constFieldsOf a) False +instance (IsConstFields a) => IsConst (PackedStruct a) where + constOf (PackedStruct a) = ConstValue $ U.constStruct (constFieldsOf a) True + +class IsConstFields a where + constFieldsOf :: a -> [FFI.ValueRef] + +instance (IsConst a, IsConstFields as) => IsConstFields (a, as) where + constFieldsOf (a, as) = unConstValue (constOf a) : constFieldsOf as +instance IsConstFields () where + constFieldsOf _ = [] + +constEnum :: (Enum a) => FFI.TypeRef -> a -> ConstValue a +constEnum t i = ConstValue $ FFI.constInt t (fromIntegral $ fromEnum i) 0 + +constI :: (IsInteger a, Integral a) => a -> ConstValue a +constI i = ConstValue $ FFI.constInt (typeRef i) (fromIntegral i) (fromIntegral $ fromEnum $ isSigned i) + +constF :: (IsFloating a, Real a) => a -> ConstValue a +constF i = ConstValue $ FFI.constReal (typeRef i) (realToFrac i) + +valueOf :: (IsConst a) => a -> Value a +valueOf = value . constOf + +value :: ConstValue a -> Value a +value (ConstValue a) = Value a + +zero :: forall a . (IsType a) => ConstValue a +zero = ConstValue $ FFI.constNull $ typeRef (undefined :: a) + +allOnes :: forall a . (IsInteger a) => ConstValue a +allOnes = ConstValue $ FFI.constAllOnes $ typeRef (undefined :: a) + +undef :: forall a . (IsType a) => ConstValue a +undef = ConstValue $ FFI.getUndef $ typeRef (undefined :: a) + +{- +createString :: String -> ConstValue (DynamicArray Word8) +createString = ConstValue . U.constString + +constStringNul :: String -> ConstValue (DynamicArray Word8) +constStringNul = ConstValue . U.constStringNul +-} + +-------------------------------------- + + +-- |A function is simply a pointer to the function. +type Function a = Value (Ptr a) + +-- | Create a new named function. +newNamedFunction :: forall a . (IsFunction a) + => Linkage + -> String -- ^ Function name + -> CodeGenModule (Function a) +newNamedFunction linkage name = do + modul <- getModule + let typ = typeRef (undefined :: a) + liftIO $ liftM Value $ U.addFunction modul linkage name typ + +-- | Create a new function. Use 'newNamedFunction' to create a function with external linkage, since +-- it needs a known name. +newFunction :: forall a . (IsFunction a) + => Linkage + -> CodeGenModule (Function a) +newFunction linkage = genMSym "fun" >>= newNamedFunction linkage + +-- | Define a function body. The basic block returned by the function is the function entry point. +defineFunction :: forall f . (FunctionArgs f) + => Function f -- ^ Function to define (created by 'newFunction'). + -> FunctionCodeGen f -- ^ Function body. + -> CodeGenModule () +defineFunction fn body = do + bld <- liftIO $ U.createBuilder + let body' = do + l <- newBasicBlock + defineBasicBlock l + applyArgs fn body :: CodeGenFunction (FunctionResult f) () + runCodeGenFunction bld (unValue fn) body' + return () + +-- | Create a new function with the given body. +createFunction :: (FunctionArgs f) + => Linkage + -> FunctionCodeGen f -- ^ Function body. + -> CodeGenModule (Function f) +createFunction linkage body = do + f <- newFunction linkage + defineFunction f body + return f + +-- | Create a new function with the given body. +createNamedFunction :: (FunctionArgs f) + => Linkage + -> String + -> FunctionCodeGen f -- ^ Function body. + -> CodeGenModule (Function f) +createNamedFunction linkage name body = do + f <- newNamedFunction linkage name + defineFunction f body + return f + +-- | Set the calling convention of a function. By default it is the +-- C calling convention. +setFuncCallConv :: Function a + -> FFI.CallingConvention + -> CodeGenModule () +setFuncCallConv (Value f) cc = do + liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc) + return () + +-- | Add attributes to a value. Beware, what attributes are allowed depends on +-- what kind of value it is. +addAttributes :: Value a -> Int -> [FFI.Attribute] -> CodeGenFunction r () +addAttributes (Value f) i as = do + liftIO $ FFI.addInstrAttribute f (fromIntegral i) (sum $ map FFI.fromAttribute as) + +-- Convert a function of type f = t1->t2->...-> IO r to +-- g = Value t1 -> Value t2 -> ... CodeGenFunction r () +class IsFunction f => FunctionArgs f where + type FunctionCodeGen f :: * + type FunctionResult f :: * + apArgs :: Int -> Function f -> FunctionCodeGen f -> CodeGenFunction (FunctionResult f) () + +applyArgs :: + (FunctionArgs f) => + Function f -> FunctionCodeGen f -> CodeGenFunction (FunctionResult f) () +applyArgs = apArgs 0 + +removeArg :: Function (a -> b) -> Function b +removeArg (Value f) = Value f + +instance (FunctionArgs b, IsFirstClass a) => FunctionArgs (a -> b) where + type FunctionCodeGen (a -> b) = Value a -> FunctionCodeGen b + type FunctionResult (a -> b) = FunctionResult b + apArgs n f g = apArgs (n+1) (removeArg f) (g $ Value $ U.getParam (unValue f) n) + +instance IsFirstClass a => FunctionArgs (IO a) where + type FunctionCodeGen (IO a) = CodeGenFunction a () + type FunctionResult (IO a) = a + apArgs _ _ g = g + +-- | This class is just to simplify contexts. +-- May be less useful since we convert functional dependencies to type families +class (FunctionArgs (IO a)) => FunctionRet a +instance (FunctionArgs (IO a)) => FunctionRet a + +-------------------------------------- + +-- |A basic block is a sequence of non-branching instructions, terminated by a control flow instruction. +newtype BasicBlock = BasicBlock FFI.BasicBlockRef + deriving (Show, Typeable) + +createBasicBlock :: CodeGenFunction r BasicBlock +createBasicBlock = do + b <- newBasicBlock + defineBasicBlock b + return b + +newBasicBlock :: CodeGenFunction r BasicBlock +newBasicBlock = genFSym >>= newNamedBasicBlock + +newNamedBasicBlock :: String -> CodeGenFunction r BasicBlock +newNamedBasicBlock name = do + fn <- getFunction + liftIO $ liftM BasicBlock $ U.appendBasicBlock fn name + +defineBasicBlock :: BasicBlock -> CodeGenFunction r () +defineBasicBlock (BasicBlock l) = do + bld <- getBuilder + liftIO $ U.positionAtEnd bld l + +getCurrentBasicBlock :: CodeGenFunction r BasicBlock +getCurrentBasicBlock = do + bld <- getBuilder + liftIO $ liftM BasicBlock $ U.getInsertBlock bld + +toLabel :: BasicBlock -> Value Label +toLabel (BasicBlock ptr) = Value (FFI.basicBlockAsValue ptr) + +fromLabel :: Value Label -> BasicBlock +fromLabel (Value ptr) = BasicBlock (FFI.valueAsBasicBlock ptr) + +-------------------------------------- + +--- XXX: the functions in this section (and addGlobalMapping) don't actually use any +-- Function state so should really be in the CodeGenModule monad + +-- | Create a reference to an external function while code generating for a function. +-- If LLVM cannot resolve its name, then you may try 'staticFunction'. +externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a) +externFunction name = externCore name $ fmap (unValue :: Function a -> FFI.ValueRef) . newNamedFunction ExternalLinkage + +-- | As 'externFunction', but for 'Global's rather than 'Function's +externGlobal :: forall a r . (IsType a) => Bool -> String -> CodeGenFunction r (Global a) +externGlobal isConst name = externCore name $ fmap (unValue :: Global a -> FFI.ValueRef) . newNamedGlobal isConst ExternalLinkage + +externCore :: forall a r . String -> (String -> CodeGenModule FFI.ValueRef) -> CodeGenFunction r (Global a) +externCore name act = do + es <- getExterns + case lookup name es of + Just f -> return $ Value f + Nothing -> do + f <- liftCodeGenModule $ act name + putExterns ((name, f) : es) + return $ Value f + +{- | +Make an external C function with a fixed address callable from LLVM code. +This callback function can also be a Haskell function, +that was imported like + +> foreign import ccall "&nextElement" +> nextElementFunPtr :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) + +See @examples\/List.hs@. + +When you only use 'externFunction', then LLVM cannot resolve the name. +(However, I do not know why.) +Thus 'staticFunction' manages a list of static functions. +This list is automatically installed by 'ExecutionEngine.simpleFunction' +and can be manually obtained by 'getGlobalMappings' +and installed by 'ExecutionEngine.addGlobalMappings'. +\"Installing\" means calling LLVM's @addGlobalMapping@ according to +. +-} +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 _ = [] diff --git a/LLVM/Core/CodeGenMonad.hs b/LLVM/Core/CodeGenMonad.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/CodeGenMonad.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.Core.CodeGenMonad( + -- * Module code generation + CodeGenModule, runCodeGenModule, genMSym, getModule, + GlobalMappings(..), addGlobalMapping, getGlobalMappings, + -- * Function code generation + CodeGenFunction, runCodeGenFunction, liftCodeGenModule, genFSym, getFunction, getBuilder, getFunctionModule, getExterns, putExterns, + -- * Reexport + liftIO + ) where +import Data.Typeable +import Control.Monad.State +import Control.Applicative (Applicative, ) + +import Foreign.Ptr (Ptr, ) + +import LLVM.Core.Util(Module, Builder, Function) + +-------------------------------------- + +data CGMState = CGMState { + cgm_module :: Module, + cgm_externs :: [(String, Function)], + cgm_global_mappings :: [(Function, Ptr ())], + cgm_next :: !Int + } + deriving (Show, Typeable) +newtype CodeGenModule a = CGM (StateT CGMState IO a) + deriving (Functor, Applicative, Monad, MonadState CGMState, MonadIO, Typeable) + +genMSym :: String -> CodeGenModule String +genMSym prefix = do + s <- get + let n = cgm_next s + put (s { cgm_next = n + 1 }) + return $ "_" ++ prefix ++ show n + +getModule :: CodeGenModule Module +getModule = gets cgm_module + +runCodeGenModule :: Module -> CodeGenModule a -> IO a +runCodeGenModule m (CGM body) = do + let cgm = CGMState { cgm_module = m, cgm_next = 1, cgm_externs = [], cgm_global_mappings = [] } + evalStateT body cgm + +-------------------------------------- + +data CGFState r = CGFState { + cgf_module :: CGMState, + cgf_builder :: Builder, + cgf_function :: Function, + cgf_next :: !Int + } + deriving (Show, Typeable) +newtype CodeGenFunction r a = CGF (StateT (CGFState r) IO a) + deriving (Functor, Applicative, Monad, MonadState (CGFState r), MonadIO, Typeable) + +genFSym :: CodeGenFunction a String +genFSym = do + s <- get + let n = cgf_next s + put (s { cgf_next = n + 1 }) + return $ "_L" ++ show n + +getFunction :: CodeGenFunction a Function +getFunction = gets cgf_function + +getBuilder :: CodeGenFunction a Builder +getBuilder = gets cgf_builder + +getFunctionModule :: CodeGenFunction a Module +getFunctionModule = gets (cgm_module . cgf_module) + +getExterns :: CodeGenFunction a [(String, Function)] +getExterns = gets (cgm_externs . cgf_module) + +putExterns :: [(String, Function)] -> CodeGenFunction a () +putExterns es = do + cgf <- get + let cgm' = (cgf_module cgf) { cgm_externs = es } + put (cgf { cgf_module = cgm' }) + +addGlobalMapping :: + Function -> Ptr () -> CodeGenModule () +addGlobalMapping value func = modify $ \cgm -> + cgm { cgm_global_mappings = + (value,func) : cgm_global_mappings cgm } + +newtype GlobalMappings = + GlobalMappings [(Function, Ptr ())] + +{- | +Get a list created by calls to 'staticFunction' +that must be passed to the execution engine +via 'LLVM.ExecutionEngine.addGlobalMappings'. +-} +getGlobalMappings :: + CodeGenModule GlobalMappings +getGlobalMappings = + gets (GlobalMappings . cgm_global_mappings) + +runCodeGenFunction :: Builder -> Function -> CodeGenFunction r a -> CodeGenModule a +runCodeGenFunction bld fn (CGF body) = do + cgm <- get + let cgf = CGFState { cgf_module = cgm, + cgf_builder = bld, + cgf_function = fn, + cgf_next = 1 } + (a, cgf') <- liftIO $ runStateT body cgf + put (cgf_module cgf') + return a + +-------------------------------------- + +-- | Allows you to define part of a module while in the middle of defining a function. +liftCodeGenModule :: CodeGenModule a -> CodeGenFunction r a +liftCodeGenModule (CGM act) = do + cgf <- get + (a, cgm') <- liftIO $ runStateT act (cgf_module cgf) + put (cgf { cgf_module = cgm' }) + return a diff --git a/LLVM/Core/Data.hs b/LLVM/Core/Data.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Data.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.Core.Data(IntN(..), WordN(..), FP128(..), + Array(..), Vector(..), Ptr, Label, Struct(..), PackedStruct(..)) where +import Data.Typeable +import Foreign.Ptr(Ptr) + +-- TODO: +-- Make instances IntN, WordN to actually do the right thing. +-- Make FP128 do the right thing +-- Make Array functions. + +-- |Variable sized signed integer. +-- The /n/ parameter should belong to @PosI@. +newtype IntN n = IntN Integer + deriving (Show, Typeable) + +-- |Variable sized unsigned integer. +-- The /n/ parameter should belong to @PosI@. +newtype WordN n = WordN Integer + deriving (Show, Typeable) + +-- |128 bit floating point. +newtype FP128 = FP128 Rational + deriving (Show, Typeable) + +-- |Fixed sized arrays, the array size is encoded in the /n/ parameter. +newtype Array n a = Array [a] + deriving (Show, Typeable) + +-- |Fixed sized vector, the array size is encoded in the /n/ parameter. +newtype Vector n a = Vector [a] + deriving (Show, Typeable) + +-- |Label type, produced by a basic block. +data Label + deriving (Typeable) + +-- |Struct types; a list (nested tuple) of component types. +newtype Struct a = Struct a + deriving (Show, Typeable) +newtype PackedStruct a = PackedStruct a + deriving (Show, Typeable) diff --git a/LLVM/Core/Instructions.hs b/LLVM/Core/Instructions.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Instructions.hs @@ -0,0 +1,1253 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module LLVM.Core.Instructions( + -- * ADT representation of IR + BinOpDesc(..), InstrDesc(..), ArgDesc(..), getInstrDesc, + -- * Terminator instructions + ret, + condBr, + br, + switch, + invoke, invokeWithConv, + unreachable, + -- * Arithmetic binary operations + -- | Arithmetic operations with the normal semantics. + -- The u instractions are unsigned, the s instructions are signed. + add, sub, mul, neg, + iadd, isub, imul, ineg, + fadd, fsub, fmul, fneg, + idiv, irem, + udiv, sdiv, fdiv, urem, srem, frem, + -- * Logical binary operations + -- |Logical instructions with the normal semantics. + shl, lshr, ashr, and, or, xor, inv, + -- * Vector operations + extractelement, + insertelement, + shufflevector, + -- * Aggregate operation + extractvalue, + insertvalue, + -- * Memory access + malloc, arrayMalloc, + alloca, arrayAlloca, + free, + load, + store, + getElementPtr, getElementPtr0, + -- * Conversions + trunc, zext, sext, ext, zadapt, sadapt, adapt, + fptrunc, fpext, + fptoui, fptosi, fptoint, + uitofp, sitofp, inttofp, + ptrtoint, inttoptr, + bitcast, + bitcastElements, + -- * Comparison + CmpPredicate(..), IntPredicate(..), FPPredicate(..), + CmpOp, CmpRet, CmpResult, + cmp, pcmp, icmp, fcmp, + select, + -- * Other + phi, addPhiInputs, + call, callWithConv, + + -- * Classes and types + Terminate, + Ret, CallArgs, ABinOp, ABinOpResult, IsConst, + FunctionArgs, FunctionRet, FunctionCodeGen, FunctionResult, + AllocArg, + GetElementPtr, ElementPtrType, IsIndexArg, + GetValue, ValueType + ) where +import Prelude hiding (and, or) +import Data.Typeable +import Control.Monad(liftM) +import Data.Int +import Data.Word +import Data.Map(fromList, (!)) +import Foreign.Ptr (FunPtr, ) +import Foreign.C(CInt, CUInt) +import Types.Data.Ord(LTT, GTT) +import Types.Data.Num(Dec, DecN, (:.), d1, fromIntegerT, Pred) +import qualified LLVM.FFI.Core as FFI +import LLVM.Core.Data +import LLVM.Core.Type +import LLVM.Core.CodeGenMonad +import LLVM.Core.CodeGen +import qualified LLVM.Core.Util as U + +-- TODO: +-- Add vector version of arithmetic +-- Add rest of instructions +-- Use Terminate to ensure bb termination (how?) +-- more intrinsics are needed to, e.g., create an empty vector + +data ArgDesc = AV String | AI Int | AL String | AE + +instance Show ArgDesc where + -- show (AV s) = "V_" ++ s + -- show (AI i) = "I_" ++ show i + -- show (AL l) = "L_" ++ l + show (AV s) = s + show (AI i) = show i + show (AL l) = l + show AE = "voidarg?" + +data BinOpDesc = BOAdd | BOAddNuw | BOAddNsw | BOAddNuwNsw | BOFAdd + | BOSub | BOSubNuw | BOSubNsw | BOSubNuwNsw | BOFSub + | BOMul | BOMulNuw | BOMulNsw | BOMulNuwNsw | BOFMul + | BOUDiv | BOSDiv | BOSDivExact | BOFDiv | BOURem | BOSRem | BOFRem + | BOShL | BOLShR | BOAShR | BOAnd | BOOr | BOXor + deriving Show + +-- FIXME: complete definitions for unimplemented instructions +data InstrDesc = + -- terminators + IDRet TypeDesc ArgDesc | IDRetVoid + | IDBrCond ArgDesc ArgDesc ArgDesc | IDBrUncond ArgDesc + | IDSwitch [(ArgDesc, ArgDesc)] + | IDIndirectBr + | IDInvoke + | IDUnwind + | IDUnreachable + -- binary operators (including bitwise) + | IDBinOp BinOpDesc TypeDesc ArgDesc ArgDesc + -- memory access and addressing + | IDAlloca TypeDesc Int Int | IDLoad TypeDesc ArgDesc | IDStore TypeDesc ArgDesc ArgDesc + | IDGetElementPtr TypeDesc [ArgDesc] + -- conversion + | IDTrunc TypeDesc TypeDesc ArgDesc | IDZExt TypeDesc TypeDesc ArgDesc + | IDSExt TypeDesc TypeDesc ArgDesc | IDFPtoUI TypeDesc TypeDesc ArgDesc + | IDFPtoSI TypeDesc TypeDesc ArgDesc | IDUItoFP TypeDesc TypeDesc ArgDesc + | IDSItoFP TypeDesc TypeDesc ArgDesc + | IDFPTrunc TypeDesc TypeDesc ArgDesc | IDFPExt TypeDesc TypeDesc ArgDesc + | IDPtrToInt TypeDesc TypeDesc ArgDesc | IDIntToPtr TypeDesc TypeDesc ArgDesc + | IDBitcast TypeDesc TypeDesc ArgDesc + -- other + | IDICmp IntPredicate ArgDesc ArgDesc | IDFCmp FPPredicate ArgDesc ArgDesc + | IDPhi TypeDesc [(ArgDesc, ArgDesc)] | IDCall TypeDesc ArgDesc [ArgDesc] + | IDSelect TypeDesc ArgDesc ArgDesc | IDUserOp1 | IDUserOp2 | IDVAArg + -- vector operators + | IDExtractElement | IDInsertElement | IDShuffleVector + -- aggregate operators + | IDExtractValue | IDInsertValue + -- invalid + | IDInvalidOp + deriving Show + +-- TODO: overflow support for binary operations (add/sub/mul) +getInstrDesc :: FFI.ValueRef -> IO (String, InstrDesc) +getInstrDesc v = do + valueName <- U.getValueNameU v + opcode <- FFI.instGetOpcode v + t <- FFI.typeOf v >>= typeDesc2 + -- FIXME: sizeof() does not work for types! + --tsize <- FFI.typeOf v -- >>= FFI.sizeOf -- >>= FFI.constIntGetZExtValue >>= return . fromIntegral + tsize <- return 1 + os <- U.getOperands v >>= mapM getArgDesc + os0 <- if length os > 0 then return $ os !! 0 else return AE + os1 <- if length os > 1 then return $ os !! 1 else return AE + t2 <- (if not (null os) && (opcode >= 30 || opcode <= 41) + then U.getOperands v >>= return . snd . head >>= FFI.typeOf >>= typeDesc2 + else return TDVoid) + p <- if opcode `elem` [42, 43] then FFI.cmpInstGetPredicate v else return 0 + let instr = + (if opcode >= 8 && opcode <= 25 -- binary arithmetic + then IDBinOp (getBinOp opcode) t os0 os1 + else if opcode >= 30 && opcode <= 41 -- conversion + then (getConvOp opcode) t2 t os0 + else case opcode of + { 1 -> if null os then IDRetVoid else IDRet t os0; + 2 -> if length os == 1 then IDBrUncond os0 else IDBrCond os0 (os !! 2) os1; + 3 -> IDSwitch $ toPairs os; + -- TODO (can skip for now) + -- 4 -> IndirectBr ; 5 -> Invoke ; + 6 -> IDUnwind; 7 -> IDUnreachable; + 26 -> IDAlloca (getPtrType t) tsize (getImmInt os0); + 27 -> IDLoad t os0; 28 -> IDStore t os0 os1; + 29 -> IDGetElementPtr t os; + 42 -> IDICmp (toIntPredicate p) os0 os1; + 43 -> IDFCmp (toFPPredicate p) os0 os1; + 44 -> IDPhi t $ toPairs os; + -- FIXME: getelementptr arguments are not handled + 45 -> IDCall t (last os) (init os); + 46 -> IDSelect t os0 os1; + -- TODO (can skip for now) + -- 47 -> UserOp1 ; 48 -> UserOp2 ; 49 -> VAArg ; + -- 50 -> ExtractElement ; 51 -> InsertElement ; 52 -> ShuffleVector ; + -- 53 -> ExtractValue ; 54 -> InsertValue ; + _ -> IDInvalidOp }) + return (valueName, instr) + --if instr /= InvalidOp then return instr else fail $ "Invalid opcode: " ++ show opcode + where getBinOp o = fromList [(8, BOAdd), (9, BOFAdd), (10, BOSub), (11, BOFSub), + (12, BOMul), (13, BOFMul), (14, BOUDiv), (15, BOSDiv), + (16, BOFDiv), (17, BOURem), (18, BOSRem), (19, BOFRem), + (20, BOShL), (21, BOLShR), (22, BOAShR), (23, BOAnd), + (24, BOOr), (25, BOXor)] ! o + getConvOp o = fromList [(30, IDTrunc), (31, IDZExt), (32, IDSExt), (33, IDFPtoUI), + (34, IDFPtoSI), (35, IDUItoFP), (36, IDSItoFP), (37, IDFPTrunc), + (38, IDFPExt), (39, IDPtrToInt), (40, IDIntToPtr), (41, IDBitcast)] ! o + toPairs xs = zip (stride 2 xs) (stride 2 (drop 1 xs)) + stride _ [] = [] + stride n (x:xs) = x : stride n (drop (n-1) xs) + getPtrType (TDPtr t) = t + getPtrType _ = TDVoid + getImmInt (AI i) = i + getImmInt _ = 0 + +-- TODO: fix for non-int constants +getArgDesc :: (String, FFI.ValueRef) -> IO ArgDesc +getArgDesc (vname, v) = do + isC <- U.isConstant v + t <- FFI.typeOf v >>= typeDesc2 + if isC + then case t of + TDInt _ _ -> do + cV <- FFI.constIntGetSExtValue v + return $ AI $ fromIntegral cV + _ -> return AE + else case t of + TDLabel -> return $ AL vname + _ -> return $ AV vname + +-------------------------------------- + +type Terminate = () +terminate :: Terminate +terminate = () + +-------------------------------------- + +-- |Acceptable arguments to the 'ret' instruction. +class Ret a r where + ret' :: a -> CodeGenFunction r Terminate + +-- | Return from the current function with the given value. Use () as the return value for what would be a void function in C. +ret :: (Ret a r) => a -> CodeGenFunction r Terminate +ret = ret' + +-- overlaps with Ret () ()! +{- +instance (IsFirstClass a, IsConst a) => Ret a a where + ret' = ret . valueOf +-} + +instance Ret (Value a) a where + ret' (Value a) = do + withCurrentBuilder_ $ \ bldPtr -> FFI.buildRet bldPtr a + return terminate + +instance Ret () () where + ret' _ = do + withCurrentBuilder_ $ FFI.buildRetVoid + return terminate + +withCurrentBuilder_ :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r () +withCurrentBuilder_ p = withCurrentBuilder p >> return () + +-------------------------------------- + +-- | Branch to the first basic block if the boolean is true, otherwise to the second basic block. +condBr :: Value Bool -- ^ Boolean to branch upon. + -> BasicBlock -- ^ Target for true. + -> BasicBlock -- ^ Target for false. + -> CodeGenFunction r Terminate +condBr (Value b) (BasicBlock t1) (BasicBlock t2) = do + withCurrentBuilder_ $ \ bldPtr -> FFI.buildCondBr bldPtr b t1 t2 + return terminate + +-------------------------------------- + +-- | Unconditionally branch to the given basic block. +br :: BasicBlock -- ^ Branch target. + -> CodeGenFunction r Terminate +br (BasicBlock t) = do + withCurrentBuilder_ $ \ bldPtr -> FFI.buildBr bldPtr t + return terminate + +-------------------------------------- + +-- | Branch table instruction. +switch :: (IsInteger a) + => Value a -- ^ Value to branch upon. + -> BasicBlock -- ^ Default branch target. + -> [(ConstValue a, BasicBlock)] -- ^ Labels and corresponding branch targets. + -> CodeGenFunction r Terminate +switch (Value val) (BasicBlock dflt) arms = do + withCurrentBuilder_ $ \ bldPtr -> do + inst <- FFI.buildSwitch bldPtr val dflt (fromIntegral $ length arms) + sequence_ [ FFI.addCase inst c b | (ConstValue c, BasicBlock b) <- arms ] + return terminate + +-------------------------------------- + +-- |Inform the code generator that this code can never be reached. +unreachable :: CodeGenFunction r Terminate +unreachable = do + withCurrentBuilder_ FFI.buildUnreachable + return terminate + +-------------------------------------- + +type FFIBinOp = FFI.BuilderRef -> FFI.ValueRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef +type FFIConstBinOp = FFI.ValueRef -> FFI.ValueRef -> FFI.ValueRef + + +withArithmeticType :: + (IsArithmetic c) => + (ArithmeticType c -> a -> CodeGenFunction r (v c)) -> + (a -> CodeGenFunction r (v c)) +withArithmeticType f = f arithmeticType + +-- |Acceptable arguments to arithmetic binary instructions. +class ABinOp a b where + type ABinOpResult a b :: * + abinop :: FFIConstBinOp -> FFIBinOp -> a -> b -> CodeGenFunction r (ABinOpResult a b) + +add :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +add = + curry $ withArithmeticType $ \typ -> uncurry $ case typ of + IntegerType -> abinop FFI.constAdd FFI.buildAdd + FloatingType -> abinop FFI.constFAdd FFI.buildFAdd + +sub :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +sub = + curry $ withArithmeticType $ \typ -> uncurry $ case typ of + IntegerType -> abinop FFI.constSub FFI.buildSub + FloatingType -> abinop FFI.constFSub FFI.buildFSub + +mul :: (IsArithmetic c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +mul = + curry $ withArithmeticType $ \typ -> uncurry $ case typ of + IntegerType -> abinop FFI.constMul FFI.buildMul + FloatingType -> abinop FFI.constFMul FFI.buildFMul + +iadd :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +iadd = abinop FFI.constAdd FFI.buildAdd +isub :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +isub = abinop FFI.constSub FFI.buildSub +imul :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +imul = abinop FFI.constMul FFI.buildMul + +-- | signed or unsigned integer division depending on the type +idiv :: + forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => + a -> b -> CodeGenFunction r (v c) +idiv = + if isSigned (undefined :: c) + then abinop FFI.constSDiv FFI.buildSDiv + else abinop FFI.constUDiv FFI.buildUDiv +-- | signed or unsigned remainder depending on the type +irem :: + forall a b c r v. (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => + a -> b -> CodeGenFunction r (v c) +irem = + if isSigned (undefined :: c) + then abinop FFI.constSRem FFI.buildSRem + else abinop FFI.constURem FFI.buildURem + +{-# DEPRECATED udiv "use idiv instead" #-} +{-# DEPRECATED sdiv "use idiv instead" #-} +{-# DEPRECATED urem "use irem instead" #-} +{-# DEPRECATED srem "use irem instead" #-} +udiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +udiv = abinop FFI.constUDiv FFI.buildUDiv +sdiv :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +sdiv = abinop FFI.constSDiv FFI.buildSDiv +urem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +urem = abinop FFI.constURem FFI.buildURem +srem :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +srem = abinop FFI.constSRem FFI.buildSRem + +fadd :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fadd = abinop FFI.constFAdd FFI.buildFAdd +fsub :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fsub = abinop FFI.constFSub FFI.buildFSub +fmul :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fmul = abinop FFI.constFMul FFI.buildFMul + +-- | Floating point division. +fdiv :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +fdiv = abinop FFI.constFDiv FFI.buildFDiv +-- | Floating point remainder. +frem :: (IsFloating c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +frem = abinop FFI.constFRem FFI.buildFRem + +shl :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +shl = abinop FFI.constShl FFI.buildShl +lshr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +lshr = abinop FFI.constLShr FFI.buildLShr +ashr :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +ashr = abinop FFI.constAShr FFI.buildAShr +and :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +and = abinop FFI.constAnd FFI.buildAnd +or :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +or = abinop FFI.constOr FFI.buildOr +xor :: (IsInteger c, ABinOp a b, v c ~ ABinOpResult a b) => a -> b -> CodeGenFunction r (v c) +xor = abinop FFI.constXor FFI.buildXor + +instance ABinOp (Value a) (Value a) where + type ABinOpResult (Value a) (Value a) = Value a + abinop _ op (Value a1) (Value a2) = buildBinOp op a1 a2 + +instance ABinOp (ConstValue a) (Value a) where + type ABinOpResult (ConstValue a) (Value a) = Value a + abinop _ op (ConstValue a1) (Value a2) = buildBinOp op a1 a2 + +instance ABinOp (Value a) (ConstValue a) where + type ABinOpResult (Value a) (ConstValue a) = Value a + abinop _ op (Value a1) (ConstValue a2) = buildBinOp op a1 a2 + +instance ABinOp (ConstValue a) (ConstValue a) where + type ABinOpResult (ConstValue a) (ConstValue a) = ConstValue a + abinop cop _ (ConstValue a1) (ConstValue a2) = + return $ ConstValue $ cop a1 a2 + +instance (IsConst a) => ABinOp (Value a) a where + type ABinOpResult (Value a) a = Value a + abinop cop op a1 a2 = abinop cop op a1 (constOf a2) + +instance (IsConst a) => ABinOp a (Value a) where + type ABinOpResult a (Value a) = Value a + abinop cop op a1 a2 = abinop cop op (constOf a1) a2 + +--instance (IsConst a) => ABinOp a a (ConstValue a) where +-- abinop cop op a1 a2 = abinop cop op (constOf a1) (constOf a2) + +buildBinOp :: FFIBinOp -> FFI.ValueRef -> FFI.ValueRef -> CodeGenFunction r (Value a) +buildBinOp op a1 a2 = + liftM Value $ + withCurrentBuilder $ \ bld -> + U.withEmptyCString $ op bld a1 a2 + +type FFIUnOp = FFI.BuilderRef -> FFI.ValueRef -> U.CString -> IO FFI.ValueRef + +buildUnOp :: FFIUnOp -> FFI.ValueRef -> CodeGenFunction r (Value a) +buildUnOp op a = + liftM Value $ + withCurrentBuilder $ \ bld -> + U.withEmptyCString $ op bld a + +neg :: forall r a. (IsArithmetic a) => Value a -> CodeGenFunction r (Value a) +neg = + withArithmeticType $ \typ -> case typ of + IntegerType -> \(Value x) -> buildUnOp FFI.buildNeg x + FloatingType -> abinop FFI.constFSub FFI.buildFSub (value zero :: Value a) + +ineg :: (IsInteger a) => Value a -> CodeGenFunction r (Value a) +ineg (Value x) = buildUnOp FFI.buildNeg x + +fneg :: forall r a. (IsFloating a) => Value a -> CodeGenFunction r (Value a) +fneg = fsub (value zero :: Value a) +{- +fneg (Value x) = buildUnOp FFI.buildFNeg x +-} + +inv :: (IsInteger a) => Value a -> CodeGenFunction r (Value a) +inv (Value x) = buildUnOp FFI.buildNot x + +-------------------------------------- + +-- | Get a value from a vector. +extractelement :: (PositiveT n) + => Value (Vector n a) -- ^ Vector + -> Value Word32 -- ^ Index into the vector + -> CodeGenFunction r (Value a) +extractelement (Value vec) (Value i) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildExtractElement bldPtr vec i + +-- | Insert a value into a vector, nondestructive. +insertelement :: (PositiveT n) + => Value (Vector n a) -- ^ Vector + -> Value a -- ^ Value to insert + -> Value Word32 -- ^ Index into the vector + -> CodeGenFunction r (Value (Vector n a)) +insertelement (Value vec) (Value e) (Value i) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildInsertElement bldPtr vec e i + +-- | Permute vector. +shufflevector :: (PositiveT n, PositiveT m) + => Value (Vector n a) + -> Value (Vector n a) + -> ConstValue (Vector m Word32) + -> CodeGenFunction r (Value (Vector m a)) +shufflevector (Value a) (Value b) (ConstValue mask) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildShuffleVector bldPtr a b mask + + +-- |Acceptable arguments to 'extractvalue' and 'insertvalue'. +class GetValue agg ix where + type ValueType agg ix :: * + getIx :: agg -> ix -> CUInt + +instance (GetField as i, NaturalT i) => GetValue (Struct as) i where + type ValueType (Struct as) i = FieldType as i + getIx _ n = fromIntegerT n + +instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word32 where + type ValueType (Array n a) Word32 = a + getIx _ n = fromIntegral n + +instance (IsFirstClass a, NaturalT n) => GetValue (Array n a) Word64 where + type ValueType (Array n a) Word64 = a + getIx _ n = fromIntegral n + + +instance (IsFirstClass a, NaturalT n, NaturalT (Dec i), LTT (Dec i) n) => GetValue (Array n a) (Dec i) where + type ValueType (Array n a) (Dec i) = a + getIx _ n = fromIntegerT n + + +-- | Get a value from an aggregate. +extractvalue :: forall r agg i. + GetValue agg i + => Value agg -- ^ Aggregate + -> i -- ^ Index into the aggregate + -> CodeGenFunction r (Value (ValueType agg i)) +extractvalue (Value agg) i = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildExtractValue bldPtr agg (getIx (undefined::agg) i) + +-- | Insert a value into an aggregate, nondestructive. +insertvalue :: forall r agg i. + GetValue agg i + => Value agg -- ^ Aggregate + -> Value (ValueType agg i) -- ^ Value to insert + -> i -- ^ Index into the aggregate + -> CodeGenFunction r (Value agg) +insertvalue (Value agg) (Value e) i = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildInsertValue bldPtr agg e (getIx (undefined::agg) i) + + +-------------------------------------- + +-- XXX should allows constants + +-- | Truncate a value to a shorter bit width. +trunc :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +trunc = convert FFI.buildTrunc + +-- | Zero extend a value to a wider width. +-- If possible, use 'ext' that chooses the right padding according to the types +zext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +zext = convert FFI.buildZExt + +-- | Sign extend a value to wider width. +-- If possible, use 'ext' that chooses the right padding according to the types +sext :: (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +sext = convert FFI.buildSExt + +-- | Extend a value to wider width. +-- If the target type is signed, then preserve the sign, +-- If the target type is unsigned, then extended by zeros. +ext :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +ext = + if isSigned (undefined :: b) + then convert FFI.buildSExt + else convert FFI.buildZExt + + +-- | It is 'zext', 'trunc' or nop depending on the relation of the sizes. +zadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) + => Value a -> CodeGenFunction r (Value b) +zadapt = + case compare (sizeOf (typeDesc (undefined :: a))) + (sizeOf (typeDesc (undefined :: b))) of + LT -> convert FFI.buildZExt + EQ -> convert FFI.buildBitCast + GT -> convert FFI.buildTrunc + +-- | It is 'sext', 'trunc' or nop depending on the relation of the sizes. +sadapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b) + => Value a -> CodeGenFunction r (Value b) +sadapt = + case compare (sizeOf (typeDesc (undefined :: a))) + (sizeOf (typeDesc (undefined :: b))) of + LT -> convert FFI.buildSExt + EQ -> convert FFI.buildBitCast + GT -> convert FFI.buildTrunc + +-- | It is 'sadapt' or 'zadapt' depending on the sign mode. +adapt :: forall a b r. (IsInteger a, IsInteger b, NumberOfElements a ~ NumberOfElements b, Signed a ~ Signed b) + => Value a -> CodeGenFunction r (Value b) +adapt = + case compare (sizeOf (typeDesc (undefined :: a))) + (sizeOf (typeDesc (undefined :: b))) of + LT -> + if isSigned (undefined :: b) + then convert FFI.buildSExt + else convert FFI.buildZExt + EQ -> convert FFI.buildBitCast + GT -> convert FFI.buildTrunc + +-- | Truncate a floating point value. +fptrunc :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, GTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +fptrunc = convert FFI.buildFPTrunc + +-- | Extend a floating point value. +fpext :: (IsFloating a, IsFloating b, NumberOfElements a ~ NumberOfElements b, IsSized a, IsSized b, LTT (SizeOf a) (SizeOf b)) + => Value a -> CodeGenFunction r (Value b) +fpext = convert FFI.buildFPExt + +{-# DEPRECATED fptoui "use fptoint since it is type-safe with respect to signs" #-} +-- | Convert a floating point value to an unsigned integer. +fptoui :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +fptoui = convert FFI.buildFPToUI + +{-# DEPRECATED fptosi "use fptoint since it is type-safe with respect to signs" #-} +-- | Convert a floating point value to a signed integer. +fptosi :: (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +fptosi = convert FFI.buildFPToSI + +-- | Convert a floating point value to an integer. +-- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@. +fptoint :: forall r a b. (IsFloating a, IsInteger b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +fptoint = + if isSigned (undefined :: b) + then convert FFI.buildFPToSI + else convert FFI.buildFPToUI + + +{- DEPRECATED uitofp "use inttofp since it is type-safe with respect to signs" -} +-- | Convert an unsigned integer to a floating point value. +-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool. +uitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +uitofp = convert FFI.buildUIToFP + +{- DEPRECATED sitofp "use inttofp since it is type-safe with respect to signs" -} +-- | Convert a signed integer to a floating point value. +-- Although 'inttofp' should be prefered, this function may be useful for conversion from Bool. +sitofp :: (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +sitofp = convert FFI.buildSIToFP + +-- | Convert an integer to a floating point value. +-- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@. +inttofp :: forall r a b. (IsInteger a, IsFloating b, NumberOfElements a ~ NumberOfElements b) => Value a -> CodeGenFunction r (Value b) +inttofp = + if isSigned (undefined :: a) + then convert FFI.buildSIToFP + else convert FFI.buildUIToFP + + +-- | Convert a pointer to an integer. +ptrtoint :: (IsInteger b, IsPrimitive b) => Value (Ptr a) -> CodeGenFunction r (Value b) +ptrtoint = convert FFI.buildPtrToInt + +-- | Convert an integer to a pointer. +inttoptr :: (IsInteger a, IsType b) => Value a -> CodeGenFunction r (Value (Ptr b)) +inttoptr = convert FFI.buildIntToPtr + +-- | Convert between to values of the same size by just copying the bit pattern. +bitcast :: (IsFirstClass a, IsFirstClass b, IsSized a, IsSized b, SizeOf a ~ SizeOf b) + => Value a -> CodeGenFunction r (Value b) +bitcast = convert FFI.buildBitCast + +-- | Like 'bitcast' for vectors but it enforces that the number of elements remains the same. +bitcastElements :: (PositiveT n, IsPrimitive a, IsPrimitive b, IsSized a, IsSized b, SizeOf a ~ SizeOf b) + => Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) +bitcastElements = convert FFI.buildBitCast + + +type FFIConvert = FFI.BuilderRef -> FFI.ValueRef -> FFI.TypeRef -> U.CString -> IO FFI.ValueRef + +convert :: forall a b r . (IsType b) => FFIConvert -> Value a -> CodeGenFunction r (Value b) +convert conv (Value a) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ conv bldPtr a (typeRef (undefined :: b)) + +-------------------------------------- + +data CmpPredicate = + CmpEQ -- ^ equal + | CmpNE -- ^ not equal + | CmpGT -- ^ greater than + | CmpGE -- ^ greater or equal + | CmpLT -- ^ less than + | CmpLE -- ^ less or equal + deriving (Eq, Ord, Enum, Show, Typeable) + +uintFromCmpPredicate :: CmpPredicate -> IntPredicate +uintFromCmpPredicate p = + case p of + CmpEQ -> IntEQ + CmpNE -> IntNE + CmpGT -> IntUGT + CmpGE -> IntUGE + CmpLT -> IntULT + CmpLE -> IntULE + +sintFromCmpPredicate :: CmpPredicate -> IntPredicate +sintFromCmpPredicate p = + case p of + CmpEQ -> IntEQ + CmpNE -> IntNE + CmpGT -> IntSGT + CmpGE -> IntSGE + CmpLT -> IntSLT + CmpLE -> IntSLE + +fpFromCmpPredicate :: CmpPredicate -> FPPredicate +fpFromCmpPredicate p = + case p of + CmpEQ -> FPOEQ + CmpNE -> FPONE + CmpGT -> FPOGT + CmpGE -> FPOGE + CmpLT -> FPOLT + CmpLE -> FPOLE + + +data IntPredicate = + IntEQ -- ^ equal + | IntNE -- ^ not equal + | IntUGT -- ^ unsigned greater than + | IntUGE -- ^ unsigned greater or equal + | IntULT -- ^ unsigned less than + | IntULE -- ^ unsigned less or equal + | IntSGT -- ^ signed greater than + | IntSGE -- ^ signed greater or equal + | IntSLT -- ^ signed less than + | IntSLE -- ^ signed less or equal + deriving (Eq, Ord, Enum, Show, Typeable) + +fromIntPredicate :: IntPredicate -> CInt +fromIntPredicate p = fromIntegral (fromEnum p + 32) + +toIntPredicate :: CInt -> IntPredicate +toIntPredicate p = toEnum $ fromIntegral p - 32 + +data FPPredicate = + FPFalse -- ^ Always false (always folded) + | FPOEQ -- ^ True if ordered and equal + | FPOGT -- ^ True if ordered and greater than + | FPOGE -- ^ True if ordered and greater than or equal + | FPOLT -- ^ True if ordered and less than + | FPOLE -- ^ True if ordered and less than or equal + | FPONE -- ^ True if ordered and operands are unequal + | FPORD -- ^ True if ordered (no nans) + | FPUNO -- ^ True if unordered: isnan(X) | isnan(Y) + | FPUEQ -- ^ True if unordered or equal + | FPUGT -- ^ True if unordered or greater than + | FPUGE -- ^ True if unordered, greater than, or equal + | FPULT -- ^ True if unordered or less than + | FPULE -- ^ True if unordered, less than, or equal + | FPUNE -- ^ True if unordered or not equal + | FPT -- ^ Always true (always folded) + deriving (Eq, Ord, Enum, Show, Typeable) + +fromFPPredicate :: FPPredicate -> CInt +fromFPPredicate p = fromIntegral (fromEnum p) + +toFPPredicate :: CInt -> FPPredicate +toFPPredicate p = toEnum $ fromIntegral p + +-- |Acceptable operands to comparison instructions. +class CmpRet (CmpType a b) => CmpOp a b where + type CmpType a b :: * + cmpop :: FFIBinOp -> a -> b -> CodeGenFunction r (Value (CmpResult (CmpType a b))) + +instance (CmpRet a) => CmpOp (Value a) (Value a) where + type CmpType (Value a) (Value a) = a + cmpop op (Value a1) (Value a2) = buildBinOp op a1 a2 + +instance (IsConst a, CmpRet a) => CmpOp a (Value a) where + type CmpType a (Value a) = a + cmpop op a1 a2 = cmpop op (valueOf a1) a2 + +instance (IsConst a, CmpRet a) => CmpOp (Value a) a where + type CmpType (Value a) a = a + cmpop op a1 a2 = cmpop op a1 (valueOf a2) + +class CmpRet c where + type CmpResult c :: * + cmpBld :: c -> CmpPredicate -> FFIBinOp + +instance CmpRet Float where type CmpResult Float = Bool ; cmpBld _ = fcmpBld +instance CmpRet Double where type CmpResult Double = Bool ; cmpBld _ = fcmpBld +instance CmpRet FP128 where type CmpResult FP128 = Bool ; cmpBld _ = fcmpBld +instance CmpRet Bool where type CmpResult Bool = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word8 where type CmpResult Word8 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word16 where type CmpResult Word16 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word32 where type CmpResult Word32 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Word64 where type CmpResult Word64 = Bool ; cmpBld _ = ucmpBld +instance CmpRet Int8 where type CmpResult Int8 = Bool ; cmpBld _ = scmpBld +instance CmpRet Int16 where type CmpResult Int16 = Bool ; cmpBld _ = scmpBld +instance CmpRet Int32 where type CmpResult Int32 = Bool ; cmpBld _ = scmpBld +instance CmpRet Int64 where type CmpResult Int64 = Bool ; cmpBld _ = scmpBld +instance CmpRet (Ptr a) where type CmpResult (Ptr a) = Bool ; cmpBld _ = ucmpBld +instance (CmpRet a, IsPrimitive a, PositiveT n) => CmpRet (Vector n a) + where type CmpResult (Vector n a) = (Vector n (CmpResult a)) ; cmpBld _ = cmpBld (undefined :: a) + + +{- | +Compare values of ordered types +and choose predicates according to the compared types. +Floating point numbers are compared in \"ordered\" mode, +that is @NaN@ operands yields 'False' as result. +Pointers are compared unsigned. +These choices are consistent with comparison in plain Haskell. +-} +cmp :: forall a b c r. + (CmpOp a b, c ~ CmpType a b) => + CmpPredicate -> a -> b -> + CodeGenFunction r (Value (CmpResult c)) +cmp p = cmpop (cmpBld (undefined :: CmpType a b) p) + +ucmpBld :: CmpPredicate -> FFIBinOp +ucmpBld p = flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p)) + +scmpBld :: CmpPredicate -> FFIBinOp +scmpBld p = flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p)) + +fcmpBld :: CmpPredicate -> FFIBinOp +fcmpBld p = flip FFI.buildFCmp (fromFPPredicate (fpFromCmpPredicate p)) + + +_ucmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) => + CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +_ucmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (uintFromCmpPredicate p))) + +_scmp :: (IsInteger c, CmpOp a b, c ~ CmpType a b) => + CmpPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +_scmp p = cmpop (flip FFI.buildICmp (fromIntPredicate (sintFromCmpPredicate p))) + +pcmp :: (CmpOp a b, Ptr c ~ CmpType a b) => + IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult (Ptr c))) +pcmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) + + +{-# DEPRECATED icmp "use cmp or pcmp instead" #-} +-- | Compare integers. +icmp :: (IsIntegerOrPointer c, CmpOp a b, c ~ CmpType a b) => + IntPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +icmp p = cmpop (flip FFI.buildICmp (fromIntPredicate p)) + +-- | Compare floating point values. +fcmp :: (IsFloating c, CmpOp a b, c ~ CmpType a b) => + FPPredicate -> a -> b -> CodeGenFunction r (Value (CmpResult c)) +fcmp p = cmpop (flip FFI.buildFCmp (fromFPPredicate p)) + +-------------------------------------- + +-- XXX could do const song and dance +-- | Select between two values depending on a boolean. +select :: (IsFirstClass a, CmpRet a) => Value (CmpResult a) -> Value a -> Value a -> CodeGenFunction r (Value a) +select (Value cnd) (Value thn) (Value els) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildSelect bldPtr cnd thn els + +-------------------------------------- + +type Caller = FFI.BuilderRef -> [FFI.ValueRef] -> IO FFI.ValueRef + +-- |Acceptable arguments to 'call'. +class (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) => + CallArgs f g r where + type CalledFunction g :: * + type CallerResult g :: * + type CallerFunction f r :: * + doCall :: Caller -> [FFI.ValueRef] -> f -> g + +instance (CallArgs b b' r) => CallArgs (a -> b) (Value a -> b') r where + type CalledFunction (Value a -> b') = a -> CalledFunction b' + type CallerResult (Value a -> b') = CallerResult b' + type CallerFunction (a -> b) r = Value a -> CallerFunction b r + doCall mkCall args f (Value arg) = doCall mkCall (arg : args) (f (undefined :: a)) + +--instance (CallArgs b b') => CallArgs (a -> b) (ConstValue a -> b') where +-- doCall mkCall args f (ConstValue arg) = doCall mkCall (arg : args) (f (undefined :: a)) + +instance CallArgs (IO a) (CodeGenFunction r (Value a)) r where + type CalledFunction (CodeGenFunction r (Value a)) = IO a + type CallerResult (CodeGenFunction r (Value a)) = r + type CallerFunction (IO a) r = CodeGenFunction r (Value a) + doCall = doCallDef + +doCallDef :: Caller -> [FFI.ValueRef] -> b -> CodeGenFunction r (Value a) +doCallDef mkCall args _ = + withCurrentBuilder $ \ bld -> + liftM Value $ mkCall bld (reverse args) + +-- | Call a function with the given arguments. The 'call' instruction is variadic, i.e., the number of arguments +-- it takes depends on the type of /f/. +call :: (CallArgs f g r) => Function f -> g +call (Value f) = doCall (U.makeCall f) [] (undefined :: f) + +-- | Call a function with exception handling. +invoke :: (CallArgs f g r) + => BasicBlock -- ^Normal return point. + -> BasicBlock -- ^Exception return point. + -> Function f -- ^Function to call. + -> g +invoke (BasicBlock norm) (BasicBlock expt) (Value f) = + doCall (U.makeInvoke norm expt f) [] (undefined :: f) + +-- | Call a function with the given arguments. The 'call' instruction +-- is variadic, i.e., the number of arguments it takes depends on the +-- type of /f/. +-- This also sets the calling convention of the call to the function. +-- As LLVM itself defines, if the calling conventions of the calling +-- /instruction/ and the function being /called/ are different, undefined +-- behavior results. +callWithConv :: (CallArgs f g r) => FFI.CallingConvention -> Function f -> g +callWithConv cc (Value f) = doCall (U.makeCallWithCc cc f) [] (undefined :: f) + +-- | Call a function with exception handling. +-- This also sets the calling convention of the call to the function. +-- As LLVM itself defines, if the calling conventions of the calling +-- /instruction/ and the function being /called/ are different, undefined +-- behavior results. +invokeWithConv :: (CallArgs f g r) + => FFI.CallingConvention -- ^Calling convention + -> BasicBlock -- ^Normal return point. + -> BasicBlock -- ^Exception return point. + -> Function f -- ^Function to call. + -> g +invokeWithConv cc (BasicBlock norm) (BasicBlock expt) (Value f) = + doCall (U.makeInvokeWithCc cc norm expt f) [] (undefined :: f) + +-------------------------------------- + +-- XXX could do const song and dance +-- |Join several variables (virtual registers) from different basic blocks into one. +-- All of the variables in the list are joined. See also 'addPhiInputs'. +phi :: forall a r . (IsFirstClass a) => [(Value a, BasicBlock)] -> CodeGenFunction r (Value a) +phi incoming = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> do + inst <- U.buildEmptyPhi bldPtr (typeRef (undefined :: a)) + U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] + return inst + +-- |Add additional inputs to an existing phi node. +-- The reason for this instruction is that sometimes the structure of the code +-- makes it impossible to have all variables in scope at the point where you need the phi node. +addPhiInputs :: forall a r . (IsFirstClass a) + => Value a -- ^Must be a variable from a call to 'phi'. + -> [(Value a, BasicBlock)] -- ^Variables to add. + -> CodeGenFunction r () +addPhiInputs (Value inst) incoming = + liftIO $ U.addPhiIns inst [ (v, b) | (Value v, BasicBlock b) <- incoming ] + + +-------------------------------------- + +-- | Acceptable argument to array memory allocation. +class AllocArg a where + getAllocArg :: a -> Value Word32 +instance AllocArg (Value Word32) where + getAllocArg = id +instance AllocArg (ConstValue Word32) where + getAllocArg = value +instance AllocArg Word32 where + getAllocArg = valueOf + +-- could be moved to Util.Memory +-- FFI.buildMalloc deprecated since LLVM-2.7 +-- XXX What's the type returned by malloc +-- | Allocate heap memory. +malloc :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a)) +malloc = arrayMalloc (1::Word32) + +{- +I use a pointer type as size parameter of 'malloc'. +This way I hope that the parameter has always the correct size (32 or 64 bit). +A side effect is that we can convert the result of 'getelementptr' using 'bitcast', +that does not suffer from the slow assembly problem. (bug #8281) +-} +foreign import ccall "&aligned_malloc_sizeptr" + alignedMalloc :: FunPtr (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8)) + +foreign import ccall "&aligned_free" + alignedFree :: FunPtr (Ptr Word8 -> IO ()) + + +{- +There is a bug in LLVM-2.7 and LLVM-2.8 +(http://llvm.org/bugs/show_bug.cgi?id=8281) +that causes huge assembly times for expressions like +ptrtoint(getelementptr(zero,..)). +If you break those expressions into two statements +at separate lines, everything is fine. +But the C interface is too clever, +and rewrites two separate statements into a functional expression on a single line. +Such code is generated whenever you call +buildMalloc, buildArrayMalloc, sizeOf (called by buildMalloc), or alignOf. +One possible way is to write a getelementptr expression +containing a nullptr in a way +that hides the constant nature of nullptr. + + ptr <- alloca + store (value zero) ptr + z <- load ptr + size <- bitcast =<< + getElementPtr (z :: Value (Ptr a)) (getAllocArg s, ()) + +However, I found that bitcast on pointers causes no problems. +Thus I switched to using pointers for size quantities. +This still allows for optimizations involving pointers. +-} + +-- XXX What's the type returned by arrayMalloc? +-- | Allocate heap (array) memory. +arrayMalloc :: forall a r s . (IsSized a, AllocArg s) => + s -> CodeGenFunction r (Value (Ptr a)) -- XXX +arrayMalloc s = do + func <- staticFunction alignedMalloc +-- func <- externFunction "malloc" + + size <- sizeOfArray (undefined :: a) (getAllocArg s) + alignment <- alignOf (undefined :: a) + bitcast =<< + call + (func :: Function (Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8))) + size + alignment + +-- XXX What's the type returned by malloc +-- | Allocate stack memory. +alloca :: forall a r . (IsSized a) => CodeGenFunction r (Value (Ptr a)) +alloca = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildAlloca bldPtr (typeRef (undefined :: a)) + +-- XXX What's the type returned by arrayAlloca? +-- | Allocate stack (array) memory. +arrayAlloca :: forall a r s . (IsSized a, AllocArg s) => + s -> CodeGenFunction r (Value (Ptr a)) +arrayAlloca s = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ + FFI.buildArrayAlloca bldPtr (typeRef (undefined :: a)) (case getAllocArg s of Value v -> v) + +-- FFI.buildFree deprecated since LLVM-2.7 +-- XXX What's the type of free? +-- | Free heap memory. +free :: (IsType a) => Value (Ptr a) -> CodeGenFunction r () +free ptr = do + func <- staticFunction alignedFree +-- func <- externFunction "free" + _ <- call (func :: Function (Ptr Word8 -> IO ())) =<< bitcast ptr + return () + + +-- | If we want to export that, then we should have a Size type +-- This is the official implementation, +-- but it suffers from the ptrtoint(gep) bug. +_sizeOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64) +_sizeOf a = + liftIO $ liftM Value $ + FFI.sizeOf (typeRef a) + +_alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value Word64) +_alignOf a = + liftIO $ liftM Value $ + FFI.alignOf (typeRef a) + + +-- Here are reimplementation from Constants.cpp that avoid the ptrtoint(gep) bug #8281. +-- see ConstantExpr::getSizeOf +sizeOfArray :: forall a r . (IsSized a) => a -> Value Word32 -> CodeGenFunction r (Value (Ptr Word8)) +sizeOfArray _ len = + bitcast =<< + getElementPtr (value zero :: Value (Ptr a)) (len, ()) + +-- see ConstantExpr::getAlignOf +alignOf :: forall a r . (IsSized a) => a -> CodeGenFunction r (Value (Ptr Word8)) +alignOf _ = + bitcast =<< + getElementPtr0 (value zero :: Value (Ptr (Struct (Bool, (a, ()))))) (d1, ()) + + +-- | Load a value from memory. +load :: Value (Ptr a) -- ^ Address to load from. + -> CodeGenFunction r (Value a) +load (Value p) = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withEmptyCString $ FFI.buildLoad bldPtr p + +-- | Store a value in memory +store :: Value a -- ^ Value to store. + -> Value (Ptr a) -- ^ Address to store to. + -> CodeGenFunction r () +store (Value v) (Value p) = do + withCurrentBuilder_ $ \ bldPtr -> + FFI.buildStore bldPtr v p + return () + +{- +-- XXX type is wrong +-- | Address arithmetic. See LLVM description. +-- (The type isn't as accurate as it should be.) +getElementPtr :: (IsInteger i) => + Value (Ptr a) -> [Value i] -> CodeGenFunction r (Value (Ptr b)) +getElementPtr (Value ptr) ixs = + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withArrayLen [ v | Value v <- ixs ] $ \ idxLen idxPtr -> + U.withEmptyCString $ + FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) +-} + +-- |Acceptable arguments to 'getElementPointer'. +class GetElementPtr optr ixs where + type ElementPtrType optr ixs :: * + getIxList :: optr -> ixs -> [FFI.ValueRef] + +-- |Acceptable single index to 'getElementPointer'. +class IsIndexArg a where + getArg :: a -> FFI.ValueRef + +instance IsIndexArg (Value Word32) where + getArg (Value v) = v + +instance IsIndexArg (Value Word64) where + getArg (Value v) = v + +instance IsIndexArg (Value Int32) where + getArg (Value v) = v + +instance IsIndexArg (Value Int64) where + getArg (Value v) = v + +instance IsIndexArg (ConstValue Word32) where + getArg = unConst + +instance IsIndexArg (ConstValue Word64) where + getArg = unConst + +instance IsIndexArg (ConstValue Int32) where + getArg = unConst + +instance IsIndexArg (ConstValue Int64) where + getArg = unConst + +instance IsIndexArg Word32 where + getArg = unConst . constOf + +instance IsIndexArg Word64 where + getArg = unConst . constOf + +instance IsIndexArg Int32 where + getArg = unConst . constOf + +instance IsIndexArg Int64 where + getArg = unConst . constOf + +unConst :: ConstValue a -> FFI.ValueRef +unConst (ConstValue v) = v + +-- End of indexing +instance GetElementPtr a () where + type ElementPtrType a () = a + getIxList _ () = [] + +-- Index in Array +instance (GetElementPtr o i, IsIndexArg a, NaturalT k) => GetElementPtr (Array k o) (a, i) where + type ElementPtrType (Array k o) (a, i) = ElementPtrType o i + getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i + +-- Index in Vector +instance (GetElementPtr o i, IsIndexArg a, PositiveT k) => GetElementPtr (Vector k o) (a, i) where + type ElementPtrType (Vector k o) (a, i) = ElementPtrType o i + getIxList _ (v, i) = getArg v : getIxList (undefined :: o) i + +-- Index in Struct and PackedStruct. +-- The index has to be a type level integer to statically determine the record field type +instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (Struct fs) (a, i) where + type ElementPtrType (Struct fs) (a, i) = ElementPtrType (FieldType fs a) i + getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i +instance (GetElementPtr (FieldType fs a) i, NaturalT a) => GetElementPtr (PackedStruct fs) (a, i) where + type ElementPtrType (PackedStruct fs) (a, i) = ElementPtrType (FieldType fs a) i + getIxList _ (v, i) = unConst (constOf (fromIntegerT v :: Word32)) : getIxList (undefined :: FieldType fs a) i + +class GetField as i where type FieldType as i :: * +instance GetField (a, as) (Dec DecN) where type FieldType (a, as) (Dec DecN) = a +instance (GetField as (Pred (Dec (i1:.i0)))) => GetField (a, as) (Dec (i1:.i0)) where type FieldType (a,as) (Dec (i1:.i0)) = FieldType as (Pred (Dec (i1:.i0))) + +-- | Address arithmetic. See LLVM description. +-- The index is a nested tuple of the form @(i1,(i2,( ... ())))@. +-- (This is without a doubt the most confusing LLVM instruction, but the types help.) +getElementPtr :: forall a o i r . (GetElementPtr o i, IsIndexArg a) => + Value (Ptr o) -> (a, i) -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) +getElementPtr (Value ptr) (a, ixs) = + let ixl = getArg a : getIxList (undefined :: o) ixs in + liftM Value $ + withCurrentBuilder $ \ bldPtr -> + U.withArrayLen ixl $ \ idxLen idxPtr -> + U.withEmptyCString $ + FFI.buildGEP bldPtr ptr idxPtr (fromIntegral idxLen) + +-- | Like getElementPtr, but with an initial index that is 0. +-- This is useful since any pointer first need to be indexed off the pointer, and then into +-- its actual value. This first indexing is often with 0. +getElementPtr0 :: (GetElementPtr o i) => + Value (Ptr o) -> i -> CodeGenFunction r (Value (Ptr (ElementPtrType o i))) +getElementPtr0 p i = getElementPtr p (0::Word32, i) + +-------------------------------------- +{- +instance (IsConst a) => Show (ConstValue a) -- XXX +instance (IsConst a) => Eq (ConstValue a) + +{- +instance (IsConst a) => Eq (ConstValue a) where + ConstValue x == ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOEQ) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntEQ) x y) + ConstValue x /= ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPONE) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntNE) x y) + +instance (IsConst a) => Ord (ConstValue a) where + ConstValue x < ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLT) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntLT) x y) + ConstValue x <= ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOLE) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntLE) x y) + ConstValue x > ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGT) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntGT) x y) + ConstValue x >= ConstValue y = + if isFloating x then ConstValue (FFI.constFCmp (fromFPPredicate FPOGE) x y) + else ConstValue (FFI.constICmp (fromIntPredicate IntGE) x y) +-} + +instance (Num a, IsConst a) => Num (ConstValue a) where + ConstValue x + ConstValue y = ConstValue (FFI.constAdd x y) + ConstValue x - ConstValue y = ConstValue (FFI.constSub x y) + ConstValue x * ConstValue y = ConstValue (FFI.constMul x y) + negate (ConstValue x) = ConstValue (FFI.constNeg x) + fromInteger x = constOf (fromInteger x :: a) +-} diff --git a/LLVM/Core/Type.hs b/LLVM/Core/Type.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Type.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +-- |The LLVM type system is captured with a number of Haskell type classes. +-- In general, an LLVM type @T@ is represented as @Value T@, where @T@ is some Haskell type. +-- The various types @T@ are classified by various type classes, e.g., 'IsFirstClass' for +-- those types that are LLVM first class types (passable as arguments etc). +-- All valid LLVM types belong to the 'IsType' class. +module LLVM.Core.Type( + -- * Type classifier + IsType(..), + -- ** Special type classifiers + NaturalT, + PositiveT, + IsArithmetic(arithmeticType), + ArithmeticType(IntegerType,FloatingType), + IsInteger, Signed, + IsIntegerOrPointer, + IsFloating, + IsPrimitive, + IsFirstClass, + IsSized, SizeOf, sizeOf, + IsFunction, + -- ** Others + IsScalarOrVector, NumberOfElements, + UnknownSize, -- needed for arrays of structs + -- ** Structs + (:&), (&), + -- ** Type tests + TypeDesc(..), + isFloating, + isSigned, + typeRef, + typeName, + intrinsicTypeName, + typeDesc2, + VarArgs, CastVarArgs, + ) where +import Data.Typeable +import Data.List(intercalate) +import Data.Int +import Data.Word +import Types.Data.Num +import Types.Data.Bool (True, False) +import Foreign.StablePtr (StablePtr, ) +import LLVM.Core.Util(functionType, structType) +import LLVM.Core.Data +import qualified LLVM.FFI.Core as FFI + +#include "MachDeps.h" + +-- TODO: +-- Move IntN, WordN to a special module that implements those types +-- properly in Haskell. +-- Also more Array and Vector to a Haskell module to implement them. +-- Add Label? +-- Add structures (using tuples, maybe nested). + +-- |The 'IsType' class classifies all types that have an LLVM representation. +class IsType a where + typeDesc :: a -> TypeDesc + +typeRef :: (IsType a) => a -> FFI.TypeRef -- ^The argument is never evaluated +typeRef = code . typeDesc + where code TDFloat = FFI.floatType + code TDDouble = FFI.doubleType + code TDFP128 = FFI.fP128Type + code TDVoid = FFI.voidType + code (TDInt _ n) = FFI.integerType (fromInteger n) + code (TDArray n a) = FFI.arrayType (code a) (fromInteger n) + code (TDVector n a) = FFI.vectorType (code a) (fromInteger n) + code (TDPtr a) = FFI.pointerType (code a) 0 + code (TDFunction va as b) = functionType va (code b) (map code as) + code TDLabel = FFI.labelType + code (TDStruct ts packed) = structType (map code ts) packed + code TDInvalidType = error "typeRef TDInvalidType" + +typeName :: (IsType a) => a -> String +typeName = code . typeDesc + where code TDFloat = "f32" + code TDDouble = "f64" + code TDFP128 = "f128" + code TDVoid = "void" + code (TDInt _ n) = "i" ++ show n + code (TDArray n a) = "[" ++ show n ++ " x " ++ code a ++ "]" + code (TDVector n a) = "<" ++ show n ++ " x " ++ code a ++ ">" + code (TDPtr a) = code a ++ "*" + code (TDFunction _ as b) = code b ++ "(" ++ intercalate "," (map code as) ++ ")" + code TDLabel = "label" + code (TDStruct as packed) = (if packed then "<{" else "{") ++ + intercalate "," (map code as) ++ + (if packed then "}>" else "}") + code TDInvalidType = error "typeName TDInvalidType" + +intrinsicTypeName :: (IsType a) => a -> String +intrinsicTypeName = code . typeDesc + where code TDFloat = "f32" + code TDDouble = "f64" + code TDFP128 = "f128" + code (TDInt _ n) = "i" ++ show n + code (TDVector n a) = "v" ++ show n ++ code a + code _ = error "intrinsicTypeName: type not supported in intrinsics" + +typeDesc2 :: FFI.TypeRef -> IO TypeDesc +typeDesc2 t = do + tk <- FFI.getTypeKind t + case tk of + FFI.VoidTypeKind -> return TDVoid + FFI.FloatTypeKind -> return TDFloat + FFI.DoubleTypeKind -> return TDDouble + -- FIXME: FFI.X86_FP80TypeKind -> return "X86_FP80" + FFI.FP128TypeKind -> return TDFP128 + -- FIXME: FFI.PPC_FP128TypeKind -> return "PPC_FP128" + FFI.LabelTypeKind -> return TDLabel + FFI.IntegerTypeKind -> do + n <- FFI.getIntTypeWidth t + return $ TDInt False (fromIntegral n) + -- FIXME: FFI.FunctionTypeKind + -- FIXME: FFI.StructTypeKind -> return "(Struct ...)" + FFI.ArrayTypeKind -> do + n <- FFI.getArrayLength t + et <- FFI.getElementType t + etd <- typeDesc2 et + return $ TDArray (fromIntegral n) etd + FFI.PointerTypeKind -> do + et <- FFI.getElementType t + etd <- typeDesc2 et + return $ TDPtr etd + -- FIXME: FFI.OpaqueTypeKind -> return "Opaque" + FFI.VectorTypeKind -> do + n <- FFI.getVectorSize t + et <- FFI.getElementType t + etd <- typeDesc2 et + return $ TDVector (fromIntegral n) etd + -- FIXME: LLVMMetadataTypeKind, /**< Metadata */ + -- FIXME: LLVMX86_MMXTypeKind /**< X86 MMX */ + _ -> return TDInvalidType + +-- |Type descriptor, used to convey type information through the LLVM API. +data TypeDesc = TDFloat | TDDouble | TDFP128 | TDVoid | TDInt Bool Integer + | TDArray Integer TypeDesc | TDVector Integer TypeDesc + | TDPtr TypeDesc | TDFunction Bool [TypeDesc] TypeDesc | TDLabel + | TDStruct [TypeDesc] Bool | TDInvalidType + deriving (Eq, Ord, Show, Typeable) + +-- XXX isFloating and typeName could be extracted from typeRef +-- Usage: +-- superclass of IsConst +-- add, sub, mul, neg context +-- used to get type name to call intrinsic +-- |Arithmetic types, i.e., integral and floating types. +class IsFirstClass a => IsArithmetic a where + arithmeticType :: ArithmeticType a + +data ArithmeticType a = IntegerType | FloatingType + +instance Functor ArithmeticType where + fmap _ IntegerType = IntegerType + fmap _ FloatingType = FloatingType + +-- Usage: +-- constI, allOnes +-- many instructions. XXX some need vector +-- used to find signedness in Arithmetic +-- |Integral types. +class (IsArithmetic a, IsIntegerOrPointer a) => IsInteger a where + type Signed a :: * + +-- Usage: +-- icmp +-- |Integral or pointer type. +class IsIntegerOrPointer a + +isSigned :: (IsInteger a) => a -> Bool +isSigned = is . typeDesc + where is (TDInt s _) = s + is (TDVector _ a) = is a + is _ = error "isSigned got impossible input" + +-- Usage: +-- constF +-- many instructions +-- |Floating types. +class IsArithmetic a => IsFloating a + +isFloating :: (IsArithmetic a) => a -> Bool +isFloating = is . typeDesc + where is TDFloat = True + is TDDouble = True + is TDFP128 = True + is (TDVector _ a) = is a + is _ = False + +-- Usage: +-- Precondition for Vector +-- |Primitive types. +-- class (IsType a) => IsPrimitive a +class (IsType a, NumberOfElements a ~ D1) => IsPrimitive a + +-- do we really need IsScalarOrVector? +-- proposal: either associate NumberOfElements with IsType or make it a non-associated type family +-- |Number of elements for instructions that handle both primitive and vector types +class (IsType a) => IsScalarOrVector a where + type NumberOfElements a :: * + + +-- Usage: +-- Precondition for function args and result. +-- Used by some instructions, like ret and phi. +-- XXX IsSized as precondition? +-- |First class types, i.e., the types that can be passed as arguments, etc. +class IsType a => IsFirstClass a + +-- Usage: +-- Context for Array being a type +-- thus, allocation instructions +-- |Types with a fixed size. +class (IsType a, PositiveT (SizeOf a)) => IsSized a where + type SizeOf a :: * + +sizeOf :: TypeDesc -> Integer +sizeOf TDFloat = 32 +sizeOf TDDouble = 64 +sizeOf TDFP128 = 128 +sizeOf (TDInt _ bits) = bits +sizeOf (TDArray n typ) = n * sizeOf typ +sizeOf (TDVector n typ) = n * sizeOf typ +sizeOf (TDStruct ts _packed) = sum (map sizeOf ts) +sizeOf _ = error "type has no size" + +-- |Function type. +class (IsType a) => IsFunction a where + funcType :: [TypeDesc] -> a -> TypeDesc + +-- Only make instances for types that make sense in Haskell +-- (i.e., some floating types are excluded). + +-- Floating point types. +instance IsType Float where typeDesc _ = TDFloat +instance IsType Double where typeDesc _ = TDDouble +instance IsType FP128 where typeDesc _ = TDFP128 + +-- Void type +instance IsType () where typeDesc _ = TDVoid + +-- Label type +instance IsType Label where typeDesc _ = TDLabel + +-- Variable size integer types +instance (PositiveT n) => IsType (IntN n) + where typeDesc _ = TDInt True (fromIntegerT (undefined :: n)) + +instance (PositiveT n) => IsType (WordN n) + where typeDesc _ = TDInt False (fromIntegerT (undefined :: n)) + +-- Fixed size integer types. +instance IsType Bool where typeDesc _ = TDInt False 1 +instance IsType Word8 where typeDesc _ = TDInt False 8 +instance IsType Word16 where typeDesc _ = TDInt False 16 +instance IsType Word32 where typeDesc _ = TDInt False 32 +instance IsType Word64 where typeDesc _ = TDInt False 64 +instance IsType Int8 where typeDesc _ = TDInt True 8 +instance IsType Int16 where typeDesc _ = TDInt True 16 +instance IsType Int32 where typeDesc _ = TDInt True 32 +instance IsType Int64 where typeDesc _ = TDInt True 64 + +-- Sequence types +instance (NaturalT n, IsSized a) => IsType (Array n a) + where typeDesc _ = TDArray (fromIntegerT (undefined :: n)) + (typeDesc (undefined :: a)) +instance (PositiveT n, IsPrimitive a) => IsType (Vector n a) + where typeDesc _ = TDVector (fromIntegerT (undefined :: n)) + (typeDesc (undefined :: a)) + +-- Pointer type. +instance (IsType a) => IsType (Ptr a) where + typeDesc _ = TDPtr (typeDesc (undefined :: a)) + +instance IsType (StablePtr a) where + typeDesc _ = TDPtr (typeDesc (undefined :: Int8)) +{- + typeDesc _ = TDPtr TDVoid + +List: Type.cpp:1311: static llvm::PointerType* llvm::PointerType::get(const llvm::Type*, unsigned int): Assertion `ValueType != Type::VoidTy && "Pointer to void is not valid, use sbyte* instead!"' failed. +-} + + +-- Functions. +instance (IsFirstClass a, IsFunction b) => IsType (a->b) where + typeDesc = funcType [] + +-- Function base type, always IO. +instance (IsFirstClass a) => IsType (IO a) where + typeDesc = funcType [] + +-- Struct types, basically a list of component types. +instance (StructFields a) => IsType (Struct a) where + typeDesc ~(Struct a) = TDStruct (fieldTypes a) False + +instance (StructFields a) => IsType (PackedStruct a) where + typeDesc ~(PackedStruct a) = TDStruct (fieldTypes a) True + +-- Use a nested tuples for struct fields. +class StructFields as where + fieldTypes :: as -> [TypeDesc] + +instance (IsSized a, StructFields as) => StructFields (a :& as) where + fieldTypes ~(a, as) = typeDesc a : fieldTypes as +instance StructFields () where + fieldTypes _ = [] + +-- An alias for pairs to make structs look nicer +infixr :& +type (:&) a as = (a, as) +infixr & +(&) :: a -> as -> a :& as +a & as = (a, as) + +--- Instances to classify types +instance IsArithmetic Float where arithmeticType = FloatingType +instance IsArithmetic Double where arithmeticType = FloatingType +instance IsArithmetic FP128 where arithmeticType = FloatingType +instance (PositiveT n) => IsArithmetic (IntN n) where arithmeticType = IntegerType +instance (PositiveT n) => IsArithmetic (WordN n) where arithmeticType = IntegerType +instance IsArithmetic Bool where arithmeticType = IntegerType +instance IsArithmetic Int8 where arithmeticType = IntegerType +instance IsArithmetic Int16 where arithmeticType = IntegerType +instance IsArithmetic Int32 where arithmeticType = IntegerType +instance IsArithmetic Int64 where arithmeticType = IntegerType +instance IsArithmetic Word8 where arithmeticType = IntegerType +instance IsArithmetic Word16 where arithmeticType = IntegerType +instance IsArithmetic Word32 where arithmeticType = IntegerType +instance IsArithmetic Word64 where arithmeticType = IntegerType +instance (PositiveT n, IsPrimitive a, IsArithmetic a) => + IsArithmetic (Vector n a) where + arithmeticType = fmap (undefined :: a -> Vector n a) arithmeticType + +instance IsFloating Float +instance IsFloating Double +instance IsFloating FP128 +instance (PositiveT n, IsPrimitive a, IsFloating a) => IsFloating (Vector n a) + +data NotANumber + +instance (PositiveT n) => IsInteger (IntN n) where type Signed (IntN n) = True +instance (PositiveT n) => IsInteger (WordN n) where type Signed (WordN n) = False +instance IsInteger Bool where type Signed Bool = NotANumber +instance IsInteger Int8 where type Signed Int8 = True +instance IsInteger Int16 where type Signed Int16 = True +instance IsInteger Int32 where type Signed Int32 = True +instance IsInteger Int64 where type Signed Int64 = True +instance IsInteger Word8 where type Signed Word8 = False +instance IsInteger Word16 where type Signed Word16 = False +instance IsInteger Word32 where type Signed Word32 = False +instance IsInteger Word64 where type Signed Word64 = False +instance (PositiveT n, IsPrimitive a, IsInteger a) => IsInteger (Vector n a) + where type Signed (Vector n a) = Signed a + +instance (PositiveT n) => IsIntegerOrPointer (IntN n) +instance (PositiveT n) => IsIntegerOrPointer (WordN n) +instance IsIntegerOrPointer Bool +instance IsIntegerOrPointer Int8 +instance IsIntegerOrPointer Int16 +instance IsIntegerOrPointer Int32 +instance IsIntegerOrPointer Int64 +instance IsIntegerOrPointer Word8 +instance IsIntegerOrPointer Word16 +instance IsIntegerOrPointer Word32 +instance IsIntegerOrPointer Word64 +instance (PositiveT n, IsPrimitive a, IsInteger a) => IsIntegerOrPointer (Vector n a) +instance (IsType a) => IsIntegerOrPointer (Ptr a) + +instance IsFirstClass Float +instance IsFirstClass Double +instance IsFirstClass FP128 +instance (PositiveT n) => IsFirstClass (IntN n) +instance (PositiveT n) => IsFirstClass (WordN n) +instance IsFirstClass Bool +instance IsFirstClass Int8 +instance IsFirstClass Int16 +instance IsFirstClass Int32 +instance IsFirstClass Int64 +instance IsFirstClass Word8 +instance IsFirstClass Word16 +instance IsFirstClass Word32 +instance IsFirstClass Word64 +instance (PositiveT n, IsPrimitive a) => IsFirstClass (Vector n a) +instance (NaturalT n, IsSized a) => IsFirstClass (Array n a) +instance (IsType a) => IsFirstClass (Ptr a) +instance IsFirstClass (StablePtr a) +instance IsFirstClass Label +instance IsFirstClass () -- XXX This isn't right, but () can be returned +instance (StructFields as) => IsFirstClass (Struct as) + +instance (PositiveT n) => IsSized (IntN n) where type SizeOf (IntN n) = n +instance (PositiveT n) => IsSized (WordN n) where type SizeOf (WordN n) = n +instance IsSized Float where type SizeOf Float = D32 +instance IsSized Double where type SizeOf Double = D64 +instance IsSized FP128 where type SizeOf FP128 = D128 +instance IsSized Bool where type SizeOf Bool = D1 +instance IsSized Int8 where type SizeOf Int8 = D8 +instance IsSized Int16 where type SizeOf Int16 = D16 +instance IsSized Int32 where type SizeOf Int32 = D32 +instance IsSized Int64 where type SizeOf Int64 = D64 +instance IsSized Word8 where type SizeOf Word8 = D8 +instance IsSized Word16 where type SizeOf Word16 = D16 +instance IsSized Word32 where type SizeOf Word32 = D32 +instance IsSized Word64 where type SizeOf Word64 = D64 +instance (NaturalT n, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Array n a) where + type SizeOf (Array n a) = n :*: SizeOf a +instance (PositiveT n, IsPrimitive a, IsSized a, PositiveT (n :*: SizeOf a)) => IsSized (Vector n a) where + type SizeOf (Vector n a) = n :*: SizeOf a +instance (IsType a) => IsSized (Ptr a) where type SizeOf (Ptr a) = PtrSize +instance IsSized (StablePtr a) where type SizeOf (StablePtr a) = PtrSize +-- instance IsSized Label PtrSize -- labels are not quite first classed +-- We cannot compute the sizes statically :( +instance (StructFields as) => IsSized (Struct as) where + type SizeOf (Struct as) = UnknownSize +instance (StructFields as) => IsSized (PackedStruct as) where + type SizeOf (PackedStruct as) = UnknownSize + +type UnknownSize = D99 -- XXX this is wrong! + +#if WORD_SIZE_IN_BITS == 32 +type PtrSize = D32 +#elif WORD_SIZE_IN_BITS == 64 +type PtrSize = D64 +#else +#error cannot determine type of PtrSize +#endif + +instance IsPrimitive Float +instance IsPrimitive Double +instance IsPrimitive FP128 +instance (PositiveT n) => IsPrimitive (IntN n) +instance (PositiveT n) => IsPrimitive (WordN n) +instance IsPrimitive Bool +instance IsPrimitive Int8 +instance IsPrimitive Int16 +instance IsPrimitive Int32 +instance IsPrimitive Int64 +instance IsPrimitive Word8 +instance IsPrimitive Word16 +instance IsPrimitive Word32 +instance IsPrimitive Word64 +instance IsPrimitive Label +instance IsPrimitive () + + +instance (PositiveT n) => + IsScalarOrVector (IntN n) where type NumberOfElements (IntN n) = D1 +instance (PositiveT n) => + IsScalarOrVector (WordN n) where type NumberOfElements (WordN n) = D1 +instance IsScalarOrVector Float where type NumberOfElements Float = D1 +instance IsScalarOrVector Double where type NumberOfElements Double = D1 +instance IsScalarOrVector FP128 where type NumberOfElements FP128 = D1 +instance IsScalarOrVector Bool where type NumberOfElements Bool = D1 +instance IsScalarOrVector Int8 where type NumberOfElements Int8 = D1 +instance IsScalarOrVector Int16 where type NumberOfElements Int16 = D1 +instance IsScalarOrVector Int32 where type NumberOfElements Int32 = D1 +instance IsScalarOrVector Int64 where type NumberOfElements Int64 = D1 +instance IsScalarOrVector Word8 where type NumberOfElements Word8 = D1 +instance IsScalarOrVector Word16 where type NumberOfElements Word16 = D1 +instance IsScalarOrVector Word32 where type NumberOfElements Word32 = D1 +instance IsScalarOrVector Word64 where type NumberOfElements Word64 = D1 +instance IsScalarOrVector Label where type NumberOfElements Label = D1 +instance IsScalarOrVector () where type NumberOfElements () = D1 + +instance (PositiveT n, IsPrimitive a) => + IsScalarOrVector (Vector n a) where + type NumberOfElements (Vector n a) = n + + +-- Functions. +instance (IsFirstClass a, IsFunction b) => IsFunction (a->b) where + funcType ts _ = funcType (typeDesc (undefined :: a) : ts) (undefined :: b) +instance (IsFirstClass a) => IsFunction (IO a) where + funcType ts _ = TDFunction False (reverse ts) (typeDesc (undefined :: a)) +instance (IsFirstClass a) => IsFunction (VarArgs a) where + funcType ts _ = TDFunction True (reverse ts) (typeDesc (undefined :: a)) + +-- |The 'VarArgs' type is a placeholder for the real 'IO' type that +-- can be obtained with 'castVarArgs'. +data VarArgs a + deriving (Typeable) +instance IsType (VarArgs a) where + typeDesc _ = error "typeDesc: Dummy type VarArgs used incorrectly" + +-- |Define what vararg types are permissible. +class CastVarArgs a b +instance (CastVarArgs b c) => CastVarArgs (a -> b) (a -> c) +instance CastVarArgs (VarArgs a) (IO a) +instance (IsFirstClass a, CastVarArgs (VarArgs b) c) => CastVarArgs (VarArgs b) (a -> c) + + + + +-- XXX Structures not implemented. Tuples is probably an easy way. + diff --git a/LLVM/Core/Util.hs b/LLVM/Core/Util.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Util.hs @@ -0,0 +1,498 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.Core.Util( + -- * Module handling + Module(..), withModule, createModule, destroyModule, writeBitcodeToFile, readBitcodeFromFile, + getModuleValues, getFunctions, getGlobalVariables, valueHasType, + -- * Module provider handling + ModuleProvider(..), withModuleProvider, createModuleProviderForExistingModule, + -- * Pass manager handling + PassManager(..), withPassManager, createPassManager, createFunctionPassManager, + runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager, + -- * Instruction builder + Builder(..), withBuilder, createBuilder, positionAtEnd, getInsertBlock, + -- * Basic blocks + BasicBlock, + appendBasicBlock, getBasicBlocks, + -- * Functions + Function, + addFunction, getParam, getParams, + -- * Structs + structType, + -- * Globals + addGlobal, + constString, constStringNul, constVector, constArray, constStruct, + -- * Instructions + makeCall, makeInvoke, + makeCallWithCc, makeInvokeWithCc, + withValue, getInstructions, getOperands, + -- * Uses and Users + hasUsers, getUsers, getUses, getUser, isChildOf, getDep, + -- * Misc + CString, withArrayLen, + withEmptyCString, + functionType, buildEmptyPhi, addPhiIns, + showTypeOf, getValueNameU, getObjList, annotateValueList, isConstant, + -- * Transformation passes + addCFGSimplificationPass, addConstantPropagationPass, addDemoteMemoryToRegisterPass, + addGVNPass, addInstructionCombiningPass, addPromoteMemoryToRegisterPass, addReassociatePass, + addTargetData + ) where +import Data.Typeable +import Data.List(intercalate) +import Control.Monad(liftM, filterM, when) +import Foreign.C.String (withCString, withCStringLen, CString, peekCString) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_, withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Marshal.Array (withArrayLen, withArray, allocaArray, peekArray) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Storable (Storable(..)) +import Foreign.Marshal.Utils (fromBool) +import System.IO.Unsafe (unsafePerformIO) + +import qualified LLVM.FFI.Core as FFI +import qualified LLVM.FFI.Target as FFI +import qualified LLVM.FFI.BitWriter as FFI +import qualified LLVM.FFI.BitReader as FFI +import qualified LLVM.FFI.Transforms.Scalar as FFI + +type Type = FFI.TypeRef + +-- unsafePerformIO just to wrap the non-effecting withArrayLen call +functionType :: Bool -> Type -> [Type] -> Type +functionType varargs retType paramTypes = unsafePerformIO $ + withArrayLen paramTypes $ \ len ptr -> + return $ FFI.functionType retType ptr (fromIntegral len) + (fromBool varargs) + +-- unsafePerformIO just to wrap the non-effecting withArrayLen call +structType :: [Type] -> Bool -> Type +structType types packed = unsafePerformIO $ + withArrayLen types $ \ len ptr -> + return $ FFI.structType ptr (fromIntegral len) (if packed then 1 else 0) + +-------------------------------------- +-- Handle modules + +-- Don't use a finalizer for the module, but instead provide an +-- explicit destructor. This is because handing a module to +-- a module provider changes ownership of the module to the provider, +-- and we don't want to free it by mistake. + +-- | Type of top level modules. +newtype Module = Module { + fromModule :: FFI.ModuleRef + } + deriving (Show, Typeable) + +withModule :: Module -> (FFI.ModuleRef -> IO a) -> IO a +withModule modul f = f (fromModule modul) + +createModule :: String -> IO Module +createModule name = + withCString name $ \ namePtr -> do + liftM Module $ FFI.moduleCreateWithName namePtr + +-- | Free all storage related to a module. *Note*, this is a dangerous call, since referring +-- to the module after this call is an error. The reason for the explicit call to free +-- the module instead of an automatic lifetime management is that modules have a +-- somewhat complicated ownership. Handing a module to a module provider changes +-- the ownership of the module, and the module provider will free the module when necessary. +destroyModule :: Module -> IO () +destroyModule = FFI.disposeModule . fromModule + +-- |Write a module to a file. +writeBitcodeToFile :: String -> Module -> IO () +writeBitcodeToFile name mdl = + withCString name $ \ namePtr -> + withModule mdl $ \ mdlPtr -> do + rc <- FFI.writeBitcodeToFile mdlPtr namePtr + when (rc /= 0) $ + ioError $ userError $ "writeBitcodeToFile: return code " ++ show rc + return () + +-- |Read a module from a file. +readBitcodeFromFile :: String -> IO Module +readBitcodeFromFile name = + withCString name $ \ namePtr -> + alloca $ \ bufPtr -> + alloca $ \ modPtr -> + alloca $ \ errStr -> do + rrc <- FFI.createMemoryBufferWithContentsOfFile namePtr bufPtr errStr + if rrc /= 0 then do + msg <- peek errStr >>= peekCString + ioError $ userError $ "readBitcodeFromFile: read return code " ++ show rrc ++ ", " ++ msg + else do + buf <- peek bufPtr + prc <- FFI.parseBitcode buf modPtr errStr + if prc /= 0 then do + msg <- peek errStr >>= peekCString + ioError $ userError $ "readBitcodeFromFile: parse return code " ++ show prc ++ ", " ++ msg + else do + ptr <- peek modPtr + return $ Module ptr +{- + liftM Module $ newForeignPtr FFI.ptrDisposeModule ptr +-} + +getModuleValues :: Module -> IO [(String, Value)] +getModuleValues mdl = do + fs <- getFunctions mdl + gs <- getGlobalVariables mdl + return (fs ++ gs) + +getFunctions :: Module -> IO [(String, Value)] +getFunctions mdl = getObjList withModule FFI.getFirstFunction FFI.getNextFunction mdl >>= filterM isIntrinsic >>= annotateValueList + +getGlobalVariables :: Module -> IO [(String, Value)] +getGlobalVariables mdl = getObjList withModule FFI.getFirstGlobal FFI.getNextGlobal mdl >>= annotateValueList + +-- This is safe because we just ask for the type of a value. +valueHasType :: Value -> Type -> Bool +valueHasType v t = unsafePerformIO $ do + vt <- FFI.typeOf v + return $ vt == t -- LLVM uses hash consing for types, so pointer equality works. + +showTypeOf :: Value -> IO String +showTypeOf v = FFI.typeOf v >>= showType' + +showType' :: Type -> IO String +showType' p = do + pk <- FFI.getTypeKind p + case pk of + FFI.VoidTypeKind -> return "()" + FFI.FloatTypeKind -> return "Float" + FFI.DoubleTypeKind -> return "Double" + FFI.X86_FP80TypeKind -> return "X86_FP80" + FFI.FP128TypeKind -> return "FP128" + FFI.PPC_FP128TypeKind -> return "PPC_FP128" + FFI.LabelTypeKind -> return "Label" + FFI.IntegerTypeKind -> do w <- FFI.getIntTypeWidth p; return $ "(IntN " ++ show w ++ ")" + FFI.FunctionTypeKind -> do + r <- FFI.getReturnType p + c <- FFI.countParamTypes p + let n = fromIntegral c + as <- allocaArray n $ \ args -> do + FFI.getParamTypes p args + peekArray n args + ts <- mapM showType' (as ++ [r]) + return $ "(" ++ intercalate " -> " ts ++ ")" + FFI.StructTypeKind -> return "(Struct ...)" + FFI.ArrayTypeKind -> do n <- FFI.getArrayLength p; t <- FFI.getElementType p >>= showType'; return $ "(Array " ++ show n ++ " " ++ t ++ ")" + FFI.PointerTypeKind -> do t <- FFI.getElementType p >>= showType'; return $ "(Ptr " ++ t ++ ")" + FFI.OpaqueTypeKind -> return "Opaque" + FFI.VectorTypeKind -> do n <- FFI.getVectorSize p; t <- FFI.getElementType p >>= showType'; return $ "(Vector " ++ show n ++ " " ++ t ++ ")" + +-------------------------------------- +-- Handle module providers + +-- | A module provider is used by the code generator to get access to a module. +newtype ModuleProvider = ModuleProvider { + fromModuleProvider :: ForeignPtr FFI.ModuleProvider + } + deriving (Show, Typeable) + +withModuleProvider :: ModuleProvider -> (FFI.ModuleProviderRef -> IO a) + -> IO a +withModuleProvider = withForeignPtr . fromModuleProvider + +-- | Turn a module into a module provider. +createModuleProviderForExistingModule :: Module -> IO ModuleProvider +createModuleProviderForExistingModule modul = + withModule modul $ \modulPtr -> do + ptr <- FFI.createModuleProviderForExistingModule modulPtr + -- MPs given to the EE get taken over, so we should not GC them. + liftM ModuleProvider $ newForeignPtr_ {-FFI.ptrDisposeModuleProvider-} ptr + + +-------------------------------------- +-- Handle instruction builders + +newtype Builder = Builder { + fromBuilder :: ForeignPtr FFI.Builder + } + deriving (Show, Typeable) + +withBuilder :: Builder -> (FFI.BuilderRef -> IO a) -> IO a +withBuilder = withForeignPtr . fromBuilder + +createBuilder :: IO Builder +createBuilder = do + ptr <- FFI.createBuilder + liftM Builder $ newForeignPtr FFI.ptrDisposeBuilder ptr + +positionAtEnd :: Builder -> FFI.BasicBlockRef -> IO () +positionAtEnd bld bblk = + withBuilder bld $ \ bldPtr -> + FFI.positionAtEnd bldPtr bblk + +getInsertBlock :: Builder -> IO FFI.BasicBlockRef +getInsertBlock bld = + withBuilder bld $ \ bldPtr -> + FFI.getInsertBlock bldPtr + +-------------------------------------- + +type BasicBlock = FFI.BasicBlockRef + +appendBasicBlock :: Function -> String -> IO BasicBlock +appendBasicBlock func name = + withCString name $ \ namePtr -> + FFI.appendBasicBlock func namePtr + +getBasicBlocks :: Value -> IO [(String, Value)] +getBasicBlocks v = getObjList withValue FFI.getFirstBasicBlock FFI.getNextBasicBlock v >>= annotateValueList + +-------------------------------------- + +type Function = FFI.ValueRef + +addFunction :: Module -> FFI.Linkage -> String -> Type -> IO Function +addFunction modul linkage name typ = + withModule modul $ \ modulPtr -> + withCString name $ \ namePtr -> do + f <- FFI.addFunction modulPtr namePtr typ + FFI.setLinkage f (FFI.fromLinkage linkage) + return f + +getParam :: Function -> Int -> Value +getParam f = FFI.getParam f . fromIntegral + +getParams :: Value -> IO [(String, Value)] +getParams v = getObjList withValue FFI.getFirstParam FFI.getNextParam v >>= annotateValueList + +-------------------------------------- + +addGlobal :: Module -> FFI.Linkage -> String -> Type -> IO Value +addGlobal modul linkage name typ = + withModule modul $ \ modulPtr -> + withCString name $ \ namePtr -> do + v <- FFI.addGlobal modulPtr typ namePtr + FFI.setLinkage v (FFI.fromLinkage linkage) + return v + +-- unsafePerformIO is safe because it's only used for the withCStringLen conversion +constStringInternal :: Bool -> String -> Value +constStringInternal nulTerm s = unsafePerformIO $ + withCStringLen s $ \(sPtr, sLen) -> + return $ FFI.constString sPtr (fromIntegral sLen) (fromBool (not nulTerm)) + +constString :: String -> Value +constString = constStringInternal False + +constStringNul :: String -> Value +constStringNul = constStringInternal True + +-------------------------------------- + +type Value = FFI.ValueRef + +withValue :: Value -> (Value -> IO a) -> IO a +withValue v f = f v + +makeCall :: Function -> FFI.BuilderRef -> [Value] -> IO Value +makeCall = makeCallWithCc FFI.C + +makeCallWithCc :: FFI.CallingConvention -> Function -> FFI.BuilderRef -> [Value] -> IO Value +makeCallWithCc cc func bldPtr args = do +{- + print "makeCall" + FFI.dumpValue func + mapM_ FFI.dumpValue args + print "----------------------" +-} + withArrayLen args $ \ argLen argPtr -> + withEmptyCString $ \cstr -> do + i <- FFI.buildCall bldPtr func argPtr + (fromIntegral argLen) cstr + FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) + return i + +makeInvoke :: BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> + [Value] -> IO Value +makeInvoke = makeInvokeWithCc FFI.C + +makeInvokeWithCc :: FFI.CallingConvention -> BasicBlock -> BasicBlock -> Function -> FFI.BuilderRef -> + [Value] -> IO Value +makeInvokeWithCc cc norm expt func bldPtr args = + withArrayLen args $ \ argLen argPtr -> + withEmptyCString $ \cstr -> do + i <- FFI.buildInvoke bldPtr func argPtr (fromIntegral argLen) norm expt cstr + FFI.setInstructionCallConv i (FFI.fromCallingConvention cc) + return i + +getInstructions :: Value -> IO [(String, Value)] +getInstructions bb = getObjList withValue FFI.getFirstInstruction FFI.getNextInstruction bb >>= annotateValueList + +getOperands :: Value -> IO [(String, Value)] +getOperands ii = geto ii >>= annotateValueList + where geto i = do + num <- FFI.getNumOperands i + let oloop instr number total = if number >= total then return [] else do + o <- FFI.getOperand instr number + os <- oloop instr (number + 1) total + return (o : os) + oloop i 0 num + +-------------------------------------- + +buildEmptyPhi :: FFI.BuilderRef -> Type -> IO Value +buildEmptyPhi bldPtr typ = do + withEmptyCString $ FFI.buildPhi bldPtr typ + +withEmptyCString :: (CString -> IO a) -> IO a +withEmptyCString = withCString "" + +addPhiIns :: Value -> [(Value, BasicBlock)] -> IO () +addPhiIns inst incoming = do + let (vals, bblks) = unzip incoming + withArrayLen vals $ \ count valPtr -> + withArray bblks $ \ bblkPtr -> + FFI.addIncoming inst valPtr bblkPtr (fromIntegral count) + +-------------------------------------- + +-- | Manage compile passes. +newtype PassManager = PassManager { + fromPassManager :: ForeignPtr FFI.PassManager + } + deriving (Show, Typeable) + +withPassManager :: PassManager -> (FFI.PassManagerRef -> IO a) + -> IO a +withPassManager = withForeignPtr . fromPassManager + +-- | Create a pass manager. +createPassManager :: IO PassManager +createPassManager = do + ptr <- FFI.createPassManager + liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr + +-- | Create a pass manager for a module. +createFunctionPassManager :: ModuleProvider -> IO PassManager +createFunctionPassManager modul = + withModuleProvider modul $ \modulPtr -> do + ptr <- FFI.createFunctionPassManager modulPtr + liftM PassManager $ newForeignPtr FFI.ptrDisposePassManager ptr + +-- | Add a control flow graph simplification pass to the manager. +addCFGSimplificationPass :: PassManager -> IO () +addCFGSimplificationPass pm = withPassManager pm FFI.addCFGSimplificationPass + +-- | Add a constant propagation pass to the manager. +addConstantPropagationPass :: PassManager -> IO () +addConstantPropagationPass pm = withPassManager pm FFI.addConstantPropagationPass + +addDemoteMemoryToRegisterPass :: PassManager -> IO () +addDemoteMemoryToRegisterPass pm = withPassManager pm FFI.addDemoteMemoryToRegisterPass + +-- | Add a global value numbering pass to the manager. +addGVNPass :: PassManager -> IO () +addGVNPass pm = withPassManager pm FFI.addGVNPass + +addInstructionCombiningPass :: PassManager -> IO () +addInstructionCombiningPass pm = withPassManager pm FFI.addInstructionCombiningPass + +addPromoteMemoryToRegisterPass :: PassManager -> IO () +addPromoteMemoryToRegisterPass pm = withPassManager pm FFI.addPromoteMemoryToRegisterPass + +addReassociatePass :: PassManager -> IO () +addReassociatePass pm = withPassManager pm FFI.addReassociatePass + +addTargetData :: FFI.TargetDataRef -> PassManager -> IO () +addTargetData td pm = withPassManager pm $ FFI.addTargetData td + +runFunctionPassManager :: PassManager -> Function -> IO Int +runFunctionPassManager pm fcn = liftM fromIntegral $ withPassManager pm $ \ pmref -> FFI.runFunctionPassManager pmref fcn + +initializeFunctionPassManager :: PassManager -> IO Int +initializeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.initializeFunctionPassManager + +finalizeFunctionPassManager :: PassManager -> IO Int +finalizeFunctionPassManager pm = liftM fromIntegral $ withPassManager pm FFI.finalizeFunctionPassManager + +-------------------------------------- + +-- The unsafePerformIO is just for the non-effecting withArrayLen +constVector :: Int -> [Value] -> Value +constVector n xs = unsafePerformIO $ do + let xs' = take n (cycle xs) + withArrayLen xs' $ \ len ptr -> + return $ FFI.constVector ptr (fromIntegral len) + +-- The unsafePerformIO is just for the non-effecting withArrayLen +constArray :: Type -> Int -> [Value] -> Value +constArray t n xs = unsafePerformIO $ do + let xs' = take n (cycle xs) + withArrayLen xs' $ \ len ptr -> + return $ FFI.constArray t ptr (fromIntegral len) + +-- The unsafePerformIO is just for the non-effecting withArrayLen +constStruct :: [Value] -> Bool -> Value +constStruct xs packed = unsafePerformIO $ do + withArrayLen xs $ \ len ptr -> + return $ FFI.constStruct ptr (fromIntegral len) (if packed then 1 else 0) + +-------------------------------------- + +getValueNameU :: Value -> IO String +getValueNameU a = do + -- sometimes void values need explicit names too + cs <- FFI.getValueName a + str <- peekCString cs + if str == "" then return (show a) else return str + +getObjList :: (t1 -> (t2 -> IO [Ptr a]) -> t) -> (t2 -> IO (Ptr a)) + -> (Ptr a -> IO (Ptr a)) -> t1 -> t +getObjList withF firstF nextF obj = do + withF obj $ \ objPtr -> do + ofst <- firstF objPtr + let oloop p = if p == nullPtr then return [] else do + n <- nextF p + ps <- oloop n + return (p : ps) + oloop ofst + +annotateValueList :: [Value] -> IO [(String, Value)] +annotateValueList vs = do + names <- mapM getValueNameU vs + return $ zip names vs + +isConstant :: Value -> IO Bool +isConstant v = do + isC <- FFI.isConstant v + if isC == 0 then return False else return True + +isIntrinsic :: Value -> IO Bool +isIntrinsic v = do + if FFI.getIntrinsicID v == 0 then return True else return False + +-------------------------------------- + +type Use = FFI.UseRef + +hasUsers :: Value -> IO Bool +hasUsers v = do + nU <- FFI.getNumUses v + if nU == 0 then return False else return True + +getUses :: Value -> IO [Use] +getUses = getObjList withValue FFI.getFirstUse FFI.getNextUse + +getUsers :: [Use] -> IO [(String, Value)] +getUsers us = mapM FFI.getUser us >>= annotateValueList + +getUser :: Use -> IO Value +getUser = FFI.getUser + +isChildOf :: BasicBlock -> Value -> IO Bool +isChildOf bb v = do + bb2 <- FFI.getInstructionParent v + if bb == bb2 then return True else return False + +getDep :: Use -> IO (String, String) +getDep u = do + producer <- FFI.getUsedValue u >>= getValueNameU + consumer <- FFI.getUser u >>= getValueNameU + return (producer, consumer) diff --git a/LLVM/Core/Vector.hs b/LLVM/Core/Vector.hs new file mode 100644 --- /dev/null +++ b/LLVM/Core/Vector.hs @@ -0,0 +1,148 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Core.Vector(MkVector(..), vector, ) where +import Data.Function +import Types.Data.Num +import LLVM.Core.Type +import LLVM.Core.Data +import LLVM.ExecutionEngine.Target +import Foreign.Ptr(castPtr) +import Foreign.Storable(Storable(..)) +import Foreign.Marshal.Array(peekArray, pokeArray) +import System.IO.Unsafe(unsafePerformIO) + +-- XXX Should these really be here? +class (PositiveT n, IsPrimitive a) => MkVector n a where + type Tuple n a :: * + toVector :: Tuple n a -> Vector n a + fromVector :: Vector n a -> Tuple n a + +{- +instance (IsPrimitive a) => MkVector (Value a) D1 (Value a) where + toVector a = Vector [a] +-} + +instance (IsPrimitive a) => MkVector D2 a where + type Tuple D2 a = (a,a) + toVector (a1, a2) = Vector [a1, a2] + fromVector (Vector [a1, a2]) = (a1, a2) + fromVector _ = error "fromVector: impossible" + +instance (IsPrimitive a) => MkVector D4 a where + type Tuple D4 a = (a,a,a,a) + toVector (a1, a2, a3, a4) = Vector [a1, a2, a3, a4] + fromVector (Vector [a1, a2, a3, a4]) = (a1, a2, a3, a4) + fromVector _ = error "fromVector: impossible" + +instance (IsPrimitive a) => MkVector D8 a where + type Tuple D8 a = (a,a,a,a,a,a,a,a) + toVector (a1, a2, a3, a4, a5, a6, a7, a8) = Vector [a1, a2, a3, a4, a5, a6, a7, a8] + fromVector (Vector [a1, a2, a3, a4, a5, a6, a7, a8]) = (a1, a2, a3, a4, a5, a6, a7, a8) + fromVector _ = error "fromVector: impossible" + +instance (Storable a, PositiveT n, IsPrimitive a) => Storable (Vector n a) where + sizeOf a = storeSizeOfType ourTargetData (typeRef a) + alignment a = aBIAlignmentOfType ourTargetData (typeRef a) + peek p = fmap Vector $ peekArray (fromIntegerT (undefined :: n)) (castPtr p :: Ptr a) + poke p (Vector vs) = pokeArray (castPtr p :: Ptr a) vs + +-- XXX The JITer target data. This isn't really right. +ourTargetData :: TargetData +ourTargetData = unsafePerformIO getTargetData + +-------------------------------------- + +unVector :: Vector n a -> [a] +unVector (Vector xs) = xs + +-- |Make a constant vector. Replicates or truncates the list to get length /n/. +-- This behaviour is consistent with that of 'LLVM.Core.CodeGen.constVector'. +vector :: forall a n. (PositiveT n) => [a] -> Vector n a +vector xs = + Vector (take (fromIntegerT (undefined :: n)) (cycle xs)) + + +binop :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c +binop op xs ys = Vector $ zipWith op (unVector xs) (unVector ys) + +unop :: (a -> b) -> Vector n a -> Vector n b +unop op = Vector . map op . unVector + +instance (Eq a, PositiveT n) => Eq (Vector n a) where + (==) = (==) `on` unVector + +instance (Ord a, PositiveT n) => Ord (Vector n a) where + compare = compare `on` unVector + +instance (Num a, PositiveT n) => Num (Vector n a) where + (+) = binop (+) + (-) = binop (-) + (*) = binop (*) + negate = unop negate + abs = unop abs + signum = unop signum + fromInteger = Vector . replicate (fromIntegerT (undefined :: n)) . fromInteger + +instance (Enum a, PositiveT n) => Enum (Vector n a) where + succ = unop succ + pred = unop pred + fromEnum = error "Vector fromEnum" + toEnum = Vector . map toEnum . replicate (fromIntegerT (undefined :: n)) + +instance (Real a, PositiveT n) => Real (Vector n a) where + toRational = error "Vector toRational" + +instance (Integral a, PositiveT n) => Integral (Vector n a) where + quot = binop quot + rem = binop rem + div = binop div + mod = binop mod + quotRem (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith quotRem xs ys + divMod (Vector xs) (Vector ys) = (Vector qs, Vector rs) where (qs, rs) = unzip $ zipWith divMod xs ys + toInteger = error "Vector toInteger" + +instance (Fractional a, PositiveT n) => Fractional (Vector n a) where + (/) = binop (/) + fromRational = Vector . replicate (fromIntegerT (undefined :: n)) . fromRational + +instance (RealFrac a, PositiveT n) => RealFrac (Vector n a) where + properFraction = error "Vector properFraction" + +instance (Floating a, PositiveT n) => Floating (Vector n a) where + pi = Vector $ replicate (fromIntegerT (undefined :: n)) pi + sqrt = unop sqrt + log = unop log + logBase = binop logBase + (**) = binop (**) + exp = unop exp + sin = unop sin + cos = unop cos + tan = unop tan + asin = unop asin + acos = unop acos + atan = unop atan + sinh = unop sinh + cosh = unop cosh + tanh = unop tanh + asinh = unop asinh + acosh = unop acosh + atanh = unop atanh + +instance (RealFloat a, PositiveT n) => RealFloat (Vector n a) where + floatRadix = floatRadix . head . unVector + floatDigits = floatDigits . head . unVector + floatRange = floatRange . head . unVector + decodeFloat = error "Vector decodeFloat" + encodeFloat = error "Vector encodeFloat" + exponent _ = 0 + scaleFloat 0 x = x + scaleFloat _ _ = error "Vector scaleFloat" + isNaN = error "Vector isNaN" + isInfinite = error "Vector isInfinite" + isDenormalized = error "Vector isDenormalized" + isNegativeZero = error "Vector isNegativeZero" + isIEEE = isIEEE . head . unVector diff --git a/LLVM/ExecutionEngine.hs b/LLVM/ExecutionEngine.hs new file mode 100644 --- /dev/null +++ b/LLVM/ExecutionEngine.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE TypeFamilies #-} + -- |An 'ExecutionEngine' is JIT compiler that is used to generate code for an LLVM module. +module LLVM.ExecutionEngine( + -- * Execution engine + EngineAccess, + runEngineAccess, + addModuleProvider, + addModule, +{- + runStaticConstructors, + runStaticDestructors, +-} + getPointerToFunction, + addFunctionValue, + addGlobalMappings, + getFreePointers, FreePointers, + -- * Translation + Translatable, Generic, + generateFunction, + -- * Unsafe type conversion + Unsafe, + unsafeRemoveIO, + -- * Simplified interface. + simpleFunction, + unsafeGenerateFunction, + -- * Target information + module LLVM.ExecutionEngine.Target + ) where +import System.IO.Unsafe (unsafePerformIO) + +import LLVM.ExecutionEngine.Engine +import LLVM.FFI.Core(ValueRef) +import LLVM.Core.CodeGen(Value(..)) +import LLVM.Core +import LLVM.ExecutionEngine.Target +--import LLVM.Core.Util(runFunctionPassManager, initializeFunctionPassManager, finalizeFunctionPassManager) +import Control.Monad (liftM2, ) + +-- |Class of LLVM function types that can be translated to the corresponding +-- Haskell type. +class Translatable f where + translate :: (ValueRef -> [GenericValue] -> IO GenericValue) -> [GenericValue] -> ValueRef -> f + +instance (Generic a, Translatable b) => Translatable (a -> b) where + translate run args f = \ arg -> translate run (toGeneric arg : args) f + +instance (Generic a) => Translatable (IO a) where + translate run args f = fmap fromGeneric $ run f $ reverse args + +-- |Generate a Haskell function from an LLVM function. +-- +-- Note that the function is compiled for every call (Just-In-Time compilation). +-- If you want to compile the function once and call it a lot of times +-- then you should better use 'getPointerToFunction'. +generateFunction :: (Translatable f) => + Value (Ptr f) -> EngineAccess f +generateFunction (Value f) = do + run <- getRunFunction + return $ translate run [] f + +class Unsafe a where + type RemoveIO a :: * + unsafeRemoveIO :: a -> RemoveIO a -- ^Remove the IO from a function return type. This is unsafe in general. + +instance (Unsafe b) => Unsafe (a->b) where + type RemoveIO (a -> b) = a -> RemoveIO b + unsafeRemoveIO f = unsafeRemoveIO . f + +instance Unsafe (IO a) where + type RemoveIO (IO a) = a + unsafeRemoveIO = unsafePerformIO + +-- |Translate a function to Haskell code. This is a simplified interface to +-- the execution engine and module mechanism. +-- It is based on 'generateFunction', so see there for limitations. +simpleFunction :: (Translatable f) => CodeGenModule (Function f) -> IO f +simpleFunction bld = do + m <- newModule + (func, mappings) <- defineModule m (liftM2 (,) bld getGlobalMappings) + prov <- createModuleProviderForExistingModule m + runEngineAccess $ do + addModuleProvider prov + addGlobalMappings mappings + generateFunction func + +{- + m <- newModule + func <- defineModule m bld +-- dumpValue func + prov <- createModuleProviderForExistingModule m + ee <- createExecutionEngine prov + pm <- createFunctionPassManager prov + td <- getExecutionEngineTargetData ee + addTargetData td pm + addInstructionCombiningPass pm + addReassociatePass pm + addGVNPass pm + addCFGSimplificationPass pm + addPromoteMemoryToRegisterPass pm + initializeFunctionPassManager pm +-- print ("rc1", rc1) + runFunctionPassManager pm (unValue func) +-- print ("rc2", rc2) + finalizeFunctionPassManager pm +-- print ("rc3", rc3) +-- dumpValue func + return $ generateFunction ee func +-} + +-- | Combine 'simpleFunction' and 'unsafeRemoveIO'. +unsafeGenerateFunction :: (Unsafe t, Translatable t) => + CodeGenModule (Function t) -> RemoveIO t +unsafeGenerateFunction bld = unsafePerformIO $ do + fun <- simpleFunction bld + return $ unsafeRemoveIO fun diff --git a/LLVM/ExecutionEngine/Engine.hs b/LLVM/ExecutionEngine/Engine.hs new file mode 100644 --- /dev/null +++ b/LLVM/ExecutionEngine/Engine.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.ExecutionEngine.Engine( + EngineAccess, + runEngineAccess, +{- + ExecutionEngine, +-} + createExecutionEngine, addModuleProvider, addModule, + {- runStaticConstructors, runStaticDestructors, -} + getExecutionEngineTargetData, + getPointerToFunction, + addFunctionValue, addGlobalMappings, + getFreePointers, FreePointers, + runFunction, getRunFunction, + GenericValue, Generic(..) + ) where +import Control.Monad.State +import Control.Applicative (Applicative, ) +import Control.Concurrent.MVar +import Data.Typeable +import Data.Int +import Data.Word +import Foreign.Marshal.Alloc (alloca, free) +import Foreign.Marshal.Array (withArrayLen) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Marshal.Utils (fromBool) +import Foreign.C.String (peekCString) +import Foreign.Ptr (Ptr, FunPtr, castFunPtrToPtr) +import LLVM.Core.CodeGen(Value(..), Function) +import LLVM.Core.CodeGenMonad(GlobalMappings(..)) +import Foreign.Storable (peek) +import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr, ) +import System.IO.Unsafe (unsafePerformIO) + +import LLVM.Core.Util(Module, ModuleProvider, withModuleProvider, createModule, createModuleProviderForExistingModule) +import qualified LLVM.FFI.ExecutionEngine as FFI +import qualified LLVM.FFI.Target as FFI +import qualified LLVM.FFI.Core as FFI(ModuleProviderRef, ValueRef) +import qualified LLVM.Core.Util as U +import LLVM.Core.Type(IsFirstClass, typeRef) + +{- +-- |The type of the JITer. +newtype ExecutionEngine = ExecutionEngine { + fromExecutionEngine :: ForeignPtr FFI.ExecutionEngine + } + +withExecutionEngine :: ExecutionEngine -> (Ptr FFI.ExecutionEngine -> IO a) + -> IO a +withExecutionEngine = withForeignPtr . fromExecutionEngine + +-- |Create an execution engine for a module provider. +-- Warning, do not call this function more than once. +createExecutionEngine :: ModuleProvider -> IO ExecutionEngine +createExecutionEngine prov = + withModuleProvider prov $ \provPtr -> + alloca $ \eePtr -> + alloca $ \errPtr -> do + ret <- FFI.createExecutionEngine eePtr provPtr errPtr + if ret == 1 + then do err <- peek errPtr + errStr <- peekCString err + free err + ioError . userError $ errStr + else do ptr <- peek eePtr + liftM ExecutionEngine $ newForeignPtr FFI.ptrDisposeExecutionEngine ptr + +addModuleProvider :: ExecutionEngine -> ModuleProvider -> IO () +addModuleProvider ee prov = + withExecutionEngine ee $ \ eePtr -> + withModuleProvider prov $ \ provPtr -> + FFI.addModuleProvider eePtr provPtr + +runStaticConstructors :: ExecutionEngine -> IO () +runStaticConstructors ee = withExecutionEngine ee FFI.runStaticConstructors + +runStaticDestructors :: ExecutionEngine -> IO () +runStaticDestructors ee = withExecutionEngine ee FFI.runStaticDestructors + +getExecutionEngineTargetData :: ExecutionEngine -> IO FFI.TargetDataRef +getExecutionEngineTargetData ee = withExecutionEngine ee FFI.getExecutionEngineTargetData + +getPointerToFunction :: ExecutionEngine -> Function f -> IO (FunPtr f) +getPointerToFunction ee (Value f) = + withExecutionEngine ee $ \ eePtr -> + FFI.getPointerToGlobal eePtr f +-} + +-- This global variable holds the one and only execution engine. +-- It may be missing, but it never dies. +-- XXX We could provide a destructor, what about functions obtained by runFunction? +{-# NOINLINE theEngine #-} +theEngine :: MVar (Maybe (Ptr FFI.ExecutionEngine)) +theEngine = unsafePerformIO $ newMVar Nothing + +createExecutionEngine :: ModuleProvider -> IO (Ptr FFI.ExecutionEngine) +createExecutionEngine prov = + withModuleProvider prov $ \provPtr -> + alloca $ \eePtr -> + alloca $ \errPtr -> do + ret <- FFI.createExecutionEngine eePtr provPtr errPtr + if ret == 1 + then do + err <- peek errPtr + errStr <- peekCString err + free err + ioError . userError $ errStr + else + peek eePtr + +getTheEngine :: IO (Ptr FFI.ExecutionEngine) +getTheEngine = do + mee <- takeMVar theEngine + case mee of + Just ee -> do putMVar theEngine mee; return ee + Nothing -> do + m <- createModule "__empty__" + mp <- createModuleProviderForExistingModule m + ee <- createExecutionEngine mp + putMVar theEngine (Just ee) + return ee + +data EAState = EAState { + ea_engine :: Ptr FFI.ExecutionEngine, + ea_providers :: [ModuleProvider] + } + deriving (Show, Typeable) + +newtype EngineAccess a = EA (StateT EAState IO a) + deriving (Functor, Applicative, Monad, MonadState EAState, MonadIO) + +-- |The LLVM execution engine is encapsulated so it cannot be accessed directly. +-- The reason is that (currently) there must only ever be one engine, +-- so access to it is wrapped in a monad. +runEngineAccess :: EngineAccess a -> IO a +runEngineAccess (EA body) = do + eePtr <- getTheEngine + let ea = EAState { ea_engine = eePtr, ea_providers = [] } + (a, _ea') <- runStateT body ea + -- XXX should remove module providers again + return a + +addModuleProvider :: ModuleProvider -> EngineAccess () +addModuleProvider prov = do + ea <- get + put ea{ ea_providers = prov : ea_providers ea } + liftIO $ withModuleProvider prov $ \ provPtr -> + FFI.addModuleProvider (ea_engine ea) provPtr + +getExecutionEngineTargetData :: EngineAccess FFI.TargetDataRef +getExecutionEngineTargetData = do + eePtr <- gets ea_engine + liftIO $ FFI.getExecutionEngineTargetData eePtr + +{- | +In contrast to 'generateFunction' this compiles a function once. +Thus it is faster for many calls to the same function. +See @examples\/Vector.hs@. + +If the function calls back into Haskell code, +you also have to set the function addresses +using 'addFunctionValue' or 'addGlobalMappings'. +-} +getPointerToFunction :: Function f -> EngineAccess (FunPtr f) +getPointerToFunction (Value f) = do + eePtr <- gets ea_engine + liftIO $ FFI.getPointerToGlobal eePtr f + +{- | +Tell LLVM the address of an external function +if it cannot resolve a name automatically. +Alternatively you may declare the function +with 'staticFunction' instead of 'externFunction'. +-} +addFunctionValue :: Function f -> FunPtr f -> EngineAccess () +addFunctionValue (Value g) f = + addFunctionValueCore g (castFunPtrToPtr f) + +{- | +Pass a list of global mappings to LLVM +that can be obtained from 'LLVM.Core.getGlobalMappings'. +-} +addGlobalMappings :: GlobalMappings -> EngineAccess () +addGlobalMappings (GlobalMappings gms) = + mapM_ (uncurry addFunctionValueCore) gms + +addFunctionValueCore :: U.Function -> Ptr () -> EngineAccess () +addFunctionValueCore g f = do + eePtr <- gets ea_engine + liftIO $ FFI.addGlobalMapping eePtr g f + +addModule :: Module -> EngineAccess () +addModule m = do + mp <- liftIO $ createModuleProviderForExistingModule m + addModuleProvider mp + +-- | Get all the information needed to free a function. +-- Freeing code might have to be done from a (C) finalizer, so it has to done from C. +-- The function c_freeFunctionObject take these pointers as arguments and frees the function. +type FreePointers = (Ptr FFI.ExecutionEngine, FFI.ModuleProviderRef, FFI.ValueRef) +getFreePointers :: Function f -> EngineAccess FreePointers +getFreePointers (Value f) = do + ea <- get + liftIO $ withModuleProvider (head $ ea_providers ea) $ \ mpp -> + return (ea_engine ea, mpp, f) + +-------------------------------------- + +newtype GenericValue = GenericValue { + fromGenericValue :: ForeignPtr FFI.GenericValue + } + +withGenericValue :: GenericValue -> (FFI.GenericValueRef -> IO a) -> IO a +withGenericValue = withForeignPtr . fromGenericValue + +createGenericValueWith :: IO FFI.GenericValueRef -> IO GenericValue +createGenericValueWith f = do + ptr <- f + liftM GenericValue $ newForeignPtr FFI.ptrDisposeGenericValue ptr + +withAll :: [GenericValue] -> (Int -> Ptr FFI.GenericValueRef -> IO a) -> IO a +withAll ps a = go [] ps + where go ptrs (x:xs) = withGenericValue x $ \ptr -> go (ptr:ptrs) xs + go ptrs _ = withArrayLen (reverse ptrs) a + +runFunction :: U.Function -> [GenericValue] -> EngineAccess GenericValue +runFunction func args = do + eePtr <- gets ea_engine + liftIO $ withAll args $ \argLen argPtr -> + createGenericValueWith $ FFI.runFunction eePtr func + (fromIntegral argLen) argPtr +getRunFunction :: EngineAccess (U.Function -> [GenericValue] -> IO GenericValue) +getRunFunction = do + eePtr <- gets ea_engine + return $ \ func args -> + withAll args $ \argLen argPtr -> + createGenericValueWith $ FFI.runFunction eePtr func + (fromIntegral argLen) argPtr + +class Generic a where + toGeneric :: a -> GenericValue + fromGeneric :: GenericValue -> a + +instance Generic () where + toGeneric _ = error "toGeneric ()" + fromGeneric _ = () + +toGenericInt :: (Integral a, IsFirstClass a) => Bool -> a -> GenericValue +toGenericInt signed val = unsafePerformIO $ createGenericValueWith $ + FFI.createGenericValueOfInt (typeRef val) (fromIntegral val) (fromBool signed) + +fromGenericInt :: (Integral a, IsFirstClass a) => Bool -> GenericValue -> a +fromGenericInt signed val = unsafePerformIO $ + withGenericValue val $ \ref -> + return . fromIntegral $ FFI.genericValueToInt ref (fromBool signed) + +--instance Generic Bool where +-- toGeneric = toGenericInt False . fromBool +-- fromGeneric = toBool . fromGenericInt False + +instance Generic Int8 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +instance Generic Int16 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +instance Generic Int32 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +{- +instance Generic Int where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True +-} + +instance Generic Int64 where + toGeneric = toGenericInt True + fromGeneric = fromGenericInt True + +instance Generic Word8 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +instance Generic Word16 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +instance Generic Word32 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +instance Generic Word64 where + toGeneric = toGenericInt False + fromGeneric = fromGenericInt False + +toGenericReal :: (Real a, IsFirstClass a) => a -> GenericValue +toGenericReal val = unsafePerformIO $ createGenericValueWith $ + FFI.createGenericValueOfFloat (typeRef val) (realToFrac val) + +fromGenericReal :: forall a . (Fractional a, IsFirstClass a) => GenericValue -> a +fromGenericReal val = unsafePerformIO $ + withGenericValue val $ \ ref -> + return . realToFrac $ FFI.genericValueToFloat (typeRef (undefined :: a)) ref + +instance Generic Float where + toGeneric = toGenericReal + fromGeneric = fromGenericReal + +instance Generic Double where + toGeneric = toGenericReal + fromGeneric = fromGenericReal + +instance Generic (Ptr a) where + toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer + fromGeneric val = unsafePerformIO . withGenericValue val $ FFI.genericValueToPointer + +instance Generic (StablePtr a) where + toGeneric = unsafePerformIO . createGenericValueWith . FFI.createGenericValueOfPointer . castStablePtrToPtr + fromGeneric val = unsafePerformIO . fmap castPtrToStablePtr . withGenericValue val $ FFI.genericValueToPointer diff --git a/LLVM/ExecutionEngine/Target.hs b/LLVM/ExecutionEngine/Target.hs new file mode 100644 --- /dev/null +++ b/LLVM/ExecutionEngine/Target.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where +import Data.Typeable +import Types.Data.Num(PositiveT, reifyPositiveD) +import Data.Maybe(fromMaybe) +import Foreign.C.String +import System.IO.Unsafe(unsafePerformIO) + +import LLVM.Core.Data(WordN) +import LLVM.ExecutionEngine.Engine(runEngineAccess, getExecutionEngineTargetData) + +import qualified LLVM.FFI.Core as FFI +import qualified LLVM.FFI.Target as FFI + +type Type = FFI.TypeRef + +data TargetData = TargetData { + aBIAlignmentOfType :: Type -> Int, + aBISizeOfType :: Type -> Int, + littleEndian :: Bool, + callFrameAlignmentOfType :: Type -> Int, +-- elementAtOffset :: Type -> Word64 -> Int, + intPtrType :: Type, +-- offsetOfElements :: Int -> Word64, + pointerSize :: Int, +-- preferredAlignmentOfGlobal :: Value a -> Int, + preferredAlignmentOfType :: Type -> Int, + sizeOfTypeInBits :: Type -> Int, + storeSizeOfType :: Type -> Int + } + deriving (Typeable) + +withIntPtrType :: (forall n . (PositiveT n) => WordN n -> a) -> a +withIntPtrType f = + fromMaybe (error "withIntPtrType: pointer size must be non-negative") $ + reifyPositiveD (fromIntegral sz) (\ n -> f (g n)) + where g :: n -> WordN n + g _ = error "withIntPtrType: argument used" + sz = pointerSize $ unsafePerformIO getTargetData + +-- Gets the target data for the JIT target. +getEngineTargetDataRef :: IO FFI.TargetDataRef +getEngineTargetDataRef = runEngineAccess getExecutionEngineTargetData + +-- Normally the TargetDataRef never changes, so the operation +-- are really pure functions. +makeTargetData :: FFI.TargetDataRef -> TargetData +makeTargetData r = TargetData { + aBIAlignmentOfType = fromIntegral . FFI.aBIAlignmentOfType r, + aBISizeOfType = fromIntegral . FFI.aBISizeOfType r, + littleEndian = FFI.byteOrder r /= 0, + callFrameAlignmentOfType = fromIntegral . FFI.callFrameAlignmentOfType r, + intPtrType = FFI.intPtrType r, + pointerSize = fromIntegral $ FFI.pointerSize r, + preferredAlignmentOfType = fromIntegral . FFI.preferredAlignmentOfType r, + sizeOfTypeInBits = fromIntegral . FFI.sizeOfTypeInBits r, + storeSizeOfType = fromIntegral . FFI.storeSizeOfType r + } + +getTargetData :: IO TargetData +getTargetData = fmap makeTargetData getEngineTargetDataRef + +targetDataFromString :: String -> TargetData +targetDataFromString s = makeTargetData $ unsafePerformIO $ withCString s FFI.createTargetData diff --git a/LLVM/Util/Arithmetic.hs b/LLVM/Util/Arithmetic.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/Arithmetic.hs @@ -0,0 +1,308 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Util.Arithmetic( + TValue, + (%==), (%/=), (%<), (%<=), (%>), (%>=), + (%&&), (%||), + (?), (??), + retrn, set, + ArithFunction, arithFunction, + UnwrapArgs, toArithFunction, + recursiveFunction, + CallIntrinsic, + ) where + +import qualified Types.Data.Num as TypeNum +import qualified LLVM.Core as LLVM +import LLVM.Core hiding (cmp, ) +import LLVM.Util.Loop(mapVector, mapVector2) +import Control.Monad(liftM2) + +-- |Synonym for @CodeGenFunction r (Value a)@. +type TValue r a = CodeGenFunction r (Value a) + + +infix 4 %==, %/=, %<, %<=, %>=, %> +-- |Comparison functions. +(%==), (%/=), (%<), (%<=), (%>), (%>=) :: (CmpRet a) => TValue r a -> TValue r a -> TValue r (CmpResult a) +(%==) = binop $ LLVM.cmp CmpEQ +(%/=) = binop $ LLVM.cmp CmpNE +(%>) = binop $ LLVM.cmp CmpGT +(%>=) = binop $ LLVM.cmp CmpGE +(%<) = binop $ LLVM.cmp CmpLT +(%<=) = binop $ LLVM.cmp CmpLE + +infixr 3 %&& +infixr 2 %|| +-- |Lazy and. +(%&&) :: TValue r Bool -> TValue r Bool -> TValue r Bool +a %&& b = a ? (b, return (valueOf False)) +-- |Lazy or. +(%||) :: TValue r Bool -> TValue r Bool -> TValue r Bool +a %|| b = a ? (return (valueOf True), b) + +infix 0 ? +-- |Conditional, returns first element of the pair when condition is true, otherwise second. +(?) :: (IsFirstClass a) => TValue r Bool -> (TValue r a, TValue r a) -> TValue r a +c ? (t, f) = do + lt <- newBasicBlock + lf <- newBasicBlock + lj <- newBasicBlock + c' <- c + condBr c' lt lf + defineBasicBlock lt + rt <- t + lt' <- getCurrentBasicBlock + br lj + defineBasicBlock lf + rf <- f + lf' <- getCurrentBasicBlock + br lj + defineBasicBlock lj + phi [(rt, lt'), (rf, lf')] + +infix 0 ?? +(??) :: (IsFirstClass a, CmpRet a) => TValue r (CmpResult a) -> (TValue r a, TValue r a) -> TValue r a +c ?? (t, f) = do + c' <- c + t' <- t + f' <- f + select c' t' f' + +-- | Return a value from an 'arithFunction'. +retrn :: (Ret (Value a) r) => TValue r a -> CodeGenFunction r () +retrn x = x >>= ret + +-- | Use @x <- set $ ...@ to make a binding. +set :: TValue r a -> (CodeGenFunction r (TValue r a)) +set x = do x' <- x; return (return x') + +instance (Show (TValue r a)) +instance (Eq (TValue r a)) +instance (Ord (TValue r a)) + +instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Num (TValue r a) where + (+) = binop add + (-) = binop sub + (*) = binop mul + negate = (>>= neg) + abs x = x %< 0 ?? (-x, x) + signum x = x %< 0 ?? (-1, x %> 0 ?? (1, 0)) + fromInteger = return . valueOf . fromInteger + +instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Enum (TValue r a) where + succ x = x + 1 + pred x = x - 1 + fromEnum _ = error "CodeGenFunction Value: fromEnum" + toEnum = fromIntegral + +instance (IsArithmetic a, CmpRet a, Num a, IsConst a) => Real (TValue r a) where + toRational _ = error "CodeGenFunction Value: toRational" + +instance (CmpRet a, Num a, IsConst a, IsInteger a) => Integral (TValue r a) where + quot = binop idiv + rem = binop irem + quotRem x y = (quot x y, rem x y) + toInteger _ = error "CodeGenFunction Value: toInteger" + +instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => Fractional (TValue r a) where + (/) = binop fdiv + fromRational = return . valueOf . fromRational + +instance (CmpRet a, Fractional a, IsConst a, IsFloating a) => RealFrac (TValue r a) where + properFraction _ = error "CodeGenFunction Value: properFraction" + +instance (CmpRet a, CallIntrinsic a, Floating a, IsConst a, IsFloating a) => Floating (TValue r a) where + pi = return $ valueOf pi + sqrt = callIntrinsic1 "sqrt" + sin = callIntrinsic1 "sin" + cos = callIntrinsic1 "cos" + (**) = callIntrinsic2 "pow" + exp = callIntrinsic1 "exp" + log = callIntrinsic1 "log" + + asin _ = error "LLVM missing intrinsic: asin" + acos _ = error "LLVM missing intrinsic: acos" + atan _ = error "LLVM missing intrinsic: atan" + + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x + exp (-x)) / 2 + asinh x = log (x + sqrt (x*x + 1)) + acosh x = log (x + sqrt (x*x - 1)) + atanh x = (log (1 + x) - log (1 - x)) / 2 + +instance (CmpRet a, CallIntrinsic a, RealFloat a, IsConst a, IsFloating a) => RealFloat (TValue r a) where + floatRadix _ = floatRadix (undefined :: a) + floatDigits _ = floatDigits (undefined :: a) + floatRange _ = floatRange (undefined :: a) + decodeFloat _ = error "CodeGenFunction Value: decodeFloat" + encodeFloat _ _ = error "CodeGenFunction Value: encodeFloat" + exponent _ = 0 + scaleFloat 0 x = x + scaleFloat _ _ = error "CodeGenFunction Value: scaleFloat" + isNaN _ = error "CodeGenFunction Value: isNaN" + isInfinite _ = error "CodeGenFunction Value: isInfinite" + isDenormalized _ = error "CodeGenFunction Value: isDenormalized" + isNegativeZero _ = error "CodeGenFunction Value: isNegativeZero" + isIEEE _ = isIEEE (undefined :: a) + +binop :: (Value a -> Value b -> TValue r c) -> + TValue r a -> TValue r b -> TValue r c +binop op x y = do + x' <- x + y' <- y + op x' y' + +{- +If we add the ReadNone attribute, then LLVM-2.8 complains: + +llvm/examples$ Arith_dyn.exe +Attribute readnone only applies to the function! + %2 = call readnone double @llvm.sin.f64(double %0) +Attribute readnone only applies to the function! + %3 = call readnone double @llvm.exp.f64(double %2) +Broken module found, compilation aborted! +Stack dump: +0. Running pass 'Function Pass Manager' on module '_module'. +1. Running pass 'Module Verifier' on function '@_fun1' +Aborted +-} +addReadNone :: Value a -> CodeGenFunction r (Value a) +addReadNone x = do +-- addAttributes x 0 [ReadNoneAttribute] + return x + +callIntrinsicP1 :: forall a b r . (IsFirstClass a, IsFirstClass b, IsPrimitive a) => + String -> Value a -> TValue r b +callIntrinsicP1 fn x = do + op :: Function (a -> IO b) <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a)) +{- +You can add these attributes, +but the verifier pass in the optimizer checks whether they match +the attributes that are declared for that intrinsic. +If we omit adding attributes then the right attributes are added automatically. + addFunctionAttributes op [NoUnwindAttribute, ReadOnlyAttribute] +-} + call op x >>= addReadNone + +callIntrinsicP2 :: forall a b c r . (IsFirstClass a, IsFirstClass b, IsFirstClass c, IsPrimitive a) => + String -> Value a -> Value b -> TValue r c +callIntrinsicP2 fn x y = do + op :: Function (a -> b -> IO c) <- externFunction ("llvm." ++ fn ++ "." ++ intrinsicTypeName (undefined :: a)) + call op x y >>= addReadNone + +------------------------------------------- + +class ArithFunction a b | a -> b, b -> a where + arithFunction' :: a -> b + +instance (Ret a r) => ArithFunction (CodeGenFunction r a) (CodeGenFunction r ()) where + arithFunction' x = x >>= ret + +instance (ArithFunction b b') => ArithFunction (CodeGenFunction r a -> b) (a -> b') where + arithFunction' f = arithFunction' . f . return + +-- |Unlift a function with @TValue@ to have @Value@ arguments. +arithFunction :: ArithFunction a b => a -> b +arithFunction = arithFunction' + +------------------------------------------- + +class UncurryN a b | a -> b, b -> a where + uncurryN :: a -> b + curryN :: b -> a + +instance UncurryN (CodeGenFunction r a) (() -> CodeGenFunction r a) where + uncurryN i = \ () -> i + curryN f = f () + +instance (UncurryN t (b -> c)) => UncurryN (a -> t) ((a, b) -> c) where + uncurryN f = \ (a, b) -> uncurryN (f a) b + curryN f = \ a -> curryN (\ b -> f (a, b)) + +class LiftTuple r a b | a -> b, b -> a where + liftTuple :: a -> CodeGenFunction r b + +instance LiftTuple r () () where + liftTuple = return + +instance (LiftTuple r b b') => LiftTuple r (CodeGenFunction r a, b) (a, b') where + liftTuple (a, b) = liftM2 (,) a (liftTuple b) + +class (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => + UnwrapArgs a a1 b1 b a2 r | a -> a1 b1, a1 b1 -> a, a1 -> b, b -> a1, a2 -> b b1, b b1 -> a2 where + unwrapArgs :: a2 -> a +instance (UncurryN a (a1 -> CodeGenFunction r b1), LiftTuple r a1 b, UncurryN a2 (b -> CodeGenFunction r b1)) => + UnwrapArgs a a1 b1 b a2 r where + unwrapArgs f = curryN $ \ x -> uncurryN f =<< liftTuple x + +-- |Lift a function from having @Value@ arguments to having @TValue@ arguments. +toArithFunction :: (CallArgs f g r, UnwrapArgs a a1 b1 b g r) => + Function f -> a +toArithFunction f = unwrapArgs (call f) + +------------------------------------------- + +-- |Define a recursive 'arithFunction', gets passed itself as the first argument. +recursiveFunction :: + (CallArgs a g r0, + UnwrapArgs a11 a1 b1 b g r0, + FunctionArgs a, a2 ~ FunctionCodeGen a, r1 ~ FunctionResult a, + ArithFunction a3 a2, + IsFunction a) => + (a11 -> a3) -> CodeGenModule (Function a) +recursiveFunction af = do + f <- newFunction ExternalLinkage + let f' = toArithFunction f + defineFunction f $ arithFunction (af f') + return f + +------------------------------------------- + +class CallIntrinsic a where + callIntrinsic1' :: String -> Value a -> TValue r a + callIntrinsic2' :: String -> Value a -> Value a -> TValue r a + +instance CallIntrinsic Float where + callIntrinsic1' = callIntrinsicP1 + callIntrinsic2' = callIntrinsicP2 + +instance CallIntrinsic Double where + callIntrinsic1' = callIntrinsicP1 + callIntrinsic2' = callIntrinsicP2 + +{- +I think such a special case for certain systems +would be better handled as in LLVM.Extra.Extension. +(lemming) +-} +macOS :: Bool +#if defined(__MACOS__) +macOS = True +#else +macOS = False +#endif + +instance (PositiveT n, IsPrimitive a, CallIntrinsic a) => CallIntrinsic (Vector n a) where + callIntrinsic1' s x = + if macOS && TypeNum.fromIntegerT (undefined :: n) == (4::Int) && + elem s ["sqrt", "log", "exp", "sin", "cos", "tan"] + then do + op <- externFunction ("v" ++ s ++ "f") + call op x >>= addReadNone + else mapVector (callIntrinsic1' s) x + callIntrinsic2' s = mapVector2 (callIntrinsic2' s) + +callIntrinsic1 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a +callIntrinsic1 s x = do x' <- x; callIntrinsic1' s x' + +callIntrinsic2 :: (CallIntrinsic a) => String -> TValue r a -> TValue r a -> TValue r a +callIntrinsic2 s = binop (callIntrinsic2' s) diff --git a/LLVM/Util/File.hs b/LLVM/Util/File.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/File.hs @@ -0,0 +1,47 @@ +module LLVM.Util.File(writeCodeGenModule, optimizeFunction, optimizeFunctionCG) where +import System.Cmd(system) + +import LLVM.Core +import LLVM.ExecutionEngine + +writeCodeGenModule :: FilePath -> CodeGenModule a -> IO () +writeCodeGenModule name f = do + m <- newModule + _ <- defineModule m f + writeBitcodeToFile name m + +optimize :: FilePath -> IO () +optimize name = do + _rc <- system $ "opt -std-compile-opts " ++ name ++ " -f -o " ++ name + return () + +optimizeFunction :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Function t) +optimizeFunction = fmap snd . optimizeFunction' + +optimizeFunction' :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO (Module, Function t) +optimizeFunction' mdl = do + m <- newModule + mf <- defineModule m mdl + fName <- getValueName mf + + let name = "__tmp__" ++ fName ++ ".bc" + writeBitcodeToFile name m + + optimize name + + m' <- readBitcodeFromFile name + funcs <- getModuleValues m' + +-- removeFile name + + let Just mf' = castModuleValue =<< lookup fName funcs + + return (m', mf') + +optimizeFunctionCG :: (IsType t, Translatable t) => CodeGenModule (Function t) -> IO t +optimizeFunctionCG mdl = do + (m', mf') <- optimizeFunction' mdl + rf <- runEngineAccess $ do + addModule m' + generateFunction mf' + return rf diff --git a/LLVM/Util/Foreign.hs b/LLVM/Util/Foreign.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/Foreign.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- These are replacements for the broken equivalents in Foreign.*. +-- The functions in Foreign.* do not obey the required alignment. +module LLVM.Util.Foreign where + +import Foreign.Ptr(alignPtr, Ptr) +import Foreign.Storable(Storable(poke, sizeOf, alignment)) +import Foreign.Marshal.Alloc(allocaBytes) +import Foreign.Marshal.Array(allocaArray, pokeArray) + +with :: Storable a => a -> (Ptr a -> IO b) -> IO b +with x act = + alloca $ \ p -> do + poke p x + act p + +alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b +alloca act = + allocaBytes (2 * sizeOf (undefined :: a)) $ \ p -> + act $ alignPtr p (alignment (undefined :: a)) + +withArrayLen :: (Storable a) => [a] -> (Int -> Ptr a -> IO b) -> IO b +withArrayLen xs act = + let l = length xs in + allocaArray (l+1) $ \ p -> do + let p' = alignPtr p (alignment (head xs)) + pokeArray p' xs + act l p' + diff --git a/LLVM/Util/Loop.hs b/LLVM/Util/Loop.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/Loop.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module LLVM.Util.Loop(Phi(phis,addPhis), forLoop, mapVector, mapVector2) where +import Types.Data.Num +import LLVM.Core + +class Phi a where + phis :: BasicBlock -> a -> CodeGenFunction r a + addPhis :: BasicBlock -> a -> a -> CodeGenFunction r () + +{- +infixr 1 :* +-- XXX should use HList if it was packaged in a nice way. +data a :* b = a :* b + deriving (Eq, Ord, Show, Read) + +instance (IsFirstClass a, Phi b) => Phi (Value a :* b) where + phis bb (a :* b) = do + a' <- phi [(a, bb)] + b' <- phis bb b + return (a' :* b') + addPhis bb (a :* b) (a' :* b') = do + addPhiInputs a [(a', bb)] + addPhis bb b b' +-} + +instance Phi () where + phis _ _ = return () + addPhis _ _ _ = return () + +instance (IsFirstClass a) => Phi (Value a) where + phis bb a = do + a' <- phi [(a, bb)] + return a' + addPhis bb a a' = do + addPhiInputs a [(a', bb)] + +instance (Phi a, Phi b) => Phi (a, b) where + phis bb (a, b) = do + a' <- phis bb a + b' <- phis bb b + return (a', b') + addPhis bb (a, b) (a', b') = do + addPhis bb a a' + addPhis bb b b' + +instance (Phi a, Phi b, Phi c) => Phi (a, b, c) where + phis bb (a, b, c) = do + a' <- phis bb a + b' <- phis bb b + c' <- phis bb c + return (a', b', c') + addPhis bb (a, b, c) (a', b', c') = do + addPhis bb a a' + addPhis bb b b' + addPhis bb c c' + +-- Loop the index variable from low to high. The state in the loop starts as start, and is modified +-- by incr in each iteration. +forLoop :: forall i a r . (Phi a, Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) => + Value i -> Value i -> a -> (Value i -> a -> CodeGenFunction r a) -> CodeGenFunction r a +forLoop low high start incr = do + top <- getCurrentBasicBlock + loop <- newBasicBlock + body <- newBasicBlock + exit <- newBasicBlock + + br loop + + defineBasicBlock loop + i <- phi [(low, top)] + vars <- phis top start + t <- cmp CmpNE i high + condBr t body exit + + defineBasicBlock body + + vars' <- incr i vars + i' <- add i (valueOf 1 :: Value i) + + body' <- getCurrentBasicBlock + addPhis body' vars vars' + addPhiInputs i [(i', body')] + br loop + defineBasicBlock exit + + return vars + +-------------------------------------- + +mapVector :: forall a b n r . + (PositiveT n, IsPrimitive b) => + (Value a -> CodeGenFunction r (Value b)) -> + Value (Vector n a) -> CodeGenFunction r (Value (Vector n b)) +mapVector f v = + forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do + x <- extractelement v i + y <- f x + insertelement w y i + +mapVector2 :: forall a b c n r . + (PositiveT n, IsPrimitive c) => + (Value a -> Value b -> CodeGenFunction r (Value c)) -> + Value (Vector n a) -> Value (Vector n b) -> CodeGenFunction r (Value (Vector n c)) +mapVector2 f v1 v2 = + forLoop (valueOf 0) (valueOf (fromIntegerT (undefined :: n))) (value undef) $ \ i w -> do + x <- extractelement v1 i + y <- extractelement v2 i + z <- f x y + insertelement w z i diff --git a/LLVM/Util/Memory.hs b/LLVM/Util/Memory.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/Memory.hs @@ -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 diff --git a/LLVM/Util/Optimize.hs b/LLVM/Util/Optimize.hs new file mode 100644 --- /dev/null +++ b/LLVM/Util/Optimize.hs @@ -0,0 +1,130 @@ +{- +LLVM does not export its functions +@createStandardFunctionPasses@ and +@createStandardModulePasses@ via its C interface +and interfacing to C-C++ wrappers is not very portable. +Thus we reimplement these functions +from @opt.cpp@ and @StandardPasses.h@ in Haskell. +However this way we risk inconsistencies +between 'optimizeModule' and the @opt@ shell command. +-} +module LLVM.Util.Optimize(optimizeModule) where + +import LLVM.Core.Util(Module, withModule) +import qualified LLVM.FFI.Core as FFI +import qualified LLVM.FFI.Support as FFI +import LLVM.FFI.Transforms.Scalar +import Control.Exception (bracket) + + +{- | +Result tells whether the module was modified by any of the passes. +-} +optimizeModule :: Int -> Module -> IO Bool +optimizeModule optLevel mdl = + withModule mdl $ \ m -> + {- + Core.Util.createPassManager would provide a finalizer for us, + but I think it is better here to immediately dispose the manager + when we need it no longer. + -} + bracket FFI.createPassManager FFI.disposePassManager $ \ passes -> + +{- +Note on LLVM-2.6 to 2.8 (at least): +As far as I understand, if we do not set target data, +then the optimizer will only perform machine independent optimizations. +If we set target data +(e.g. an empty layout string obtained from a module without 'target data' specification.) +we risk that the optimizer switches to a wrong layout +(e.g. to 64 bit pointers on a 32 bit machine for empty layout string) +and thus generates corrupt code. + +Currently it seems to be safer to disable +machine dependent optimization completely. + +http://llvm.org/bugs/show_bug.cgi?id=6394 + + -- Pass the module target data to the pass manager. + target <- FFI.getDataLayout m >>= createTargetData + addTargetData target passes +-} + + {- + opt.cpp does not use a FunctionPassManager for function optimization, + but a module PassManager. + Thus we do it the same way. + I assume that we would need a FunctionPassManager + only if we wanted to apply individual optimizations to functions. + + fPasses <- FFI.createFunctionPassManager mp + -} + bracket FFI.createPassManager FFI.disposePassManager $ \ fPasses -> do + -- add module target data? + + -- tools/opt/opt.cpp: AddStandardCompilePasses + addVerifierPass passes + addOptimizationPasses passes fPasses optLevel + + {- if we wanted to do so, we could loop through all functions and optimize them. + initializeFunctionPassManager fPasses + runFunctionPassManager fPasses fcn + -} + + functionsModified <- FFI.runPassManager fPasses m + + moduleModified <- FFI.runPassManager passes m + + return $ + toEnum (fromIntegral moduleModified) || + toEnum (fromIntegral functionsModified) + +-- tools/opt/opt.cpp: AddOptimizationPasses +addOptimizationPasses :: FFI.PassManagerRef -> FFI.PassManagerRef -> Int -> IO () +addOptimizationPasses passes fPasses optLevel = do + createStandardFunctionPasses fPasses optLevel + createStandardModulePasses passes optLevel True True (optLevel > 1) True True True + +createStandardFunctionPasses :: FFI.PassManagerRef -> Int -> IO () +createStandardFunctionPasses fPasses optLevel = + FFI.createStandardFunctionPasses fPasses (fromIntegral optLevel) + +-- llvm/Support/StandardPasses.h: createStandardModulePasses +createStandardModulePasses :: FFI.PassManagerRef -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IO () +createStandardModulePasses passes optLevel optSize unitAtATime unrollLoops simplifyLibCalls haveExceptions inliningPass = + FFI.createStandardModulePasses passes (fromIntegral optLevel) (f optSize) + (f unitAtATime) (f unrollLoops) (f simplifyLibCalls) (f haveExceptions) + (f (not inliningPass)) + where f True = 1 + f _ = 0 + + +{- +ToDo: +Function that adds passes according to a list of opt-options. +This would simplify to get consistent behaviour between opt and optimizeModule. + +-adce addAggressiveDCEPass +-deadargelim addDeadArgEliminationPass +-deadtypeelim addDeadTypeEliminationPass +-dse addDeadStoreEliminationPass +-functionattrs addFunctionAttrsPass +-globalopt addGlobalOptimizerPass +-indvars addIndVarSimplifyPass +-instcombine addInstructionCombiningPass +-ipsccp addIPSCCPPass +-jump-threading addJumpThreadingPass +-licm addLICMPass +-loop-deletion addLoopDeletionPass +-loop-rotate addLoopRotatePass +-memcpyopt addMemCpyOptPass +-prune-eh addPruneEHPass +-reassociate addReassociatePass +-scalarrepl addScalarReplAggregatesPass +-sccp addSCCPPass +-simplifycfg addCFGSimplificationPass +-simplify-libcalls addSimplifyLibCallsPass +-strip-dead-prototypes addStripDeadPrototypesPass +-tailcallelim addTailCallEliminationPass +-verify addVerifierPass +-} diff --git a/PROBLEMS.md b/PROBLEMS.md new file mode 100644 --- /dev/null +++ b/PROBLEMS.md @@ -0,0 +1,20 @@ +Known problems +-------------- + +If you have solutions to any of the problems listed below, please let +me know, or better yet, send a patch. Thanks! + + +Can't use LLVM bindings from ghci +--------------------------------- + +When I try to use the LLVM bindings in `ghci`, on Linux, loading the +bindings succeeds, but trying to do anything fails: + + $ ghci + Prelude> :m +LLVM.Core + Prelude LLVM.Core> m <- createModule "foo" + can't load .so/.DLL for: stdc++ (libstdc++.so: cannot open shared + object file: No such file or directory) + +I don't know why this happens, but it looks like a `ghci` bug. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +Haskell LLVM bindings +--------------------- + +This package provides Haskell bindings for the popular +[LLVM](http://llvm.org/) compiler infrastructure project. + + +Compatibility +------------- + +We try to stay up to date with LLVM releases. The current version of +this package is compatible with LLVM 2.9 and 2.8. Please understand +that the package may or may not work against older LLVM releases; we +don't have the time or resources to test across multiple releases. + + +Configuration +------------- + +By default, when you run `cabal install`, the Haskell bindings will be +configured to look for LLVM in `/usr/local`. + +If you have LLVM installed in a different location, e.g. `/usr`, you +can tell the `configure` script where to find it as follows: + + cabal install --configure-option=--with-llvm-prefix=/usr + + +Package status - what to expect +------------------------------- + +This package is still under development. + +The high level bindings are currently incomplete, so there are some +limits on what you can do. Adding new functions is generally easy, +though, so don't be afraid to get your hands dirty. + +The high level interface is mostly safe, but the type system cannot +protect against everything that can go wrong, so take care. And, of +course, there's no way to guarantee anything about the generated code. + + +Staying in touch +---------------- + +There is a low-volume mailing list named +[haskell-llvm@projects.haskellorg](http://projects.haskell.org/cgi-bin/mailman/listinfo/haskell-llvm). +If you use the LLVM bindings, you should think about joining. + +If you want to contribute patches, please clone a copy of the +[git repository](https://github.com/bos/llvm): + + git clone git://github.com/bos/llvm + +Patches are best submitted via the github "pull request" interface. + +To file a bug or a request for an enhancement, please use the +[github issue tracker](https://github.com/bos/llvm/issues). diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/examples/Align.hs b/examples/Align.hs new file mode 100644 --- /dev/null +++ b/examples/Align.hs @@ -0,0 +1,21 @@ +module Align (main) where +import Types.Data.Num(D1, D4) +import Data.Word + +import LLVM.Core +import LLVM.ExecutionEngine + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + + td <- getTargetData + print (littleEndian td, + aBIAlignmentOfType td $ typeRef (undefined :: Word32), + aBIAlignmentOfType td $ typeRef (undefined :: Word64), + aBIAlignmentOfType td $ typeRef (undefined :: Vector D4 Float), + aBIAlignmentOfType td $ typeRef (undefined :: Vector D1 Double), + storeSizeOfType td $ typeRef (undefined :: Vector D4 Float), + intPtrType td + ) diff --git a/examples/Arith.hs b/examples/Arith.hs new file mode 100644 --- /dev/null +++ b/examples/Arith.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Arith where +import Data.Int +import Types.Data.Num(D4) +import LLVM.Core +import LLVM.ExecutionEngine +import LLVM.Util.Arithmetic +import LLVM.Util.Foreign as F +import LLVM.Util.File(writeCodeGenModule) + +import Foreign.Storable +{- +import Foreign.Ptr +import Foreign.Marshal.Utils +import Foreign.Marshal.Alloc as F +-} + +mSomeFn :: forall a . (IsConst a, Floating a, IsFloating a, CallIntrinsic a, + FunctionRet a, CmpRet a + ) => CodeGenModule (Function (a -> IO a)) +mSomeFn = do + foo <- createFunction InternalLinkage $ arithFunction $ \ x y -> exp (sin x) + y + let foo' = toArithFunction foo + createFunction ExternalLinkage $ arithFunction $ \ x -> do + y <- set $ x^3 + sqrt (x^2 - 5 * x + 6) + foo' x x + y + log y + +mFib :: CodeGenModule (Function (Int32 -> IO Int32)) +mFib = recursiveFunction $ \ rfib n -> n %< 2 ? (1, rfib (n-1) + rfib (n-2)) + +type V = Vector D4 Float + +mVFun :: CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) +mVFun = do + fn :: Function (V -> IO V) + <- createFunction ExternalLinkage $ arithFunction $ \ x -> + log x * exp x * x - 16 + + vectorToPtr fn + + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + + let mSomeFn' = mSomeFn + ioSomeFn <- simpleFunction mSomeFn' + let someFn :: Double -> Double + someFn = unsafeRemoveIO ioSomeFn + + writeCodeGenModule "Arith.bc" mSomeFn' + + print (someFn 10) + print (someFn 2) + + writeCodeGenModule "ArithFib.bc" mFib + + fib <- simpleFunction mFib + fib 22 >>= print + +{- + writeCodeGenModule "VArith.bc" mVFun + + ioVFun <- simpleFunction mVFun + let v = toVector (1,2,3,4) + + r <- vectorPtrWrap ioVFun v + print r +-} + +vectorToPtr :: Function (V -> IO V) -> CodeGenModule (Function (Ptr V -> Ptr V -> IO ())) +vectorToPtr f = + createFunction ExternalLinkage $ \ px py -> do + x <- load px + y <- call f x + store y py + ret () + +vectorPtrWrap :: (Ptr V -> Ptr V -> IO ()) -> V -> IO V +vectorPtrWrap f v = + with v $ \ aPtr -> + F.alloca $ \ bPtr -> do + f aPtr bPtr + peek bPtr diff --git a/examples/Array.hs b/examples/Array.hs new file mode 100644 --- /dev/null +++ b/examples/Array.hs @@ -0,0 +1,62 @@ +module Array where +import Data.Word + +import LLVM.Core +--import LLVM.ExecutionEngine +import LLVM.Util.Loop +import LLVM.Util.Optimize + +cg :: CodeGenModule (Function (Double -> IO (Ptr Double))) +cg = do + dotProd <- createFunction InternalLinkage $ \ size aPtr aStride bPtr bStride -> do + r <- forLoop (valueOf 0) size (valueOf 0) $ \ i s -> do + ai <- mul aStride i + bi <- mul bStride i + ap <- getElementPtr aPtr (ai, ()) + bp <- getElementPtr bPtr (bi, ()) + a <- load ap + b <- load bp + ab <- mul a b + add (s :: Value Double) ab + ret r + let _ = dotProd :: Function (Word32 -> Ptr Double -> Word32 -> Ptr Double -> Word32 -> IO Double) + + -- multiply a:[n x m], b:[m x l] + matMul <- createFunction InternalLinkage $ \ n m l aPtr bPtr cPtr -> do + forLoop (valueOf 0) n () $ \ ni () -> do + forLoop (valueOf 0) l () $ \ li () -> do + ni' <- mul ni m + row <- getElementPtr aPtr (ni', ()) + col <- getElementPtr bPtr (li, ()) + x <- call dotProd m row (valueOf 1) col m + j <- add ni' li + p <- getElementPtr cPtr (j, ()) + store x p + return () + ret () + let _ = matMul :: Function (Word32 -> Word32 -> Word32 -> Ptr Double -> Ptr Double -> Ptr Double -> IO ()) + + let fillArray _ [] = return () + fillArray ptr (x:xs) = do store x ptr; ptr' <- getElementPtr ptr (1::Word32,()); fillArray ptr' xs + + test <- createNamedFunction ExternalLinkage "test" $ \ x -> do + a <- arrayMalloc (4 :: Word32) + fillArray a $ map valueOf [1,2,3,4] + b <- arrayMalloc (4 :: Word32) + fillArray b [x,x,x,x] + c <- arrayMalloc (4 :: Word32) + _ <- call matMul (valueOf 2) (valueOf 2) (valueOf 2) a b c + ret c + let _ = test :: Function (Double -> IO (Ptr Double)) + + return test + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + m <- newModule + _f <- defineModule m cg + writeBitcodeToFile "Arr.bc" m + _ <- optimizeModule 3 m + writeBitcodeToFile "Arr-opt.bc" m diff --git a/examples/BrainF.hs b/examples/BrainF.hs new file mode 100644 --- /dev/null +++ b/examples/BrainF.hs @@ -0,0 +1,157 @@ +module BrainF where +-- BrainF compiler example +-- +-- The BrainF language has 8 commands: +-- Command Equivalent C Action +-- ------- ------------ ------ +-- , *h=getchar(); Read a character from stdin, 255 on EOF +-- . putchar(*h); Write a character to stdout +-- - --*h; Decrement tape +-- + ++*h; Increment tape +-- < --h; Move head left +-- > ++h; Move head right +-- [ while(*h) { Start loop +-- ] } End loop +-- +import Control.Monad(when) +import Data.Word +import Data.Int +import System.Environment(getArgs) +import System.Exit(exitFailure) +import qualified System.IO as IO + +import LLVM.Core +import LLVM.Util.File(writeCodeGenModule) +import qualified LLVM.Util.Memory as Memory +import LLVM.ExecutionEngine + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + + aargs <- getArgs + let (args, debug) = + case aargs of + "-":rargs -> (rargs, True) + _ -> (aargs, False) + let text = "+++++++++++++++++++++++++++++++++" ++ -- constant 33 + ">++++" ++ -- next cell, loop counter, constant 4 + "[>++++++++++" ++ -- loop, loop counter, constant 10 + "[" ++ -- loop + "<<.+>>-" ++ -- back to 33, print, increment, forward, decrement loop counter + "]<-" ++ -- back to 4, decrement loop counter + "]" ++ + "++++++++++." + prog <- + case args of + [] -> return text + fileName:[] -> readFile fileName + _ -> + IO.hPutStrLn IO.stderr "too many arguments" >> + exitFailure + + when debug $ + writeCodeGenModule "BrainF.bc" $ brainCompile debug prog 65536 + + bfprog <- simpleFunction $ brainCompile debug prog 65536 + when (prog == text) $ + putStrLn "Should print '!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGH' on the next line:" + bfprog + +brainCompile :: Bool -> String -> Word32 -> CodeGenModule (Function (IO ())) +brainCompile _debug instrs wmemtotal = do + -- LLVM functions + memset <- Memory.memset + getchar <- newNamedFunction ExternalLinkage "getchar" + :: TFunction (IO Int32) + putchar <- newNamedFunction ExternalLinkage "putchar" + :: TFunction (Int32 -> IO Int32) + + -- Generate code, first argument is the list of commands, + -- second argument is a stack of loop contexts, and the + -- third argument is the current register for the head and + -- the current basic block. + -- A loop context is a triple of the phi node, the loop top label, + -- and the loop exit label. + let generate [] [] _ = + return () + generate [] (_:_) _ = error "Missing ]" + generate (']':_) [] _ = error "Missing [" + generate (']':is) ((cphi, loop, exit) : bs) (cur, bb) = do + -- The loop has terminated, add the phi node at the top, + -- branch to the top, and set up the exit label. + addPhiInputs cphi [(cur, bb)] + br loop + defineBasicBlock exit + generate is bs (cphi, exit) + + generate ('[':is) bs curbb = do + -- Start a new loop. + loop <- newBasicBlock -- loop top + body <- newBasicBlock -- body of the loop + exit <- newBasicBlock -- loop exit label + br loop + + defineBasicBlock loop + cur <- phi [curbb] -- will get one more input from the loop terminator. + val <- load cur -- load head byte. + eqz <- cmp CmpEQ val (0::Word8) -- test if it is 0. + condBr eqz exit body -- and branch accordingly. + + defineBasicBlock body + generate is ((cur, loop, exit) : bs) (cur, body) + + generate (i:is) bs (curhead, bb) = do + -- A simple command, with no new basic blocks. + -- Just update which register the head is in. + curhead' <- gen curhead i + generate is bs (curhead', bb) + + gen cur ',' = do + -- Read a character. + char32 <- call getchar + char8 <- trunc char32 + store char8 cur + return cur + gen cur '.' = do + -- Write a character. + char8 <- load cur + char32 <- zext char8 + _ <- call putchar char32 + return cur + gen cur '-' = do + -- Decrement byte at head. + val <- load cur + val' <- sub val (1 :: Word8) + store val' cur + return cur + gen cur '+' = do + -- Increment byte at head. + val <- load cur + val' <- add val (1 :: Word8) + store val' cur + return cur + gen cur '<' = + -- Decrement head. + getElementPtr cur ((-1) :: Word32, ()) + gen cur '>' = + -- Increment head. + getElementPtr cur (1 :: Word32, ()) + gen _ c = error $ "Bad character in program: " ++ show c + + + brainf <- createFunction ExternalLinkage $ do + ptr_arr <- arrayMalloc wmemtotal + _ <- memset ptr_arr (valueOf 0) (valueOf wmemtotal) (valueOf 0) (valueOf False) +-- _ptr_arrmax <- getElementPtr ptr_arr (wmemtotal, ()) + -- Start head in the middle. + curhead <- getElementPtr ptr_arr (wmemtotal `div` 2, ()) + + bb <- getCurrentBasicBlock + generate instrs [] (curhead, bb) + + free ptr_arr + ret () + + return brainf diff --git a/examples/CallConv.hs b/examples/CallConv.hs new file mode 100644 --- /dev/null +++ b/examples/CallConv.hs @@ -0,0 +1,33 @@ +module CallConv where + +import LLVM.Core +import LLVM.FFI.Core (CallingConvention(GHC)) + +import Data.Word (Word32) + + +-- Our module will have these two functions. +data Mod = Mod { + m1 :: Function (Word32 -> IO Word32), + m2 :: Function (Word32 -> Word32 -> IO Word32) + } + +main :: IO () +main = do + m <- newModule + _fns <- defineModule m buildMod + --_ <- optimizeModule 3 m + writeBitcodeToFile "CallConv.bc" m + return () + +buildMod :: CodeGenModule Mod +buildMod = do + mod2 <- createNamedFunction InternalLinkage "plus" $ \ x y -> do + r <- add x y + ret r + setFuncCallConv mod2 GHC + mod1 <- newNamedFunction ExternalLinkage "test" + defineFunction mod1 $ \ arg -> do + r <- callWithConv GHC mod2 arg (valueOf 1) + ret r + return $ Mod mod1 mod2 diff --git a/examples/Convert.hs b/examples/Convert.hs new file mode 100644 --- /dev/null +++ b/examples/Convert.hs @@ -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 + diff --git a/examples/DotProd.hs b/examples/DotProd.hs new file mode 100644 --- /dev/null +++ b/examples/DotProd.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances #-} +module DotProd where +import Data.Word +import Types.Data.Num(D2, D4, D8, fromIntegerT) +import LLVM.Core +import LLVM.ExecutionEngine +import LLVM.Util.Loop +import LLVM.Util.File(writeCodeGenModule) +import LLVM.Util.Foreign + +mDotProd :: forall n a . (PositiveT n, + IsPrimitive a, IsArithmetic a, IsFirstClass a, IsConst a, Num a, + FunctionRet a + ) => + CodeGenModule (Function (Word32 -> Ptr (Vector n a) -> Ptr (Vector n a) -> IO a)) +mDotProd = + createFunction ExternalLinkage $ \ size aPtr bPtr -> do + s <- forLoop (valueOf 0) size (value (zero :: ConstValue (Vector n a))) $ \ i s -> do + + ap <- getElementPtr aPtr (i, ()) -- index into aPtr + bp <- getElementPtr bPtr (i, ()) -- index into bPtr + a <- load ap -- load element from a vector + b <- load bp -- load element from b vector + ab <- mul a b -- multiply them + add s ab -- accumulate sum + + r <- forLoop (valueOf (0::Word32)) (valueOf (fromIntegerT (undefined :: n))) + (valueOf 0) $ \ i r -> do + ri <- extractelement s i + add r ri + ret (r :: Value a) + +type R = Float +type T = Vector D4 R + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + let mDotProd' = mDotProd + writeCodeGenModule "DotProd.bc" mDotProd' + + ioDotProd <- simpleFunction mDotProd' + let dotProd :: [T] -> [T] -> R + dotProd a b = + unsafeRemoveIO $ + withArrayLen a $ \ aLen aPtr -> + withArrayLen b $ \ bLen bPtr -> + ioDotProd (fromIntegral (aLen `min` bLen)) aPtr bPtr + + + let a = [1 .. 8] + b = [4 .. 11] + print $ dotProd (vectorize 0 a) (vectorize 0 b) + print $ sum $ zipWith (*) a b + +class Vectorize n a where + vectorize :: a -> [a] -> [Vector n a] + +{- +instance (IsPrimitive a) => Vectorize D1 a where + vectorize _ [] = [] + vectorize x (x1:xs) = toVector x1 : vectorize x xs +-} + +instance (IsPrimitive a) => Vectorize D2 a where + vectorize _ [] = [] + vectorize x (x1:x2:xs) = toVector (x1, x2) : vectorize x xs + vectorize x xs = vectorize x $ xs ++ [x] + +instance (IsPrimitive a) => Vectorize D4 a where + vectorize _ [] = [] + vectorize x (x1:x2:x3:x4:xs) = toVector (x1, x2, x3, x4) : vectorize x xs + vectorize x xs = vectorize x $ xs ++ [x] + +instance (IsPrimitive a) => Vectorize D8 a where + vectorize _ [] = [] + vectorize x (x1:x2:x3:x4:x5:x6:x7:x8:xs) = toVector (x1, x2, x3, x4, x5, x6, x7, x8) : vectorize x xs + vectorize x xs = vectorize x $ xs ++ [x] diff --git a/examples/Fibonacci.hs b/examples/Fibonacci.hs new file mode 100644 --- /dev/null +++ b/examples/Fibonacci.hs @@ -0,0 +1,106 @@ +module Fibonacci where +import Prelude hiding(and, or) +import System.Environment(getArgs) +import Control.Monad(forM_) +import Data.Word + +import LLVM.Core +import LLVM.Util.Optimize +import LLVM.ExecutionEngine + +-- Our module will have these two functions. +data Mod = Mod { + mfib :: Function (Word32 -> IO Word32), + mplus :: Function (Word32 -> Word32 -> IO Word32) + } + +main :: IO () +main = do + args <- getArgs + let args' = if null args then ["10"] else args + + -- Initialize jitter + initializeNativeTarget + -- Create a module, + m <- newNamedModule "fib" + -- and define its contents. + fns <- defineModule m buildMod + + -- Show the code for the two functions, just for fun. + --dumpValue $ mfib fns + --dumpValue $ mplus fns + -- Write the code to a file for later perusal. + -- Can be disassembled with llvm-dis. + writeBitcodeToFile "Fibonacci.bc" m + + _ <- optimizeModule 3 m + writeBitcodeToFile "Fibonacci-opt.bc" m + + -- Generate code for mfib, and then throw away the IO in the type. + -- The result is an ordinary Haskell function. + iofib <- runEngineAccess $ do + addModule m + generateFunction $ mfib fns + let fib = unsafeRemoveIO iofib + + -- Run fib for the arguments. + forM_ args' $ \num -> do + putStrLn $ "fib " ++ num ++ " = " ++ show (fib (read num)) + return () + +buildMod :: CodeGenModule Mod +buildMod = do + -- Add two numbers in a cumbersome way. + plus <- createFunction InternalLinkage $ \ x y -> do + -- Create three additional basic blocks, need to be created before being referred to. + l1 <- newBasicBlock + l2 <- newBasicBlock + l3 <- newBasicBlock + + -- Test if x is even/odd. + a <- and x (1 :: Word32) + c <- cmp CmpEQ a (0 :: Word32) + condBr c l1 l2 + + -- Do x+y if even. + defineBasicBlock l1 + r1 <- add x y + br l3 + + -- Do y+x if odd. + defineBasicBlock l2 + r2 <- add y x + br l3 + + defineBasicBlock l3 + -- Join the two execution paths with a phi instruction. + r <- phi [(r1, l1), (r2, l2)] + ret r + + -- The usual doubly recursive Fibonacci. + -- Use new&define so the name fib is defined in the body for recursive calls. + fib <- newNamedFunction ExternalLinkage "fib" + defineFunction fib $ \ arg -> do + -- Create the two basic blocks. + recurse <- newBasicBlock + exit <- newBasicBlock + + -- Test if arg > 2 + test <- cmp CmpGT arg (2::Word32) + condBr test recurse exit + + -- Just return 1 if not > 2 + defineBasicBlock exit + ret (valueOf (1::Word32)) + + -- Recurse if > 2, using the cumbersome plus to add the results. + defineBasicBlock recurse + x1 <- sub arg (1::Word32) + fibx1 <- call fib x1 + x2 <- sub arg (2::Word32) + fibx2 <- call fib x2 + r <- call plus fibx1 fibx2 + ret r + + -- Return the two functions. + return $ Mod fib plus diff --git a/examples/HelloJIT.hs b/examples/HelloJIT.hs new file mode 100644 --- /dev/null +++ b/examples/HelloJIT.hs @@ -0,0 +1,24 @@ +module HelloJIT (main) where + +import Data.Word + +import LLVM.Core +import LLVM.ExecutionEngine + +bldGreet :: CodeGenModule (Function (IO ())) +bldGreet = withStringNul "Hello, JIT!" (\greetz -> do + puts <- newNamedFunction ExternalLinkage "puts" :: TFunction (Ptr Word8 -> IO Word32) + func <- createFunction ExternalLinkage $ do + tmp <- getElementPtr0 greetz (0::Word32, ()) + _ <- call puts tmp :: CodeGenFunction r (Value Word32) + ret () + return func) + +main :: IO () +main = do + initializeNativeTarget + greet <- simpleFunction bldGreet + greet + greet + greet + return () diff --git a/examples/List.hs b/examples/List.hs new file mode 100644 --- /dev/null +++ b/examples/List.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} +module List(main) where + +import LLVM.Util.Loop (Phi, phis, addPhis, ) +import LLVM.ExecutionEngine (simpleFunction, ) +import LLVM.Core +import qualified System.IO as IO + +import Data.Word (Word32, ) +import Data.Int (Int32, ) +import Foreign.Marshal.Array (allocaArray, ) +import qualified Foreign.Storable as St + +import Foreign.StablePtr (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr, ) +import Foreign.Ptr (FunPtr, ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, ) + + +{- +I had to export Phi's methods in llvm-0.6.8 +in order to be able to implement this function. +-} +arrayLoop :: + (Phi a, IsType b, + Num i, IsConst i, IsInteger i, IsFirstClass i, CmpRet i, CmpResult i ~ Bool) => + Value i -> Value (Ptr b) -> a -> + (Value (Ptr b) -> a -> CodeGenFunction r a) -> + CodeGenFunction r a +arrayLoop len ptr start loopBody = do + top <- getCurrentBasicBlock + loop <- newBasicBlock + body <- newBasicBlock + exit <- newBasicBlock + + br loop + + defineBasicBlock loop + i <- phi [(len, top)] + p <- phi [(ptr, top)] + vars <- phis top start + t <- cmp CmpNE i (valueOf 0 `asTypeOf` len) + condBr t body exit + + defineBasicBlock body + + vars' <- loopBody p vars + i' <- sub i (valueOf 1 `asTypeOf` len) + p' <- getElementPtr p (valueOf 1 :: Value Word32, ()) + + body' <- getCurrentBasicBlock + addPhis body' vars vars' + addPhiInputs i [(i', body')] + addPhiInputs p [(p', body')] + br loop + + defineBasicBlock exit + return vars + + +mList :: + CodeGenModule (Function + (StablePtr (IORef [Word32]) -> Word32 -> Ptr Word32 -> IO Int32)) +mList = + createFunction ExternalLinkage $ \ ref size ptr -> do + next <- staticFunction nelem + let _ = next :: Function (StablePtr (IORef [Word32]) -> IO Word32) + s <- arrayLoop size ptr (valueOf 0) $ \ ptri y -> do + flip store ptri =<< call next ref + return y + ret (s :: Value Int32) + +renderList :: IO () +renderList = do + m <- newModule + _f <- defineModule m mList + writeBitcodeToFile "List.bc" m + + fill <- simpleFunction mList + stable <- newStablePtr =<< newIORef [3,5..] + IO.withFile "listcontent.u32" IO.WriteMode $ \h -> + let len = 100 + in allocaArray len $ \ ptr -> + fill stable (fromIntegral len) ptr >> + IO.hPutBuf h ptr (len * St.sizeOf(undefined::Int32)) + freeStablePtr stable + + +foreign import ccall "&nextListElement" + nelem :: FunPtr (StablePtr (IORef [Word32]) -> IO Word32) + +foreign export ccall + nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 + +nextListElement :: StablePtr (IORef [Word32]) -> IO Word32 +nextListElement stable = + do ioRef <- deRefStablePtr stable + xt <- readIORef ioRef + case xt of + [] -> return 0 + (x:xs) -> writeIORef ioRef xs >> return x + + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + renderList diff --git a/examples/Struct.hs b/examples/Struct.hs new file mode 100644 --- /dev/null +++ b/examples/Struct.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeOperators, ScopedTypeVariables #-} +module Struct (main) where + +import Data.Word +import Types.Data.Num(d0, d1, d2, D10) + +import LLVM.Core +import LLVM.Util.File +import LLVM.ExecutionEngine + +foreign import ccall structCheck :: Word32 -> Ptr S -> Int + +-- Watch out for double! Alignment differs between platforms. +-- struct S { uint32 x0; float x1; uint32 x2[10] }; +type S = Struct (Word32 :& Float :& Array D10 Word32 :& ()) + +-- S *s = malloc(sizeof *s); s->x0 = a; s->x1 = 1.2; s->x2[5] = a+1; return s; +mStruct :: CodeGenModule (Function (Word32 -> IO (Ptr S))) +mStruct = do + createFunction ExternalLinkage $ \ x -> do + p :: Value (Ptr S) + <- malloc + p0 <- getElementPtr0 p (d0 & ()) + store x (p0 :: Value (Ptr Word32)) + p1 <- getElementPtr0 p (d1 & ()) + store (valueOf 1.5) p1 + x' <- add x (1 :: Word32) + p2 <- getElementPtr0 p (d2 & (5::Word32) & ()) + store x' p2 + ret p + +main :: IO () +main = do + initializeNativeTarget + writeCodeGenModule "Struct.bc" mStruct + struct <- simpleFunction mStruct + let a = 10 + p <- struct a + putStrLn $ if structCheck a p /= 0 then "OK" else "failed" + return () diff --git a/examples/Varargs.hs b/examples/Varargs.hs new file mode 100644 --- /dev/null +++ b/examples/Varargs.hs @@ -0,0 +1,37 @@ +module Varargs (main) where + +import Data.Word + +import LLVM.Core +import LLVM.ExecutionEngine + +bldVarargs :: CodeGenModule (Function (Word32 -> IO ())) +bldVarargs = + withStringNul "Hello\n" (\fmt1 -> + withStringNul "A number %d\n" (\fmt2 -> + withStringNul "Two numbers %d %d\n" (\fmt3 -> do + printf <- newNamedFunction ExternalLinkage "printf" :: TFunction (Ptr Word8 -> VarArgs Word32) + func <- createFunction ExternalLinkage $ \ x -> do + + tmp1 <- getElementPtr0 fmt1 (0::Word32, ()) + let p1 = castVarArgs printf :: Function (Ptr Word8 -> IO Word32) + _ <- call p1 tmp1 + + tmp2 <- getElementPtr0 fmt2 (0::Word32, ()) + let p2 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> IO Word32) + _ <- call p2 tmp2 x + + tmp3 <- getElementPtr0 fmt3 (0::Word32, ()) + let p3 = castVarArgs printf :: Function (Ptr Word8 -> Word32 -> Word32 -> IO Word32) + _ <- call p3 tmp3 x x + + ret () + return func + ))) + +main :: IO () +main = do + initializeNativeTarget + varargs <- simpleFunction bldVarargs + varargs 42 + return () diff --git a/examples/Vector.hs b/examples/Vector.hs new file mode 100644 --- /dev/null +++ b/examples/Vector.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE TypeOperators #-} +module Vector where + +import Convert + +import LLVM.Core +import LLVM.ExecutionEngine +import LLVM.Util.Optimize (optimizeModule, ) +import LLVM.Util.Loop (forLoop, ) + +import Control.Monad (liftM2, ) +import Types.Data.Num (D16, fromIntegerT, ) +import Data.Word (Word32, ) + +-- Type of vector elements. +type T = Float + +-- Number of vector elements. +type N = D16 + +cgvec :: CodeGenModule (Function (T -> IO T)) +cgvec = do + -- A global variable that vectest messes with. + acc <- createNamedGlobal False ExternalLinkage "acc" (constOf (0 :: T)) + + -- Return the global variable. + retAcc <- createNamedFunction ExternalLinkage "retacc" $ do + vacc <- load acc + ret vacc + let _ = retAcc :: Function (IO T) -- Force the type of retAcc. + + -- A function that tests vector opreations. + f <- createNamedFunction ExternalLinkage "vectest" $ \ x -> do + + let v = value (zero :: ConstValue (Vector N T)) + n = fromIntegerT (undefined :: N) :: Word32 + + -- Fill the vector with x, x+1, x+2, ... + (_, v1) <- forLoop (valueOf 0) (valueOf n) (x, v) $ \ i (x1, v1) -> do + x1' <- add x1 (1::T) + v1' <- insertelement v1 x1 i + return (x1', v1') + + -- Elementwise cubing of the vector. + vsq <- mul v1 v1 + vcb <- mul vsq v1 + + -- Sum the elements of the vector. + s <- forLoop (valueOf 0) (valueOf n) (valueOf 0) $ \ i s -> do + y <- extractelement vcb i + s' <- add s (y :: Value T) + return s' + + -- Update the global variable. + vacc <- load acc + vacc' <- add vacc s + store vacc' acc + + ret (s :: Value T) + +-- liftIO $ dumpValue f + return f + +main :: IO () +main = do + -- Initialize jitter + initializeNativeTarget + -- First run standard code. + m <- newModule + iovec <- defineModule m cgvec + + fptr <- runEngineAccess $ do addModule m; getPointerToFunction iovec + let fvec = convert fptr + + fvec 10 >>= print + + vec <- runEngineAccess $ do addModule m; generateFunction iovec + + vec 10 >>= print + + -- And then optimize and run. + _ <- optimizeModule 1 m + + funcs <- getModuleValues m + print $ map fst funcs + + let iovec' :: Function (T -> IO T) + Just iovec' = castModuleValue =<< lookup "vectest" funcs + ioretacc' :: Function (IO T) + Just ioretacc' = castModuleValue =<< lookup "retacc" funcs + + (vec', retacc') <- runEngineAccess $ do + addModule m + liftM2 (,) (generateFunction iovec') (generateFunction ioretacc') + + dumpValue iovec' + + vec' 10 >>= print + vec' 0 >>= print + retacc' >>= print diff --git a/examples/mainfib.c b/examples/mainfib.c new file mode 100644 --- /dev/null +++ b/examples/mainfib.c @@ -0,0 +1,12 @@ +#include +#include + +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); +} diff --git a/examples/structCheck.c b/examples/structCheck.c new file mode 100644 --- /dev/null +++ b/examples/structCheck.c @@ -0,0 +1,9 @@ +#include + +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; +} diff --git a/llvm-tf.cabal b/llvm-tf.cabal new file mode 100644 --- /dev/null +++ b/llvm-tf.cabal @@ -0,0 +1,95 @@ +name: llvm-tf +version: 3.0.0.0 +license: BSD3 +license-file: LICENSE +synopsis: Bindings to the LLVM compiler toolkit using type families. +description: + High-level bindings to the LLVM compiler toolkit + using type families instead of functional dependencies. + . + * New in 3.0.0.0: + The low-level bindings have been split into the llvm-base package. + . + We use the same module names as the @llvm@ package, + which makes it harder to work with both packages from GHCi. + You may use the @-hide-package@ option. + We may change the module names later. + . + A note on versioning: + The first two version numbers match the version of LLVM. + In order to be able to improve the Haskell API for the same version of LLVM, + I use the first three numbers of the Cabal package version + as the major version in the sense of the Package Versioning Policy PVP. + That is, a bump from 3.0.0 to 3.0.1 may contain substantial API changes, + a bump from 3.0.0.0 to 3.0.0.1 may contain API extensions, + and a bump from 3.0.0.0.0 to 3.0.0.0.1 may contain API-preserving bugfixes. +author: Henning Thieleman, Bryan O'Sullivan, Lennart Augustsson +maintainer: Henning Thieleman +stability: experimental +category: Compilers/Interpreters, Code Generation +tested-with: GHC == 7.4.2 +cabal-version: >= 1.10 +build-type: Simple + +extra-source-files: + *.md + examples/*.c + examples/*.hs + tests/*.hs + tests/Makefile + +flag developer + description: operate in developer mode + default: False + +library + default-language: Haskell98 + build-depends: + base >= 3 && < 5, + bytestring >= 0.9, + directory, + llvm-base == 3.0.*, + mtl, + process, + tfp >= 0.7 && < 0.8, + containers + + ghc-options: -Wall + + if flag(developer) + ghc-options: -Werror + + if os(darwin) + ld-options: -w + frameworks: vecLib + cpp-options: -D__MACOS__ + + exposed-modules: + LLVM.Core + LLVM.ExecutionEngine + LLVM.Util.Arithmetic + LLVM.Util.File + LLVM.Util.Foreign + LLVM.Util.Loop + LLVM.Util.Memory + LLVM.Util.Optimize + + other-modules: + LLVM.Core.CodeGen + LLVM.Core.CodeGenMonad + LLVM.Core.Data + LLVM.Core.Instructions + LLVM.Core.Type + LLVM.Core.Util + LLVM.Core.Vector + LLVM.ExecutionEngine.Engine + LLVM.ExecutionEngine.Target + +source-repository head + type: darcs + location: http://code.haskell.org/~thielema/llvm-tf/ + +source-repository this + tag: 3.0.0.0 + type: darcs + location: http://code.haskell.org/~thielema/llvm-tf/ diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,16 @@ +ghc := ghc +ghcflags := -Wall -Werror +tests := TestType TestValue + +all: $(tests:%=%.out) + +%.out: %.test + ./$< > $@ 2>&1; s=$$?; cat $@; \ + if [ $$s != 0 ]; then mv $@ $(basename $@).err; exit 1; fi + +.PRECIOUS: %.test +%.test: %.hs + $(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $< + +clean: + -rm -f *.o *.hi $(tests:%=%.test) $(tests:%=%.out) diff --git a/tests/TestValue.hs b/tests/TestValue.hs new file mode 100644 --- /dev/null +++ b/tests/TestValue.hs @@ -0,0 +1,69 @@ +module TestValue (main) where + +import qualified LLVM.Core as Core +import qualified LLVM.Core.Type as T +import qualified LLVM.Core.Value as V + +testArguments :: (T.DynamicType r, T.Params p, V.Params p v, V.Value v) + => T.Module -> String -> IO (V.Function r p) +testArguments m name = do + func <- Core.addFunction m name (T.function undefined undefined) + V.dumpValue func + let arg = V.params func + V.dumpValue arg + return func + +voidArguments :: T.Module -> IO () +voidArguments m = do + func <- Core.addFunction m "void" (T.function (undefined :: T.Void) ()) + V.dumpValue func + return () + +type F a = V.Function a a +type P a = V.Function (T.Pointer a) (T.Pointer a) +type V a = V.Function (T.Vector a) (T.Vector a) + +arguments :: T.Module -> IO () +arguments m = do + voidArguments m + + testArguments m "int1" :: IO (F T.Int1) + testArguments m "int8" :: IO (F T.Int8) + testArguments m "int16" :: IO (F T.Int16) + testArguments m "int32" :: IO (F T.Int32) + testArguments m "int64" :: IO (F T.Int64) + testArguments m "float" :: IO (F T.Float) + testArguments m "double" :: IO (F T.Double) + testArguments m "float128" :: IO (F T.Float128) + testArguments m "x86Float80" :: IO (F T.X86Float80) + testArguments m "ppcFloat128" :: IO (F T.PPCFloat128) + + testArguments m "ptrInt1" :: IO (P T.Int1) + testArguments m "ptrInt8" :: IO (P T.Int8) + testArguments m "ptrInt16" :: IO (P T.Int16) + testArguments m "ptrInt32" :: IO (P T.Int32) + testArguments m "ptrInt64" :: IO (P T.Int64) + testArguments m "ptrFloat" :: IO (P T.Float) + testArguments m "ptrDouble" :: IO (P T.Double) + testArguments m "ptrFloat128" :: IO (P T.Float128) + testArguments m "ptrX86Float80" :: IO (P T.X86Float80) + testArguments m "ptrPpcFloat128" :: IO (P T.PPCFloat128) + + testArguments m "vecInt1" :: IO (V T.Int1) + testArguments m "vecInt8" :: IO (V T.Int8) + testArguments m "vecInt16" :: IO (V T.Int16) + testArguments m "vecInt32" :: IO (V T.Int32) + testArguments m "vecInt64" :: IO (V T.Int64) + testArguments m "vecFloat" :: IO (V T.Float) + testArguments m "vecDouble" :: IO (V T.Double) + testArguments m "vecFloat128" :: IO (V T.Float128) + testArguments m "vecX86Float80" :: IO (V T.X86Float80) + testArguments m "vecPpcFloat128" :: IO (V T.PPCFloat128) + + return () + +main :: IO () +main = do + m <- Core.createModule "m" + arguments m + return ()