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