case hmap of
Just hmap' -> do
let methods = classMethods cls; methods :: [Method Resolved]
- let method = find (\x -> (methodName x) == "main") methods
+ let method = find (\x -> methodName x == "main") methods
case method of
Just m -> do
- let mi = (MethodInfo "main" bclspath (methodSignature m))
+ let mi = MethodInfo "main" bclspath $ methodSignature m
entry <- compileBB hmap' mi
addMethodRef entry mi [bclspath]
#ifdef DEBUG
parseMethod :: Class Resolved -> B.ByteString -> IO (Maybe MapBB)
parseMethod cls method = do
let maybe_bb = testCFG $ lookupMethod method cls
- let msig = methodSignature $ (classMethods cls) !! 1
- printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` (encode msig))
+ let msig = methodSignature $ classMethods cls !! 1
+ printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` encode msig)
#ifdef DBG_BB
printMapBB maybe_bb
#endif
markBackwardTargets [] = []
markBackwardTargets (x:[]) = [x]
markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) =
- (x_new):(markBackwardTargets (y:xs))
+ x_new:markBackwardTargets (y:xs)
where
x_new = if isTarget then checkX y_off else x
checkX w16 = case x_bbend of
-- 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 ((_,Just (OneTarget w16)),_) = w16 == y_off
+ cmpOffset ((_,Just (TwoTarget _ w16)),_) = w16 == y_off
cmpOffset _ = False
value = parseBasicBlock y insns
entryi :: [BlockID]
- entryi = (if off == 0 then [0] else []) ++ -- also consider the entrypoint
- case entry of
- Just (TwoTarget t1 t2) -> [t1, t2]
- Just (OneTarget t) -> [t]
- Just (FallThrough t) -> [t]
- Just (Return) -> []
- Nothing -> []
+ 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
+ (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))
+ | p x = let (lastins, list) = takeWhilePlusOne p xs in (lastins, x:list)
| otherwise = (Just x,[x])
validins :: ((Int, Maybe BBEnd), Instruction) -> Bool
calculateInstructionOffset = cio' (0, Nothing)
where
newoffset :: Instruction -> Int -> Offset
- newoffset x off = (off + (fromIntegral $ B.length $ encodeInstructions [x]), Nothing)
+ 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
+ addW16Signed i w16 = i + fromIntegral s16
+ where s16 = fromIntegral w16 :: Int16
cio' :: Offset -> [Instruction] -> [OffIns]
cio' _ [] = []
_ -> ((off, Nothing), x):next
where
notarget = ((off, Just Return), x):next
- onetarget w16 = ((off, Just $ OneTarget $ (off `addW16Signed` w16)), 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
ci <- getClassInfo path
return $ ciFile ci
-getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
+getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO CUInt
getStaticFieldOffset path field = do
ci <- getClassInfo path
- return $ fromIntegral $ (ciStaticMap ci) M.! field
+ return $ fromIntegral $ ciStaticMap ci M.! field
-getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
+getFieldOffset :: B.ByteString -> B.ByteString -> IO Int32
getFieldOffset path field = do
ci <- getClassInfo path
- return $ (ciFieldMap ci) M.! field
+ return $ ciFieldMap ci M.! field
-- method + signature plz!
-getMethodOffset :: B.ByteString -> B.ByteString -> IO (Word32)
+getMethodOffset :: B.ByteString -> B.ByteString -> IO Word32
getMethodOffset path method = do
ci <- getClassInfo path
-- (4+) one slot for "interface-table-ptr"
- return $ (+4) $ fromIntegral $ (ciMethodMap ci) M.! method
+ return $ (+4) $ fromIntegral $ ciMethodMap ci M.! method
-getMethodTable :: B.ByteString -> IO (Word32)
+getMethodTable :: B.ByteString -> IO Word32
getMethodTable path = do
ci <- getClassInfo path
return $ ciMethodBase ci
-getObjectSize :: B.ByteString -> IO (Word32)
+getObjectSize :: B.ByteString -> IO Word32
getObjectSize path = do
ci <- getClassInfo path
-- TODO(bernhard): correct sizes for different types...
let w32_from = fromIntegral from
let sfi = trapmap M.! w32_from
case sfi of
- (SFI (StaticFieldInfo cls field)) -> do
- getStaticFieldOffset cls field
- _ -> error $ "getFieldAddr: no trapInfo. abort"
+ (SFI (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field
+ _ -> error "getFieldAddr: no trapInfo. abort"
-- interface + method + signature plz!
-getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO (Word32)
+getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO Word32
getInterfaceMethodOffset ifname meth sig = do
loadInterface ifname
ifmmap <- get_interfacemethodmap >>= ptr2interfacemethodmap
let k = ifname `B.append` meth `B.append` sig
case M.lookup k ifmmap of
- Just w32 -> return $ (+4) w32
- Nothing -> error $ "getInterfaceMethodOffset: no offset set"
+ Just w32 -> return $ w32 + 4
+ Nothing -> error "getInterfaceMethodOffset: no offset set"
loadClass :: B.ByteString -> IO ClassInfo
#endif
-- load all interfaces, which are implemented by this class
sequence_ [ loadInterface i | i <- interfaces cfile ]
- superclass <- case (path /= "java/lang/Object") of
- True -> do
+ superclass <- if path /= "java/lang/Object"
+ then do
sc <- loadClass $ superClass cfile
- return $ Just $ sc
- False -> return $ Nothing
+ return $ Just sc
+ else return Nothing
(staticmap, fieldmap) <- calculateFields cfile superclass
(methodmap, mbase) <- calculateMethodMap cfile superclass
-- load map again, because there could be new entries now
-- due to loading superinterfaces
imap' <- get_interfacesmap >>= ptr2interfacesmap
- let max_off = fromIntegral $ (M.size immap) * 4
+ let max_off = fromIntegral $ M.size immap * 4
-- create index of methods by this interface
let mm = zipbase max_off (classMethods cfile)
-- create for each method from *every* superinterface a entry to,
-- but just put in the same offset as it is already in the map
- let (ifnames, methodnames) = unzip $ concat $
+ let (ifnames, methodnames) = unzip $ concat
[ zip (repeat ifname) (classMethods $ imap' M.! ifname)
| ifname <- interfaces cfile ]
- let sm = zipWith (\x y -> (entry y, immap M.! (getname x y))) ifnames methodnames
+ let sm = zipWith (\x y -> (entry y, immap M.! getname x y)) ifnames methodnames
-- merge all offset tables
- let methodmap = (M.fromList sm) `M.union` (M.fromList mm) `M.union` immap
+ let methodmap = M.fromList sm `M.union` M.fromList mm `M.union` immap
interfacemethodmap2ptr methodmap >>= set_interfacemethodmap
interfacesmap2ptr (M.insert path cfile imap') >>= set_interfacesmap
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)
+ getname p y = p `B.append` methodName y `B.append` encode (methodSignature y)
calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
- staticbase <- mallocClassData ((fromIntegral $ length sfields) * 4)
- let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
+ staticbase <- mallocClassData $ fromIntegral (length sfields) * 4
+ let i_sb = fromIntegral $ ptrToIntPtr staticbase
let sm = zipbase i_sb sfields
let sc_sm = getsupermap superclass ciStaticMap
-- new fields "overwrite" old ones, if they have the same name
- let staticmap = (M.fromList sm) `M.union` sc_sm
+ let staticmap = M.fromList sm `M.union` sc_sm
let sc_im = getsupermap superclass ciFieldMap
-- "+ 4" for the method table pointer
- let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
+ let max_off = (4+) $ fromIntegral $ M.size sc_im * 4
let im = zipbase max_off ifields
-- new fields "overwrite" old ones, if they have the same name
- let fieldmap = (M.fromList im) `M.union` sc_im
+ let fieldmap = M.fromList im `M.union` sc_im
return (staticmap, fieldmap)
where
((/=) "<init>" . methodName) x)
(classMethods cf)
let sc_mm = getsupermap superclass ciMethodMap
- let max_off = fromIntegral $ (M.size sc_mm) * 4
+ let max_off = fromIntegral $ M.size sc_mm * 4
let mm = zipbase max_off methods
- let methodmap = (M.fromList mm) `M.union` sc_mm
+ let methodmap = M.fromList mm `M.union` sc_mm
-- (+1): one slot for the interface-table-ptr
methodbase <- mallocClassData (((+1) $ fromIntegral $ M.size methodmap) * 4)
- return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
+ return (methodmap, fromIntegral $ ptrToIntPtr methodbase)
where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
- where entry y = (methodName y) `B.append` (encode $ methodSignature y)
+ where entry y = methodName y `B.append` encode (methodSignature y)
loadAndInitClass :: B.ByteString -> IO ClassInfo
Just x -> return x
-- first try to execute class initializer of superclass
- when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
+ when (path /= "java/lang/Object") (void $ loadAndInitClass $ superClass $ ciFile ci)
-- execute class initializer
case lookupMethod "<clinit>" (ciFile ci) of
hmap <- parseMethod (ciFile ci) "<clinit>"
case hmap of
Just hmap' -> do
- let mi = (MethodInfo "<clinit>" path (methodSignature m))
+ let mi = MethodInfo "<clinit>" path (methodSignature m)
entry <- compileBB hmap' 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 $ "loadClass: static initializer not found (WTF?). abort"
+ Nothing -> error "loadClass: static initializer not found (WTF?). abort"
Nothing -> return ()
class_map' <- get_classmap >>= ptr2classmap
varFake _ = return undefined
instance (Show a, VarArgsFake r) => VarArgsFake (a -> r) where
- varFake _ = \_ -> varFake []
+ varFake _ _ = varFake []
printfFake :: String -> (VarArgsFake t) => t
printfFake _ = varFake []
import Mate.Debug
foreign import ccall "dynamic"
- code_void :: FunPtr (IO ()) -> (IO ())
+ code_void :: FunPtr (IO ()) -> IO ()
foreign export ccall getTrapType :: CUInt -> CUInt -> IO CUInt
getTrapType :: CUInt -> CUInt -> IO CUInt
Nothing -> case M.lookup (fromIntegral from2) tmap of
(Just (VI _)) -> return 1
(Just (II _)) -> return 4
- (Just _) -> error $ "getTrapType: abort #1 :-("
- Nothing -> error $ "getTrapType: abort #2 :-("
+ (Just _) -> error "getTrapType: abort #1 :-("
+ Nothing -> error "getTrapType: abort #2 :-("
foreign export ccall getMethodEntry :: CUInt -> CUInt -> IO CUInt
getMethodEntry :: CUInt -> CUInt -> IO CUInt
case mi of
(MI x) -> x
(VI (MethodInfo methname _ msig)) ->
- (MethodInfo methname (vmap M.! (fromIntegral methodtable)) msig)
+ MethodInfo methname (vmap M.! fromIntegral methodtable) msig
(II (MethodInfo methname _ msig)) ->
- (MethodInfo methname (vmap M.! (fromIntegral methodtable)) msig)
- _ -> error $ "getMethodEntry: no trapInfo. abort."
+ MethodInfo methname (vmap M.! fromIntegral methodtable) msig
+ _ -> error "getMethodEntry: no trapInfo. abort."
case M.lookup mi' mmap of
Nothing -> do
cls <- getClassFile cm
case mm of
Just (mm', clsnames, cls') -> do
let flags = methodAccessFlags mm'
- case S.member ACC_NATIVE flags of
- False -> do
- hmap <- parseMethod cls' method
- 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"
- True -> do
+ if S.member ACC_NATIVE flags
+ then do
-- TODO(bernhard): cleaner please... *do'h*
- let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace ";" "_" $ replace "/" "_" $ replace "(" "_" (replace ")" "_" $ toString $ encode sig))
+ let sym1 = replace "/" "_" $ toString cm
+ parenth = replace "(" "_" $ replace ")" "_" $ toString $ encode sig
+ sym2 = replace ";" "_" $ replace "/" "_" parenth
+ symbol = sym1 ++ "__" ++ toString method ++ "__" ++ sym2
printfMp "native-call: symbol: %s\n" symbol
nf <- loadNativeFunction symbol
let w32_nf = fromIntegral nf
let mmap' = M.insert mi' w32_nf mmap
methodmap2ptr mmap' >>= set_methodmap
return nf
- Nothing -> error $ (show method) ++ " not found. abort"
+ else do
+ hmap <- parseMethod cls' method
+ 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"
+ Nothing -> error $ show method ++ " not found. abort"
Just w32 -> return (fromIntegral w32)
lookupMethodRecursive :: B.ByteString -> [B.ByteString] -> Class Resolved
- -> IO (Maybe ((Method Resolved, [B.ByteString], Class Resolved)))
-lookupMethodRecursive name clsnames cls = do
+ -> IO (Maybe (Method Resolved, [B.ByteString], Class Resolved))
+lookupMethodRecursive name clsnames cls =
case res of
Just x -> return $ Just (x, nextclsn, cls)
Nothing -> if thisname == "java/lang/Object"
- then return $ Nothing
+ then return Nothing
else do
supercl <- getClassFile (superClass cls)
lookupMethodRecursive name nextclsn supercl
foreign import ccall safe "lookupSymbol"
c_lookupSymbol :: CString -> IO (Ptr a)
-loadNativeFunction :: String -> IO (CUInt)
+loadNativeFunction :: String -> IO CUInt
loadNativeFunction sym = do
_ <- loadRawObject "ffi/native.o"
-- TODO(bernhard): WTF
resolveObjs (return ())
ptr <- withCString sym c_lookupSymbol
- if (ptr == nullPtr)
+ if ptr == nullPtr
then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
else return $ fromIntegral $ ptrToIntPtr ptr
addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO ()
addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
mmap <- get_methodmap >>= ptr2methodmap
- let newmap = M.fromList $ map (\x -> ((MethodInfo mmname x msig), entry)) clsnames
+ let newmap = M.fromList $ map (\x -> (MethodInfo mmname x msig, entry)) clsnames
methodmap2ptr (mmap `M.union` newmap) >>= set_methodmap
(_, Right right) <- runCodeGen ebb () ()
let ((entry, _, _, new_tmap), _) = right
- let tmap' = M.union tmap new_tmap -- prefers elements in cmap
+ let tmap' = tmap `M.union` new_tmap -- prefers elements in tmap
trapmap2ptr tmap' >>= set_trapmap
printfJit "generated code of \"%s\":\n" (toString $ methName methodinfo)
executeFuncPtr :: Word32 -> IO ()
executeFuncPtr entry =
- code_void $ ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))
+ code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))
degree g@(IGraph xs) label = count (isParticipiant label) xs
-doChaitin81 :: (Eq a) => IArchitecture -> (IGraph a) -> [Assignment a]
+doChaitin81 :: (Eq a) => IArchitecture -> IGraph a -> [Assignment a]
doChaitin81 numberOfRegisters graph = []
type IState a = ([a],IGraph a)
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
#include "debug.h"
module Mate.Strings (
getUniqueStringAddr
allocateJavaString str = do
-- TODO(bernhard): is this also true for UTF8 stuff?
let strlen = fromIntegral $ B.length str
- arr <- newArray $ ((map fromIntegral $ B.unpack str) :: [Word8])
+ arr <- newArray ((map fromIntegral $ B.unpack str) :: [Word8])
-- (+1) for \0
newstr <- mallocString (strlen + 1)
BI.memset newstr 0 (fromIntegral $ strlen + 1)
instance Ord MethodSignature where
compare (MethodSignature args_a ret_a) (MethodSignature args_b ret_b)
| cmp_args /= EQ = cmp_args
- | otherwise = (show ret_a) `compare` (show ret_b)
- where
- cmp_args = (show args_a) `compare` (show args_b)
+ | otherwise = show ret_a `compare` show ret_b
+ where cmp_args = show args_a `compare` show args_b
instance Show MethodInfo where
show (MethodInfo method c sig) =
- (toString c) ++ "." ++ (toString method) ++ "." ++ (show sig)
+ toString c ++ "." ++ toString method ++ "." ++ show sig
return $ castStablePtrToPtr ptr_methodmap
ptr2methodmap :: Ptr () -> IO MethodMap
-ptr2methodmap methodmap = deRefStablePtr $ ((castPtrToStablePtr methodmap) :: StablePtr MethodMap)
+ptr2methodmap methodmap = deRefStablePtr (castPtrToStablePtr methodmap :: StablePtr MethodMap)
trapmap2ptr :: TrapMap -> IO (Ptr ())
trapmap2ptr trapmap = do
return $ castStablePtrToPtr ptr_trapmap
ptr2trapmap :: Ptr () -> IO TrapMap
-ptr2trapmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr trapmap)
+ptr2trapmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr trapmap)
classmap2ptr :: ClassMap -> IO (Ptr ())
classmap2ptr cmap = do
return $ castStablePtrToPtr ptr_cmap
ptr2classmap :: Ptr () -> IO ClassMap
-ptr2classmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)
+ptr2classmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
virtualmap2ptr :: VirtualMap -> IO (Ptr ())
virtualmap2ptr cmap = do
return $ castStablePtrToPtr ptr_cmap
ptr2virtualmap :: Ptr () -> IO VirtualMap
-ptr2virtualmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)
+ptr2virtualmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
stringsmap2ptr :: StringsMap -> IO (Ptr ())
return $ castStablePtrToPtr ptr_cmap
ptr2stringsmap :: Ptr () -> IO StringsMap
-ptr2stringsmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)
+ptr2stringsmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
interfacesmap2ptr :: InterfacesMap -> IO (Ptr ())
return $ castStablePtrToPtr ptr_cmap
ptr2interfacesmap :: Ptr () -> IO InterfacesMap
-ptr2interfacesmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)
+ptr2interfacesmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
interfacemethodmap2ptr :: InterfaceMethodMap -> IO (Ptr ())
return $ castStablePtrToPtr ptr_cmap
ptr2interfacemethodmap :: Ptr () -> IO InterfaceMethodMap
-ptr2interfacemethodmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)
+ptr2interfacemethodmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
buildMethodID :: Class Resolved -> Word16 -> MethodInfo
buildMethodID cls idx = MethodInfo (ntName nt) rc (ntSignature nt)
- where (rc, nt) = case (constsPool cls) M.! idx of
+ where (rc, nt) = case constsPool cls M.! idx of
(CMethod rc' nt') -> (rc', nt')
(CIfaceMethod rc' nt') -> (rc', nt')
- _ -> error $ "buildMethodID: something wrong. abort."
+ _ -> error "buildMethodID: something wrong. abort."
buildStaticFieldID :: Class Resolved -> Word16 -> StaticFieldInfo
buildStaticFieldID cls idx = StaticFieldInfo rc (ntName fnt)
- where (CField rc fnt) = (constsPool cls) M.! idx
+ where (CField rc fnt) = constsPool cls M.! idx
buildFieldOffset :: Class Resolved -> Word16 -> (B.ByteString, B.ByteString)
buildFieldOffset cls idx = (rc, ntName fnt)
- where (CField rc fnt) = (constsPool cls) M.! idx
+ where (CField rc fnt) = constsPool cls M.! idx
buildClassID :: Class Resolved -> Word16 -> B.ByteString
buildClassID cls idx = cl
- where (CClass cl) = (constsPool cls) M.! idx
+ where (CClass cl) = constsPool cls M.! idx
methodGetArgsCount :: Class Resolved -> Word16 -> Word32
methodGetArgsCount cls idx = fromIntegral $ length args
where
- nt = case (constsPool cls) M.! idx of
+ nt = case constsPool cls M.! idx of
(CMethod _ nt') -> nt'
(CIfaceMethod _ nt') -> nt'
- _ -> error $ "methodGetArgsCount: something wrong. abort."
+ _ -> error "methodGetArgsCount: something wrong. abort."
(MethodSignature args _) = ntSignature nt
-- TODO(bernhard): Extend it to more than just int, and provide typeinformation
(Returns (ObjectType _)) -> True;
_ -> error "methodHaveReturnValue: todo"
where
- nt = case (constsPool cls) M.! idx of
+ nt = case constsPool cls M.! idx of
(CMethod _ nt') -> nt'
(CIfaceMethod _ nt') -> nt'
- _ -> error $ "methodHaveReturnValue: something wrong. abort."
+ _ -> error "methodHaveReturnValue: something wrong. abort."
(MethodSignature _ ret) = ntSignature nt
foreign import ccall "dynamic"
- code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
+ code_int :: FunPtr (CInt -> CInt -> IO CInt) -> CInt -> CInt -> IO CInt
foreign import ccall "getMallocObjectAddr"
getMallocObjectAddr :: CUInt
-- e.g. (locals used) * 4
sub esp (0x60 :: Word32)
- (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
+ (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
d <- disassemble
end <- getCodeOffset
return ((ep, bbstarts, end, calls), d)
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)
+ let calls' = calls `M.union` M.fromList (catMaybes cs)
case successor bb of
Return -> return (calls', bbstarts')
- FallThrough t -> do
- efBB (t, hmap M.! t) calls' bbstarts' lmap
- OneTarget t -> do
- efBB (t, hmap M.! t) calls' bbstarts' lmap
+ FallThrough t -> 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): implement `emit' as function which accepts a list of
-- instructions, so we can use patterns for optimizations
where
- getCurrentOffset :: CodeGen e s (Word32)
+ getCurrentOffset :: CodeGen e s Word32
getCurrentOffset = do
ep <- getEntryPoint
let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
offset <- getCodeOffset
- return $ w32_ep + (fromIntegral offset)
+ return $ w32_ep + fromIntegral offset
emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
emitInvoke cpidx hasThis = 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 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)
+ return $ Just (calladdr, MI l)
emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
calladdr <- getCurrentOffset
call (Disp offset, ebx)
-- discard arguments on stack (+4 for "this")
- let argcnt = 4 + ((methodGetArgsCount cls cpidx) * 4)
+ 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)
-- 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, II mi)
+ return $ Just (calladdr, II mi)
emit' (INVOKEVIRTUAL cpidx) = do
-- get methodInfo entry
let mi@(MethodInfo methodname objname msig@(MethodSignature args _)) = buildMethodID cls cpidx
-- get method-table-ptr
mov eax (Disp 0, eax)
-- get method offset
- let nameAndSig = methodname `B.append` (encode msig)
+ let nameAndSig = methodname `B.append` encode msig
offset <- liftIO $ 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)
+ 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)
-- 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)
+ 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)
+ 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)
+ return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
emit' insn = emit insn >> return Nothing
emit :: J.Instruction -> CodeGen e s ()
- emit POP = do -- dropp value
- add esp (4 :: Word32)
+ emit POP = add esp (4 :: Word32) -- drop value
emit DUP = push (Disp 0, esp)
emit AASTORE = emit IASTORE
emit IASTORE = do
emit (NEWARRAY typ) = do
let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
T_INT -> 4
- _ -> error $ "newarray: type not implemented yet"
+ _ -> error "newarray: type not implemented yet"
-- get length from stack, but leave it there
mov eax (Disp 0, esp)
mov ebx (tsize :: Word32)
mtable <- liftIO $ 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 (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 (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
emit (ALOAD x) = emit (ILOAD x)
- emit (ILOAD x) = do
- push (Disp (cArgs x), ebp)
+ emit (ILOAD x) = push (Disp (cArgs x), ebp)
emit (ASTORE_ x) = emit (ISTORE_ x)
emit (ISTORE_ x) = do
pop eax
emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
emit (LDC2 x) = do
- value <- case (constsPool cls) M.! x of
+ value <- case constsPool cls M.! x of
(CString s) -> liftIO $ getUniqueStringAddr s
- _ -> error $ "LDCI... missing impl."
+ _ -> error "LDCI... missing impl."
push value
emit (GETFIELD x) = do
- pop eax -- this pointer
- let (cname, fname) = buildFieldOffset cls x
- offset <- liftIO $ getFieldOffset cname fname
- 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
- pop eax -- this pointer
- let (cname, fname) = buildFieldOffset cls x
- offset <- liftIO $ getFieldOffset cname fname
- mov (Disp (fromIntegral $ offset), eax) ebx -- set field
+ 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
emit IMUL = do pop ebx; pop eax; mul ebx; push eax
emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
- emit (IINC x imm) = do
+ emit (IINC x imm) =
add (Disp (cArgs x), ebp) (s8_w32 imm)
emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
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; _ -> error "bad"
- let l = getLabel sid lmap
- case cond of
- C_EQ -> je l; C_NE -> jne l
- C_LT -> jl l; C_GT -> jg l
- C_GE -> jge l; C_LE -> jle l
+ emitIF cond
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; _ -> error "bad"
- let l = getLabel sid lmap
- case cond of
- C_EQ -> je l; C_NE -> jne l
- C_LT -> jl l; C_GT -> jg l
- C_GE -> jge l; C_LE -> jle l
+ emitIF cond
emit (GOTO _ ) = do
let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
emit RETURN = do mov esp ebp; pop ebp; ret
emit ARETURN = emit IRETURN
- emit IRETURN = do
- pop eax
- mov esp ebp
- pop ebp
- ret
- emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
+ emit IRETURN = do pop eax; emit RETURN
+ emit invalid = error $ "insn not implemented yet: " ++ show invalid
+
+ emitFieldOffset :: Word16 -> CodeGen e s Int32
+ emitFieldOffset x = do
+ pop eax -- this pointer
+ let (cname, fname) = buildFieldOffset cls x
+ liftIO $ getFieldOffset cname fname
+
+ emitIF :: CMP -> CodeGen e s ()
+ emitIF cond = let
+ sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
+ l = getLabel sid lmap
+ in case cond of
+ C_EQ -> je l; C_NE -> jne l
+ C_LT -> jl l; C_GT -> jg l
+ C_GE -> jge l; C_LE -> jle l
callMalloc :: CodeGen e s ()
callMalloc = do
calladdr <- getCurrentOffset
let w32_calladdr = 5 + calladdr
- let malloaddr = (fromIntegral getMallocObjectAddr :: Word32)
+ let malloaddr = fromIntegral getMallocObjectAddr :: Word32
call (malloaddr - w32_calladdr)
add esp (4 :: Word32)
push eax
-- for locals we use a different storage
cArgs :: Word8 -> Word32
- cArgs x = if (x' >= thisMethodArgCnt)
+ cArgs x = if x' >= thisMethodArgCnt
-- TODO(bernhard): maybe s/(-4)/(-8)/
then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
else 4 + (thisMethodArgCnt * 4) - (4 * x')
cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
thisMethodArgCnt :: Word32
- thisMethodArgCnt = isNonStatic + (fromIntegral $ length args)
+ 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
+ then 0 else 1 -- one argument for the this pointer
-- sign extension from w8 to w32 (over s8)
-- it should be Int8 actually)
s8_w32 :: Word8 -> Word32
s8_w32 w8 = fromIntegral s8
- where s8 = (fromIntegral w8) :: Int8
+ where s8 = fromIntegral w8 :: Int8
projects / mate.git / commitdiff