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     -- 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>"
 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)