Mate/Types.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.Types where
   4
   5 import Data.Char
   6 import Data.Word
   7 import qualified Data.Map as M
   8 import qualified Data.ByteString.Lazy as B
   9 import Codec.Binary.UTF8.String hiding (encode,decode)
  10
  11 import Foreign.Ptr
  12 import Foreign.C.Types
  13 import Foreign.C.String
  14 import Foreign.StablePtr
  15
  16 import JVM.ClassFile
  17 import JVM.Assembler
  18
  19
  20 type BlockID = Int
  21 -- Represents a CFG node
  22 data BasicBlock = BasicBlock {
  23                      code    :: [Instruction],
  24                      successor :: BBEnd }
  25
  26 -- describes (leaving) edges of a CFG node
  27 data BBEnd = Return | FallThrough BlockID | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
  28
  29 type MapBB = M.Map BlockID BasicBlock
  30
  31
  32 -- Word32 = point of method call in generated code
  33 -- MethodInfo = relevant information about callee
  34 type TMap = M.Map Word32 TrapInfo
  35
  36 data TrapInfo = MI MethodInfo | SFI StaticFieldInfo
  37
  38 data StaticFieldInfo = StaticFieldInfo {
  39   dunnoyet :: Int }
  40
  41 -- B.ByteString = name of method
  42 -- Word32 = entrypoint of method
  43 type MMap = M.Map MethodInfo Word32
  44
  45 type ClassMap = M.Map B.ByteString ClassInfo
  46
  47 data ClassInfo = ClassInfo {
  48   clName :: B.ByteString,
  49   clFile :: Class Resolved }
  50
  51 data MethodInfo = MethodInfo {
  52   methName :: B.ByteString,
  53   cName :: B.ByteString,
  54   mSignature :: MethodSignature}
  55
  56 instance Eq MethodInfo where
  57   (MethodInfo m_a c_a s_a) == (MethodInfo m_b c_b s_b) =
  58     (m_a == m_b) && (c_a == c_b) && (s_a == s_b)
  59
  60 -- TODO(bernhard): not really efficient. also, outsource that to hs-java
  61 instance Ord MethodSignature where
  62   compare (MethodSignature args_a ret_a) (MethodSignature args_b ret_b)
  63     | cmp_args /= EQ = cmp_args
  64     | otherwise = (show ret_a) `compare` (show ret_b)
  65     where
  66     cmp_args = (show args_a) `compare` (show args_b)
  67
  68 instance Ord MethodInfo where
  69   compare (MethodInfo m_a c_a s_a) (MethodInfo m_b c_b s_b)
  70     | cmp_m /= EQ = cmp_m
  71     | cmp_c /= EQ = cmp_c
  72     | otherwise = s_a `compare` s_b
  73     where
  74     cmp_m = m_a `compare` m_b
  75     cmp_c = c_a `compare` c_b
  76
  77 instance Show MethodInfo where
  78   show (MethodInfo method c sig) =
  79     (toString c) ++ "." ++ (toString method) ++ "." ++ (show sig)
  80
  81
  82 toString :: B.ByteString -> String
  83 toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
  84
  85
  86 -- global map hax
  87 foreign import ccall "get_trapmap"
  88   get_trapmap :: IO (Ptr ())
  89
  90 foreign import ccall "set_trapmap"
  91   set_trapmap :: Ptr () -> IO ()
  92
  93 foreign import ccall "get_methodmap"
  94   get_methodmap :: IO (Ptr ())
  95
  96 foreign import ccall "set_methodmap"
  97   set_methodmap :: Ptr () -> IO ()
  98
  99 foreign import ccall "get_classmap"
 100   get_classmap :: IO (Ptr ())
 101
 102 foreign import ccall "set_classmap"
 103   set_classmap :: Ptr () -> IO ()
 104
 105 -- TODO(bernhard): make some typeclass magic 'n stuff
 106 mmap2ptr :: MMap -> IO (Ptr ())
 107 mmap2ptr mmap = do
 108   ptr_mmap <- newStablePtr mmap
 109   return $ castStablePtrToPtr ptr_mmap
 110
 111 ptr2mmap :: Ptr () -> IO MMap
 112 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
 113
 114 tmap2ptr :: TMap -> IO (Ptr ())
 115 tmap2ptr tmap = do
 116   ptr_tmap <- newStablePtr tmap
 117   return $ castStablePtrToPtr ptr_tmap
 118
 119 ptr2tmap :: Ptr () -> IO TMap
 120 ptr2tmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr tmap)
 121
 122 classmap2ptr :: ClassMap -> IO (Ptr ())
 123 classmap2ptr cmap = do
 124   ptr_cmap <- newStablePtr cmap
 125   return $ castStablePtrToPtr ptr_cmap
 126
 127 ptr2classmap :: Ptr () -> IO ClassMap
 128 ptr2classmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)