1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ForeignFunctionInterface #-}
3 module Mate.MethodPool where
6 import qualified Data.Map as M
7 import qualified Data.ByteString.Lazy as B
12 import Foreign.C.Types
13 import Foreign.StablePtr
19 import Harpy.X86Disassembler
21 import Mate.BasicBlocks
23 import Mate.X86CodeGen
26 foreign import ccall "get_mmap"
27 get_mmap :: IO (Ptr ())
29 foreign import ccall "set_mmap"
30 set_mmap :: Ptr () -> IO ()
32 foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
33 getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
34 getMethodEntry signal_from ptr_mmap ptr_cmap = do
35 mmap <- ptr2mmap ptr_mmap
36 cmap <- ptr2cmap ptr_cmap
38 let w32_from = fromIntegral signal_from
39 let mi@(MethodInfo method cm _ cpidx) = cmap M.! w32_from
40 -- TODO(bernhard): replace parsing with some kind of classpool
41 cls <- parseClassFile $ toString $ cm `B.append` ".class"
42 case M.lookup mi mmap of
44 printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi)
45 -- TODO(bernhard): maybe we have to load the class first?
46 -- (Or better in X86CodeGen?)
47 let (CMethod _ nt) = (constsPool cls) M.! cpidx
48 hmap <- parseMethod cls (ntName nt)
52 entry <- compileBB hmap' mi
53 return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
54 Nothing -> error $ (show method) ++ " not found. abort"
55 Just w32 -> return (fromIntegral w32)
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
66 initMethodPool :: IO ()
68 mmap2ptr M.empty >>= set_mmap
69 cmap2ptr M.empty >>= set_cmap
71 compileBB :: MapBB -> MethodInfo -> IO (Ptr Word8)
72 compileBB hmap methodinfo = do
73 mmap <- get_mmap >>= ptr2mmap
74 cmap <- get_cmap >>= ptr2cmap
76 -- TODO(bernhard): replace parsing with some kind of classpool
77 cls <- parseClassFile $ toString $ (cName methodinfo) `B.append` ".class"
78 let ebb = emitFromBB cls hmap
79 (_, Right ((entry, _, _, new_cmap), disasm)) <- runCodeGen ebb () ()
80 let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
82 let mmap' = M.insert methodinfo w32_entry mmap
83 let cmap' = M.union cmap new_cmap -- prefers elements in cmap
84 mmap2ptr mmap' >>= set_mmap
85 cmap2ptr cmap' >>= set_cmap
88 mapM_ (putStrLn . showAtt) disasm
89 -- UNCOMMENT NEXT LINE FOR GDB FUN
91 -- (1) start it with `gdb ./mate' and then `run <classfile>'
92 -- (2) on getLine, press ctrl+c
93 -- (3) `br *0x<addr>'; obtain the address from the disasm above
94 -- (4) `cont' and press enter
98 foreign import ccall "dynamic"
99 code_void :: FunPtr (IO ()) -> (IO ())
101 executeFuncPtr :: Ptr Word8 -> IO ()
102 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))
104 -- TODO(bernhard): make some typeclass magic 'n stuff
105 mmap2ptr :: MMap -> IO (Ptr ())
107 ptr_mmap <- newStablePtr mmap
108 return $ castStablePtrToPtr ptr_mmap
110 ptr2mmap :: Ptr () -> IO MMap
111 ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
113 cmap2ptr :: CMap -> IO (Ptr ())
115 ptr_cmap <- newStablePtr cmap
116 return $ castStablePtrToPtr ptr_cmap
118 ptr2cmap :: Ptr () -> IO CMap
119 ptr2cmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr cmap)