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             error "no athrow for you, sorry"
 230             emitSigIllTrap 2
 231             return reip
 232       return $ Just (trapaddr, ThrowException patcher)
 233
 234     emit' insn = emit insn >> return Nothing
 235
 236     emit :: J.Instruction -> CodeGen e s ()
 237     emit POP = add esp (ptrSize :: Word32) -- drop value
 238     emit DUP = push (Disp 0, esp)
 239     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 240     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 241     emit AASTORE = emit IASTORE
 242     emit IASTORE = do
 243       pop eax -- value
 244       pop ebx -- offset
 245       add ebx (1 :: Word32)
 246       pop ecx -- aref
 247       mov (ecx, ebx, S4) eax
 248     emit CASTORE = do
 249       pop eax -- value
 250       pop ebx -- offset
 251       add ebx (1 :: Word32)
 252       pop ecx -- aref
 253       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 254     emit AALOAD = emit IALOAD
 255     emit IALOAD = do
 256       pop ebx -- offset
 257       add ebx (1 :: Word32)
 258       pop ecx -- aref
 259       push (ecx, ebx, S4)
 260     emit CALOAD = do
 261       pop ebx -- offset
 262       add ebx (1 :: Word32)
 263       pop ecx -- aref
 264       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 265     emit ARRAYLENGTH = do
 266       pop eax
 267       push (Disp 0, eax)
 268     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 269     emit (NEWARRAY typ) = do
 270       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 271                   T_INT -> 4
 272                   T_CHAR -> 2
 273                   _ -> error "newarray: type not implemented yet"
 274       -- get length from stack, but leave it there
 275       mov eax (Disp 0, esp)
 276       mov ebx (tsize :: Word32)
 277       -- multiple amount with native size of one element
 278       mul ebx -- result is in eax
 279       add eax (ptrSize :: Word32) -- for "length" entry
 280       -- push amount of bytes to allocate
 281       push eax
 282       callMalloc
 283       pop eax -- ref to arraymemory
 284       pop ebx -- length
 285       mov (Disp 0, eax) ebx -- store length at offset 0
 286       push eax -- push ref again
 287
 288     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 289     emit I2C = do
 290       pop eax
 291       and eax (0x000000ff :: Word32)
 292       push eax
 293     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 294     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 295     emit ACONST_NULL = push (0 :: Word32)
 296     emit (ICONST_M1) = push ((-1) :: Word32)
 297     emit (ICONST_0) = push (0 :: Word32)
 298     emit (ICONST_1) = push (1 :: Word32)
 299     emit (ICONST_2) = push (2 :: Word32)
 300     emit (ICONST_3) = push (3 :: Word32)
 301     emit (ICONST_4) = push (4 :: Word32)
 302     emit (ICONST_5) = push (5 :: Word32)
 303
 304     emit (ALOAD_ x) = emit (ILOAD_ x)
 305     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 306     emit (ALOAD x) = emit (ILOAD x)
 307     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 308
 309     emit (ASTORE_ x) = emit (ISTORE_ x)
 310     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 311     emit (ASTORE x) = emit (ISTORE x)
 312     emit (ISTORE x) = do
 313       pop eax
 314       mov (Disp (cArgs x), ebp) eax
 315
 316     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 317     emit (LDC2 x) = do
 318       value <- case constsPool cls M.! x of
 319                     (CString s) -> liftIO $ getUniqueStringAddr s
 320                     (CInteger i) -> liftIO $ return i
 321                     e -> error $ "LDCI... missing impl.: " ++ show e
 322       push value
 323
 324     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 325     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 326     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 327     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 328     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 329     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 330     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 331     emit INEG = do pop eax; neg eax; push eax
 332     emit (IINC x imm) =
 333       add (Disp (cArgs x), ebp) (s8_w32 imm)
 334
 335     emit (IFNONNULL x) = emit (IF C_NE x)
 336     emit (IFNULL x) = emit (IF C_EQ x)
 337     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 338     emit (IF_ICMP cond _) = do
 339       pop eax -- value2
 340       pop ebx -- value1
 341       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 342       emitIF cond
 343
 344     emit (IF cond _) = do
 345       pop eax -- value1
 346       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 347       emitIF cond
 348
 349     emit (GOTO _ ) = do
 350       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 351       jmp $ getLabel sid lmap
 352
 353     emit RETURN = do mov esp ebp; pop ebp; ret
 354     emit ARETURN = emit IRETURN
 355     emit IRETURN = do pop eax; emit RETURN
 356     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 357
 358     emitIF :: CMP -> CodeGen e s ()
 359     emitIF cond = let
 360       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 361       l = getLabel sid lmap
 362       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 363       l2 = getLabel sid2 lmap
 364       in do
 365         case cond of
 366           C_EQ -> je  l; C_NE -> jne l
 367           C_LT -> jl  l; C_GT -> jg  l
 368           C_GE -> jge l; C_LE -> jle l
 369         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 370         --  (it didn't work for gnu/classpath/SystemProperties.java)
 371         jmp l2
 372
 373     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 374     emitSigIllTrap traplen = do
 375       when (traplen < 2) (error "emitSigIllTrap: trap len too short")
 376       trapaddr <- getCurrentOffset
 377       -- 0xffff causes SIGILL
 378       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 379       -- fill rest up with NOPs
 380       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 381       return trapaddr
 382
 383
 384   -- for locals we use a different storage
 385   cArgs :: Word8 -> Word32
 386   cArgs x = ptrSize * (argcount - x' + isLocal)
 387     where
 388       x' = fromIntegral x
 389       argcount = rawArgCount method
 390       isLocal = if x' >= argcount then (-1) else 1
 391
 392   cArgs_ :: IMM -> Word8
 393   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 394
 395
 396   -- sign extension from w8 to w32 (over s8)
 397   --   unfortunately, hs-java is using Word8 everywhere (while
 398   --   it should be Int8 actually)
 399   s8_w32 :: Word8 -> Word32
 400   s8_w32 w8 = fromIntegral s8
 401     where s8 = fromIntegral w8 :: Int8
 402
 403 callMalloc :: CodeGen e s ()
 404 callMalloc = do
 405   call mallocObjectAddr
 406   add esp (ptrSize :: Word32)
 407   push eax
 408
 409
 410 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 411 -- however, this is bad for patching so we want to put always 32bit.
 412
 413 -- push imm32
 414 push32 :: Word32 -> CodeGen e s ()
 415 push32 imm32 = emit8 0x68 >> emit32 imm32
 416
 417 -- call disp32(%eax)
 418 call32Eax :: Disp -> CodeGen e s ()
 419 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 420
 421 -- push disp32(%eax)
 422 push32RelEax :: Disp -> CodeGen e s ()
 423 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 424
 425 -- mov %ebx, disp32(%eax)
 426 mov32RelEbxEax :: Disp -> CodeGen e s ()
 427 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32