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_tmap = do
  39   mmap <- ptr2mmap ptr_mmap
  40   tmap <- ptr2tmap ptr_tmap
  41
  42   let w32_from = fromIntegral signal_from
  43   let mi = tmap M.! w32_from
  44   case mi of
  45     (MI mi'@(MethodInfo method cm sig)) -> do
  46       case M.lookup mi' mmap of
  47         Nothing -> do
  48           cls <- getClassFile cm
  49           printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi')
  50           let mm = lookupMethod method cls
  51           case mm of
  52             Just mm' -> do
  53                 let flags = methodAccessFlags mm'
  54                 case S.member ACC_NATIVE flags of
  55                   False -> do
  56                     hmap <- parseMethod cls method
  57                     printMapBB hmap
  58                     case hmap of
  59                       Just hmap' -> do
  60                         entry <- compileBB hmap' mi'
  61                         return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  62                       Nothing -> error $ (show method) ++ " not found. abort"
  63                   True -> do
  64                     let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace "(" "_" (replace ")" "_" $ toString $ encode sig))
  65                     printf "native-call: symbol: %s\n" symbol
  66                     nf <- loadNativeFunction symbol
  67                     let w32_nf = fromIntegral nf
  68                     let mmap' = M.insert mi' w32_nf mmap
  69                     mmap2ptr mmap' >>= set_methodmap
  70                     return nf
  71             Nothing -> error $ (show method) ++ " not found. abort"
  72         Just w32 -> return (fromIntegral w32)
  73     _ -> error $ "getMethodEntry: no trapInfo. abort"
  74
  75 -- TODO(bernhard): UBERHAX.  ghc patch?
  76 foreign import ccall safe "lookupSymbol"
  77    c_lookupSymbol :: CString -> IO (Ptr a)
  78
  79 loadNativeFunction :: String -> IO (CUInt)
  80 loadNativeFunction sym = do
  81         _ <- loadRawObject "ffi/native.o"
  82         -- TODO(bernhard): WTF
  83         resolveObjs (return ())
  84         ptr <- withCString sym c_lookupSymbol
  85         if (ptr == nullPtr)
  86           then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
  87           else return $ fromIntegral $ minusPtr ptr nullPtr
  88
  89 -- t_01 :: IO ()
  90 -- t_01 = do
  91 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
  92 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  93 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
  94 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
  95 --   mmap2ptr mmap >>= set_mmap
  96 --   demo_mmap -- access Data.Map from C
  97
  98 initMethodPool :: IO ()
  99 initMethodPool = do
 100   mmap2ptr M.empty >>= set_methodmap
 101   tmap2ptr M.empty >>= set_trapmap
 102   classmap2ptr M.empty >>= set_classmap
 103
 104 compileBB :: MapBB -> MethodInfo -> IO (Ptr Word8)
 105 compileBB hmap methodinfo = do
 106   mmap <- get_methodmap >>= ptr2mmap
 107   tmap <- get_trapmap >>= ptr2tmap
 108
 109   -- TODO(bernhard): replace parsing with some kind of classpool
 110   cls <- getClassFile (cName methodinfo)
 111   let ebb = emitFromBB cls hmap
 112   (_, Right ((entry, _, _, new_tmap), disasm)) <- runCodeGen ebb () ()
 113   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
 114
 115   let mmap' = M.insert methodinfo w32_entry mmap
 116   let tmap' = M.union tmap new_tmap -- prefers elements in cmap
 117   mmap2ptr mmap' >>= set_methodmap
 118   tmap2ptr tmap' >>= set_trapmap
 119
 120   printf "disasm:\n"
 121   mapM_ (putStrLn . showAtt) disasm
 122   -- UNCOMMENT NEXT LINE FOR GDB FUN
 123   -- _ <- getLine
 124   -- (1) start it with `gdb ./mate' and then `run <classfile>'
 125   -- (2) on getLine, press ctrl+c
 126   -- (3) `br *0x<addr>'; obtain the address from the disasm above
 127   -- (4) `cont' and press enter
 128   return entry
 129
 130
 131 executeFuncPtr :: Ptr Word8 -> IO ()
 132 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))