Mate/Utilities.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Mate.Utilities where
   4
   5 import Data.Word
   6 import qualified Data.Map as M
   7 import qualified Data.Set as S
   8 import qualified Data.ByteString.Lazy as B
   9 import Data.List
  10 import Data.Maybe
  11
  12 import JVM.ClassFile
  13
  14 import Mate.Types
  15 import Mate.NativeSizes
  16
  17 #ifdef DEBUG
  18 import Text.Printf
  19 #endif
  20
  21 buildMethodID :: Class Direct -> Word16 -> MethodInfo
  22 buildMethodID cls idx = MethodInfo (ntName nt) rc (ntSignature nt)
  23   where
  24     (rc, nt) = case constsPool cls M.! idx of
  25       (CMethod rc' nt') -> (rc', nt')
  26       (CIfaceMethod rc' nt') -> (rc', nt')
  27       _ -> error "buildMethodID: something wrong. abort."
  28
  29 buildStaticFieldID :: Class Direct -> Word16 -> StaticFieldInfo
  30 buildStaticFieldID cls idx = StaticFieldInfo rc (ntName fnt)
  31   where (CField rc fnt) = constsPool cls M.! idx
  32
  33 buildFieldOffset :: Class Direct -> Word16 -> (B.ByteString, B.ByteString)
  34 buildFieldOffset cls idx = (rc, ntName fnt)
  35   where (CField rc fnt) = constsPool cls M.! idx
  36
  37 buildClassID :: Class Direct -> Word16 -> B.ByteString
  38 buildClassID cls idx = cl
  39   where (CClass cl) = constsPool cls M.! idx
  40
  41
  42 methodNameTypeByIdx :: Class Direct -> Word16 -> NameType (Method Direct)
  43 methodNameTypeByIdx cls idx = case constsPool cls M.! idx of
  44   (CMethod _ nt') -> nt'
  45   (CIfaceMethod _ nt') -> nt'
  46   _ -> error "methodGetArgsCount: something wrong. abort."
  47
  48 methodGetArgsCount :: NameType (Method Direct) -> NativeWord
  49 methodGetArgsCount nt = genericLength args
  50   where (MethodSignature args _) = ntSignature nt
  51
  52 -- TODO(bernhard): Extend it to more than just int, and provide typeinformation
  53 methodHaveReturnValue :: Class Direct -> Word16 -> Bool
  54 methodHaveReturnValue cls idx = case ret of
  55     ReturnsVoid -> False;
  56     (Returns BoolType) -> True
  57     (Returns CharByte) -> True
  58     (Returns IntType) -> True;
  59     (Returns (Array _ _)) -> True
  60     (Returns (ObjectType _)) -> True;
  61     _ -> error $ "methodHaveReturnValue: todo: " ++ show ret
  62   where
  63     nt = case constsPool cls M.! idx of
  64       (CMethod _ nt') -> nt'
  65       (CIfaceMethod _ nt') -> nt'
  66       _ -> error "methodHaveReturnValue: something wrong. abort."
  67     (MethodSignature _ ret) = ntSignature nt
  68
  69 methodInfoToMethod :: MethodInfo -> Class Direct -> Method Direct
  70 methodInfoToMethod mi cls =
  71   fromJust $ lookupMethodSig (methName mi) (methSignature mi) cls
  72
  73 methodIsStatic :: Method Direct -> Bool
  74 methodIsStatic = S.member ACC_STATIC . methodAccessFlags
  75
  76 lookupMethodSig :: B.ByteString -> MethodSignature -> Class Direct -> Maybe (Method Direct)
  77 lookupMethodSig name sig cls =
  78   find (\x -> methodName x == name && methodSignature x == sig) $ classMethods cls
  79
  80 hexDumpMap :: Integral v => String -> M.Map B.ByteString v -> IO ()
  81 #ifdef DEBUG
  82 hexDumpMap header mmap = do
  83   let printValue :: B.ByteString -> IO ()
  84       printValue key = printf "\t%-70s: 0x%08x\n" (toString key) val
  85         where val = fromIntegral (mmap M.! key) :: NativeWord
  86   printf "%s\n" header
  87   mapM_ printValue (M.keys mmap)
  88 #else
  89 hexDumpMap _ _ = return ()
  90 #endif