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   ) where
  15
  16 import Data.Int
  17 import Data.Word
  18 import Data.Binary
  19 import qualified Data.Map as M
  20 import qualified Data.Set as S
  21 import qualified Data.ByteString.Lazy as B
  22 import Control.Monad
  23
  24 #ifdef DEBUG
  25 import Text.Printf
  26 #endif
  27 #ifdef DBG_CLASS
  28 import JVM.Dump
  29 #endif
  30
  31 import Foreign.Ptr
  32 import Foreign.C.Types
  33 import Foreign.Storable
  34
  35 import JVM.ClassFile
  36 import JVM.Converter
  37
  38 import Mate.BasicBlocks
  39 import {-# SOURCE #-} Mate.MethodPool
  40 import Mate.Types
  41 import Mate.Utilities
  42 import Mate.Debug
  43 import Mate.GarbageAlloc
  44
  45 getClassInfo :: B.ByteString -> IO ClassInfo
  46 getClassInfo path = do
  47   class_map <- get_classmap >>= ptr2classmap
  48   case M.lookup path class_map of
  49     Nothing -> loadAndInitClass path
  50     Just ci -> return ci
  51
  52 getClassFile :: B.ByteString -> IO (Class Resolved)
  53 getClassFile path = do
  54   ci <- getClassInfo path
  55   return $ ciFile ci
  56
  57 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  58 getStaticFieldOffset path field = do
  59   ci <- getClassInfo path
  60   return $ fromIntegral $ (ciStaticMap ci) M.! field
  61
  62 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
  63 getFieldOffset path field = do
  64   ci <- getClassInfo path
  65   return $ (ciFieldMap ci) M.! field
  66
  67 -- method + signature plz!
  68 getMethodOffset :: B.ByteString -> B.ByteString -> IO (Word32)
  69 getMethodOffset path method = do
  70   ci <- getClassInfo path
  71   -- (4+) one slot for "interface-table-ptr"
  72   return $ (+4) $ fromIntegral $ (ciMethodMap ci) M.! method
  73
  74 getMethodTable :: B.ByteString -> IO (Word32)
  75 getMethodTable path = do
  76   ci <- getClassInfo path
  77   return $ ciMethodBase ci
  78
  79 getObjectSize :: B.ByteString -> IO (Word32)
  80 getObjectSize path = do
  81   ci <- getClassInfo path
  82   -- TODO(bernhard): correct sizes for different types...
  83   let fsize = fromIntegral $ M.size $ ciFieldMap ci
  84   -- one slot for "method-table-ptr"
  85   return $ (1 + fsize) * 4
  86
  87 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  88 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  89 getStaticFieldAddr from ptr_trapmap = do
  90   trapmap <- ptr2trapmap ptr_trapmap
  91   let w32_from = fromIntegral from
  92   let sfi = trapmap M.! w32_from
  93   case sfi of
  94     (SFI (StaticFieldInfo cls field)) -> do
  95       getStaticFieldOffset cls field
  96     _ -> error $ "getFieldAddr: no trapInfo. abort"
  97
  98 -- interface + method + signature plz!
  99 getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO (Word32)
 100 getInterfaceMethodOffset ifname meth sig = do
 101   loadInterface ifname
 102   ifmmap <- get_interfacemethodmap >>= ptr2interfacemethodmap
 103   let k = ifname `B.append` meth `B.append` sig
 104   case M.lookup k ifmmap of
 105     Just w32 -> return $ (+4) w32
 106     Nothing -> error $ "getInterfaceMethodOffset: no offset set"
 107
 108
 109 loadClass :: B.ByteString -> IO ClassInfo
 110 loadClass path = do
 111   let rpath = toString $ path `B.append` ".class"
 112   cfile <- parseClassFile rpath
 113 #ifdef DBG_CLASS
 114   dumpClass cfile
 115 #endif
 116   -- load all interfaces, which are implemented by this class
 117   sequence_ [ loadInterface i | i <- interfaces cfile ]
 118   superclass <- case (path /= "java/lang/Object") of
 119       True -> do
 120         sc <- loadClass $ superClass cfile
 121         return $ Just $ sc
 122       False -> return $ Nothing
 123
 124   (staticmap, fieldmap) <- calculateFields cfile superclass
 125   (methodmap, mbase) <- calculateMethodMap cfile superclass
 126   immap <- get_interfacemethodmap >>= ptr2interfacemethodmap
 127
 128   -- allocate interface offset table for this class
 129   -- TODO(bernhard): we have some duplicates in immap (i.e. some
 130   --                 entries have the same offset), so we could
 131   --                 save some memory here.
 132   iftable <- mallocClassData ((4*) $ M.size immap)
 133   let w32_iftable = fromIntegral $ ptrToIntPtr iftable :: Word32
 134   -- store interface-table at offset 0 in method-table
 135   pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 w32_iftable
 136   printfCp "staticmap: %s @ %s\n" (show staticmap) (toString path)
 137   printfCp "fieldmap:  %s @ %s\n" (show fieldmap) (toString path)
 138   printfCp "methodmap: %s @ %s\n" (show methodmap) (toString path)
 139   printfCp "mbase: 0x%08x\n" mbase
 140   printfCp "interfacemethod: %s @ %s\n" (show immap) (toString path)
 141   printfCp "iftable: 0x%08x\n" w32_iftable
 142   virtual_map <- get_virtualmap >>= ptr2virtualmap
 143   let virtual_map' = M.insert mbase path virtual_map
 144   virtualmap2ptr virtual_map' >>= set_virtualmap
 145
 146   class_map <- get_classmap >>= ptr2classmap
 147   let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
 148   let class_map' = M.insert path new_ci class_map
 149   classmap2ptr class_map' >>= set_classmap
 150   return new_ci
 151
 152
 153 loadInterface :: B.ByteString -> IO ()
 154 loadInterface path = do
 155   imap <- get_interfacesmap >>= ptr2interfacesmap
 156   -- interface already loaded?
 157   case M.lookup path imap of
 158     Just _ -> return ()
 159     Nothing -> do
 160       printfCp "interface: loading \"%s\"\n" $ toString path
 161       let ifpath = toString $ path `B.append` ".class"
 162       cfile <- parseClassFile ifpath
 163       -- load "superinterfaces" first
 164       sequence_ [ loadInterface i | i <- interfaces cfile ]
 165       immap <- get_interfacemethodmap >>= ptr2interfacemethodmap
 166
 167       -- load map again, because there could be new entries now
 168       -- due to loading superinterfaces
 169       imap' <- get_interfacesmap >>= ptr2interfacesmap
 170       let max_off = fromIntegral $ (M.size immap) * 4
 171       -- create index of methods by this interface
 172       let mm = zipbase max_off (classMethods cfile)
 173
 174       -- create for each method from *every* superinterface a entry to,
 175       -- but just put in the same offset as it is already in the map
 176       let (ifnames, methodnames) = unzip $ concat $
 177             [ zip (repeat ifname) (classMethods $ imap' M.! ifname)
 178             | ifname <- interfaces cfile ]
 179       let sm = zipWith (\x y -> (entry y, immap M.! (getname x y))) ifnames methodnames
 180
 181       -- merge all offset tables
 182       let methodmap = (M.fromList sm) `M.union` (M.fromList mm) `M.union` immap
 183       interfacemethodmap2ptr methodmap >>= set_interfacemethodmap
 184
 185       interfacesmap2ptr (M.insert path cfile imap') >>= set_interfacesmap
 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 Resolved -> 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 = (fromIntegral $ (M.size sc_im) * 4) + 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 Resolved -> 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 <- get_classmap >>= ptr2classmap
 242   ci <- case M.lookup path class_map of
 243     Nothing -> loadClass path
 244     Just x -> return x
 245
 246   -- first try to execute class initializer of superclass
 247   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
 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 $ "loadClass: static initializer not found (WTF?). abort"
 262     Nothing -> return ()
 263
 264   class_map' <- get_classmap >>= ptr2classmap
 265   let new_ci = ci { ciInitDone = True }
 266   let class_map'' = M.insert path new_ci class_map'
 267   classmap2ptr class_map'' >>= set_classmap
 268   return new_ci