Mate/ClassPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.ClassPool (
   4   getClassInfo,
   5   getClassFile,
   6   getMethodTable,
   7   getMethodSize,
   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 getMethodSize :: B.ByteString -> IO (Word32)
  69 getMethodSize path = do
  70   ci <- getClassInfo path
  71   -- TODO(bernhard): correct sizes for different types...
  72   let msize = fromIntegral $ M.size $ ciMethodMap ci
  73   return $ (1 + msize) * 4
  74
  75 foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  76 getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
  77 getStaticFieldAddr from ptr_trapmap = do
  78   trapmap <- ptr2trapmap ptr_trapmap
  79   let w32_from = fromIntegral from
  80   let sfi = trapmap M.! w32_from
  81   case sfi of
  82     (SFI (StaticFieldInfo cls field)) -> do
  83       getStaticFieldOffset cls field
  84     _ -> error $ "getFieldAddr: no trapInfo. abort"
  85
  86 loadClass :: B.ByteString -> IO ClassInfo
  87 loadClass path = do
  88   printf "loadClass: \"%s\"\n" $ toString path
  89   let rpath = toString $ path `B.append` ".class"
  90   cfile <- parseClassFile rpath
  91   superclass <- case (path /= "java/lang/Object") of
  92       True -> do
  93         sc <- loadClass $ superClass cfile
  94         return $ Just $ sc
  95       False -> return $ Nothing
  96
  97   (staticmap, fieldmap) <- calculateFields cfile superclass
  98   printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
  99   printf "fieldmap:  %s @ %s\n" (show fieldmap) (toString path)
 100   (methodmap, mbase) <- calculateMethodMap cfile superclass
 101   printf "methodmap: %s @ %s\n" (show methodmap) (toString path)
 102   printf "mbase: 0x%08x\n" mbase
 103
 104   virtual_map <- get_virtualmap >>= ptr2virtualmap
 105   let virtual_map' = M.insert mbase path virtual_map
 106   virtualmap2ptr virtual_map' >>= set_virtualmap
 107
 108   class_map <- get_classmap >>= ptr2classmap
 109   let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
 110   let class_map' = M.insert path new_ci class_map
 111   classmap2ptr class_map' >>= set_classmap
 112   return new_ci
 113
 114
 115 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
 116 calculateFields cf superclass = do
 117     -- TODO(bernhard): correct sizes. int only atm
 118
 119     let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 120
 121     staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
 122     let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
 123     let sm = zipbase i_sb sfields
 124     let sc_sm = getsupermap superclass ciStaticMap
 125     -- new fields "overwrite" old ones, if they have the same name
 126     let staticmap = (M.fromList sm) `M.union` sc_sm
 127
 128     let sc_im = getsupermap superclass ciFieldMap
 129     -- "+ 4" for the method table pointer
 130     let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
 131     let im = zipbase max_off ifields
 132     -- new fields "overwrite" old ones, if they have the same name
 133     let fieldmap = (M.fromList im) `M.union` sc_im
 134
 135     return (staticmap, fieldmap)
 136   where
 137   zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
 138
 139 -- helper
 140 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 141 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 142
 143
 144 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
 145 calculateMethodMap cf superclass = do
 146     let methods = filter
 147                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
 148                          ((/=) "<init>" . methodName) x)
 149                   (classMethods cf)
 150     let sc_mm = getsupermap superclass ciMethodMap
 151     let max_off = fromIntegral $ (M.size sc_mm) * 4
 152     let mm = zipbase max_off methods
 153     let methodmap = (M.fromList mm) `M.union` sc_mm
 154
 155     methodbase <- mallocBytes ((fromIntegral $ M.size methodmap) * 4)
 156     return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
 157   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 158           where entry y = (methodName y) `B.append` (encode $ methodSignature y)
 159
 160
 161 loadAndInitClass :: B.ByteString -> IO ClassInfo
 162 loadAndInitClass path = do
 163   class_map <- get_classmap >>= ptr2classmap
 164   ci <- case M.lookup path class_map of
 165     Nothing -> loadClass path
 166     Just x -> return x
 167
 168   -- first try to execute class initializer of superclass
 169   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
 170
 171   -- execute class initializer
 172   case lookupMethod "<clinit>" (ciFile ci) of
 173     Just m -> do
 174       hmap <- parseMethod (ciFile ci) "<clinit>"
 175       printMapBB hmap
 176       case hmap of
 177         Just hmap' -> do
 178           let mi = (MethodInfo "<clinit>" path (methodSignature m))
 179           entry <- compileBB hmap' mi
 180           addMethodRef entry mi [path]
 181           printf "executing static initializer from %s now\n" (toString path)
 182           executeFuncPtr entry
 183           printf "static initializer from %s done\n" (toString path)
 184         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
 185     Nothing -> return ()
 186
 187   class_map' <- get_classmap >>= ptr2classmap
 188   let new_ci = ci { ciInitDone = True }
 189   let class_map'' = M.insert path new_ci class_map'
 190   classmap2ptr class_map'' >>= set_classmap
 191   return new_ci