X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FClassPool.hs;h=b9b8b3cafb158366aff27752a250a8cae71b735a;hb=a60718741f1acee2830528f57e2d48f2df1f7acb;hp=cb38b28fbd22d89b4237c0735e9d395089e7e85e;hpb=7e3cda1c8cfe2f1e91816277969391c6d91bfb6a;p=mate.git

diff --git a/Mate/ClassPool.hs b/Mate/ClassPool.hs
index cb38b28..b9b8b3c 100644
--- a/Mate/ClassPool.hs
+++ b/Mate/ClassPool.hs
@@ -3,6 +3,7 @@
 #include "debug.h"
 module Mate.ClassPool (
   getClassInfo,
+  classLoaded,
   getClassFile,
   getMethodTable,
   getObjectSize,
@@ -15,10 +16,10 @@ 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
+import Data.List
 import qualified Data.ByteString.Lazy as B
 import Data.String.Utils
 import Control.Monad
@@ -46,8 +47,10 @@ import Java.JAR
 import Mate.BasicBlocks
 import {-# SOURCE #-} Mate.MethodPool
 import Mate.Types
+import Mate.Utilities
 import Mate.Debug
 import Mate.GarbageAlloc
+import Mate.NativeSizes
 
 getClassInfo :: B.ByteString -> IO ClassInfo
 getClassInfo path = do
@@ -56,12 +59,17 @@ getClassInfo path = do
     Nothing -> loadAndInitClass path
     Just ci -> return ci
 
+classLoaded :: B.ByteString -> IO Bool
+classLoaded path = do
+  class_map <- getClassMap
+  return $ M.member path class_map
+
 getClassFile :: B.ByteString -> IO (Class Direct)
 getClassFile path = do
   ci <- getClassInfo path
   return $ ciFile ci
 
-getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO CUInt
+getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO CPtrdiff
 getStaticFieldOffset path field = do
   ci <- getClassInfo path
   return $ fromIntegral $ ciStaticMap ci M.! field
@@ -72,37 +80,37 @@ 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
-  -- (4+) one slot for "interface-table-ptr"
-  return $ (+4) $ fromIntegral $ ciMethodMap ci M.! method
+  -- (+ 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...
   let fsize = fromIntegral $ M.size $ ciFieldMap ci
   -- one slot for "method-table-ptr"
-  return $ (1 + fsize) * 4
+  return $ (1 + fsize) * ptrSize
 
-getStaticFieldAddr :: CUInt -> IO CUInt
+getStaticFieldAddr :: CPtrdiff -> IO CPtrdiff
 getStaticFieldAddr from = do
   trapmap <- getTrapMap
   let w32_from = fromIntegral from
   let sfi = trapmap M.! w32_from
   setTrapMap $ M.delete w32_from trapmap
   case sfi of
-    (SFI (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field
-    _ -> error "getFieldAddr: no trapInfo. abort"
+    (StaticField (StaticFieldInfo cls field)) -> getStaticFieldOffset cls field
+    _ -> 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
@@ -139,15 +147,18 @@ 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 strpath = toString path
+#ifdef DBG_CLASS
+      hexDumpMap ("staticmap @ " ++ strpath) staticmap
+      hexDumpMap ("fieldmap @ " ++ strpath) fieldmap
+      hexDumpMap ("methodmap @ " ++ strpath) methodmap
+      hexDumpMap ("interfacemap @ " ++ strpath) immap
+#endif
+      printfCp "mbase:   0x%08x\n" mbase
+      printfCp "iftable: 0x%08x\n" wn_iftable
       virtual_map <- getVirtualMap
       setVirtualMap $ M.insert mbase path virtual_map
 
@@ -188,48 +199,41 @@ loadInterface path = do
       setInterfaceMethodMap $ M.fromList sm `M.union` M.fromList mm `M.union` immap
       setInterfaceMap $ M.insert path cfile imap'
   where
-  zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
-  entry = getname path
-  getname p y = p `B.append` methodName y `B.append` encode (methodSignature y)
+    zipbase base = zipWith (\x y -> (entry y, x + base)) [0,4..]
+    entry = getname path
+    getname p y = p `B.append` methodName y `B.append` encode (methodSignature y)
 
 
 calculateFields :: Class Direct -> Maybe ClassInfo -> IO (FieldMap, FieldMap)
 calculateFields cf superclass = do
     -- TODO(bernhard): correct sizes. int only atm
 
-    -- TODO(bernhard): nicer replacement for `myspan'
-    let (sfields, ifields) = myspan (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
-        myspan :: (a -> Bool) -> [a] -> ([a], [a])
-        myspan _ [] = ([],[])
-        myspan p (x:xs)
-          | p x = (x:ns, ni)
-          | otherwise = (ns, x:ni)
-          where (ns,ni) = myspan p xs
+    let (sfields, ifields) = partition (S.member ACC_STATIC . fieldAccessFlags) (classFields cf)
 
-    staticbase <- mallocClassData $ fromIntegral (length sfields) * 4
-    let i_sb = fromIntegral $ ptrToIntPtr staticbase
-    let sm = zipbase i_sb sfields
     let sc_sm = getsupermap superclass ciStaticMap
+    staticbase <- mallocClassData $ fromIntegral (length sfields) * 4
+    let sm = zipbase (fromIntegral $ ptrToIntPtr staticbase) sfields
     -- new fields "overwrite" old ones, if they have the same name
-    let staticmap = M.fromList sm `M.union` sc_sm
+    let staticmap = sm `M.union` sc_sm
 
     let sc_im = getsupermap superclass ciFieldMap
     -- "+ 4" for the method table pointer
     let max_off = (4+) $ fromIntegral $ M.size sc_im * 4
     let im = zipbase max_off ifields
     -- new fields "overwrite" old ones, if they have the same name
-    let fieldmap = M.fromList im `M.union` sc_im
+    let fieldmap = im `M.union` sc_im
 
     return (staticmap, fieldmap)
   where
-  zipbase base = zipWith (\x y -> (fieldName y, x + base)) [0,4..]
+    zipbase :: Int32 -> [Field Direct] -> FieldMap
+    zipbase base = foldr (\(x,y) -> M.insert (fieldName y) (x + base)) M.empty . zip [0,4..]
 
 -- helper
 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 &&
@@ -260,16 +264,13 @@ loadAndInitClass path = do
   -- execute class initializer
   case lookupMethod "<clinit>" (ciFile ci) of
     Just m -> do
-      hmap <- parseMethod (ciFile ci) "<clinit>" $ MethodSignature [] ReturnsVoid
-      case hmap of
-        Just hmap' -> do
-          let mi = MethodInfo "<clinit>" path (methodSignature m)
-          entry <- compileBB hmap' mi
-          addMethodRef entry mi [path]
-          printfCp "executing static initializer from %s now\n" (toString path)
-          executeFuncPtr entry
-          printfCp "static initializer from %s done\n" (toString path)
-        Nothing -> error "readClass: static initializer not found (WTF?). abort"
+      rawmethod <- parseMethod (ciFile ci) "<clinit>" $ MethodSignature [] ReturnsVoid
+      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)
+      executeFuncPtr entry
+      printfCp "static initializer from %s done\n" (toString path)
     Nothing -> return ()
 
   class_map' <- getClassMap
@@ -281,23 +282,23 @@ loadAndInitClass path = do
 readClassFile :: String -> IO (Class Direct)
 readClassFile path' = readIORef classPaths >>= rcf
   where
-  path = replace "." "/" path'
-  rcf :: [MClassPath] -> IO (Class Direct)
-  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)
-    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)
-    entry <- getEntry p path
-    case entry of
-      Just (LoadedJAR _ cls) -> return cls
-      Nothing -> rcf xs
-      _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1"
+    path = replace "." "/" path'
+    rcf :: [MClassPath] -> IO (Class Direct)
+    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)
+      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)
+      entry <- getEntry p path
+      case entry of
+        Just (LoadedJAR _ cls) -> return cls
+        Nothing -> rcf xs
+        _ -> error $ "readClassFile: Class \"" ++ show path ++ "\" in JAR not found. #1"
 
 data MClassPath =
   Directory String |