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.Utilities
  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 NativeWord
  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 NativeWord
  90 getMethodTable path = do
  91   ci <- getClassInfo path
  92   return $ ciMethodBase ci
  93
  94 getObjectSize :: B.ByteString -> IO NativeWord
  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 NativeWord
 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 wn_iftable = fromIntegral $ ptrToIntPtr iftable :: NativeWord
 151       -- store interface-table at offset 0 in method-table
 152       pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 wn_iftable
 153       let strpath = toString path
 154 #ifdef DBG_CLASS
 155       hexDumpMap ("staticmap @ " ++ strpath) staticmap
 156       hexDumpMap ("fieldmap @ " ++ strpath) fieldmap
 157       hexDumpMap ("methodmap @ " ++ strpath) methodmap
 158       hexDumpMap ("interfacemap @ " ++ strpath) immap
 159 #endif
 160       printfCp "mbase:   0x%08x\n" mbase
 161       printfCp "iftable: 0x%08x\n" wn_iftable
 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 "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 * 4
 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,4..]
 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) * 4
 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     -- "+ 4" for the method table pointer
 221     let max_off = (4+) $ fromIntegral $ M.size sc_im * 4
 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,4..]
 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 * 4
 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) * 4)
 249     return (methodmap, fromIntegral $ ptrToIntPtr methodbase)
 250   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 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 "executing static initializer from %s now\n" (toString path)
 272       executeFuncPtr entry
 273       printfCp "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 "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 "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)