2 {-# LANGUAGE OverloadedStrings #-}
4 module Mate.ClassPool (
12 getInterfaceMethodOffset,
20 import qualified Data.Map as M
21 import qualified Data.Set as S
23 import qualified Data.ByteString.Lazy as B
24 import Data.String.Utils
35 import Foreign.C.Types
36 import Foreign.Storable
39 import System.IO.Unsafe
40 import System.Directory
44 import Java.ClassPath hiding (Directory)
47 import Mate.BasicBlocks
48 import {-# SOURCE #-} Mate.MethodPool
51 import Mate.GarbageAlloc
52 import Mate.NativeSizes
54 getClassInfo :: B.ByteString -> IO ClassInfo
55 getClassInfo path = do
56 class_map <- getClassMap
57 case M.lookup path class_map of
58 Nothing -> loadAndInitClass path
61 getClassFile :: B.ByteString -> IO (Class Direct)
62 getClassFile path = do
63 ci <- getClassInfo path
66 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO CPtrdiff
67 getStaticFieldOffset path field = do
68 ci <- getClassInfo path
69 return $ fromIntegral $ ciStaticMap ci M.! field
71 getFieldOffset :: B.ByteString -> B.ByteString -> IO Int32
72 getFieldOffset path field = do
73 ci <- getClassInfo path
74 return $ ciFieldMap ci M.! field
76 -- method + signature plz!
77 getMethodOffset :: B.ByteString -> B.ByteString -> IO Word32
78 getMethodOffset path method = do
79 ci <- getClassInfo path
80 -- (+ ptrSize) one slot for "interface-table-ptr"
81 return $ (+ ptrSize) $ fromIntegral $ ciMethodMap ci M.! method
83 getMethodTable :: B.ByteString -> IO Word32
84 getMethodTable path = do
85 ci <- getClassInfo path
86 return $ ciMethodBase ci
88 getObjectSize :: B.ByteString -> IO Word32
89 getObjectSize path = do
90 ci <- getClassInfo path
91 -- TODO(bernhard): correct sizes for different types...
92 let fsize = fromIntegral $ M.size $ ciFieldMap ci
93 -- one slot for "method-table-ptr"
94 return $ (1 + fsize) * ptrSize
96 getStaticFieldAddr :: CPtrdiff -> IO CPtrdiff
97 getStaticFieldAddr from = do
99 let w32_from = fromIntegral from
100 let sfi = trapmap M.! w32_from
101 setTrapMap $ M.delete w32_from trapmap
103 (StaticField (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field
104 _ -> error "getFieldAddr: no TrapCause found. abort"
106 -- interface + method + signature plz!
107 getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO Word32
108 getInterfaceMethodOffset ifname meth sig = do
110 ifmmap <- getInterfaceMethodMap
111 let k = ifname `B.append` meth `B.append` sig
112 case M.lookup k ifmmap of
113 Just w32 -> return $ w32 + 4
114 Nothing -> error "getInterfaceMethodOffset: no offset set"
117 readClass :: B.ByteString -> IO ClassInfo
119 class_map' <- getClassMap
120 case M.lookup path class_map' of
123 cfile <- readClassFile $ toString path
127 -- load all interfaces, which are implemented by this class
128 sequence_ [ loadInterface i | i <- interfaces cfile ]
129 superclass <- if path /= "java/lang/Object"
131 sc <- readClass $ superClass cfile
135 (staticmap, fieldmap) <- calculateFields cfile superclass
136 (methodmap, mbase) <- calculateMethodMap cfile superclass
137 immap <- getInterfaceMethodMap
139 -- allocate interface offset table for this class
140 -- TODO(bernhard): we have some duplicates in immap (i.e. some
141 -- entries have the same offset), so we could
142 -- save some memory here.
143 iftable <- mallocClassData ((4*) $ M.size immap)
144 let w32_iftable = fromIntegral $ ptrToIntPtr iftable :: Word32
145 -- store interface-table at offset 0 in method-table
146 pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 w32_iftable
147 printfCp "staticmap: %s @ %s\n" (show staticmap) (toString path)
148 printfCp "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
149 printfCp "methodmap: %s @ %s\n" (show methodmap) (toString path)
150 printfCp "mbase: 0x%08x\n" mbase
151 printfCp "interfacemethod: %s @ %s\n" (show immap) (toString path)
152 printfCp "iftable: 0x%08x\n" w32_iftable
153 virtual_map <- getVirtualMap
154 setVirtualMap $ M.insert mbase path virtual_map
156 class_map <- getClassMap
157 let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
158 setClassMap $ M.insert path new_ci class_map
162 loadInterface :: B.ByteString -> IO ()
163 loadInterface path = do
164 imap <- getInterfaceMap
165 -- interface already loaded?
166 case M.lookup path imap of
169 printfCp "interface: loading \"%s\"\n" $ toString path
170 cfile <- readClassFile $ toString path
171 -- load "superinterfaces" first
172 sequence_ [ loadInterface i | i <- interfaces cfile ]
173 immap <- getInterfaceMethodMap
175 -- load map again, because there could be new entries now
176 -- due to loading superinterfaces
177 imap' <- getInterfaceMap
178 let max_off = fromIntegral $ M.size immap * 4
179 -- create index of methods by this interface
180 let mm = zipbase max_off (classMethods cfile)
182 -- create for each method from *every* superinterface a entry to,
183 -- but just put in the same offset as it is already in the map
184 let (ifnames, methodnames) = unzip $ concat
185 [ zip (repeat ifname) (classMethods $ imap' M.! ifname)
186 | ifname <- interfaces cfile ]
187 let sm = zipWith (\x y -> (entry y, immap M.! getname x y)) ifnames methodnames
189 -- merge all offset tables
190 setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap
191 setInterfaceMap $ M.insert path cfile imap'
193 zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
195 getname p y = p `B.append` methodName y `B.append` encode (methodSignature y)
198 calculateFields :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
199 calculateFields cf superclass = do
200 -- TODO(bernhard): correct sizes. int only atm
202 let (sfields, ifields) = partition (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
204 let sc_sm = getsupermap superclass ciStaticMap
205 staticbase <- mallocClassData $ fromIntegral (length sfields) * 4
206 let sm = zipbase (fromIntegral $ ptrToIntPtr staticbase) sfields
207 -- new fields "overwrite" old ones, if they have the same name
208 let staticmap = sm `M.union` sc_sm
210 let sc_im = getsupermap superclass ciFieldMap
211 -- "+ 4" for the method table pointer
212 let max_off = (4+) $ fromIntegral $ M.size sc_im * 4
213 let im = zipbase max_off ifields
214 -- new fields "overwrite" old ones, if they have the same name
215 let fieldmap = im `M.union` sc_im
217 return (staticmap, fieldmap)
219 zipbase :: Int32 -> [Field Direct] -> FieldMap
220 zipbase base = foldr (\(x,y) -> M.insert (fieldName y) (x + base)) M.empty . zip [0,4..]
223 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
224 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
227 calculateMethodMap :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, Word32)
228 calculateMethodMap cf superclass = do
230 (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
231 ((/=) "<init>" . methodName) x)
233 let sc_mm = getsupermap superclass ciMethodMap
234 let max_off = fromIntegral $ M.size sc_mm * 4
235 let mm = zipbase max_off methods
236 let methodmap = M.fromList mm `M.union` sc_mm
238 -- (+1): one slot for the interface-table-ptr
239 methodbase <- mallocClassData (((+1) $ fromIntegral $ M.size methodmap) * 4)
240 return (methodmap, fromIntegral $ ptrToIntPtr methodbase)
241 where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
242 where entry y = methodName y `B.append` encode (methodSignature y)
245 loadAndInitClass :: B.ByteString -> IO ClassInfo
246 loadAndInitClass path = do
247 class_map <- getClassMap
248 ci <- case M.lookup path class_map of
249 Nothing -> readClass path
252 -- first try to execute class initializer of superclass
253 when (path /= "java/lang/Object") (void $ loadAndInitClass $ superClass $ ciFile ci)
255 -- execute class initializer
256 case lookupMethod "<clinit>" (ciFile ci) of
258 rawmethod <- parseMethod (ciFile ci) "<clinit>" $ MethodSignature [] ReturnsVoid
259 let mi = MethodInfo "<clinit>" path (methodSignature m)
260 entry <- compileBB rawmethod mi
261 addMethodRef entry mi [path]
262 printfCp "executing static initializer from %s now\n" (toString path)
264 printfCp "static initializer from %s done\n" (toString path)
267 class_map' <- getClassMap
268 let new_ci = ci { ciInitDone = True }
269 setClassMap $ M.insert path new_ci class_map'
273 readClassFile :: String -> IO (Class Direct)
274 readClassFile path' = readIORef classPaths >>= rcf
276 path = replace "." "/" path'
277 rcf :: [MClassPath] -> IO (Class Direct)
278 rcf [] = error $ "readClassFile: Class \"" ++ show path ++ "\" not found."
279 rcf (Directory pre:xs) = do
280 let cf = pre ++ path ++ ".class"
281 printfCp "rcf: searching @ %s for %s\n" (show pre) (show path)
282 b <- doesFileExist cf
284 then parseClassFile cf
287 printfCp "rcf: searching %s in JAR\n" (show path)
288 entry <- getEntry p path
290 Just (LoadedJAR _ cls) -> return cls
292 _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1"
298 classPaths :: IORef [MClassPath]
299 {-# NOINLINE classPaths #-}
300 classPaths = unsafePerformIO $ newIORef []
302 addClassPath :: String -> IO ()
304 cps <- readIORef classPaths
305 writeIORef classPaths (Directory x:cps)
307 addClassPathJAR :: String -> IO ()
308 addClassPathJAR x = do
309 cps <- readIORef classPaths
310 t <- execClassPath $ addJAR x
311 writeIORef classPaths (JAR t:cps)