Mate/ClassPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Mate.ClassPool (
   3   getClassInfo,
   4   classLoaded,
   5   getClassFile,
   6   getMethodTable,
   7   getObjectSize,
   8   getMethodOffset,
   9   getFieldOffset,
  10   getStaticFieldAddr,
  11   getInterfaceMethodOffset,
  12   addClassPath,
  13   addClassPathJAR
  14   ) where
  15
  16 import Data.Int
  17 import Data.Binary
  18 import qualified Data.Map as M
  19 import qualified Data.Set as S
  20 import Data.List
  21 import qualified Data.ByteString.Lazy as B
  22 import Data.String.Utils
  23 import Control.Monad
  24
  25 -- import JVM.Dump
  26
  27 import Foreign.Ptr
  28 import Foreign.C.Types
  29 import Foreign.Storable
  30
  31 import Data.IORef
  32 import System.IO.Unsafe
  33 import System.Directory
  34
  35 import JVM.ClassFile
  36 import JVM.Converter
  37 import Java.ClassPath hiding (Directory)
  38 import Java.JAR
  39
  40 import Mate.BasicBlocks
  41 import {-# SOURCE #-} Mate.MethodPool
  42 import Mate.Types
  43 import Mate.Debug
  44 import Mate.GarbageAlloc
  45 import Mate.NativeSizes
  46
  47 getClassInfo :: B.ByteString -> IO ClassInfo
  48 getClassInfo path = do
  49   class_map <- getClassMap
  50   case M.lookup path class_map of
  51     Nothing -> loadAndInitClass path
  52     Just ci -> return ci
  53
  54 classLoaded :: B.ByteString -> IO Bool
  55 classLoaded path = do
  56   class_map <- getClassMap
  57   return $ M.member path class_map
  58
  59 getClassFile :: B.ByteString -> IO (Class Direct)
  60 getClassFile path = do
  61   ci <- getClassInfo path
  62   return $ ciFile ci
  63
  64 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO CPtrdiff
  65 getStaticFieldOffset path field = do
  66   ci <- getClassInfo path
  67   return $ fromIntegral $ ciStaticMap ci M.! field
  68
  69 getFieldOffset :: B.ByteString -> B.ByteString -> IO Int32
  70 getFieldOffset path field = do
  71   ci <- getClassInfo path
  72   return $ ciFieldMap ci M.! field
  73
  74 -- method + signature plz!
  75 getMethodOffset :: B.ByteString -> B.ByteString -> IO NativeWord
  76 getMethodOffset path method = do
  77   ci <- getClassInfo path
  78   -- (+ ptrSize) one slot for "interface-table-ptr"
  79   return $ (+ ptrSize) $ fromIntegral $ ciMethodMap ci M.! method
  80
  81 getMethodTable :: B.ByteString -> IO NativeWord
  82 getMethodTable path = do
  83   ci <- getClassInfo path
  84   return $ ciMethodBase ci
  85
  86 getObjectSize :: B.ByteString -> IO NativeWord
  87 getObjectSize path = do
  88   ci <- getClassInfo path
  89   -- TODO(bernhard): correct sizes for different types...
  90   let fsize = fromIntegral $ M.size $ ciFieldMap ci
  91   -- one slot for "method-table-ptr"
  92   -- one slot for GC-data
  93   return $ (2 + fsize) * ptrSize
  94
  95 getStaticFieldAddr :: CPtrdiff -> IO CPtrdiff
  96 getStaticFieldAddr from = do
  97   trapmap <- getTrapMap
  98   let w32_from = fromIntegral from
  99   let sfi = trapmap M.! w32_from
 100   setTrapMap $ M.delete w32_from trapmap
 101   case sfi of
 102     (StaticField (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field
 103     _ -> error "getFieldAddr: no TrapCause found. abort"
 104
 105 -- interface + method + signature plz!
 106 getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO NativeWord
 107 getInterfaceMethodOffset ifname meth sig = do
 108   loadInterface ifname
 109   ifmmap <- getInterfaceMethodMap
 110   let k = ifname `B.append` meth `B.append` sig
 111   case M.lookup k ifmmap of
 112     Just w32 -> return $ w32 + 4
 113     Nothing -> error "getInterfaceMethodOffset: no offset set"
 114
 115
 116 readClass :: B.ByteString -> IO ClassInfo
 117 readClass path = do
 118   class_map' <- getClassMap
 119   case M.lookup path class_map' of
 120     Just cm -> return cm
 121     Nothing -> do
 122       cfile <- readClassFile $ toString path
 123       -- TODO(bernhard): hDumpClass
 124       -- dumpClass cfile
 125       -- load all interfaces, which are implemented by this class
 126       sequence_ [ loadInterface i | i <- interfaces cfile ]
 127       superclass <- if path /= "java/lang/Object"
 128           then do
 129             sc <- readClass $ superClass cfile
 130             return $ Just sc
 131           else return Nothing
 132
 133       (staticmap, fieldmap) <- calculateFields cfile superclass
 134       (methodmap, mbase) <- calculateMethodMap cfile superclass
 135       immap <- getInterfaceMethodMap
 136
 137       -- allocate interface offset table for this class
 138       -- TODO(bernhard): we have some duplicates in immap (i.e. some
 139       --                 entries have the same offset), so we could
 140       --                 save some memory here.
 141       iftable <- mallocClassData ((ptrSize*) $ M.size immap)
 142       let wn_iftable = fromIntegral $ ptrToIntPtr iftable :: NativeWord
 143       -- store interface-table at offset 0 in method-table
 144       pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 wn_iftable
 145       let hexDumpMap :: Integral v => String -> M.Map B.ByteString v -> IO ()
 146           hexDumpMap header mmap = do
 147             let printValue :: B.ByteString -> IO ()
 148                 printValue key = printfCp $ printf "\t%-70s: 0x%08x\n" (toString key) val
 149                   where val = fromIntegral (mmap M.! key) :: NativeWord
 150             printfCp $ printf "%s\n" header
 151             mapM_ printValue (M.keys mmap)
 152       if mateDEBUG
 153         then do
 154           let strpath = toString path
 155           hexDumpMap ("staticmap @ " ++ strpath) staticmap
 156           hexDumpMap ("fieldmap @ " ++ strpath) fieldmap
 157           hexDumpMap ("methodmap @ " ++ strpath) methodmap
 158           hexDumpMap ("interfacemap @ " ++ strpath) immap
 159           printfCp $ printf "mbase:   0x%08x\n" mbase
 160           printfCp $ printf "iftable: 0x%08x\n" wn_iftable
 161         else return ()
 162       virtual_map <- getVirtualMap
 163       setVirtualMap $ M.insert mbase path virtual_map
 164
 165       class_map <- getClassMap
 166       let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
 167       setClassMap $ M.insert path new_ci class_map
 168       return new_ci
 169
 170
 171 loadInterface :: B.ByteString -> IO ()
 172 loadInterface path = do
 173   imap <- getInterfaceMap
 174   -- interface already loaded?
 175   case M.lookup path imap of
 176     Just _ -> return ()
 177     Nothing -> do
 178       printfCp $ printf "interface: loading \"%s\"\n" $ toString path
 179       cfile <- readClassFile $ toString path
 180       -- load "superinterfaces" first
 181       sequence_ [ loadInterface i | i <- interfaces cfile ]
 182       immap <- getInterfaceMethodMap
 183
 184       -- load map again, because there could be new entries now
 185       -- due to loading superinterfaces
 186       imap' <- getInterfaceMap
 187       let max_off = fromIntegral $ M.size immap * ptrSize
 188       -- create index of methods by this interface
 189       let mm = zipbase max_off (classMethods cfile)
 190
 191       -- create for each method from *every* superinterface a entry to,
 192       -- but just put in the same offset as it is already in the map
 193       let (ifnames, methodnames) = unzip $ concat
 194             [ zip (repeat ifname) (classMethods $ imap' M.! ifname)
 195             | ifname <- interfaces cfile ]
 196       let sm = zipWith (\x y -> (entry y, immap M.! getname x y)) ifnames methodnames
 197
 198       -- merge all offset tables
 199       setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap
 200       setInterfaceMap $ M.insert path cfile imap'
 201   where
 202     zipbase base = zipWith (\x y -> (entry y, x + base)) [0,ptrSize..]
 203     entry = getname path
 204     getname p y = p `B.append` methodName y `B.append` encode (methodSignature y)
 205
 206
 207 calculateFields :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
 208 calculateFields cf superclass = do
 209     -- TODO(bernhard): correct sizes. int only atm
 210
 211     let (sfields, ifields) = partition (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 212
 213     let sc_sm = getsupermap superclass ciStaticMap
 214     staticbase <- mallocClassData $ fromIntegral (length sfields) * ptrSize
 215     let sm = zipbase (fromIntegral $ ptrToIntPtr staticbase) sfields
 216     -- new fields "overwrite" old ones, if they have the same name
 217     let staticmap = sm `M.union` sc_sm
 218
 219     let sc_im = getsupermap superclass ciFieldMap
 220     -- "+ (2*ptrsize)" for the method table pointer and GC data
 221     let max_off = (+ (2*ptrSize)) $ fromIntegral $ M.size sc_im * ptrSize
 222     let im = zipbase max_off ifields
 223     -- new fields "overwrite" old ones, if they have the same name
 224     let fieldmap = im `M.union` sc_im
 225
 226     return (staticmap, fieldmap)
 227   where
 228     zipbase :: Int32 -> [Field Direct] -> FieldMap
 229     zipbase base = foldr (\(x,y) -> M.insert (fieldName y) (x + base)) M.empty . zip [0,ptrSize..]
 230
 231 -- helper
 232 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 233 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 234
 235
 236 calculateMethodMap :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, NativeWord)
 237 calculateMethodMap cf superclass = do
 238     let methods = filter
 239                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
 240                          ((/=) "<init>" . methodName) x)
 241                   (classMethods cf)
 242     let sc_mm = getsupermap superclass ciMethodMap
 243     let max_off = fromIntegral $ M.size sc_mm * ptrSize
 244     let mm = zipbase max_off methods
 245     let methodmap = M.fromList mm `M.union` sc_mm
 246
 247     -- (+1): one slot for the interface-table-ptr
 248     methodbase <- mallocClassData (((+1) $ fromIntegral $ M.size methodmap) * ptrSize)
 249     return (methodmap, fromIntegral $ ptrToIntPtr methodbase)
 250   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,ptrSize..]
 251           where entry y = methodName y `B.append` encode (methodSignature y)
 252
 253
 254 loadAndInitClass :: B.ByteString -> IO ClassInfo
 255 loadAndInitClass path = do
 256   class_map <- getClassMap
 257   ci <- case M.lookup path class_map of
 258     Nothing -> readClass path
 259     Just x -> return x
 260
 261   -- first try to execute class initializer of superclass
 262   when (path /= "java/lang/Object") (void $ loadAndInitClass $ superClass $ ciFile ci)
 263
 264   -- execute class initializer
 265   case lookupMethod "<clinit>" (ciFile ci) of
 266     Just m -> do
 267       rawmethod <- parseMethod (ciFile ci) "<clinit>" $ MethodSignature [] ReturnsVoid
 268       let mi = MethodInfo "<clinit>" path (methodSignature m)
 269       entry <- compileBB rawmethod mi
 270       addMethodRef entry mi [path]
 271       printfCp $ printf "executing static initializer from %s now\n" (toString path)
 272       executeFuncPtr entry
 273       printfCp $ printf "static initializer from %s done\n" (toString path)
 274     Nothing -> return ()
 275
 276   class_map' <- getClassMap
 277   let new_ci = ci { ciInitDone = True }
 278   setClassMap $ M.insert path new_ci class_map'
 279   return new_ci
 280
 281
 282 readClassFile :: String -> IO (Class Direct)
 283 readClassFile path' = readIORef classPaths >>= rcf
 284   where
 285     path = replace "." "/" path'
 286     rcf :: [MClassPath] -> IO (Class Direct)
 287     rcf [] = error $ "readClassFile: Class \"" ++ show path ++ "\" not found."
 288     rcf (Directory pre:xs) = do
 289       let cf = pre ++ path ++ ".class"
 290       printfCp $ printf "rcf: searching @ %s for %s\n" (show pre) (show path)
 291       b <- doesFileExist cf
 292       if b
 293         then parseClassFile cf
 294         else rcf xs
 295     rcf (JAR p:xs) = do
 296       printfCp $ printf "rcf: searching %s in JAR\n" (show path)
 297       entry <- getEntry p path
 298       case entry of
 299         Just (LoadedJAR _ cls) -> return cls
 300         Nothing -> rcf xs
 301         _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1"
 302
 303 data MClassPath =
 304   Directory String |
 305   JAR [Tree CPEntry]
 306
 307 classPaths :: IORef [MClassPath]
 308 {-# NOINLINE classPaths #-}
 309 classPaths = unsafePerformIO $ newIORef []
 310
 311 addClassPath :: String -> IO ()
 312 addClassPath x = do
 313   cps <- readIORef classPaths
 314   writeIORef classPaths (Directory x:cps)
 315
 316 addClassPathJAR :: String -> IO ()
 317 addClassPathJAR x = do
 318   cps <- readIORef classPaths
 319   t <- execClassPath $ addJAR x
 320   writeIORef classPaths (JAR t:cps)