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, Int, TrapMap)
  46
  47
  48 emitFromBB :: Class Direct -> MethodInfo -> RawMethod -> CodeGen e JpcNpcMap (CompileInfo, [Instruction])
  49 emitFromBB cls miThis 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     calls <- M.fromList . catMaybes . concat <$> mapM (efBB lmap) keys
  58     d <- disassemble
  59     end <- getCodeOffset
  60     return ((ep, end, calls), d)
  61   where
  62   hmap = rawMapBB method
  63
  64   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  65   getLabel bid [] = error $ "label " ++ show bid ++ " not found"
  66   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  67
  68   efBB :: [(BlockID, Label)] -> BlockID -> CodeGen e JpcNpcMap [(Maybe (Word32, TrapCause))]
  69   efBB lmap bid = do
  70     defineLabel $ getLabel bid lmap
  71     retval <- mapM emit'' $ code bb
  72     case successor bb of
  73         FallThrough t -> do
  74           -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
  75           jmp (getLabel t lmap)
  76         _ -> return ()
  77     return retval
  78     where
  79     bb = hmap M.! bid
  80
  81     forceRegDump :: CodeGen e s ()
  82     forceRegDump = do
  83       push esi
  84       mov esi (0x13371234 :: Word32)
  85       mov esi (Addr 0)
  86       pop esi
  87
  88     getCurrentOffset :: CodeGen e s Word32
  89     getCurrentOffset = do
  90       ep <- (fromIntegral . ptrToIntPtr) <$> getEntryPoint
  91       offset <- fromIntegral <$> getCodeOffset
  92       return $ ep + offset
  93
  94     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
  95     emitInvoke cpidx hasThis = do
  96       let l = buildMethodID cls cpidx
  97       newNamedLabel (show l) >>= defineLabel
  98       -- like: call $0x01234567
  99       calladdr <- emitSigIllTrap 5
 100       let patcher reip = do
 101             (entryAddr, _) <- liftIO $ getMethodEntry l
 102             call (fromIntegral (entryAddr - (reip + 5)) :: NativeWord)
 103             return reip
 104       -- discard arguments on stack
 105       let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount (methodNameTypeByIdx cls cpidx)) * ptrSize
 106       when (argcnt > 0) (add esp argcnt)
 107       -- push result on stack if method has a return value
 108       when (methodHaveReturnValue cls cpidx) (push eax)
 109       return $ Just (calladdr, StaticMethod patcher)
 110
 111     virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 112     virtualCall cpidx isInterface = do
 113       let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 114       newNamedLabel (show mi) >>= defineLabel
 115       -- get method offset for call @ runtime
 116       let offset = if isInterface
 117           then getInterfaceMethodOffset objname methodname (encode msig)
 118           else getMethodOffset objname (methodname `B.append` encode msig)
 119       let argsLen = genericLength args
 120       -- objref lives somewhere on the argument stack
 121       mov ebx (Disp (argsLen * ptrSize), esp)
 122       when isInterface $
 123         mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
 124       -- get method-table-ptr (or interface-table-ptr)
 125       mov eax (Disp 0, ebx)
 126       -- make actual (indirect) call
 127       calladdr <- getCurrentOffset
 128       -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
 129       emitSigIllTrap 6
 130       -- discard arguments on stack (`+1' for "this")
 131       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
 132       when (argcnt > 0) (add esp argcnt)
 133       -- push result on stack if method has a return value
 134       when (methodHaveReturnValue cls cpidx) (push eax)
 135       -- note, that "mi" has the wrong class reference here.
 136       -- we figure that out at run-time, in the methodpool,
 137       -- depending on the method-table-ptr
 138       return $ Just (calladdr, VirtualCall isInterface mi offset)
 139
 140     emit'' :: J.Instruction -> CodeGen e JpcNpcMap (Maybe (Word32, TrapCause))
 141     emit'' insn = do
 142       ep <- (fromIntegral . ptrToIntPtr) <$> getEntryPoint
 143       jpcrpc <- getState
 144       setState (M.insert ep bid jpcrpc)
 145       newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 146
 147     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 148     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 149     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 150     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 151     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 152
 153     emit' (PUTSTATIC cpidx) = do
 154       pop eax
 155       trapaddr <- getCurrentOffset
 156       mov (Addr 0x00000000) eax -- it's a trap
 157       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 158     emit' (GETSTATIC cpidx) = do
 159       trapaddr <- getCurrentOffset
 160       mov eax (Addr 0x00000000) -- it's a trap
 161       push eax
 162       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 163
 164     emit' (GETFIELD x) = do
 165       pop eax -- this pointer
 166       -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
 167       trapaddr <- emitSigIllTrap 6
 168       let patcher reip = do
 169             let (cname, fname) = buildFieldOffset cls x
 170             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 171             push32RelEax (Disp offset) -- get field
 172             return reip
 173       return $ Just (trapaddr, ObjectField patcher)
 174     emit' (PUTFIELD x) = do
 175       pop ebx -- value to write
 176       pop eax -- this pointer
 177       -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
 178       trapaddr <- emitSigIllTrap 6
 179       let patcher reip = do
 180             let (cname, fname) = buildFieldOffset cls x
 181             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 182             mov32RelEbxEax (Disp offset) -- set field
 183             return reip
 184       return $ Just (trapaddr, ObjectField patcher)
 185
 186     emit' (INSTANCEOF cpidx) = do
 187       pop eax
 188       -- place something like `mov edx $mtable_of_objref' instead
 189       trapaddr <- emitSigIllTrap 4
 190       push (0 :: Word32)
 191       let patcher reax reip = do
 192             emitSigIllTrap 4
 193             let classname = buildClassID cls cpidx
 194             check <- liftIO $ isInstanceOf (fromIntegral reax) classname
 195             if check
 196               then push (1 :: Word32)
 197               else push (0 :: Word32)
 198             return (reip + 4)
 199       return $ Just (trapaddr, InstanceOf patcher)
 200     emit' (NEW objidx) = do
 201       let objname = buildClassID cls objidx
 202       -- place something like `push $objsize' instead
 203       trapaddr <- emitSigIllTrap 5
 204       callMalloc
 205       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 206       mov (Disp 0, eax) (0x13371337 :: Word32)
 207       mov (Disp 4, eax) (0x1337babe :: Word32)
 208       let patcher reip = do
 209             objsize <- liftIO $ getObjectSize objname
 210             push32 objsize
 211             callMalloc
 212             mtable <- liftIO $ getMethodTable objname
 213             mov (Disp 0, eax) mtable
 214             mov (Disp 4, eax) (0x1337babe :: Word32)
 215             return reip
 216       return $ Just (trapaddr, NewObject patcher)
 217
 218     emit' ATHROW = do
 219       trapaddr <- emitSigIllTrap 2
 220       let patcher resp reip = do
 221             (_, jnmap) <- liftIO $ getMethodEntry miThis
 222             error "no athrow for you, sorry"
 223             emitSigIllTrap 2
 224             return reip
 225       return $ Just (trapaddr, ThrowException 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 I2C = do
 283       pop eax
 284       and eax (0x000000ff :: Word32)
 285       push eax
 286     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 287     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 288     emit ACONST_NULL = push (0 :: Word32)
 289     emit (ICONST_M1) = push ((-1) :: Word32)
 290     emit (ICONST_0) = push (0 :: Word32)
 291     emit (ICONST_1) = push (1 :: Word32)
 292     emit (ICONST_2) = push (2 :: Word32)
 293     emit (ICONST_3) = push (3 :: Word32)
 294     emit (ICONST_4) = push (4 :: Word32)
 295     emit (ICONST_5) = push (5 :: Word32)
 296
 297     emit (ALOAD_ x) = emit (ILOAD_ x)
 298     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 299     emit (ALOAD x) = emit (ILOAD x)
 300     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 301
 302     emit (ASTORE_ x) = emit (ISTORE_ x)
 303     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 304     emit (ASTORE x) = emit (ISTORE x)
 305     emit (ISTORE x) = do
 306       pop eax
 307       mov (Disp (cArgs x), ebp) eax
 308
 309     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 310     emit (LDC2 x) = do
 311       value <- case constsPool cls M.! x of
 312                     (CString s) -> liftIO $ getUniqueStringAddr s
 313                     (CInteger i) -> liftIO $ return i
 314                     e -> error $ "LDCI... missing impl.: " ++ show e
 315       push value
 316
 317     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 318     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 319     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 320     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 321     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 322     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 323     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 324     emit INEG = do pop eax; neg eax; push eax
 325     emit (IINC x imm) =
 326       add (Disp (cArgs x), ebp) (s8_w32 imm)
 327
 328     emit (IFNONNULL x) = emit (IF C_NE x)
 329     emit (IFNULL x) = emit (IF C_EQ x)
 330     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 331     emit (IF_ICMP cond _) = do
 332       pop eax -- value2
 333       pop ebx -- value1
 334       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 335       emitIF cond
 336
 337     emit (IF cond _) = do
 338       pop eax -- value1
 339       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 340       emitIF cond
 341
 342     emit (GOTO _ ) = do
 343       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 344       jmp $ getLabel sid lmap
 345
 346     emit RETURN = do mov esp ebp; pop ebp; ret
 347     emit ARETURN = emit IRETURN
 348     emit IRETURN = do pop eax; emit RETURN
 349     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 350
 351     emitIF :: CMP -> CodeGen e s ()
 352     emitIF cond = let
 353       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 354       l = getLabel sid lmap
 355       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 356       l2 = getLabel sid2 lmap
 357       in do
 358         case cond of
 359           C_EQ -> je  l; C_NE -> jne l
 360           C_LT -> jl  l; C_GT -> jg  l
 361           C_GE -> jge l; C_LE -> jle l
 362         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 363         --  (it didn't work for gnu/classpath/SystemProperties.java)
 364         jmp l2
 365
 366     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 367     emitSigIllTrap traplen = do
 368       when (traplen < 2) (error "emitSigIllTrap: trap len too short")
 369       trapaddr <- getCurrentOffset
 370       -- 0xffff causes SIGILL
 371       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 372       -- fill rest up with NOPs
 373       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 374       return trapaddr
 375
 376
 377   -- for locals we use a different storage
 378   cArgs :: Word8 -> Word32
 379   cArgs x = ptrSize * (argcount - x' + isLocal)
 380     where
 381       x' = fromIntegral x
 382       argcount = rawArgCount method
 383       isLocal = if x' >= argcount then (-1) else 1
 384
 385   cArgs_ :: IMM -> Word8
 386   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 387
 388
 389   -- sign extension from w8 to w32 (over s8)
 390   --   unfortunately, hs-java is using Word8 everywhere (while
 391   --   it should be Int8 actually)
 392   s8_w32 :: Word8 -> Word32
 393   s8_w32 w8 = fromIntegral s8
 394     where s8 = fromIntegral w8 :: Int8
 395
 396 callMalloc :: CodeGen e s ()
 397 callMalloc = do
 398   call mallocObjectAddr
 399   add esp (ptrSize :: Word32)
 400   push eax
 401
 402
 403 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 404 -- however, this is bad for patching so we want to put always 32bit.
 405
 406 -- push imm32
 407 push32 :: Word32 -> CodeGen e s ()
 408 push32 imm32 = emit8 0x68 >> emit32 imm32
 409
 410 -- call disp32(%eax)
 411 call32Eax :: Disp -> CodeGen e s ()
 412 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 413
 414 -- push disp32(%eax)
 415 push32RelEax :: Disp -> CodeGen e s ()
 416 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 417
 418 -- mov %ebx, disp32(%eax)
 419 mov32RelEbxEax :: Disp -> CodeGen e s ()
 420 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32