+{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface #-}
+#include "debug.h"
module Mate.X86CodeGen where
import Data.Binary
+import Data.BinaryState
import Data.Int
import Data.Maybe
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
import Control.Monad
-import Foreign
+import Foreign hiding (xor)
import Foreign.C.Types
-import Text.Printf
-
import qualified JVM.Assembler as J
import JVM.Assembler hiding (Instruction)
import JVM.ClassFile
foreign import ccall "dynamic"
code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
-foreign import ccall "getaddr"
- getaddr :: CUInt
-
-foreign import ccall "getMallocAddr"
- getMallocAddr :: CUInt
-
-foreign import ccall "callertrap"
- callertrap :: IO ()
+foreign import ccall "getMallocObjectAddr"
+ getMallocObjectAddr :: CUInt
foreign import ccall "register_signal"
register_signal :: IO ()
-test_01, test_02, test_03 :: IO ()
-test_01 = do
- register_signal
- (entry, end) <- testCase "./tests/Fib" "fib"
- let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
-
- mapM_ (\x -> do
- result <- code_int entryFuncPtr x 0
- let iresult :: Int; iresult = fromIntegral result
- let kk :: String; kk = if iresult == (fib x) then "OK" else "FAIL (" ++ (show (fib x)) ++ ")"
- printf "result of fib(%2d): %3d\t\t%s\n" (fromIntegral x :: Int) iresult kk
- ) $ ([0..10] :: [CInt])
- printf "patched disasm:\n"
- Right newdisasm <- disassembleBlock entry end
- mapM_ (putStrLn . showAtt) newdisasm
- where
- fib :: CInt -> Int
- fib n
- | n <= 1 = 1
- | otherwise = (fib (n - 1)) + (fib (n - 2))
-
-
-test_02 = do
- (entry,_) <- testCase "./tests/While" "f"
- let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
- result <- code_int entryFuncPtr 5 4
- let iresult :: Int; iresult = fromIntegral result
- let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
- printf "result of f(5,4): %3d\t\t%s\n" iresult kk
-
- result2 <- code_int entryFuncPtr 4 3
- let iresult2 :: Int; iresult2 = fromIntegral result2
- let kk2 :: String; kk2 = if iresult2 == 10 then "OK" else "FAIL"
- printf "result of f(4,3): %3d\t\t%s\n" iresult2 kk2
-
-
-test_03 = do
- (entry,_) <- testCase "./tests/While" "g"
- let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
- result <- code_int entryFuncPtr 5 4
- let iresult :: Int; iresult = fromIntegral result
- let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
- printf "result of g(5,4): %3d\t\t%s\n" iresult kk
-
- result2 <- code_int entryFuncPtr 4 3
- let iresult2 :: Int; iresult2 = fromIntegral result2
- let kk2 :: String; kk2 = if iresult2 == 10 then "OK" else "FAIL"
- printf "result of g(4,3): %3d\t\t%s\n" iresult2 kk2
-
-
-testCase :: B.ByteString -> B.ByteString -> IO (Ptr Word8, Int)
-testCase cf method = do
- cls <- getClassFile cf
- hmap <- parseMethod cls method
- printMapBB hmap
- case hmap of
- Nothing -> error "sorry, no code generation"
- Just hmap' -> do
- let ebb = emitFromBB method cls hmap'
- (_, Right ((entry, bbstarts, end, _), disasm)) <- runCodeGen ebb () ()
- let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Int)
- printf "disasm:\n"
- mapM_ (putStrLn . showAtt) disasm
- printf "basicblocks addresses:\n"
- let b = map (\(x,y) -> (x,y + int_entry)) $ M.toList bbstarts
- mapM_ (\(x,y) -> printf "\tBasicBlock %2d starts at 0x%08x\n" x y) b
- return (entry, end)
type EntryPoint = Ptr Word8
type EntryPointOffset = Int
type BBStarts = M.Map BlockID Int
-type CompileInfo = (EntryPoint, BBStarts, Int, TMap)
+type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
getLabel _ [] = error "label not found!"
getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
- efBB :: (BlockID, BasicBlock) -> TMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TMap, BBStarts)
+ 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)
emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
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)
+ -- make actual (indirect) call
+ calladdr <- getCurrentOffset
+ call (Disp offset, ebx)
+ -- discard arguments on stack (+4 for "this")
+ let argcnt = 4 + ((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)
+ -- note, the "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)
emit' (INVOKEVIRTUAL cpidx) = do
-- get methodInfo entry
let mi@(MethodInfo methodname objname msig@(MethodSignature args _)) = buildMethodID cls cpidx
emit' insn = emit insn >> return Nothing
emit :: J.Instruction -> CodeGen e s ()
- emit POP = do -- print dropped value
- calladdr <- getCurrentOffset
- -- '5' is the size of the `call' instruction ( + immediate)
- let w32_calladdr = 5 + calladdr
- let trapaddr = (fromIntegral getaddr :: Word32)
- call (trapaddr - w32_calladdr)
+ emit POP = do -- dropp value
add esp (4 :: Word32)
emit DUP = push (Disp 0, esp)
+ 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
+ emit AALOAD = emit IALOAD
+ emit IALOAD = do
+ pop ebx -- offset
+ add ebx (1 :: Word32)
+ pop ecx -- aref
+ push (ecx, ebx, S4)
+ emit ARRAYLENGTH = do
+ 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
+ _ -> 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 $ getMethodSize objname
+ amount <- liftIO $ getObjectSize objname
push (amount :: Word32)
- calladdr <- getCurrentOffset
- let w32_calladdr = 5 + calladdr
- let malloaddr = (fromIntegral getMallocAddr :: Word32)
- call (malloaddr - w32_calladdr)
- add esp (4 :: Word32)
- push eax
+ callMalloc
-- TODO(bernhard): save reference somewhere for GC
-- set method table pointer
mtable <- liftIO $ getMethodTable objname
emit (ICONST_0) = push (0 :: Word32)
emit (ICONST_1) = push (1 :: Word32)
emit (ICONST_2) = push (2 :: 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)
pop eax -- this pointer
let (cname, fname) = buildFieldOffset cls x
offset <- liftIO $ getFieldOffset cname fname
- push (Disp (fromIntegral $ offset * 4), eax) -- get field
+ push (Disp (fromIntegral $ offset), eax) -- get field
emit (PUTFIELD x) = do
pop ebx -- value to write
pop eax -- this pointer
let (cname, fname) = buildFieldOffset cls x
offset <- liftIO $ getFieldOffset cname fname
- mov (Disp (fromIntegral $ offset * 4), eax) ebx -- set field
+ 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
emit IMUL = do pop ebx; pop eax; mul ebx; push eax
+ emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
emit (IINC x imm) = do
add (Disp (cArgs x), ebp) (s8_w32 imm)
ret
emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
+ callMalloc :: CodeGen e s ()
+ callMalloc = do
+ calladdr <- getCurrentOffset
+ let w32_calladdr = 5 + calladdr
+ let malloaddr = (fromIntegral getMallocObjectAddr :: Word32)
+ call (malloaddr - w32_calladdr)
+ add esp (4 :: Word32)
+ push eax
+
-- for locals we use a different storage
cArgs :: Word8 -> Word32
cArgs x = if (x' >= thisMethodArgCnt)
projects / mate.git / blobdiff