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