Mate/X86CodeGen.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 module Mate.X86CodeGen where
   5
   6 import Data.Binary
   7 import Data.BinaryState
   8 import Data.Int
   9 import Data.Maybe
  10 import qualified Data.Map as M
  11 import qualified Data.Set as S
  12 import qualified Data.ByteString.Lazy as B
  13 import Control.Monad
  14
  15 import Foreign hiding (xor)
  16 import Foreign.C.Types
  17
  18 import qualified JVM.Assembler as J
  19 import JVM.Assembler hiding (Instruction)
  20 import JVM.ClassFile
  21
  22 import Harpy
  23 import Harpy.X86Disassembler
  24
  25 import Mate.BasicBlocks
  26 import Mate.Types
  27 import Mate.Utilities
  28 import Mate.ClassPool
  29 import Mate.Strings
  30
  31
  32 foreign import ccall "dynamic"
  33    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
  34
  35 foreign import ccall "getMallocAddr"
  36   getMallocAddr :: CUInt
  37
  38 foreign import ccall "register_signal"
  39   register_signal :: IO ()
  40
  41
  42 type EntryPoint = Ptr Word8
  43 type EntryPointOffset = Int
  44 type PatchInfo = (BlockID, EntryPointOffset)
  45
  46 type BBStarts = M.Map BlockID Int
  47
  48 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  49
  50
  51 emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  52 emitFromBB method cls hmap =  do
  53         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  54         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  55         ep <- getEntryPoint
  56         push ebp
  57         mov ebp esp
  58         -- TODO(bernhard): determine a reasonable value.
  59         --                 e.g. (locals used) * 4
  60         sub esp (0x60 :: Word32)
  61
  62         (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
  63         d <- disassemble
  64         end <- getCodeOffset
  65         return ((ep, bbstarts, end, calls), d)
  66   where
  67   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  68   getLabel _ [] = error "label not found!"
  69   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  70
  71   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  72   efBB (bid, bb) calls bbstarts lmap =
  73         if M.member bid bbstarts then
  74           return (calls, bbstarts)
  75         else do
  76           bb_offset <- getCodeOffset
  77           let bbstarts' = M.insert bid bb_offset bbstarts
  78           defineLabel $ getLabel bid lmap
  79           cs <- mapM emit' $ code bb
  80           let calls' = calls `M.union` (M.fromList $ catMaybes cs)
  81           case successor bb of
  82             Return -> return (calls', bbstarts')
  83             FallThrough t -> do
  84               efBB (t, hmap M.! t) calls' bbstarts' lmap
  85             OneTarget t -> do
  86               efBB (t, hmap M.! t) calls' bbstarts' lmap
  87             TwoTarget t1 t2 -> do
  88               (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
  89               efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
  90     -- TODO(bernhard): also use metainformation
  91     -- TODO(bernhard): implement `emit' as function which accepts a list of
  92     --                 instructions, so we can use patterns for optimizations
  93     where
  94     getCurrentOffset :: CodeGen e s (Word32)
  95     getCurrentOffset = do
  96       ep <- getEntryPoint
  97       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
  98       offset <- getCodeOffset
  99       return $ w32_ep + (fromIntegral offset)
 100
 101     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
 102     emitInvoke cpidx hasThis = do
 103         let l = buildMethodID cls cpidx
 104         calladdr <- getCurrentOffset
 105         newNamedLabel (show l) >>= defineLabel
 106         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 107         -- place a nop at the end, therefore the disasm doesn't screw up
 108         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 109         -- discard arguments on stack
 110         let argcnt = ((if hasThis then 1 else 0) + (methodGetArgsCount cls cpidx)) * 4
 111         when (argcnt > 0) (add esp argcnt)
 112         -- push result on stack if method has a return value
 113         when (methodHaveReturnValue cls cpidx) (push eax)
 114         return $ Just $ (calladdr, 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 + ((methodGetArgsCount cls cpidx) * 4)
 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 + ((methodGetArgsCount cls cpidx) * 4)
 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 = do -- dropp value
 180         add esp (4 :: Word32)
 181     emit DUP = push (Disp 0, esp)
 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 AALOAD = emit IALOAD
 190     emit IALOAD = do
 191         pop ebx -- offset
 192         add ebx (1 :: Word32)
 193         pop ecx -- aref
 194         push (ecx, ebx, S4)
 195     emit ARRAYLENGTH = do
 196         pop eax
 197         push (Disp 0, eax)
 198     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 199     emit (NEWARRAY typ) = do
 200         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 201                     T_INT -> 4
 202                     _ -> error $ "newarray: type not implemented yet"
 203         -- get length from stack, but leave it there
 204         mov eax (Disp 0, esp)
 205         mov ebx (tsize :: Word32)
 206         -- multiple amount with native size of one element
 207         mul ebx -- result is in eax
 208         add eax (4 :: Word32) -- for "length" entry
 209         -- push amount of bytes to allocate
 210         push eax
 211         callMalloc
 212         pop eax -- ref to arraymemory
 213         pop ebx -- length
 214         mov (Disp 0, eax) ebx -- store length at offset 0
 215         push eax -- push ref again
 216     emit (NEW objidx) = do
 217         let objname = buildClassID cls objidx
 218         amount <- liftIO $ getObjectSize objname
 219         push (amount :: Word32)
 220         callMalloc
 221         -- TODO(bernhard): save reference somewhere for GC
 222         -- set method table pointer
 223         mtable <- liftIO $ getMethodTable objname
 224         mov (Disp 0, eax) mtable
 225     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 226     emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
 227     emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
 228     emit (ICONST_0) = push (0 :: Word32)
 229     emit (ICONST_1) = push (1 :: Word32)
 230     emit (ICONST_2) = push (2 :: Word32)
 231     emit (ICONST_3) = push (3 :: Word32)
 232     emit (ICONST_4) = push (4 :: Word32)
 233     emit (ICONST_5) = push (5 :: Word32)
 234     emit (ALOAD_ x) = emit (ILOAD_ x)
 235     emit (ILOAD_ x) = do
 236         push (Disp (cArgs_ x), ebp)
 237     emit (ALOAD x) = emit (ILOAD x)
 238     emit (ILOAD x) = do
 239         push (Disp (cArgs x), ebp)
 240     emit (ASTORE_ x) = emit (ISTORE_ x)
 241     emit (ISTORE_ x) = do
 242         pop eax
 243         mov (Disp (cArgs_ x), ebp) eax
 244     emit (ASTORE x) = emit (ISTORE x)
 245     emit (ISTORE x) = do
 246         pop eax
 247         mov (Disp (cArgs x), ebp) eax
 248
 249     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 250     emit (LDC2 x) = do
 251         value <- case (constsPool cls) M.! x of
 252                       (CString s) -> liftIO $ getUniqueStringAddr s
 253                       _ -> error $ "LDCI... missing impl."
 254         push value
 255     emit (GETFIELD x) = do
 256         pop eax -- this pointer
 257         let (cname, fname) = buildFieldOffset cls x
 258         offset <- liftIO $ getFieldOffset cname fname
 259         push (Disp (fromIntegral $ offset), eax) -- get field
 260     emit (PUTFIELD x) = do
 261         pop ebx -- value to write
 262         pop eax -- this pointer
 263         let (cname, fname) = buildFieldOffset cls x
 264         offset <- liftIO $ getFieldOffset cname fname
 265         mov (Disp (fromIntegral $ offset), eax) ebx -- set field
 266
 267     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 268     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 269     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 270     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 271     emit (IINC x imm) = do
 272         add (Disp (cArgs x), ebp) (s8_w32 imm)
 273
 274     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 275     emit (IF_ICMP cond _) = do
 276         pop eax -- value2
 277         pop ebx -- value1
 278         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 279         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 280         let l = getLabel sid lmap
 281         case cond of
 282           C_EQ -> je  l; C_NE -> jne l
 283           C_LT -> jl  l; C_GT -> jg  l
 284           C_GE -> jge l; C_LE -> jle l
 285
 286     emit (IF cond _) = do
 287         pop eax -- value1
 288         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 289         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 290         let l = getLabel sid lmap
 291         case cond of
 292           C_EQ -> je  l; C_NE -> jne l
 293           C_LT -> jl  l; C_GT -> jg  l
 294           C_GE -> jge l; C_LE -> jle l
 295
 296     emit (GOTO _ ) = do
 297         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 298         jmp $ getLabel sid lmap
 299
 300     emit RETURN = do mov esp ebp; pop ebp; ret
 301     emit ARETURN = emit IRETURN
 302     emit IRETURN = do
 303         pop eax
 304         mov esp ebp
 305         pop ebp
 306         ret
 307     emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
 308
 309     callMalloc :: CodeGen e s ()
 310     callMalloc = do
 311         calladdr <- getCurrentOffset
 312         let w32_calladdr = 5 + calladdr
 313         let malloaddr = (fromIntegral getMallocAddr :: Word32)
 314         call (malloaddr - w32_calladdr)
 315         add esp (4 :: Word32)
 316         push eax
 317
 318   -- for locals we use a different storage
 319   cArgs :: Word8 -> Word32
 320   cArgs x = if (x' >= thisMethodArgCnt)
 321       -- TODO(bernhard): maybe s/(-4)/(-8)/
 322       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 323       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 324     where x' = fromIntegral x
 325
 326   cArgs_ :: IMM -> Word32
 327   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 328
 329   thisMethodArgCnt :: Word32
 330   thisMethodArgCnt = isNonStatic + (fromIntegral $ length args)
 331     where
 332     (Just m) = lookupMethod method cls
 333     (MethodSignature args _) = methodSignature m
 334     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 335         then 0
 336         else 1 -- one argument for the this pointer
 337
 338
 339   -- sign extension from w8 to w32 (over s8)
 340   --   unfortunately, hs-java is using Word8 everywhere (while
 341   --   it should be Int8 actually)
 342   s8_w32 :: Word8 -> Word32
 343   s8_w32 w8 = fromIntegral s8
 344     where s8 = (fromIntegral w8) :: Int8