Mate/X86CodeGen.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 #include "debug.h"
   5 module Mate.X86CodeGen where
   6
   7 import Data.Binary
   8 import Data.BinaryState
   9 import Data.Int
  10 import Data.Maybe
  11 import qualified Data.Map as M
  12 import qualified Data.Set as S
  13 import qualified Data.ByteString.Lazy as B
  14 import Control.Monad
  15
  16 import Foreign hiding (xor)
  17 import Foreign.C.Types
  18
  19 import qualified JVM.Assembler as J
  20 import JVM.Assembler hiding (Instruction)
  21 import JVM.ClassFile
  22
  23 import Harpy
  24 import Harpy.X86Disassembler
  25
  26 import Mate.BasicBlocks
  27 import Mate.Types
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30 import Mate.Strings
  31
  32
  33 foreign import ccall "dynamic"
  34    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> CInt -> CInt -> IO CInt
  35
  36 foreign import ccall "getMallocObjectAddr"
  37   getMallocObjectAddr :: CUInt
  38
  39 foreign import ccall "register_signal"
  40   register_signal :: IO ()
  41
  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 -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  53 emitFromBB method 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         return $ Just (calladdr, MI l)
 114
 115     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 116     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 117     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 118     emit' (INVOKEINTERFACE cpidx _) = do
 119         -- get methodInfo entry
 120         let mi@(MethodInfo methodname ifacename msig@(MethodSignature args _)) = buildMethodID cls cpidx
 121         newNamedLabel (show mi) >>= defineLabel
 122         -- objref lives somewhere on the argument stack
 123         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 124         -- get method-table-ptr, keep it in eax (for trap handling)
 125         mov eax (Disp 0, eax)
 126         -- get interface-table-ptr
 127         mov ebx (Disp 0, eax)
 128         -- get method offset
 129         offset <- liftIO $ getInterfaceMethodOffset ifacename methodname (encode msig)
 130         -- make actual (indirect) call
 131         calladdr <- getCurrentOffset
 132         call (Disp offset, ebx)
 133         -- discard arguments on stack (+4 for "this")
 134         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 135         when (argcnt > 0) (add esp argcnt)
 136         -- push result on stack if method has a return value
 137         when (methodHaveReturnValue cls cpidx) (push eax)
 138         -- note, the "mi" has the wrong class reference here.
 139         -- we figure that out at run-time, in the methodpool,
 140         -- depending on the method-table-ptr
 141         return $ Just (calladdr, II mi)
 142     emit' (INVOKEVIRTUAL cpidx) = do
 143         -- get methodInfo entry
 144         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 145         newNamedLabel (show mi) >>= defineLabel
 146         -- objref lives somewhere on the argument stack
 147         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 148         -- get method-table-ptr
 149         mov eax (Disp 0, eax)
 150         -- get method offset
 151         let nameAndSig = methodname `B.append` encode msig
 152         offset <- liftIO $ getMethodOffset objname nameAndSig
 153         -- make actual (indirect) call
 154         calladdr <- getCurrentOffset
 155         call (Disp offset, eax)
 156         -- discard arguments on stack (+4 for "this")
 157         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 158         when (argcnt > 0) (add esp argcnt)
 159         -- push result on stack if method has a return value
 160         when (methodHaveReturnValue cls cpidx) (push eax)
 161         -- note, the "mi" has the wrong class reference here.
 162         -- we figure that out at run-time, in the methodpool,
 163         -- depending on the method-table-ptr
 164         return $ Just (calladdr, VI mi)
 165     emit' (PUTSTATIC cpidx) = do
 166         pop eax
 167         trapaddr <- getCurrentOffset
 168         mov (Addr 0x00000000) eax -- it's a trap
 169         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 170     emit' (GETSTATIC cpidx) = do
 171         trapaddr <- getCurrentOffset
 172         mov eax (Addr 0x00000000) -- it's a trap
 173         push eax
 174         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 175     emit' insn = emit insn >> return Nothing
 176
 177     emit :: J.Instruction -> CodeGen e s ()
 178     emit POP = add esp (4 :: Word32) -- drop value
 179     emit DUP = push (Disp 0, esp)
 180     emit AASTORE = emit IASTORE
 181     emit IASTORE = do
 182         pop eax -- value
 183         pop ebx -- offset
 184         add ebx (1 :: Word32)
 185         pop ecx -- aref
 186         mov (ecx, ebx, S4) eax
 187     emit AALOAD = emit IALOAD
 188     emit IALOAD = do
 189         pop ebx -- offset
 190         add ebx (1 :: Word32)
 191         pop ecx -- aref
 192         push (ecx, ebx, S4)
 193     emit ARRAYLENGTH = do
 194         pop eax
 195         push (Disp 0, eax)
 196     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 197     emit (NEWARRAY typ) = do
 198         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 199                     T_INT -> 4
 200                     _ -> error "newarray: type not implemented yet"
 201         -- get length from stack, but leave it there
 202         mov eax (Disp 0, esp)
 203         mov ebx (tsize :: Word32)
 204         -- multiple amount with native size of one element
 205         mul ebx -- result is in eax
 206         add eax (4 :: Word32) -- for "length" entry
 207         -- push amount of bytes to allocate
 208         push eax
 209         callMalloc
 210         pop eax -- ref to arraymemory
 211         pop ebx -- length
 212         mov (Disp 0, eax) ebx -- store length at offset 0
 213         push eax -- push ref again
 214     emit (NEW objidx) = do
 215         let objname = buildClassID cls objidx
 216         amount <- liftIO $ getObjectSize objname
 217         push (amount :: Word32)
 218         callMalloc
 219         -- TODO(bernhard): save reference somewhere for GC
 220         -- set method table pointer
 221         mtable <- liftIO $ getMethodTable objname
 222         mov (Disp 0, eax) mtable
 223     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 224     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 225     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 226     emit (ICONST_0) = push (0 :: Word32)
 227     emit (ICONST_1) = push (1 :: Word32)
 228     emit (ICONST_2) = push (2 :: Word32)
 229     emit (ICONST_3) = push (3 :: Word32)
 230     emit (ICONST_4) = push (4 :: Word32)
 231     emit (ICONST_5) = push (5 :: Word32)
 232     emit (ALOAD_ x) = emit (ILOAD_ x)
 233     emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
 234     emit (ALOAD x) = emit (ILOAD x)
 235     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 236     emit (ASTORE_ x) = emit (ISTORE_ x)
 237     emit (ISTORE_ x) = do
 238         pop eax
 239         mov (Disp (cArgs_ x), ebp) eax
 240     emit (ASTORE x) = emit (ISTORE x)
 241     emit (ISTORE x) = do
 242         pop eax
 243         mov (Disp (cArgs x), ebp) eax
 244
 245     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 246     emit (LDC2 x) = do
 247         value <- case constsPool cls M.! x of
 248                       (CString s) -> liftIO $ getUniqueStringAddr s
 249                       _ -> error "LDCI... missing impl."
 250         push value
 251     emit (GETFIELD x) = do
 252         offset <- emitFieldOffset x
 253         push (Disp (fromIntegral offset), eax) -- get field
 254     emit (PUTFIELD x) = do
 255         pop ebx -- value to write
 256         offset <- emitFieldOffset x
 257         mov (Disp (fromIntegral offset), eax) ebx -- set field
 258
 259     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 260     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 261     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 262     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 263     emit (IINC x imm) =
 264         add (Disp (cArgs x), ebp) (s8_w32 imm)
 265
 266     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 267     emit (IF_ICMP cond _) = do
 268         pop eax -- value2
 269         pop ebx -- value1
 270         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 271         emitIF cond
 272
 273     emit (IF cond _) = do
 274         pop eax -- value1
 275         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 276         emitIF cond
 277
 278     emit (GOTO _ ) = do
 279         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 280         jmp $ getLabel sid lmap
 281
 282     emit RETURN = do mov esp ebp; pop ebp; ret
 283     emit ARETURN = emit IRETURN
 284     emit IRETURN = do pop eax; emit RETURN
 285     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 286
 287     emitFieldOffset :: Word16 -> CodeGen e s Int32
 288     emitFieldOffset x = do
 289         pop eax -- this pointer
 290         let (cname, fname) = buildFieldOffset cls x
 291         liftIO $ getFieldOffset cname fname
 292
 293     emitIF :: CMP -> CodeGen e s ()
 294     emitIF cond = let
 295       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 296       l = getLabel sid lmap
 297       in case cond of
 298         C_EQ -> je  l; C_NE -> jne l
 299         C_LT -> jl  l; C_GT -> jg  l
 300         C_GE -> jge l; C_LE -> jle l
 301
 302     callMalloc :: CodeGen e s ()
 303     callMalloc = do
 304         calladdr <- getCurrentOffset
 305         let w32_calladdr = 5 + calladdr
 306         let malloaddr = fromIntegral getMallocObjectAddr :: Word32
 307         call (malloaddr - w32_calladdr)
 308         add esp (4 :: Word32)
 309         push eax
 310
 311   -- for locals we use a different storage
 312   cArgs :: Word8 -> Word32
 313   cArgs x = if x' >= thisMethodArgCnt
 314       -- TODO(bernhard): maybe s/(-4)/(-8)/
 315       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 316       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 317     where x' = fromIntegral x
 318
 319   cArgs_ :: IMM -> Word32
 320   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 321
 322   thisMethodArgCnt :: Word32
 323   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 324     where
 325     (Just m) = lookupMethod method cls
 326     (MethodSignature args _) = methodSignature m
 327     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 328         then 0 else 1 -- one argument for the this pointer
 329
 330
 331   -- sign extension from w8 to w32 (over s8)
 332   --   unfortunately, hs-java is using Word8 everywhere (while
 333   --   it should be Int8 actually)
 334   s8_w32 :: Word8 -> Word32
 335   s8_w32 w8 = fromIntegral s8
 336     where s8 = fromIntegral w8 :: Int8