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         return $ Just (calladdr, II mi)
 143     emit' (INVOKEVIRTUAL cpidx) = do
 144         -- get methodInfo entry
 145         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 146         newNamedLabel (show mi) >>= defineLabel
 147         -- objref lives somewhere on the argument stack
 148         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 149         -- get method-table-ptr
 150         mov eax (Disp 0, eax)
 151         -- get method offset
 152         let nameAndSig = methodname `B.append` encode msig
 153         offset <- liftIO $ getMethodOffset objname nameAndSig
 154         -- make actual (indirect) call
 155         calladdr <- getCurrentOffset
 156         call (Disp offset, eax)
 157         -- discard arguments on stack (+4 for "this")
 158         let argcnt = 4 + 4 * methodGetArgsCount cls cpidx
 159         when (argcnt > 0) (add esp argcnt)
 160         -- push result on stack if method has a return value
 161         when (methodHaveReturnValue cls cpidx) (push eax)
 162         -- note, the "mi" has the wrong class reference here.
 163         -- we figure that out at run-time, in the methodpool,
 164         -- depending on the method-table-ptr
 165         return $ Just (calladdr, VI mi)
 166     emit' (PUTSTATIC cpidx) = do
 167         pop eax
 168         trapaddr <- getCurrentOffset
 169         mov (Addr 0x00000000) eax -- it's a trap
 170         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 171     emit' (GETSTATIC cpidx) = do
 172         trapaddr <- getCurrentOffset
 173         mov eax (Addr 0x00000000) -- it's a trap
 174         push eax
 175         return $ Just (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 176     emit' insn = emit insn >> return Nothing
 177
 178     emit :: J.Instruction -> CodeGen e s ()
 179     emit POP = add esp (4 :: Word32) -- drop value
 180     emit DUP = push (Disp 0, esp)
 181     emit DUP_X1 = do pop eax; pop ebx; push eax; push ebx; push eax
 182     emit AASTORE = emit IASTORE
 183     emit IASTORE = do
 184         pop eax -- value
 185         pop ebx -- offset
 186         add ebx (1 :: Word32)
 187         pop ecx -- aref
 188         mov (ecx, ebx, S4) eax
 189     emit CASTORE = do
 190         pop eax -- value
 191         pop ebx -- offset
 192         add ebx (1 :: Word32)
 193         pop ecx -- aref
 194         mov (ecx, ebx, S1) eax -- TODO(bernhard): char is two byte
 195     emit AALOAD = emit IALOAD
 196     emit IALOAD = do
 197         pop ebx -- offset
 198         add ebx (1 :: Word32)
 199         pop ecx -- aref
 200         push (ecx, ebx, S4)
 201     emit CALOAD = do
 202         pop ebx -- offset
 203         add ebx (1 :: Word32)
 204         pop ecx -- aref
 205         push (ecx, ebx, S1) -- TODO(bernhard): char is two byte
 206     emit ARRAYLENGTH = do
 207         pop eax
 208         push (Disp 0, eax)
 209     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 210     emit (NEWARRAY typ) = do
 211         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 212                     T_INT -> 4
 213                     T_CHAR -> 2
 214                     _ -> error "newarray: type not implemented yet"
 215         -- get length from stack, but leave it there
 216         mov eax (Disp 0, esp)
 217         mov ebx (tsize :: Word32)
 218         -- multiple amount with native size of one element
 219         mul ebx -- result is in eax
 220         add eax (4 :: Word32) -- for "length" entry
 221         -- push amount of bytes to allocate
 222         push eax
 223         callMalloc
 224         pop eax -- ref to arraymemory
 225         pop ebx -- length
 226         mov (Disp 0, eax) ebx -- store length at offset 0
 227         push eax -- push ref again
 228     emit (NEW objidx) = do
 229         let objname = buildClassID cls objidx
 230         amount <- liftIO $ getObjectSize objname
 231         push (amount :: Word32)
 232         callMalloc
 233         -- TODO(bernhard): save reference somewhere for GC
 234         -- set method table pointer
 235         mtable <- liftIO $ getMethodTable objname
 236         mov (Disp 0, eax) mtable
 237     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 238     emit ATHROW = nop -- TODO(bernhard): ...
 239     emit I2C = do
 240       pop eax
 241       and eax (0x000000ff :: Word32)
 242       push eax
 243     emit (BIPUSH val) = push (fromIntegral val :: Word32)
 244     emit (SIPUSH val) = push (fromIntegral (fromIntegral val :: Int16) :: Word32)
 245     emit ACONST_NULL = push (0 :: Word32)
 246     emit (ICONST_M1) = push ((-1) :: Word32)
 247     emit (ICONST_0) = push (0 :: Word32)
 248     emit (ICONST_1) = push (1 :: Word32)
 249     emit (ICONST_2) = push (2 :: Word32)
 250     emit (ICONST_3) = push (3 :: Word32)
 251     emit (ICONST_4) = push (4 :: Word32)
 252     emit (ICONST_5) = push (5 :: Word32)
 253     emit (ALOAD_ x) = emit (ILOAD_ x)
 254     emit (ILOAD_ x) = push (Disp (cArgs_ x), ebp)
 255     emit (ALOAD x) = emit (ILOAD x)
 256     emit (ILOAD x) = push (Disp (cArgs x), ebp)
 257     emit (ASTORE_ x) = emit (ISTORE_ x)
 258     emit (ISTORE_ x) = do
 259         pop eax
 260         mov (Disp (cArgs_ x), ebp) eax
 261     emit (ASTORE x) = emit (ISTORE x)
 262     emit (ISTORE x) = do
 263         pop eax
 264         mov (Disp (cArgs x), ebp) eax
 265
 266     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 267     emit (LDC2 x) = do
 268         value <- case constsPool cls M.! x of
 269                       (CString s) -> liftIO $ getUniqueStringAddr s
 270                       e -> error $ "LDCI... missing impl.: " ++ show e
 271         push value
 272     emit (GETFIELD x) = do
 273         offset <- emitFieldOffset x
 274         push (Disp (fromIntegral offset), eax) -- get field
 275     emit (PUTFIELD x) = do
 276         pop ebx -- value to write
 277         offset <- emitFieldOffset x
 278         mov (Disp (fromIntegral offset), eax) ebx -- set field
 279
 280     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 281     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 282     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 283     emit IDIV = do pop ebx; pop eax; xor edx edx; div ebx; push eax
 284     emit IREM = do pop ebx; pop eax; xor edx edx; div ebx; push edx
 285     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 286     emit INEG = do pop eax; neg eax; push eax
 287     emit (IINC x imm) =
 288         add (Disp (cArgs x), ebp) (s8_w32 imm)
 289
 290     emit (IFNONNULL x) = emit (IF C_NE x)
 291     emit (IFNULL x) = emit (IF C_EQ x)
 292     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 293     emit (IF_ICMP cond _) = do
 294         pop eax -- value2
 295         pop ebx -- value1
 296         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 297         emitIF cond
 298
 299     emit (IF cond _) = do
 300         pop eax -- value1
 301         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 302         emitIF cond
 303
 304     emit (GOTO _ ) = do
 305         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 306         jmp $ getLabel sid lmap
 307
 308     emit RETURN = do mov esp ebp; pop ebp; ret
 309     emit ARETURN = emit IRETURN
 310     emit IRETURN = do pop eax; emit RETURN
 311     emit invalid = error $ "insn not implemented yet: " ++ show invalid
 312
 313     emitFieldOffset :: Word16 -> CodeGen e s Int32
 314     emitFieldOffset x = do
 315         pop eax -- this pointer
 316         let (cname, fname) = buildFieldOffset cls x
 317         liftIO $ getFieldOffset cname fname
 318
 319     emitIF :: CMP -> CodeGen e s ()
 320     emitIF cond = let
 321       sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 322       l = getLabel sid lmap
 323       in case cond of
 324         C_EQ -> je  l; C_NE -> jne l
 325         C_LT -> jl  l; C_GT -> jg  l
 326         C_GE -> jge l; C_LE -> jle l
 327
 328     callMalloc :: CodeGen e s ()
 329     callMalloc = do
 330         calladdr <- getCurrentOffset
 331         let w32_calladdr = 5 + calladdr
 332         let malloaddr = fromIntegral getMallocObjectAddr :: Word32
 333         call (malloaddr - w32_calladdr)
 334         add esp (4 :: Word32)
 335         push eax
 336
 337   -- for locals we use a different storage
 338   cArgs :: Word8 -> Word32
 339   cArgs x = if x' >= thisMethodArgCnt
 340       -- TODO(bernhard): maybe s/(-4)/(-8)/
 341       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 342       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 343     where x' = fromIntegral x
 344
 345   cArgs_ :: IMM -> Word32
 346   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 347
 348   thisMethodArgCnt :: Word32
 349   thisMethodArgCnt = isNonStatic + fromIntegral (length args)
 350     where
 351     (Just m) = lookupMethodSig method sig cls
 352     (MethodSignature args _) = sig
 353     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 354         then 0 else 1 -- one argument for the this pointer
 355
 356
 357   -- sign extension from w8 to w32 (over s8)
 358   --   unfortunately, hs-java is using Word8 everywhere (while
 359   --   it should be Int8 actually)
 360   s8_w32 :: Word8 -> Word32
 361   s8_w32 w8 = fromIntegral s8
 362     where s8 = fromIntegral w8 :: Int8