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 #ifdef DEBUG
  33 import Text.Printf
  34 #endif
  35
  36
  37 foreign import ccall "dynamic"
  38    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> CInt -> CInt -> IO CInt
  39
  40 foreign import ccall "getMallocObjectAddr"
  41   getMallocObjectAddr :: CUInt
  42
  43 type EntryPoint = Ptr Word8
  44 type EntryPointOffset = Int
  45 type PatchInfo = (BlockID, EntryPointOffset)
  46
  47 type BBStarts = M.Map BlockID Int
  48
  49 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  50
  51
  52 emitFromBB :: B.ByteString -> MethodSignature -> Class Direct -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  53 emitFromBB method sig cls hmap =  do
  54         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  55         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  56         ep <- getEntryPoint
  57         push ebp
  58         mov ebp esp
  59         -- TODO(bernhard): determine a reasonable value.
  60         --                 e.g. (locals used) * 4
  61         sub esp (0x60 :: Word32)
  62
  63         (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  64         d <- disassemble
  65         end <- getCodeOffset
  66         return ((ep, bbstarts, end, calls), d)
  67   where
  68   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  69   getLabel _ [] = error "label not found!"
  70   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  71
  72   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  73   efBB (bid, bb) calls bbstarts lmap =
  74         if M.member bid bbstarts then
  75           return (calls, bbstarts)
  76         else do
  77           bb_offset <- getCodeOffset
  78           let bbstarts' = M.insert bid bb_offset bbstarts
  79           defineLabel $ getLabel bid lmap
  80           cs <- mapM emit' $ code bb
  81           let calls' = calls `M.union` M.fromList (catMaybes cs)
  82           case successor bb of
  83             Return -> return (calls', bbstarts')
  84             FallThrough t -> 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, TrapInfo))
 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 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, MI l)
 115
 116     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 117     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 118     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 119     emit' (INVOKEINTERFACE cpidx _) = do
 120         -- get methodInfo entry
 121         let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
 122         newNamedLabel (show mi) >>= defineLabel
 123         -- objref lives somewhere on the argument stack
 124         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 125         -- get method-table-ptr, keep it in eax (for trap handling)
 126         mov eax (Disp 0, eax)
 127         -- get interface-table-ptr
 128         mov ebx (Disp 0, eax)
 129         -- get method offset
 130         offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
 131         -- make actual (indirect) call
 132         calladdr <- getCurrentOffset
 133         call (Disp offset, ebx)
 134         -- discard arguments on stack (+4 for "this")
 135         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 136         when (argcnt > 0) (add esp argcnt)
 137         -- push result on stack if method has a return value
 138         when (methodHaveReturnValue cls cpidx) (push eax)
 139         -- note, the "mi" has the wrong class reference here.
 140         -- we figure that out at run-time, in the methodpool,
 141         -- depending on the method-table-ptr
 142         let imm8 = is8BitOffset offset
 143         return $ Just (calladdr + (if imm8 then 3 else 6), II imm8 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         let imm8 = is8BitOffset offset
 167         return $ Just (calladdr + (if imm8 then 3 else 6), VI imm8 mi)
 168     emit' (PUTSTATIC cpidx) = do
 169         pop eax
 170         trapaddr <- getCurrentOffset
 171         mov (Addr 0x00000000) eax -- it's a trap
 172         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 173     emit' (GETSTATIC cpidx) = do
 174         trapaddr <- getCurrentOffset
 175         mov eax (Addr 0x00000000) -- it's a trap
 176         push eax
 177         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 178     emit' insn = emit insn >> return Nothing
 179
 180     emit :: J.Instruction -> CodeGen e s ()
 181     emit POP = add esp (4 :: Word32) -- drop value
 182     emit DUP = push (Disp 0, esp)
 183     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 184     emit AASTORE = emit IASTORE
 185     emit IASTORE = do
 186         pop eax -- value
 187         pop ebx -- offset
 188         add ebx (1 :: Word32)
 189         pop ecx -- aref
 190         mov (ecx, ebx, S4) eax
 191     emit CASTORE = do
 192         pop eax -- value
 193         pop ebx -- offset
 194         add ebx (1 :: Word32)
 195         pop ecx -- aref
 196         mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 197     emit AALOAD = emit IALOAD
 198     emit IALOAD = do
 199         pop ebx -- offset
 200         add ebx (1 :: Word32)
 201         pop ecx -- aref
 202         push (ecx, ebx, S4)
 203     emit CALOAD = do
 204         pop ebx -- offset
 205         add ebx (1 :: Word32)
 206         pop ecx -- aref
 207         push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 208     emit ARRAYLENGTH = do
 209         pop eax
 210         push (Disp 0, eax)
 211     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 212     emit (NEWARRAY typ) = do
 213         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 214                     T_INT -> 4
 215                     T_CHAR -> 2
 216                     _ -> error "newarray: type not implemented yet"
 217         -- get length from stack, but leave it there
 218         mov eax (Disp 0, esp)
 219         mov ebx (tsize :: Word32)
 220         -- multiple amount with native size of one element
 221         mul ebx -- result is in eax
 222         add eax (4 :: Word32) -- for "length" entry
 223         -- push amount of bytes to allocate
 224         push eax
 225         callMalloc
 226         pop eax -- ref to arraymemory
 227         pop ebx -- length
 228         mov (Disp 0, eax) ebx -- store length at offset 0
 229         push eax -- push ref again
 230     emit (NEW objidx) = do
 231         let objname = buildClassID cls objidx
 232         amount <- liftIO $ getObjectSize objname
 233         push (amount :: Word32)
 234         callMalloc
 235         -- TODO(bernhard): save reference somewhere for GC
 236         -- set method table pointer
 237         mtable <- liftIO $ getMethodTable objname
 238         mov (Disp 0, eax) mtable
 239     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 240     -- TODO(bernhard): ...
 241     emit (INSTANCEOF _) = do
 242       pop eax
 243       push (1 :: Word32)
 244     emit ATHROW = nop -- TODO(bernhard): ...
 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     emit (ALOAD_ x) = emit (ILOAD_ x)
 260     emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
 261     emit (ALOAD x) = emit (ILOAD x)
 262     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 263     emit (ASTORE_ x) = emit (ISTORE_ x)
 264     emit (ISTORE_ x) = do
 265         pop eax
 266         mov (Disp (cArgs_ x), ebp) eax
 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                       e -> error $ "LDCI... missing impl.: " ++ show e
 277         push value
 278     emit (GETFIELD x) = do
 279         offset <- emitFieldOffset x
 280         push (Disp (fromIntegral offset), eax) -- get field
 281     emit (PUTFIELD x) = do
 282         pop ebx -- value to write
 283         offset <- emitFieldOffset x
 284         mov (Disp (fromIntegral offset), eax) ebx -- set field
 285
 286     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 287     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 288     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 289     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 290     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 291     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 292     emit INEG = do pop eax; neg eax; push eax
 293     emit (IINC x imm) =
 294         add (Disp (cArgs x), ebp) (s8_w32 imm)
 295
 296     emit (IFNONNULL x) = emit (IF C_NE x)
 297     emit (IFNULL x) = emit (IF C_EQ x)
 298     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 299     emit (IF_ICMP cond _) = do
 300         pop eax -- value2
 301         pop ebx -- value1
 302         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 303         emitIF cond
 304
 305     emit (IF cond _) = do
 306         pop eax -- value1
 307         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 308         emitIF cond
 309
 310     emit (GOTO _ ) = do
 311         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 312         jmp $ getLabel sid lmap
 313
 314     emit RETURN = do mov esp ebp; pop ebp; ret
 315     emit ARETURN = emit IRETURN
 316     emit IRETURN = do pop eax; emit RETURN
 317     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 318
 319     emitFieldOffset :: Word16 -> CodeGen e s Int32
 320     emitFieldOffset x = do
 321         pop eax -- this pointer
 322         let (cname, fname) = buildFieldOffset cls x
 323         liftIO $ getFieldOffset cname fname
 324
 325     emitIF :: CMP -> CodeGen e s ()
 326     emitIF cond = let
 327       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 328       l = getLabel sid lmap
 329       in case cond of
 330         C_EQ -> je  l; C_NE -> jne l
 331         C_LT -> jl  l; C_GT -> jg  l
 332         C_GE -> jge l; C_LE -> jle l
 333
 334     callMalloc :: CodeGen e s ()
 335     callMalloc = do
 336         calladdr <- getCurrentOffset
 337         let w32_calladdr = 5 + calladdr
 338         let malloaddr = fromIntegral getMallocObjectAddr :: Word32
 339         call (malloaddr - w32_calladdr)
 340         add esp (4 :: Word32)
 341         push eax
 342
 343   -- for locals we use a different storage
 344   cArgs :: Word8 -> Word32
 345   cArgs x = if x' >= thisMethodArgCnt
 346       -- TODO(bernhard): maybe s/(-4)/(-8)/
 347       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 348       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 349     where x' = fromIntegral x
 350
 351   cArgs_ :: IMM -> Word32
 352   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 353
 354   thisMethodArgCnt :: Word32
 355   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 356     where
 357     (Just m) = lookupMethodSig method sig cls
 358     (MethodSignature args _) = sig
 359     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 360         then 0 else 1 -- one argument for the this pointer
 361
 362
 363   -- sign extension from w8 to w32 (over s8)
 364   --   unfortunately, hs-java is using Word8 everywhere (while
 365   --   it should be Int8 actually)
 366   s8_w32 :: Word8 -> Word32
 367   s8_w32 w8 = fromIntegral s8
 368     where s8 = fromIntegral w8 :: Int8
 369
 370   is8BitOffset :: Word32 -> Bool
 371   is8BitOffset w32 = s32 < 128 && s32 > (-127)
 372     where s32 = fromIntegral w32 :: Int32