From 108c401766a0c0ccd805187900d3b1771597896c Mon Sep 17 00:00:00 2001
From: Bernhard Urban <lewurm@gmail.com>
Date: Wed, 25 Apr 2012 00:38:11 +0200
Subject: [PATCH] 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)
---
 Mate/ClassPool.hs | 73 +++++++++++++++++++++++++++++------------------
 Mate/Types.hs     |  5 ++--
 2 files changed, 49 insertions(+), 29 deletions(-)

diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs
index 0a4d357..07cdb81 100644
--- 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 130c293..ec5b977 100644
--- 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,
-- 
2.25.1