classpool: refactor, refactor, ...

we also need to load classes *without* executing the static
initializer (to access field-offset data at compile-time
for non-static fields)

diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs
index 0a4d35781b020ef7e565bd8b4c540aa151a2a9e2..07cdb81aa1fdd7322d1a460175554fc0bdf6be42 100644 (file)
--- a/Mate/ClassPool.hs
+++ b/Mate/ClassPool.hs
@@ -1,10 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
-module Mate.ClassPool where
+module Mate.ClassPool (
+  getClassInfo,
+  getClassFile,
+  getFieldAddr
+  ) where
 
 import qualified Data.Map as M
 import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as B
+import Control.Monad
 
 import Text.Printf
 
@@ -22,28 +27,25 @@ import Mate.Utilities
 
 getClassInfo :: B.ByteString -> IO ClassInfo
 getClassInfo path = do
-  ptr_classmap <- get_classmap
-  class_map <- ptr2classmap ptr_classmap
+  class_map <- get_classmap >>= ptr2classmap
   case M.lookup path class_map of
-    Nothing -> loadClass path
+    Nothing -> loadAndInitClass path
     Just ci -> return ci
 
 getClassFile :: B.ByteString -> IO (Class Resolved)
 getClassFile path = do
-  (ClassInfo _ cfile _ _) <- getClassInfo path
-  return cfile
+  ci <- getClassInfo path
+  return $ clFile ci
 
--- TODO(bernhard): I think we don't need that anymore. also remove fieldbase
---                 entry in ClassInfo
-getFieldBase :: B.ByteString -> IO (CUInt)
-getFieldBase path = do
-  (ClassInfo _ _ fs _) <- getClassInfo path
-  return $ fromIntegral $ ptrToIntPtr fs
+getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
+getStaticFieldOffset path field = do
+  ci <- getClassInfo path
+  return $ fromIntegral $ (clStaticMap ci) M.! field
 
 getFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
 getFieldOffset path field = do
-  (ClassInfo _ _ _ fieldmap) <- getClassInfo path
-  return $ fromIntegral $ fieldmap M.! field
+  ci <- getClassInfo path
+  return $ fromIntegral $ (clFieldMap ci) M.! field
 
 foreign export ccall getFieldAddr :: CUInt -> Ptr () -> IO CUInt
 getFieldAddr :: CUInt -> Ptr () -> IO CUInt
@@ -53,7 +55,7 @@ getFieldAddr from ptr_trapmap = do
   let sfi = trapmap M.! w32_from
   case sfi of
     (SFI (StaticFieldInfo cls field)) -> do
-      getFieldOffset cls field
+      getStaticFieldOffset cls field
     _ -> error $ "getFieldAddr: no trapInfo. abort"
 
 loadClass :: B.ByteString -> IO ClassInfo
@@ -68,21 +70,33 @@ loadClass path = do
       False -> return $ Nothing
   class_map <- get_classmap >>= ptr2classmap
   -- TODO(bernhard): correct sizes. int only atm
-  let filteredfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
-  fieldbase <- mallocBytes ((fromIntegral $ length filteredfields) * 4)
-  let i_fb = fromIntegral $ ptrToIntPtr $ fieldbase
-  let fm = zipWith (\x y -> (fieldName y, x + i_fb)) [0,4..] filteredfields
-  let sc_fm = case superclass of Just x -> clFieldMap x; Nothing -> M.empty
+  let staticfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
+  staticbase <- mallocBytes ((fromIntegral $ length staticfields) * 4)
+  let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
+  let sm = zipWith (\x y -> (fieldName y, x + i_sb)) [0,4..] staticfields
+  let sc_sm = case superclass of Just x -> clStaticMap x; Nothing -> M.empty
   -- new fields "overwrite" old ones, if they have the same name
-  let fieldmap = (M.fromList fm) `M.union` sc_fm
-  printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
-  let new_ci = ClassInfo path cfile fieldbase fieldmap
+  let staticmap = (M.fromList sm) `M.union` sc_sm
+  printf "staticmap: %s @ %s\n" (show staticmap) (toString path)
+  let new_ci = ClassInfo path cfile staticmap M.empty False
   let class_map' = M.insert path new_ci class_map
   classmap2ptr class_map' >>= set_classmap
+  return new_ci
+
+loadAndInitClass :: B.ByteString -> IO ClassInfo
+loadAndInitClass path = do
+  class_map <- get_classmap >>= ptr2classmap
+  ci <- case M.lookup path class_map of
+    Nothing -> loadClass path
+    Just x -> return x
+
+  -- first try to execute class initializer of superclass
+  when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
+
   -- execute class initializer
-  case lookupMethod "<clinit>" cfile of
+  case lookupMethod "<clinit>" (clFile ci) of
     Just m -> do
-      hmap <- parseMethod cfile "<clinit>"
+      hmap <- parseMethod (clFile ci) "<clinit>"
       printMapBB hmap
       case hmap of
         Just hmap' -> do
@@ -92,6 +106,11 @@ loadClass path = do
           printf "executing static initializer from %s now\n" (toString path)
           executeFuncPtr entry
           printf "static initializer from %s done\n" (toString path)
-          return new_ci
         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
-    Nothing -> return new_ci
+    Nothing -> return ()
+
+  class_map' <- get_classmap >>= ptr2classmap
+  let new_ci = ci { clInitDone = True }
+  let class_map'' = M.insert path new_ci class_map'
+  classmap2ptr class_map'' >>= set_classmap
+  return new_ci

diff --git a/Mate/Types.hs b/Mate/Types.hs
index 130c2932d5b70548c4b3eca5a593965cd2cffe36..ec5b977b32def5b243d640f272106af54bce98cc 100644 (file)
--- a/Mate/Types.hs
+++ b/Mate/Types.hs
@@ -49,8 +49,9 @@ type FieldMap = M.Map B.ByteString Int32
 data ClassInfo = ClassInfo {
   clName :: B.ByteString,
   clFile :: Class Resolved,
-  clFieldBase :: Ptr Int32,
-  clFieldMap :: FieldMap }
+  clStaticMap  :: FieldMap,
+  clFieldMap :: FieldMap,
+  clInitDone :: Bool }
 
 data MethodInfo = MethodInfo {
   methName :: B.ByteString,