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 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     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 s [(Maybe (Word32, TrapCause))]
  69   efBB lmap bid = do
  70     defineLabel $ getLabel bid lmap
  71     ret <- 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 ret
  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 s (Maybe (Word32, TrapCause))
 141     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 142
 143     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 144     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 145     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 146     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 147     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 148
 149     emit' (PUTSTATIC cpidx) = do
 150       pop eax
 151       trapaddr <- getCurrentOffset
 152       mov (Addr 0x00000000) eax -- it's a trap
 153       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 154     emit' (GETSTATIC cpidx) = do
 155       trapaddr <- getCurrentOffset
 156       mov eax (Addr 0x00000000) -- it's a trap
 157       push eax
 158       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 159
 160     emit' (GETFIELD x) = do
 161       pop eax -- this pointer
 162       -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
 163       trapaddr <- emitSigIllTrap 6
 164       let patcher reip = do
 165             let (cname, fname) = buildFieldOffset cls x
 166             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 167             push32RelEax (Disp offset) -- get field
 168             return reip
 169       return $ Just (trapaddr, ObjectField patcher)
 170     emit' (PUTFIELD x) = do
 171       pop ebx -- value to write
 172       pop eax -- this pointer
 173       -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
 174       trapaddr <- emitSigIllTrap 6
 175       let patcher reip = do
 176             let (cname, fname) = buildFieldOffset cls x
 177             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 178             mov32RelEbxEax (Disp offset) -- set field
 179             return reip
 180       return $ Just (trapaddr, ObjectField patcher)
 181
 182     emit' (INSTANCEOF cpidx) = do
 183       pop eax
 184       -- place something like `mov edx $mtable_of_objref' instead
 185       trapaddr <- emitSigIllTrap 4
 186       push (0 :: Word32)
 187       let patcher reax reip = do
 188             emitSigIllTrap 4
 189             let classname = buildClassID cls cpidx
 190             check <- liftIO $ isInstanceOf (fromIntegral reax) classname
 191             if check
 192               then push (1 :: Word32)
 193               else push (0 :: Word32)
 194             return (reip + 4)
 195       return $ Just (trapaddr, InstanceOf patcher)
 196     emit' (NEW objidx) = do
 197       let objname = buildClassID cls objidx
 198       -- place something like `push $objsize' instead
 199       trapaddr <- emitSigIllTrap 5
 200       callMalloc
 201       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 202       mov (Disp 0, eax) (0x13371337 :: Word32)
 203       mov (Disp 4, eax) (0x1337babe :: Word32)
 204       let patcher reip = do
 205             objsize <- liftIO $ getObjectSize objname
 206             push32 objsize
 207             callMalloc
 208             mtable <- liftIO $ getMethodTable objname
 209             mov (Disp 0, eax) mtable
 210             mov (Disp 4, eax) (0x1337babe :: Word32)
 211             return reip
 212       return $ Just (trapaddr, NewObject patcher)
 213
 214     emit' ATHROW = do
 215       trapaddr <- emitSigIllTrap 2
 216       let patcher resp reip = do
 217             error "no athrow for you, sorry"
 218             emitSigIllTrap 2
 219             return reip
 220       return $ Just (trapaddr, ThrowException patcher)
 221
 222     emit' insn = emit insn >> return Nothing
 223
 224     emit :: J.Instruction -> CodeGen e s ()
 225     emit POP = add esp (ptrSize :: Word32) -- drop value
 226     emit DUP = push (Disp 0, esp)
 227     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 228     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 229     emit AASTORE = emit IASTORE
 230     emit IASTORE = do
 231       pop eax -- value
 232       pop ebx -- offset
 233       add ebx (1 :: Word32)
 234       pop ecx -- aref
 235       mov (ecx, ebx, S4) eax
 236     emit CASTORE = do
 237       pop eax -- value
 238       pop ebx -- offset
 239       add ebx (1 :: Word32)
 240       pop ecx -- aref
 241       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 242     emit AALOAD = emit IALOAD
 243     emit IALOAD = do
 244       pop ebx -- offset
 245       add ebx (1 :: Word32)
 246       pop ecx -- aref
 247       push (ecx, ebx, S4)
 248     emit CALOAD = do
 249       pop ebx -- offset
 250       add ebx (1 :: Word32)
 251       pop ecx -- aref
 252       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 253     emit ARRAYLENGTH = do
 254       pop eax
 255       push (Disp 0, eax)
 256     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 257     emit (NEWARRAY typ) = do
 258       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 259                   T_INT -> 4
 260                   T_CHAR -> 2
 261                   _ -> error "newarray: type not implemented yet"
 262       -- get length from stack, but leave it there
 263       mov eax (Disp 0, esp)
 264       mov ebx (tsize :: Word32)
 265       -- multiple amount with native size of one element
 266       mul ebx -- result is in eax
 267       add eax (ptrSize :: Word32) -- for "length" entry
 268       -- push amount of bytes to allocate
 269       push eax
 270       callMalloc
 271       pop eax -- ref to arraymemory
 272       pop ebx -- length
 273       mov (Disp 0, eax) ebx -- store length at offset 0
 274       push eax -- push ref again
 275
 276     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 277     emit I2C = do
 278       pop eax
 279       and eax (0x000000ff :: Word32)
 280       push eax
 281     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 282     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 283     emit ACONST_NULL = push (0 :: Word32)
 284     emit (ICONST_M1) = push ((-1) :: Word32)
 285     emit (ICONST_0) = push (0 :: Word32)
 286     emit (ICONST_1) = push (1 :: Word32)
 287     emit (ICONST_2) = push (2 :: Word32)
 288     emit (ICONST_3) = push (3 :: Word32)
 289     emit (ICONST_4) = push (4 :: Word32)
 290     emit (ICONST_5) = push (5 :: Word32)
 291
 292     emit (ALOAD_ x) = emit (ILOAD_ x)
 293     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 294     emit (ALOAD x) = emit (ILOAD x)
 295     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 296
 297     emit (ASTORE_ x) = emit (ISTORE_ x)
 298     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 299     emit (ASTORE x) = emit (ISTORE x)
 300     emit (ISTORE x) = do
 301       pop eax
 302       mov (Disp (cArgs x), ebp) eax
 303
 304     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 305     emit (LDC2 x) = do
 306       value <- case constsPool cls M.! x of
 307                     (CString s) -> liftIO $ getUniqueStringAddr s
 308                     (CInteger i) -> liftIO $ return i
 309                     e -> error $ "LDCI... missing impl.: " ++ show e
 310       push value
 311
 312     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 313     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 314     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 315     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 316     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 317     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 318     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 319     emit INEG = do pop eax; neg eax; push eax
 320     emit (IINC x imm) =
 321       add (Disp (cArgs x), ebp) (s8_w32 imm)
 322
 323     emit (IFNONNULL x) = emit (IF C_NE x)
 324     emit (IFNULL x) = emit (IF C_EQ x)
 325     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 326     emit (IF_ICMP cond _) = do
 327       pop eax -- value2
 328       pop ebx -- value1
 329       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 330       emitIF cond
 331
 332     emit (IF cond _) = do
 333       pop eax -- value1
 334       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 335       emitIF cond
 336
 337     emit (GOTO _ ) = do
 338       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 339       jmp $ getLabel sid lmap
 340
 341     emit RETURN = do mov esp ebp; pop ebp; ret
 342     emit ARETURN = emit IRETURN
 343     emit IRETURN = do pop eax; emit RETURN
 344     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 345
 346     emitIF :: CMP -> CodeGen e s ()
 347     emitIF cond = let
 348       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 349       l = getLabel sid lmap
 350       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 351       l2 = getLabel sid2 lmap
 352       in do
 353         case cond of
 354           C_EQ -> je  l; C_NE -> jne l
 355           C_LT -> jl  l; C_GT -> jg  l
 356           C_GE -> jge l; C_LE -> jle l
 357         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 358         --  (it didn't work for gnu/classpath/SystemProperties.java)
 359         jmp l2
 360
 361     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 362     emitSigIllTrap traplen = do
 363       when (traplen < 2) (error "emitSigIllTrap: trap len too short")
 364       trapaddr <- getCurrentOffset
 365       -- 0xffff causes SIGILL
 366       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 367       -- fill rest up with NOPs
 368       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 369       return trapaddr
 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 call32Eax :: Disp -> CodeGen e s ()
 407 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 408
 409 -- push disp32(%eax)
 410 push32RelEax :: Disp -> CodeGen e s ()
 411 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 412
 413 -- mov %ebx, disp32(%eax)
 414 mov32RelEbxEax :: Disp -> CodeGen e s ()
 415 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32