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 >>= ptr2methodmap
  38   tmap <- get_trapmap >>= ptr2trapmap
  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                 -- TODO(bernhard): cleaner please... *do'h*
  69                 let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace ";" "_" $ replace "/" "_" $ 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                 methodmap2ptr mmap' >>= set_methodmap
  75                 return nf
  76         Nothing -> error $ (show method) ++ " not found. abort"
  77     Just w32 -> return (fromIntegral w32)
  78
  79 lookupMethodRecursive :: B.ByteString -> [B.ByteString] -> Class Resolved
  80                          -> IO (Maybe ((Method Resolved, [B.ByteString], Class Resolved)))
  81 lookupMethodRecursive name clsnames cls = do
  82   case res of
  83     Just x -> return $ Just (x, nextclsn, cls)
  84     Nothing -> if thisname == "java/lang/Object"
  85       then return $ Nothing
  86       else do
  87         supercl <- getClassFile (superClass cls)
  88         lookupMethodRecursive name nextclsn supercl
  89   where
  90   res = lookupMethod name cls
  91   thisname = thisClass cls
  92   nextclsn :: [B.ByteString]
  93   nextclsn = thisname:clsnames
  94
  95 -- TODO(bernhard): UBERHAX.  ghc patch?
  96 foreign import ccall safe "lookupSymbol"
  97    c_lookupSymbol :: CString -> IO (Ptr a)
  98
  99 loadNativeFunction :: String -> IO (CUInt)
 100 loadNativeFunction sym = do
 101         _ <- loadRawObject "ffi/native.o"
 102         -- TODO(bernhard): WTF
 103         resolveObjs (return ())
 104         ptr <- withCString sym c_lookupSymbol
 105         if (ptr == nullPtr)
 106           then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
 107           else return $ fromIntegral $ ptrToIntPtr ptr
 108
 109 -- t_01 :: IO ()
 110 -- t_01 = do
 111 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
 112 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
 113 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
 114 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
 115 --   mmap2ptr mmap >>= set_mmap
 116 --   demo_mmap -- access Data.Map from C
 117
 118 initMethodPool :: IO ()
 119 initMethodPool = do
 120   methodmap2ptr M.empty >>= set_methodmap
 121   trapmap2ptr M.empty >>= set_trapmap
 122   classmap2ptr M.empty >>= set_classmap
 123   virtualmap2ptr M.empty >>= set_virtualmap
 124   stringsmap2ptr M.empty >>= set_stringsmap
 125
 126
 127 addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO ()
 128 addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
 129   mmap <- get_methodmap >>= ptr2methodmap
 130   let newmap = M.fromList $ map (\x -> ((MethodInfo mmname x msig), entry)) clsnames
 131   methodmap2ptr (mmap `M.union` newmap) >>= set_methodmap
 132
 133
 134 compileBB :: MapBB -> MethodInfo -> IO Word32
 135 compileBB hmap methodinfo = do
 136   tmap <- get_trapmap >>= ptr2trapmap
 137
 138   cls <- getClassFile (methClassName methodinfo)
 139   let ebb = emitFromBB (methName methodinfo) cls hmap
 140   (_, Right ((entry, _, _, new_tmap), disasm)) <- runCodeGen ebb () ()
 141
 142   let tmap' = M.union tmap new_tmap -- prefers elements in cmap
 143   trapmap2ptr tmap' >>= set_trapmap
 144
 145   printf "disasm:\n"
 146   mapM_ (putStrLn . showAtt) disasm
 147   -- UNCOMMENT NEXT LINE FOR GDB FUN
 148   -- _ <- getLine
 149   -- (1) start it with `gdb ./mate' and then `run <classfile>'
 150   -- (2) on getLine, press ctrl+c
 151   -- (3) `br *0x<addr>'; obtain the address from the disasm above
 152   -- (4) `cont' and press enter
 153   return $ fromIntegral $ ptrToIntPtr entry
 154
 155
 156 executeFuncPtr :: Word32 -> IO ()
 157 executeFuncPtr entry =
 158   code_void $ ((castPtrToFunPtr $ intPtrToPtr $ fromIntegral entry) :: FunPtr (IO ()))