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 getFieldBase :: B.ByteString -> IO (CUInt)
  34 getFieldBase path = do
  35   (ClassInfo _ _ fs _) <- getClassInfo path
  36   return $ fromIntegral $ ptrToIntPtr fs
  37
  38 getFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  39 getFieldOffset path field = do
  40   (ClassInfo _ _ _ fieldmap) <- getClassInfo path
  41   return $ fromIntegral $ fieldmap M.! field
  42
  43 foreign export ccall getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  44 getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  45 getFieldAddr from ptr_trapmap = do
  46   trapmap <- ptr2tmap ptr_trapmap
  47   let w32_from = fromIntegral from
  48   let sfi = trapmap M.! w32_from
  49   case sfi of
  50     (SFI (StaticFieldInfo cls field)) -> do
  51       off <- getFieldOffset cls field
  52       base <- getFieldBase cls
  53       return $ base + off
  54     _ -> error $ "getFieldAddr: no trapInfo. abort"
  55
  56 loadClass :: B.ByteString -> IO ClassInfo
  57 loadClass path = do
  58   ptr_classmap <- get_classmap
  59   class_map <- ptr2classmap ptr_classmap
  60   let rpath = toString $ path `B.append` ".class"
  61   cfile <- parseClassFile rpath
  62   printf "class fieldlength: %d\n" $ classFieldsCount cfile
  63   -- TODO(bernhard): correct sizes. int only atm
  64   let filteredfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
  65   let fm = zipWith (\x y -> (fieldName y, x)) [0,4..] filteredfields
  66   let fieldmap = M.fromList fm
  67   fieldbase <- mallocBytes ((fromIntegral $ M.size fieldmap) * 4)
  68   putStrLn $ "fieldmap: " ++ (show fieldmap)
  69   let new_ci = ClassInfo path cfile fieldbase fieldmap
  70   let class_map' = M.insert path new_ci class_map
  71   classmap2ptr class_map' >>= set_classmap
  72   return new_ci