import Data.Binary
import Data.Int
-import Data.List
import Data.Maybe
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as B
+import Control.Monad
import Foreign
-import Foreign.Ptr
import Foreign.C.Types
import Text.Printf
import qualified JVM.Assembler as J
import JVM.Assembler hiding (Instruction)
+import JVM.ClassFile
+import JVM.Converter
import Harpy
import Harpy.X86Disassembler
import Mate.BasicBlocks
+import Mate.Utilities
foreign import ccall "dynamic"
code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
foreign import ccall "register_signal"
register_signal :: IO ()
+foreign import ccall "get_cmap"
+ get_cmap :: IO (Ptr ())
+
+foreign import ccall "set_cmap"
+ set_cmap :: Ptr () -> IO ()
+
test_01, test_02, test_03 :: IO ()
test_01 = do
register_signal
(entry, end) <- testCase "./tests/Fib.class" "fib"
let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
- mapM_ (\(x,entryFuncPtr) -> do
- result <- code_int entryFuncPtr (fromIntegral x) (fromIntegral 0)
+ 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" x iresult kk
- ) $ zip ([0..10] :: [Int]) (repeat entryFuncPtr)
+ 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.class" "f"
let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
- result <- code_int entryFuncPtr (fromIntegral 5) (fromIntegral 4)
+ 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
- result <- code_int entryFuncPtr (fromIntegral 4) (fromIntegral 3)
- let iresult :: Int; iresult = fromIntegral result
- let kk :: String; kk = if iresult == 10 then "OK" else "FAIL"
- printf "result of f(4,3): %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.class" "g"
let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
- result <- code_int entryFuncPtr (fromIntegral 5) (fromIntegral 4)
+ 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
- result <- code_int entryFuncPtr (fromIntegral 4) (fromIntegral 3)
- let iresult :: Int; iresult = fromIntegral result
- let kk :: String; kk = if iresult == 10 then "OK" else "FAIL"
- printf "result of g(4,3): %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 :: String -> B.ByteString -> IO (Ptr Word8, Int)
testCase cf method = do
- hmap <- parseMethod cf method
+ cls <- parseClassFile cf
+ hmap <- parseMethod cls method
printMapBB hmap
case hmap of
Nothing -> error "sorry, no code generation"
- Just hmap -> do
- let ebb = emitFromBB hmap
- (_, Right ((entry, bbstarts, end), disasm)) <- runCodeGen ebb () ()
+ Just hmap' -> do
+ let ebb = emitFromBB cls hmap'
+ (_, Right ((entry, bbstarts, end, _), disasm)) <- runCodeGen ebb () ()
let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Int)
printf "disasm:\n"
mapM_ (putStrLn . showAtt) disasm
type BBStarts = M.Map BlockID Int
-type CompileInfo = (EntryPoint, BBStarts, Int)
+type CompileInfo = (EntryPoint, BBStarts, Int, CMap)
+
+-- B.ByteString: encoded name: <Class>.<methodname><signature>
+-- Class Resolved: classfile
+-- Word16: index of invoke-instruction
+type MethodInfo = (B.ByteString, Class Resolved, Word16)
+
+-- Word32 = point of method call in generated code
+-- MethodInfo = relevant information about callee
+type CMap = M.Map Word32 MethodInfo
+
-emitFromBB :: MapBB -> CodeGen e s (CompileInfo, [Instruction])
-emitFromBB hmap = do
+emitFromBB :: Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
+emitFromBB cls hmap = do
llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
ep <- getEntryPoint
push ebp
mov ebp esp
- -- TODO(bernhard): remove me. just for PoC here
- ep <- getEntryPoint
- let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
- push w32_ep
- -- '5' is the size of the `call' instruction ( + immediate)
- calladdr <- getCodeOffset
- let w32_calladdr = 5 + w32_ep + (fromIntegral calladdr) :: Word32
- let trapaddr = (fromIntegral getaddr :: Word32)
- call (trapaddr - w32_calladdr)
-
- bbstarts <- efBB (0,(hmap M.! 0)) M.empty lmap
+ (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
d <- disassemble
end <- getCodeOffset
- return ((ep, bbstarts, end), d)
+ return ((ep, bbstarts, end, calls), d)
where
getLabel :: BlockID -> [(BlockID, Label)] -> Label
getLabel _ [] = error "label not found!"
getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
- efBB :: (BlockID, BasicBlock) -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (BBStarts)
- efBB (bid, bb) bbstarts lmap =
+ efBB :: (BlockID, BasicBlock) -> CMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (CMap, BBStarts)
+ efBB (bid, bb) calls bbstarts lmap =
if M.member bid bbstarts then
- return bbstarts
+ return (calls, bbstarts)
else do
bb_offset <- getCodeOffset
let bbstarts' = M.insert bid bb_offset bbstarts
defineLabel $ getLabel bid lmap
- mapM emit $ code bb
+ cs <- mapM emit' $ code bb
+ let calls' = calls `M.union` (M.fromList $ catMaybes cs)
case successor bb of
- Return -> return bbstarts'
+ Return -> return (calls', bbstarts')
+ FallThrough t -> do
+ efBB (t, hmap M.! t) calls' bbstarts' lmap
OneTarget t -> do
- efBB (t, hmap M.! t) bbstarts' lmap
+ efBB (t, hmap M.! t) calls' bbstarts' lmap
TwoTarget t1 t2 -> do
- bbstarts'' <- efBB (t1, hmap M.! t1) bbstarts' lmap
- efBB (t2, hmap M.! t2) bbstarts'' lmap
+ (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
+ emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, MethodInfo))
+ emit' (INVOKESTATIC cpidx) = do
+ ep <- getEntryPoint
+ let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
+ let l = buildMethodID cls cpidx
+ calladdr <- getCodeOffset
+ let w32_calladdr = w32_ep + (fromIntegral calladdr) :: Word32
+ newNamedLabel (toString 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 (0xffffffff :: Word32) >> emit8 (0x90 :: Word8)
+ -- discard arguments on stack
+ let argcnt = (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)
+ return $ Just $ (w32_calladdr, (l, cls, cpidx))
+ emit' insn = emit insn >> return Nothing
+
emit :: J.Instruction -> CodeGen e s ()
+ emit POP = do -- print dropped value
+ ep <- getEntryPoint
+ let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
+ -- '5' is the size of the `call' instruction ( + immediate)
+ calladdr <- getCodeOffset
+ let w32_calladdr = 5 + w32_ep + (fromIntegral calladdr) :: Word32
+ let trapaddr = (fromIntegral getaddr :: Word32)
+ call (trapaddr - w32_calladdr)
+ add esp (4 :: Word32)
+ emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
+ emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
+ emit (ICONST_0) = push (0 :: Word32)
emit (ICONST_1) = push (1 :: Word32)
emit (ICONST_2) = push (2 :: Word32)
+ emit (ICONST_4) = push (4 :: Word32)
+ emit (ICONST_5) = push (5 :: Word32)
emit (ILOAD_ x) = do
push (Disp (cArgs_ x), ebp)
emit (ISTORE_ x) = do
mov (Disp (cArgs_ x), ebp) eax
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 (IINC x imm) = do
add (Disp (cArgs x), ebp) (s8_w32 imm)
pop eax -- value2
pop ebx -- value1
cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
- let sid = case successor bb of TwoTarget _ t -> t
+ let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
let l = getLabel sid lmap
case cond of
C_EQ -> je l; C_NE -> jne l
emit (IF cond _) = do
pop eax -- value1
cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
- let sid = case successor bb of TwoTarget _ t -> t
+ let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
let l = getLabel sid lmap
case cond of
C_EQ -> je l; C_NE -> jne l
C_GE -> jge l; C_LE -> jle l
emit (GOTO _ ) = do
- let sid = case successor bb of OneTarget t -> t
+ let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
jmp $ getLabel sid lmap
- emit (INVOKESTATIC x) = do
- -- TODO(bernhard): get and save information about this call
- -- TODO(bernhard): better try SIGILL instead of SIGSEGV?
- mov (Addr 0) eax
- -- discard arguments (TODO(bernhard): don't hardcode it)
- add esp (4 :: Word32)
- -- push result on stack (TODO(bernhard): if any)
- push eax
+ emit RETURN = do mov esp ebp; pop ebp; ret
emit IRETURN = do
pop eax
mov esp ebp
projects / mate.git / blobdiff