Mate/X86CodeGen.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.X86CodeGen where
   4
   5 import Prelude hiding (and, div)
   6 import Data.Binary
   7 import Data.BinaryState
   8 import Data.Int
   9 import Data.Maybe
  10 import Data.List (genericLength)
  11 import qualified Data.Map as M
  12 import qualified Data.ByteString.Lazy as B
  13 import Control.Monad
  14
  15 import Foreign hiding (xor)
  16 import Foreign.C.Types
  17
  18 import qualified JVM.Assembler as J
  19 import JVM.Assembler hiding (Instruction)
  20 import JVM.ClassFile
  21
  22 import Harpy
  23 import Harpy.X86Disassembler
  24
  25 import Mate.BasicBlocks
  26 import Mate.NativeSizes
  27 import Mate.Types
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30 import Mate.Strings
  31
  32
  33 foreign import ccall "&mallocObjectGC"
  34   mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
  35
  36 type EntryPoint = Ptr Word8
  37 type EntryPointOffset = Int
  38 type PatchInfo = (BlockID, EntryPointOffset)
  39
  40 type BBStarts = M.Map BlockID Int
  41
  42 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  43
  44
  45 emitFromBB :: Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction])
  46 emitFromBB cls method = do
  47     let keys = M.keys hmap
  48     llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
  49     let lmap = zip keys llmap
  50     ep <- getEntryPoint
  51     push ebp
  52     mov ebp esp
  53     sub esp (fromIntegral (rawLocals method) * ptrSize :: Word32)
  54
  55     (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  56     d <- disassemble
  57     end <- getCodeOffset
  58     return ((ep, bbstarts, end, calls), d)
  59   where
  60   hmap = rawMapBB method
  61
  62   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  63   getLabel _ [] = error "label not found!"
  64   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  65
  66   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  67   efBB (bid, bb) calls bbstarts lmap =
  68     if M.member bid bbstarts then
  69       return (calls, bbstarts)
  70     else do
  71       bb_offset <- getCodeOffset
  72       let bbstarts' = M.insert bid bb_offset bbstarts
  73       defineLabel $ getLabel bid lmap
  74       cs <- mapM emit'' $ code bb
  75       let calls' = calls `M.union` M.fromList (catMaybes cs)
  76       case successor bb of
  77         Return -> return (calls', bbstarts')
  78         FallThrough t -> do
  79           -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
  80           jmp (getLabel t lmap)
  81           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     forceRegDump :: CodeGen e s ()
  91     forceRegDump = do
  92       push esi
  93       mov esi (0x13371234 :: Word32)
  94       mov esi (Addr 0)
  95       pop esi
  96
  97     getCurrentOffset :: CodeGen e s Word32
  98     getCurrentOffset = do
  99       ep <- getEntryPoint
 100       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
 101       offset <- getCodeOffset
 102       return $ w32_ep + fromIntegral offset
 103
 104     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 105     emitInvoke cpidx hasThis = do
 106       let l = buildMethodID cls cpidx
 107       calladdr <- getCurrentOffset
 108       newNamedLabel (show l) >>= defineLabel
 109       -- causes SIGILL. in the signal handler we patch it to the acutal call.
 110       -- place two nop's at the end, therefore the disasm doesn't screw up
 111       emit32 (0x9090ffff :: Word32); nop
 112       -- discard arguments on stack
 113       let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount (methodNameTypeByIdx cls cpidx)) * ptrSize
 114       when (argcnt > 0) (add esp argcnt)
 115       -- push result on stack if method has a return value
 116       when (methodHaveReturnValue cls cpidx) (push eax)
 117       return $ Just (calladdr, StaticMethod l)
 118
 119     virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 120     virtualCall cpidx isInterface = do
 121       let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 122       newNamedLabel (show mi) >>= defineLabel
 123       -- get method offset for call @ runtime
 124       let offset = if isInterface
 125           then getInterfaceMethodOffset objname methodname (encode msig)
 126           else getMethodOffset objname (methodname `B.append` encode msig)
 127       let argsLen = genericLength args
 128       -- objref lives somewhere on the argument stack
 129       mov ebx (Disp (argsLen * ptrSize), esp)
 130       if isInterface
 131         then mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
 132         else return () -- invokevirtual
 133       -- get method-table-ptr (or interface-table-ptr)
 134       mov eax (Disp 0, ebx)
 135       -- make actual (indirect) call
 136       calladdr <- getCurrentOffset
 137       -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
 138       emit32 (0x9090ffff :: Word32); nop; nop
 139       -- discard arguments on stack (`+1' for "this")
 140       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
 141       when (argcnt > 0) (add esp argcnt)
 142       -- push result on stack if method has a return value
 143       when (methodHaveReturnValue cls cpidx) (push eax)
 144       -- note, that "mi" has the wrong class reference here.
 145       -- we figure that out at run-time, in the methodpool,
 146       -- depending on the method-table-ptr
 147       return $ Just (calladdr, VirtualCall isInterface mi offset)
 148
 149     emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 150     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 151
 152     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 153     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 154     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 155     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 156     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 157
 158     emit' (PUTSTATIC cpidx) = do
 159       pop eax
 160       trapaddr <- getCurrentOffset
 161       mov (Addr 0x00000000) eax -- it's a trap
 162       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 163     emit' (GETSTATIC cpidx) = do
 164       trapaddr <- getCurrentOffset
 165       mov eax (Addr 0x00000000) -- it's a trap
 166       push eax
 167       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 168
 169     emit' (GETFIELD x) = do
 170       pop eax -- this pointer
 171       trapaddr <- getCurrentOffset
 172       -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
 173       emit32 (0x9090ffff :: Word32); nop; nop
 174       let patcher reip = do
 175             let (cname, fname) = buildFieldOffset cls x
 176             offset <- liftIO $ getFieldOffset cname fname
 177             push32_rel_eax (Disp (fromIntegral offset)) -- get field
 178             return reip
 179       return $ Just (trapaddr, ObjectField patcher)
 180     emit' (PUTFIELD x) = do
 181       pop ebx -- value to write
 182       pop eax -- this pointer
 183       trapaddr <- getCurrentOffset
 184       -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
 185       emit32 (0x9090ffff :: Word32); nop; nop
 186       let patcher reip = do
 187             let (cname, fname) = buildFieldOffset cls x
 188             offset <- liftIO $ getFieldOffset cname fname
 189             mov32_rel_ebx_eax (Disp (fromIntegral offset)) -- set field
 190             return reip
 191       return $ Just (trapaddr, ObjectField patcher)
 192
 193     emit' (INSTANCEOF cpidx) = do
 194       pop eax
 195       mov eax (Disp 0, eax) -- mtable of objectref
 196       trapaddr <- getCurrentOffset
 197       -- place something like `mov edx $mtable_of_objref' instead
 198       emit32 (0x9090ffff :: Word32); nop
 199       cmp eax edx
 200       sete al
 201       movzxb eax al
 202       push eax
 203       forceRegDump
 204       return $ Just (trapaddr, InstanceOf $ buildClassID cls cpidx)
 205     emit' (NEW objidx) = do
 206       let objname = buildClassID cls objidx
 207       trapaddr <- getCurrentOffset
 208       -- place something like `push $objsize' instead
 209       emit32 (0x9090ffff :: Word32); nop
 210       callMalloc
 211       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 212       mov (Disp 0, eax) (0x13371337 :: Word32)
 213       return $ Just (trapaddr, NewObject objname)
 214
 215     emit' insn = emit insn >> return Nothing
 216
 217     emit :: J.Instruction -> CodeGen e s ()
 218     emit POP = add esp (ptrSize :: Word32) -- drop value
 219     emit DUP = push (Disp 0, esp)
 220     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 221     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 222     emit AASTORE = emit IASTORE
 223     emit IASTORE = do
 224       pop eax -- value
 225       pop ebx -- offset
 226       add ebx (1 :: Word32)
 227       pop ecx -- aref
 228       mov (ecx, ebx, S4) eax
 229     emit CASTORE = do
 230       pop eax -- value
 231       pop ebx -- offset
 232       add ebx (1 :: Word32)
 233       pop ecx -- aref
 234       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 235     emit AALOAD = emit IALOAD
 236     emit IALOAD = do
 237       pop ebx -- offset
 238       add ebx (1 :: Word32)
 239       pop ecx -- aref
 240       push (ecx, ebx, S4)
 241     emit CALOAD = do
 242       pop ebx -- offset
 243       add ebx (1 :: Word32)
 244       pop ecx -- aref
 245       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 246     emit ARRAYLENGTH = do
 247       pop eax
 248       push (Disp 0, eax)
 249     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 250     emit (NEWARRAY typ) = do
 251       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 252                   T_INT -> 4
 253                   T_CHAR -> 2
 254                   _ -> error "newarray: type not implemented yet"
 255       -- get length from stack, but leave it there
 256       mov eax (Disp 0, esp)
 257       mov ebx (tsize :: Word32)
 258       -- multiple amount with native size of one element
 259       mul ebx -- result is in eax
 260       add eax (ptrSize :: Word32) -- for "length" entry
 261       -- push amount of bytes to allocate
 262       push eax
 263       callMalloc
 264       pop eax -- ref to arraymemory
 265       pop ebx -- length
 266       mov (Disp 0, eax) ebx -- store length at offset 0
 267       push eax -- push ref again
 268
 269     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 270     emit ATHROW = -- TODO(bernhard): ...
 271         emit32 (0xffffffff :: Word32)
 272     emit I2C = do
 273       pop eax
 274       and eax (0x000000ff :: Word32)
 275       push eax
 276     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 277     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 278     emit ACONST_NULL = push (0 :: Word32)
 279     emit (ICONST_M1) = push ((-1) :: Word32)
 280     emit (ICONST_0) = push (0 :: Word32)
 281     emit (ICONST_1) = push (1 :: Word32)
 282     emit (ICONST_2) = push (2 :: Word32)
 283     emit (ICONST_3) = push (3 :: Word32)
 284     emit (ICONST_4) = push (4 :: Word32)
 285     emit (ICONST_5) = push (5 :: Word32)
 286
 287     emit (ALOAD_ x) = emit (ILOAD_ x)
 288     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 289     emit (ALOAD x) = emit (ILOAD x)
 290     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 291
 292     emit (ASTORE_ x) = emit (ISTORE_ x)
 293     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 294     emit (ASTORE x) = emit (ISTORE x)
 295     emit (ISTORE x) = do
 296       pop eax
 297       mov (Disp (cArgs x), ebp) eax
 298
 299     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 300     emit (LDC2 x) = do
 301       value <- case constsPool cls M.! x of
 302                     (CString s) -> liftIO $ getUniqueStringAddr s
 303                     (CInteger i) -> liftIO $ return i
 304                     e -> error $ "LDCI... missing impl.: " ++ show e
 305       push value
 306
 307     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 308     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 309     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 310     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 311     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 312     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 313     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 314     emit INEG = do pop eax; neg eax; push eax
 315     emit (IINC x imm) =
 316       add (Disp (cArgs x), ebp) (s8_w32 imm)
 317
 318     emit (IFNONNULL x) = emit (IF C_NE x)
 319     emit (IFNULL x) = emit (IF C_EQ x)
 320     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 321     emit (IF_ICMP cond _) = do
 322       pop eax -- value2
 323       pop ebx -- value1
 324       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 325       emitIF cond
 326
 327     emit (IF cond _) = do
 328       pop eax -- value1
 329       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 330       emitIF cond
 331
 332     emit (GOTO _ ) = do
 333       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 334       jmp $ getLabel sid lmap
 335
 336     emit RETURN = do mov esp ebp; pop ebp; ret
 337     emit ARETURN = emit IRETURN
 338     emit IRETURN = do pop eax; emit RETURN
 339     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 340
 341     emitIF :: CMP -> CodeGen e s ()
 342     emitIF cond = let
 343       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 344       l = getLabel sid lmap
 345       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 346       l2 = getLabel sid2 lmap
 347       in do
 348         case cond of
 349           C_EQ -> je  l; C_NE -> jne l
 350           C_LT -> jl  l; C_GT -> jg  l
 351           C_GE -> jge l; C_LE -> jle l
 352         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 353         --  (it didn't work for gnu/classpath/SystemProperties.java)
 354         jmp l2
 355
 356
 357   -- for locals we use a different storage
 358   cArgs :: Word8 -> Word32
 359   cArgs x = ptrSize * (argcount - x' + isLocal)
 360     where
 361       x' = fromIntegral x
 362       argcount = rawArgCount method
 363       isLocal = if x' >= argcount then (-1) else 1
 364
 365   cArgs_ :: IMM -> Word8
 366   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 367
 368
 369   -- sign extension from w8 to w32 (over s8)
 370   --   unfortunately, hs-java is using Word8 everywhere (while
 371   --   it should be Int8 actually)
 372   s8_w32 :: Word8 -> Word32
 373   s8_w32 w8 = fromIntegral s8
 374     where s8 = fromIntegral w8 :: Int8
 375
 376 callMalloc :: CodeGen e s ()
 377 callMalloc = do
 378   call mallocObjectAddr
 379   add esp (ptrSize :: Word32)
 380   push eax
 381
 382
 383 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 384 -- however, this is bad for patching so we want to put always 32bit.
 385
 386 -- push imm32
 387 push32 :: Word32 -> CodeGen e s ()
 388 push32 imm32 = emit8 0x68 >> emit32 imm32
 389
 390 -- call disp32(%eax)
 391 call32_eax :: Disp -> CodeGen e s ()
 392 call32_eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 393
 394 -- push disp32(%eax)
 395 push32_rel_eax :: Disp -> CodeGen e s ()
 396 push32_rel_eax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 397
 398 -- mov %ebx, disp32(%eax)
 399 mov32_rel_ebx_eax :: Disp -> CodeGen e s ()
 400 mov32_rel_ebx_eax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32