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