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, find)
  11 import qualified Data.Map as M
  12 import qualified Data.Bimap as BI
  13 import qualified Data.ByteString.Lazy as B
  14 import Control.Monad
  15 import Control.Applicative
  16
  17 import Foreign hiding (xor)
  18 import Foreign.C.Types
  19
  20 import qualified JVM.Assembler as J
  21 import JVM.Assembler hiding (Instruction)
  22 import JVM.ClassFile
  23
  24 import Harpy hiding (fst)
  25 import Harpy.X86Disassembler
  26
  27 import Mate.BasicBlocks
  28 import Mate.NativeSizes
  29 import Mate.Types
  30 import Mate.Utilities
  31 import Mate.ClassPool
  32 import Mate.ClassHierarchy
  33 import {-# SOURCE #-} Mate.MethodPool
  34 import Mate.Strings
  35 import Mate.Debug
  36
  37
  38 foreign import ccall "&mallocObjectGC"
  39   mallocObjectAddr :: FunPtr (Int -> IO CPtrdiff)
  40
  41 type EntryPoint = Ptr Word8
  42 type EntryPointOffset = Int
  43 type PatchInfo = (BlockID, EntryPointOffset)
  44
  45 type BBStarts = M.Map BlockID Int
  46
  47 type CompileInfo = (EntryPoint, Int, TrapMap)
  48
  49
  50 emitFromBB :: Class Direct -> MethodInfo -> RawMethod -> CodeGen e JpcNpcMap (CompileInfo, [Instruction])
  51 emitFromBB cls miThis method = do
  52     let keys = M.keys hmap
  53     llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
  54     let lmap = zip keys llmap
  55     ep <- getEntryPoint
  56     push ebp
  57     mov ebp esp
  58     sub esp (fromIntegral (rawLocals method) * ptrSize :: Word32)
  59     calls <- M.fromList . catMaybes . concat <$> mapM (efBB lmap) keys
  60     d <- disassemble
  61     end <- getCodeOffset
  62     return ((ep, end, calls), d)
  63   where
  64   hmap = rawMapBB method
  65
  66   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  67   getLabel bid [] = error $ "label " ++ show bid ++ " not found"
  68   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  69
  70   efBB :: [(BlockID, Label)] -> BlockID -> CodeGen e JpcNpcMap [(Maybe (Word32, TrapCause))]
  71   efBB lmap bid = do
  72     defineLabel $ getLabel bid lmap
  73     retval <- mapM emit'' $ code bb
  74     case successor bb of
  75         FallThrough t -> do
  76           -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
  77           jmp (getLabel t lmap)
  78         _ -> return ()
  79     return retval
  80     where
  81     bb = hmap M.! bid
  82
  83     forceRegDump :: CodeGen e s ()
  84     forceRegDump = do
  85       push esi
  86       mov esi (0x13371234 :: Word32)
  87       mov esi (Addr 0)
  88       pop esi
  89
  90     getCurrentOffset :: CodeGen e s Word32
  91     getCurrentOffset = do
  92       ep <- (fromIntegral . ptrToIntPtr) <$> getEntryPoint
  93       offset <- fromIntegral <$> getCodeOffset
  94       return $ ep + offset
  95
  96     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
  97     emitInvoke cpidx hasThis = do
  98       let l = buildMethodID cls cpidx
  99       newNamedLabel (show l) >>= defineLabel
 100       -- like: call $0x01234567
 101       calladdr <- emitSigIllTrap 5
 102       let patcher reip = do
 103             (entryAddr, _) <- liftIO $ getMethodEntry l
 104             call (fromIntegral (entryAddr - (reip + 5)) :: NativeWord)
 105             return reip
 106       -- discard arguments on stack
 107       let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount (methodNameTypeByIdx cls cpidx)) * ptrSize
 108       when (argcnt > 0) (add esp argcnt)
 109       -- push result on stack if method has a return value
 110       when (methodHaveReturnValue cls cpidx) (push eax)
 111       return $ Just (calladdr, StaticMethod patcher)
 112
 113     virtualCall :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
 114     virtualCall cpidx isInterface = do
 115       let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 116       newNamedLabel (show mi) >>= defineLabel
 117       -- get method offset for call @ runtime
 118       let offset = if isInterface
 119           then getInterfaceMethodOffset objname methodname (encode msig)
 120           else getMethodOffset objname (methodname `B.append` encode msig)
 121       let argsLen = genericLength args
 122       -- objref lives somewhere on the argument stack
 123       mov ebx (Disp (argsLen * ptrSize), esp)
 124       when isInterface $
 125         mov ebx (Disp 0, ebx) -- get method-table-ptr, keep it in ebx
 126       -- get method-table-ptr (or interface-table-ptr)
 127       mov eax (Disp 0, ebx)
 128       -- make actual (indirect) call
 129       calladdr <- getCurrentOffset
 130       -- will be patched to this: call (Disp 0xXXXXXXXX, eax)
 131       emitSigIllTrap 6
 132       -- discard arguments on stack (`+1' for "this")
 133       let argcnt = ptrSize * (1 + methodGetArgsCount (methodNameTypeByIdx cls cpidx))
 134       when (argcnt > 0) (add esp argcnt)
 135       -- push result on stack if method has a return value
 136       when (methodHaveReturnValue cls cpidx) (push eax)
 137       -- note, that "mi" has the wrong class reference here.
 138       -- we figure that out at run-time, in the methodpool,
 139       -- depending on the method-table-ptr
 140       return $ Just (calladdr, VirtualCall isInterface mi offset)
 141
 142     emit'' :: (Int, J.Instruction) -> CodeGen e JpcNpcMap (Maybe (Word32, TrapCause))
 143     emit'' (jpc, insn) = do
 144       npc <- getCurrentOffset
 145       jpcrpc <- getState
 146       setState (BI.insert jpc npc jpcrpc)
 147       newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 148
 149     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 150     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 151     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 152     emit' (INVOKEINTERFACE cpidx _) = virtualCall cpidx True
 153     emit' (INVOKEVIRTUAL cpidx) = virtualCall cpidx False
 154
 155     emit' (PUTSTATIC cpidx) = do
 156       pop eax
 157       trapaddr <- getCurrentOffset
 158       mov (Addr 0x00000000) eax -- it's a trap
 159       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 160     emit' (GETSTATIC cpidx) = do
 161       trapaddr <- getCurrentOffset
 162       mov eax (Addr 0x00000000) -- it's a trap
 163       push eax
 164       return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 165
 166     emit' (GETFIELD x) = do
 167       pop eax -- this pointer
 168       -- like: 099db064  ff b0 e4 14 00 00 pushl  5348(%eax)
 169       trapaddr <- emitSigIllTrap 6
 170       let patcher reip = do
 171             let (cname, fname) = buildFieldOffset cls x
 172             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 173             push32RelEax (Disp offset) -- get field
 174             return reip
 175       return $ Just (trapaddr, ObjectField patcher)
 176     emit' (PUTFIELD x) = do
 177       pop ebx -- value to write
 178       pop eax -- this pointer
 179       -- like: 4581fc6b  89 98 30 7b 00 00 movl   %ebx,31536(%eax)
 180       trapaddr <- emitSigIllTrap 6
 181       let patcher reip = do
 182             let (cname, fname) = buildFieldOffset cls x
 183             offset <- liftIO $ fromIntegral <$> getFieldOffset cname fname
 184             mov32RelEbxEax (Disp offset) -- set field
 185             return reip
 186       return $ Just (trapaddr, ObjectField patcher)
 187
 188     emit' (INSTANCEOF cpidx) = do
 189       pop eax
 190       -- place something like `mov edx $mtable_of_objref' instead
 191       trapaddr <- emitSigIllTrap 4
 192       push (0 :: Word32)
 193       let patcher reax reip = do
 194             emitSigIllTrap 4
 195             let classname = buildClassID cls cpidx
 196             check <- liftIO $ isInstanceOf (fromIntegral reax) classname
 197             if check
 198               then push (1 :: Word32)
 199               else push (0 :: Word32)
 200             return (reip + 4)
 201       return $ Just (trapaddr, InstanceOf patcher)
 202     emit' (NEW objidx) = do
 203       let objname = buildClassID cls objidx
 204       -- place something like `push $objsize' instead
 205       trapaddr <- emitSigIllTrap 5
 206       callMalloc
 207       -- 0x13371337 is just a placeholder; will be replaced with mtable ptr
 208       mov (Disp 0, eax) (0x13371337 :: Word32)
 209       mov (Disp 4, eax) (0x1337babe :: Word32)
 210       let patcher reip = do
 211             objsize <- liftIO $ getObjectSize objname
 212             push32 objsize
 213             callMalloc
 214             mtable <- liftIO $ getMethodTable objname
 215             mov (Disp 0, eax) mtable
 216             mov (Disp 4, eax) (0x1337babe :: Word32)
 217             return reip
 218       return $ Just (trapaddr, NewObject patcher)
 219
 220     emit' ATHROW = do
 221       pop eax
 222       push eax
 223       mov eax (Disp 0, eax)
 224       trapaddr <- emitSigIllTrap 2
 225       let patcher :: TrapPatcherEaxEsp
 226           patcher reax resp reip = do
 227             liftIO $ printfJit $ printf "reip: %d\n" (fromIntegral reip :: Word32)
 228             liftIO $ printfJit $ printf "reax: %d\n" (fromIntegral reax :: Word32)
 229             (_, jnmap) <- liftIO $ getMethodEntry miThis
 230             liftIO $ printfJit $ printf "size: %d\n" (BI.size jnmap)
 231             liftIO $ printfJit $ printf "jnmap: %s\n" (show $ BI.toList jnmap)
 232             -- TODO: (-4) is a hack (due to the insns above)
 233             let jpc = fromIntegral (jnmap BI.!> (fromIntegral reip - 4))
 234             let exceptionmap = rawExcpMap method
 235             liftIO $ printfJit $ printf "exmap: %s\n" (show $ M.toList exceptionmap)
 236             let key =
 237                   case find f $ M.keys exceptionmap of
 238                     Just x -> x
 239                     Nothing -> error "exception: no handler found. (TODO1)"
 240                   where
 241                     f (x, y) = jpc >= x && jpc <= y
 242             liftIO $ printfJit $ printf "exception: key is: %s\n" (show key)
 243             let handlerJPCs = exceptionmap M.! key
 244             let f (x, y) = do x' <- getMethodTable x; return (fromIntegral x', y)
 245             handlers <- liftIO $ mapM f handlerJPCs
 246             liftIO $ printfJit $ printf "exception: handlers: %s\n" (show handlers)
 247             let handlerJPC =
 248                   case find ((==) reax . fst) handlers of
 249                     Just x -> x
 250                     Nothing -> error "exception: no handler found (TODO2)"
 251             let handlerNPC = jnmap BI.! (fromIntegral $ snd handlerJPC)
 252             liftIO $ printfJit $ printf "exception: handler at: 0x%08x\n" handlerNPC
 253             emitSigIllTrap 2
 254             return $ fromIntegral handlerNPC
 255       return $ Just (trapaddr, ThrowException patcher)
 256
 257     emit' insn = emit insn >> return Nothing
 258
 259     emit :: J.Instruction -> CodeGen e s ()
 260     emit POP = add esp (ptrSize :: Word32) -- drop value
 261     emit DUP = push (Disp 0, esp)
 262     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 263     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 264     emit AASTORE = emit IASTORE
 265     emit IASTORE = do
 266       pop eax -- value
 267       pop ebx -- offset
 268       add ebx (1 :: Word32)
 269       pop ecx -- aref
 270       mov (ecx, ebx, S4) eax
 271     emit CASTORE = do
 272       pop eax -- value
 273       pop ebx -- offset
 274       add ebx (1 :: Word32)
 275       pop ecx -- aref
 276       mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 277     emit AALOAD = emit IALOAD
 278     emit IALOAD = do
 279       pop ebx -- offset
 280       add ebx (1 :: Word32)
 281       pop ecx -- aref
 282       push (ecx, ebx, S4)
 283     emit CALOAD = do
 284       pop ebx -- offset
 285       add ebx (1 :: Word32)
 286       pop ecx -- aref
 287       push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 288     emit ARRAYLENGTH = do
 289       pop eax
 290       push (Disp 0, eax)
 291     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 292     emit (NEWARRAY typ) = do
 293       let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 294                   T_INT -> 4
 295                   T_CHAR -> 2
 296                   _ -> error "newarray: type not implemented yet"
 297       -- get length from stack, but leave it there
 298       mov eax (Disp 0, esp)
 299       mov ebx (tsize :: Word32)
 300       -- multiple amount with native size of one element
 301       mul ebx -- result is in eax
 302       add eax (ptrSize :: Word32) -- for "length" entry
 303       -- push amount of bytes to allocate
 304       push eax
 305       callMalloc
 306       pop eax -- ref to arraymemory
 307       pop ebx -- length
 308       mov (Disp 0, eax) ebx -- store length at offset 0
 309       push eax -- push ref again
 310
 311     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 312     emit I2C = do
 313       pop eax
 314       and eax (0x000000ff :: Word32)
 315       push eax
 316     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 317     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 318     emit ACONST_NULL = push (0 :: Word32)
 319     emit (ICONST_M1) = push ((-1) :: Word32)
 320     emit (ICONST_0) = push (0 :: Word32)
 321     emit (ICONST_1) = push (1 :: Word32)
 322     emit (ICONST_2) = push (2 :: Word32)
 323     emit (ICONST_3) = push (3 :: Word32)
 324     emit (ICONST_4) = push (4 :: Word32)
 325     emit (ICONST_5) = push (5 :: Word32)
 326
 327     emit (ALOAD_ x) = emit (ILOAD_ x)
 328     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 329     emit (ALOAD x) = emit (ILOAD x)
 330     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 331
 332     emit (ASTORE_ x) = emit (ISTORE_ x)
 333     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 334     emit (ASTORE x) = emit (ISTORE x)
 335     emit (ISTORE x) = do
 336       pop eax
 337       mov (Disp (cArgs x), ebp) eax
 338
 339     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 340     emit (LDC2 x) = do
 341       value <- case constsPool cls M.! x of
 342                     (CString s) -> liftIO $ getUniqueStringAddr s
 343                     (CInteger i) -> liftIO $ return i
 344                     e -> error $ "LDCI... missing impl.: " ++ show e
 345       push value
 346
 347     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 348     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 349     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 350     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 351     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 352     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 353     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 354     emit INEG = do pop eax; neg eax; push eax
 355     emit (IINC x imm) =
 356       add (Disp (cArgs x), ebp) (s8_w32 imm)
 357
 358     emit (IFNONNULL x) = emit (IF C_NE x)
 359     emit (IFNULL x) = emit (IF C_EQ x)
 360     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 361     emit (IF_ICMP cond _) = do
 362       pop eax -- value2
 363       pop ebx -- value1
 364       cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 365       emitIF cond
 366
 367     emit (IF cond _) = do
 368       pop eax -- value1
 369       cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 370       emitIF cond
 371
 372     emit (GOTO _ ) = do
 373       let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 374       jmp $ getLabel sid lmap
 375
 376     emit RETURN = do mov esp ebp; pop ebp; ret
 377     emit ARETURN = emit IRETURN
 378     emit IRETURN = do pop eax; emit RETURN
 379     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 380
 381     emitIF :: CMP -> CodeGen e s ()
 382     emitIF cond = let
 383       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 384       l = getLabel sid lmap
 385       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 386       l2 = getLabel sid2 lmap
 387       in do
 388         case cond of
 389           C_EQ -> je  l; C_NE -> jne l
 390           C_LT -> jl  l; C_GT -> jg  l
 391           C_GE -> jge l; C_LE -> jle l
 392         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 393         --  (it didn't work for gnu/classpath/SystemProperties.java)
 394         jmp l2
 395
 396     emitSigIllTrap :: Int -> CodeGen e s NativeWord
 397     emitSigIllTrap traplen = do
 398       when (traplen < 2) (error "emitSigIllTrap: trap len too short")
 399       trapaddr <- getCurrentOffset
 400       -- 0xffff causes SIGILL
 401       emit8 (0xff :: Word8); emit8 (0xff :: Word8)
 402       -- fill rest up with NOPs
 403       sequence_ [nop | _ <- [1 .. (traplen - 2)]]
 404       return trapaddr
 405
 406
 407   -- for locals we use a different storage
 408   cArgs :: Word8 -> Word32
 409   cArgs x = ptrSize * (argcount - x' + isLocal)
 410     where
 411       x' = fromIntegral x
 412       argcount = rawArgCount method
 413       isLocal = if x' >= argcount then (-1) else 1
 414
 415   cArgs_ :: IMM -> Word8
 416   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 417
 418
 419   -- sign extension from w8 to w32 (over s8)
 420   --   unfortunately, hs-java is using Word8 everywhere (while
 421   --   it should be Int8 actually)
 422   s8_w32 :: Word8 -> Word32
 423   s8_w32 w8 = fromIntegral s8
 424     where s8 = fromIntegral w8 :: Int8
 425
 426 callMalloc :: CodeGen e s ()
 427 callMalloc = do
 428   call mallocObjectAddr
 429   add esp (ptrSize :: Word32)
 430   push eax
 431
 432
 433 -- harpy tries to cut immediates (or displacements), if they fit in 8bit.
 434 -- however, this is bad for patching so we want to put always 32bit.
 435
 436 -- push imm32
 437 push32 :: Word32 -> CodeGen e s ()
 438 push32 imm32 = emit8 0x68 >> emit32 imm32
 439
 440 -- call disp32(%eax)
 441 call32Eax :: Disp -> CodeGen e s ()
 442 call32Eax (Disp disp32) = emit8 0xff >> emit8 0x90 >> emit32 disp32
 443
 444 -- push disp32(%eax)
 445 push32RelEax :: Disp -> CodeGen e s ()
 446 push32RelEax (Disp disp32) = emit8 0xff >> emit8 0xb0 >> emit32 disp32
 447
 448 -- mov %ebx, disp32(%eax)
 449 mov32RelEbxEax :: Disp -> CodeGen e s ()
 450 mov32RelEbxEax (Disp disp32) = emit8 0x89 >> emit8 0x98 >> emit32 disp32