Mate/ClassPool.hs

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