Mate/ClassPool.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.ClassPool where
   4
   5 import qualified Data.Map as M
   6 import qualified Data.Set as S
   7 import qualified Data.ByteString.Lazy as B
   8
   9 import Text.Printf
  10
  11 import Foreign.Ptr
  12 import Foreign.C.Types
  13 import Foreign.Marshal.Alloc
  14
  15 import JVM.ClassFile
  16 import JVM.Converter
  17
  18 import Mate.BasicBlocks
  19 import {-# SOURCE #-} Mate.MethodPool
  20 import Mate.Types
  21 import Mate.Utilities
  22
  23 getClassInfo :: B.ByteString -> IO ClassInfo
  24 getClassInfo path = do
  25   ptr_classmap <- get_classmap
  26   class_map <- ptr2classmap ptr_classmap
  27   case M.lookup path class_map of
  28     Nothing -> loadClass path
  29     Just ci -> return ci
  30
  31 getClassFile :: B.ByteString -> IO (Class Resolved)
  32 getClassFile path = do
  33   (ClassInfo _ cfile _ _) <- getClassInfo path
  34   return cfile
  35
  36 -- TODO(bernhard): I think we don't need that anymore. also remove fieldbase
  37 --                 entry in ClassInfo
  38 getFieldBase :: B.ByteString -> IO (CUInt)
  39 getFieldBase path = do
  40   (ClassInfo _ _ fs _) <- getClassInfo path
  41   return $ fromIntegral $ ptrToIntPtr fs
  42
  43 getFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
  44 getFieldOffset path field = do
  45   (ClassInfo _ _ _ fieldmap) <- getClassInfo path
  46   return $ fromIntegral $ fieldmap M.! field
  47
  48 foreign export ccall getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  49 getFieldAddr :: CUInt -> Ptr () -> IO CUInt
  50 getFieldAddr from ptr_trapmap = do
  51   trapmap <- ptr2tmap ptr_trapmap
  52   let w32_from = fromIntegral from
  53   let sfi = trapmap M.! w32_from
  54   case sfi of
  55     (SFI (StaticFieldInfo cls field)) -> do
  56       getFieldOffset cls field
  57     _ -> error $ "getFieldAddr: no trapInfo. abort"
  58
  59 loadClass :: B.ByteString -> IO ClassInfo
  60 loadClass path = do
  61   printf "loadClass: \"%s\"\n" $ toString path
  62   let rpath = toString $ path `B.append` ".class"
  63   cfile <- parseClassFile rpath
  64   superclass <- case (path /= "java/lang/Object") of
  65       True -> do
  66         sc <- loadClass $ superClass cfile
  67         return $ Just $ sc
  68       False -> return $ Nothing
  69   class_map <- get_classmap >>= ptr2classmap
  70   -- TODO(bernhard): correct sizes. int only atm
  71   let filteredfields = filter (S.member ACC_STATIC . fieldAccessFlags) (classFields cfile)
  72   fieldbase <- mallocBytes ((fromIntegral $ length filteredfields) * 4)
  73   let i_fb = fromIntegral $ ptrToIntPtr $ fieldbase
  74   let fm = zipWith (\x y -> (fieldName y, x + i_fb)) [0,4..] filteredfields
  75   let sc_fm = case superclass of Just x -> clFieldMap x; Nothing -> M.empty
  76   -- new fields "overwrite" old ones, if they have the same name
  77   let fieldmap = (M.fromList fm) `M.union` sc_fm
  78   printf "fieldmap: %s @ %s\n" (show fieldmap) (toString path)
  79   let new_ci = ClassInfo path cfile fieldbase fieldmap
  80   let class_map' = M.insert path new_ci class_map
  81   classmap2ptr class_map' >>= set_classmap
  82   -- execute class initializer
  83   case lookupMethod "<clinit>" cfile of
  84     Just m -> do
  85       hmap <- parseMethod cfile "<clinit>"
  86       printMapBB hmap
  87       case hmap of
  88         Just hmap' -> do
  89           let mi = (MethodInfo "<clinit>" path (methodSignature m))
  90           entry <- compileBB hmap' mi
  91           addMethodRef entry mi [path]
  92           printf "executing static initializer from %s now\n" (toString path)
  93           executeFuncPtr entry
  94           printf "static initializer from %s done\n" (toString path)
  95           return new_ci
  96         Nothing -> error $ "loadClass: static initializer not found (WTF?). abort"
  97     Nothing -> return new_ci