Target.hs

{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveDataTypeable #-}
module LLVM.ExecutionEngine.Target(TargetData(..), getTargetData, targetDataFromString, withIntPtrType) where

import qualified LLVM.ExecutionEngine.Engine as EE
import LLVM.Core.Data (WordN)

import qualified LLVM.FFI.Core as FFI
import qualified LLVM.FFI.Target as FFI

import qualified Type.Data.Num.Decimal.Number as Dec
import Type.Base.Proxy (Proxy)

import Foreign.ForeignPtr
         (ForeignPtr, newForeignPtr, withForeignPtr, touchForeignPtr)
import Foreign.C.String (withCString)

import Control.Monad (liftM2)
import Control.Applicative ((<$>))
import Data.Typeable (Typeable)
import Data.Maybe (fromMaybe)
import System.IO.Unsafe (unsafePerformIO)


type Type = FFI.TypeRef

data TargetData = TargetData {
    abiAlignmentOfType         :: Type -> Int,
    abiSizeOfType              :: Type -> Int,
    littleEndian               :: Bool,
    callFrameAlignmentOfType   :: Type -> Int,
--  elementAtOffset            :: Type -> Word64 -> Int,
    intPtrType                 :: Type,
    offsetOfElement            :: Type -> Int -> Int,
    pointerSize                :: Int,
--  preferredAlignmentOfGlobal :: Value a -> Int,
    preferredAlignmentOfType   :: Type -> Int,
    sizeOfTypeInBits           :: Type -> Int,
    storeSizeOfType            :: Type -> Int
    }
    deriving (Typeable)

withIntPtrType :: (forall n . (Dec.Positive n) => WordN n -> a) -> a
withIntPtrType f =
    fromMaybe (error "withIntPtrType: pointer size must be non-negative") $
        Dec.reifyPositive (fromIntegral sz) (\ n -> f (g n))
  where g :: Proxy n -> WordN n
        g _ = error "withIntPtrType: argument used"
        sz = pointerSize $ unsafePerformIO getTargetData


unsafeIO :: ForeignPtr a -> IO b -> b
unsafeIO fptr act =
    unsafePerformIO $ do x <- act; touchForeignPtr fptr; return x

unsafeIntIO :: (Integral i, Num j) => ForeignPtr a -> IO i -> j
unsafeIntIO fptr = fromIntegral . unsafeIO fptr

-- Normally the TargetDataRef never changes, so the operation
-- are really pure functions.
makeTargetData :: ForeignPtr a -> FFI.TargetDataRef -> TargetData
makeTargetData fptr r = TargetData {
    abiAlignmentOfType       = unsafeIntIO fptr . FFI.abiAlignmentOfType r,
    abiSizeOfType            = unsafeIntIO fptr . FFI.abiSizeOfType r,
    littleEndian             = unsafeIO fptr (FFI.byteOrder r) /= FFI.bigEndian,
    callFrameAlignmentOfType = unsafeIntIO fptr . FFI.callFrameAlignmentOfType r,
    intPtrType               = unsafeIO fptr $ FFI.intPtrType r,
    offsetOfElement          = \ty k ->
        unsafeIntIO fptr $ FFI.offsetOfElement r ty (fromIntegral k),
    pointerSize              = unsafeIntIO fptr $ FFI.pointerSize r,
    preferredAlignmentOfType = unsafeIntIO fptr . FFI.preferredAlignmentOfType r,
    sizeOfTypeInBits         = unsafeIntIO fptr . FFI.sizeOfTypeInBits r,
    storeSizeOfType          = unsafeIntIO fptr . FFI.storeSizeOfType r
    }

-- Gets the target data for the JIT target.
getTargetData :: IO TargetData
getTargetData =
    EE.runEngineAccess $
    liftM2 makeTargetData
        (EE.fromEngine <$> EE.getEngine)
        EE.getExecutionEngineTargetData

createTargetData :: String -> IO (ForeignPtr FFI.TargetData)
createTargetData s =
    newForeignPtr FFI.ptrDisposeTargetData =<<
    withCString s FFI.createTargetData

targetDataFromString :: String -> TargetData
targetDataFromString s = unsafePerformIO $ do
    td <- createTargetData s
    withForeignPtr td $ return . makeTargetData td