Mate/X86CodeGen.hs

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