Mate/ClassPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.ClassPool (
   4   getClassInfo,
   5   getClassFile,
   6   getFieldAddr
   7   ) where
   8
   9 import qualified Data.Map as M
  10 import qualified Data.Set as S
  11 import qualified Data.ByteString.Lazy as B
  12 import Control.Monad
  13
  14 import Text.Printf
  15
  16 import Foreign.Ptr
  17 import Foreign.C.Types
  18 import Foreign.Marshal.Alloc
  19
  20 import JVM.ClassFile
  21 import JVM.Converter
  22
  23 import Mate.BasicBlocks
  24 import {-# SOURCE #-} Mate.MethodPool
  25 import Mate.Types
  26 import Mate.Utilities
  27
  28 getClassInfo :: B.ByteString -> IO ClassInfo
  29 getClassInfo path = do
  30   class_map <- get_classmap >>= ptr2classmap
  31   case M.lookup path class_map of
  32     Nothing -> loadAndInitClass path
  33     Just ci -> return ci
  34
  35 getClassFile :: B.ByteString -> IO (Class Resolved)
  36 getClassFile path = do
  37   ci <- getClassInfo path
  38   return $ clFile ci
  39
  40 getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  41 getStaticFieldOffset path field = do
  42   ci <- getClassInfo path
  43   return $ fromIntegral $ (clStaticMap ci) M.! field
  44
  45 getFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  46 getFieldOffset path field = do
  47   ci <- getClassInfo path
  48   return $ fromIntegral $ (clFieldMap ci) M.! field
  49
  50 foreign export ccall getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  51 getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  52 getFieldAddr from ptr_trapmap = do
  53   trapmap <- ptr2tmap ptr_trapmap
  54   let w32_from = fromIntegral from
  55   let sfi = trapmap M.! w32_from
  56   case sfi of
  57     (SFI (StaticFieldInfo cls field)) -> do
  58       getStaticFieldOffset cls field
  59     _ -> error $ "getFieldAddr: no trapInfo. abort"
  60
  61 loadClass :: B.ByteString -> IO ClassInfo
  62 loadClass path = do
  63   printf "loadClass: \"%s\"\n" $ toString path
  64   let rpath = toString $ path `B.append` ".class"
  65   cfile <- parseClassFile rpath
  66   superclass <- case (path /= "java/lang/Object") of
  67       True -> do
  68         sc <- loadClass $ superClass cfile
  69         return $ Just $ sc
  70       False -> return $ Nothing
  71   class_map <- get_classmap >>= ptr2classmap
  72   -- TODO(bernhard): correct sizes. int only atm
  73   let staticfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
  74   staticbase <- mallocBytes ((fromIntegral $ length staticfields) * 4)
  75   let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
  76   let sm = zipWith (\x y -> (fieldName y, x + i_sb)) [0,4..] staticfields
  77   let sc_sm = case superclass of Just x -> clStaticMap x; Nothing -> M.empty
  78   -- new fields "overwrite" old ones, if they have the same name
  79   let staticmap = (M.fromList sm) `M.union` sc_sm
  80   printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
  81   let new_ci = ClassInfo path cfile staticmap M.empty False
  82   let class_map' = M.insert path new_ci class_map
  83   classmap2ptr class_map' >>= set_classmap
  84   return new_ci
  85
  86 loadAndInitClass :: B.ByteString -> IO ClassInfo
  87 loadAndInitClass path = do
  88   class_map <- get_classmap >>= ptr2classmap
  89   ci <- case M.lookup path class_map of
  90     Nothing -> loadClass path
  91     Just x -> return x
  92
  93   -- first try to execute class initializer of superclass
  94   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
  95
  96   -- execute class initializer
  97   case lookupMethod "<clinit>" (clFile ci) of
  98     Just m -> do
  99       hmap <- parseMethod (clFile ci) "<clinit>"
 100       printMapBB hmap
 101       case hmap of
 102         Just hmap' -> do
 103           let mi = (MethodInfo "<clinit>" path (methodSignature m))
 104           entry <- compileBB hmap' mi
 105           addMethodRef entry mi [path]
 106           printf "executing static initializer from %s now\n" (toString path)
 107           executeFuncPtr entry
 108           printf "static initializer from %s done\n" (toString path)
 109         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
 110     Nothing -> return ()
 111
 112   class_map' <- get_classmap >>= ptr2classmap
 113   let new_ci = ci { clInitDone = True }
 114   let class_map'' = M.insert path new_ci class_map'
 115   classmap2ptr class_map'' >>= set_classmap
 116   return new_ci