Mate/ClassPool.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 module Mate.ClassPool (
   5   getClassInfo,
   6   getClassFile,
   7   getMethodTable,
   8   getObjectSize,
   9   getMethodOffset,
  10   getFieldOffset,
  11   getStaticFieldAddr,
  12   getInterfaceMethodOffset
  13   ) where
  14
  15 import Data.Int
  16 import Data.Word
  17 import Data.Binary
  18 import qualified Data.Map as M
  19 import qualified Data.Set as S
  20 import qualified Data.ByteString.Lazy as B
  21 import Control.Monad
  22
  23 #ifdef DEBUG
  24 import Text.Printf
  25 #endif
  26
  27 import Foreign.Ptr
  28 import Foreign.C.Types
  29 import Foreign.Marshal.Alloc
  30 import Foreign.Storable
  31
  32 import JVM.ClassFile
  33 import JVM.Converter
  34
  35 import Mate.BasicBlocks
  36 import {-# SOURCE #-} Mate.MethodPool
  37 import Mate.Types
  38 import Mate.Utilities
  39
  40 getClassInfo :: B.ByteString -> IO ClassInfo
  41 getClassInfo path = do
  42   class_map <- get_classmap >>= ptr2classmap
  43   case M.lookup path class_map of
  44     Nothing -> loadAndInitClass path
  45     Just ci -> return ci
  46
  47 getClassFile :: B.ByteString -> IO (Class Resolved)
  48 getClassFile path = do
  49   ci <- getClassInfo path
  50   return $ ciFile ci
  51
  52 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  53 getStaticFieldOffset path field = do
  54   ci <- getClassInfo path
  55   return $ fromIntegral $ (ciStaticMap ci) M.! field
  56
  57 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
  58 getFieldOffset path field = do
  59   ci <- getClassInfo path
  60   return $ (ciFieldMap ci) M.! field
  61
  62 -- method + signature plz!
  63 getMethodOffset :: B.ByteString -> B.ByteString -> IO (Word32)
  64 getMethodOffset path method = do
  65   ci <- getClassInfo path
  66   -- (4+) one slot for "interface-table-ptr"
  67   return $ (+4) $ fromIntegral $ (ciMethodMap ci) M.! method
  68
  69 getMethodTable :: B.ByteString -> IO (Word32)
  70 getMethodTable path = do
  71   ci <- getClassInfo path
  72   return $ ciMethodBase ci
  73
  74 getObjectSize :: B.ByteString -> IO (Word32)
  75 getObjectSize path = do
  76   ci <- getClassInfo path
  77   -- TODO(bernhard): correct sizes for different types...
  78   let fsize = fromIntegral $ M.size $ ciFieldMap ci
  79   -- one slot for "method-table-ptr"
  80   return $ (1 + fsize) * 4
  81
  82 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  83 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  84 getStaticFieldAddr from ptr_trapmap = do
  85   trapmap <- ptr2trapmap ptr_trapmap
  86   let w32_from = fromIntegral from
  87   let sfi = trapmap M.! w32_from
  88   case sfi of
  89     (SFI (StaticFieldInfo cls field)) -> do
  90       getStaticFieldOffset cls field
  91     _ -> error $ "getFieldAddr: no trapInfo. abort"
  92
  93 -- interface + method + signature plz!
  94 getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO (Word32)
  95 getInterfaceMethodOffset ifname meth sig = do
  96   loadInterface ifname
  97   ifmmap <- get_interfacemethodmap >>= ptr2interfacemethodmap
  98   let k = ifname `B.append` meth `B.append` sig
  99   case M.lookup k ifmmap of
 100     Just w32 -> return $ (+4) w32
 101     Nothing -> error $ "getInterfaceMethodOffset: no offset set"
 102
 103 loadClass :: B.ByteString -> IO ClassInfo
 104 loadClass path = do
 105 #ifdef DEBUG
 106   printf "loadClass: \"%s\"\n" $ toString path
 107 #endif
 108   let rpath = toString $ path `B.append` ".class"
 109   cfile <- parseClassFile rpath
 110   -- load all interfaces, which are implemented by this class
 111   sequence_ [ loadInterface i | i <- interfaces cfile ]
 112   superclass <- case (path /= "java/lang/Object") of
 113       True -> do
 114         sc <- loadClass $ superClass cfile
 115         return $ Just $ sc
 116       False -> return $ Nothing
 117
 118   (staticmap, fieldmap) <- calculateFields cfile superclass
 119   (methodmap, mbase) <- calculateMethodMap cfile superclass
 120   immap <- get_interfacemethodmap >>= ptr2interfacemethodmap
 121
 122   -- allocate interface offset table for this class
 123   -- TODO(bernhard): we have some duplicates in immap (i.e. some
 124   --                 entries have the same offset), so we could
 125   --                 save some memory here.
 126   iftable <- mallocBytes ((4*) $ M.size immap)
 127   let w32_iftable = fromIntegral $ ptrToIntPtr iftable :: Word32
 128   -- store interface-table at offset 0 in method-table
 129   pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 w32_iftable
 130 #ifdef DEBUG
 131   printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
 132   printf "fieldmap:  %s @ %s\n" (show fieldmap) (toString path)
 133   printf "methodmap: %s @ %s\n" (show methodmap) (toString path)
 134   printf "mbase: 0x%08x\n" mbase
 135   printf "interfacemethod: %s @ %s\n" (show immap) (toString path)
 136   printf "iftable: 0x%08x\n" w32_iftable
 137 #endif
 138   virtual_map <- get_virtualmap >>= ptr2virtualmap
 139   let virtual_map' = M.insert mbase path virtual_map
 140   virtualmap2ptr virtual_map' >>= set_virtualmap
 141
 142   class_map <- get_classmap >>= ptr2classmap
 143   let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
 144   let class_map' = M.insert path new_ci class_map
 145   classmap2ptr class_map' >>= set_classmap
 146   return new_ci
 147
 148
 149 loadInterface :: B.ByteString -> IO ()
 150 loadInterface path = do
 151   imap <- get_interfacesmap >>= ptr2interfacesmap
 152   -- interface already loaded?
 153   case M.lookup path imap of
 154     Just _ -> return ()
 155     Nothing -> do
 156 #ifdef DEBUG
 157       printf "interface: loading \"%s\"\n" $ toString path
 158 #endif
 159       let ifpath = toString $ path `B.append` ".class"
 160       cfile <- parseClassFile ifpath
 161       -- load "superinterfaces" first
 162       sequence_ [ loadInterface i | i <- interfaces cfile ]
 163       immap <- get_interfacemethodmap >>= ptr2interfacemethodmap
 164
 165       -- load map again, because there could be new entries now
 166       -- due to loading superinterfaces
 167       imap' <- get_interfacesmap >>= ptr2interfacesmap
 168       let max_off = fromIntegral $ (M.size immap) * 4
 169       -- create index of methods by this interface
 170       let mm = zipbase max_off (classMethods cfile)
 171
 172       -- create for each method from *every* superinterface a entry to,
 173       -- but just put in the same offset as it is already in the map
 174       let (ifnames, methodnames) = unzip $ concat $
 175             [ zip (repeat ifname) (classMethods $ imap' M.! ifname)
 176             | ifname <- interfaces cfile ]
 177       let sm = zipWith (\x y -> (entry y, immap M.! (getname x y))) ifnames methodnames
 178
 179       -- merge all offset tables
 180       let methodmap = (M.fromList sm) `M.union` (M.fromList mm) `M.union` immap
 181       interfacemethodmap2ptr methodmap >>= set_interfacemethodmap
 182
 183       interfacesmap2ptr (M.insert path cfile imap') >>= set_interfacesmap
 184   where
 185   zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 186   entry = getname path
 187   getname p y = p `B.append` (methodName y) `B.append` (encode $ methodSignature y)
 188
 189
 190 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
 191 calculateFields cf superclass = do
 192     -- TODO(bernhard): correct sizes. int only atm
 193
 194     let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 195
 196     staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
 197     let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
 198     let sm = zipbase i_sb sfields
 199     let sc_sm = getsupermap superclass ciStaticMap
 200     -- new fields "overwrite" old ones, if they have the same name
 201     let staticmap = (M.fromList sm) `M.union` sc_sm
 202
 203     let sc_im = getsupermap superclass ciFieldMap
 204     -- "+ 4" for the method table pointer
 205     let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
 206     let im = zipbase max_off ifields
 207     -- new fields "overwrite" old ones, if they have the same name
 208     let fieldmap = (M.fromList im) `M.union` sc_im
 209
 210     return (staticmap, fieldmap)
 211   where
 212   zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
 213
 214 -- helper
 215 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 216 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 217
 218
 219 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
 220 calculateMethodMap cf superclass = do
 221     let methods = filter
 222                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
 223                          ((/=) "<init>" . methodName) x)
 224                   (classMethods cf)
 225     let sc_mm = getsupermap superclass ciMethodMap
 226     let max_off = fromIntegral $ (M.size sc_mm) * 4
 227     let mm = zipbase max_off methods
 228     let methodmap = (M.fromList mm) `M.union` sc_mm
 229
 230     -- (+1): one slot for the interface-table-ptr
 231     methodbase <- mallocBytes (((+1) $ fromIntegral $ M.size methodmap) * 4)
 232     return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
 233   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 234           where entry y = (methodName y) `B.append` (encode $ methodSignature y)
 235
 236
 237 loadAndInitClass :: B.ByteString -> IO ClassInfo
 238 loadAndInitClass path = do
 239   class_map <- get_classmap >>= ptr2classmap
 240   ci <- case M.lookup path class_map of
 241     Nothing -> loadClass path
 242     Just x -> return x
 243
 244   -- first try to execute class initializer of superclass
 245   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
 246
 247   -- execute class initializer
 248   case lookupMethod "<clinit>" (ciFile ci) of
 249     Just m -> do
 250       hmap <- parseMethod (ciFile ci) "<clinit>"
 251       case hmap of
 252         Just hmap' -> do
 253           let mi = (MethodInfo "<clinit>" path (methodSignature m))
 254           entry <- compileBB hmap' mi
 255           addMethodRef entry mi [path]
 256 #ifdef DEBUG
 257           printf "executing static initializer from %s now\n" (toString path)
 258 #endif
 259           executeFuncPtr entry
 260 #ifdef DEBUG
 261           printf "static initializer from %s done\n" (toString path)
 262 #endif
 263         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
 264     Nothing -> return ()
 265
 266   class_map' <- get_classmap >>= ptr2classmap
 267   let new_ci = ci { ciInitDone = True }
 268   let class_map'' = M.insert path new_ci class_map'
 269   classmap2ptr class_map'' >>= set_classmap
 270   return new_ci