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       newNamedLabel (show l) >>= defineLabel
 111       -- like: call $0x01234567
 112       calladdr <- emitSigIllTrap 5
 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       when isInterface $
 136         mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
 137       -- get method-table-ptr (or interface-table-ptr)
 138       mov eax (Disp 0, ebx)
 139       -- make actual (indirect) call
 140       calladdr <- getCurrentOffset
 141       -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
 142       emitSigIllTrap 6
 143       -- discard arguments on stack (`+1' for "this")
 144       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
 145       when (argcnt > 0) (add esp argcnt)
 146       -- push result on stack if method has a return value
 147       when (methodHaveReturnValue cls cpidx) (push eax)
 148       -- note, that "mi" has the wrong class reference here.
 149       -- we figure that out at run-time, in the methodpool,
 150       -- depending on the method-table-ptr
 151       return $ Just (calladdr, VirtualCall isInterface mi offset)
 152
 153     emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 154     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 155
 156     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 157     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 158     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 159     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 160     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 161
 162     emit' (PUTSTATIC cpidx) = do
 163       pop eax
 164       trapaddr <- getCurrentOffset
 165       mov (Addr 0x00000000) eax -- it's a trap
 166       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 167     emit' (GETSTATIC cpidx) = do
 168       trapaddr <- getCurrentOffset
 169       mov eax (Addr 0x00000000) -- it's a trap
 170       push eax
 171       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 172
 173     emit' (GETFIELD x) = do
 174       pop eax -- this pointer
 175       -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
 176       trapaddr <- emitSigIllTrap 6
 177       let patcher reip = do
 178             let (cname, fname) = buildFieldOffset cls x
 179             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 180             push32RelEax (Disp offset) -- get field
 181             return reip
 182       return $ Just (trapaddr, ObjectField patcher)
 183     emit' (PUTFIELD x) = do
 184       pop ebx -- value to write
 185       pop eax -- this pointer
 186       -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
 187       trapaddr <- emitSigIllTrap 6
 188       let patcher reip = do
 189             let (cname, fname) = buildFieldOffset cls x
 190             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 191             mov32RelEbxEax (Disp offset) -- set field
 192             return reip
 193       return $ Just (trapaddr, ObjectField patcher)
 194
 195     emit' (INSTANCEOF cpidx) = do
 196       pop eax
 197       -- place something like `mov edx $mtable_of_objref' instead
 198       trapaddr <- emitSigIllTrap 4
 199       push (0 :: Word32)
 200       let patcher reax reip = do
 201             emitSigIllTrap 4
 202             let classname = buildClassID cls cpidx
 203             check <- liftIO $ isInstanceOf (fromIntegral reax) classname
 204             if check
 205               then push (1 :: Word32)
 206               else push (0 :: Word32)
 207             return (reip + 4)
 208       return $ Just (trapaddr, InstanceOf patcher)
 209     emit' (NEW objidx) = do
 210       let objname = buildClassID cls objidx
 211       -- place something like `push $objsize' instead
 212       trapaddr <- emitSigIllTrap 5
 213       callMalloc
 214       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 215       mov (Disp 0, eax) (0x13371337 :: Word32)
 216       mov (Disp 4, eax) (0x1337babe :: Word32)
 217       let patcher reip = do
 218             objsize <- liftIO $ getObjectSize objname
 219             push32 objsize
 220             callMalloc
 221             mtable <- liftIO $ getMethodTable objname
 222             mov (Disp 0, eax) mtable
 223             mov (Disp 4, eax) (0x1337babe :: Word32)
 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     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 369     emitSigIllTrap traplen = do
 370       trapaddr <- getCurrentOffset
 371       -- 0xffff causes SIGILL
 372       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 373       -- fill rest up with NOPs
 374       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 375       return trapaddr
 376
 377
 378   -- for locals we use a different storage
 379   cArgs :: Word8 -> Word32
 380   cArgs x = ptrSize * (argcount - x' + isLocal)
 381     where
 382       x' = fromIntegral x
 383       argcount = rawArgCount method
 384       isLocal = if x' >= argcount then (-1) else 1
 385
 386   cArgs_ :: IMM -> Word8
 387   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 388
 389
 390   -- sign extension from w8 to w32 (over s8)
 391   --   unfortunately, hs-java is using Word8 everywhere (while
 392   --   it should be Int8 actually)
 393   s8_w32 :: Word8 -> Word32
 394   s8_w32 w8 = fromIntegral s8
 395     where s8 = fromIntegral w8 :: Int8
 396
 397 callMalloc :: CodeGen e s ()
 398 callMalloc = do
 399   call mallocObjectAddr
 400   add esp (ptrSize :: Word32)
 401   push eax
 402
 403
 404 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 405 -- however, this is bad for patching so we want to put always 32bit.
 406
 407 -- push imm32
 408 push32 :: Word32 -> CodeGen e s ()
 409 push32 imm32 = emit8 0x68 >> emit32 imm32
 410
 411 -- call disp32(%eax)
 412 call32Eax :: Disp -> CodeGen e s ()
 413 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 414
 415 -- push disp32(%eax)
 416 push32RelEax :: Disp -> CodeGen e s ()
 417 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 418
 419 -- mov %ebx, disp32(%eax)
 420 mov32RelEbxEax :: Disp -> CodeGen e s ()
 421 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32