Mate/MethodPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.MethodPool where
   4
   5 import Data.Binary
   6 import qualified Data.Map as M
   7 import qualified Data.ByteString.Lazy as B
   8
   9 import Text.Printf
  10
  11 import Foreign.Ptr
  12 import Foreign.C.Types
  13 import Foreign.StablePtr
  14
  15 import JVM.ClassFile
  16
  17 import Harpy
  18 import Harpy.X86Disassembler
  19
  20 import Mate.BasicBlocks
  21 import Mate.X86CodeGen
  22
  23
  24 foreign import ccall "get_mmap"
  25   get_mmap :: IO (Ptr ())
  26
  27 foreign import ccall "set_mmap"
  28   set_mmap :: Ptr () -> IO ()
  29
  30
  31 -- B.ByteString = name of method
  32 -- Word32 = entrypoint of method
  33 type MMap = M.Map B.ByteString Word32
  34
  35 foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  36 getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
  37 getMethodEntry signal_from ptr_mmap ptr_cmap = do
  38   mmap <- ptr2mmap ptr_mmap
  39   cmap <- ptr2cmap ptr_cmap
  40
  41   let w32_from = fromIntegral signal_from
  42   let (method, cls, cpidx) = cmap M.! w32_from
  43   case M.lookup method mmap of
  44     Nothing -> do
  45       printf "getMethodEntry(from 0x%08x): no method found. compile it\n" w32_from
  46       -- TODO(bernhard): maybe we have to load the class first?
  47       --                 (Or better in X86CodeGen?)
  48       let (CMethod _ nt) = (constsPool cls) M.! cpidx
  49       hmap <- parseMethod cls (ntName nt)
  50       case hmap of
  51         Just hmap' -> do
  52           entry <- compileBB hmap' cls method
  53           return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  54         Nothing -> error $ (show method) ++ " not found. abort"
  55     Just w32 -> return (fromIntegral w32)
  56
  57 -- t_01 :: IO ()
  58 -- t_01 = do
  59 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
  60 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  61 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
  62 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
  63 --   mmap2ptr mmap >>= set_mmap
  64 --   demo_mmap -- access Data.Map from C
  65
  66 initMethodPool :: IO ()
  67 initMethodPool = do
  68   mmap2ptr M.empty >>= set_mmap
  69   cmap2ptr M.empty >>= set_cmap
  70
  71 compileBB :: MapBB -> Class Resolved -> B.ByteString -> IO (Ptr Word8)
  72 compileBB hmap cls name = do
  73   mmap <- get_mmap >>= ptr2mmap
  74   cmap <- get_cmap >>= ptr2cmap
  75
  76   let ebb = emitFromBB cls hmap
  77   (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () ()
  78   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  79
  80   let mmap' = M.insert name w32_entry mmap
  81   let cmap' = M.union cmap new_cmap -- prefers elements in cmap
  82   mmap2ptr mmap' >>= set_mmap
  83   cmap2ptr cmap' >>= set_cmap
  84
  85   printf "disasm:\n"
  86   mapM_ (putStrLn . showAtt) disasm
  87   return entry
  88
  89
  90 foreign import ccall "dynamic"
  91    code_void :: FunPtr (IO ()) -> (IO ())
  92
  93 executeFuncPtr :: Ptr Word8 -> IO ()
  94 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
  95
  96 -- TODO(bernhard): make some typeclass magic 'n stuff
  97 mmap2ptr :: MMap -> IO (Ptr ())
  98 mmap2ptr mmap = do
  99   ptr_mmap <- newStablePtr mmap
 100   return $ castStablePtrToPtr ptr_mmap
 101
 102 ptr2mmap :: Ptr () -> IO MMap
 103 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
 104
 105 cmap2ptr :: CMap -> IO (Ptr ())
 106 cmap2ptr cmap = do
 107   ptr_cmap <- newStablePtr cmap
 108   return $ castStablePtrToPtr ptr_cmap
 109
 110 ptr2cmap :: Ptr () -> IO CMap
 111 ptr2cmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)