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 #ifdef DEFINE
  19 import Text.Printf
  20 #endif
  21
  22 import qualified JVM.Assembler as J
  23 import JVM.Assembler hiding (Instruction)
  24 import JVM.ClassFile
  25
  26 import Harpy
  27 import Harpy.X86Disassembler
  28
  29 import Mate.BasicBlocks
  30 import Mate.Types
  31 import Mate.Utilities
  32 import Mate.ClassPool
  33 import Mate.Strings
  34
  35
  36 foreign import ccall "dynamic"
  37    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
  38
  39 foreign import ccall "getMallocAddr"
  40   getMallocAddr :: CUInt
  41
  42 foreign import ccall "callertrap"
  43   callertrap :: IO ()
  44
  45 foreign import ccall "register_signal"
  46   register_signal :: IO ()
  47
  48
  49 type EntryPoint = Ptr Word8
  50 type EntryPointOffset = Int
  51 type PatchInfo = (BlockID, EntryPointOffset)
  52
  53 type BBStarts = M.Map BlockID Int
  54
  55 type CompileInfo = (EntryPoint, BBStarts, Int, TrapMap)
  56
  57
  58 emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
  59 emitFromBB method cls hmap =  do
  60         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  61         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  62         ep <- getEntryPoint
  63         push ebp
  64         mov ebp esp
  65         -- TODO(bernhard): determine a reasonable value.
  66         --                 e.g. (locals used) * 4
  67         sub esp (0x60 :: Word32)
  68
  69         (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
  70         d <- disassemble
  71         end <- getCodeOffset
  72         return ((ep, bbstarts, end, calls), d)
  73   where
  74   getLabel :: BlockID -> [(BlockID, Label)] -> Label
  75   getLabel _ [] = error "label not found!"
  76   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
  77
  78   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
  79   efBB (bid, bb) calls bbstarts lmap =
  80         if M.member bid bbstarts then
  81           return (calls, bbstarts)
  82         else do
  83           bb_offset <- getCodeOffset
  84           let bbstarts' = M.insert bid bb_offset bbstarts
  85           defineLabel $ getLabel bid lmap
  86           cs <- mapM emit' $ code bb
  87           let calls' = calls `M.union` (M.fromList $ catMaybes cs)
  88           case successor bb of
  89             Return -> return (calls', bbstarts')
  90             FallThrough t -> do
  91               efBB (t, hmap M.! t) calls' bbstarts' lmap
  92             OneTarget t -> do
  93               efBB (t, hmap M.! t) calls' bbstarts' lmap
  94             TwoTarget t1 t2 -> do
  95               (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
  96               efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
  97     -- TODO(bernhard): also use metainformation
  98     -- TODO(bernhard): implement `emit' as function which accepts a list of
  99     --                 instructions, so we can use patterns for optimizations
 100     where
 101     getCurrentOffset :: CodeGen e s (Word32)
 102     getCurrentOffset = do
 103       ep <- getEntryPoint
 104       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
 105       offset <- getCodeOffset
 106       return $ w32_ep + (fromIntegral offset)
 107
 108     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
 109     emitInvoke cpidx hasThis = do
 110         let l = buildMethodID cls cpidx
 111         calladdr <- getCurrentOffset
 112         newNamedLabel (show l) >>= defineLabel
 113         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 114         -- place a nop at the end, therefore the disasm doesn't screw up
 115         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 116         -- discard arguments on stack
 117         let argcnt = ((if hasThis then 1 else 0) + (methodGetArgsCount cls cpidx)) * 4
 118         when (argcnt > 0) (add esp argcnt)
 119         -- push result on stack if method has a return value
 120         when (methodHaveReturnValue cls cpidx) (push eax)
 121         return $ Just $ (calladdr, MI l)
 122
 123     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 124     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 125     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 126     emit' (INVOKEVIRTUAL cpidx) = do
 127         -- get methodInfo entry
 128         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 129         newNamedLabel (show mi) >>= defineLabel
 130         -- objref lives somewhere on the argument stack
 131         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 132         -- get method-table-ptr
 133         mov eax (Disp 0, eax)
 134         -- get method offset
 135         let nameAndSig = methodname `B.append` (encode msig)
 136         offset <- liftIO $ getMethodOffset objname nameAndSig
 137         -- make actual (indirect) call
 138         calladdr <- getCurrentOffset
 139         call (Disp offset, eax)
 140         -- discard arguments on stack (+4 for "this")
 141         let argcnt = 4 + ((methodGetArgsCount cls cpidx) * 4)
 142         when (argcnt > 0) (add esp argcnt)
 143         -- push result on stack if method has a return value
 144         when (methodHaveReturnValue cls cpidx) (push eax)
 145         -- note, the "mi" has the wrong class reference here.
 146         -- we figure that out at run-time, in the methodpool,
 147         -- depending on the method-table-ptr
 148         return $ Just $ (calladdr, VI mi)
 149     emit' (PUTSTATIC cpidx) = do
 150         pop eax
 151         trapaddr <- getCurrentOffset
 152         mov (Addr 0x00000000) eax -- it's a trap
 153         return $ Just $ (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 154     emit' (GETSTATIC cpidx) = do
 155         trapaddr <- getCurrentOffset
 156         mov eax (Addr 0x00000000) -- it's a trap
 157         push eax
 158         return $ Just $ (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 159     emit' insn = emit insn >> return Nothing
 160
 161     emit :: J.Instruction -> CodeGen e s ()
 162     emit POP = do -- dropp value
 163         add esp (4 :: Word32)
 164     emit DUP = push (Disp 0, esp)
 165     emit AASTORE = emit IASTORE
 166     emit IASTORE = do
 167         pop eax -- value
 168         pop ebx -- offset
 169         add ebx (1 :: Word32)
 170         pop ecx -- aref
 171         mov (ecx, ebx, S4) eax
 172     emit AALOAD = emit IALOAD
 173     emit IALOAD = do
 174         pop ebx -- offset
 175         add ebx (1 :: Word32)
 176         pop ecx -- aref
 177         push (ecx, ebx, S4)
 178     emit ARRAYLENGTH = do
 179         pop eax
 180         push (Disp 0, eax)
 181     emit (ANEWARRAY _) = emit (NEWARRAY 10) -- 10 == T_INT
 182     emit (NEWARRAY typ) = do
 183         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 184                     T_INT -> 4
 185                     _ -> error $ "newarray: type not implemented yet"
 186         -- get length from stack, but leave it there
 187         mov eax (Disp 0, esp)
 188         mov ebx (tsize :: Word32)
 189         -- multiple amount with native size of one element
 190         mul ebx -- result is in eax
 191         add eax (4 :: Word32) -- for "length" entry
 192         -- push amount of bytes to allocate
 193         push eax
 194         callMalloc
 195         pop eax -- ref to arraymemory
 196         pop ebx -- length
 197         mov (Disp 0, eax) ebx -- store length at offset 0
 198         push eax -- push ref again
 199     emit (NEW objidx) = do
 200         let objname = buildClassID cls objidx
 201         amount <- liftIO $ getObjectSize objname
 202         push (amount :: Word32)
 203         callMalloc
 204         -- TODO(bernhard): save reference somewhere for GC
 205         -- set method table pointer
 206         mtable <- liftIO $ getMethodTable objname
 207         mov (Disp 0, eax) mtable
 208     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 209     emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
 210     emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
 211     emit (ICONST_0) = push (0 :: Word32)
 212     emit (ICONST_1) = push (1 :: Word32)
 213     emit (ICONST_2) = push (2 :: Word32)
 214     emit (ICONST_3) = push (3 :: Word32)
 215     emit (ICONST_4) = push (4 :: Word32)
 216     emit (ICONST_5) = push (5 :: Word32)
 217     emit (ALOAD_ x) = emit (ILOAD_ x)
 218     emit (ILOAD_ x) = do
 219         push (Disp (cArgs_ x), ebp)
 220     emit (ALOAD x) = emit (ILOAD x)
 221     emit (ILOAD x) = do
 222         push (Disp (cArgs x), ebp)
 223     emit (ASTORE_ x) = emit (ISTORE_ x)
 224     emit (ISTORE_ x) = do
 225         pop eax
 226         mov (Disp (cArgs_ x), ebp) eax
 227     emit (ASTORE x) = emit (ISTORE x)
 228     emit (ISTORE x) = do
 229         pop eax
 230         mov (Disp (cArgs x), ebp) eax
 231
 232     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 233     emit (LDC2 x) = do
 234         value <- case (constsPool cls) M.! x of
 235                       (CString s) -> liftIO $ getUniqueStringAddr s
 236                       _ -> error $ "LDCI... missing impl."
 237         push value
 238     emit (GETFIELD x) = do
 239         pop eax -- this pointer
 240         let (cname, fname) = buildFieldOffset cls x
 241         offset <- liftIO $ getFieldOffset cname fname
 242         push (Disp (fromIntegral $ offset), eax) -- get field
 243     emit (PUTFIELD x) = do
 244         pop ebx -- value to write
 245         pop eax -- this pointer
 246         let (cname, fname) = buildFieldOffset cls x
 247         offset <- liftIO $ getFieldOffset cname fname
 248         mov (Disp (fromIntegral $ offset), eax) ebx -- set field
 249
 250     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 251     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 252     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 253     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 254     emit (IINC x imm) = do
 255         add (Disp (cArgs x), ebp) (s8_w32 imm)
 256
 257     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 258     emit (IF_ICMP cond _) = do
 259         pop eax -- value2
 260         pop ebx -- value1
 261         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 262         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 263         let l = getLabel sid lmap
 264         case cond of
 265           C_EQ -> je  l; C_NE -> jne l
 266           C_LT -> jl  l; C_GT -> jg  l
 267           C_GE -> jge l; C_LE -> jle l
 268
 269     emit (IF cond _) = do
 270         pop eax -- value1
 271         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 272         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 273         let l = getLabel sid lmap
 274         case cond of
 275           C_EQ -> je  l; C_NE -> jne l
 276           C_LT -> jl  l; C_GT -> jg  l
 277           C_GE -> jge l; C_LE -> jle l
 278
 279     emit (GOTO _ ) = do
 280         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 281         jmp $ getLabel sid lmap
 282
 283     emit RETURN = do mov esp ebp; pop ebp; ret
 284     emit ARETURN = emit IRETURN
 285     emit IRETURN = do
 286         pop eax
 287         mov esp ebp
 288         pop ebp
 289         ret
 290     emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
 291
 292     callMalloc :: CodeGen e s ()
 293     callMalloc = do
 294         calladdr <- getCurrentOffset
 295         let w32_calladdr = 5 + calladdr
 296         let malloaddr = (fromIntegral getMallocAddr :: Word32)
 297         call (malloaddr - w32_calladdr)
 298         add esp (4 :: Word32)
 299         push eax
 300
 301   -- for locals we use a different storage
 302   cArgs :: Word8 -> Word32
 303   cArgs x = if (x' >= thisMethodArgCnt)
 304       -- TODO(bernhard): maybe s/(-4)/(-8)/
 305       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 306       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 307     where x' = fromIntegral x
 308
 309   cArgs_ :: IMM -> Word32
 310   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 311
 312   thisMethodArgCnt :: Word32
 313   thisMethodArgCnt = isNonStatic + (fromIntegral $ length args)
 314     where
 315     (Just m) = lookupMethod method cls
 316     (MethodSignature args _) = methodSignature m
 317     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 318         then 0
 319         else 1 -- one argument for the this pointer
 320
 321
 322   -- sign extension from w8 to w32 (over s8)
 323   --   unfortunately, hs-java is using Word8 everywhere (while
 324   --   it should be Int8 actually)
 325   s8_w32 :: Word8 -> Word32
 326   s8_w32 w8 = fromIntegral s8
 327     where s8 = (fromIntegral w8) :: Int8