From bc05c4601a08bc81f459b98ac54575fd4b56fb48 Mon Sep 17 00:00:00 2001 From: Bernhard Urban Date: Tue, 31 Jul 2012 22:22:28 +0200 Subject: [PATCH] code style: just different indent --- Mate.hs | 10 +- Mate/BasicBlocks.hs | 199 ++++++++++----------- Mate/ClassPool.hs | 44 ++--- Mate/MethodPool.hs | 34 ++-- Mate/RegisterAllocation.hs | 7 +- Mate/Utilities.hs | 29 ++-- Mate/X86CodeGen.hs | 347 +++++++++++++++++++------------------ 7 files changed, 337 insertions(+), 333 deletions(-) diff --git a/Mate.hs b/Mate.hs index eb3c873..08e7a79 100644 --- a/Mate.hs +++ b/Mate.hs @@ -44,11 +44,11 @@ parseArgs ("-classpath":cps:xs) False = do let paths = splitOn ":" cps mapM_ addStuff paths parseArgs xs True - where - addStuff :: String -> IO () - addStuff x - | ".jar" `isSuffixOf` x = addClassPathJAR x - | otherwise = addClassPath $ x ++ "/" + where + addStuff :: String -> IO () + addStuff x + | ".jar" `isSuffixOf` x = addClassPathJAR x + | otherwise = addClassPath $ x ++ "/" parseArgs ("-classpath":xs) _ = parseArgs ("-":xs) True -- usage parseArgs (('-':_):_) _ = error "Usage: mate [-cp|-classpath ] [ | -jar ]" -- first argument which isn't prefixed by '-' should be a class file diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index 2a8ac22..555f466 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -40,34 +40,34 @@ type OffIns = (Offset, Instruction) #ifdef DBG_BB printMapBB :: MapBB -> IO () printMapBB hmap = do - putStr "BlockIDs: " - let keys = M.keys hmap - mapM_ (putStr . (flip (++)) ", " . show) keys - putStrLn "\n\nBasicBlocks:" - printMapBB' keys hmap - where - printMapBB' :: [BlockID] -> MapBB -> IO () - printMapBB' [] _ = return () - printMapBB' (i:is) hmap' = case M.lookup i hmap' of - Just bb -> do - putStrLn $ "Block " ++ (show i) - mapM_ putStrLn (map ((++) "\t" . show) $ code bb) - case successor bb of - Return -> putStrLn "" - FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" - OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" - TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n" - printMapBB' is hmap - Nothing -> error $ "BlockID " ++ show i ++ " not found." + putStr "BlockIDs: " + let keys = M.keys hmap + mapM_ (putStr . (flip (++)) ", " . show) keys + putStrLn "\n\nBasicBlocks:" + printMapBB' keys hmap + where + printMapBB' :: [BlockID] -> MapBB -> IO () + printMapBB' [] _ = return () + printMapBB' (i:is) hmap' = case M.lookup i hmap' of + Just bb -> do + putStrLn $ "Block " ++ (show i) + mapM_ putStrLn (map ((++) "\t" . show) $ code bb) + case successor bb of + Return -> putStrLn "" + FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" + OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" + TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n" + printMapBB' is hmap + Nothing -> error $ "BlockID " ++ show i ++ " not found." #endif #if 0 #ifdef DBG_BB testInstance :: String -> B.ByteString -> MethodSignature -> IO () testInstance cf method sig = do - cls <- parseClassFile cf - hmap <- parseMethod cls method sig - printMapBB hmap + cls <- parseClassFile cf + hmap <- parseMethod cls method sig + printMapBB hmap #endif #ifdef DBG_BB @@ -89,23 +89,24 @@ test_04 = testInstance "./tests/Fac.class" "fac" parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO (Maybe RawMethod) parseMethod cls method sig = do - let maybe_bb = testCFG $ lookupMethodSig method sig cls - let msig = methodSignature $ classMethods cls !! 1 - printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` encode msig) + let maybe_bb = testCFG $ lookupMethodSig method sig cls + let msig = methodSignature $ classMethods cls !! 1 + printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` encode msig) #ifdef DBG_BB - case maybe_bb of - Just m -> printMapBB $ rawMapBB m - Nothing -> return () + case maybe_bb of + Just m -> printMapBB $ rawMapBB m + Nothing -> return () #endif - -- small example how to get information about - -- exceptions of a method - -- TODO: remove ;-) - let (Just m) = lookupMethodSig method sig cls - case attrByName m "Code" of - Nothing -> printfBb "exception: no handler for this method\n" - Just exceptionstream -> do - printfBb "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream) - return maybe_bb + -- small example how to get information about + -- exceptions of a method + -- TODO: remove ;-) + let (Just m) = lookupMethodSig method sig cls + case attrByName m "Code" of + Nothing -> + printfBb "exception: no handler for this method\n" + Just exceptionstream -> + printfBb "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream) + return maybe_bb testCFG :: Maybe (Method Direct) -> Maybe RawMethod @@ -133,84 +134,84 @@ markBackwardTargets [] = [] markBackwardTargets (x:[]) = [x] markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) = x_new:markBackwardTargets (y:xs) - where - x_new = if isTarget then checkX y_off else x - checkX w16 = case x_bbend of - Just _ -> x -- already marked, don't change - Nothing -> ((x_off, Just $ FallThrough w16), x_ins) -- mark previous insn + where + x_new = if isTarget then checkX y_off else x + checkX w16 = case x_bbend of + Just _ -> x -- already marked, don't change + Nothing -> ((x_off, Just $ FallThrough w16), x_ins) -- mark previous insn - -- look through all remaining insns in the stream if there is a jmp to `y' - isTarget = case find cmpOffset insns of Just _ -> True; Nothing -> False - cmpOffset ((_,Just (OneTarget w16)),_) = w16 == y_off - cmpOffset ((_,Just (TwoTarget _ w16)),_) = w16 == y_off - cmpOffset _ = False + -- look through all remaining insns in the stream if there is a jmp to `y' + isTarget = case find cmpOffset insns of Just _ -> True; Nothing -> False + cmpOffset ((_,Just (OneTarget w16)),_) = w16 == y_off + cmpOffset ((_,Just (TwoTarget _ w16)),_) = w16 == y_off + cmpOffset _ = False buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB buildCFG' hmap [] _ = hmap buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns where - insertlist :: [BlockID] -> MapBB -> MapBB - insertlist [] hmap' = hmap' - insertlist (y:ys) hmap' = insertlist ys newhmap - where - newhmap = if M.member y hmap' then hmap' else M.insert y value hmap' - value = parseBasicBlock y insns - - entryi :: [BlockID] - entryi = if off == 0 then 0:ys else ys -- also consider the entrypoint - where ys = case entry of - Just (TwoTarget t1 t2) -> [t1, t2] - Just (OneTarget t) -> [t] - Just (FallThrough t) -> [t] - Just Return -> [] - Nothing -> [] + insertlist :: [BlockID] -> MapBB -> MapBB + insertlist [] hmap' = hmap' + insertlist (y:ys) hmap' = insertlist ys newhmap + where + newhmap = if M.member y hmap' then hmap' else M.insert y value hmap' + value = parseBasicBlock y insns + entryi :: [BlockID] + entryi = if off == 0 then 0:ys else ys -- also consider the entrypoint + where + ys = case entry of + Just (TwoTarget t1 t2) -> [t1, t2] + Just (OneTarget t) -> [t] + Just (FallThrough t) -> [t] + Just Return -> [] + Nothing -> [] parseBasicBlock :: Int -> [OffIns] -> BasicBlock parseBasicBlock i insns = BasicBlock insonly endblock where - startlist = dropWhile (\((x,_),_) -> x < i) insns - (Just ((_, Just endblock),_), is) = takeWhilePlusOne validins startlist - insonly = snd $ unzip is + startlist = dropWhile (\((x,_),_) -> x < i) insns + (Just ((_, Just endblock),_), is) = takeWhilePlusOne validins startlist + insonly = snd $ unzip is - -- also take last (non-matched) element and return it - takeWhilePlusOne :: (a -> Bool) -> [a] -> (Maybe a,[a]) - takeWhilePlusOne _ [] = (Nothing,[]) - takeWhilePlusOne p (x:xs) - | p x = let (lastins, list) = takeWhilePlusOne p xs in (lastins, x:list) - | otherwise = (Just x,[x]) + -- also take last (non-matched) element and return it + takeWhilePlusOne :: (a -> Bool) -> [a] -> (Maybe a,[a]) + takeWhilePlusOne _ [] = (Nothing,[]) + takeWhilePlusOne p (x:xs) + | p x = let (lastins, list) = takeWhilePlusOne p xs in (lastins, x:list) + | otherwise = (Just x,[x]) - validins :: ((Int, Maybe BBEnd), Instruction) -> Bool - validins ((_,x),_) = case x of Just _ -> False; Nothing -> True + validins :: ((Int, Maybe BBEnd), Instruction) -> Bool + validins ((_,x),_) = case x of Just _ -> False; Nothing -> True calculateInstructionOffset :: [Instruction] -> [OffIns] calculateInstructionOffset = cio' (0, Nothing) where - newoffset :: Instruction -> Int -> Offset - newoffset x off = (off + fromIntegral (B.length $ encodeInstructions [x]), Nothing) - - addW16Signed :: Int -> Word16 -> Int - addW16Signed i w16 = i + fromIntegral s16 - where s16 = fromIntegral w16 :: Int16 - - cio' :: Offset -> [Instruction] -> [OffIns] - cio' _ [] = [] - -- TODO(bernhard): add more instruction with offset (IF_ACMP, JSR, ...) - cio' (off,_) (x:xs) = case x of - IF _ w16 -> twotargets w16 - IF_ICMP _ w16 -> twotargets w16 - IF_ACMP _ w16 -> twotargets w16 - IFNONNULL w16 -> twotargets w16 - IFNULL w16 -> twotargets w16 - GOTO w16 -> onetarget w16 - IRETURN -> notarget - ARETURN -> notarget - RETURN -> notarget - _ -> ((off, Nothing), x):next - where - notarget = ((off, Just Return), x):next - onetarget w16 = ((off, Just $ OneTarget (off `addW16Signed` w16)), x):next - twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next - next = cio' (newoffset x off) xs + newoffset :: Instruction -> Int -> Offset + newoffset x off = (off + fromIntegral (B.length $ encodeInstructions [x]), Nothing) + + addW16Signed :: Int -> Word16 -> Int + addW16Signed i w16 = i + fromIntegral s16 + where s16 = fromIntegral w16 :: Int16 + + cio' :: Offset -> [Instruction] -> [OffIns] + cio' _ [] = [] + -- TODO(bernhard): add more instruction with offset (IF_ACMP, JSR, ...) + cio' (off,_) (x:xs) = case x of + IF _ w16 -> twotargets w16 + IF_ICMP _ w16 -> twotargets w16 + IF_ACMP _ w16 -> twotargets w16 + IFNONNULL w16 -> twotargets w16 + IFNULL w16 -> twotargets w16 + GOTO w16 -> onetarget w16 + IRETURN -> notarget + ARETURN -> notarget + RETURN -> notarget + _ -> ((off, Nothing), x):next + where + notarget = ((off, Just Return), x):next + onetarget w16 = ((off, Just $ OneTarget (off `addW16Signed` w16)), x):next + twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next + next = cio' (newoffset x off) xs diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs index ae6ce44..62eb383 100644 --- a/Mate/ClassPool.hs +++ b/Mate/ClassPool.hs @@ -189,9 +189,9 @@ loadInterface path = do setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap setInterfaceMap $ M.insert path cfile imap' where - zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..] - entry = getname path - getname p y = p `B.append` methodName y `B.append` encode (methodSignature y) + zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..] + entry = getname path + getname p y = p `B.append` methodName y `B.append` encode (methodSignature y) calculateFields :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, FieldMap) @@ -215,8 +215,8 @@ calculateFields cf superclass = do return (staticmap, fieldmap) where - zipbase :: Int32 -> [Field Direct] -> FieldMap - zipbase base = foldr (\(x,y) -> M.insert (fieldName y) (x + base)) M.empty . zip [0,4..] + zipbase :: Int32 -> [Field Direct] -> FieldMap + zipbase base = foldr (\(x,y) -> M.insert (fieldName y) (x + base)) M.empty . zip [0,4..] -- helper getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap @@ -275,23 +275,23 @@ loadAndInitClass path = do readClassFile :: String -> IO (Class Direct) readClassFile path' = readIORef classPaths >>= rcf where - path = replace "." "/" path' - rcf :: [MClassPath] -> IO (Class Direct) - rcf [] = error $ "readClassFile: Class \"" ++ show path ++ "\" not found." - rcf (Directory pre:xs) = do - let cf = pre ++ path ++ ".class" - printfCp "rcf: searching @ %s for %s\n" (show pre) (show path) - b <- doesFileExist cf - if b - then parseClassFile cf - else rcf xs - rcf (JAR p:xs) = do - printfCp "rcf: searching %s in JAR\n" (show path) - entry <- getEntry p path - case entry of - Just (LoadedJAR _ cls) -> return cls - Nothing -> rcf xs - _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1" + path = replace "." "/" path' + rcf :: [MClassPath] -> IO (Class Direct) + rcf [] = error $ "readClassFile: Class \"" ++ show path ++ "\" not found." + rcf (Directory pre:xs) = do + let cf = pre ++ path ++ ".class" + printfCp "rcf: searching @ %s for %s\n" (show pre) (show path) + b <- doesFileExist cf + if b + then parseClassFile cf + else rcf xs + rcf (JAR p:xs) = do + printfCp "rcf: searching %s in JAR\n" (show path) + entry <- getEntry p path + case entry of + Just (LoadedJAR _ cls) -> return cls + Nothing -> rcf xs + _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1" data MClassPath = Directory String | diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index 508ff11..1eccbd2 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -44,12 +44,12 @@ getMethodEntry signal_from methodtable = do let w32_from = fromIntegral signal_from let mi = tmap M.! w32_from let mi'@(MethodInfo method cm sig) = - case mi of - (StaticMethod x) -> x - (VirtualMethod _ (MethodInfo methname _ msig)) -> newMi methname msig - (InterfaceMethod _ (MethodInfo methname _ msig)) -> newMi methname msig - _ -> error "getMethodEntry: no TrapCause found. abort." - where newMi mn = MethodInfo mn (vmap M.! fromIntegral methodtable) + case mi of + (StaticMethod x) -> x + (VirtualMethod _ (MethodInfo methname _ msig)) -> newMi methname msig + (InterfaceMethod _ (MethodInfo methname _ msig)) -> newMi methname msig + _ -> error "getMethodEntry: no TrapCause found. abort." + where newMi mn = MethodInfo mn (vmap M.! fromIntegral methodtable) -- bernhard (TODO): doesn't work with gnu classpath at some point. didn't -- figured out the problem yet :/ therefore, I have no -- testcase for replaying the situation. @@ -96,10 +96,10 @@ lookupMethodRecursive name sig clsnames cls = supercl <- getClassFile (superClass cls) lookupMethodRecursive name sig nextclsn supercl where - res = lookupMethodSig name sig cls - thisname = thisClass cls - nextclsn :: [B.ByteString] - nextclsn = thisname:clsnames + res = lookupMethodSig name sig cls + thisname = thisClass cls + nextclsn :: [B.ByteString] + nextclsn = thisname:clsnames -- TODO(bernhard): UBERHAX. ghc patch? foreign import ccall safe "lookupSymbol" @@ -107,13 +107,13 @@ foreign import ccall safe "lookupSymbol" loadNativeFunction :: String -> IO Word32 loadNativeFunction sym = do - _ <- loadRawObject "ffi/native.o" - -- TODO(bernhard): WTF - resolveObjs (return ()) - ptr <- withCString sym c_lookupSymbol - if ptr == nullPtr - then error $ "dyn. loading of \"" ++ sym ++ "\" failed." - else return $ fromIntegral $ ptrToIntPtr ptr + _ <- loadRawObject "ffi/native.o" + -- TODO(bernhard): WTF + resolveObjs (return ()) + ptr <- withCString sym c_lookupSymbol + if ptr == nullPtr + then error $ "dyn. loading of \"" ++ sym ++ "\" failed." + else return $ fromIntegral $ ptrToIntPtr ptr -- t_01 :: IO () -- t_01 = do diff --git a/Mate/RegisterAllocation.hs b/Mate/RegisterAllocation.hs index 7f220aa..249840a 100644 --- a/Mate/RegisterAllocation.hs +++ b/Mate/RegisterAllocation.hs @@ -27,9 +27,10 @@ edgeEq (from,to) (from',to') = from == from' && to == to' -- TODO: find combinator do match try semantics here -- Solution: use list because list is MonadPlus instance -- other solution add maybe monadplus implementation -conflicts (IGraph xs) (label,anotherLabel) = let comparison = edgeEq (label,anotherLabel) - comparison' = edgeEq (anotherLabel,label) - in isJust (find comparison xs) || isJust (find comparison' xs) +conflicts (IGraph xs) (label,anotherLabel) = + let comparison = edgeEq (label,anotherLabel) + comparison' = edgeEq (anotherLabel,label) + in isJust (find comparison xs) || isJust (find comparison' xs) isParticipiant label (from,to) = from == label || to == label diff --git a/Mate/Utilities.hs b/Mate/Utilities.hs index 565d4b1..fd4fc76 100644 --- a/Mate/Utilities.hs +++ b/Mate/Utilities.hs @@ -14,10 +14,11 @@ import Mate.Types buildMethodID :: Class Direct -> Word16 -> MethodInfo buildMethodID cls idx = MethodInfo (ntName nt) rc (ntSignature nt) - where (rc, nt) = case constsPool cls M.! idx of - (CMethod rc' nt') -> (rc', nt') - (CIfaceMethod rc' nt') -> (rc', nt') - _ -> error "buildMethodID: something wrong. abort." + where + (rc, nt) = case constsPool cls M.! idx of + (CMethod rc' nt') -> (rc', nt') + (CIfaceMethod rc' nt') -> (rc', nt') + _ -> error "buildMethodID: something wrong. abort." buildStaticFieldID :: Class Direct -> Word16 -> StaticFieldInfo buildStaticFieldID cls idx = StaticFieldInfo rc (ntName fnt) @@ -34,11 +35,11 @@ buildClassID cls idx = cl methodGetArgsCount :: Class Direct -> Word16 -> Word32 methodGetArgsCount cls idx = fromIntegral $ length args where - nt = case constsPool cls M.! idx of - (CMethod _ nt') -> nt' - (CIfaceMethod _ nt') -> nt' - _ -> error "methodGetArgsCount: something wrong. abort." - (MethodSignature args _) = ntSignature nt + nt = case constsPool cls M.! idx of + (CMethod _ nt') -> nt' + (CIfaceMethod _ nt') -> nt' + _ -> error "methodGetArgsCount: something wrong. abort." + (MethodSignature args _) = ntSignature nt -- TODO(bernhard): Extend it to more than just int, and provide typeinformation methodHaveReturnValue :: Class Direct -> Word16 -> Bool @@ -51,11 +52,11 @@ methodHaveReturnValue cls idx = case ret of (Returns (ObjectType _)) -> True; _ -> error $ "methodHaveReturnValue: todo: " ++ show ret where - nt = case constsPool cls M.! idx of - (CMethod _ nt') -> nt' - (CIfaceMethod _ nt') -> nt' - _ -> error "methodHaveReturnValue: something wrong. abort." - (MethodSignature _ ret) = ntSignature nt + nt = case constsPool cls M.! idx of + (CMethod _ nt') -> nt' + (CIfaceMethod _ nt') -> nt' + _ -> error "methodHaveReturnValue: something wrong. abort." + (MethodSignature _ ret) = ntSignature nt lookupMethodSig :: B.ByteString -> MethodSignature -> Class Direct -> Maybe (Method Direct) lookupMethodSig name sig cls = diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs index c2c336f..6517d9c 100644 --- a/Mate/X86CodeGen.hs +++ b/Mate/X86CodeGen.hs @@ -47,19 +47,19 @@ 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 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) where hmap = rawMapBB method @@ -69,24 +69,24 @@ 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 @@ -100,32 +100,32 @@ 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) + 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) + -- 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 @@ -134,46 +134,46 @@ emitFromBB methodname sig cls method = do 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) + -- 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) + -- 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' (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' insn = emit insn >> return Nothing emit :: J.Instruction -> CodeGen e s () @@ -183,59 +183,59 @@ emitFromBB methodname sig cls method = do 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 + 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 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 emit (CHECKCAST _) = nop -- TODO(bernhard): ... -- TODO(bernhard): ... emit (INSTANCEOF _) = do @@ -267,23 +267,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 +294,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 +321,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,17 +343,18 @@ emitFromBB methodname sig cls method = do callMalloc :: CodeGen e s () callMalloc = do - call mallocObjectAddr - add esp (4 :: Word32) - push eax + call mallocObjectAddr + add esp (4 :: 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 = + 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 -> Word8 cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3 @@ -362,10 +363,10 @@ emitFromBB methodname sig cls method = do 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 + 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) -- 2.25.1