packages feed

x86-64bit 0.3.1 → 0.4

raw patch · 9 files changed

+104/−68 lines, 9 filesdep +deepseq

Dependencies added: deepseq

Files

CHANGELOG.md view
@@ -1,3 +1,10 @@+# Version 0.4
+
+-   rewrite FFI
+-   support calling labels
+-   speed up long code alignments
+-   bugfix: auto size calculation fix
+
 # Version 0.3.1
 
 -   use multi-byte nop operations for padding
CodeGen/X86.hs view
@@ -135,7 +135,6 @@     , leaData
     , traceReg
     -- * Compilation
-    , Callable
     , compile
     , preBuild
     -- * Calling convention
@@ -143,9 +142,10 @@     , arg1, arg2, arg3, arg4
     , result
     -- * Calling C and Haskell from Assembly
+    , Callable (..)
+    , CallableHs (..)
     , callFun
     , printf
-    , CallableHs
     , hsPtr
     , CString (..)
     -- * Misc
CodeGen/X86/Asm.hs view
@@ -300,6 +300,7 @@ instance (rw ~ R) => Num (Operand rw s) where     negate (ImmOp (Immediate x)) = ImmOp $ Immediate $ negate x     fromInteger (Integral x) = ImmOp $ Immediate x+    fromInteger z = error $ show z ++ " does not fit into " -- ++ show s     (+) = error "(+) @Operand"     (-) = error "(-) @Operand"     (*) = error "(*) @Operand"
CodeGen/X86/CodeGen.hs view
@@ -169,7 +169,7 @@             vx' = ma - ma'             (z', s) = g' ss             g' [] = error $ show vx' ++ " does not fit into auto size"-            g' ((s, c): ss) = case (s, vx' - length c - sizeLen s) of+            g' ((s, c): ss) = case (s, vx') of                 (S8,  Integral (j :: Int8)) -> (c, s)                 (S32, Integral (j :: Int32)) -> (c, s)                 _ -> g' ss@@ -245,7 +245,8 @@     7 -> [0x0f, 0x1f, 0x80, 0x00, 0x00, 0x00, 0x00]     8 -> [0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00]     9 -> [0x66, 0x0f, 0x1f, 0x84, 0x00, 0x00, 0x00, 0x00, 0x00]-    x -> nops 9 ++ nops (x-9)+    ((+(-2)) -> Integral x) -> [0xeb] ++ toBytes (x :: Int8) ++ replicate (fromIntegral x) 0x00+    ((+(-5)) -> Integral x) -> [0xe9] ++ toBytes (x :: Int32) ++ replicate (fromIntegral x) 0x00  mkCodeBuilder' :: CodeLine -> CodeBuilder mkCodeBuilder' = \case@@ -296,6 +297,8 @@     Neg_  a -> op1 0x7b 0x3 a     Inc_  a -> op1 0x7f 0x0 a     Dec_  a -> op1 0x7f 0x1 a++    Call_ (ImmOp (LabelRelValue S32 l)) -> codeByte 0xe8 <> mkRef S32 4 l     Call_ a -> op1' 0xff 0x2 a      Movd_ a@OpXMM b -> sse 0x6e a b
CodeGen/X86/Examples.hs view
@@ -1,9 +1,22 @@+{-# LANGUAGE FlexibleInstances #-}
 module CodeGen.X86.Examples where
 
 import Foreign
 
 import CodeGen.X86
 
+foreign import ccall "dynamic" callWW :: FunPtr (Word64 -> Word64) -> Word64 -> Word64
+instance Callable (Word64 -> Word64) where dynCCall = callWW
+
+foreign import ccall "dynamic" callPW :: FunPtr (Ptr a -> Word64) -> Ptr a -> Word64
+instance Callable (Ptr a -> Word64) where dynCCall = callPW
+
+foreign import ccall "dynamic" callIO :: FunPtr (IO ()) -> IO ()
+instance Callable (IO ()) where dynCCall = callIO
+
+foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64))
+instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64
+
 ------------------------------------------------------------------------------ 
 -- * examples
 
@@ -84,6 +97,6 @@     let code = saveNonVolatile $ do
             mov rdi arg1
             mov rax (addr rdi)
