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 $ clFile ci
  46
  47 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  48 getStaticFieldOffset path field = do
  49   ci <- getClassInfo path
  50   return $ fromIntegral $ (clStaticMap ci) M.! field
  51
  52 getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
  53 getFieldOffset path field = do
  54   ci <- getClassInfo path
  55   return $ (clFieldMap 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 $ (clMethodMap ci) M.! method
  62
  63 getMethodTable :: B.ByteString -> IO (Word32)
  64 getMethodTable path = do
  65   ci <- getClassInfo path
  66   return $ clMethodBase 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 $ clMethodMap 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 <- ptr2tmap 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   class_map <- get_classmap >>= ptr2classmap
 105   let new_ci = ClassInfo path cfile staticmap fieldmap methodmap mbase False
 106   let class_map' = M.insert path new_ci class_map
 107   classmap2ptr class_map' >>= set_classmap
 108   return new_ci
 109
 110
 111 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
 112 calculateFields cf superclass = do
 113     -- TODO(bernhard): correct sizes. int only atm
 114
 115     let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 116
 117     staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
 118     let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
 119     let sm = zipbase i_sb sfields
 120     let sc_sm = getsupermap superclass clStaticMap
 121     -- new fields "overwrite" old ones, if they have the same name
 122     let staticmap = (M.fromList sm) `M.union` sc_sm
 123
 124     let sc_im = getsupermap superclass clFieldMap
 125     -- "+ 4" for the method table pointer
 126     let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
 127     let im = zipbase max_off ifields
 128     -- new fields "overwrite" old ones, if they have the same name
 129     let fieldmap = (M.fromList im) `M.union` sc_im
 130
 131     return (staticmap, fieldmap)
 132   where
 133   zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
 134
 135 -- helper
 136 getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 137 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 138
 139
 140 calculateMethodMap :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, Word32)
 141 calculateMethodMap cf superclass = do
 142     let methods = filter
 143                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
 144                          ((/=) "<init>" . methodName) x)
 145                   (classMethods cf)
 146     let sc_mm = getsupermap superclass clMethodMap
 147     let max_off = fromIntegral $ (M.size sc_mm) * 4
 148     let mm = zipbase max_off methods
 149     let methodmap = (M.fromList mm) `M.union` sc_mm
 150
 151     methodbase <- mallocBytes ((fromIntegral $ M.size methodmap) * 4)
 152     return (methodmap, fromIntegral $ ptrToIntPtr $ methodbase)
 153   where zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
 154           where entry y = (methodName y) `B.append` (encode $ methodSignature y)
 155
 156
 157 loadAndInitClass :: B.ByteString -> IO ClassInfo
 158 loadAndInitClass path = do
 159   class_map <- get_classmap >>= ptr2classmap
 160   ci <- case M.lookup path class_map of
 161     Nothing -> loadClass path
 162     Just x -> return x
 163
 164   -- first try to execute class initializer of superclass
 165   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
 166
 167   -- execute class initializer
 168   case lookupMethod "<clinit>" (clFile ci) of
 169     Just m -> do
 170       hmap <- parseMethod (clFile ci) "<clinit>"
 171       printMapBB hmap
 172       case hmap of
 173         Just hmap' -> do
 174           let mi = (MethodInfo "<clinit>" path (methodSignature m))
 175           entry <- compileBB hmap' mi
 176           addMethodRef entry mi [path]
 177           printf "executing static initializer from %s now\n" (toString path)
 178           executeFuncPtr entry
 179           printf "static initializer from %s done\n" (toString path)
 180         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
 181     Nothing -> return ()
 182
 183   class_map' <- get_classmap >>= ptr2classmap
 184   let new_ci = ci { clInitDone = True }
 185   let class_map'' = M.insert path new_ci class_map'
 186   classmap2ptr class_map'' >>= set_classmap
 187   return new_ci