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
  15 import Foreign hiding (xor)
  16 import Foreign.C.Types
  17
  18 import qualified JVM.Assembler as J
  19 import JVM.Assembler hiding (Instruction)
  20 import JVM.ClassFile
  21
  22 import Harpy
  23 import Harpy.X86Disassembler
  24
  25 import Mate.BasicBlocks
  26 import Mate.NativeSizes
  27 import Mate.Types
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30 import Mate.Strings
  31
  32
  33 foreign import ccall "&mallocObjectGC"
  34   mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
  35
  36 type EntryPoint = Ptr Word8
  37 type EntryPointOffset = Int
  38 type PatchInfo = (BlockID, EntryPointOffset)
  39
  40 type BBStarts = M.Map BlockID Int
  41
  42 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  43
  44
  45 emitFromBB :: Class Direct -> RawMethod -> CodeGen e s (CompileInfo, [Instruction])
  46 emitFromBB cls method = do
  47     let keys = M.keys hmap
  48     llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
  49     let lmap = zip keys llmap
  50     ep <- getEntryPoint
  51     push ebp
  52     mov ebp esp
  53     sub esp (fromIntegral (rawLocals method) * ptrSize :: Word32)
  54
  55     (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  56     d <- disassemble
  57     end <- getCodeOffset
  58     return ((ep, bbstarts, end, calls), d)
  59   where
  60   hmap = rawMapBB method
  61
  62   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  63   getLabel _ [] = error "label not found!"
  64   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  65
  66   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  67   efBB (bid, bb) calls bbstarts lmap =
  68     if M.member bid bbstarts then
  69       return (calls, bbstarts)
  70     else do
  71       bb_offset <- getCodeOffset
  72       let bbstarts' = M.insert bid bb_offset bbstarts
  73       defineLabel $ getLabel bid lmap
  74       cs <- mapM emit'' $ code bb
  75       let calls' = calls `M.union` M.fromList (catMaybes cs)
  76       case successor bb of
  77         Return -> return (calls', bbstarts')
  78         FallThrough t -> do
  79           -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
  80           jmp (getLabel t lmap)
  81           efBB (t, hmap M.! t) calls' bbstarts' lmap
  82         OneTarget t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
  83         TwoTarget t1 t2 -> do
  84           (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
  85           efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
  86     -- TODO(bernhard): also use metainformation
  87     -- TODO(bernhard): implement `emit' as function which accepts a list of
  88     --                 instructions, so we can use patterns for optimizations
  89     where
  90     forceRegDump :: CodeGen e s ()
  91     forceRegDump = do
  92       push esi
  93       mov esi (0x13371234 :: Word32)
  94       mov esi (Addr 0)
  95       pop esi
  96
  97     getCurrentOffset :: CodeGen e s Word32
  98     getCurrentOffset = do
  99       ep <- getEntryPoint
 100       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
 101       offset <- getCodeOffset
 102       return $ w32_ep + fromIntegral offset
 103
 104     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 105     emitInvoke cpidx hasThis = do
 106       let l = buildMethodID cls cpidx
 107       calladdr <- getCurrentOffset
 108       newNamedLabel (show l) >>= defineLabel
 109       -- causes SIGILL. in the signal handler we patch it to the acutal call.
 110       -- place two nop's at the end, therefore the disasm doesn't screw up
 111       emit32 (0x9090ffff :: Word32); nop
 112       -- discard arguments on stack
 113       let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount (methodNameTypeByIdx cls cpidx)) * ptrSize
 114       when (argcnt > 0) (add esp argcnt)
 115       -- push result on stack if method has a return value
 116       when (methodHaveReturnValue cls cpidx) (push eax)
 117       return $ Just (calladdr, StaticMethod l)
 118
 119     virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 120     virtualCall cpidx isInterface = do
 121       let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 122       newNamedLabel (show mi) >>= defineLabel
 123       -- get method offset for call @ runtime
 124       let offset = if isInterface
 125           then getInterfaceMethodOffset objname methodname (encode msig)
 126           else getMethodOffset objname (methodname `B.append` encode msig)
 127       let argsLen = genericLength args
 128       -- objref lives somewhere on the argument stack
 129       mov ebx (Disp (argsLen * ptrSize), esp)
 130       if isInterface
 131         then mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
 132         else return () -- invokevirtual
 133       -- get method-table-ptr (or interface-table-ptr)
 134       mov eax (Disp 0, ebx)
 135       -- make actual (indirect) call
 136       calladdr <- getCurrentOffset
 137       -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
 138       emit32 (0x9090ffff :: Word32); nop; nop
 139       -- discard arguments on stack (`+1' for "this")
 140       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
 141       when (argcnt > 0) (add esp argcnt)
 142       -- push result on stack if method has a return value
 143       when (methodHaveReturnValue cls cpidx) (push eax)
 144       -- note, that "mi" has the wrong class reference here.
 145       -- we figure that out at run-time, in the methodpool,
 146       -- depending on the method-table-ptr
 147       return $ Just (calladdr, VirtualCall isInterface mi offset)
 148
 149     emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 150     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 151
 152     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 153     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 154     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 155     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 156     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 157     emit' (PUTSTATIC cpidx) = do
 158       pop eax
 159       trapaddr <- getCurrentOffset
 160       mov (Addr 0x00000000) eax -- it's a trap
 161       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 162     emit' (GETSTATIC cpidx) = do
 163       trapaddr <- getCurrentOffset
 164       mov eax (Addr 0x00000000) -- it's a trap
 165       push eax
 166       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 167     emit' (INSTANCEOF cpidx) = do
 168       pop eax
 169       mov eax (Disp 0, eax) -- mtable of objectref
 170       trapaddr <- getCurrentOffset
 171       -- place something like `mov edx $mtable_of_objref' instead
 172       emit32 (0x9090ffff :: Word32); nop
 173       cmp eax edx
 174       sete al
 175       movzxb eax al
 176       push eax
 177       forceRegDump
 178       return $ Just (trapaddr, InstanceOf $ buildClassID cls cpidx)
 179     emit' (NEW objidx) = do
 180       let objname = buildClassID cls objidx
 181       trapaddr <- getCurrentOffset
 182       -- place something like `push $objsize' instead
 183       emit32 (0x9090ffff :: Word32); nop
 184       callMalloc
 185       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 186       mov (Disp 0, eax) (0x13371337 :: Word32)
 187       return $ Just (trapaddr, NewObject objname)
 188
 189     emit' insn = emit insn >> return Nothing
 190
 191     emit :: J.Instruction -> CodeGen e s ()
 192     emit POP = add esp (ptrSize :: Word32) -- drop value
 193     emit DUP = push (Disp 0, esp)
 194     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 195     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 196     emit AASTORE = emit IASTORE
 197     emit IASTORE = do
 198       pop eax -- value
 199       pop ebx -- offset
 200       add ebx (1 :: Word32)
 201       pop ecx -- aref
 202       mov (ecx, ebx, S4) eax
 203     emit CASTORE = do
 204       pop eax -- value
 205       pop ebx -- offset
 206       add ebx (1 :: Word32)
 207       pop ecx -- aref
 208       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 209     emit AALOAD = emit IALOAD
 210     emit IALOAD = do
 211       pop ebx -- offset
 212       add ebx (1 :: Word32)
 213       pop ecx -- aref
 214       push (ecx, ebx, S4)
 215     emit CALOAD = do
 216       pop ebx -- offset
 217       add ebx (1 :: Word32)
 218       pop ecx -- aref
 219       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 220     emit ARRAYLENGTH = do
 221       pop eax
 222       push (Disp 0, eax)
 223     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 224     emit (NEWARRAY typ) = do
 225       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 226                   T_INT -> 4
 227                   T_CHAR -> 2
 228                   _ -> error "newarray: type not implemented yet"
 229       -- get length from stack, but leave it there
 230       mov eax (Disp 0, esp)
 231       mov ebx (tsize :: Word32)
 232       -- multiple amount with native size of one element
 233       mul ebx -- result is in eax
 234       add eax (ptrSize :: Word32) -- for "length" entry
 235       -- push amount of bytes to allocate
 236       push eax
 237       callMalloc
 238       pop eax -- ref to arraymemory
 239       pop ebx -- length
 240       mov (Disp 0, eax) ebx -- store length at offset 0
 241       push eax -- push ref again
 242
 243     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 244     emit ATHROW = -- TODO(bernhard): ...
 245         emit32 (0xffffffff :: Word32)
 246     emit I2C = do
 247       pop eax
 248       and eax (0x000000ff :: Word32)
 249       push eax
 250     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 251     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 252     emit ACONST_NULL = push (0 :: Word32)
 253     emit (ICONST_M1) = push ((-1) :: Word32)
 254     emit (ICONST_0) = push (0 :: Word32)
 255     emit (ICONST_1) = push (1 :: Word32)
 256     emit (ICONST_2) = push (2 :: Word32)
 257     emit (ICONST_3) = push (3 :: Word32)
 258     emit (ICONST_4) = push (4 :: Word32)
 259     emit (ICONST_5) = push (5 :: Word32)
 260
 261     emit (ALOAD_ x) = emit (ILOAD_ x)
 262     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 263     emit (ALOAD x) = emit (ILOAD x)
 264     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 265
 266     emit (ASTORE_ x) = emit (ISTORE_ x)
 267     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 268     emit (ASTORE x) = emit (ISTORE x)
 269     emit (ISTORE x) = do
 270       pop eax
 271       mov (Disp (cArgs x), ebp) eax
 272
 273     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 274     emit (LDC2 x) = do
 275       value <- case constsPool cls M.! x of
 276                     (CString s) -> liftIO $ getUniqueStringAddr s
 277                     (CInteger i) -> liftIO $ return i
 278                     e -> error $ "LDCI... missing impl.: " ++ show e
 279       push value
 280     emit (GETFIELD x) = do
 281       offset <- emitFieldOffset x
 282       push (Disp (fromIntegral offset), eax) -- get field
 283     emit (PUTFIELD x) = do
 284       pop ebx -- value to write
 285       offset <- emitFieldOffset x
 286       mov (Disp (fromIntegral offset), eax) ebx -- set field
 287
 288     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 289     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 290     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 291     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 292     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 293     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 294     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 295     emit INEG = do pop eax; neg eax; push eax
 296     emit (IINC x imm) =
 297       add (Disp (cArgs x), ebp) (s8_w32 imm)
 298
 299     emit (IFNONNULL x) = emit (IF C_NE x)
 300     emit (IFNULL x) = emit (IF C_EQ x)
 301     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 302     emit (IF_ICMP cond _) = do
 303       pop eax -- value2
 304       pop ebx -- value1
 305       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 306       emitIF cond
 307
 308     emit (IF cond _) = do
 309       pop eax -- value1
 310       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 311       emitIF cond
 312
 313     emit (GOTO _ ) = do
 314       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 315       jmp $ getLabel sid lmap
 316
 317     emit RETURN = do mov esp ebp; pop ebp; ret
 318     emit ARETURN = emit IRETURN
 319     emit IRETURN = do pop eax; emit RETURN
 320     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 321
 322     -- TODO(bernhard): delay to runtime (find counter example!)
 323     emitFieldOffset :: Word16 -> CodeGen e s Int32
 324     emitFieldOffset x = do
 325       pop eax -- this pointer
 326       let (cname, fname) = buildFieldOffset cls x
 327       liftIO $ getFieldOffset cname fname
 328
 329     emitIF :: CMP -> CodeGen e s ()
 330     emitIF cond = let
 331       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 332       l = getLabel sid lmap
 333       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 334       l2 = getLabel sid2 lmap
 335       in do
 336         case cond of
 337           C_EQ -> je  l; C_NE -> jne l
 338           C_LT -> jl  l; C_GT -> jg  l
 339           C_GE -> jge l; C_LE -> jle l
 340         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 341         --  (it didn't work for gnu/classpath/SystemProperties.java)
 342         jmp l2
 343
 344
 345   -- for locals we use a different storage
 346   cArgs :: Word8 -> Word32
 347   cArgs x = ptrSize * (argcount - x' + isLocal)
 348     where
 349       x' = fromIntegral x
 350       argcount = rawArgCount method
 351       isLocal = if x' >= argcount then (-1) else 1
 352
 353   cArgs_ :: IMM -> Word8
 354   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 355
 356
 357   -- sign extension from w8 to w32 (over s8)
 358   --   unfortunately, hs-java is using Word8 everywhere (while
 359   --   it should be Int8 actually)
 360   s8_w32 :: Word8 -> Word32
 361   s8_w32 w8 = fromIntegral s8
 362     where s8 = fromIntegral w8 :: Int8
 363
 364 callMalloc :: CodeGen e s ()
 365 callMalloc = do
 366   call mallocObjectAddr
 367   add esp (ptrSize :: Word32)
 368   push eax
 369
 370 -- the regular push implementation, considers the provided immediate and selects
 371 -- a different instruction if it fits in 8bit. but this is not useful for
 372 -- patching.
 373 push32 :: Word32 -> CodeGen e s ()
 374 push32 imm32 = emit8 0x68 >> emit32 imm32
 375
 376 call32_eax :: Disp -> CodeGen e s ()
 377 call32_eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32