Mate/MethodPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.MethodPool where
   4
   5 import Data.Binary
   6 import Data.String.Utils
   7 import qualified Data.Map as M
   8 import qualified Data.Set as S
   9 import qualified Data.ByteString.Lazy as B
  10 import System.Plugins
  11
  12 import Text.Printf
  13
  14 import Foreign.Ptr
  15 import Foreign.C.Types
  16 import Foreign.C.String
  17 import Foreign.StablePtr
  18
  19 import JVM.ClassFile
  20 import JVM.Converter
  21
  22 import Harpy
  23 import Harpy.X86Disassembler
  24
  25 import Mate.BasicBlocks
  26 import Mate.Types
  27 import Mate.X86CodeGen
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30
  31
  32 foreign import ccall "dynamic"
  33    code_void :: FunPtr (IO ()) -> (IO ())
  34
  35
  36 foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  37 getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  38 getMethodEntry signal_from ptr_mmap ptr_cmap = do
  39   mmap <- ptr2mmap ptr_mmap
  40   cmap <- ptr2cmap ptr_cmap
  41
  42   let w32_from = fromIntegral signal_from
  43   let mi@(MethodInfo method cm sig) = cmap M.! w32_from
  44   -- TODO(bernhard): replace parsing with some kind of classpool
  45   cls <- getClassFile cm
  46   case M.lookup mi mmap of
  47     Nothing -> do
  48       printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi)
  49       let mm = lookupMethod method cls
  50       case mm of
  51         Just mm' -> do
  52             let flags = methodAccessFlags mm'
  53             case S.member ACC_NATIVE flags of
  54               False -> do
  55                 hmap <- parseMethod cls method
  56                 printMapBB hmap
  57                 case hmap of
  58                   Just hmap' -> do
  59                     entry <- compileBB hmap' mi
  60                     return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  61                   Nothing -> error $ (show method) ++ " not found. abort"
  62               True -> do
  63                 let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace "(" "_" (replace ")" "_" $ toString $ encode sig))
  64                 printf "native-call: symbol: %s\n" symbol
  65                 nf <- loadNativeFunction symbol
  66                 let w32_nf = fromIntegral nf
  67                 let mmap' = M.insert mi w32_nf mmap
  68                 mmap2ptr mmap' >>= set_methodmap
  69                 return nf
  70         Nothing -> error $ (show method) ++ " not found. abort"
  71     Just w32 -> return (fromIntegral w32)
  72
  73 -- TODO(bernhard): UBERHAX.  ghc patch?
  74 foreign import ccall safe "lookupSymbol"
  75    c_lookupSymbol :: CString -> IO (Ptr a)
  76
  77 loadNativeFunction :: String -> IO (CUInt)
  78 loadNativeFunction sym = do
  79         _ <- loadRawObject "ffi/native.o"
  80         -- TODO(bernhard): WTF
  81         resolveObjs (return ())
  82         ptr <- withCString sym c_lookupSymbol
  83         if (ptr == nullPtr)
  84           then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
  85           else return $ fromIntegral $ minusPtr ptr nullPtr
  86
  87 -- t_01 :: IO ()
  88 -- t_01 = do
  89 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
  90 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  91 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
  92 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
  93 --   mmap2ptr mmap >>= set_mmap
  94 --   demo_mmap -- access Data.Map from C
  95
  96 initMethodPool :: IO ()
  97 initMethodPool = do
  98   mmap2ptr M.empty >>= set_methodmap
  99   cmap2ptr M.empty >>= set_callermap
 100   classmap2ptr M.empty >>= set_classmap
 101
 102 compileBB :: MapBB -> MethodInfo -> IO (Ptr Word8)
 103 compileBB hmap methodinfo = do
 104   mmap <- get_methodmap >>= ptr2mmap
 105   cmap <- get_callermap >>= ptr2cmap
 106
 107   -- TODO(bernhard): replace parsing with some kind of classpool
 108   cls <- getClassFile (cName methodinfo)
 109   let ebb = emitFromBB cls hmap
 110   (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () ()
 111   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
 112
 113   let mmap' = M.insert methodinfo w32_entry mmap
 114   let cmap' = M.union cmap new_cmap -- prefers elements in cmap
 115   mmap2ptr mmap' >>= set_methodmap
 116   cmap2ptr cmap' >>= set_callermap
 117
 118   printf "disasm:\n"
 119   mapM_ (putStrLn . showAtt) disasm
 120   -- UNCOMMENT NEXT LINE FOR GDB FUN
 121   -- _ <- getLine
 122   -- (1) start it with `gdb ./mate' and then `run <classfile>'
 123   -- (2) on getLine, press ctrl+c
 124   -- (3) `br *0x<addr>'; obtain the address from the disasm above
 125   -- (4) `cont' and press enter
 126   return entry
 127
 128
 129 executeFuncPtr :: Ptr Word8 -> IO ()
 130 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))