Mate/ClassPool.hs

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