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