Mate/X86CodeGen.hs

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