codegen: make use of Functor instance
[mate.git] / Mate / X86CodeGen.hs
index f1f9969da9237e802697d7890eeffa923993d577..af3e98d282a31e37c35e40898c70bfa487eac400 100644 (file)
@@ -1,7 +1,5 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
-#include "debug.h"
 module Mate.X86CodeGen where
 
 import Prelude hiding (and, div)
@@ -9,9 +7,11 @@ import Data.Binary
 import Data.BinaryState
 import Data.Int
 import Data.Maybe
+import Data.List (genericLength)
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as B
 import Control.Monad
+import Control.Applicative
 
 import Foreign hiding (xor)
 import Foreign.C.Types
@@ -28,13 +28,12 @@ import Mate.NativeSizes
 import Mate.Types
 import Mate.Utilities
 import Mate.ClassPool
+import Mate.ClassHierarchy
+import {-# SOURCE #-} Mate.MethodPool
 import Mate.Strings
-#ifdef DEBUG
-import Text.Printf
-#endif
 
 
-foreign import ccall "&mallocObject"
+foreign import ccall "&mallocObjectGC"
   mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
 
 type EntryPoint = Ptr Word8
@@ -64,7 +63,7 @@ emitFromBB cls method = do
   hmap = rawMapBB method
 
   getLabel :: BlockID -> [(BlockID, Label)] -> Label
-  getLabel _ [] = error "label not found!"
+  getLabel bid [] = error $ "label " ++ show bid ++ " not found"
   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
 
   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
@@ -100,38 +99,55 @@ emitFromBB cls method = do
 
     getCurrentOffset :: CodeGen e s Word32
     getCurrentOffset = do
-      ep <- getEntryPoint
-      let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
-      offset <- getCodeOffset
-      return $ w32_ep + fromIntegral offset
+      ep <- (fromIntegral . ptrToIntPtr) <$> getEntryPoint
+      offset <- fromIntegral <$> getCodeOffset
+      return $ ep + offset
 
     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
     emitInvoke cpidx hasThis = do
       let l = buildMethodID cls cpidx
-      calladdr <- getCurrentOffset
       newNamedLabel (show l) >>= defineLabel
-      -- causes SIGILL. in the signal handler we patch it to the acutal call.
-      -- place two nop's at the end, therefore the disasm doesn't screw up
-      emit32 (0x9090ffff :: Word32) >> emit8 (0x90 :: Word8)
+      -- like: call $0x01234567
+      calladdr <- emitSigIllTrap 5
+      let patcher reip = do
+            entryAddr <- liftIO $ getMethodEntry l
+            call (fromIntegral (entryAddr - (reip + 5)) :: NativeWord)
+            return reip
       -- discard arguments on stack
       let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount (methodNameTypeByIdx cls cpidx)) * ptrSize
       when (argcnt > 0) (add esp argcnt)
       -- push result on stack if method has a return value
       when (methodHaveReturnValue cls cpidx) (push eax)
-      return $ Just (calladdr, StaticMethod l)
+      return $ Just (calladdr, StaticMethod patcher)
 
-    invokeEpilog :: Word16 -> Word32 -> (Bool -> TrapCause) -> CodeGen e s (Maybe (Word32, TrapCause))
-    invokeEpilog cpidx offset trapcause = do
+    virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
+    virtualCall cpidx isInterface = do
+      let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
+      newNamedLabel (show mi) >>= defineLabel
+      -- get method offset for call @ runtime
+      let offset = if isInterface
+          then getInterfaceMethodOffset objname methodname (encode msig)
+          else getMethodOffset objname (methodname `B.append` encode msig)
+      let argsLen = genericLength args
+      -- objref lives somewhere on the argument stack
+      mov ebx (Disp (argsLen * ptrSize), esp)
+      when isInterface $
+        mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
+      -- get method-table-ptr (or interface-table-ptr)
+      mov eax (Disp 0, ebx)
       -- make actual (indirect) call
       calladdr <- getCurrentOffset
