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 "&mallocObject"
  38   mallocObjectAddr :: FunPtr (Int -> IO CUInt)
  39
  40 type EntryPoint = Ptr Word8
  41 type EntryPointOffset = Int
  42 type PatchInfo = (BlockID, EntryPointOffset)
  43
  44 type BBStarts = M.Map BlockID Int
  45
  46 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  47
  48
  49 emitFromBB :: B.ByteString -> MethodSignature -> Class Direct -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  50 emitFromBB method sig cls hmap =  do
  51         let keys = M.keys hmap
  52         llmap <- mapM (newNamedLabel . (++) "bb_" . show) keys
  53         let lmap = zip keys llmap
  54         ep <- getEntryPoint
  55         push ebp
  56         mov ebp esp
  57         -- TODO(bernhard): determine a reasonable value.
  58         --                 e.g. (locals used) * 4
  59         sub esp (0x60 :: Word32)
  60
  61         (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  62         d <- disassemble
  63         end <- getCodeOffset
  64         return ((ep, bbstarts, end, calls), d)
  65   where
  66   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  67   getLabel _ [] = error "label not found!"
  68   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  69
  70   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  71   efBB (bid, bb) calls bbstarts lmap =
  72         if M.member bid bbstarts then
  73           return (calls, bbstarts)
  74         else do
  75           bb_offset <- getCodeOffset
  76           let bbstarts' = M.insert bid bb_offset bbstarts
  77           defineLabel $ getLabel bid lmap
  78           cs <- mapM emit'' $ code bb
  79           let calls' = calls `M.union` M.fromList (catMaybes cs)
  80           case successor bb of
  81             Return -> return (calls', bbstarts')
  82             FallThrough t -> do
  83               -- TODO(bernhard): le dirty hax. see java/lang/Integer.toString(int, int)
  84               jmp (getLabel t lmap)
  85               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, TrapCause))
 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, StaticMethod l)
 116
 117     invokeEpilog :: Word16 -> Word32 -> (Bool -> TrapCause) -> CodeGen e s (Maybe (Word32, TrapCause))
 118     invokeEpilog cpidx offset trapcause = do
 119         -- make actual (indirect) call
 120         calladdr <- getCurrentOffset
 121         call (Disp offset, eax)
 122         -- discard arguments on stack (+4 for "this")
 123         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 124         when (argcnt > 0) (add esp argcnt)
 125         -- push result on stack if method has a return value
 126         when (methodHaveReturnValue cls cpidx) (push eax)
 127         let imm8 = is8BitOffset offset
 128         return $ Just (calladdr + (if imm8 then 3 else 6), trapcause imm8)
 129
 130     emit'' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 131     emit'' insn = newNamedLabel ("jvm_insn: " ++ show insn) >>= defineLabel >> emit' insn
 132
 133     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 134     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 135     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 136     emit' (INVOKEINTERFACE cpidx _) = do
 137         -- get methodInfo entry
 138         let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
 139         newNamedLabel (show mi) >>= defineLabel
 140         -- objref lives somewhere on the argument stack
 141         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 142         -- get method-table-ptr, keep it in eax (for trap handling)
 143         mov eax (Disp 0, eax)
 144         -- get interface-table-ptr
 145         mov ebx (Disp 0, eax)
 146         -- get method offset
 147         offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
 148         -- note, that "mi" has the wrong class reference here.
 149         -- we figure that out at run-time, in the methodpool,
 150         -- depending on the method-table-ptr
 151         invokeEpilog cpidx offset (`InterfaceMethod` mi)
 152     emit' (INVOKEVIRTUAL cpidx) = do
 153         -- get methodInfo entry
 154         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 155         newNamedLabel (show mi) >>= defineLabel
 156         -- objref lives somewhere on the argument stack
 157         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 158         -- get method-table-ptr
 159         mov eax (Disp 0, eax)
 160         -- get method offset
 161         let nameAndSig = methodname `B.append` encode msig
 162         offset <- liftIO $ getMethodOffset objname nameAndSig
 163         -- note, that "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         invokeEpilog cpidx offset (`VirtualMethod` 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, StaticField $ 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, StaticField $ 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 DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; 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 = -- TODO(bernhard): ...
 245         emit32 (0xffffffff :: Word32)
 246     emit I2C = do
 247       pop eax
 248       and eax (0x000000ff :: Word32)
 249       push eax
 250     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 251     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 252     emit ACONST_NULL = push (0 :: Word32)
 253     emit (ICONST_M1) = push ((-1) :: Word32)
 254     emit (ICONST_0) = push (0 :: Word32)
 255     emit (ICONST_1) = push (1 :: Word32)
 256     emit (ICONST_2) = push (2 :: Word32)
 257     emit (ICONST_3) = push (3 :: Word32)
 258     emit (ICONST_4) = push (4 :: Word32)
 259     emit (ICONST_5) = push (5 :: Word32)
 260
 261     emit (ALOAD_ x) = emit (ILOAD_ x)
 262     emit (ILOAD_ x) = emit (ILOAD $ cArgs_ x)
 263     emit (ALOAD x) = emit (ILOAD x)
 264     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 265
 266     emit (ASTORE_ x) = emit (ISTORE_ x)
 267     emit (ISTORE_ x) = emit (ISTORE $ cArgs_ x)
 268     emit (ASTORE x) = emit (ISTORE x)
 269     emit (ISTORE x) = do
 270         pop eax
 271         mov (Disp (cArgs x), ebp) eax
 272
 273     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 274     emit (LDC2 x) = do
 275         value <- case constsPool cls M.! x of
 276                       (CString s) -> liftIO $ getUniqueStringAddr s
 277                       (CInteger i) -> liftIO $ return i
 278                       e -> error $ "LDCI... missing impl.: " ++ show e
 279         push value
 280     emit (GETFIELD x) = do
 281         offset <- emitFieldOffset x
 282         push (Disp (fromIntegral offset), eax) -- get field
 283     emit (PUTFIELD x) = do
 284         pop ebx -- value to write
 285         offset <- emitFieldOffset x
 286         mov (Disp (fromIntegral offset), eax) ebx -- set field
 287
 288     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 289     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 290     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 291     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 292     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 293     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 294     emit IUSHR = do pop ecx; pop eax; sar eax cl; push eax
 295     emit INEG = do pop eax; neg eax; push eax
 296     emit (IINC x imm) =
 297         add (Disp (cArgs x), ebp) (s8_w32 imm)
 298
 299     emit (IFNONNULL x) = emit (IF C_NE x)
 300     emit (IFNULL x) = emit (IF C_EQ x)
 301     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 302     emit (IF_ICMP cond _) = do
 303         pop eax -- value2
 304         pop ebx -- value1
 305         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 306         emitIF cond
 307
 308     emit (IF cond _) = do
 309         pop eax -- value1
 310         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 311         emitIF cond
 312
 313     emit (GOTO _ ) = do
 314         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 315         jmp $ getLabel sid lmap
 316
 317     emit RETURN = do mov esp ebp; pop ebp; ret
 318     emit ARETURN = emit IRETURN
 319     emit IRETURN = do pop eax; emit RETURN
 320     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 321
 322     emitFieldOffset :: Word16 -> CodeGen e s Int32
 323     emitFieldOffset x = do
 324         pop eax -- this pointer
 325         let (cname, fname) = buildFieldOffset cls x
 326         liftIO $ getFieldOffset cname fname
 327
 328     emitIF :: CMP -> CodeGen e s ()
 329     emitIF cond = let
 330       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 331       l = getLabel sid lmap
 332       sid2 = case successor bb of TwoTarget t _ -> t; _ -> error "bad"
 333       l2 = getLabel sid2 lmap
 334       in do
 335         case cond of
 336           C_EQ -> je  l; C_NE -> jne l
 337           C_LT -> jl  l; C_GT -> jg  l
 338           C_GE -> jge l; C_LE -> jle l
 339         -- TODO(bernhard): ugly workaround, to get broken emitBB working
 340         --  (it didn't work for gnu/classpath/SystemProperties.java)
 341         jmp l2
 342
 343
 344     callMalloc :: CodeGen e s ()
 345     callMalloc = do
 346         call mallocObjectAddr
 347         add esp (4 :: Word32)
 348         push eax
 349
 350   -- for locals we use a different storage
 351   cArgs :: Word8 -> Word32
 352   cArgs x = if x' >= thisMethodArgCnt
 353       -- TODO(bernhard): maybe s/(-4)/(-8)/
 354       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 355       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 356     where x' = fromIntegral x
 357
 358   cArgs_ :: IMM -> Word8
 359   cArgs_ x = case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 360
 361   thisMethodArgCnt :: Word32
 362   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 363     where
 364     m = fromJust $ lookupMethodSig method sig cls
 365     (MethodSignature args _) = sig
 366     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 367         then 0 else 1 -- one argument for the this pointer
 368
 369
 370   -- sign extension from w8 to w32 (over s8)
 371   --   unfortunately, hs-java is using Word8 everywhere (while
 372   --   it should be Int8 actually)
 373   s8_w32 :: Word8 -> Word32
 374   s8_w32 w8 = fromIntegral s8
 375     where s8 = fromIntegral w8 :: Int8
 376
 377   is8BitOffset :: Word32 -> Bool
 378   is8BitOffset w32 = s32 < 128 && s32 > (-127)
 379     where s32 = fromIntegral w32 :: Int32