X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FX86CodeGen.hs;h=fb62c905d3332d67c3188e5b81cba239e809a676;hb=c803146cc80b61305fde8279f0a36f8fe6ef7eb2;hp=c2c336fab736e33ec8cd6cf3b163cb5d169fe186;hpb=da245b03d80644c22b011acba31acacb880d8327;p=mate.git

diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs
index c2c336f..fb62c90 100644
--- a/Mate/X86CodeGen.hs
+++ b/Mate/X86CodeGen.hs
@@ -9,8 +9,8 @@ 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.Set as S
 import qualified Data.ByteString.Lazy as B
 import Control.Monad
 
@@ -25,6 +25,7 @@ import Harpy
 import Harpy.X86Disassembler
 
 import Mate.BasicBlocks
+import Mate.NativeSizes
 import Mate.Types
 import Mate.Utilities
 import Mate.ClassPool
@@ -35,7 +36,7 @@ import Text.Printf
 
 
 foreign import ccall "&mallocObject"
-  mallocObjectAddr :: FunPtr (Int -> IO CUInt)
+  mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
 
 type EntryPoint = Ptr Word8
 type EntryPointOffset = Int
@@ -46,20 +47,20 @@ type BBStarts = M.Map BlockID Int
 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
 
 
-emitFromBB :: B.ByteString -> MethodSignature -> Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction])
-emitFromBB methodname sig cls method =  do
-        let keys = M.keys hmap
-        llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
-        let lmap = zip keys llmap
-        ep <- getEntryPoint
-        push ebp
-        mov ebp esp
-        sub esp (fromIntegral ((rawLocals method) * 4) :: Word32)
-
-        (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
-        d <- disassemble
-        end <- getCodeOffset
-        return ((ep, bbstarts, end, calls), d)
+emitFromBB :: Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction])
+emitFromBB cls method = do
+    let keys = M.keys hmap
+    llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
+    let lmap = zip keys llmap
+    ep <- getEntryPoint
+    push ebp
+    mov ebp esp
+    sub esp (fromIntegral (rawLocals method) * ptrSize :: Word32)
+
+    (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
+    d <- disassemble
+    end <- getCodeOffset
+    return ((ep, bbstarts, end, calls), d)
   where
   hmap = rawMapBB method
 
@@ -69,28 +70,35 @@ emitFromBB methodname sig cls method =  do
 
   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
   efBB (bid, bb) calls bbstarts lmap =
-        if M.member bid bbstarts then
-          return (calls, bbstarts)
-        else do
-          bb_offset <- getCodeOffset
-          let bbstarts' = M.insert bid bb_offset bbstarts
-          defineLabel $ getLabel bid lmap
-          cs <- mapM emit'' $ code bb
-          let calls' = calls `M.union` M.fromList (catMaybes cs)
-          case successor bb of
-            Return -> return (calls', bbstarts')
-            FallThrough t -> do
-              -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
-              jmp (getLabel t lmap)
-              efBB (t, hmap M.! t) calls' bbstarts' lmap
-            OneTarget t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
-            TwoTarget t1 t2 -> do
-              (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
-              efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
+    if M.member bid bbstarts then
+      return (calls, bbstarts)
+    else do
+      bb_offset <- getCodeOffset
+      let bbstarts' = M.insert bid bb_offset bbstarts
+      defineLabel $ getLabel bid lmap
+      cs <- mapM emit'' $ code bb
+      let calls' = calls `M.union` M.fromList (catMaybes cs)
+      case successor bb of
+        Return -> return (calls', bbstarts')
+        FallThrough t -> do
+          -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
+          jmp (getLabel t lmap)
+          efBB (t, hmap M.! t) calls' bbstarts' lmap
+        OneTarget t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
+        TwoTarget t1 t2 -> do
+          (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
+          efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
     -- TODO(bernhard): also use metainformation
     -- TODO(bernhard): implement `emit' as function which accepts a list of
     --                 instructions, so we can use patterns for optimizations
     where
+    forceRegDump :: CodeGen e s ()
+    forceRegDump = do
+      push esi
+      mov esi (0x13371234 :: Word32)
+      mov esi (Addr 0)
+      pop esi
+
     getCurrentOffset :: CodeGen e s Word32
     getCurrentOffset = do
       ep <- getEntryPoint
@@ -100,32 +108,48 @@ emitFromBB methodname sig cls method =  do
 
     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 a nop at the end, therefore the disasm doesn't screw up
-        emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
-        -- discard arguments on stack
-        let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount cls cpidx) * 4
-        when (argcnt > 0) (add esp argcnt)
-        -- push result on stack if method has a return value
-        when (methodHaveReturnValue cls cpidx) (push eax)
-        -- +2 is for correcting eip in trap context
-        return $ Just (calladdr + 2, StaticMethod l)
-
-    invokeEpilog :: Word16 -> Word32 -> (Bool -> TrapCause) -> CodeGen e s (Maybe (Word32, TrapCause))
-    invokeEpilog cpidx offset trapcause = do
-        -- make actual (indirect) call
-        calladdr <- getCurrentOffset
-        call (Disp offset, eax)
-        -- discard arguments on stack (+4 for "this")
-        let argcnt = 4 + 4 * methodGetArgsCount 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)
+      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); nop
+      -- 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)
+
+    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)
+      if isInterface
+        then mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
+        else return () -- invokevirtual
+      -- get method-table-ptr (or interface-table-ptr)
+      mov eax (Disp 0, ebx)
+      -- make actual (indirect) call
+      calladdr <- getCurrentOffset
+      -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
+      emit32 (0x9090ffff :: Word32); nop; nop
+      -- 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)
+      -- 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
@@ -133,114 +157,95 @@ emitFromBB methodname sig 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 ((*4) $ 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 ((*4) $ 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
-        mov (Addr 0x00000000) eax -- it's a trap
-        return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
+      pop eax
+      trapaddr <- getCurrentOffset
+      mov (Addr 0x00000000) eax -- it's a trap
+      return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
     emit' (GETSTATIC cpidx) = do
-        trapaddr <- getCurrentOffset
-        mov eax (Addr 0x00000000) -- it's a trap
-        push eax
-        return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
+      trapaddr <- getCurrentOffset
+      mov eax (Addr 0x00000000) -- it's a trap
+      push eax
+      return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
+    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); nop
+      cmp eax edx
+      sete al
+      movzxb eax al
+      push eax
+      forceRegDump
+      return $ Just (trapaddr, InstanceOf $ buildClassID cls cpidx)
+    emit' (NEW objidx) = do
+      let objname = buildClassID cls objidx
+      trapaddr <- getCurrentOffset
+      -- place something like `push $objsize' instead
+      emit32 (0x9090ffff :: Word32); nop
+      callMalloc
+      -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
+      mov (Disp 0, eax) (0x13371337 :: Word32)
+      return $ Just (trapaddr, NewObject objname)
+
     emit' insn = emit insn >> return Nothing
 
     emit :: J.Instruction -> CodeGen e s ()
-    emit POP = add esp (4 :: Word32) -- drop value
+    emit POP = add esp (ptrSize :: Word32) -- drop value
     emit DUP = push (Disp 0, esp)
     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
     emit AASTORE = emit IASTORE
     emit IASTORE = do
-        pop eax -- value
-        pop ebx -- offset
-        add ebx (1 :: Word32)
-        pop ecx -- aref
-        mov (ecx, ebx, S4) eax
+      pop eax -- value
+      pop ebx -- offset
+      add ebx (1 :: Word32)
+      pop ecx -- aref
+      mov (ecx, ebx, S4) eax
     emit CASTORE = do
-        pop eax -- value
-        pop ebx -- offset
-        add ebx (1 :: Word32)
-        pop ecx -- aref
-        mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
+      pop eax -- value
+      pop ebx -- offset
+      add ebx (1 :: Word32)
+      pop ecx -- aref
+      mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
     emit AALOAD = emit IALOAD
     emit IALOAD = do
-        pop ebx -- offset
-        add ebx (1 :: Word32)
-        pop ecx -- aref
-        push (ecx, ebx, S4)
+      pop ebx -- offset
+      add ebx (1 :: Word32)
+      pop ecx -- aref
+      push (ecx, ebx, S4)
     emit CALOAD = do
-        pop ebx -- offset
-        add ebx (1 :: Word32)
-        pop ecx -- aref
-        push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
+      pop ebx -- offset
+      add ebx (1 :: Word32)
+      pop ecx -- aref
+      push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
     emit ARRAYLENGTH = do
-        pop eax
-        push (Disp 0, eax)
+      pop eax
+      push (Disp 0, eax)
     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
     emit (NEWARRAY typ) = do
-        let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
-                    T_INT -> 4
-                    T_CHAR -> 2
-                    _ -> error "newarray: type not implemented yet"
-        -- get length from stack, but leave it there
-        mov eax (Disp 0, esp)
-        mov ebx (tsize :: Word32)
-        -- multiple amount with native size of one element
-        mul ebx -- result is in eax
-        add eax (4 :: Word32) -- for "length" entry
-        -- push amount of bytes to allocate
-        push eax
-        callMalloc
-        pop eax -- ref to arraymemory
-        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
+      let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
+                  T_INT -> 4
+                  T_CHAR -> 2
+                  _ -> error "newarray: type not implemented yet"
+      -- get length from stack, but leave it there
+      mov eax (Disp 0, esp)
+      mov ebx (tsize :: Word32)
+      -- multiple amount with native size of one element
+      mul ebx -- result is in eax
+      add eax (ptrSize :: Word32) -- for "length" entry
+      -- push amount of bytes to allocate
+      push eax
+      callMalloc
+      pop eax -- ref to arraymemory
+      pop ebx -- length
+      mov (Disp 0, eax) ebx -- store length at offset 0
+      push eax -- push ref again
+
     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
-    -- TODO(bernhard): ...
-    emit (INSTANCEOF _) = do
-      pop eax
-      push (1 :: Word32)
     emit ATHROW = -- TODO(bernhard): ...
         emit32 (0xffffffff :: Word32)
     emit I2C = do
@@ -267,23 +272,23 @@ emitFromBB methodname sig cls method =  do
     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
     emit (ASTORE x) = emit (ISTORE x)
     emit (ISTORE x) = do
-        pop eax
-        mov (Disp (cArgs x), ebp) eax
+      pop eax
+      mov (Disp (cArgs x), ebp) eax
 
     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
     emit (LDC2 x) = do
-        value <- case constsPool cls M.! x of
-                      (CString s) -> liftIO $ getUniqueStringAddr s
-                      (CInteger i) -> liftIO $ return i
-                      e -> error $ "LDCI... missing impl.: " ++ show e
-        push value
+      value <- case constsPool cls M.! x of
+                    (CString s) -> liftIO $ getUniqueStringAddr s
+                    (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
+      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
+      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
@@ -294,25 +299,25 @@ emitFromBB methodname sig cls method =  do
     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
     emit INEG = do pop eax; neg eax; push eax
     emit (IINC x imm) =
-        add (Disp (cArgs x), ebp) (s8_w32 imm)
+      add (Disp (cArgs x), ebp) (s8_w32 imm)
 
     emit (IFNONNULL x) = emit (IF C_NE x)
     emit (IFNULL x) = emit (IF C_EQ x)
     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
     emit (IF_ICMP cond _) = do
-        pop eax -- value2
-        pop ebx -- value1
-        cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
-        emitIF cond
+      pop eax -- value2
+      pop ebx -- value1
+      cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
+      emitIF cond
 
     emit (IF cond _) = do
-        pop eax -- value1
-        cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
-        emitIF cond
+      pop eax -- value1
+      cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
+      emitIF cond
 
     emit (GOTO _ ) = do
-        let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
-        jmp $ getLabel sid lmap
+      let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
+      jmp $ getLabel sid lmap
 
     emit RETURN = do mov esp ebp; pop ebp; ret
     emit ARETURN = emit IRETURN
@@ -321,9 +326,9 @@ emitFromBB methodname sig cls method =  do
 
     emitFieldOffset :: Word16 -> CodeGen e s Int32
     emitFieldOffset x = do
-        pop eax -- this pointer
-        let (cname, fname) = buildFieldOffset cls x
-        liftIO $ getFieldOffset cname fname
+      pop eax -- this pointer
+      let (cname, fname) = buildFieldOffset cls x
+      liftIO $ getFieldOffset cname fname
 
     emitIF :: CMP -> CodeGen e s ()
     emitIF cond = let
@@ -343,30 +348,21 @@ emitFromBB methodname sig cls method =  do
 
     callMalloc :: CodeGen e s ()
     callMalloc = do
-        call mallocObjectAddr
-        add esp (4 :: Word32)
-        push eax
+      call mallocObjectAddr
+      add esp (ptrSize :: Word32)
+      push eax
 
   -- for locals we use a different storage
   cArgs :: Word8 -> Word32
-  cArgs x = if x' >= thisMethodArgCnt
-      -- TODO(bernhard): maybe s/(-4)/(-8)/
-      then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
-      else 4 + (thisMethodArgCnt * 4) - (4 * x')
-    where x' = fromIntegral x
+  cArgs x = ptrSize * (argcount - x' + isLocal)
+    where
+      x' = fromIntegral x
+      argcount = rawArgCount method
+      isLocal = if x' >= argcount then (-1) else 1
 
   cArgs_ :: IMM -> Word8
   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 
-  -- TODO: factor this out to `compileBB'
-  thisMethodArgCnt :: Word32
-  thisMethodArgCnt = isNonStatic + fromIntegral (length args)
-    where
-    m = fromJust $ lookupMethodSig methodname sig cls
-    (MethodSignature args _) = sig
-    isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
-        then 0 else 1 -- one argument for the this pointer
-
 
   -- sign extension from w8 to w32 (over s8)
   --   unfortunately, hs-java is using Word8 everywhere (while
@@ -374,7 +370,3 @@ emitFromBB methodname sig cls method =  do
   s8_w32 :: Word8 -> Word32
   s8_w32 w8 = fromIntegral s8
     where s8 = fromIntegral w8 :: Int8
-
-  is8BitOffset :: Word32 -> Bool
-  is8BitOffset w32 = s32 < 128 && s32 > (-127)
-    where s32 = fromIntegral w32 :: Int32