Mate/MethodPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.MethodPool where
   4
   5 import Data.Binary
   6 import Data.String
   7 import qualified Data.Map as M
   8 import qualified Data.ByteString.Lazy as B
   9
  10 import Text.Printf
  11
  12 import Foreign.Ptr
  13 import Foreign.C.Types
  14 import Foreign.C.String
  15 import Foreign.StablePtr
  16
  17 import JVM.Converter
  18
  19 import Harpy
  20 import Harpy.X86Disassembler
  21
  22 import Mate.BasicBlocks
  23 import Mate.X86CodeGen
  24
  25
  26 foreign import ccall "get_mmap"
  27   get_mmap :: IO (Ptr ())
  28
  29 foreign import ccall "set_mmap"
  30   set_mmap :: Ptr () -> IO ()
  31
  32
  33 -- B.ByteString = name of method
  34 -- Word32 = entrypoint of method
  35 type MMap = M.Map B.ByteString Word32
  36
  37 -- TODO(bernhard): not in use yet
  38 -- Word32 = point of method call
  39 -- B.ByteString = name of called method
  40 type CMap = M.Map Word32 B.ByteString
  41
  42 foreign export ccall getMethodEntry :: Ptr () -> CString -> IO CUInt
  43 getMethodEntry :: Ptr () -> CString -> IO CUInt
  44 getMethodEntry ptr_mmap cstr = do
  45   mmap <- ptr2mmap ptr_mmap
  46   str' <- peekCString cstr
  47   let method = fromString str'
  48   case M.lookup method mmap of
  49     Nothing -> do
  50       printf "getMethodEntry: no method found. compile it\n"
  51       -- TODO(bernhard): hardcoded... fixme!
  52       cls <- parseClassFile "tests/Fib.class"
  53       hmap <- parseMethod cls method
  54       case hmap of
  55         Just hmap' -> do
  56           entry <- compileBB hmap' method
  57           let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  58           let mmap' = M.insert method w32_entry mmap
  59           mmap2ptr mmap' >>= set_mmap
  60           return $ fromIntegral w32_entry
  61         Nothing -> error $ (show method) ++ " not found. abort"
  62     Just w32 -> return (fromIntegral w32)
  63
  64 -- t_01 :: IO ()
  65 -- t_01 = do
  66 --   (entry, _) <- testCase "./tests/Fib.class" "fib"
  67 --   let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  68 --   let mmap = M.insert ("fib" :: String) int_entry M.empty
  69 --   mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
  70 --   mmap2ptr mmap >>= set_mmap
  71 --   demo_mmap -- access Data.Map from C
  72
  73 initMethodPool :: IO ()
  74 initMethodPool = mmap2ptr M.empty >>= set_mmap
  75
  76 compileBB :: MapBB -> B.ByteString -> IO (Ptr Word8)
  77 compileBB hmap name = do
  78   mmap <- get_mmap >>= ptr2mmap
  79   let ebb = emitFromBB hmap
  80   (_, Right ((entry, bbstarts, end), disasm)) <- runCodeGen ebb () ()
  81   let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
  82   let mmap' = M.insert name w32_entry mmap
  83   mmap2ptr mmap' >>= set_mmap
  84   printf "disasm:\n"
  85   mapM_ (putStrLn . showAtt) disasm
  86   return entry
  87
  88 foreign import ccall "dynamic"
  89    code_void :: FunPtr (IO ()) -> (IO ())
  90
  91 executeFuncPtr :: Ptr Word8 -> IO ()
  92 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
  93
  94 mmap2ptr :: MMap -> IO (Ptr ())
  95 mmap2ptr mmap = do
  96   ptr_mmap <- newStablePtr mmap
  97   return $ castStablePtrToPtr ptr_mmap
  98
  99 ptr2mmap :: Ptr () -> IO MMap
 100 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)