getClassInfo :: B.ByteString -> IO ClassInfo
getClassInfo path = do
- class_map <- get_classmap >>= ptr2classmap
+ class_map <- getClassMap
case M.lookup path class_map of
Nothing -> loadAndInitClass path
Just ci -> return ci
foreign export ccall getStaticFieldAddr :: CUInt -> IO CUInt
getStaticFieldAddr :: CUInt -> IO CUInt
getStaticFieldAddr from = do
- trapmap <- get_trapmap >>= ptr2trapmap
+ trapmap <- getTrapMap
let w32_from = fromIntegral from
let sfi = trapmap M.! w32_from
case sfi of
getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO Word32
getInterfaceMethodOffset ifname meth sig = do
loadInterface ifname
- ifmmap <- get_interfacemethodmap >>= ptr2interfacemethodmap
+ ifmmap <- getInterfaceMethodMap
let k = ifname `B.append` meth `B.append` sig
case M.lookup k ifmmap of
Just w32 -> return $ w32 + 4
(staticmap, fieldmap) <- calculateFields cfile superclass
(methodmap, mbase) <- calculateMethodMap cfile superclass
- immap <- get_interfacemethodmap >>= ptr2interfacemethodmap
+ immap <- getInterfaceMethodMap
-- allocate interface offset table for this class
-- TODO(bernhard): we have some duplicates in immap (i.e. some
printfCp "mbase: 0x%08x\n" mbase
printfCp "interfacemethod: %s @ %s\n" (show immap) (toString path)
printfCp "iftable: 0x%08x\n" w32_iftable
- virtual_map <- get_virtualmap >>= ptr2virtualmap
- let virtual_map' = M.insert mbase path virtual_map
- virtualmap2ptr virtual_map' >>= set_virtualmap
+ virtual_map <- getVirtualMap
+ setVirtualMap $ M.insert mbase path virtual_map
- class_map <- get_classmap >>= ptr2classmap
+ class_map <- getClassMap
let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
- let class_map' = M.insert path new_ci class_map
- classmap2ptr class_map' >>= set_classmap
+ setClassMap $ M.insert path new_ci class_map
return new_ci
loadInterface :: B.ByteString -> IO ()
loadInterface path = do
- imap <- get_interfacesmap >>= ptr2interfacesmap
+ imap <- getInterfaceMap
-- interface already loaded?
case M.lookup path imap of
Just _ -> return ()
cfile <- parseClassFile ifpath
-- load "superinterfaces" first
sequence_ [ loadInterface i | i <- interfaces cfile ]
- immap <- get_interfacemethodmap >>= ptr2interfacemethodmap
+ immap <- getInterfaceMethodMap
-- load map again, because there could be new entries now
-- due to loading superinterfaces
- imap' <- get_interfacesmap >>= ptr2interfacesmap
+ imap' <- getInterfaceMap
let max_off = fromIntegral $ M.size immap * 4
-- create index of methods by this interface
let mm = zipbase max_off (classMethods cfile)
let sm = zipWith (\x y -> (entry y, immap M.! getname x y)) ifnames methodnames
-- merge all offset tables
- let methodmap = M.fromList sm `M.union` M.fromList mm `M.union` immap
- interfacemethodmap2ptr methodmap >>= set_interfacemethodmap
-
- interfacesmap2ptr (M.insert path cfile imap') >>= set_interfacesmap
+ setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap
+ setInterfaceMap $ M.insert path cfile imap'
where
zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
entry = getname path
loadAndInitClass :: B.ByteString -> IO ClassInfo
loadAndInitClass path = do
- class_map <- get_classmap >>= ptr2classmap
+ class_map <- getClassMap
ci <- case M.lookup path class_map of
Nothing -> loadClass path
Just x -> return x
Nothing -> error "loadClass: static initializer not found (WTF?). abort"
Nothing -> return ()
- class_map' <- get_classmap >>= ptr2classmap
+ class_map' <- getClassMap
let new_ci = ci { ciInitDone = True }
- let class_map'' = M.insert path new_ci class_map'
- classmap2ptr class_map'' >>= set_classmap
+ setClassMap $ M.insert path new_ci class_map'
return new_ci
foreign export ccall getTrapType :: CUInt -> CUInt -> IO CUInt
getTrapType :: CUInt -> CUInt -> IO CUInt
getTrapType signal_from from2 = do
- tmap <- get_trapmap >>= ptr2trapmap
+ tmap <- getTrapMap
case M.lookup (fromIntegral signal_from) tmap of
(Just (MI _)) -> return 0
(Just (VI _)) -> return 1
foreign export ccall getMethodEntry :: CUInt -> CUInt -> IO CUInt
getMethodEntry :: CUInt -> CUInt -> IO CUInt
getMethodEntry signal_from methodtable = do
- mmap <- get_methodmap >>= ptr2methodmap
- tmap <- get_trapmap >>= ptr2trapmap
- vmap <- get_virtualmap >>= ptr2virtualmap
+ mmap <- getMethodMap
+ tmap <- getTrapMap
+ vmap <- getVirtualMap
let w32_from = fromIntegral signal_from
let mi = tmap M.! w32_from
printfMp "native-call: symbol: %s\n" symbol
nf <- loadNativeFunction symbol
let w32_nf = fromIntegral nf
- let mmap' = M.insert mi' w32_nf mmap
- methodmap2ptr mmap' >>= set_methodmap
+ setMethodMap $ M.insert mi' w32_nf mmap
return nf
else do
hmap <- parseMethod cls' method
-- demo_mmap -- access Data.Map from C
initMethodPool :: IO ()
-initMethodPool = do
- methodmap2ptr M.empty >>= set_methodmap
- trapmap2ptr M.empty >>= set_trapmap
- classmap2ptr M.empty >>= set_classmap
- virtualmap2ptr M.empty >>= set_virtualmap
- stringsmap2ptr M.empty >>= set_stringsmap
- interfacesmap2ptr M.empty >>= set_interfacesmap
- interfacemethodmap2ptr M.empty >>= set_interfacemethodmap
+initMethodPool = ctx2ptr emptyMateCtx >>= set_mate_context
addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO ()
addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
- mmap <- get_methodmap >>= ptr2methodmap
+ mmap <- getMethodMap
let newmap = M.fromList $ map (\x -> (MethodInfo mmname x msig, entry)) clsnames
- methodmap2ptr (mmap `M.union` newmap) >>= set_methodmap
+ setMethodMap $ mmap `M.union` newmap
compileBB :: MapBB -> MethodInfo -> IO Word32
compileBB hmap methodinfo = do
- tmap <- get_trapmap >>= ptr2trapmap
+ tmap <- getTrapMap
cls <- getClassFile (methClassName methodinfo)
let ebb = emitFromBB (methName methodinfo) cls hmap
(_, Right right) <- runCodeGen ebb () ()
let ((entry, _, _, new_tmap), _) = right
- let tmap' = tmap `M.union` new_tmap -- prefers elements in tmap
- trapmap2ptr tmap' >>= set_trapmap
+ setTrapMap $ tmap `M.union` new_tmap -- prefers elements in tmap
printfJit "generated code of \"%s\":\n" (toString $ methName methodinfo)
mapM_ (printfJit "%s\n" . showAtt) (snd right)
getUniqueStringAddr :: B.ByteString -> IO Word32
getUniqueStringAddr str = do
- smap <- get_stringsmap >>= ptr2stringsmap
+ smap <- getStringMap
case M.lookup str smap of
Nothing -> do
addr <- allocateJavaString str
- let smap' = M.insert str addr smap
- stringsmap2ptr smap' >>= set_stringsmap
+ setStringMap $ M.insert str addr smap
return addr
Just addr -> return addr
-- java strings are allocated only once, therefore we
-- use a hashmap to store the address for a String
-type StringsMap = M.Map B.ByteString Word32
+type StringMap = M.Map B.ByteString Word32
-- map "methodtable addr" to "classname"
-- store each parsed Interface upon first loading
-type InterfacesMap = M.Map B.ByteString (Class Resolved)
+type InterfaceMap = M.Map B.ByteString (Class Resolved)
-- store offset for each <Interface><Method><Signature> pair
type InterfaceMethodMap = M.Map B.ByteString Word32
-- those functions are for the "global map hax"
-- TODO(bernhard): other solution please
-foreign import ccall "get_trapmap"
- get_trapmap :: IO (Ptr ())
+foreign import ccall "set_mate_context"
+ set_mate_context :: Ptr () -> IO ()
-foreign import ccall "set_trapmap"
- set_trapmap :: Ptr () -> IO ()
+foreign import ccall "get_mate_context"
+ get_mate_context :: IO (Ptr ())
-foreign import ccall "get_methodmap"
- get_methodmap :: IO (Ptr ())
+data MateCtx = MateCtx {
+ ctxMethodMap :: MethodMap,
+ ctxTrapMap :: TrapMap,
+ ctxClassMap :: ClassMap,
+ ctxVirtualMap :: VirtualMap,
+ ctxStringMap :: StringMap,
+ ctxInterfaceMap :: InterfaceMap,
+ ctxInterfaceMethodMap :: InterfaceMethodMap }
-foreign import ccall "set_methodmap"
- set_methodmap :: Ptr () -> IO ()
+emptyMateCtx :: MateCtx
+emptyMateCtx = MateCtx M.empty M.empty M.empty M.empty M.empty M.empty M.empty
-foreign import ccall "get_classmap"
- get_classmap :: IO (Ptr ())
+ctx2ptr :: MateCtx -> IO (Ptr ())
+ctx2ptr ctx = do
+ ptr <- newStablePtr ctx
+ return $ castStablePtrToPtr ptr
-foreign import ccall "set_classmap"
- set_classmap :: Ptr () -> IO ()
+ptr2ctx :: Ptr () -> IO MateCtx
+ptr2ctx ptr = deRefStablePtr (castPtrToStablePtr ptr :: StablePtr MateCtx)
-foreign import ccall "get_virtualmap"
- get_virtualmap :: IO (Ptr ())
-foreign import ccall "set_virtualmap"
- set_virtualmap :: Ptr () -> IO ()
+setMethodMap :: MethodMap -> IO ()
+setMethodMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxMethodMap = m } >>= set_mate_context
-foreign import ccall "get_stringsmap"
- get_stringsmap :: IO (Ptr ())
+getMethodMap :: IO MethodMap
+getMethodMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxMethodMap ctx
-foreign import ccall "set_stringsmap"
- set_stringsmap :: Ptr () -> IO ()
-foreign import ccall "get_interfacesmap"
- get_interfacesmap :: IO (Ptr ())
+setTrapMap :: TrapMap -> IO ()
+setTrapMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxTrapMap = m } >>= set_mate_context
-foreign import ccall "set_interfacesmap"
- set_interfacesmap :: Ptr () -> IO ()
+getTrapMap :: IO TrapMap
+getTrapMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxTrapMap ctx
-foreign import ccall "get_interfacemethodmap"
- get_interfacemethodmap :: IO (Ptr ())
-foreign import ccall "set_interfacemethodmap"
- set_interfacemethodmap :: Ptr () -> IO ()
+setClassMap :: ClassMap -> IO ()
+setClassMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxClassMap = m } >>= set_mate_context
--- TODO(bernhard): make some typeclass magic 'n stuff
--- or remove that sh**
-methodmap2ptr :: MethodMap -> IO (Ptr ())
-methodmap2ptr methodmap = do
- ptr_methodmap <- newStablePtr methodmap
- return $ castStablePtrToPtr ptr_methodmap
+getClassMap :: IO ClassMap
+getClassMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxClassMap ctx
-ptr2methodmap :: Ptr () -> IO MethodMap
-ptr2methodmap methodmap = deRefStablePtr (castPtrToStablePtr methodmap :: StablePtr MethodMap)
-trapmap2ptr :: TrapMap -> IO (Ptr ())
-trapmap2ptr trapmap = do
- ptr_trapmap <- newStablePtr trapmap
- return $ castStablePtrToPtr ptr_trapmap
+setVirtualMap :: VirtualMap -> IO ()
+setVirtualMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxVirtualMap = m } >>= set_mate_context
-ptr2trapmap :: Ptr () -> IO TrapMap
-ptr2trapmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr trapmap)
+getVirtualMap :: IO VirtualMap
+getVirtualMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxVirtualMap ctx
-classmap2ptr :: ClassMap -> IO (Ptr ())
-classmap2ptr cmap = do
- ptr_cmap <- newStablePtr cmap
- return $ castStablePtrToPtr ptr_cmap
-ptr2classmap :: Ptr () -> IO ClassMap
-ptr2classmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
+setStringMap :: StringMap -> IO ()
+setStringMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxStringMap = m } >>= set_mate_context
-virtualmap2ptr :: VirtualMap -> IO (Ptr ())
-virtualmap2ptr cmap = do
- ptr_cmap <- newStablePtr cmap
- return $ castStablePtrToPtr ptr_cmap
+getStringMap :: IO StringMap
+getStringMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxStringMap ctx
-ptr2virtualmap :: Ptr () -> IO VirtualMap
-ptr2virtualmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
+setInterfaceMap :: InterfaceMap -> IO ()
+setInterfaceMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxInterfaceMap = m } >>= set_mate_context
-stringsmap2ptr :: StringsMap -> IO (Ptr ())
-stringsmap2ptr cmap = do
- ptr_cmap <- newStablePtr cmap
- return $ castStablePtrToPtr ptr_cmap
+getInterfaceMap :: IO InterfaceMap
+getInterfaceMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxInterfaceMap ctx
-ptr2stringsmap :: Ptr () -> IO StringsMap
-ptr2stringsmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
+setInterfaceMethodMap :: InterfaceMethodMap -> IO ()
+setInterfaceMethodMap m = do
+ ctx <- get_mate_context >>= ptr2ctx
+ ctx2ptr ctx { ctxInterfaceMethodMap = m } >>= set_mate_context
-interfacesmap2ptr :: InterfacesMap -> IO (Ptr ())
-interfacesmap2ptr cmap = do
- ptr_cmap <- newStablePtr cmap
- return $ castStablePtrToPtr ptr_cmap
-
-ptr2interfacesmap :: Ptr () -> IO InterfacesMap
-ptr2interfacesmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
-
-
-interfacemethodmap2ptr :: InterfaceMethodMap -> IO (Ptr ())
-interfacemethodmap2ptr cmap = do
- ptr_cmap <- newStablePtr cmap
- return $ castStablePtrToPtr ptr_cmap
-
-ptr2interfacemethodmap :: Ptr () -> IO InterfaceMethodMap
-ptr2interfacemethodmap vmap = deRefStablePtr (castPtrToStablePtr vmap :: StablePtr cmap)
+getInterfaceMethodMap :: IO InterfaceMethodMap
+getInterfaceMethodMap = do
+ ctx <- get_mate_context >>= ptr2ctx
+ return $ ctxInterfaceMethodMap ctx
#define dprintf(args...)
#endif
-#define NEW_MAP(prefix) \
- void* prefix ## _map = NULL; \
- void set_ ## prefix ## map(void *map) \
- { \
- dprintf("set_%s: 0x%08x\n", #prefix , (unsigned int) map); \
- prefix ## _map = map; \
- } \
- void *get_ ## prefix ## map() \
- { \
- dprintf("get_%s: 0x%08x\n", #prefix , (unsigned int) prefix ## _map); \
- return prefix ## _map; \
- }
+void *mate_ctx = NULL;
-NEW_MAP(method)
-NEW_MAP(trap)
-NEW_MAP(class)
-NEW_MAP(virtual)
-NEW_MAP(strings)
-NEW_MAP(interfaces)
-NEW_MAP(interfacemethod)
+void *get_mate_context()
+{
+ return mate_ctx;
+}
+void *set_mate_context(void *ctx)
+{
+ mate_ctx = ctx;
+}
void mainresult(unsigned int a)
{
projects / mate.git / commitdiff