import Mate.Utilities
import Mate.ClassPool
import Mate.Strings
-import Mate.Debug
#ifdef DEBUG
import Text.Printf
#endif
-foreign import ccall "dynamic"
- code_int :: FunPtr (CInt -> CInt -> IO CInt) -> CInt -> CInt -> IO CInt
-
-foreign import ccall "getMallocObjectAddr"
- getMallocObjectAddr :: CUInt
+foreign import ccall "&mallocObject"
+ mallocObjectAddr :: FunPtr (Int -> IO CUInt)
type EntryPoint = Ptr Word8
type EntryPointOffset = Int
type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
-emitFromBB :: B.ByteString -> MethodSignature -> Class Direct -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
-emitFromBB method sig cls hmap = do
- llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
- let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
+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
- -- TODO(bernhard): determine a reasonable value.
- -- e.g. (locals used) * 4
- sub esp (0x60 :: Word32)
+ 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)
where
+ hmap = rawMapBB method
+
getLabel :: BlockID -> [(BlockID, Label)] -> Label
getLabel _ [] = error "label not found!"
getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
bb_offset <- getCodeOffset
let bbstarts' = M.insert bid bb_offset bbstarts
defineLabel $ getLabel bid lmap
- cs <- mapM emit' $ code bb
+ cs <- mapM emit'' $ code bb
let calls' = calls `M.union` M.fromList (catMaybes cs)
case successor bb of
Return -> return (calls', bbstarts')
- FallThrough t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
+ 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
offset <- getCodeOffset
return $ w32_ep + fromIntegral offset
- emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
+ emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
emitInvoke cpidx hasThis = do
let l = buildMethodID cls cpidx
calladdr <- getCurrentOffset
-- 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, MI l)
+ return $ Just (calladdr + 2, StaticMethod l)
- emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
+ 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)
+
+ emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
+ emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
+
+ 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
mov ebx (Disp 0, eax)
-- get method offset
offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
- -- make actual (indirect) call
- calladdr <- getCurrentOffset
- call (Disp offset, ebx)
- -- 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)
- -- note, the "mi" has the wrong class reference here.
+ -- 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, II mi)
+ invokeEpilog cpidx offset (`InterfaceMethod` mi)
emit' (INVOKEVIRTUAL cpidx) = do
-- get methodInfo entry
let mi@(MethodInfo methodname objname msig@(MethodSignature args _)) = buildMethodID cls cpidx
-- get method offset
let nameAndSig = methodname `B.append` encode msig
offset <- liftIO $ getMethodOffset objname nameAndSig
- -- 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)
- -- note, the "mi" has the wrong class reference here.
+ -- 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, VI mi)
+ invokeEpilog cpidx offset (`VirtualMethod` mi)
emit' (PUTSTATIC cpidx) = do
pop eax
trapaddr <- getCurrentOffset
mov (Addr 0x00000000) eax -- it's a trap
- return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
+ 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, SFI $ buildStaticFieldID cls cpidx)
+ return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
emit' insn = emit insn >> return Nothing
emit :: J.Instruction -> CodeGen e s ()
emit POP = add esp (4 :: 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
mtable <- liftIO $ getMethodTable objname
mov (Disp 0, eax) mtable
emit (CHECKCAST _) = nop -- TODO(bernhard): ...
- emit ATHROW = nop -- TODO(bernhard): ...
+ -- TODO(bernhard): ...
+ emit (INSTANCEOF _) = do
+ pop eax
+ push (1 :: Word32)
+ emit ATHROW = -- TODO(bernhard): ...
+ emit32 (0xffffffff :: Word32)
emit I2C = do
pop eax
and eax (0x000000ff :: Word32)
emit (ICONST_3) = push (3 :: Word32)
emit (ICONST_4) = push (4 :: Word32)
emit (ICONST_5) = push (5 :: Word32)
+
emit (ALOAD_ x) = emit (ILOAD_ x)
- emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
+ emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
emit (ALOAD x) = emit (ILOAD x)
emit (ILOAD x) = push (Disp (cArgs x), ebp)
+
emit (ASTORE_ x) = emit (ISTORE_ x)
- emit (ISTORE_ x) = do
- pop eax
- mov (Disp (cArgs_ x), ebp) eax
+ emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
emit (ASTORE x) = emit (ISTORE x)
emit (ISTORE x) = do
pop eax
emit (LDC2 x) = do
value <- case constsPool cls M.! x of
(CString s) -> liftIO $ getUniqueStringAddr s
- _ -> error "LDCI... missing impl."
+ (CInteger i) -> liftIO $ return i
+ e -> error $ "LDCI... missing impl.: " ++ show e
push value
emit (GETFIELD x) = do
offset <- emitFieldOffset x
emit IADD = do pop ebx; pop eax; add eax ebx; push eax
emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
emit IMUL = do pop ebx; pop eax; mul ebx; push eax
- emit IDIV = do pop ebx; pop eax; div ebx; push eax
- emit IREM = do pop ebx; pop eax; div ebx; push edx
+ emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
+ emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
+ 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)
emitIF cond = let
sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
l = getLabel sid lmap
- in case cond of
- C_EQ -> je l; C_NE -> jne l
- C_LT -> jl l; C_GT -> jg l
- C_GE -> jge l; C_LE -> jle l
+ sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
+ l2 = getLabel sid2 lmap
+ in do
+ case cond of
+ C_EQ -> je l; C_NE -> jne l
+ C_LT -> jl l; C_GT -> jg l
+ C_GE -> jge l; C_LE -> jle l
+ -- TODO(bernhard): ugly workaround, to get broken emitBB working
+ -- (it didn't work for gnu/classpath/SystemProperties.java)
+ jmp l2
+
callMalloc :: CodeGen e s ()
callMalloc = do
- calladdr <- getCurrentOffset
- let w32_calladdr = 5 + calladdr
- let malloaddr = fromIntegral getMallocObjectAddr :: Word32
- call (malloaddr - w32_calladdr)
+ call mallocObjectAddr
add esp (4 :: Word32)
push eax
else 4 + (thisMethodArgCnt * 4) - (4 * x')
where x' = fromIntegral x
- cArgs_ :: IMM -> Word32
- cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
+ 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
- (Just m) = lookupMethodSig method sig cls
+ 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
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