module LLVM.Core.CodeGen(
newModule, newNamedModule, defineModule, createModule,
getModuleValues, ModuleValue, castModuleValue,
Linkage(..),
Visibility(..),
Function, newFunction, newNamedFunction, defineFunction, createFunction, createNamedFunction, setFuncCallConv,
addAttributes,
FFI.Attribute(..),
externFunction, staticFunction,
FunctionArgs, FunctionRet,
TFunction,
Global, newGlobal, newNamedGlobal, defineGlobal, createGlobal, createNamedGlobal, TGlobal,
Value(..), ConstValue(..),
IsConst(..), valueOf, value,
zero, allOnes, undef,
createString, createStringNul,
withString, withStringNul,
constVector, constArray, constStruct, constPackedStruct,
BasicBlock(..), newBasicBlock, newNamedBasicBlock, defineBasicBlock, createBasicBlock, getCurrentBasicBlock,
fromLabel, toLabel,
withCurrentBuilder
) where
import Data.Typeable
import Control.Monad(liftM, when)
import Data.Int
import Data.Word
import Foreign.StablePtr (StablePtr, castStablePtrToPtr)
import Foreign.Ptr(minusPtr, nullPtr, FunPtr, castFunPtrToPtr)
import Foreign.Storable(sizeOf)
import Data.TypeLevel hiding (Bool, Eq, (+), (==))
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
newModule :: IO U.Module
newModule = newNamedModule "_module"
newNamedModule :: String
-> IO U.Module
newNamedModule = U.createModule
defineModule :: U.Module
-> CodeGenModule a
-> IO a
defineModule = runCodeGenModule
createModule :: CodeGenModule a
-> 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)
class IsConst a where
constOf :: a -> ConstValue a
instance IsConst Bool where constOf = constEnum (typeRef True)
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
constOfPtr :: (IsType a) =>
a -> Ptr b -> ConstValue a
constOfPtr proto p =
let ip = p `minusPtr` nullPtr
inttoptrC (ConstValue v) = ConstValue $ FFI.constIntToPtr v (typeRef proto)
in if sizeOf p == 4 then
inttoptrC $ constOf (fromIntegral ip :: Word32)
else if sizeOf p == 8 then
inttoptrC $ constOf (fromIntegral ip :: Word64)
else
error "constOf Ptr: pointer size not 4 or 8"
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, Pos n) => IsConst (Vector n a) where
constOf (Vector xs) = constVector (map constOf xs)
instance (IsConst a, IsSized a s, Nat 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)
type FunctionRef = FFI.ValueRef
type Function a = Value (Ptr a)
newNamedFunction :: forall a . (IsFunction a)
=> Linkage
-> String
-> CodeGenModule (Function a)
newNamedFunction linkage name = do
modul <- getModule
let typ = typeRef (undefined :: a)
liftIO $ liftM Value $ U.addFunction modul linkage name typ
newFunction :: forall a . (IsFunction a)
=> Linkage
-> CodeGenModule (Function a)
newFunction linkage = genMSym "fun" >>= newNamedFunction linkage
defineFunction :: forall f g r . (FunctionArgs f g (CodeGenFunction r ()))
=> Function f
-> g
-> CodeGenModule ()
defineFunction (Value fn) body = do
bld <- liftIO $ U.createBuilder
let body' = do
l <- newBasicBlock
defineBasicBlock l
applyArgs fn body :: CodeGenFunction r ()
runCodeGenFunction bld fn body'
return ()
createFunction :: (IsFunction f, FunctionArgs f g (CodeGenFunction r ()))
=> Linkage
-> g
-> CodeGenModule (Function f)
createFunction linkage body = do
f <- newFunction linkage
defineFunction f body
return f
createNamedFunction :: (IsFunction f, FunctionArgs f g (CodeGenFunction r ()))
=> Linkage
-> String
-> g
-> CodeGenModule (Function f)
createNamedFunction linkage name body = do
f <- newNamedFunction linkage name
defineFunction f body
return f
setFuncCallConv :: Function a
-> FFI.CallingConvention
-> CodeGenModule ()
setFuncCallConv (Value f) cc = do
liftIO $ FFI.setFunctionCallConv f (FFI.fromCallingConvention cc)
return ()
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)
class FunctionArgs f g r | f -> g r, g r -> f where
apArgs :: Int -> FunctionRef -> g -> r
applyArgs :: (FunctionArgs f g r) => FunctionRef -> g -> r
applyArgs = apArgs 0
instance (FunctionArgs b b' r) => FunctionArgs (a -> b) (Value a -> b') r where
apArgs n f g = apArgs (n+1) f (g $ Value $ U.getParam f n)
type FA a = CodeGenFunction a ()
instance FunctionArgs (IO Float) (FA Float) (FA Float) where apArgs _ _ g = g
instance FunctionArgs (IO Double) (FA Double) (FA Double) where apArgs _ _ g = g
instance FunctionArgs (IO FP128) (FA FP128) (FA FP128) where apArgs _ _ g = g
instance (Pos n) =>
FunctionArgs (IO (IntN n)) (FA (IntN n)) (FA (IntN n)) where apArgs _ _ g = g
instance (Pos n) =>
FunctionArgs (IO (WordN n)) (FA (WordN n)) (FA (WordN n)) where apArgs _ _ g = g
instance FunctionArgs (IO Bool) (FA Bool) (FA Bool) where apArgs _ _ g = g
instance FunctionArgs (IO Int8) (FA Int8) (FA Int8) where apArgs _ _ g = g
instance FunctionArgs (IO Int16) (FA Int16) (FA Int16) where apArgs _ _ g = g
instance FunctionArgs (IO Int32) (FA Int32) (FA Int32) where apArgs _ _ g = g
instance FunctionArgs (IO Int64) (FA Int64) (FA Int64) where apArgs _ _ g = g
instance FunctionArgs (IO Word8) (FA Word8) (FA Word8) where apArgs _ _ g = g
instance FunctionArgs (IO Word16) (FA Word16) (FA Word16) where apArgs _ _ g = g
instance FunctionArgs (IO Word32) (FA Word32) (FA Word32) where apArgs _ _ g = g
instance FunctionArgs (IO Word64) (FA Word64) (FA Word64) where apArgs _ _ g = g
instance FunctionArgs (IO ()) (FA ()) (FA ()) where apArgs _ _ g = g
instance (Pos n, IsPrimitive a) =>
FunctionArgs (IO (Vector n a)) (FA (Vector n a)) (FA (Vector n a)) where apArgs _ _ g = g
instance (IsType a) =>
FunctionArgs (IO (Ptr a)) (FA (Ptr a)) (FA (Ptr a)) where apArgs _ _ g = g
instance FunctionArgs (IO (StablePtr a)) (FA (StablePtr a)) (FA (StablePtr a)) where apArgs _ _ g = g
class (FunctionArgs (IO a) (CodeGenFunction a ()) (CodeGenFunction a ())) => FunctionRet a
instance (FunctionArgs (IO a) (CodeGenFunction a ()) (CodeGenFunction a ())) => FunctionRet a
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)
externFunction :: forall a r . (IsFunction a) => String -> CodeGenFunction r (Function a)
externFunction name = do
es <- getExterns
case lookup name es of
Just f -> return $ Value f
Nothing -> do
let linkage = ExternalLinkage
modul <- getFunctionModule
let typ = typeRef (undefined :: a)
f <- liftIO $ U.addFunction modul linkage name typ
putExterns ((name, f) : es)
return $ Value f
staticFunction :: (IsFunction f) => FunPtr f -> CodeGenFunction r (Function f)
staticFunction func = do
modul <- getFunctionModule
let typ :: IsType a => FunPtr a -> a -> FFI.TypeRef
typ _ x = typeRef x
val <- liftIO $ U.addFunction modul ExternalLinkage
"" (typ func undefined)
addGlobalMapping val (castFunPtrToPtr func)
return $ Value val
withCurrentBuilder :: (FFI.BuilderRef -> IO a) -> CodeGenFunction r a
withCurrentBuilder body = do
bld <- getBuilder
liftIO $ U.withBuilder bld body
type Global a = Value (Ptr a)
newNamedGlobal :: forall a . (IsType a)
=> Bool
-> Linkage
-> String
-> 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
newGlobal :: forall a . (IsType a) => Bool -> Linkage -> TGlobal a
newGlobal isConst linkage = genMSym "glb" >>= newNamedGlobal isConst linkage
defineGlobal :: Global a -> ConstValue a -> CodeGenModule ()
defineGlobal (Value g) (ConstValue v) =
liftIO $ FFI.setInitializer g v
createGlobal :: (IsType a) => Bool -> Linkage -> ConstValue a -> TGlobal a
createGlobal isConst linkage con = do
g <- newGlobal isConst linkage
defineGlobal g con
return g
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)
createString :: String -> TGlobal (Array n Word8)
createString s = string (length s) (U.constString s)
createStringNul :: String -> TGlobal (Array n Word8)
createStringNul s = string (length s + 1) (U.constStringNul s)
withString ::
String ->
(forall n. (Nat n) => Global (Array n Word8) -> CodeGenModule a) ->
CodeGenModule a
withString s act =
let n = length s
in reifyIntegral n (\tn ->
do arr <- string n (U.constString s)
act (fixArraySize tn arr))
withStringNul ::
String ->
(forall n. (Nat n) => Global (Array n Word8) -> CodeGenModule a) ->
CodeGenModule a
withStringNul s act =
let n = length s + 1
in reifyIntegral 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
constVector :: forall a n . (Pos n) => [ConstValue a] -> ConstValue (Vector n a)
constVector xs =
ConstValue $ U.constVector (toNum (undefined :: n)) [ v | ConstValue v <- xs ]
constArray :: forall a n s . (IsSized a s, Nat n) => [ConstValue a] -> ConstValue (Array n a)
constArray xs =
ConstValue $ U.constArray (typeRef (undefined :: a)) (toNum (undefined :: n)) [ v | ConstValue v <- xs ]
constStruct :: (IsConstStruct c a) => c -> ConstValue (Struct a)
constStruct struct =
ConstValue $ U.constStruct (constValueFieldsOf struct) False
constPackedStruct :: (IsConstStruct c a) => c -> ConstValue (PackedStruct a)
constPackedStruct struct =
ConstValue $ U.constStruct (constValueFieldsOf struct) True
class IsConstStruct c a | a -> c, c -> a where
constValueFieldsOf :: c -> [FFI.ValueRef]
instance (IsConst a, IsConstStruct cs as) => IsConstStruct (ConstValue a, cs) (a, as) where
constValueFieldsOf (a, as) = unConstValue a : constValueFieldsOf as
instance IsConstStruct () () where
constValueFieldsOf _ = []