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 import Control.Applicative
  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.ClassHierarchy
  32 import {-# SOURCE #-} Mate.MethodPool
  33 import Mate.Strings
  34
  35
  36 foreign import ccall "&mallocObjectGC"
  37   mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
  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) * ptrSize :: 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 bid [] = error $ "label " ++ show bid ++ " 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     forceRegDump :: CodeGen e s ()
  94     forceRegDump = do
  95       push esi
  96       mov esi (0x13371234 :: Word32)
  97       mov esi (Addr 0)
  98       pop esi
  99
 100     getCurrentOffset :: CodeGen e s Word32
 101     getCurrentOffset = do
 102       ep <- (fromIntegral . ptrToIntPtr) <$> getEntryPoint
 103       offset <- fromIntegral <$> getCodeOffset
 104       return $ ep + offset
 105
 106     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 107     emitInvoke cpidx hasThis = do
 108       let l = buildMethodID cls cpidx
 109       newNamedLabel (show l) >>= defineLabel
 110       -- like: call $0x01234567
 111       calladdr <- emitSigIllTrap 5
 112       let patcher reip = do
 113             entryAddr <- liftIO $ getMethodEntry l
 114             call (fromIntegral (entryAddr - (reip + 5)) :: NativeWord)
 115             return reip
 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 patcher)
 122
 123     virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 124     virtualCall cpidx isInterface = do
 125       let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 126       newNamedLabel (show mi) >>= defineLabel
 127       -- get method offset for call @ runtime
 128       let offset = if isInterface
 129           then getInterfaceMethodOffset objname methodname (encode msig)
 130           else getMethodOffset objname (methodname `B.append` encode msig)
 131       let argsLen = genericLength args
 132       -- objref lives somewhere on the argument stack
 133       mov ebx (Disp (argsLen * ptrSize), esp)
 134       when isInterface $
 135         mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
 136       -- get method-table-ptr (or interface-table-ptr)
 137       mov eax (Disp 0, ebx)
 138       -- make actual (indirect) call
 139       calladdr <- getCurrentOffset
 140       -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
 141       emitSigIllTrap 6
 142       -- discard arguments on stack (`+1' for "this")
 143       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
 144       when (argcnt > 0) (add esp argcnt)
 145       -- push result on stack if method has a return value
 146       when (methodHaveReturnValue cls cpidx) (push eax)
 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       return $ Just (calladdr, VirtualCall isInterface mi offset)
 151
 152     emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 153     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 154
 155     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 156     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 157     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 158     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 159     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 160
 161     emit' (PUTSTATIC cpidx) = do
 162       pop eax
 163       trapaddr <- getCurrentOffset
 164       mov (Addr 0x00000000) eax -- it's a trap
 165       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 166     emit' (GETSTATIC cpidx) = do
 167       trapaddr <- getCurrentOffset
 168       mov eax (Addr 0x00000000) -- it's a trap
 169       push eax
 170       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 171
 172     emit' (GETFIELD x) = do
 173       pop eax -- this pointer
 174       -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
 175       trapaddr <- emitSigIllTrap 6
 176       let patcher reip = do
 177             let (cname, fname) = buildFieldOffset cls x
 178             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 179             push32RelEax (Disp offset) -- get field
 180             return reip
 181       return $ Just (trapaddr, ObjectField patcher)
 182     emit' (PUTFIELD x) = do
 183       pop ebx -- value to write
 184       pop eax -- this pointer
 185       -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
 186       trapaddr <- emitSigIllTrap 6
 187       let patcher reip = do
 188             let (cname, fname) = buildFieldOffset cls x
 189             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 190             mov32RelEbxEax (Disp offset) -- set field
 191             return reip
 192       return $ Just (trapaddr, ObjectField patcher)
 193
 194     emit' (INSTANCEOF cpidx) = do
 195       pop eax
 196       -- place something like `mov edx $mtable_of_objref' instead
 197       trapaddr <- emitSigIllTrap 4
 198       push (0 :: Word32)
 199       let patcher reax reip = do
 200             emitSigIllTrap 4
 201             let classname = buildClassID cls cpidx
 202             check <- liftIO $ isInstanceOf (fromIntegral reax) classname
 203             if check
 204               then push (1 :: Word32)
 205               else push (0 :: Word32)
 206             return (reip + 4)
 207       return $ Just (trapaddr, InstanceOf patcher)
 208     emit' (NEW objidx) = do
 209       let objname = buildClassID cls objidx
 210       -- place something like `push $objsize' instead
 211       trapaddr <- emitSigIllTrap 5
 212       callMalloc
 213       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 214       mov (Disp 0, eax) (0x13371337 :: Word32)
 215       mov (Disp 4, eax) (0x1337babe :: Word32)
 216       let patcher reip = do
 217             objsize <- liftIO $ getObjectSize objname
 218             push32 objsize
 219             callMalloc
 220             mtable <- liftIO $ getMethodTable objname
 221             mov (Disp 0, eax) mtable
 222             mov (Disp 4, eax) (0x1337babe :: Word32)
 223             return reip
 224       return $ Just (trapaddr, NewObject patcher)
 225
 226     emit' ATHROW = do
 227       trapaddr <- emitSigIllTrap 2
 228       let patcher resp reip = do
 229             emitSigIllTrap 2
 230             return reip
 231       return $ Just (trapaddr, ThrowException patcher)
 232
 233     emit' insn = emit insn >> return Nothing
 234
 235     emit :: J.Instruction -> CodeGen e s ()
 236     emit POP = add esp (ptrSize :: Word32) -- drop value
 237     emit DUP = push (Disp 0, esp)
 238     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 239     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 240     emit AASTORE = emit IASTORE
 241     emit IASTORE = do
 242       pop eax -- value
 243       pop ebx -- offset
 244       add ebx (1 :: Word32)
 245       pop ecx -- aref
 246       mov (ecx, ebx, S4) eax
 247     emit CASTORE = do
 248       pop eax -- value
 249       pop ebx -- offset
 250       add ebx (1 :: Word32)
 251       pop ecx -- aref
 252       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 253     emit AALOAD = emit IALOAD
 254     emit IALOAD = do
 255       pop ebx -- offset
 256       add ebx (1 :: Word32)
 257       pop ecx -- aref
 258       push (ecx, ebx, S4)
 259     emit CALOAD = do
 260       pop ebx -- offset
 261       add ebx (1 :: Word32)
 262       pop ecx -- aref
 263       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 264     emit ARRAYLENGTH = do
 265       pop eax
 266       push (Disp 0, eax)
 267     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 268     emit (NEWARRAY typ) = do
 269       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 270                   T_INT -> 4
 271                   T_CHAR -> 2
 272                   _ -> error "newarray: type not implemented yet"
 273       -- get length from stack, but leave it there
 274       mov eax (Disp 0, esp)
 275       mov ebx (tsize :: Word32)
 276       -- multiple amount with native size of one element
 277       mul ebx -- result is in eax
 278       add eax (ptrSize :: Word32) -- for "length" entry
 279       -- push amount of bytes to allocate
 280       push eax
 281       callMalloc
 282       pop eax -- ref to arraymemory
 283       pop ebx -- length
 284       mov (Disp 0, eax) ebx -- store length at offset 0
 285       push eax -- push ref again
 286
 287     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 288     emit I2C = do
 289       pop eax
 290       and eax (0x000000ff :: Word32)
 291       push eax
 292     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 293     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 294     emit ACONST_NULL = push (0 :: Word32)
 295     emit (ICONST_M1) = push ((-1) :: Word32)
 296     emit (ICONST_0) = push (0 :: Word32)
 297     emit (ICONST_1) = push (1 :: Word32)
 298     emit (ICONST_2) = push (2 :: Word32)
 299     emit (ICONST_3) = push (3 :: Word32)
 300     emit (ICONST_4) = push (4 :: Word32)
 301     emit (ICONST_5) = push (5 :: Word32)
 302
 303     emit (ALOAD_ x) = emit (ILOAD_ x)
 304     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 305     emit (ALOAD x) = emit (ILOAD x)
 306     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 307
 308     emit (ASTORE_ x) = emit (ISTORE_ x)
 309     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 310     emit (ASTORE x) = emit (ISTORE x)
 311     emit (ISTORE x) = do
 312       pop eax
 313       mov (Disp (cArgs x), ebp) eax
 314
 315     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 316     emit (LDC2 x) = do
 317       value <- case constsPool cls M.! x of
 318                     (CString s) -> liftIO $ getUniqueStringAddr s
 319                     (CInteger i) -> liftIO $ return i
 320                     e -> error $ "LDCI... missing impl.: " ++ show e
 321       push value
 322
 323     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 324     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 325     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 326     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 327     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 328     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 329     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 330     emit INEG = do pop eax; neg eax; push eax
 331     emit (IINC x imm) =
 332       add (Disp (cArgs x), ebp) (s8_w32 imm)
 333
 334     emit (IFNONNULL x) = emit (IF C_NE x)
 335     emit (IFNULL x) = emit (IF C_EQ x)
 336     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 337     emit (IF_ICMP cond _) = do
 338       pop eax -- value2
 339       pop ebx -- value1
 340       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 341       emitIF cond
 342
 343     emit (IF cond _) = do
 344       pop eax -- value1
 345       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 346       emitIF cond
 347
 348     emit (GOTO _ ) = do
 349       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 350       jmp $ getLabel sid lmap
 351
 352     emit RETURN = do mov esp ebp; pop ebp; ret
 353     emit ARETURN = emit IRETURN
 354     emit IRETURN = do pop eax; emit RETURN
 355     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 356
 357     emitIF :: CMP -> CodeGen e s ()
 358     emitIF cond = let
 359       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 360       l = getLabel sid lmap
 361       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 362       l2 = getLabel sid2 lmap
 363       in do
 364         case cond of
 365           C_EQ -> je  l; C_NE -> jne l
 366           C_LT -> jl  l; C_GT -> jg  l
 367           C_GE -> jge l; C_LE -> jle l
 368         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 369         --  (it didn't work for gnu/classpath/SystemProperties.java)
 370         jmp l2
 371
 372     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 373     emitSigIllTrap traplen = do
 374       when (traplen < 2) (error "emitSigIllTrap: trap len too short")
 375       trapaddr <- getCurrentOffset
 376       -- 0xffff causes SIGILL
 377       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 378       -- fill rest up with NOPs
 379       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 380       return trapaddr
 381
 382
 383   -- for locals we use a different storage
 384   cArgs :: Word8 -> Word32
 385   cArgs x = ptrSize * (argcount - x' + isLocal)
 386     where
 387       x' = fromIntegral x
 388       argcount = rawArgCount method
 389       isLocal = if x' >= argcount then (-1) else 1
 390
 391   cArgs_ :: IMM -> Word8
 392   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 393
 394
 395   -- sign extension from w8 to w32 (over s8)
 396   --   unfortunately, hs-java is using Word8 everywhere (while
 397   --   it should be Int8 actually)
 398   s8_w32 :: Word8 -> Word32
 399   s8_w32 w8 = fromIntegral s8
 400     where s8 = fromIntegral w8 :: Int8
 401
 402 callMalloc :: CodeGen e s ()
 403 callMalloc = do
 404   call mallocObjectAddr
 405   add esp (ptrSize :: Word32)
 406   push eax
 407
 408
 409 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 410 -- however, this is bad for patching so we want to put always 32bit.
 411
 412 -- push imm32
 413 push32 :: Word32 -> CodeGen e s ()
 414 push32 imm32 = emit8 0x68 >> emit32 imm32
 415
 416 -- call disp32(%eax)
 417 call32Eax :: Disp -> CodeGen e s ()
 418 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 419
 420 -- push disp32(%eax)
 421 push32RelEax :: Disp -> CodeGen e s ()
 422 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 423
 424 -- mov %ebx, disp32(%eax)
 425 mov32RelEbxEax :: Disp -> CodeGen e s ()
 426 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32