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.Types
  23 import Mate.X86CodeGen
  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 foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  33 getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  34 getMethodEntry signal_from ptr_mmap ptr_cmap = do
  35   mmap <- ptr2mmap ptr_mmap
  36   cmap <- ptr2cmap ptr_cmap
  37
  38   let w32_from = fromIntegral signal_from
  39   let mi@(MethodInfo method cm _ cpidx) = cmap M.! w32_from
  40   -- TODO(bernhard): replace parsing with some kind of classpool
  41   cls <- parseClassFile $ toString $ cm `B.append` ".class"
  42   case M.lookup mi mmap of
  43     Nothing -> do
  44       printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi)
  45       -- TODO(bernhard): maybe we have to load the class first?
  46       --                 (Or better in X86CodeGen?)
  47       let (CMethod _ nt) = (constsPool cls) M.! cpidx
  48       hmap <- parseMethod cls (ntName nt)
  49       printMapBB hmap
  50       case hmap of
  51         Just hmap' -> do
  52           entry <- compileBB hmap' mi
  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 -> MethodInfo -> IO (Ptr Word8)
  72 compileBB hmap methodinfo = do
  73   mmap <- get_mmap >>= ptr2mmap
  74   cmap <- get_cmap >>= ptr2cmap
  75
  76   -- TODO(bernhard): replace parsing with some kind of classpool
  77   cls <- parseClassFile $ toString $ (cName methodinfo) `B.append` ".class"
  78   let ebb = emitFromBB cls hmap
  79   (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () ()
  80   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  81
  82   let mmap' = M.insert methodinfo w32_entry mmap
  83   let cmap' = M.union cmap new_cmap -- prefers elements in cmap
  84   mmap2ptr mmap' >>= set_mmap
  85   cmap2ptr cmap' >>= set_cmap
  86
  87   printf "disasm:\n"
  88   mapM_ (putStrLn . showAtt) disasm
  89   -- UNCOMMENT NEXT LINE FOR GDB FUN
  90   -- _ <- getLine
  91   -- (1) start it with `gdb ./mate' and then `run <classfile>'
  92   -- (2) on getLine, press ctrl+c
  93   -- (3) `br *0x<addr>'; obtain the address from the disasm above
  94   -- (4) `cont' and press enter
  95   return entry
  96
  97
  98 foreign import ccall "dynamic"
  99    code_void :: FunPtr (IO ()) -> (IO ())
 100
 101 executeFuncPtr :: Ptr Word8 -> IO ()
 102 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
 103
 104 -- TODO(bernhard): make some typeclass magic 'n stuff
 105 mmap2ptr :: MMap -> IO (Ptr ())
 106 mmap2ptr mmap = do
 107   ptr_mmap <- newStablePtr mmap
 108   return $ castStablePtrToPtr ptr_mmap
 109
 110 ptr2mmap :: Ptr () -> IO MMap
 111 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
 112
 113 cmap2ptr :: CMap -> IO (Ptr ())
 114 cmap2ptr cmap = do
 115   ptr_cmap <- newStablePtr cmap
 116   return $ castStablePtrToPtr ptr_cmap
 117
 118 ptr2cmap :: Ptr () -> IO CMap
 119 ptr2cmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)