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
  72   (staticmap, fieldmap) <- calculateFields cfile superclass
  73   printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
  74   printf "fieldmap:  %s @ %s\n" (show fieldmap) (toString path)
  75
  76   class_map <- get_classmap >>= ptr2classmap
  77   let new_ci = ClassInfo path cfile staticmap fieldmap False
  78   let class_map' = M.insert path new_ci class_map
  79   classmap2ptr class_map' >>= set_classmap
  80   return new_ci
  81
  82
  83 calculateFields :: Class Resolved -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
  84 calculateFields cf superclass = do
  85     -- TODO(bernhard): correct sizes. int only atm
  86
  87     let (sfields, ifields) = span (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
  88
  89     staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
  90     let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
  91     let sm = zipbase i_sb sfields
  92     let sc_sm = getsupermap clStaticMap
  93     -- new fields "overwrite" old ones, if they have the same name
  94     let staticmap = (M.fromList sm) `M.union` sc_sm
  95
  96     let im = zipbase 0 ifields
  97     let sc_im = getsupermap clFieldMap
  98     -- new fields "overwrite" old ones, if they have the same name
  99     let fieldmap = (M.fromList im) `M.union` sc_im
 100
 101     return (staticmap, fieldmap)
 102   where
 103   zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
 104   getsupermap getter = case superclass of Just x -> getter x; Nothing -> M.empty
 105
 106
 107 loadAndInitClass :: B.ByteString -> IO ClassInfo
 108 loadAndInitClass path = do
 109   class_map <- get_classmap >>= ptr2classmap
 110   ci <- case M.lookup path class_map of
 111     Nothing -> loadClass path
 112     Just x -> return x
 113
 114   -- first try to execute class initializer of superclass
 115   when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
 116
 117   -- execute class initializer
 118   case lookupMethod "<clinit>" (clFile ci) of
 119     Just m -> do
 120       hmap <- parseMethod (clFile ci) "<clinit>"
 121       printMapBB hmap
 122       case hmap of
 123         Just hmap' -> do
 124           let mi = (MethodInfo "<clinit>" path (methodSignature m))
 125           entry <- compileBB hmap' mi
 126           addMethodRef entry mi [path]
 127           printf "executing static initializer from %s now\n" (toString path)
 128           executeFuncPtr entry
 129           printf "static initializer from %s done\n" (toString path)
 130         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
 131     Nothing -> return ()
 132
 133   class_map' <- get_classmap >>= ptr2classmap
 134   let new_ci = ci { clInitDone = True }
 135   let class_map'' = M.insert path new_ci class_map'
 136   classmap2ptr class_map'' >>= set_classmap
 137   return new_ci