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