Mate/ClassPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.ClassPool where
   4
   5 import qualified Data.Map as M
   6 import qualified Data.Set as S
   7 import qualified Data.ByteString.Lazy as B
   8
   9 import Text.Printf
  10
  11 import Foreign.Ptr
  12 import Foreign.C.Types
  13 import Foreign.Marshal.Alloc
  14
  15 import JVM.ClassFile
  16 import JVM.Converter
  17
  18 import Mate.Types
  19
  20 getClassInfo :: B.ByteString -> IO ClassInfo
  21 getClassInfo path = do
  22   ptr_classmap <- get_classmap
  23   class_map <- ptr2classmap ptr_classmap
  24   case M.lookup path class_map of
  25     Nothing -> loadClass path
  26     Just ci -> return ci
  27
  28 getClassFile :: B.ByteString -> IO (Class Resolved)
  29 getClassFile path = do
  30   (ClassInfo _ cfile _ _) <- getClassInfo path
  31   return cfile
  32
  33 -- TODO(bernhard): I think we don't need that anymore. also remove fieldbase
  34 --                 entry in ClassInfo
  35 getFieldBase :: B.ByteString -> IO (CUInt)
  36 getFieldBase path = do
  37   (ClassInfo _ _ fs _) <- getClassInfo path
  38   return $ fromIntegral $ ptrToIntPtr fs
  39
  40 getFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  41 getFieldOffset path field = do
  42   (ClassInfo _ _ _ fieldmap) <- getClassInfo path
  43   return $ fromIntegral $ fieldmap M.! field
  44
  45 foreign export ccall getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  46 getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  47 getFieldAddr from ptr_trapmap = do
  48   trapmap <- ptr2tmap ptr_trapmap
  49   let w32_from = fromIntegral from
  50   let sfi = trapmap M.! w32_from
  51   case sfi of
  52     (SFI (StaticFieldInfo cls field)) -> do
  53       getFieldOffset cls field
  54     _ -> error $ "getFieldAddr: no trapInfo. abort"
  55
  56 loadClass :: B.ByteString -> IO ClassInfo
  57 loadClass path = do
  58   printf "loadClass: \"%s\"\n" $ toString path
  59   let rpath = toString $ path `B.append` ".class"
  60   cfile <- parseClassFile rpath
  61   superclass <- case (path /= "java/lang/Object") of
  62       True -> do
  63         sc <- loadClass $ superClass cfile
  64         return $ Just $ sc
  65       False -> return $ Nothing
  66   class_map <- get_classmap >>= ptr2classmap
  67   -- TODO(bernhard): correct sizes. int only atm
  68   let filteredfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
  69   fieldbase <- mallocBytes ((fromIntegral $ length filteredfields) * 4)
  70   let i_fb = fromIntegral $ ptrToIntPtr $ fieldbase
  71   let fm = zipWith (\x y -> (fieldName y, x + i_fb)) [0,4..] filteredfields
  72   let sc_fm = case superclass of Just x -> clFieldMap x; Nothing -> M.empty
  73   -- new fields "overwrite" old ones, if they have the same name
  74   let fieldmap = (M.fromList fm) `M.union` sc_fm
  75   printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
  76   let new_ci = ClassInfo path cfile fieldbase fieldmap
  77   let class_map' = M.insert path new_ci class_map
  78   classmap2ptr class_map' >>= set_classmap
  79   return new_ci