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