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 found. compile it\n" w32_from
  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       case hmap of
  51         Just hmap' -> do
  52           entry <- compileBB hmap' cls method
  53           return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  54         Nothing -> error $ (show method) ++ " not found. abort"
  55     Just w32 -> return (fromIntegral w32)
  56
  57 -- t_01 :: IO ()
  58 -- t_01 = do
  59 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
  60 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  61 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
  62 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
  63 --   mmap2ptr mmap >>= set_mmap
  64 --   demo_mmap -- access Data.Map from C
  65
  66 initMethodPool :: IO ()
  67 initMethodPool = do
  68   mmap2ptr M.empty >>= set_mmap
  69   cmap2ptr M.empty >>= set_cmap
  70
  71 compileBB :: MapBB -> Class Resolved -> B.ByteString -> IO (Ptr Word8)
  72 compileBB hmap cls name = do
  73   mmap <- get_mmap >>= ptr2mmap
  74   cmap <- get_cmap >>= ptr2cmap
  75
  76   let ebb = emitFromBB cls hmap
  77   (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () ()
  78   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  79
  80   let mmap' = M.insert name w32_entry mmap
  81   let cmap' = M.union cmap new_cmap -- prefers elements in cmap
  82   mmap2ptr mmap' >>= set_mmap
  83   cmap2ptr cmap' >>= set_cmap
  84
  85   printf "disasm:\n"
  86   mapM_ (putStrLn . showAtt) disasm
  87   -- UNCOMMENT NEXT LINE FOR GDB FUN
  88   -- _ <- getLine
  89   -- (1) start it with `gdb ./mate' and then `run <classfile>'
  90   -- (2) on getLine, press ctrl+c
  91   -- (3) `br *0x<addr>'; obtain the address from the disasm above
  92   -- (4) `cont' and press enter
  93   return entry
  94
  95
  96 foreign import ccall "dynamic"
  97    code_void :: FunPtr (IO ()) -> (IO ())
  98
  99 executeFuncPtr :: Ptr Word8 -> IO ()
 100 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
 101
 102 -- TODO(bernhard): make some typeclass magic 'n stuff
 103 mmap2ptr :: MMap -> IO (Ptr ())
 104 mmap2ptr mmap = do
 105   ptr_mmap <- newStablePtr mmap
 106   return $ castStablePtrToPtr ptr_mmap
 107
 108 ptr2mmap :: Ptr () -> IO MMap
 109 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
 110
 111 cmap2ptr :: CMap -> IO (Ptr ())
 112 cmap2ptr cmap = do
 113   ptr_cmap <- newStablePtr cmap
 114   return $ castStablePtrToPtr ptr_cmap
 115
 116 ptr2cmap :: Ptr () -> IO CMap
 117 ptr2cmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)