1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ForeignFunctionInterface #-}
3 module Mate.ClassPool (
16 import qualified Data.Map as M
17 import qualified Data.Set as S
18 import qualified Data.ByteString.Lazy as B
24 import Foreign.C.Types
25 import Foreign.Marshal.Alloc
30 import Mate.BasicBlocks
31 import {-# SOURCE #-} Mate.MethodPool
35 getClassInfo :: B.ByteString -> IO ClassInfo
36 getClassInfo path = do
37 class_map <- get_classmap >>= ptr2classmap
38 case M.lookup path class_map of
39 Nothing -> loadAndInitClass path
42 getClassFile :: B.ByteString -> IO (Class Resolved)
43 getClassFile path = do
44 ci <- getClassInfo path
47 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
48 getStaticFieldOffset path field = do
49 ci <- getClassInfo path
50 return $ fromIntegral $ (ciStaticMap ci) M.! field
52 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
53 getFieldOffset path field = do
54 ci <- getClassInfo path
55 return $ (ciFieldMap ci) M.! field
57 -- method + signature plz!
58 getMethodOffset :: B.ByteString -> B.ByteString -> IO (Word32)
59 getMethodOffset path method = do
60 ci <- getClassInfo path
61 return $ fromIntegral $ (ciMethodMap ci) M.! method
63 getMethodTable :: B.ByteString -> IO (Word32)
64 getMethodTable path = do
65 ci <- getClassInfo path
66 return $ ciMethodBase ci
68 getObjectSize :: B.ByteString -> IO (Word32)
69 getObjectSize path = do
70 ci <- getClassInfo path
71 -- TODO(bernhard): correct sizes for different types...
72 let fsize = fromIntegral $ M.size $ ciFieldMap ci
73 -- one slot for "method-table-ptr"
74 return $ (1 + fsize) * 4
76 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
77 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
78 getStaticFieldAddr from ptr_trapmap = do
79 trapmap <- ptr2trapmap ptr_trapmap
80 let w32_from = fromIntegral from
81 let sfi = trapmap M.! w32_from
83 (SFI (StaticFieldInfo cls field)) -> do
84 getStaticFieldOffset cls field
85 _ -> error $ "getFieldAddr: no trapInfo. abort"
87 loadClass :: B.ByteString -> IO ClassInfo
89 printf "loadClass: \"%s\"\n" $ toString path
90 let rpath = toString $ path `B.append` ".class"
91 cfile <- parseClassFile rpath
92 superclass <- case (path /= "java/lang/Object") of
94 sc <- loadClass $ superClass cfile
96 False -> return $ Nothing
98 (staticmap, fieldmap) <- calculateFields cfile superclass
99 printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
100 printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
101 (methodmap, mbase) <- calculateMethodMap cfile superclass
102 printf "methodmap: %s @ %s\n" (show methodmap) (toString path)
103 printf "mbase: 0x%08x\n" mbase
105 virtual_map <- get_virtualmap >>= ptr2virtualmap
106 let virtual_map' = M.insert mbase path virtual_map
107 virtualmap2ptr virtual_map' >>= set_virtualmap
109 class_map <- get_classmap >>= ptr2classmap
110 let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
111 let class_map' = M.insert path new_ci class_map
112 classmap2ptr class_map' >>= set_classmap
116 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
117 calculateFields cf superclass = do
118 -- TODO(bernhard): correct sizes. int only atm
120 let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
122 staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
123 let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
124 let sm = zipbase i_sb sfields
125 let sc_sm = getsupermap superclass ciStaticMap
126 -- new fields "overwrite" old ones, if they have the same name
127 let staticmap = (M.fromList sm) `M.union` sc_sm
129 let sc_im = getsupermap superclass ciFieldMap
130 -- "+ 4" for the method table pointer
131 let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
132 let im = zipbase max_off ifields
133 -- new fields "overwrite" old ones, if they have the same name
134 let fieldmap = (M.fromList im) `M.union` sc_im
136 return (staticmap, fieldmap)
138 zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
141 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
142 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
145 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
146 calculateMethodMap cf superclass = do
148 (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
149 ((/=) "<init>" . methodName) x)
151 let sc_mm = getsupermap superclass ciMethodMap
152 let max_off = fromIntegral $ (M.size sc_mm) * 4
153 let mm = zipbase max_off methods
154 let methodmap = (M.fromList mm) `M.union` sc_mm
156 methodbase <- mallocBytes ((fromIntegral $ M.size methodmap) * 4)
157 return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
158 where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
159 where entry y = (methodName y) `B.append` (encode $ methodSignature y)
162 loadAndInitClass :: B.ByteString -> IO ClassInfo
163 loadAndInitClass path = do
164 class_map <- get_classmap >>= ptr2classmap
165 ci <- case M.lookup path class_map of
166 Nothing -> loadClass path
169 -- first try to execute class initializer of superclass
170 when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
172 -- execute class initializer
173 case lookupMethod "<clinit>" (ciFile ci) of
175 hmap <- parseMethod (ciFile ci) "<clinit>"
179 let mi = (MethodInfo "<clinit>" path (methodSignature m))
180 entry <- compileBB hmap' mi
181 addMethodRef entry mi [path]
182 printf "executing static initializer from %s now\n" (toString path)
184 printf "static initializer from %s done\n" (toString path)
185 Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
188 class_map' <- get_classmap >>= ptr2classmap
189 let new_ci = ci { ciInitDone = True }
190 let class_map'' = M.insert path new_ci class_map'
191 classmap2ptr class_map'' >>= set_classmap