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         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  52         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  53         ep <- getEntryPoint
  54         push ebp
  55         mov ebp esp
  56         -- TODO(bernhard): determine a reasonable value.
  57         --                 e.g. (locals used) * 4
  58         sub esp (0x60 :: Word32)
  59
  60         (calls, bbstarts) <- efBB (0, hmap M.! 0) M.empty M.empty lmap
  61         d <- disassemble
  62         end <- getCodeOffset
  63         return ((ep, bbstarts, end, calls), d)
  64   where
  65   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  66   getLabel _ [] = error "label 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 -> efBB (t, hmap M.! t) calls' bbstarts' lmap
  82             OneTarget t -> efBB (t, hmap M.! t) calls' bbstarts' lmap
  83             TwoTarget t1 t2 -> do
  84               (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
  85               efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
  86     -- TODO(bernhard): also use metainformation
  87     -- TODO(bernhard): implement `emit' as function which accepts a list of
  88     --                 instructions, so we can use patterns for optimizations
  89     where
  90     getCurrentOffset :: CodeGen e s Word32
  91     getCurrentOffset = do
  92       ep <- getEntryPoint
  93       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
  94       offset <- getCodeOffset
  95       return $ w32_ep + fromIntegral offset
  96
  97     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapCause))
  98     emitInvoke cpidx hasThis = do
  99         let l = buildMethodID cls cpidx
 100         calladdr <- getCurrentOffset
 101         newNamedLabel (show l) >>= defineLabel
 102         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 103         -- place a nop at the end, therefore the disasm doesn't screw up
 104         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 105         -- discard arguments on stack
 106         let argcnt = ((if hasThis then 1 else 0) + methodGetArgsCount cls cpidx) * 4
 107         when (argcnt > 0) (add esp argcnt)
 108         -- push result on stack if method has a return value
 109         when (methodHaveReturnValue cls cpidx) (push eax)
 110         -- +2 is for correcting eip in trap context
 111         return $ Just (calladdr + 2, StaticMethod l)
 112
 113     invokeEpilog :: Word16 -> Word32 -> (Bool -> TrapCause) -> CodeGen e s (Maybe (Word32, TrapCause))
 114     invokeEpilog cpidx offset trapcause = do
 115         -- make actual (indirect) call
 116         calladdr <- getCurrentOffset
 117         call (Disp offset, eax)
 118         -- discard arguments on stack (+4 for "this")
 119         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 120         when (argcnt > 0) (add esp argcnt)
 121         -- push result on stack if method has a return value
 122         when (methodHaveReturnValue cls cpidx) (push eax)
 123         let imm8 = is8BitOffset offset
 124         return $ Just (calladdr + (if imm8 then 3 else 6), trapcause imm8)
 125
 126     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapCause))
 127     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 128     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 129     emit' (INVOKEINTERFACE cpidx _) = do
 130         -- get methodInfo entry
 131         let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
 132         newNamedLabel (show mi) >>= defineLabel
 133         -- objref lives somewhere on the argument stack
 134         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 135         -- get method-table-ptr, keep it in eax (for trap handling)
 136         mov eax (Disp 0, eax)
 137         -- get interface-table-ptr
 138         mov ebx (Disp 0, eax)
 139         -- get method offset
 140         offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
 141         -- note, that "mi" has the wrong class reference here.
 142         -- we figure that out at run-time, in the methodpool,
 143         -- depending on the method-table-ptr
 144         invokeEpilog cpidx offset (\x -> InterfaceMethod x mi)
 145     emit' (INVOKEVIRTUAL cpidx) = do
 146         -- get methodInfo entry
 147         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 148         newNamedLabel (show mi) >>= defineLabel
 149         -- objref lives somewhere on the argument stack
 150         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 151         -- get method-table-ptr
 152         mov eax (Disp 0, eax)
 153         -- get method offset
 154         let nameAndSig = methodname `B.append` encode msig
 155         offset <- liftIO $ getMethodOffset objname nameAndSig
 156         -- note, that "mi" has the wrong class reference here.
 157         -- we figure that out at run-time, in the methodpool,
 158         -- depending on the method-table-ptr
 159         invokeEpilog cpidx offset (\x -> VirtualMethod x mi)
 160     emit' (PUTSTATIC cpidx) = do
 161         pop eax
 162         trapaddr <- getCurrentOffset
 163         mov (Addr 0x00000000) eax -- it's a trap
 164         return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 165     emit' (GETSTATIC cpidx) = do
 166         trapaddr <- getCurrentOffset
 167         mov eax (Addr 0x00000000) -- it's a trap
 168         push eax
 169         return $ Just (trapaddr, StaticField $ buildStaticFieldID cls cpidx)
 170     emit' insn = emit insn >> return Nothing
 171
 172     emit :: J.Instruction -> CodeGen e s ()
 173     emit POP = add esp (4 :: Word32) -- drop value
 174     emit DUP = push (Disp 0, esp)
 175     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 176     emit DUP_X2 = do pop eax; pop ebx; pop ecx; push eax; push ecx; push ebx; push eax
 177     emit AASTORE = emit IASTORE
 178     emit IASTORE = do
 179         pop eax -- value
 180         pop ebx -- offset
 181         add ebx (1 :: Word32)
 182         pop ecx -- aref
 183         mov (ecx, ebx, S4) eax
 184     emit CASTORE = do
 185         pop eax -- value
 186         pop ebx -- offset
 187         add ebx (1 :: Word32)
 188         pop ecx -- aref
 189         mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 190     emit AALOAD = emit IALOAD
 191     emit IALOAD = do
 192         pop ebx -- offset
 193         add ebx (1 :: Word32)
 194         pop ecx -- aref
 195         push (ecx, ebx, S4)
 196     emit CALOAD = do
 197         pop ebx -- offset
 198         add ebx (1 :: Word32)
 199         pop ecx -- aref
 200         push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 201     emit ARRAYLENGTH = do
 202         pop eax
 203         push (Disp 0, eax)
 204     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 205     emit (NEWARRAY typ) = do
 206         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 207                     T_INT -> 4
 208                     T_CHAR -> 2
 209                     _ -> error "newarray: type not implemented yet"
 210         -- get length from stack, but leave it there
 211         mov eax (Disp 0, esp)
 212         mov ebx (tsize :: Word32)
 213         -- multiple amount with native size of one element
 214         mul ebx -- result is in eax
 215         add eax (4 :: Word32) -- for "length" entry
 216         -- push amount of bytes to allocate
 217         push eax
 218         callMalloc
 219         pop eax -- ref to arraymemory
 220         pop ebx -- length
 221         mov (Disp 0, eax) ebx -- store length at offset 0
 222         push eax -- push ref again
 223     emit (NEW objidx) = do
 224         let objname = buildClassID cls objidx
 225         amount <- liftIO $ getObjectSize objname
 226         push (amount :: Word32)
 227         callMalloc
 228         -- TODO(bernhard): save reference somewhere for GC
 229         -- set method table pointer
 230         mtable <- liftIO $ getMethodTable objname
 231         mov (Disp 0, eax) mtable
 232     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 233     -- TODO(bernhard): ...
 234     emit (INSTANCEOF _) = do
 235       pop eax
 236       push (1 :: Word32)
 237     emit ATHROW = nop -- TODO(bernhard): ...
 238     emit I2C = do
 239       pop eax
 240       and eax (0x000000ff :: Word32)
 241       push eax
 242     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 243     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 244     emit ACONST_NULL = push (0 :: Word32)
 245     emit (ICONST_M1) = push ((-1) :: Word32)
 246     emit (ICONST_0) = push (0 :: Word32)
 247     emit (ICONST_1) = push (1 :: Word32)
 248     emit (ICONST_2) = push (2 :: Word32)
 249     emit (ICONST_3) = push (3 :: Word32)
 250     emit (ICONST_4) = push (4 :: Word32)
 251     emit (ICONST_5) = push (5 :: Word32)
 252     emit (ALOAD_ x) = emit (ILOAD_ x)
 253     emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
 254     emit (ALOAD x) = emit (ILOAD x)
 255     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 256     emit (ASTORE_ x) = emit (ISTORE_ x)
 257     emit (ISTORE_ x) = do
 258         pop eax
 259         mov (Disp (cArgs_ x), ebp) eax
 260     emit (ASTORE x) = emit (ISTORE x)
 261     emit (ISTORE x) = do
 262         pop eax
 263         mov (Disp (cArgs x), ebp) eax
 264
 265     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 266     emit (LDC2 x) = do
 267         value <- case constsPool cls M.! x of
 268                       (CString s) -> liftIO $ getUniqueStringAddr s
 269                       e -> error $ "LDCI... missing impl.: " ++ show e
 270         push value
 271     emit (GETFIELD x) = do
 272         offset <- emitFieldOffset x
 273         push (Disp (fromIntegral offset), eax) -- get field
 274     emit (PUTFIELD x) = do
 275         pop ebx -- value to write
 276         offset <- emitFieldOffset x
 277         mov (Disp (fromIntegral offset), eax) ebx -- set field
 278
 279     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 280     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 281     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 282     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 283     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 284     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 285     emit INEG = do pop eax; neg eax; push eax
 286     emit (IINC x imm) =
 287         add (Disp (cArgs x), ebp) (s8_w32 imm)
 288
 289     emit (IFNONNULL x) = emit (IF C_NE x)
 290     emit (IFNULL x) = emit (IF C_EQ x)
 291     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 292     emit (IF_ICMP cond _) = do
 293         pop eax -- value2
 294         pop ebx -- value1
 295         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 296         emitIF cond
 297
 298     emit (IF cond _) = do
 299         pop eax -- value1
 300         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 301         emitIF cond
 302
 303     emit (GOTO _ ) = do
 304         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 305         jmp $ getLabel sid lmap
 306
 307     emit RETURN = do mov esp ebp; pop ebp; ret
 308     emit ARETURN = emit IRETURN
 309     emit IRETURN = do pop eax; emit RETURN
 310     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 311
 312     emitFieldOffset :: Word16 -> CodeGen e s Int32
 313     emitFieldOffset x = do
 314         pop eax -- this pointer
 315         let (cname, fname) = buildFieldOffset cls x
 316         liftIO $ getFieldOffset cname fname
 317
 318     emitIF :: CMP -> CodeGen e s ()
 319     emitIF cond = let
 320       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 321       l = getLabel sid lmap
 322       in case cond of
 323         C_EQ -> je  l; C_NE -> jne l
 324         C_LT -> jl  l; C_GT -> jg  l
 325         C_GE -> jge l; C_LE -> jle l
 326
 327     callMalloc :: CodeGen e s ()
 328     callMalloc = do
 329         call mallocObjectAddr
 330         add esp (4 :: Word32)
 331         push eax
 332
 333   -- for locals we use a different storage
 334   cArgs :: Word8 -> Word32
 335   cArgs x = if x' >= thisMethodArgCnt
 336       -- TODO(bernhard): maybe s/(-4)/(-8)/
 337       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 338       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 339     where x' = fromIntegral x
 340
 341   cArgs_ :: IMM -> Word32
 342   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 343
 344   thisMethodArgCnt :: Word32
 345   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 346     where
 347     (Just m) = lookupMethodSig method sig cls
 348     (MethodSignature args _) = sig
 349     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 350         then 0 else 1 -- one argument for the this pointer
 351
 352
 353   -- sign extension from w8 to w32 (over s8)
 354   --   unfortunately, hs-java is using Word8 everywhere (while
 355   --   it should be Int8 actually)
 356   s8_w32 :: Word8 -> Word32
 357   s8_w32 w8 = fromIntegral s8
 358     where s8 = fromIntegral w8 :: Int8
 359
 360   is8BitOffset :: Word32 -> Bool
 361   is8BitOffset w32 = s32 < 128 && s32 > (-127)
 362     where s32 = fromIntegral w32 :: Int32