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