1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ForeignFunctionInterface #-}
3 module Mate.ClassPool where
5 import qualified Data.Map as M
6 import qualified Data.Set as S
7 import qualified Data.ByteString.Lazy as B
12 import Foreign.C.Types
13 import Foreign.Marshal.Alloc
20 getClassInfo :: B.ByteString -> IO ClassInfo
21 getClassInfo path = do
22 ptr_classmap <- get_classmap
23 class_map <- ptr2classmap ptr_classmap
24 case M.lookup path class_map of
25 Nothing -> loadClass path
28 getClassFile :: B.ByteString -> IO (Class Resolved)
29 getClassFile path = do
30 (ClassInfo _ cfile _ _) <- getClassInfo path
33 -- TODO(bernhard): I think we don't need that anymore. also remove fieldbase
35 getFieldBase :: B.ByteString -> IO (CUInt)
36 getFieldBase path = do
37 (ClassInfo _ _ fs _) <- getClassInfo path
38 return $ fromIntegral $ ptrToIntPtr fs
40 getFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
41 getFieldOffset path field = do
42 (ClassInfo _ _ _ fieldmap) <- getClassInfo path
43 return $ fromIntegral $ fieldmap M.! field
45 foreign export ccall getFieldAddr :: CUInt -> Ptr () -> IO CUInt
46 getFieldAddr :: CUInt -> Ptr () -> IO CUInt
47 getFieldAddr from ptr_trapmap = do
48 trapmap <- ptr2tmap ptr_trapmap
49 let w32_from = fromIntegral from
50 let sfi = trapmap M.! w32_from
52 (SFI (StaticFieldInfo cls field)) -> do
53 getFieldOffset cls field
54 _ -> error $ "getFieldAddr: no trapInfo. abort"
56 loadClass :: B.ByteString -> IO ClassInfo
58 printf "loadClass: \"%s\"\n" $ toString path
59 let rpath = toString $ path `B.append` ".class"
60 cfile <- parseClassFile rpath
61 superclass <- case (path /= "java/lang/Object") of
63 sc <- loadClass $ superClass cfile
65 False -> return $ Nothing
66 class_map <- get_classmap >>= ptr2classmap
67 -- TODO(bernhard): correct sizes. int only atm
68 let filteredfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
69 fieldbase <- mallocBytes ((fromIntegral $ length filteredfields) * 4)
70 let i_fb = fromIntegral $ ptrToIntPtr $ fieldbase
71 let fm = zipWith (\x y -> (fieldName y, x + i_fb)) [0,4..] filteredfields
72 let sc_fm = case superclass of Just x -> clFieldMap x; Nothing -> M.empty
73 -- new fields "overwrite" old ones, if they have the same name
74 let fieldmap = (M.fromList fm) `M.union` sc_fm
75 printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
76 let new_ci = ClassInfo path cfile fieldbase fieldmap
77 let class_map' = M.insert path new_ci class_map
78 classmap2ptr class_map' >>= set_classmap