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   ) where
  13
  14 import Data.Int
  15 import Data.Word
  16 import Data.Binary
  17 import qualified Data.Map as M
  18 import qualified Data.Set as S
  19 import qualified Data.ByteString.Lazy as B
  20 import Control.Monad
  21
  22 #ifdef DEBUG
  23 import Text.Printf
  24 #endif
  25
  26 import Foreign.Ptr
  27 import Foreign.C.Types
  28 import Foreign.Marshal.Alloc
  29
  30 import JVM.ClassFile
  31 import JVM.Converter
  32
  33 import Mate.BasicBlocks
  34 import {-# SOURCE #-} Mate.MethodPool
  35 import Mate.Types
  36 import Mate.Utilities
  37
  38 getClassInfo :: B.ByteString -> IO ClassInfo
  39 getClassInfo path = do
  40   class_map <- get_classmap >>= ptr2classmap
  41   case M.lookup path class_map of
  42     Nothing -> loadAndInitClass path
  43     Just ci -> return ci
  44
  45 getClassFile :: B.ByteString -> IO (Class Resolved)
  46 getClassFile path = do
  47   ci <- getClassInfo path
  48   return $ ciFile ci
  49
  50 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  51 getStaticFieldOffset path field = do
  52   ci <- getClassInfo path
  53   return $ fromIntegral $ (ciStaticMap ci) M.! field
  54
  55 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
  56 getFieldOffset path field = do
  57   ci <- getClassInfo path
  58   return $ (ciFieldMap ci) M.! field
  59
  60 -- method + signature plz!
  61 getMethodOffset :: B.ByteString -> B.ByteString -> IO (Word32)
  62 getMethodOffset path method = do
  63   ci <- getClassInfo path
  64   return $ fromIntegral $ (ciMethodMap ci) M.! method
  65
  66 getMethodTable :: B.ByteString -> IO (Word32)
  67 getMethodTable path = do
  68   ci <- getClassInfo path
  69   return $ ciMethodBase ci
  70
  71 getObjectSize :: B.ByteString -> IO (Word32)
  72 getObjectSize path = do
  73   ci <- getClassInfo path
  74   -- TODO(bernhard): correct sizes for different types...
  75   let fsize = fromIntegral $ M.size $ ciFieldMap ci
  76   -- one slot for "method-table-ptr"
  77   return $ (1 + fsize) * 4
  78
  79 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  80 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  81 getStaticFieldAddr from ptr_trapmap = do
  82   trapmap <- ptr2trapmap ptr_trapmap
  83   let w32_from = fromIntegral from
  84   let sfi = trapmap M.! w32_from
  85   case sfi of
  86     (SFI (StaticFieldInfo cls field)) -> do
  87       getStaticFieldOffset cls field
  88     _ -> error $ "getFieldAddr: no trapInfo. abort"
  89
  90 loadClass :: B.ByteString -> IO ClassInfo
  91 loadClass path = do
  92 #ifdef DEBUG
  93   printf "loadClass: \"%s\"\n" $ toString path
  94 #endif
  95   let rpath = toString $ path `B.append` ".class"
  96   cfile <- parseClassFile rpath
  97   superclass <- case (path /= "java/lang/Object") of
  98       True -> do
  99         sc <- loadClass $ superClass cfile
 100         return $ Just $ sc
 101       False -> return $ Nothing
 102
 103   (staticmap, fieldmap) <- calculateFields cfile superclass
 104   (methodmap, mbase) <- calculateMethodMap cfile superclass
 105 #ifdef DEBUG
 106   printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
 107   printf "fieldmap:  %s @ %s\n" (show fieldmap) (toString path)
 108   printf "methodmap: %s @ %s\n" (show methodmap) (toString path)
 109   printf "mbase: 0x%08x\n" mbase
 110 #endif
 111
 112   virtual_map <- get_virtualmap >>= ptr2virtualmap
 113   let virtual_map' = M.insert mbase path virtual_map
 114   virtualmap2ptr virtual_map' >>= set_virtualmap
 115
 116   class_map <- get_classmap >>= ptr2classmap
 117   let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
 118   let class_map' = M.insert path new_ci class_map
 119   classmap2ptr class_map' >>= set_classmap
 120   return new_ci
 121
 122
 123 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
 124 calculateFields cf superclass = do
 125     -- TODO(bernhard): correct sizes. int only atm
 126
 127     let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 128
 129     staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
 130     let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
 131     let sm = zipbase i_sb sfields
 132     let sc_sm = getsupermap superclass ciStaticMap
 133     -- new fields "overwrite" old ones, if they have the same name
 134     let staticmap = (M.fromList sm) `M.union` sc_sm
 135
 136     let sc_im = getsupermap superclass ciFieldMap
 137     -- "+ 4" for the method table pointer
 138     let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
 139     let im = zipbase max_off ifields
 140     -- new fields "overwrite" old ones, if they have the same name
 141     let fieldmap = (M.fromList im) `M.union` sc_im
 142
 143     return (staticmap, fieldmap)
 144   where
 145   zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
 146
 147 -- helper
 148 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 149 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 150
 151
 152 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
 153 calculateMethodMap cf superclass = do
 154     let methods = filter
 155                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
 156                          ((/=) "<init>" . methodName) x)
 157                   (classMethods cf)
 158     let sc_mm = getsupermap superclass ciMethodMap
 159     let max_off = fromIntegral $ (M.size sc_mm) * 4
 160     let mm = zipbase max_off methods
 161     let methodmap = (M.fromList mm) `M.union` sc_mm
 162
 163     methodbase <- mallocBytes ((fromIntegral $ M.size methodmap) * 4)
 164     return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
 165   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 166           where entry y = (methodName y) `B.append` (encode $ methodSignature y)
 167
 168
 169 loadAndInitClass :: B.ByteString -> IO ClassInfo
 170 loadAndInitClass path = do
 171   class_map <- get_classmap >>= ptr2classmap
 172   ci <- case M.lookup path class_map of
 173     Nothing -> loadClass path
 174     Just x -> return x
 175
 176   -- first try to execute class initializer of superclass
 177   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
 178
 179   -- execute class initializer
 180   case lookupMethod "<clinit>" (ciFile ci) of
 181     Just m -> do
 182       hmap <- parseMethod (ciFile ci) "<clinit>"
 183       case hmap of
 184         Just hmap' -> do
 185           let mi = (MethodInfo "<clinit>" path (methodSignature m))
 186           entry <- compileBB hmap' mi
 187           addMethodRef entry mi [path]
 188 #ifdef DEBUG
 189           printf "executing static initializer from %s now\n" (toString path)
 190 #endif
 191           executeFuncPtr entry
 192 #ifdef DEBUG
 193           printf "static initializer from %s done\n" (toString path)
 194 #endif
 195         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
 196     Nothing -> return ()
 197
 198   class_map' <- get_classmap >>= ptr2classmap
 199   let new_ci = ci { ciInitDone = True }
 200   let class_map'' = M.insert path new_ci class_map'
 201   classmap2ptr class_map'' >>= set_classmap
 202   return new_ci