1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ForeignFunctionInterface #-}
3 module Mate.MethodPool where
6 import Data.String.Utils
7 import qualified Data.Map as M
8 import qualified Data.Set as S
14 import Foreign.C.Types
15 import Foreign.C.String
20 import Harpy.X86Disassembler
22 import Mate.BasicBlocks
24 import Mate.X86CodeGen
29 foreign import ccall "dynamic"
30 code_void :: FunPtr (IO ()) -> (IO ())
33 foreign export ccall getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
34 getMethodEntry :: CUInt -> Ptr () -> Ptr () -> IO CUInt
35 getMethodEntry signal_from ptr_mmap ptr_tmap = do
36 mmap <- ptr2mmap ptr_mmap
37 tmap <- ptr2tmap ptr_tmap
39 let w32_from = fromIntegral signal_from
40 let mi = tmap M.! w32_from
42 (MI mi'@(MethodInfo method cm sig)) -> do
43 case M.lookup mi' mmap of
45 cls <- getClassFile cm
46 printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show mi')
47 let mm = lookupMethod method cls
50 let flags = methodAccessFlags mm'
51 case S.member ACC_NATIVE flags of
53 hmap <- parseMethod cls method
57 entry <- compileBB hmap' mi'
58 return $ fromIntegral $ ((fromIntegral $ ptrToIntPtr entry) :: Word32)
59 Nothing -> error $ (show method) ++ " not found. abort"
61 let symbol = (replace "/" "_" $ toString cm) ++ "__" ++ (toString method) ++ "__" ++ (replace "(" "_" (replace ")" "_" $ toString $ encode sig))
62 printf "native-call: symbol: %s\n" symbol
63 nf <- loadNativeFunction symbol
64 let w32_nf = fromIntegral nf
65 let mmap' = M.insert mi' w32_nf mmap
66 mmap2ptr mmap' >>= set_methodmap
68 Nothing -> error $ (show method) ++ " not found. abort"
69 Just w32 -> return (fromIntegral w32)
70 _ -> error $ "getMethodEntry: no trapInfo. abort"
72 -- TODO(bernhard): UBERHAX. ghc patch?
73 foreign import ccall safe "lookupSymbol"
74 c_lookupSymbol :: CString -> IO (Ptr a)
76 loadNativeFunction :: String -> IO (CUInt)
77 loadNativeFunction sym = do
78 _ <- loadRawObject "ffi/native.o"
79 -- TODO(bernhard): WTF
80 resolveObjs (return ())
81 ptr <- withCString sym c_lookupSymbol
83 then error $ "dyn. loading of \"" ++ sym ++ "\" failed."
84 else return $ fromIntegral $ ptrToIntPtr ptr
88 -- (entry, _) <- testCase "./tests/Fib.class" "fib"
89 -- let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
90 -- let mmap = M.insert ("fib" :: String) int_entry M.empty
91 -- mapM_ (\(x,y) -> printf "%s at 0x%08x\n" x y) $ M.toList mmap
92 -- mmap2ptr mmap >>= set_mmap
93 -- demo_mmap -- access Data.Map from C
95 initMethodPool :: IO ()
97 mmap2ptr M.empty >>= set_methodmap
98 tmap2ptr M.empty >>= set_trapmap
99 classmap2ptr M.empty >>= set_classmap
101 compileBB :: MapBB -> MethodInfo -> IO (Ptr Word8)
102 compileBB hmap methodinfo = do
103 mmap <- get_methodmap >>= ptr2mmap
104 tmap <- get_trapmap >>= ptr2tmap
106 -- TODO(bernhard): replace parsing with some kind of classpool
107 cls <- getClassFile (cName methodinfo)
108 let ebb = emitFromBB (methName methodinfo) cls hmap
109 (_, Right ((entry, _, _, new_tmap), disasm)) <- runCodeGen ebb () ()
110 let w32_entry = ((fromIntegral $ ptrToIntPtr entry) :: Word32)
112 let mmap' = M.insert methodinfo w32_entry mmap
113 let tmap' = M.union tmap new_tmap -- prefers elements in cmap
114 mmap2ptr mmap' >>= set_methodmap
115 tmap2ptr tmap' >>= set_trapmap
118 mapM_ (putStrLn . showAtt) disasm
119 -- UNCOMMENT NEXT LINE FOR GDB FUN
121 -- (1) start it with `gdb ./mate' and then `run <classfile>'
122 -- (2) on getLine, press ctrl+c
123 -- (3) `br *0x<addr>'; obtain the address from the disasm above
124 -- (4) `cont' and press enter
128 executeFuncPtr :: Ptr Word8 -> IO ()
129 executeFuncPtr entry = code_void $ ((castPtrToFunPtr entry) :: FunPtr (IO ()))