Mate/ClassPool.hs

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