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.Set as S
  14 import qualified Data.ByteString.Lazy as B
  15 import Control.Monad
  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
  25 import Harpy.X86Disassembler
  26
  27 import Mate.BasicBlocks
  28 import Mate.Types
  29 import Mate.Utilities
  30 import Mate.ClassPool
  31 import Mate.Strings
  32 import Mate.Debug
  33 #ifdef DEBUG
  34 import Text.Printf
  35 #endif
  36
  37
  38 foreign import ccall "dynamic"
  39    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> CInt -> CInt -> IO CInt
  40
  41 foreign import ccall "getMallocObjectAddr"
  42   getMallocObjectAddr :: CUInt
  43
  44 type EntryPoint = Ptr Word8
  45 type EntryPointOffset = Int
  46 type PatchInfo = (BlockID, EntryPointOffset)
  47
  48 type BBStarts = M.Map BlockID Int
  49
  50 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  51
  52
  53 emitFromBB :: B.ByteString -> MethodSignature -> Class Direct -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  54 emitFromBB method sig cls hmap =  do
  55         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  56         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  57         ep <- getEntryPoint
  58         push ebp
  59         mov ebp esp
  60         -- TODO(bernhard): determine a reasonable value.
  61         --                 e.g. (locals used) * 4
  62         sub esp (0x60 :: Word32)
  63
  64         (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  65         d <- disassemble
  66         end <- getCodeOffset
  67         return ((ep, bbstarts, end, calls), d)
  68   where
  69   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  70   getLabel _ [] = error "label not found!"
  71   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  72
  73   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  74   efBB (bid, bb) calls bbstarts lmap =
  75         if M.member bid bbstarts then
  76           return (calls, bbstarts)
  77         else do
  78           bb_offset <- getCodeOffset
  79           let bbstarts' = M.insert bid bb_offset bbstarts
  80           defineLabel $ getLabel bid lmap
  81           cs <- mapM emit' $ code bb
  82           let calls' = calls `M.union` M.fromList (catMaybes cs)
  83           case successor bb of
  84             Return -> return (calls', bbstarts')
  85             FallThrough t -> 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     getCurrentOffset :: CodeGen e s Word32
  95     getCurrentOffset = do
  96       ep <- getEntryPoint
  97       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
  98       offset <- getCodeOffset
  99       return $ w32_ep + fromIntegral offset
 100
 101     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
 102     emitInvoke cpidx hasThis = do
 103         let l = buildMethodID cls cpidx
 104         calladdr <- getCurrentOffset
 105         newNamedLabel (show l) >>= defineLabel
 106         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 107         -- place a nop at the end, therefore the disasm doesn't screw up
 108         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 109         -- discard arguments on stack
 110         let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount cls cpidx) * 4
 111         when (argcnt > 0) (add esp argcnt)
 112         -- push result on stack if method has a return value
 113         when (methodHaveReturnValue cls cpidx) (push eax)
 114         -- +2 is for correcting eip in trap context
 115         return $ Just (calladdr + 2, MI l)
 116
 117     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 118     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 119     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 120     emit' (INVOKEINTERFACE cpidx _) = do
 121         -- get methodInfo entry
 122         let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
 123         newNamedLabel (show mi) >>= defineLabel
 124         -- objref lives somewhere on the argument stack
 125         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 126         -- get method-table-ptr, keep it in eax (for trap handling)
 127         mov eax (Disp 0, eax)
 128         -- get interface-table-ptr
 129         mov ebx (Disp 0, eax)
 130         -- get method offset
 131         offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
 132         -- make actual (indirect) call
 133         calladdr <- getCurrentOffset
 134         call (Disp offset, ebx)
 135         -- discard arguments on stack (+4 for "this")
 136         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 137         when (argcnt > 0) (add esp argcnt)
 138         -- push result on stack if method has a return value
 139         when (methodHaveReturnValue cls cpidx) (push eax)
 140         -- note, the "mi" has the wrong class reference here.
 141         -- we figure that out at run-time, in the methodpool,
 142         -- depending on the method-table-ptr
 143         return $ Just (calladdr, II mi)
 144     emit' (INVOKEVIRTUAL cpidx) = do
 145         -- get methodInfo entry
 146         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 147         newNamedLabel (show mi) >>= defineLabel
 148         -- objref lives somewhere on the argument stack
 149         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 150         -- get method-table-ptr
 151         mov eax (Disp 0, eax)
 152         -- get method offset
 153         let nameAndSig = methodname `B.append` encode msig
 154         offset <- liftIO $ getMethodOffset objname nameAndSig
 155         -- make actual (indirect) call
 156         calladdr <- getCurrentOffset
 157         call (Disp offset, eax)
 158         -- discard arguments on stack (+4 for "this")
 159         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 160         when (argcnt > 0) (add esp argcnt)
 161         -- push result on stack if method has a return value
 162         when (methodHaveReturnValue cls cpidx) (push eax)
 163         -- note, the "mi" has the wrong class reference here.
 164         -- we figure that out at run-time, in the methodpool,
 165         -- depending on the method-table-ptr
 166         return $ Just (calladdr, VI mi)
 167     emit' (PUTSTATIC cpidx) = do
 168         pop eax
 169         trapaddr <- getCurrentOffset
 170         mov (Addr 0x00000000) eax -- it's a trap
 171         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 172     emit' (GETSTATIC cpidx) = do
 173         trapaddr <- getCurrentOffset
 174         mov eax (Addr 0x00000000) -- it's a trap
 175         push eax
 176         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 177     emit' insn = emit insn >> return Nothing
 178
 179     emit :: J.Instruction -> CodeGen e s ()
 180     emit POP = add esp (4 :: Word32) -- drop value
 181     emit DUP = push (Disp 0, esp)
 182     emit DUP_X1 = do pop eax; pop ebx; push eax; 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     emit ATHROW = nop -- TODO(bernhard): ...
 240     emit I2C = do
 241       pop eax
 242       and eax (0x000000ff :: Word32)
 243       push eax
 244     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 245     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 246     emit ACONST_NULL = push (0 :: Word32)
 247     emit (ICONST_M1) = push ((-1) :: Word32)
 248     emit (ICONST_0) = push (0 :: Word32)
 249     emit (ICONST_1) = push (1 :: Word32)
 250     emit (ICONST_2) = push (2 :: Word32)
 251     emit (ICONST_3) = push (3 :: Word32)
 252     emit (ICONST_4) = push (4 :: Word32)
 253     emit (ICONST_5) = push (5 :: Word32)
 254     emit (ALOAD_ x) = emit (ILOAD_ x)
 255     emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
 256     emit (ALOAD x) = emit (ILOAD x)
 257     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 258     emit (ASTORE_ x) = emit (ISTORE_ x)
 259     emit (ISTORE_ x) = do
 260         pop eax
 261         mov (Disp (cArgs_ x), ebp) eax
 262     emit (ASTORE x) = emit (ISTORE x)
 263     emit (ISTORE x) = do
 264         pop eax
 265         mov (Disp (cArgs x), ebp) eax
 266
 267     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 268     emit (LDC2 x) = do
 269         value <- case constsPool cls M.! x of
 270                       (CString s) -> liftIO $ getUniqueStringAddr s
 271                       _ -> error "LDCI... missing impl."
 272         push value
 273     emit (GETFIELD x) = do
 274         offset <- emitFieldOffset x
 275         push (Disp (fromIntegral offset), eax) -- get field
 276     emit (PUTFIELD x) = do
 277         pop ebx -- value to write
 278         offset <- emitFieldOffset x
 279         mov (Disp (fromIntegral offset), eax) ebx -- set field
 280
 281     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 282     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 283     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 284     emit IDIV = do pop ebx; pop eax; div ebx; push eax
 285     emit IREM = do pop ebx; pop eax; div ebx; push edx
 286     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 287     emit INEG = do pop eax; neg eax; push eax
 288     emit (IINC x imm) =
 289         add (Disp (cArgs x), ebp) (s8_w32 imm)
 290
 291     emit (IFNONNULL x) = emit (IF C_NE x)
 292     emit (IFNULL x) = emit (IF C_EQ x)
 293     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 294     emit (IF_ICMP cond _) = do
 295         pop eax -- value2
 296         pop ebx -- value1
 297         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 298         emitIF cond
 299
 300     emit (IF cond _) = do
 301         pop eax -- value1
 302         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 303         emitIF cond
 304
 305     emit (GOTO _ ) = do
 306         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 307         jmp $ getLabel sid lmap
 308
 309     emit RETURN = do mov esp ebp; pop ebp; ret
 310     emit ARETURN = emit IRETURN
 311     emit IRETURN = do pop eax; emit RETURN
 312     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 313
 314     emitFieldOffset :: Word16 -> CodeGen e s Int32
 315     emitFieldOffset x = do
 316         pop eax -- this pointer
 317         let (cname, fname) = buildFieldOffset cls x
 318         liftIO $ getFieldOffset cname fname
 319
 320     emitIF :: CMP -> CodeGen e s ()
 321     emitIF cond = let
 322       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 323       l = getLabel sid lmap
 324       in case cond of
 325         C_EQ -> je  l; C_NE -> jne l
 326         C_LT -> jl  l; C_GT -> jg  l
 327         C_GE -> jge l; C_LE -> jle l
 328
 329     callMalloc :: CodeGen e s ()
 330     callMalloc = do
 331         calladdr <- getCurrentOffset
 332         let w32_calladdr = 5 + calladdr
 333         let malloaddr = fromIntegral getMallocObjectAddr :: Word32
 334         call (malloaddr - w32_calladdr)
 335         add esp (4 :: Word32)
 336         push eax
 337
 338   -- for locals we use a different storage
 339   cArgs :: Word8 -> Word32
 340   cArgs x = if x' >= thisMethodArgCnt
 341       -- TODO(bernhard): maybe s/(-4)/(-8)/
 342       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 343       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 344     where x' = fromIntegral x
 345
 346   cArgs_ :: IMM -> Word32
 347   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 348
 349   thisMethodArgCnt :: Word32
 350   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 351     where
 352     (Just m) = lookupMethodSig method sig cls
 353     (MethodSignature args _) = sig
 354     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 355         then 0 else 1 -- one argument for the this pointer
 356
 357
 358   -- sign extension from w8 to w32 (over s8)
 359   --   unfortunately, hs-java is using Word8 everywhere (while
 360   --   it should be Int8 actually)
 361   s8_w32 :: Word8 -> Word32
 362   s8_w32 w8 = fromIntegral s8
 363     where s8 = fromIntegral w8 :: Int8