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