X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FX86CodeGen.hs;h=2c4e70e907289e4c87fd8326e6a66b6802697f64;hb=54a2170d22bb853afa42d87eeeffd8b633efcd36;hp=b33d524f674d5c98e16c791041bc8166226a8db0;hpb=25a042de1d9ae5598ba8bdea33c20aa2cbbb179b;p=mate.git diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs index b33d524..2c4e70e 100644 --- a/Mate/X86CodeGen.hs +++ b/Mate/X86CodeGen.hs @@ -4,8 +4,11 @@ module Mate.X86CodeGen where import Data.Binary import Data.Int +import Data.Maybe import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.ByteString.Lazy as B +import Control.Monad import Foreign import Foreign.C.Types @@ -14,11 +17,15 @@ import Text.Printf import qualified JVM.Assembler as J import JVM.Assembler hiding (Instruction) +import JVM.ClassFile import Harpy import Harpy.X86Disassembler import Mate.BasicBlocks +import Mate.Types +import Mate.Utilities +import Mate.ClassPool foreign import ccall "dynamic" code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt) @@ -26,6 +33,9 @@ foreign import ccall "dynamic" foreign import ccall "getaddr" getaddr :: CUInt +foreign import ccall "getMallocAddr" + getMallocAddr :: CUInt + foreign import ccall "callertrap" callertrap :: IO () @@ -35,7 +45,7 @@ foreign import ccall "register_signal" test_01, test_02, test_03 :: IO () test_01 = do register_signal - (entry, end) <- testCase "./tests/Fib.class" "fib" + (entry, end) <- testCase "./tests/Fib" "fib" let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt)) mapM_ (\x -> do @@ -55,7 +65,7 @@ test_01 = do test_02 = do - (entry,_) <- testCase "./tests/While.class" "f" + (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 @@ -69,7 +79,7 @@ test_02 = do test_03 = do - (entry,_) <- testCase "./tests/While.class" "g" + (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 @@ -82,15 +92,16 @@ test_03 = do printf "result of g(4,3): %3d\t\t%s\n" iresult2 kk2 -testCase :: String -> B.ByteString -> IO (Ptr Word8, Int) +testCase :: B.ByteString -> B.ByteString -> IO (Ptr Word8, Int) testCase cf method = do - hmap <- parseMethod cf method + cls <- getClassFile 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 () () + 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 @@ -105,64 +116,173 @@ type PatchInfo = (BlockID, EntryPointOffset) type BBStarts = M.Map BlockID Int -type CompileInfo = (EntryPoint, BBStarts, Int) +type CompileInfo = (EntryPoint, BBStarts, Int, TMap) + -emitFromBB :: MapBB -> CodeGen e s (CompileInfo, [Instruction]) -emitFromBB hmap = do +emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction]) +emitFromBB method 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): determine a reasonable value. + -- e.g. (locals used) * 4 + sub esp (0x60 :: Word32) - -- TODO(bernhard): remove me. just for PoC here - 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) -> TMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TMap, 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 + getCurrentOffset :: CodeGen e s (Word32) + getCurrentOffset = do + ep <- getEntryPoint + let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32 + offset <- getCodeOffset + return $ w32_ep + (fromIntegral offset) + + emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo)) + 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) + return $ Just $ (calladdr, MI l) + + emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo)) + emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True + emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False + 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) + let offset = unsafePerformIO $ getMethodOffset objname nameAndSig + -- make actual (indirect) call + calladdr <- getCurrentOffset + call (Disp offset, eax) + -- 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, VI mi) + emit' (PUTSTATIC cpidx) = do + pop eax + trapaddr <- getCurrentOffset + mov (Addr 0x00000000) eax -- it's a trap + return $ Just $ (trapaddr, SFI $ 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) + 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) + add esp (4 :: Word32) + emit DUP = push (Disp 0, esp) + emit (NEW objidx) = do + let objname = buildClassID cls objidx + let amount = unsafePerformIO $ getMethodSize 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 + -- TODO(bernhard): save reference somewhere for GC + -- set method table pointer + let mtable = unsafePerformIO $ getMethodTable objname + mov (Disp 0, eax) mtable + emit (CHECKCAST _) = nop -- TODO(bernhard): ... + 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 (ALOAD_ x) = emit (ILOAD_ x) emit (ILOAD_ x) = do push (Disp (cArgs_ x), ebp) + emit (ALOAD x) = emit (ILOAD x) + emit (ILOAD x) = do + push (Disp (cArgs x), ebp) + emit (ASTORE_ x) = emit (ISTORE_ x) emit (ISTORE_ x) = do pop eax mov (Disp (cArgs_ x), ebp) eax + emit (ASTORE x) = emit (ISTORE x) + emit (ISTORE x) = do + pop eax + mov (Disp (cArgs x), ebp) eax + + emit (GETFIELD x) = do + pop eax -- this pointer + let (cname, fname) = buildFieldOffset cls x + let offset = unsafePerformIO $ getFieldOffset cname fname + push (Disp (fromIntegral $ offset * 4), eax) -- get field + emit (PUTFIELD x) = do + pop ebx -- value to write + pop eax -- this pointer + let (cname, fname) = buildFieldOffset cls x + let offset = unsafePerformIO $ getFieldOffset cname fname + mov (Disp (fromIntegral $ offset * 4), 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 (IINC x imm) = do add (Disp (cArgs x), ebp) (s8_w32 imm) @@ -190,24 +310,35 @@ emitFromBB hmap = do emit (GOTO _ ) = do let sid = case successor bb of OneTarget t -> t; _ -> error "bad" jmp $ getLabel sid lmap - emit (INVOKESTATIC _) = 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 pop ebp ret - emit _ = do cmovbe eax eax -- dummy + emit invalid = error $ "insn not implemented yet: " ++ (show invalid) + + -- 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_ :: IMM -> Word32 + cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3 + + thisMethodArgCnt :: Word32 + thisMethodArgCnt = isNonStatic + (fromIntegral $ length args) + where + (Just m) = lookupMethod method cls + (MethodSignature args _) = methodSignature m + isNonStatic = if S.member ACC_STATIC (methodAccessFlags m) + then 0 + else 1 -- one argument for the this pointer - cArgs x = (8 + 4 * (fromIntegral x)) - cArgs_ x = (8 + 4 * case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3) -- sign extension from w8 to w32 (over s8) -- unfortunately, hs-java is using Word8 everywhere (while