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