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