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 $ (clStaticMap ci) M.! field
52 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
53 getFieldOffset path field = do
54 ci <- getClassInfo path
55 return $ (clFieldMap 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 $ (clMethodMap ci) M.! method
63 getMethodTable :: B.ByteString -> IO (Word32)
64 getMethodTable path = do
65 ci <- getClassInfo path
66 return $ clMethodBase ci
68 getMethodSize :: B.ByteString -> IO (Word32)
69 getMethodSize path = do
70 ci <- getClassInfo path
71 -- TODO(bernhard): correct sizes for different types...
72 let msize = fromIntegral $ M.size $ clMethodMap ci
73 return $ (1 + msize) * 4
75 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
76 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
77 getStaticFieldAddr from ptr_trapmap = do
78 trapmap <- ptr2tmap ptr_trapmap
79 let w32_from = fromIntegral from
80 let sfi = trapmap M.! w32_from
82 (SFI (StaticFieldInfo cls field)) -> do
83 getStaticFieldOffset cls field
84 _ -> error $ "getFieldAddr: no trapInfo. abort"
86 loadClass :: B.ByteString -> IO ClassInfo
88 printf "loadClass: \"%s\"\n" $ toString path
89 let rpath = toString $ path `B.append` ".class"
90 cfile <- parseClassFile rpath
91 superclass <- case (path /= "java/lang/Object") of
93 sc <- loadClass $ superClass cfile
95 False -> return $ Nothing
97 (staticmap, fieldmap) <- calculateFields cfile superclass
98 printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
99 printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
100 (methodmap, mbase) <- calculateMethodMap cfile superclass
101 printf "methodmap: %s @ %s\n" (show methodmap) (toString path)
102 printf "mbase: 0x%08x\n" mbase
104 virtual_map <- get_virtualmap >>= ptr2virtualmap
105 let virtual_map' = M.insert mbase path virtual_map
106 virtualmap2ptr virtual_map' >>= set_virtualmap
108 class_map <- get_classmap >>= ptr2classmap
109 let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
110 let class_map' = M.insert path new_ci class_map
111 classmap2ptr class_map' >>= set_classmap
115 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
116 calculateFields cf superclass = do
117 -- TODO(bernhard): correct sizes. int only atm
119 let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
121 staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
122 let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
123 let sm = zipbase i_sb sfields
124 let sc_sm = getsupermap superclass clStaticMap
125 -- new fields "overwrite" old ones, if they have the same name
126 let staticmap = (M.fromList sm) `M.union` sc_sm
128 let sc_im = getsupermap superclass clFieldMap
129 -- "+ 4" for the method table pointer
130 let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
131 let im = zipbase max_off ifields
132 -- new fields "overwrite" old ones, if they have the same name
133 let fieldmap = (M.fromList im) `M.union` sc_im
135 return (staticmap, fieldmap)
137 zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
140 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
141 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
144 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
145 calculateMethodMap cf superclass = do
147 (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
148 ((/=) "<init>" . methodName) x)
150 let sc_mm = getsupermap superclass clMethodMap
151 let max_off = fromIntegral $ (M.size sc_mm) * 4
152 let mm = zipbase max_off methods
153 let methodmap = (M.fromList mm) `M.union` sc_mm
155 methodbase <- mallocBytes ((fromIntegral $ M.size methodmap) * 4)
156 return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
157 where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
158 where entry y = (methodName y) `B.append` (encode $ methodSignature y)
161 loadAndInitClass :: B.ByteString -> IO ClassInfo
162 loadAndInitClass path = do
163 class_map <- get_classmap >>= ptr2classmap
164 ci <- case M.lookup path class_map of
165 Nothing -> loadClass path
168 -- first try to execute class initializer of superclass
169 when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
171 -- execute class initializer
172 case lookupMethod "<clinit>" (clFile ci) of
174 hmap <- parseMethod (clFile ci) "<clinit>"
178 let mi = (MethodInfo "<clinit>" path (methodSignature m))
179 entry <- compileBB hmap' mi
180 addMethodRef entry mi [path]
181 printf "executing static initializer from %s now\n" (toString path)
183 printf "static initializer from %s done\n" (toString path)
184 Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
187 class_map' <- get_classmap >>= ptr2classmap
188 let new_ci = ci { clInitDone = True }
189 let class_map'' = M.insert path new_ci class_map'
190 classmap2ptr class_map'' >>= set_classmap