diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/CodeGen/X86.hs b/CodeGen/X86.hs --- a/CodeGen/X86.hs +++ b/CodeGen/X86.hs @@ -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 diff --git a/CodeGen/X86/Asm.hs b/CodeGen/X86/Asm.hs --- a/CodeGen/X86/Asm.hs +++ b/CodeGen/X86/Asm.hs @@ -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" diff --git a/CodeGen/X86/CodeGen.hs b/CodeGen/X86/CodeGen.hs --- a/CodeGen/X86/CodeGen.hs +++ b/CodeGen/X86/CodeGen.hs @@ -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 diff --git a/CodeGen/X86/Examples.hs b/CodeGen/X86/Examples.hs --- a/CodeGen/X86/Examples.hs +++ b/CodeGen/X86/Examples.hs @@ -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 diff --git a/CodeGen/X86/FFI.hs b/CodeGen/X86/FFI.hs --- a/CodeGen/X86/FFI.hs +++ b/CodeGen/X86/FFI.hs @@ -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 - diff --git a/CodeGen/X86/Tests.hs b/CodeGen/X86/Tests.hs --- a/CodeGen/X86/Tests.hs +++ b/CodeGen/X86/Tests.hs @@ -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 diff --git a/Control/DeeperSeq.hs b/Control/DeeperSeq.hs new file mode 100644 --- /dev/null +++ b/Control/DeeperSeq.hs @@ -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 + diff --git a/x86-64bit.cabal b/x86-64bit.cabal --- a/x86-64bit.cabal +++ b/x86-64bit.cabal @@ -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