From 03ddf0056a8ebae7ce10d694bbf906c276677a33 Mon Sep 17 00:00:00 2001 From: Bernhard Urban Date: Tue, 31 Jul 2012 22:22:28 +0200 Subject: [PATCH] refactor: store amount of arguments of a method in RawMethod also kick `Maybe' at parseMethod in BasicBlock. It's just annoying to unpack it from Maybe everywhere. Just fail @ parseMethod if we don't find the codeseg --- Mate.hs | 13 +++++-------- Mate/BasicBlocks.hs | 38 ++++++++++++++++++++++---------------- Mate/ClassPool.hs | 17 +++++++---------- Mate/MethodPool.hs | 13 +++++-------- Mate/Types.hs | 3 ++- Mate/Utilities.hs | 27 +++++++++++++++++++-------- Mate/X86CodeGen.hs | 28 ++++++++++------------------ 7 files changed, 70 insertions(+), 69 deletions(-) diff --git a/Mate.hs b/Mate.hs index 08e7a79..4664ff1 100644 --- a/Mate.hs +++ b/Mate.hs @@ -66,14 +66,11 @@ executeMain bclspath cls = do case find (\x -> methodName x == "main") methods of Just m -> do let mi = MethodInfo "main" bclspath $ methodSignature m - hmap <- parseMethod cls "main" $ methodSignature m - case hmap of - Just hmap' -> do - entry <- compileBB hmap' mi - addMethodRef entry mi [bclspath] + rawmethod <- parseMethod cls "main" $ methodSignature m + entry <- compileBB rawmethod mi + addMethodRef entry mi [bclspath] #ifdef DEBUG - printf "executing `main' now:\n" + printf "executing `main' now:\n" #endif - executeFuncPtr entry - Nothing -> error "main not found" + executeFuncPtr entry Nothing -> error "main not found" diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index 555f466..d863f55 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -87,11 +87,25 @@ test_04 = testInstance "./tests/Fac.class" "fac" #endif -parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO (Maybe RawMethod) -parseMethod cls method sig = do - let maybe_bb = testCFG $ lookupMethodSig method sig cls +parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod +parseMethod cls methodname sig = do + let method = case lookupMethodSig methodname sig cls of + Just m -> m + Nothing -> error $ "method " ++ (show . toString) methodname ++ " not found" + let codeseg = case attrByName method "Code" of + Just m -> m + Nothing -> error $ "codeseg " ++ (show . toString) methodname ++ " not found" + let decoded = decodeMethod codeseg + let mapbb = testCFG decoded + let locals = fromIntegral (codeMaxLocals decoded) + let stacks = fromIntegral (codeStackSize decoded) + let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls + let isStatic = methodIsStatic methoddirect + let nametype = methodNameType methoddirect + let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1) + let msig = methodSignature $ classMethods cls !! 1 - printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` encode msig) + printfBb "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig) #ifdef DBG_BB case maybe_bb of Just m -> printMapBB $ rawMapBB m @@ -100,25 +114,17 @@ parseMethod cls method sig = do -- small example how to get information about -- exceptions of a method -- TODO: remove ;-) - let (Just m) = lookupMethodSig method sig cls + let (Just m) = lookupMethodSig methodname 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 + return $ RawMethod mapbb locals stacks argscount -testCFG :: Maybe (Method Direct) -> Maybe RawMethod -testCFG m = do - m' <- m - codeseg <- attrByName m' "Code" - let decoded = decodeMethod codeseg - let mapbb = buildCFG $ codeInstructions decoded - let locals = fromIntegral (codeMaxLocals decoded) - let stacks = fromIntegral (codeStackSize decoded) - return $ RawMethod mapbb locals stacks - +testCFG :: Code -> MapBB +testCFG = buildCFG . codeInstructions buildCFG :: [Instruction] -> MapBB buildCFG xs = buildCFG' M.empty xs' xs' diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs index 62eb383..ad29054 100644 --- a/Mate/ClassPool.hs +++ b/Mate/ClassPool.hs @@ -254,16 +254,13 @@ loadAndInitClass path = do -- execute class initializer case lookupMethod "" (ciFile ci) of Just m -> do - method <- parseMethod (ciFile ci) "" $ MethodSignature [] ReturnsVoid - case method of - Just rawmethod -> do - let mi = MethodInfo "" path (methodSignature m) - entry <- compileBB rawmethod mi - addMethodRef entry mi [path] - printfCp "executing static initializer from %s now\n" (toString path) - executeFuncPtr entry - printfCp "static initializer from %s done\n" (toString path) - Nothing -> error "readClass: static initializer not found (WTF?). abort" + rawmethod <- parseMethod (ciFile ci) "" $ MethodSignature [] ReturnsVoid + let mi = MethodInfo "" path (methodSignature m) + entry <- compileBB rawmethod mi + addMethodRef entry mi [path] + printfCp "executing static initializer from %s now\n" (toString path) + executeFuncPtr entry + printfCp "static initializer from %s done\n" (toString path) Nothing -> return () class_map' <- getClassMap diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index 1eccbd2..5f787a2 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -74,13 +74,10 @@ getMethodEntry signal_from methodtable = do setMethodMap $ M.insert mi' nf mmap return nf else do - hmap <- parseMethod cls' method sig - case hmap of - Just hmap' -> do - entry <- compileBB hmap' (MethodInfo method (thisClass cls') sig) - addMethodRef entry mi' clsnames - return $ fromIntegral entry - Nothing -> error $ show method ++ " not found. abort" + rawmethod <- parseMethod cls' method sig + entry <- compileBB rawmethod (MethodInfo method (thisClass cls') sig) + addMethodRef entry mi' clsnames + return $ fromIntegral entry Nothing -> error $ show method ++ " not found. abort" Just w32 -> return w32 return $ fromIntegral entryaddr @@ -136,7 +133,7 @@ compileBB rawmethod methodinfo = do tmap <- getTrapMap cls <- getClassFile (methClassName methodinfo) - let ebb = emitFromBB (methName methodinfo) (methSignature methodinfo) cls rawmethod + let ebb = emitFromBB cls rawmethod (_, Right right) <- runCodeGen ebb () () let ((entry, _, _, new_tmap), _) = right diff --git a/Mate/Types.hs b/Mate/Types.hs index 1978bb3..1f67aa6 100644 --- a/Mate/Types.hs +++ b/Mate/Types.hs @@ -28,7 +28,8 @@ type MapBB = M.Map BlockID BasicBlock data RawMethod = RawMethod { rawMapBB :: MapBB, rawLocals :: Int, - rawStackSize :: Int } + rawStackSize :: Int, + rawArgCount :: Word32 } -- Word32 = point of method call in generated code diff --git a/Mate/Utilities.hs b/Mate/Utilities.hs index fd4fc76..da07ecf 100644 --- a/Mate/Utilities.hs +++ b/Mate/Utilities.hs @@ -4,8 +4,10 @@ module Mate.Utilities where import Data.Word import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.ByteString.Lazy as B import Data.List +import Data.Maybe import JVM.ClassFile @@ -32,14 +34,16 @@ buildClassID :: Class Direct -> Word16 -> B.ByteString buildClassID cls idx = cl where (CClass cl) = constsPool cls M.! idx -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 + +methodNameTypeByIdx :: Class Direct -> Word16 -> NameType (Method Direct) +methodNameTypeByIdx cls idx = case constsPool cls M.! idx of + (CMethod _ nt') -> nt' + (CIfaceMethod _ nt') -> nt' + _ -> error "methodGetArgsCount: something wrong. abort." + +methodGetArgsCount :: NameType (Method Direct) -> Word32 +methodGetArgsCount nt = genericLength args + where (MethodSignature args _) = ntSignature nt -- TODO(bernhard): Extend it to more than just int, and provide typeinformation methodHaveReturnValue :: Class Direct -> Word16 -> Bool @@ -58,6 +62,13 @@ methodHaveReturnValue cls idx = case ret of _ -> error "methodHaveReturnValue: something wrong. abort." (MethodSignature _ ret) = ntSignature nt +methodInfoToMethod :: MethodInfo -> Class Direct -> Method Direct +methodInfoToMethod mi cls = + fromJust $ lookupMethodSig (methName mi) (methSignature mi) cls + +methodIsStatic :: Method Direct -> Bool +methodIsStatic = S.member ACC_STATIC . methodAccessFlags + lookupMethodSig :: B.ByteString -> MethodSignature -> Class Direct -> Maybe (Method Direct) lookupMethodSig name sig cls = find (\x -> methodName x == name && methodSignature x == sig) $ classMethods cls diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs index 6517d9c..df39e5f 100644 --- a/Mate/X86CodeGen.hs +++ b/Mate/X86CodeGen.hs @@ -10,7 +10,6 @@ import Data.BinaryState 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 @@ -46,8 +45,8 @@ type BBStarts = M.Map BlockID Int type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap) -emitFromBB :: B.ByteString -> MethodSignature -> Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction]) -emitFromBB methodname sig cls method = do +emitFromBB :: Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction]) +emitFromBB cls method = do let keys = M.keys hmap llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys let lmap = zip keys llmap @@ -107,7 +106,7 @@ emitFromBB methodname sig cls method = do -- 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 + let argcnt = ((if hasThis then 1 else 0) + (methodGetArgsCount $ methodNameTypeByIdx 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) @@ -120,7 +119,7 @@ emitFromBB methodname sig cls method = do calladdr <- getCurrentOffset call (Disp offset, eax) -- discard arguments on stack (+4 for "this") - let argcnt = 4 + 4 * methodGetArgsCount cls cpidx + let argcnt = 4 + 4 * (methodGetArgsCount $ methodNameTypeByIdx cls cpidx) when (argcnt > 0) (add esp argcnt) -- push result on stack if method has a return value when (methodHaveReturnValue cls cpidx) (push eax) @@ -350,24 +349,17 @@ emitFromBB methodname sig cls method = do -- for locals we use a different storage cArgs :: Word8 -> Word32 cArgs x = - if x' >= thisMethodArgCnt + if x' >= argcount -- TODO(bernhard): maybe s/(-4)/(-8)/ - then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1) - else 4 + (thisMethodArgCnt * 4) - (4 * x') - where x' = fromIntegral x + then (-4) * (x' - argcount + 1) + else 4 + (argcount * 4) - (4 * x') + where + x' = fromIntegral x + argcount = rawArgCount method 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 - 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) -- unfortunately, hs-java is using Word8 everywhere (while -- 2.25.1