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