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 class_map <- get_classmap >>= ptr2classmap
105 let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
106 let class_map' = M.insert path new_ci class_map
107 classmap2ptr class_map' >>= set_classmap
111 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
112 calculateFields cf superclass = do
113 -- TODO(bernhard): correct sizes. int only atm
115 let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
117 staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
118 let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
119 let sm = zipbase i_sb sfields
120 let sc_sm = getsupermap superclass clStaticMap
121 -- new fields "overwrite" old ones, if they have the same name
122 let staticmap = (M.fromList sm) `M.union` sc_sm
124 let sc_im = getsupermap superclass clFieldMap
125 -- "+ 4" for the method table pointer
126 let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
127 let im = zipbase max_off ifields
128 -- new fields "overwrite" old ones, if they have the same name
129 let fieldmap = (M.fromList im) `M.union` sc_im
131 return (staticmap, fieldmap)
133 zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
136 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
137 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
140 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
141 calculateMethodMap cf superclass = do
143 (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
144 ((/=) "<init>" . methodName) x)
146 let sc_mm = getsupermap superclass clMethodMap
147 let max_off = fromIntegral $ (M.size sc_mm) * 4
148 let mm = zipbase max_off methods
149 let methodmap = (M.fromList mm) `M.union` sc_mm
151 methodbase <- mallocBytes ((fromIntegral $ M.size methodmap) * 4)
152 return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
153 where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
154 where entry y = (methodName y) `B.append` (encode $ methodSignature y)
157 loadAndInitClass :: B.ByteString -> IO ClassInfo
158 loadAndInitClass path = do
159 class_map <- get_classmap >>= ptr2classmap
160 ci <- case M.lookup path class_map of
161 Nothing -> loadClass path
164 -- first try to execute class initializer of superclass
165 when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
167 -- execute class initializer
168 case lookupMethod "<clinit>" (clFile ci) of
170 hmap <- parseMethod (clFile ci) "<clinit>"
174 let mi = (MethodInfo "<clinit>" path (methodSignature m))
175 entry <- compileBB hmap' mi
176 addMethodRef entry mi [path]
177 printf "executing static initializer from %s now\n" (toString path)
179 printf "static initializer from %s done\n" (toString path)
180 Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
183 class_map' <- get_classmap >>= ptr2classmap
184 let new_ci = ci { clInitDone = True }
185 let class_map'' = M.insert path new_ci class_map'
186 classmap2ptr class_map'' >>= set_classmap