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