-    return $ compile code r == v
+    return $ compile code (r :: Ptr Word8) == v
CodeGen/X86/FFI.hs view
@@ -3,6 +3,7 @@ {-# language BangPatterns #-} {-# language ViewPatterns #-} {-# language FlexibleInstances #-}+{-# language TypeFamilies #-} module CodeGen.X86.FFI where  -------------------------------------------------------@@ -15,6 +16,7 @@ import Foreign.ForeignPtr.Unsafe import System.IO.Unsafe +import Control.DeeperSeq import CodeGen.X86.Asm import CodeGen.X86.CodeGen @@ -31,54 +33,21 @@  #endif ----------------------------------------------------------foreign import ccall "dynamic" callWord64           :: FunPtr Word64                -> Word64-foreign import ccall "dynamic" callWord32           :: FunPtr Word32                -> Word32-foreign import ccall "dynamic" callWord16           :: FunPtr Word16                -> Word16-foreign import ccall "dynamic" callWord8            :: FunPtr Word8                 -> Word8-foreign import ccall "dynamic" callWord             :: FunPtr Word                  -> Word-foreign import ccall "dynamic" callInt64            :: FunPtr Int64                 -> Int64-foreign import ccall "dynamic" callInt32            :: FunPtr Int32                 -> Int32-foreign import ccall "dynamic" callInt16            :: FunPtr Int16                 -> Int16-foreign import ccall "dynamic" callInt8             :: FunPtr Int8                  -> Int8-foreign import ccall "dynamic" callInt              :: FunPtr Int                   -> Int-foreign import ccall "dynamic" callBool             :: FunPtr Bool                  -> Bool-foreign import ccall "dynamic" callIOUnit           :: FunPtr (IO ())               -> IO ()-foreign import ccall "dynamic" callWord64_Word64    :: FunPtr (Word64 -> Word64)    -> Word64 -> Word64-foreign import ccall "dynamic" callPtr_Word64       :: FunPtr (Ptr a -> Word64)     -> Ptr a -> Word64-foreign import ccall "dynamic" callPtr_Word         :: FunPtr (Ptr a -> Word)       -> Ptr a -> Word-foreign import ccall "dynamic" callPtr_Int64        :: FunPtr (Ptr a -> Int64)      -> Ptr a -> Int64-foreign import ccall "dynamic" callPtr_Int          :: FunPtr (Ptr a -> Int)        -> Ptr a -> Int--unsafeCallForeignPtr0 call p = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p)) <* touchForeignPtr p--unsafeCallForeignPtr1 call p a = unsafePerformIO $ evaluate (call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) a) <* touchForeignPtr p--unsafeCallForeignPtrIO0 call p = call (castPtrToFunPtr $ unsafeForeignPtrToPtr p) <* touchForeignPtr p-+class MapResult a => Callable a where dynCCall :: FunPtr a -> a -class Callable a where unsafeCallForeignPtr :: ForeignPtr a -> a+callForeignPtr :: Callable a => ForeignPtr a -> a+callForeignPtr p = deeperSeq (unsafePerformIO $ touchForeignPtr p) (dynCCall $ castPtrToFunPtr $ unsafeForeignPtrToPtr p) -instance Callable Word64                where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord64-instance Callable Word32                where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord32-instance Callable Word16                where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord16-instance Callable Word8                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord8-instance Callable Word                  where unsafeCallForeignPtr = unsafeCallForeignPtr0 callWord-instance Callable Int64                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt64-instance Callable Int32                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt32-instance Callable Int16                 where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt16-instance Callable Int8                  where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt8-instance Callable Int                   where unsafeCallForeignPtr = unsafeCallForeignPtr0 callInt-instance Callable Bool                  where unsafeCallForeignPtr = unsafeCallForeignPtr0 callBool-instance Callable (IO ())               where unsafeCallForeignPtr = unsafeCallForeignPtrIO0 callIOUnit-instance Callable (Word64 -> Word64)    where unsafeCallForeignPtr = unsafeCallForeignPtr1 callWord64_Word64-instance Callable (Ptr a -> Word64)     where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word64-instance Callable (Ptr a -> Word)       where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Word-instance Callable (Ptr a -> Int64)      where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Int64-instance Callable (Ptr a -> Int)        where unsafeCallForeignPtr = unsafeCallForeignPtr1 callPtr_Int+class MapResult a => CallableHs a where createHsPtr :: a -> IO (FunPtr a) --------------------------------------------------------+hsPtr :: CallableHs a => a -> FunPtr a+hsPtr x = unsafePerformIO $ createHsPtr x+{- TODO+hsPtr' :: CallableHs a => a -> ForeignPtr a+hsPtr' x = unsafePerformIO $ do+    p <- createHsPtr x+    newForeignPtr (freeHaskellFunPtr p) (castFunPtrToPtr p)+-}  #if defined (mingw32_HOST_OS) || defined (mingw64_HOST_OS)  -- note: GHC 64 bit also defines mingw32 ...@@ -111,7 +80,7 @@  {-# NOINLINE compile #-} compile :: Callable a => Code -> a-compile x = unsafeCallForeignPtr $ unsafePerformIO $ do+compile x = callForeignPtr $ unsafePerformIO $ do     let (bytes, fromIntegral -> size) = buildTheCode x     arr <- c_aligned_malloc (fromIntegral size) PAGE_SIZE     _ <- virtualProtect (castPtr arr) (fromIntegral size) flag_PAGE_EXECUTE_READWRITE@@ -122,7 +91,7 @@  {-# NOINLINE compile #-} compile :: Callable a => Code -> a-compile x = unsafeCallForeignPtr $ unsafePerformIO $ do+compile x = callForeignPtr $ unsafePerformIO $ do     let (bytes, fromIntegral -> size) = buildTheCode x     arr <- memalign PAGE_SIZE size     _ <- mprotect arr size 0x7 -- READ, WRITE, EXEC@@ -147,7 +116,7 @@        {-# NOINLINE compile #-} compile :: Callable a => Code -> a-compile x = unsafeCallForeignPtr $ unsafePerformIO $ do+compile x = callForeignPtr $ unsafePerformIO $ do     let (bytes, fromIntegral -> size) = buildTheCode x     arr <- posixMemAlign PAGE_SIZE size     _ <- mprotect arr size 0x7 -- READ, WRITE, EXEC@@ -155,16 +124,4 @@     newForeignPtr stdfree arr  #endif-----------------------------------------------------------foreign import ccall "wrapper" createPtrWord64_Word64 :: (Word64 -> Word64) -> IO (FunPtr (Word64 -> Word64))--class CallableHs a where createHsPtr :: a -> IO (FunPtr a)--instance CallableHs (Word64 -> Word64) where createHsPtr = createPtrWord64_Word64--hsPtr :: CallableHs a => a -> FunPtr a-hsPtr x = unsafePerformIO $ createHsPtr x-
CodeGen/X86/Tests.hs view
@@ -33,6 +33,11 @@ import CodeGen.X86.FFI
 import CodeGen.X86.Utils
 
+import Foreign
+
+foreign import ccall "dynamic" dcb :: FunPtr Bool -> Bool
+instance Callable Bool where dynCCall = dcb
+
 ------------------------------------------------------------------------------
 
 class HasSigned a where
+ Control/DeeperSeq.hs view
@@ -0,0 +1,47 @@+{-# language TypeFamilies #-}+module Control.DeeperSeq where++import Foreign+import Control.DeepSeq++type family Result a where+    Result (IO a)   = Result a+    Result (b -> a) = Result a+    Result a        = a++type family SetResult a b where+    SetResult x (IO a)   = IO (SetResult x a)+    SetResult x (b -> a) = b -> SetResult x a+    SetResult x _        = x++class (SetResult (Result a) a ~ a) => MapResult a where+    mapResult :: (Result a -> b) -> a -> SetResult b a++instance MapResult Char     where mapResult = id+instance MapResult Double   where mapResult = id+instance MapResult Float    where mapResult = id+instance MapResult Bool     where mapResult = id+instance MapResult Int      where mapResult = id+instance MapResult Int8     where mapResult = id+instance MapResult Int16    where mapResult = id+instance MapResult Int32    where mapResult = id+instance MapResult Int64    where mapResult = id+instance MapResult Word     where mapResult = id+instance MapResult Word8    where mapResult = id+instance MapResult Word16   where mapResult = id+instance MapResult Word32   where mapResult = id+instance MapResult Word64   where mapResult = id+instance MapResult (Ptr a)          where mapResult = id+instance MapResult (FunPtr a)       where mapResult = id+instance MapResult (StablePtr a)    where mapResult = id+instance MapResult ()               where mapResult = id+instance MapResult (a, b)           where mapResult = id+instance MapResult (a, b, c)        where mapResult = id+instance MapResult (a, b, c, d)     where mapResult = id++instance MapResult b => MapResult (a -> b)  where mapResult = fmap . mapResult+instance MapResult a => MapResult (IO a)    where mapResult = fmap . mapResult++deeperSeq :: (NFData a, MapResult b) => a -> b -> b+deeperSeq a b = mapResult (deepseq a) b+
x86-64bit.cabal view
@@ -1,5 +1,5 @@ name:                x86-64bit
-version:             0.3.1
+version:             0.4
 homepage:            https://github.com/divipp/x86-64
 synopsis:            Runtime code generation for x86 64 bit machine code
 description:         The primary goal of x86-64bit is to provide a lightweight assembler for machine generated 64 bit x86 assembly instructions. See README.md for further details.
@@ -25,6 +25,7 @@     CodeGen.X86
     CodeGen.X86.Examples
   other-modules:
+    Control.DeeperSeq
     CodeGen.X86.Asm
     CodeGen.X86.CodeGen
     CodeGen.X86.CallConv
@@ -59,7 +60,8 @@     monads-tf >=0.1 && <0.2,
     tardis >= 0.4 && <0.5,
     vector >=0.11 && <0.12,
-    QuickCheck >=2.8 && <2.10
+    QuickCheck >=2.8 && <2.10,
+    deepseq
 
   if os(windows)
     build-depends: Win32
@@ -75,7 +77,8 @@     monads-tf >=0.1 && <0.2,
     tardis >= 0.4 && <0.5,
     vector >=0.11 && <0.12,
-    QuickCheck >=2.8 && <2.10
+    QuickCheck >=2.8 && <2.10,
+    deepseq
 
   if os(windows)
     build-depends: Win32