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 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   case sfi of
 101     (SFI (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field
 102     _ -> error "getFieldAddr: no trapInfo. 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     let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 201
 202     staticbase <- mallocClassData $ fromIntegral (length sfields) * 4
 203     let i_sb = fromIntegral $ ptrToIntPtr staticbase
 204     let sm = zipbase i_sb sfields
 205     let sc_sm = getsupermap superclass ciStaticMap
 206     -- new fields "overwrite" old ones, if they have the same name
 207     let staticmap = M.fromList 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 = M.fromList im `M.union` sc_im
 215
 216     return (staticmap, fieldmap)
 217   where
 218   zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
 219
 220 -- helper
 221 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 222 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 223
 224
 225 calculateMethodMap :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, Word32)
 226 calculateMethodMap cf superclass = do
 227     let methods = filter
 228                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
 229                          ((/=) "<init>" . methodName) x)
 230                   (classMethods cf)
 231     let sc_mm = getsupermap superclass ciMethodMap
 232     let max_off = fromIntegral $ M.size sc_mm * 4
 233     let mm = zipbase max_off methods
 234     let methodmap = M.fromList mm `M.union` sc_mm
 235
 236     -- (+1): one slot for the interface-table-ptr
 237     methodbase <- mallocClassData (((+1) $ fromIntegral $ M.size methodmap) * 4)
 238     return (methodmap, fromIntegral $ ptrToIntPtr methodbase)
 239   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 240           where entry y = methodName y `B.append` encode (methodSignature y)
 241
 242
 243 loadAndInitClass :: B.ByteString -> IO ClassInfo
 244 loadAndInitClass path = do
 245   class_map <- getClassMap
 246   ci <- case M.lookup path class_map of
 247     Nothing -> readClass path
 248     Just x -> return x
 249
 250   -- first try to execute class initializer of superclass
 251   when (path /= "java/lang/Object") (void $ loadAndInitClass $ superClass $ ciFile ci)
 252
 253   -- execute class initializer
 254   case lookupMethod "<clinit>" (ciFile ci) of
 255     Just m -> do
 256       hmap <- parseMethod (ciFile ci) "<clinit>"
 257       case hmap of
 258         Just hmap' -> do
 259           let mi = MethodInfo "<clinit>" path (methodSignature m)
 260           entry <- compileBB hmap' 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 -> error "readClass: static initializer not found (WTF?). abort"
 266     Nothing -> return ()
 267
 268   class_map' <- getClassMap
 269   let new_ci = ci { ciInitDone = True }
 270   setClassMap $ M.insert path new_ci class_map'
 271   return new_ci
 272
 273
 274 readClassFile :: String -> IO (Class Direct)
 275 readClassFile path' = readIORef classPaths >>= rcf
 276   where
 277   path = replace "." "/" path'
 278   rcf :: [MClassPath] -> IO (Class Direct)
 279   rcf [] = error $ "readClassFile: Class \"" ++ (show path) ++ "\" not found."
 280   rcf ((Directory pre):xs) = do
 281     let cf = pre ++ path ++ ".class"
 282     printfCp "rcf: searching @ %s for %s\n" (show pre) (show path)
 283     b <- doesFileExist cf
 284     if b
 285       then parseClassFile cf
 286       else rcf xs
 287   rcf ((JAR p):xs) = do
 288     printfCp "rcf: searching %s in JAR\n" (show path)
 289     entry <- getEntry p path
 290     case entry of
 291       Just (LoadedJAR _ cls) -> return cls
 292       Nothing -> rcf xs
 293       _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1"
 294
 295 data MClassPath =
 296   Directory String |
 297   JAR [Tree CPEntry]
 298
 299 classPaths :: IORef [MClassPath]
 300 {-# NOINLINE classPaths #-}
 301 classPaths = unsafePerformIO $ newIORef []
 302
 303 addClassPath :: String -> IO ()
 304 addClassPath x = do
 305   cps <- readIORef classPaths
 306   writeIORef classPaths (Directory x:cps)
 307
 308 addClassPathJAR :: String -> IO ()
 309 addClassPathJAR x = do
 310   cps <- readIORef classPaths
 311   t <- execClassPath $ addJAR x
 312   writeIORef classPaths (JAR t:cps)