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