-      call (Disp offset, eax)
+      -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
+      emitSigIllTrap 6
       -- discard arguments on stack (`+1' for "this")
       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
       when (argcnt > 0) (add esp argcnt)
       -- push result on stack if method has a return value
       when (methodHaveReturnValue cls cpidx) (push eax)
-      let imm8 = is8BitOffset offset
-      return $ Just (calladdr + (if imm8 then 3 else 6), trapcause imm8)
+      -- note, that "mi" has the wrong class reference here.
+      -- we figure that out at run-time, in the methodpool,
+      -- depending on the method-table-ptr
+      return $ Just (calladdr, VirtualCall isInterface mi offset)
 
     emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
@@ -139,37 +155,9 @@ emitFromBB cls method = do
     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
-    emit' (INVOKEINTERFACE cpidx _) = do
-      -- get methodInfo entry
-      let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
-      newNamedLabel (show mi) >>= defineLabel
-      -- objref lives somewhere on the argument stack
-      mov eax (Disp ((* ptrSize) $ fromIntegral $ length args), esp)
-      -- get method-table-ptr, keep it in eax (for trap handling)
-      mov eax (Disp 0, eax)
-      -- get interface-table-ptr
-      mov ebx (Disp 0, eax)
-      -- get method offset
-      offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
-      -- note, that "mi" has the wrong class reference here.
-      -- we figure that out at run-time, in the methodpool,
-      -- depending on the method-table-ptr
-      invokeEpilog cpidx offset (`InterfaceMethod` mi)
-    emit' (INVOKEVIRTUAL cpidx) = do
-      -- get methodInfo entry
-      let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
-      newNamedLabel (show mi) >>= defineLabel
-      -- objref lives somewhere on the argument stack
-      mov eax (Disp ((* ptrSize) $ fromIntegral $ length args), esp)
-      -- get method-table-ptr
-      mov eax (Disp 0, eax)
-      -- get method offset
-      let nameAndSig = methodname `B.append` encode msig
-      offset <- liftIO $ getMethodOffset objname nameAndSig
-      -- note, that "mi" has the wrong class reference here.
-      -- we figure that out at run-time, in the methodpool,
-      -- depending on the method-table-ptr
-      invokeEpilog cpidx offset (`VirtualMethod` mi)
+    emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
+    emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
+
     emit' (PUTSTATIC cpidx) = do
       pop eax
       trapaddr <- getCurrentOffset
@@ -180,18 +168,68 @@ emitFromBB cls method = do
       mov eax (Addr 0x00000000) -- it's a trap
       push eax
       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
+
+    emit' (GETFIELD x) = do
+      pop eax -- this pointer
+      -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
+      trapaddr <- emitSigIllTrap 6
+      let patcher reip = do
+            let (cname, fname) = buildFieldOffset cls x
+            offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
+            push32RelEax (Disp offset) -- get field
+            return reip
+      return $ Just (trapaddr, ObjectField patcher)
+    emit' (PUTFIELD x) = do
+      pop ebx -- value to write
+      pop eax -- this pointer
+      -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
+      trapaddr <- emitSigIllTrap 6
+      let patcher reip = do
+            let (cname, fname) = buildFieldOffset cls x
+            offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
+            mov32RelEbxEax (Disp offset) -- set field
+            return reip
+      return $ Just (trapaddr, ObjectField patcher)
+
     emit' (INSTANCEOF cpidx) = do
       pop eax
-      mov eax (Disp 0, eax) -- mtable of objectref
-      trapaddr <- getCurrentOffset
       -- place something like `mov edx $mtable_of_objref' instead
-      emit32 (0x9090ffff :: Word32) >> emit8 (0x90 :: Word8)
-      cmp eax edx
-      sete al
-      movzxb eax al
-      push eax
-      forceRegDump
-      return $ Just (trapaddr, InstanceOf $ buildClassID cls cpidx)
+      trapaddr <- emitSigIllTrap 4
+      push (0 :: Word32)
+      let patcher reax reip = do
+            emitSigIllTrap 4
+            let classname = buildClassID cls cpidx
+            check <- liftIO $ isInstanceOf (fromIntegral reax) classname
+            if check
+              then push (1 :: Word32)
+              else push (0 :: Word32)
+            return (reip + 4)
+      return $ Just (trapaddr, InstanceOf patcher)
+    emit' (NEW objidx) = do
+      let objname = buildClassID cls objidx
+      -- place something like `push $objsize' instead
+      trapaddr <- emitSigIllTrap 5
+      callMalloc
+      -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
+      mov (Disp 0, eax) (0x13371337 :: Word32)
+      mov (Disp 4, eax) (0x1337babe :: Word32)
+      let patcher reip = do
+            objsize <- liftIO $ getObjectSize objname
+            push32 objsize
+            callMalloc
+            mtable <- liftIO $ getMethodTable objname
+            mov (Disp 0, eax) mtable
+            mov (Disp 4, eax) (0x1337babe :: Word32)
+            return reip
+      return $ Just (trapaddr, NewObject patcher)
+
+    emit' ATHROW = do
+      trapaddr <- emitSigIllTrap 2
+      let patcher resp reip = do
+            emitSigIllTrap 2
+            return reip
+      return $ Just (trapaddr, ThrowException patcher)
+
     emit' insn = emit insn >> return Nothing
 
     emit :: J.Instruction -> CodeGen e s ()
@@ -245,18 +283,8 @@ emitFromBB cls method = do
       pop ebx -- length
       mov (Disp 0, eax) ebx -- store length at offset 0
       push eax -- push ref again
-    emit (NEW objidx) = do
-      let objname = buildClassID cls objidx
-      amount <- liftIO $ getObjectSize objname
-      push (amount :: Word32)
-      callMalloc
-      -- TODO(bernhard): save reference somewhere for GC
-      -- set method table pointer
-      mtable <- liftIO $ getMethodTable objname
-      mov (Disp 0, eax) mtable
+
     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
-    emit ATHROW = -- TODO(bernhard): ...
-        emit32 (0xffffffff :: Word32)
     emit I2C = do
       pop eax
       and eax (0x000000ff :: Word32)
@@ -291,13 +319,6 @@ emitFromBB cls method = do
                     (CInteger i) -> liftIO $ return i
                     e -> error $ "LDCI... missing impl.: " ++ show e
       push value
-    emit (GETFIELD x) = do
-      offset <- emitFieldOffset x
-      push (Disp (fromIntegral offset), eax) -- get field
-    emit (PUTFIELD x) = do
-      pop ebx -- value to write
-      offset <- emitFieldOffset x
-      mov (Disp (fromIntegral offset), eax) ebx -- set field
 
     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
@@ -333,12 +354,6 @@ emitFromBB cls method = do
     emit IRETURN = do pop eax; emit RETURN
     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 
-    emitFieldOffset :: Word16 -> CodeGen e s Int32
-    emitFieldOffset x = do
-      pop eax -- this pointer
-      let (cname, fname) = buildFieldOffset cls x
-      liftIO $ getFieldOffset cname fname
-
     emitIF :: CMP -> CodeGen e s ()
     emitIF cond = let
       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
@@ -354,12 +369,16 @@ emitFromBB cls method = do
         --  (it didn't work for gnu/classpath/SystemProperties.java)
         jmp l2
 
+    emitSigIllTrap :: Int -> CodeGen e s NativeWord
+    emitSigIllTrap traplen = do
+      when (traplen < 2) (error "emitSigIllTrap: trap len too short")
+      trapaddr <- getCurrentOffset
+      -- 0xffff causes SIGILL
+      emit8 (0xff :: Word8); emit8 (0xff :: Word8)
+      -- fill rest up with NOPs
+      sequence_ [nop | _ <- [1 .. (traplen - 2)]]
+      return trapaddr
 
-    callMalloc :: CodeGen e s ()
-    callMalloc = do
-      call mallocObjectAddr
-      add esp (ptrSize :: Word32)
-      push eax
 
   -- for locals we use a different storage
   cArgs :: Word8 -> Word32
@@ -380,6 +399,28 @@ emitFromBB cls method = do
   s8_w32 w8 = fromIntegral s8
     where s8 = fromIntegral w8 :: Int8
 
-  is8BitOffset :: Word32 -> Bool
-  is8BitOffset w32 = s32 < 128 && s32 > (-127)
-    where s32 = fromIntegral w32 :: Int32
+callMalloc :: CodeGen e s ()
+callMalloc = do
+  call mallocObjectAddr
+  add esp (ptrSize :: Word32)
+  push eax
+
+
+-- harpy tries to cut immediates (or displacements), if they fit in 8bit.
+-- however, this is bad for patching so we want to put always 32bit.
+
+-- push imm32
+push32 :: Word32 -> CodeGen e s ()
+push32 imm32 = emit8 0x68 >> emit32 imm32
+
+-- call disp32(%eax)
+call32Eax :: Disp -> CodeGen e s ()
+call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
+
+-- push disp32(%eax)
+push32RelEax :: Disp -> CodeGen e s ()
+push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
+
+-- mov %ebx, disp32(%eax)
+mov32RelEbxEax :: Disp -> CodeGen e s ()
+mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32