Mate/X86CodeGen.hs

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