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