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