From: Bernhard Urban Date: Thu, 10 May 2012 11:55:29 +0000 (+0200) Subject: hlint: fix suggested improvements X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=b3427c38e5e0b38e44df820e03cabf91613be1ce hlint: fix suggested improvements nice tool \o/ some code duplication stuff need to be fixed yet --- diff --git a/Mate.hs b/Mate.hs index 4c73290..0275e81 100644 --- a/Mate.hs +++ b/Mate.hs @@ -32,10 +32,10 @@ main = do 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 diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index bf34eee..3c0b93c 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -89,8 +89,8 @@ test_04 = testInstance "./tests/Fac.class" "fac" 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 @@ -124,7 +124,7 @@ markBackwardTargets :: [OffIns] -> [OffIns] 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 @@ -133,8 +133,8 @@ markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) = -- 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 @@ -150,27 +150,27 @@ buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) 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 @@ -181,11 +181,11 @@ calculateInstructionOffset :: [Instruction] -> [OffIns] 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' _ [] = [] @@ -201,6 +201,6 @@ calculateInstructionOffset = cio' (0, Nothing) _ -> ((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 diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs index 986193d..45a8fff 100644 --- a/Mate/ClassPool.hs +++ b/Mate/ClassPool.hs @@ -54,29 +54,29 @@ getClassFile path = do 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... @@ -91,19 +91,18 @@ getStaticFieldAddr from ptr_trapmap = do 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 @@ -115,11 +114,11 @@ loadClass path = do #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 @@ -167,26 +166,26 @@ loadInterface path = do -- 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) @@ -195,19 +194,19 @@ calculateFields cf superclass = do 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 @@ -225,15 +224,15 @@ calculateMethodMap cf superclass = do ((/=) "" . 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 @@ -244,7 +243,7 @@ loadAndInitClass path = do 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 "" (ciFile ci) of @@ -252,13 +251,13 @@ loadAndInitClass path = do hmap <- parseMethod (ciFile ci) "" case hmap of Just hmap' -> do - let mi = (MethodInfo "" path (methodSignature m)) + let mi = MethodInfo "" 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 diff --git a/Mate/Debug.hs b/Mate/Debug.hs index c03bfcc..8c1ca63 100644 --- a/Mate/Debug.hs +++ b/Mate/Debug.hs @@ -14,7 +14,7 @@ instance VarArgsFake (IO a) where varFake _ = return undefined instance (Show a, VarArgsFake r) => VarArgsFake (a -> r) where - varFake _ = \_ -> varFake [] + varFake _ _ = varFake [] printfFake :: String -> (VarArgsFake t) => t printfFake _ = varFake [] diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs index 3740f1e..672c70c 100644 --- a/Mate/MethodPool.hs +++ b/Mate/MethodPool.hs @@ -32,7 +32,7 @@ import Mate.ClassPool 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 @@ -47,8 +47,8 @@ getTrapType signal_from from2 = do 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 @@ -63,10 +63,10 @@ getMethodEntry signal_from methodtable = do 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 @@ -75,34 +75,37 @@ getMethodEntry signal_from methodtable = do 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 @@ -116,13 +119,13 @@ lookupMethodRecursive name clsnames cls = do 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 @@ -149,7 +152,7 @@ initMethodPool = do 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 @@ -162,7 +165,7 @@ compileBB hmap methodinfo = do (_, 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) @@ -179,4 +182,4 @@ compileBB hmap methodinfo = do executeFuncPtr :: Word32 -> IO () executeFuncPtr entry = - code_void $ ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ())) + code_void ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ())) diff --git a/Mate/RegisterAllocation.hs b/Mate/RegisterAllocation.hs index 6dfaa80..7162ae6 100644 --- a/Mate/RegisterAllocation.hs +++ b/Mate/RegisterAllocation.hs @@ -36,7 +36,7 @@ count p = length . filter p 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) diff --git a/Mate/Strings.hs b/Mate/Strings.hs index 36b2342..74a0e17 100644 --- a/Mate/Strings.hs +++ b/Mate/Strings.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ForeignFunctionInterface #-} #include "debug.h" module Mate.Strings ( getUniqueStringAddr @@ -38,7 +37,7 @@ allocateJavaString :: B.ByteString -> IO Word32 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) diff --git a/Mate/Types.hs b/Mate/Types.hs index 88455bc..2c181b0 100644 --- a/Mate/Types.hs +++ b/Mate/Types.hs @@ -60,13 +60,12 @@ data MethodInfo = MethodInfo { 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 @@ -161,7 +160,7 @@ methodmap2ptr methodmap = do 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 @@ -169,7 +168,7 @@ 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 @@ -177,7 +176,7 @@ 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 @@ -185,7 +184,7 @@ 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 ()) @@ -194,7 +193,7 @@ stringsmap2ptr cmap = do 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 ()) @@ -203,7 +202,7 @@ interfacesmap2ptr cmap = do 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 ()) @@ -212,4 +211,4 @@ interfacemethodmap2ptr cmap = do return $ castStablePtrToPtr ptr_cmap ptr2interfacemethodmap :: Ptr () -> IO InterfaceMethodMap -ptr2interfacemethodmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap) +ptr2interfacemethodmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap) diff --git a/Mate/Utilities.hs b/Mate/Utilities.hs index 50e7a56..4d1cd07 100644 --- a/Mate/Utilities.hs +++ b/Mate/Utilities.hs @@ -22,30 +22,30 @@ lookupMethod name cls = look (classMethods cls) 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 @@ -56,8 +56,8 @@ methodHaveReturnValue cls idx = case ret of (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 diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs index abe5a39..893a397 100644 --- a/Mate/X86CodeGen.hs +++ b/Mate/X86CodeGen.hs @@ -31,7 +31,7 @@ import Mate.Strings 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 @@ -60,7 +60,7 @@ emitFromBB method cls hmap = do -- 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) @@ -78,13 +78,11 @@ emitFromBB method cls hmap = do 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 @@ -92,12 +90,12 @@ emitFromBB method cls hmap = do -- 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 @@ -108,11 +106,11 @@ emitFromBB method cls hmap = 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 @@ -133,14 +131,14 @@ emitFromBB method cls hmap = do 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 @@ -150,35 +148,34 @@ emitFromBB method cls hmap = do -- 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 @@ -200,7 +197,7 @@ emitFromBB method cls hmap = 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) @@ -224,8 +221,8 @@ emitFromBB method cls hmap = do 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) @@ -233,11 +230,9 @@ emitFromBB method cls hmap = do 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 @@ -249,27 +244,23 @@ emitFromBB method cls hmap = do 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) @@ -277,22 +268,12 @@ emitFromBB method cls hmap = do 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" @@ -300,25 +281,36 @@ emitFromBB method cls hmap = do 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') @@ -328,13 +320,12 @@ emitFromBB method cls hmap = do 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) @@ -342,4 +333,4 @@ emitFromBB method cls hmap = do -- it should be Int8 actually) s8_w32 :: Word8 -> Word32 s8_w32 w8 = fromIntegral s8 - where s8 = (fromIntegral w8) :: Int8 + where s8 = fromIntegral w8 :: Int8