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