1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ForeignFunctionInterface #-}
3 module Mate.ClassPool (
11 import qualified Data.Map as M
12 import qualified Data.Set as S
13 import qualified Data.ByteString.Lazy as B
19 import Foreign.C.Types
20 import Foreign.Marshal.Alloc
25 import Mate.BasicBlocks
26 import {-# SOURCE #-} Mate.MethodPool
30 getClassInfo :: B.ByteString -> IO ClassInfo
31 getClassInfo path = do
32 class_map <- get_classmap >>= ptr2classmap
33 case M.lookup path class_map of
34 Nothing -> loadAndInitClass path
37 getClassFile :: B.ByteString -> IO (Class Resolved)
38 getClassFile path = do
39 ci <- getClassInfo path
42 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
43 getStaticFieldOffset path field = do
44 ci <- getClassInfo path
45 return $ fromIntegral $ (clStaticMap ci) M.! field
47 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
48 getFieldOffset path field = do
49 ci <- getClassInfo path
50 return $ (clFieldMap ci) M.! field
52 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
53 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
54 getStaticFieldAddr from ptr_trapmap = do
55 trapmap <- ptr2tmap ptr_trapmap
56 let w32_from = fromIntegral from
57 let sfi = trapmap M.! w32_from
59 (SFI (StaticFieldInfo cls field)) -> do
60 getStaticFieldOffset cls field
61 _ -> error $ "getFieldAddr: no trapInfo. abort"
63 loadClass :: B.ByteString -> IO ClassInfo
65 printf "loadClass: \"%s\"\n" $ toString path
66 let rpath = toString $ path `B.append` ".class"
67 cfile <- parseClassFile rpath
68 superclass <- case (path /= "java/lang/Object") of
70 sc <- loadClass $ superClass cfile
72 False -> return $ Nothing
74 (staticmap, fieldmap) <- calculateFields cfile superclass
75 printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
76 printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
78 class_map <- get_classmap >>= ptr2classmap
79 let new_ci = ClassInfo path cfile staticmap fieldmap False
80 let class_map' = M.insert path new_ci class_map
81 classmap2ptr class_map' >>= set_classmap
85 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
86 calculateFields cf superclass = do
87 -- TODO(bernhard): correct sizes. int only atm
89 let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
91 staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
92 let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
93 let sm = zipbase i_sb sfields
94 let sc_sm = getsupermap clStaticMap
95 -- new fields "overwrite" old ones, if they have the same name
96 let staticmap = (M.fromList sm) `M.union` sc_sm
98 let sc_im = getsupermap clFieldMap
99 -- TODO(bernhard): not efficient :-(
100 let max_off = if (M.size sc_im) > 0 then maximum $ M.elems sc_im else 0
101 let im = zipbase (max_off + 4) ifields
102 -- new fields "overwrite" old ones, if they have the same name
103 let fieldmap = (M.fromList im) `M.union` sc_im
105 return (staticmap, fieldmap)
107 zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
108 getsupermap getter = case superclass of Just x -> getter x; Nothing -> M.empty
111 loadAndInitClass :: B.ByteString -> IO ClassInfo
112 loadAndInitClass path = do
113 class_map <- get_classmap >>= ptr2classmap
114 ci <- case M.lookup path class_map of
115 Nothing -> loadClass path
118 -- first try to execute class initializer of superclass
119 when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
121 -- execute class initializer
122 case lookupMethod "<clinit>" (clFile ci) of
124 hmap <- parseMethod (clFile ci) "<clinit>"
128 let mi = (MethodInfo "<clinit>" path (methodSignature m))
129 entry <- compileBB hmap' mi
130 addMethodRef entry mi [path]
131 printf "executing static initializer from %s now\n" (toString path)
133 printf "static initializer from %s done\n" (toString path)
134 Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
137 class_map' <- get_classmap >>= ptr2classmap
138 let new_ci = ci { clInitDone = True }
139 let class_map'' = M.insert path new_ci class_map'
140 classmap2ptr class_map'' >>= set_classmap