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.Types
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30 import Mate.Strings
  31 #ifdef DEBUG
  32 import Text.Printf
  33 #endif
  34
  35
  36 foreign import ccall "&mallocObject"
  37   mallocObjectAddr :: FunPtr (Int -> IO CUInt)
  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) * 4) :: 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     getCurrentOffset :: CodeGen e s Word32
  94     getCurrentOffset = do
  95       ep <- getEntryPoint
  96       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
  97       offset <- getCodeOffset
  98       return $ w32_ep + fromIntegral offset
  99
 100     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 101     emitInvoke cpidx hasThis = do
 102       let l = buildMethodID cls cpidx
 103       calladdr <- getCurrentOffset
 104       newNamedLabel (show l) >>= defineLabel
 105       -- causes SIGILL. in the signal handler we patch it to the acutal call.
 106       -- place a nop at the end, therefore the disasm doesn't screw up
 107       emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 108       -- discard arguments on stack
 109       let argcnt = ((if hasThis then 1 else 0) + (methodGetArgsCount $ methodNameTypeByIdx cls cpidx)) * 4
 110       when (argcnt > 0) (add esp argcnt)
 111       -- push result on stack if method has a return value
 112       when (methodHaveReturnValue cls cpidx) (push eax)
 113       -- +2 is for correcting eip in trap context
 114       return $ Just (calladdr + 2, 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 (+4 for "this")
 122       let argcnt = 4 + 4 * (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 ((*4) $ 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 ((*4) $ 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' insn = emit insn >> return Nothing
 177
 178     emit :: J.Instruction -> CodeGen e s ()
 179     emit POP = add esp (4 :: Word32) -- drop value
 180     emit DUP = push (Disp 0, esp)
 181     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 182     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 183     emit AASTORE = emit IASTORE
 184     emit IASTORE = do
 185       pop eax -- value
 186       pop ebx -- offset
 187       add ebx (1 :: Word32)
 188       pop ecx -- aref
 189       mov (ecx, ebx, S4) eax
 190     emit CASTORE = do
 191       pop eax -- value
 192       pop ebx -- offset
 193       add ebx (1 :: Word32)
 194       pop ecx -- aref
 195       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 196     emit AALOAD = emit IALOAD
 197     emit IALOAD = do
 198       pop ebx -- offset
 199       add ebx (1 :: Word32)
 200       pop ecx -- aref
 201       push (ecx, ebx, S4)
 202     emit CALOAD = do
 203       pop ebx -- offset
 204       add ebx (1 :: Word32)
 205       pop ecx -- aref
 206       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 207     emit ARRAYLENGTH = do
 208       pop eax
 209       push (Disp 0, eax)
 210     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 211     emit (NEWARRAY typ) = do
 212       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 213                   T_INT -> 4
 214                   T_CHAR -> 2
 215                   _ -> error "newarray: type not implemented yet"
 216       -- get length from stack, but leave it there
 217       mov eax (Disp 0, esp)
 218       mov ebx (tsize :: Word32)
 219       -- multiple amount with native size of one element
 220       mul ebx -- result is in eax
 221       add eax (4 :: Word32) -- for "length" entry
 222       -- push amount of bytes to allocate
 223       push eax
 224       callMalloc
 225       pop eax -- ref to arraymemory
 226       pop ebx -- length
 227       mov (Disp 0, eax) ebx -- store length at offset 0
 228       push eax -- push ref again
 229     emit (NEW objidx) = do
 230       let objname = buildClassID cls objidx
 231       amount <- liftIO $ getObjectSize objname
 232       push (amount :: Word32)
 233       callMalloc
 234       -- TODO(bernhard): save reference somewhere for GC
 235       -- set method table pointer
 236       mtable <- liftIO $ getMethodTable objname
 237       mov (Disp 0, eax) mtable
 238     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 239     -- TODO(bernhard): ...
 240     emit (INSTANCEOF _) = do
 241       pop eax
 242       push (1 :: Word32)
 243     emit ATHROW = -- TODO(bernhard): ...
 244         emit32 (0xffffffff :: Word32)
 245     emit I2C = do
 246       pop eax
 247       and eax (0x000000ff :: Word32)
 248       push eax
 249     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 250     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 251     emit ACONST_NULL = push (0 :: Word32)
 252     emit (ICONST_M1) = push ((-1) :: Word32)
 253     emit (ICONST_0) = push (0 :: Word32)
 254     emit (ICONST_1) = push (1 :: Word32)
 255     emit (ICONST_2) = push (2 :: Word32)
 256     emit (ICONST_3) = push (3 :: Word32)
 257     emit (ICONST_4) = push (4 :: Word32)
 258     emit (ICONST_5) = push (5 :: Word32)
 259
 260     emit (ALOAD_ x) = emit (ILOAD_ x)
 261     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 262     emit (ALOAD x) = emit (ILOAD x)
 263     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 264
 265     emit (ASTORE_ x) = emit (ISTORE_ x)
 266     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 267     emit (ASTORE x) = emit (ISTORE x)
 268     emit (ISTORE x) = do
 269       pop eax
 270       mov (Disp (cArgs x), ebp) eax
 271
 272     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 273     emit (LDC2 x) = do
 274       value <- case constsPool cls M.! x of
 275                     (CString s) -> liftIO $ getUniqueStringAddr s
 276                     (CInteger i) -> liftIO $ return i
 277                     e -> error $ "LDCI... missing impl.: " ++ show e
 278       push value
 279     emit (GETFIELD x) = do
 280       offset <- emitFieldOffset x
 281       push (Disp (fromIntegral offset), eax) -- get field
 282     emit (PUTFIELD x) = do
 283       pop ebx -- value to write
 284       offset <- emitFieldOffset x
 285       mov (Disp (fromIntegral offset), eax) ebx -- set field
 286
 287     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 288     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 289     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 290     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 291     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 292     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 293     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 294     emit INEG = do pop eax; neg eax; push eax
 295     emit (IINC x imm) =
 296       add (Disp (cArgs x), ebp) (s8_w32 imm)
 297
 298     emit (IFNONNULL x) = emit (IF C_NE x)
 299     emit (IFNULL x) = emit (IF C_EQ x)
 300     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 301     emit (IF_ICMP cond _) = do
 302       pop eax -- value2
 303       pop ebx -- value1
 304       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 305       emitIF cond
 306
 307     emit (IF cond _) = do
 308       pop eax -- value1
 309       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 310       emitIF cond
 311
 312     emit (GOTO _ ) = do
 313       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 314       jmp $ getLabel sid lmap
 315
 316     emit RETURN = do mov esp ebp; pop ebp; ret
 317     emit ARETURN = emit IRETURN
 318     emit IRETURN = do pop eax; emit RETURN
 319     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 320
 321     emitFieldOffset :: Word16 -> CodeGen e s Int32
 322     emitFieldOffset x = do
 323       pop eax -- this pointer
 324       let (cname, fname) = buildFieldOffset cls x
 325       liftIO $ getFieldOffset cname fname
 326
 327     emitIF :: CMP -> CodeGen e s ()
 328     emitIF cond = let
 329       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 330       l = getLabel sid lmap
 331       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 332       l2 = getLabel sid2 lmap
 333       in do
 334         case cond of
 335           C_EQ -> je  l; C_NE -> jne l
 336           C_LT -> jl  l; C_GT -> jg  l
 337           C_GE -> jge l; C_LE -> jle l
 338         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 339         --  (it didn't work for gnu/classpath/SystemProperties.java)
 340         jmp l2
 341
 342
 343     callMalloc :: CodeGen e s ()
 344     callMalloc = do
 345       call mallocObjectAddr
 346       add esp (4 :: Word32)
 347       push eax
 348
 349   -- for locals we use a different storage
 350   cArgs :: Word8 -> Word32
 351   cArgs x =
 352     if x' >= argcount
 353     -- TODO(bernhard): maybe s/(-4)/(-8)/
 354     then (-4) * (x' - argcount + 1)
 355     else 4 + (argcount * 4) - (4 * x')
 356       where
 357         x' = fromIntegral x
 358         argcount = rawArgCount method
 359
 360   cArgs_ :: IMM -> Word8
 361   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 362
 363
 364   -- sign extension from w8 to w32 (over s8)
 365   --   unfortunately, hs-java is using Word8 everywhere (while
 366   --   it should be Int8 actually)
 367   s8_w32 :: Word8 -> Word32
 368   s8_w32 w8 = fromIntegral s8
 369     where s8 = fromIntegral w8 :: Int8
 370
 371   is8BitOffset :: Word32 -> Bool
 372   is8BitOffset w32 = s32 < 128 && s32 > (-127)
 373     where s32 = fromIntegral w32 :: Int32