getClassFile :: B.ByteString -> IO (Class Resolved)
getClassFile path = do
ci <- getClassInfo path
- return $ clFile ci
+ return $ ciFile ci
getStaticFieldOffset :: B.ByteString -> B.ByteString -> IO (CUInt)
getStaticFieldOffset path field = do
ci <- getClassInfo path
- return $ fromIntegral $ (clStaticMap ci) M.! field
+ return $ fromIntegral $ (ciStaticMap ci) M.! field
getFieldOffset :: B.ByteString -> B.ByteString -> IO (Int32)
getFieldOffset path field = do
ci <- getClassInfo path
- return $ (clFieldMap ci) M.! field
+ return $ (ciFieldMap ci) M.! field
-- method + signature plz!
getMethodOffset :: B.ByteString -> B.ByteString -> IO (Word32)
getMethodOffset path method = do
ci <- getClassInfo path
- return $ fromIntegral $ (clMethodMap ci) M.! method
+ return $ fromIntegral $ (ciMethodMap ci) M.! method
getMethodTable :: B.ByteString -> IO (Word32)
getMethodTable path = do
ci <- getClassInfo path
- return $ clMethodBase ci
+ return $ ciMethodBase ci
getMethodSize :: B.ByteString -> IO (Word32)
getMethodSize path = do
ci <- getClassInfo path
-- TODO(bernhard): correct sizes for different types...
- let msize = fromIntegral $ M.size $ clMethodMap ci
+ let msize = fromIntegral $ M.size $ ciMethodMap ci
return $ (1 + msize) * 4
foreign export ccall getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
getStaticFieldAddr :: CUInt -> Ptr () -> IO CUInt
getStaticFieldAddr from ptr_trapmap = do
- trapmap <- ptr2tmap ptr_trapmap
+ trapmap <- ptr2trapmap ptr_trapmap
let w32_from = fromIntegral from
let sfi = trapmap M.! w32_from
case sfi of
staticbase <- mallocBytes ((fromIntegral $ length sfields) * 4)
let i_sb = fromIntegral $ ptrToIntPtr $ staticbase
let sm = zipbase i_sb sfields
- let sc_sm = getsupermap superclass clStaticMap
+ let sc_sm = getsupermap superclass ciStaticMap
-- new fields "overwrite" old ones, if they have the same name
let staticmap = (M.fromList sm) `M.union` sc_sm
- let sc_im = getsupermap superclass clFieldMap
+ let sc_im = getsupermap superclass ciFieldMap
-- "+ 4" for the method table pointer
let max_off = (fromIntegral $ (M.size sc_im) * 4) + 4
let im = zipbase max_off ifields
(\x -> (not . S.member ACC_STATIC . methodAccessFlags) x &&
((/=) "<init>" . methodName) x)
(classMethods cf)
- let sc_mm = getsupermap superclass clMethodMap
+ let sc_mm = getsupermap superclass ciMethodMap
let max_off = fromIntegral $ (M.size sc_mm) * 4
let mm = zipbase max_off methods
let methodmap = (M.fromList mm) `M.union` sc_mm
Just x -> return x
-- first try to execute class initializer of superclass
- when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ clFile ci) >> return ())
+ when (path /= "java/lang/Object") ((loadAndInitClass $ superClass $ ciFile ci) >> return ())
-- execute class initializer
- case lookupMethod "<clinit>" (clFile ci) of
+ case lookupMethod "<clinit>" (ciFile ci) of
Just m -> do
- hmap <- parseMethod (clFile ci) "<clinit>"
+ hmap <- parseMethod (ciFile ci) "<clinit>"
printMapBB hmap
case hmap of
Just hmap' -> do
Nothing -> return ()
class_map' <- get_classmap >>= ptr2classmap
- let new_ci = ci { clInitDone = True }
+ let new_ci = ci { ciInitDone = True }
let class_map'' = M.insert path new_ci class_map'
classmap2ptr class_map'' >>= set_classmap
return new_ci
foreign export ccall getMethodEntry :: CUInt -> CUInt -> IO CUInt
getMethodEntry :: CUInt -> CUInt -> IO CUInt
getMethodEntry signal_from methodtable = do
- mmap <- get_methodmap >>= ptr2mmap
- tmap <- get_trapmap >>= ptr2tmap
+ mmap <- get_methodmap >>= ptr2methodmap
+ tmap <- get_trapmap >>= ptr2trapmap
vmap <- get_virtualmap >>= ptr2virtualmap
let w32_from = fromIntegral signal_from
nf <- loadNativeFunction symbol
let w32_nf = fromIntegral nf
let mmap' = M.insert mi' w32_nf mmap
- mmap2ptr mmap' >>= set_methodmap
+ methodmap2ptr mmap' >>= set_methodmap
return nf
Nothing -> error $ (show method) ++ " not found. abort"
Just w32 -> return (fromIntegral w32)
initMethodPool :: IO ()
initMethodPool = do
- mmap2ptr M.empty >>= set_methodmap
- tmap2ptr M.empty >>= set_trapmap
+ methodmap2ptr M.empty >>= set_methodmap
+ trapmap2ptr M.empty >>= set_trapmap
classmap2ptr M.empty >>= set_classmap
virtualmap2ptr M.empty >>= set_virtualmap
stringsmap2ptr M.empty >>= set_stringsmap
addMethodRef :: Word32 -> MethodInfo -> [B.ByteString] -> IO ()
addMethodRef entry (MethodInfo mmname _ msig) clsnames = do
- mmap <- get_methodmap >>= ptr2mmap
+ mmap <- get_methodmap >>= ptr2methodmap
let newmap = M.fromList $ map (\x -> ((MethodInfo mmname x msig), entry)) clsnames
- mmap2ptr (mmap `M.union` newmap) >>= set_methodmap
+ methodmap2ptr (mmap `M.union` newmap) >>= set_methodmap
compileBB :: MapBB -> MethodInfo -> IO Word32
compileBB hmap methodinfo = do
- tmap <- get_trapmap >>= ptr2tmap
+ tmap <- get_trapmap >>= ptr2trapmap
- cls <- getClassFile (cName methodinfo)
+ cls <- getClassFile (methClassName methodinfo)
let ebb = emitFromBB (methName methodinfo) cls hmap
(_, Right ((entry, _, _, new_tmap), disasm)) <- runCodeGen ebb () ()
let tmap' = M.union tmap new_tmap -- prefers elements in cmap
- tmap2ptr tmap' >>= set_trapmap
+ trapmap2ptr tmap' >>= set_trapmap
printf "disasm:\n"
mapM_ (putStrLn . showAtt) disasm
type BlockID = Int
-- Represents a CFG node
data BasicBlock = BasicBlock {
- code :: [Instruction],
- successor :: BBEnd }
+ code :: [Instruction],
+ successor :: BBEnd }
-- describes (leaving) edges of a CFG node
data BBEnd = Return | FallThrough BlockID | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
type MapBB = M.Map BlockID BasicBlock
+
-- Word32 = point of method call in generated code
-- MethodInfo = relevant information about callee
-type TMap = M.Map Word32 TrapInfo
+type TrapMap = M.Map Word32 TrapInfo
data TrapInfo =
- MI MethodInfo |
+ MI MethodInfo | -- for static calls
VI MethodInfo | -- for virtual calls
SFI StaticFieldInfo
sfiClassName :: B.ByteString,
sfiFieldName :: B.ByteString }
--- B.ByteString = name of method
--- Word32 = entrypoint of method
-type MMap = M.Map MethodInfo Word32
-
-type ClassMap = M.Map B.ByteString ClassInfo
-type FieldMap = M.Map B.ByteString Int32
--- java strings are allocated once, therefore we
--- use a hashmap to store the address for a String
-type StringsMap = M.Map B.ByteString Word32
-
--- map "methodtable addr" to "classname"
--- we need that to identify the actual type
--- on the invokevirtual insn
-type VirtualMap = M.Map Word32 B.ByteString
-
-data ClassInfo = ClassInfo {
- clName :: B.ByteString,
- clFile :: Class Resolved,
- clStaticMap :: FieldMap,
- clFieldMap :: FieldMap,
- clMethodMap :: FieldMap,
- clMethodBase :: Word32,
- clInitDone :: Bool }
+-- B.ByteString = name of method
+-- Word32 = entrypoint of method
+type MethodMap = M.Map MethodInfo Word32
data MethodInfo = MethodInfo {
methName :: B.ByteString,
- cName :: B.ByteString,
- mSignature :: MethodSignature}
-
-instance Eq MethodInfo where
- (MethodInfo m_a c_a s_a) == (MethodInfo m_b c_b s_b) =
- (m_a == m_b) && (c_a == c_b) && (s_a == s_b)
+ methClassName :: B.ByteString,
+ methSignature :: MethodSignature
+ } deriving (Eq, Ord)
-- TODO(bernhard): not really efficient. also, outsource that to hs-java
+-- deriving should be enough?
instance Ord MethodSignature where
compare (MethodSignature args_a ret_a) (MethodSignature args_b ret_b)
| cmp_args /= EQ = cmp_args
where
cmp_args = (show args_a) `compare` (show args_b)
-instance Ord MethodInfo where
- compare (MethodInfo m_a c_a s_a) (MethodInfo m_b c_b s_b)
- | cmp_m /= EQ = cmp_m
- | cmp_c /= EQ = cmp_c
- | otherwise = s_a `compare` s_b
- where
- cmp_m = m_a `compare` m_b
- cmp_c = c_a `compare` c_b
-
instance Show MethodInfo where
show (MethodInfo method c sig) =
(toString c) ++ "." ++ (toString method) ++ "." ++ (show sig)
+
+-- store information of loaded classes
+type ClassMap = M.Map B.ByteString ClassInfo
+
+data ClassInfo = ClassInfo {
+ ciName :: B.ByteString,
+ ciFile :: Class Resolved,
+ ciStaticMap :: FieldMap,
+ ciFieldMap :: FieldMap,
+ ciMethodMap :: FieldMap,
+ ciMethodBase :: Word32,
+ ciInitDone :: Bool }
+
+
+-- store field offsets in a map
+type FieldMap = M.Map B.ByteString Int32
+
+
+-- java strings are allocated only once, therefore we
+-- use a hashmap to store the address for a String
+type StringsMap = M.Map B.ByteString Word32
+
+
+-- map "methodtable addr" to "classname"
+-- we need that to identify the actual type
+-- on the invokevirtual insn
+type VirtualMap = M.Map Word32 B.ByteString
+
+
toString :: B.ByteString -> String
toString bstr = decodeString $ map (chr . fromIntegral) $ B.unpack bstr
--- global map hax
+-- those functions are for the "global map hax"
+-- TODO(bernhard): other solution please
foreign import ccall "get_trapmap"
get_trapmap :: IO (Ptr ())
set_stringsmap :: Ptr () -> IO ()
-- TODO(bernhard): make some typeclass magic 'n stuff
-mmap2ptr :: MMap -> IO (Ptr ())
-mmap2ptr mmap = do
- ptr_mmap <- newStablePtr mmap
- return $ castStablePtrToPtr ptr_mmap
-
-ptr2mmap :: Ptr () -> IO MMap
-ptr2mmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr MMap)
-
-tmap2ptr :: TMap -> IO (Ptr ())
-tmap2ptr tmap = do
- ptr_tmap <- newStablePtr tmap
- return $ castStablePtrToPtr ptr_tmap
-
-ptr2tmap :: Ptr () -> IO TMap
-ptr2tmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr tmap)
+-- or remove that sh**
+methodmap2ptr :: MethodMap -> IO (Ptr ())
+methodmap2ptr methodmap = do
+ ptr_methodmap <- newStablePtr methodmap
+ return $ castStablePtrToPtr ptr_methodmap
+
+ptr2methodmap :: Ptr () -> IO MethodMap
+ptr2methodmap methodmap = deRefStablePtr $ ((castPtrToStablePtr methodmap) :: StablePtr MethodMap)
+
+trapmap2ptr :: TrapMap -> IO (Ptr ())
+trapmap2ptr trapmap = do
+ ptr_trapmap <- newStablePtr trapmap
+ return $ castStablePtrToPtr ptr_trapmap
+
+ptr2trapmap :: Ptr () -> IO TrapMap
+ptr2trapmap vmap = deRefStablePtr $ ((castPtrToStablePtr vmap) :: StablePtr trapmap)
classmap2ptr :: ClassMap -> IO (Ptr ())
classmap2ptr cmap = do
type BBStarts = M.Map BlockID Int
-type CompileInfo = (EntryPoint, BBStarts, Int, TMap)
+type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
getLabel _ [] = error "label not found!"
getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
- efBB :: (BlockID, BasicBlock) -> TMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TMap, BBStarts)
+ efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
efBB (bid, bb) calls bbstarts lmap =
if M.member bid bbstarts then
return (calls, bbstarts)