Mate/ClassPool.hs

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