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"
#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
-- 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'
-- execute class initializer
case lookupMethod "<clinit>" (ciFile ci) of
Just m -> do
- method <- parseMethod (ciFile ci) "<clinit>" $ MethodSignature [] ReturnsVoid
- case method of
- Just rawmethod -> do
- let mi = MethodInfo "<clinit>" 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) "<clinit>" $ MethodSignature [] ReturnsVoid
+ let mi = MethodInfo "<clinit>" 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
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
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
data RawMethod = RawMethod {
rawMapBB :: MapBB,
rawLocals :: Int,
- rawStackSize :: Int }
+ rawStackSize :: Int,
+ rawArgCount :: Word32 }
-- Word32 = point of method call in generated code
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
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
_ -> 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
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
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
-- 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)
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)
-- 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
projects / mate.git / commitdiff