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