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       mov eax (Disp 0, eax) -- mtable of objectref
 203       trapaddr <- getCurrentOffset
 204       -- place something like `mov edx $mtable_of_objref' instead
 205       emit32 (0x9090ffff :: Word32); nop
 206       push (0 :: Word32)
 207       let patcher reax reip = do
 208             -- mtable <- liftIO $ getMethodTable (buildClassID cls cpidx)
 209             -- mov edx mtable
 210             emit32 (0x9090ffff :: Word32); nop
 211             let classname = buildClassID cls cpidx
 212             check <- liftIO $ isInstanceOf (fromIntegral reax) classname
 213             if check
 214               then push (1 :: Word32)
 215               else push (0 :: Word32)
 216             return (reip + 5)
 217       -- cmp eax edx
 218       -- sete al
 219       -- movzxb eax al
 220       -- push eax
 221       -- forceRegDump
 222       return $ Just (trapaddr, InstanceOf patcher)
 223     emit' (NEW objidx) = do
 224       let objname = buildClassID cls objidx
 225       trapaddr <- getCurrentOffset
 226       -- place something like `push $objsize' instead
 227       emit32 (0x9090ffff :: Word32); nop
 228       callMalloc
 229       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 230       mov (Disp 0, eax) (0x13371337 :: Word32)
 231       mov (Disp 4, eax) (0x1337babe :: Word32)
 232       let patcher reip = do
 233             objsize <- liftIO $ getObjectSize objname
 234             push32 objsize
 235             callMalloc
 236             mtable <- liftIO $ getMethodTable objname
 237             mov (Disp 0, eax) mtable
 238             mov (Disp 4, eax) (0x1337babe :: Word32)
 239             return reip
 240       return $ Just (trapaddr, NewObject patcher)
 241
 242     emit' insn = emit insn >> return Nothing
 243
 244     emit :: J.Instruction -> CodeGen e s ()
 245     emit POP = add esp (ptrSize :: Word32) -- drop value
 246     emit DUP = push (Disp 0, esp)
 247     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 248     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 249     emit AASTORE = emit IASTORE
 250     emit IASTORE = do
 251       pop eax -- value
 252       pop ebx -- offset
 253       add ebx (1 :: Word32)
 254       pop ecx -- aref
 255       mov (ecx, ebx, S4) eax
 256     emit CASTORE = do
 257       pop eax -- value
 258       pop ebx -- offset
 259       add ebx (1 :: Word32)
 260       pop ecx -- aref
 261       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 262     emit AALOAD = emit IALOAD
 263     emit IALOAD = do
 264       pop ebx -- offset
 265       add ebx (1 :: Word32)
 266       pop ecx -- aref
 267       push (ecx, ebx, S4)
 268     emit CALOAD = do
 269       pop ebx -- offset
 270       add ebx (1 :: Word32)
 271       pop ecx -- aref
 272       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 273     emit ARRAYLENGTH = do
 274       pop eax
 275       push (Disp 0, eax)
 276     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 277     emit (NEWARRAY typ) = do
 278       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 279                   T_INT -> 4
 280                   T_CHAR -> 2
 281                   _ -> error "newarray: type not implemented yet"
 282       -- get length from stack, but leave it there
 283       mov eax (Disp 0, esp)
 284       mov ebx (tsize :: Word32)
 285       -- multiple amount with native size of one element
 286       mul ebx -- result is in eax
 287       add eax (ptrSize :: Word32) -- for "length" entry
 288       -- push amount of bytes to allocate
 289       push eax
 290       callMalloc
 291       pop eax -- ref to arraymemory
 292       pop ebx -- length
 293       mov (Disp 0, eax) ebx -- store length at offset 0
 294       push eax -- push ref again
 295
 296     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 297     emit ATHROW = -- TODO(bernhard): ...
 298         emit32 (0xffffffff :: Word32)
 299     emit I2C = do
 300       pop eax
 301       and eax (0x000000ff :: Word32)
 302       push eax
 303     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 304     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 305     emit ACONST_NULL = push (0 :: Word32)
 306     emit (ICONST_M1) = push ((-1) :: Word32)
 307     emit (ICONST_0) = push (0 :: Word32)
 308     emit (ICONST_1) = push (1 :: Word32)
 309     emit (ICONST_2) = push (2 :: Word32)
 310     emit (ICONST_3) = push (3 :: Word32)
 311     emit (ICONST_4) = push (4 :: Word32)
 312     emit (ICONST_5) = push (5 :: Word32)
 313
 314     emit (ALOAD_ x) = emit (ILOAD_ x)
 315     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 316     emit (ALOAD x) = emit (ILOAD x)
 317     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 318
 319     emit (ASTORE_ x) = emit (ISTORE_ x)
 320     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 321     emit (ASTORE x) = emit (ISTORE x)
 322     emit (ISTORE x) = do
 323       pop eax
 324       mov (Disp (cArgs x), ebp) eax
 325
 326     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 327     emit (LDC2 x) = do
 328       value <- case constsPool cls M.! x of
 329                     (CString s) -> liftIO $ getUniqueStringAddr s
 330                     (CInteger i) -> liftIO $ return i
 331                     e -> error $ "LDCI... missing impl.: " ++ show e
 332       push value
 333
 334     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 335     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 336     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 337     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 338     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 339     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 340     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 341     emit INEG = do pop eax; neg eax; push eax
 342     emit (IINC x imm) =
 343       add (Disp (cArgs x), ebp) (s8_w32 imm)
 344
 345     emit (IFNONNULL x) = emit (IF C_NE x)
 346     emit (IFNULL x) = emit (IF C_EQ x)
 347     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 348     emit (IF_ICMP cond _) = do
 349       pop eax -- value2
 350       pop ebx -- value1
 351       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 352       emitIF cond
 353
 354     emit (IF cond _) = do
 355       pop eax -- value1
 356       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 357       emitIF cond
 358
 359     emit (GOTO _ ) = do
 360       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 361       jmp $ getLabel sid lmap
 362
 363     emit RETURN = do mov esp ebp; pop ebp; ret
 364     emit ARETURN = emit IRETURN
 365     emit IRETURN = do pop eax; emit RETURN
 366     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 367
 368     emitIF :: CMP -> CodeGen e s ()
 369     emitIF cond = let
 370       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 371       l = getLabel sid lmap
 372       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 373       l2 = getLabel sid2 lmap
 374       in do
 375         case cond of
 376           C_EQ -> je  l; C_NE -> jne l
 377           C_LT -> jl  l; C_GT -> jg  l
 378           C_GE -> jge l; C_LE -> jle l
 379         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 380         --  (it didn't work for gnu/classpath/SystemProperties.java)
 381         jmp l2
 382
 383
 384   -- for locals we use a different storage
 385   cArgs :: Word8 -> Word32
 386   cArgs x = ptrSize * (argcount - x' + isLocal)
 387     where
 388       x' = fromIntegral x
 389       argcount = rawArgCount method
 390       isLocal = if x' >= argcount then (-1) else 1
 391
 392   cArgs_ :: IMM -> Word8
 393   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 394
 395
 396   -- sign extension from w8 to w32 (over s8)
 397   --   unfortunately, hs-java is using Word8 everywhere (while
 398   --   it should be Int8 actually)
 399   s8_w32 :: Word8 -> Word32
 400   s8_w32 w8 = fromIntegral s8
 401     where s8 = fromIntegral w8 :: Int8
 402
 403 callMalloc :: CodeGen e s ()
 404 callMalloc = do
 405   call mallocObjectAddr
 406   add esp (ptrSize :: Word32)
 407   push eax
 408
 409
 410 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 411 -- however, this is bad for patching so we want to put always 32bit.
 412
 413 -- push imm32
 414 push32 :: Word32 -> CodeGen e s ()
 415 push32 imm32 = emit8 0x68 >> emit32 imm32
 416
 417 -- call disp32(%eax)
 418 call32_eax :: Disp -> CodeGen e s ()
 419 call32_eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 420
 421 -- push disp32(%eax)
 422 push32_rel_eax :: Disp -> CodeGen e s ()
 423 push32_rel_eax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 424
 425 -- mov %ebx, disp32(%eax)
 426 mov32_rel_ebx_eax :: Disp -> CodeGen e s ()
 427 mov32_rel_ebx_eax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32