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