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