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
  18 import JVM.ClassFile
  19
  20 import Harpy
  21 import Harpy.X86Disassembler
  22
  23 import Mate.BasicBlocks
  24 import Mate.Types
  25 import Mate.X86CodeGen
  26 import Mate.Utilities
  27 import Mate.ClassPool
  28
  29
  30 foreign import ccall "dynamic"
  31    code_void :: FunPtr (IO ()) -> (IO ())
  32
  33
  34 foreign export ccall getMethodEntry :: CUInt -> CUInt -> IO CUInt
  35 getMethodEntry :: CUInt -> CUInt -> IO CUInt
  36 getMethodEntry signal_from methodtable = do
  37   mmap <- get_methodmap >>= ptr2mmap
  38   tmap <- get_trapmap >>= ptr2tmap
  39   vmap <- get_virtualmap >>= ptr2virtualmap
  40
  41   let w32_from = fromIntegral signal_from
  42   let mi = tmap M.! w32_from
  43   let mi'@(MethodInfo method cm sig) =
  44         case mi of
  45           (MI x) -> x
  46           (VI (MethodInfo methname _ msig)) ->
  47               (MethodInfo methname (vmap M.! (fromIntegral methodtable)) msig)
  48           _ -> error $ "getMethodEntry: no trapInfo. abort."
  49   case M.lookup mi' mmap of
  50     Nothing -> do
  51       cls <- getClassFile cm
  52       printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi')
  53       mm <- lookupMethodRecursive method [] cls
  54       case mm of
  55         Just (mm', clsnames, cls') -> do
  56             let flags = methodAccessFlags mm'
  57             case S.member ACC_NATIVE flags of
  58               False -> do
  59                 hmap <- parseMethod cls' method
  60                 printMapBB hmap
  61                 case hmap of
  62                   Just hmap' -> do
  63                     entry <- compileBB hmap' (MethodInfo method (thisClass cls') sig)
  64                     addMethodRef entry mi' clsnames
  65                     return $ fromIntegral entry
  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_methodmap
  74                 return nf
  75         Nothing -> error $ (show method) ++ " not found. abort"
  76     Just w32 -> return (fromIntegral w32)
  77
  78 lookupMethodRecursive :: B.ByteString -> [B.ByteString] -> Class Resolved
  79                          -> IO (Maybe ((Method Resolved, [B.ByteString], Class Resolved)))
  80 lookupMethodRecursive name clsnames cls = do
  81   case res of
  82     Just x -> return $ Just (x, nextclsn, cls)
  83     Nothing -> if thisname == "java/lang/Object"
  84       then return $ Nothing
  85       else do
  86         supercl <- getClassFile (superClass cls)
  87         lookupMethodRecursive name nextclsn supercl
  88   where
  89   res = lookupMethod name cls
  90   thisname = thisClass cls
  91   nextclsn :: [B.ByteString]
  92   nextclsn = thisname:clsnames
  93
  94 -- TODO(bernhard): UBERHAX.  ghc patch?
  95 foreign import ccall safe "lookupSymbol"
  96    c_lookupSymbol :: CString -> IO (Ptr a)
  97
  98 loadNativeFunction :: String -> IO (CUInt)
  99 loadNativeFunction sym = do
 100         _ <- loadRawObject "ffi/native.o"
 101         -- TODO(bernhard): WTF
 102         resolveObjs (return ())
 103         ptr <- withCString sym c_lookupSymbol
 104         if (ptr == nullPtr)
 105           then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
 106           else return $ fromIntegral $ ptrToIntPtr ptr
 107
 108 -- t_01 :: IO ()
 109 -- t_01 = do
 110 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
 111 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
 112 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
 113 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
 114 --   mmap2ptr mmap >>= set_mmap
 115 --   demo_mmap -- access Data.Map from C
 116
 117 initMethodPool :: IO ()
 118 initMethodPool = do
 119   mmap2ptr M.empty >>= set_methodmap
 120   tmap2ptr M.empty >>= set_trapmap
 121   classmap2ptr M.empty >>= set_classmap
 122   virtualmap2ptr M.empty >>= set_virtualmap
 123
 124
 125 addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO ()
 126 addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
 127   mmap <- get_methodmap >>= ptr2mmap
 128   let newmap = M.fromList $ map (\x -> ((MethodInfo mmname x msig), entry)) clsnames
 129   mmap2ptr (mmap `M.union` newmap) >>= set_methodmap
 130
 131
 132 compileBB :: MapBB -> MethodInfo -> IO Word32
 133 compileBB hmap methodinfo = do
 134   tmap <- get_trapmap >>= ptr2tmap
 135
 136   cls <- getClassFile (cName methodinfo)
 137   let ebb = emitFromBB (methName methodinfo) cls hmap
 138   (_, Right ((entry, _, _, new_tmap), disasm)) <- runCodeGen ebb () ()
 139
 140   let tmap' = M.union tmap new_tmap -- prefers elements in cmap
 141   tmap2ptr tmap' >>= set_trapmap
 142
 143   printf "disasm:\n"
 144   mapM_ (putStrLn . showAtt) disasm
 145   -- UNCOMMENT NEXT LINE FOR GDB FUN
 146   -- _ <- getLine
 147   -- (1) start it with `gdb ./mate' and then `run <classfile>'
 148   -- (2) on getLine, press ctrl+c
 149   -- (3) `br *0x<addr>'; obtain the address from the disasm above
 150   -- (4) `cont' and press enter
 151   return $ fromIntegral $ ptrToIntPtr entry
 152
 153
 154 executeFuncPtr :: Word32 -> IO ()
 155 executeFuncPtr entry =
 156   code_void $ ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))