Mate/MethodPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.MethodPool where
   4
   5 import Data.Binary
   6 import qualified Data.Map as M
   7 import qualified Data.ByteString.Lazy as B
   8
   9 import Text.Printf
  10
  11 import Foreign.Ptr
  12 import Foreign.C.Types
  13 import Foreign.StablePtr
  14
  15 import JVM.ClassFile
  16 import JVM.Converter
  17
  18 import Harpy
  19 import Harpy.X86Disassembler
  20
  21 import Mate.BasicBlocks
  22 import Mate.X86CodeGen
  23 import Mate.Utilities
  24
  25
  26 foreign import ccall "get_mmap"
  27   get_mmap :: IO (Ptr ())
  28
  29 foreign import ccall "set_mmap"
  30   set_mmap :: Ptr () -> IO ()
  31
  32
  33 -- B.ByteString = name of method
  34 -- Word32 = entrypoint of method
  35 type MMap = M.Map MethodInfo Word32
  36
  37 foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  38 getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  39 getMethodEntry signal_from ptr_mmap ptr_cmap = do
  40   mmap <- ptr2mmap ptr_mmap
  41   cmap <- ptr2cmap ptr_cmap
  42
  43   let w32_from = fromIntegral signal_from
  44   let mi@(MethodInfo method cm sig cpidx) = cmap M.! w32_from
  45   -- TODO(bernhard): replace parsing with some kind of classpool
  46   cls <- parseClassFile $ toString $ cm `B.append` ".class"
  47   case M.lookup mi mmap of
  48     Nothing -> do
  49       printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi)
  50       -- TODO(bernhard): maybe we have to load the class first?
  51       --                 (Or better in X86CodeGen?)
  52       let (CMethod _ nt) = (constsPool cls) M.! cpidx
  53       hmap <- parseMethod cls (ntName nt)
  54       printMapBB hmap
  55       case hmap of
  56         Just hmap' -> do
  57           entry <- compileBB hmap' mi
  58           return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  59         Nothing -> error $ (show method) ++ " not found. abort"
  60     Just w32 -> return (fromIntegral w32)
  61
  62 -- t_01 :: IO ()
  63 -- t_01 = do
  64 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
  65 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  66 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
  67 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
  68 --   mmap2ptr mmap >>= set_mmap
  69 --   demo_mmap -- access Data.Map from C
  70
  71 initMethodPool :: IO ()
  72 initMethodPool = do
  73   mmap2ptr M.empty >>= set_mmap
  74   cmap2ptr M.empty >>= set_cmap
  75
  76 compileBB :: MapBB -> MethodInfo -> IO (Ptr Word8)
  77 compileBB hmap methodinfo = do
  78   mmap <- get_mmap >>= ptr2mmap
  79   cmap <- get_cmap >>= ptr2cmap
  80
  81   -- TODO(bernhard): replace parsing with some kind of classpool
  82   cls <- parseClassFile $ toString $ (classname methodinfo) `B.append` ".class"
  83   let ebb = emitFromBB cls hmap
  84   (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () ()
  85   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  86
  87   let mmap' = M.insert methodinfo w32_entry mmap
  88   let cmap' = M.union cmap new_cmap -- prefers elements in cmap
  89   mmap2ptr mmap' >>= set_mmap
  90   cmap2ptr cmap' >>= set_cmap
  91
  92   printf "disasm:\n"
  93   mapM_ (putStrLn . showAtt) disasm
  94   -- UNCOMMENT NEXT LINE FOR GDB FUN
  95   -- _ <- getLine
  96   -- (1) start it with `gdb ./mate' and then `run <classfile>'
  97   -- (2) on getLine, press ctrl+c
  98   -- (3) `br *0x<addr>'; obtain the address from the disasm above
  99   -- (4) `cont' and press enter
 100   return entry
 101
 102
 103 foreign import ccall "dynamic"
 104    code_void :: FunPtr (IO ()) -> (IO ())
 105
 106 executeFuncPtr :: Ptr Word8 -> IO ()
 107 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
 108
 109 -- TODO(bernhard): make some typeclass magic 'n stuff
 110 mmap2ptr :: MMap -> IO (Ptr ())
 111 mmap2ptr mmap = do
 112   ptr_mmap <- newStablePtr mmap
 113   return $ castStablePtrToPtr ptr_mmap
 114
 115 ptr2mmap :: Ptr () -> IO MMap
 116 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
 117
 118 cmap2ptr :: CMap -> IO (Ptr ())
 119 cmap2ptr cmap = do
 120   ptr_cmap <- newStablePtr cmap
 121   return $ castStablePtrToPtr ptr_cmap
 122
 123 ptr2cmap :: Ptr () -> IO CMap
 124 ptr2cmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)