Mate/X86CodeGen.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 #include "debug.h"
   5 module Mate.X86CodeGen where
   6
   7 import Data.Binary
   8 import Data.BinaryState
   9 import Data.Int
  10 import Data.Maybe
  11 import qualified Data.Map as M
  12 import qualified Data.Set as S
  13 import qualified Data.ByteString.Lazy as B
  14 import Control.Monad
  15
  16 import Foreign hiding (xor)
  17 import Foreign.C.Types
  18
  19 import qualified JVM.Assembler as J
  20 import JVM.Assembler hiding (Instruction)
  21 import JVM.ClassFile
  22
  23 import Harpy
  24 import Harpy.X86Disassembler
  25
  26 import Mate.BasicBlocks
  27 import Mate.Types
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30 import Mate.Strings
  31
  32
  33 foreign import ccall "dynamic"
  34    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> CInt -> CInt -> IO CInt
  35
  36 foreign import ccall "getMallocObjectAddr"
  37   getMallocObjectAddr :: CUInt
  38
  39 type EntryPoint = Ptr Word8
  40 type EntryPointOffset = Int
  41 type PatchInfo = (BlockID, EntryPointOffset)
  42
  43 type BBStarts = M.Map BlockID Int
  44
  45 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  46
  47
  48 emitFromBB :: B.ByteString -> Class Direct -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  49 emitFromBB method cls hmap =  do
  50         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  51         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  52         ep <- getEntryPoint
  53         push ebp
  54         mov ebp esp
  55         -- TODO(bernhard): determine a reasonable value.
  56         --                 e.g. (locals used) * 4
  57         sub esp (0x60 :: Word32)
  58
  59         (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  60         d <- disassemble
  61         end <- getCodeOffset
  62         return ((ep, bbstarts, end, calls), d)
  63   where
  64   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  65   getLabel _ [] = error "label not found!"
  66   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  67
  68   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  69   efBB (bid, bb) calls bbstarts lmap =
  70         if M.member bid bbstarts then
  71           return (calls, bbstarts)
  72         else do
  73           bb_offset <- getCodeOffset
  74           let bbstarts' = M.insert bid bb_offset bbstarts
  75           defineLabel $ getLabel bid lmap
  76           cs <- mapM emit' $ code bb
  77           let calls' = calls `M.union` M.fromList (catMaybes cs)
  78           case successor bb of
  79             Return -> return (calls', bbstarts')
  80             FallThrough t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
  81             OneTarget t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
  82             TwoTarget t1 t2 -> do
  83               (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
  84               efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
  85     -- TODO(bernhard): also use metainformation
  86     -- TODO(bernhard): implement `emit' as function which accepts a list of
  87     --                 instructions, so we can use patterns for optimizations
  88     where
  89     getCurrentOffset :: CodeGen e s Word32
  90     getCurrentOffset = do
  91       ep <- getEntryPoint
  92       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
  93       offset <- getCodeOffset
  94       return $ w32_ep + fromIntegral offset
  95
  96     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
  97     emitInvoke cpidx hasThis = do
  98         let l = buildMethodID cls cpidx
  99         calladdr <- getCurrentOffset
 100         newNamedLabel (show l) >>= defineLabel
 101         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 102         -- place a nop at the end, therefore the disasm doesn't screw up
 103         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 104         -- discard arguments on stack
 105         let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount cls cpidx) * 4
 106         when (argcnt > 0) (add esp argcnt)
 107         -- push result on stack if method has a return value
 108         when (methodHaveReturnValue cls cpidx) (push eax)
 109         -- +2 is for correcting eip in trap context
 110         return $ Just (calladdr + 2, MI l)
 111
 112     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 113     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 114     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 115     emit' (INVOKEINTERFACE cpidx _) = do
 116         -- get methodInfo entry
 117         let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
 118         newNamedLabel (show mi) >>= defineLabel
 119         -- objref lives somewhere on the argument stack
 120         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 121         -- get method-table-ptr, keep it in eax (for trap handling)
 122         mov eax (Disp 0, eax)
 123         -- get interface-table-ptr
 124         mov ebx (Disp 0, eax)
 125         -- get method offset
 126         offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
 127         -- make actual (indirect) call
 128         calladdr <- getCurrentOffset
 129         call (Disp offset, ebx)
 130         -- discard arguments on stack (+4 for "this")
 131         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 132         when (argcnt > 0) (add esp argcnt)
 133         -- push result on stack if method has a return value
 134         when (methodHaveReturnValue cls cpidx) (push eax)
 135         -- note, the "mi" has the wrong class reference here.
 136         -- we figure that out at run-time, in the methodpool,
 137         -- depending on the method-table-ptr
 138         return $ Just (calladdr, II mi)
 139     emit' (INVOKEVIRTUAL cpidx) = do
 140         -- get methodInfo entry
 141         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 142         newNamedLabel (show mi) >>= defineLabel
 143         -- objref lives somewhere on the argument stack
 144         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 145         -- get method-table-ptr
 146         mov eax (Disp 0, eax)
 147         -- get method offset
 148         let nameAndSig = methodname `B.append` encode msig
 149         offset <- liftIO $ getMethodOffset objname nameAndSig
 150         -- make actual (indirect) call
 151         calladdr <- getCurrentOffset
 152         call (Disp offset, eax)
 153         -- discard arguments on stack (+4 for "this")
 154         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 155         when (argcnt > 0) (add esp argcnt)
 156         -- push result on stack if method has a return value
 157         when (methodHaveReturnValue cls cpidx) (push eax)
 158         -- note, the "mi" has the wrong class reference here.
 159         -- we figure that out at run-time, in the methodpool,
 160         -- depending on the method-table-ptr
 161         return $ Just (calladdr, VI mi)
 162     emit' (PUTSTATIC cpidx) = do
 163         pop eax
 164         trapaddr <- getCurrentOffset
 165         mov (Addr 0x00000000) eax -- it's a trap
 166         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 167     emit' (GETSTATIC cpidx) = do
 168         trapaddr <- getCurrentOffset
 169         mov eax (Addr 0x00000000) -- it's a trap
 170         push eax
 171         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 172     emit' insn = emit insn >> return Nothing
 173
 174     emit :: J.Instruction -> CodeGen e s ()
 175     emit POP = add esp (4 :: Word32) -- drop value
 176     emit DUP = push (Disp 0, esp)
 177     emit AASTORE = emit IASTORE
 178     emit IASTORE = do
 179         pop eax -- value
 180         pop ebx -- offset
 181         add ebx (1 :: Word32)
 182         pop ecx -- aref
 183         mov (ecx, ebx, S4) eax
 184     emit AALOAD = emit IALOAD
 185     emit IALOAD = do
 186         pop ebx -- offset
 187         add ebx (1 :: Word32)
 188         pop ecx -- aref
 189         push (ecx, ebx, S4)
 190     emit ARRAYLENGTH = do
 191         pop eax
 192         push (Disp 0, eax)
 193     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 194     emit (NEWARRAY typ) = do
 195         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 196                     T_INT -> 4
 197                     _ -> error "newarray: type not implemented yet"
 198         -- get length from stack, but leave it there
 199         mov eax (Disp 0, esp)
 200         mov ebx (tsize :: Word32)
 201         -- multiple amount with native size of one element
 202         mul ebx -- result is in eax
 203         add eax (4 :: Word32) -- for "length" entry
 204         -- push amount of bytes to allocate
 205         push eax
 206         callMalloc
 207         pop eax -- ref to arraymemory
 208         pop ebx -- length
 209         mov (Disp 0, eax) ebx -- store length at offset 0
 210         push eax -- push ref again
 211     emit (NEW objidx) = do
 212         let objname = buildClassID cls objidx
 213         amount <- liftIO $ getObjectSize objname
 214         push (amount :: Word32)
 215         callMalloc
 216         -- TODO(bernhard): save reference somewhere for GC
 217         -- set method table pointer
 218         mtable <- liftIO $ getMethodTable objname
 219         mov (Disp 0, eax) mtable
 220     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 221     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 222     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 223     emit (ICONST_0) = push (0 :: Word32)
 224     emit (ICONST_1) = push (1 :: Word32)
 225     emit (ICONST_2) = push (2 :: Word32)
 226     emit (ICONST_3) = push (3 :: Word32)
 227     emit (ICONST_4) = push (4 :: Word32)
 228     emit (ICONST_5) = push (5 :: Word32)
 229     emit (ALOAD_ x) = emit (ILOAD_ x)
 230     emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
 231     emit (ALOAD x) = emit (ILOAD x)
 232     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 233     emit (ASTORE_ x) = emit (ISTORE_ x)
 234     emit (ISTORE_ x) = do
 235         pop eax
 236         mov (Disp (cArgs_ x), ebp) eax
 237     emit (ASTORE x) = emit (ISTORE x)
 238     emit (ISTORE x) = do
 239         pop eax
 240         mov (Disp (cArgs x), ebp) eax
 241
 242     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 243     emit (LDC2 x) = do
 244         value <- case constsPool cls M.! x of
 245                       (CString s) -> liftIO $ getUniqueStringAddr s
 246                       _ -> error "LDCI... missing impl."
 247         push value
 248     emit (GETFIELD x) = do
 249         offset <- emitFieldOffset x
 250         push (Disp (fromIntegral offset), eax) -- get field
 251     emit (PUTFIELD x) = do
 252         pop ebx -- value to write
 253         offset <- emitFieldOffset x
 254         mov (Disp (fromIntegral offset), eax) ebx -- set field
 255
 256     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 257     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 258     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 259     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 260     emit (IINC x imm) =
 261         add (Disp (cArgs x), ebp) (s8_w32 imm)
 262
 263     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 264     emit (IF_ICMP cond _) = do
 265         pop eax -- value2
 266         pop ebx -- value1
 267         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 268         emitIF cond
 269
 270     emit (IF cond _) = do
 271         pop eax -- value1
 272         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 273         emitIF cond
 274
 275     emit (GOTO _ ) = do
 276         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 277         jmp $ getLabel sid lmap
 278
 279     emit RETURN = do mov esp ebp; pop ebp; ret
 280     emit ARETURN = emit IRETURN
 281     emit IRETURN = do pop eax; emit RETURN
 282     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 283
 284     emitFieldOffset :: Word16 -> CodeGen e s Int32
 285     emitFieldOffset x = do
 286         pop eax -- this pointer
 287         let (cname, fname) = buildFieldOffset cls x
 288         liftIO $ getFieldOffset cname fname
 289
 290     emitIF :: CMP -> CodeGen e s ()
 291     emitIF cond = let
 292       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 293       l = getLabel sid lmap
 294       in case cond of
 295         C_EQ -> je  l; C_NE -> jne l
 296         C_LT -> jl  l; C_GT -> jg  l
 297         C_GE -> jge l; C_LE -> jle l
 298
 299     callMalloc :: CodeGen e s ()
 300     callMalloc = do
 301         calladdr <- getCurrentOffset
 302         let w32_calladdr = 5 + calladdr
 303         let malloaddr = fromIntegral getMallocObjectAddr :: Word32
 304         call (malloaddr - w32_calladdr)
 305         add esp (4 :: Word32)
 306         push eax
 307
 308   -- for locals we use a different storage
 309   cArgs :: Word8 -> Word32
 310   cArgs x = if x' >= thisMethodArgCnt
 311       -- TODO(bernhard): maybe s/(-4)/(-8)/
 312       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 313       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 314     where x' = fromIntegral x
 315
 316   cArgs_ :: IMM -> Word32
 317   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 318
 319   thisMethodArgCnt :: Word32
 320   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 321     where
 322     (Just m) = lookupMethod method cls
 323     (MethodSignature args _) = methodSignature m
 324     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 325         then 0 else 1 -- one argument for the this pointer
 326
 327
 328   -- sign extension from w8 to w32 (over s8)
 329   --   unfortunately, hs-java is using Word8 everywhere (while
 330   --   it should be Int8 actually)
 331   s8_w32 :: Word8 -> Word32
 332   s8_w32 w8 = fromIntegral s8
 333     where s8 = fromIntegral w8 :: Int8