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