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 -> RawMethod -> CodeGen e JpcNpcMap (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     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             error "no athrow for you, sorry"
 222             emitSigIllTrap 2
 223             return reip
 224       return $ Just (trapaddr, ThrowException patcher)
 225
 226     emit' insn = emit insn >> return Nothing
 227
 228     emit :: J.Instruction -> CodeGen e s ()
 229     emit POP = add esp (ptrSize :: Word32) -- drop value
 230     emit DUP = push (Disp 0, esp)
 231     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 232     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 233     emit AASTORE = emit IASTORE
 234     emit IASTORE = do
 235       pop eax -- value
 236       pop ebx -- offset
 237       add ebx (1 :: Word32)
 238       pop ecx -- aref
 239       mov (ecx, ebx, S4) eax
 240     emit CASTORE = do
 241       pop eax -- value
 242       pop ebx -- offset
 243       add ebx (1 :: Word32)
 244       pop ecx -- aref
 245       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 246     emit AALOAD = emit IALOAD
 247     emit IALOAD = do
 248       pop ebx -- offset
 249       add ebx (1 :: Word32)
 250       pop ecx -- aref
 251       push (ecx, ebx, S4)
 252     emit CALOAD = do
 253       pop ebx -- offset
 254       add ebx (1 :: Word32)
 255       pop ecx -- aref
 256       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 257     emit ARRAYLENGTH = do
 258       pop eax
 259       push (Disp 0, eax)
 260     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 261     emit (NEWARRAY typ) = do
 262       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 263                   T_INT -> 4
 264                   T_CHAR -> 2
 265                   _ -> error "newarray: type not implemented yet"
 266       -- get length from stack, but leave it there
 267       mov eax (Disp 0, esp)
 268       mov ebx (tsize :: Word32)
 269       -- multiple amount with native size of one element
 270       mul ebx -- result is in eax
 271       add eax (ptrSize :: Word32) -- for "length" entry
 272       -- push amount of bytes to allocate
 273       push eax
 274       callMalloc
 275       pop eax -- ref to arraymemory
 276       pop ebx -- length
 277       mov (Disp 0, eax) ebx -- store length at offset 0
 278       push eax -- push ref again
 279
 280     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 281     emit I2C = do
 282       pop eax
 283       and eax (0x000000ff :: Word32)
 284       push eax
 285     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 286     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 287     emit ACONST_NULL = push (0 :: Word32)
 288     emit (ICONST_M1) = push ((-1) :: Word32)
 289     emit (ICONST_0) = push (0 :: Word32)
 290     emit (ICONST_1) = push (1 :: Word32)
 291     emit (ICONST_2) = push (2 :: Word32)
 292     emit (ICONST_3) = push (3 :: Word32)
 293     emit (ICONST_4) = push (4 :: Word32)
 294     emit (ICONST_5) = push (5 :: Word32)
 295
 296     emit (ALOAD_ x) = emit (ILOAD_ x)
 297     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 298     emit (ALOAD x) = emit (ILOAD x)
 299     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 300
 301     emit (ASTORE_ x) = emit (ISTORE_ x)
 302     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 303     emit (ASTORE x) = emit (ISTORE x)
 304     emit (ISTORE x) = do
 305       pop eax
 306       mov (Disp (cArgs x), ebp) eax
 307
 308     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 309     emit (LDC2 x) = do
 310       value <- case constsPool cls M.! x of
 311                     (CString s) -> liftIO $ getUniqueStringAddr s
 312                     (CInteger i) -> liftIO $ return i
 313                     e -> error $ "LDCI... missing impl.: " ++ show e
 314       push value
 315
 316     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 317     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 318     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 319     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 320     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 321     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 322     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 323     emit INEG = do pop eax; neg eax; push eax
 324     emit (IINC x imm) =
 325       add (Disp (cArgs x), ebp) (s8_w32 imm)
 326
 327     emit (IFNONNULL x) = emit (IF C_NE x)
 328     emit (IFNULL x) = emit (IF C_EQ x)
 329     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 330     emit (IF_ICMP cond _) = do
 331       pop eax -- value2
 332       pop ebx -- value1
 333       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 334       emitIF cond
 335
 336     emit (IF cond _) = do
 337       pop eax -- value1
 338       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 339       emitIF cond
 340
 341     emit (GOTO _ ) = do
 342       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 343       jmp $ getLabel sid lmap
 344
 345     emit RETURN = do mov esp ebp; pop ebp; ret
 346     emit ARETURN = emit IRETURN
 347     emit IRETURN = do pop eax; emit RETURN
 348     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 349
 350     emitIF :: CMP -> CodeGen e s ()
 351     emitIF cond = let
 352       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 353       l = getLabel sid lmap
 354       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 355       l2 = getLabel sid2 lmap
 356       in do
 357         case cond of
 358           C_EQ -> je  l; C_NE -> jne l
 359           C_LT -> jl  l; C_GT -> jg  l
 360           C_GE -> jge l; C_LE -> jle l
 361         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 362         --  (it didn't work for gnu/classpath/SystemProperties.java)
 363         jmp l2
 364
 365     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 366     emitSigIllTrap traplen = do
 367       when (traplen < 2) (error "emitSigIllTrap: trap len too short")
 368       trapaddr <- getCurrentOffset
 369       -- 0xffff causes SIGILL
 370       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 371       -- fill rest up with NOPs
 372       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 373       return trapaddr
 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 call32Eax :: Disp -> CodeGen e s ()
 411 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 412
 413 -- push disp32(%eax)
 414 push32RelEax :: Disp -> CodeGen e s ()
 415 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 416
 417 -- mov %ebx, disp32(%eax)
 418 mov32RelEbxEax :: Disp -> CodeGen e s ()
 419 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32