Mate/ClassPool.hs

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