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