lazy classloading: yet another bug

[mate.git] / Mate / ClassPool.hs

diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs
index 88749995a59e7e5b95e7f7f40f73a5bb923d7a55..849f1a1f1d06be03e22216ffb63a1d79efa02b8d 100644 (file)
--- a/Mate/ClassPool.hs
+++ b/Mate/ClassPool.hs
@@ -1,6 +1,4 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
-#include "debug.h"
 module Mate.ClassPool (
   getClassInfo,
   classLoaded,
@@ -16,7 +14,6 @@ module Mate.ClassPool (
   ) where
 
 import Data.Int
-import Data.Word
 import Data.Binary
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -25,12 +22,7 @@ import qualified Data.ByteString.Lazy as B
 import Data.String.Utils
 import Control.Monad
 
-#ifdef DEBUG
-import Text.Printf
-#endif
-#ifdef DBG_CLASS
-import JVM.Dump
-#endif
+-- import JVM.Dump
 
 import Foreign.Ptr
 import Foreign.C.Types
@@ -80,18 +72,18 @@ getFieldOffset path field = do
   return $ ciFieldMap ci M.! field
 
 -- method + signature plz!
-getMethodOffset :: B.ByteString -> B.ByteString -> IO Word32
+getMethodOffset :: B.ByteString -> B.ByteString -> IO NativeWord
 getMethodOffset path method = do
   ci <- getClassInfo path
   -- (+ ptrSize) one slot for "interface-table-ptr"
   return $ (+ ptrSize) $ fromIntegral $ ciMethodMap ci M.! method
 
-getMethodTable :: B.ByteString -> IO Word32
+getMethodTable :: B.ByteString -> IO NativeWord
 getMethodTable path = do
   ci <- getClassInfo path
   return $ ciMethodBase ci
 
-getObjectSize :: B.ByteString -> IO Word32
+getObjectSize :: B.ByteString -> IO NativeWord
 getObjectSize path = do
   ci <- getClassInfo path
   -- TODO(bernhard): correct sizes for different types...
@@ -110,7 +102,7 @@ getStaticFieldAddr from = do
     _ -> error "getFieldAddr: no TrapCause found. abort"
 
 -- interface + method + signature plz!
-getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO Word32
+getInterfaceMethodOffset :: B.ByteString -> B.ByteString -> B.ByteString -> IO NativeWord
 getInterfaceMethodOffset ifname meth sig = do
   loadInterface ifname
   ifmmap <- getInterfaceMethodMap
@@ -127,9 +119,8 @@ readClass path = do
     Just cm -> return cm
     Nothing -> do
       cfile <- readClassFile $ toString path
-#ifdef DBG_CLASS
-      dumpClass cfile
-#endif
+      -- TODO(bernhard): hDumpClass
+      -- dumpClass cfile
       -- load all interfaces, which are implemented by this class
       sequence_ [ loadInterface i | i <- interfaces cfile ]
       superclass <- if path /= "java/lang/Object"
@@ -147,15 +138,26 @@ readClass path = do
       --                 entries have the same offset), so we could
       --                 save some memory here.
       iftable <- mallocClassData ((4*) $ M.size immap)
-      let w32_iftable = fromIntegral $ ptrToIntPtr iftable :: Word32
+      let wn_iftable = fromIntegral $ ptrToIntPtr iftable :: NativeWord
       -- store interface-table at offset 0 in method-table
-      pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 w32_iftable
-      printfCp "staticmap: %s @ %s\n" (show staticmap) (toString path)
-      printfCp "fieldmap:  %s @ %s\n" (show fieldmap) (toString path)
-      printfCp "methodmap: %s @ %s\n" (show methodmap) (toString path)
-      printfCp "mbase: 0x%08x\n" mbase
-      printfCp "interfacemethod: %s @ %s\n" (show immap) (toString path)
-      printfCp "iftable: 0x%08x\n" w32_iftable
+      pokeElemOff (intPtrToPtr $ fromIntegral mbase) 0 wn_iftable
+      let hexDumpMap :: Integral v => String -> M.Map B.ByteString v -> IO ()
+          hexDumpMap header mmap = do
+            let printValue :: B.ByteString -> IO ()
+                printValue key = printfCp $ printf "\t%-70s: 0x%08x\n" (toString key) val
+                  where val = fromIntegral (mmap M.! key) :: NativeWord
+            printfCp $ printf "%s\n" header
+            mapM_ printValue (M.keys mmap)
+      if mateDEBUG
+        then do
+          let strpath = toString path
+          hexDumpMap ("staticmap @ " ++ strpath) staticmap
+          hexDumpMap ("fieldmap @ " ++ strpath) fieldmap
+          hexDumpMap ("methodmap @ " ++ strpath) methodmap
+          hexDumpMap ("interfacemap @ " ++ strpath) immap
+          printfCp $ printf "mbase:   0x%08x\n" mbase
+          printfCp $ printf "iftable: 0x%08x\n" wn_iftable
+        else return ()
       virtual_map <- getVirtualMap
       setVirtualMap $ M.insert mbase path virtual_map
 
@@ -172,7 +174,7 @@ loadInterface path = do
   case M.lookup path imap of
     Just _ -> return ()
     Nothing -> do
-      printfCp "interface: loading \"%s\"\n" $ toString path
+      printfCp $ printf "interface: loading \"%s\"\n" $ toString path
       cfile <- readClassFile $ toString path
       -- load "superinterfaces" first
       sequence_ [ loadInterface i | i <- interfaces cfile ]
@@ -230,7 +232,7 @@ getsupermap :: Maybe ClassInfo -> (ClassInfo -> FieldMap) -> FieldMap
 getsupermap superclass getter = case superclass of Just x -> getter x; Nothing -> M.empty
 
 
-calculateMethodMap :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, Word32)
+calculateMethodMap :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, NativeWord)
 calculateMethodMap cf superclass = do
     let methods = filter
                   (\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
@@ -265,9 +267,9 @@ loadAndInitClass path = do
       let mi = MethodInfo "<clinit>" path (methodSignature m)
       entry <- compileBB rawmethod mi
       addMethodRef entry mi [path]
-      printfCp "executing static initializer from %s now\n" (toString path)
+      printfCp $ printf "executing static initializer from %s now\n" (toString path)
       executeFuncPtr entry
-      printfCp "static initializer from %s done\n" (toString path)
+      printfCp $ printf "static initializer from %s done\n" (toString path)
     Nothing -> return ()
 
   class_map' <- getClassMap
@@ -284,13 +286,13 @@ readClassFile path' = readIORef classPaths >>= rcf
     rcf [] = error $ "readClassFile: Class \"" ++ show path ++ "\" not found."
     rcf (Directory pre:xs) = do
       let cf = pre ++ path ++ ".class"
-      printfCp "rcf: searching @ %s for %s\n" (show pre) (show path)
+      printfCp $ printf "rcf: searching @ %s for %s\n" (show pre) (show path)
       b <- doesFileExist cf
       if b
         then parseClassFile cf
         else rcf xs
     rcf (JAR p:xs) = do
-      printfCp "rcf: searching %s in JAR\n" (show path)
+      printfCp $ printf "rcf: searching %s in JAR\n" (show path)
       entry <- getEntry p path
       case entry of
         Just (LoadedJAR _ cls) -> return cls