Mate/X86CodeGen.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.X86CodeGen where
   4
   5 import Data.Binary
   6 import Data.Int
   7 import Data.Maybe
   8 import qualified Data.Map as M
   9 import qualified Data.ByteString.Lazy as B
  10 import Control.Monad
  11
  12 import Foreign
  13 import Foreign.C.Types
  14
  15 import Text.Printf
  16
  17 import qualified JVM.Assembler as J
  18 import JVM.Assembler hiding (Instruction)
  19 import JVM.ClassFile
  20
  21 import Harpy
  22 import Harpy.X86Disassembler
  23
  24 import Mate.BasicBlocks
  25 import Mate.Types
  26 import Mate.Utilities
  27 import Mate.ClassPool
  28
  29 foreign import ccall "dynamic"
  30    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
  31
  32 foreign import ccall "getaddr"
  33   getaddr :: CUInt
  34
  35 foreign import ccall "callertrap"
  36   callertrap :: IO ()
  37
  38 foreign import ccall "register_signal"
  39   register_signal :: IO ()
  40
  41 test_01, test_02, test_03 :: IO ()
  42 test_01 = do
  43   register_signal
  44   (entry, end) <- testCase "./tests/Fib" "fib"
  45   let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
  46
  47   mapM_ (\x -> do
  48     result <- code_int entryFuncPtr x 0
  49     let iresult :: Int; iresult = fromIntegral result
  50     let kk :: String; kk = if iresult == (fib x) then "OK" else "FAIL (" ++ (show (fib x)) ++ ")"
  51     printf "result of fib(%2d): %3d\t\t%s\n" (fromIntegral x :: Int) iresult kk
  52     ) $ ([0..10] :: [CInt])
  53   printf "patched disasm:\n"
  54   Right newdisasm <- disassembleBlock entry end
  55   mapM_ (putStrLn . showAtt) newdisasm
  56   where
  57     fib :: CInt -> Int
  58     fib n
  59       | n <= 1 = 1
  60       | otherwise = (fib (n - 1)) + (fib (n - 2))
  61
  62
  63 test_02 = do
  64   (entry,_) <- testCase "./tests/While" "f"
  65   let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
  66   result <- code_int entryFuncPtr 5 4
  67   let iresult :: Int; iresult = fromIntegral result
  68   let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
  69   printf "result of f(5,4): %3d\t\t%s\n" iresult kk
  70
  71   result2 <- code_int entryFuncPtr 4 3
  72   let iresult2 :: Int; iresult2 = fromIntegral result2
  73   let kk2 :: String; kk2 = if iresult2 == 10 then "OK" else "FAIL"
  74   printf "result of f(4,3): %3d\t\t%s\n" iresult2 kk2
  75
  76
  77 test_03 = do
  78   (entry,_) <- testCase "./tests/While" "g"
  79   let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
  80   result <- code_int entryFuncPtr 5 4
  81   let iresult :: Int; iresult = fromIntegral result
  82   let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
  83   printf "result of g(5,4): %3d\t\t%s\n" iresult kk
  84
  85   result2 <- code_int entryFuncPtr 4 3
  86   let iresult2 :: Int; iresult2 = fromIntegral result2
  87   let kk2 :: String; kk2 = if iresult2 == 10 then "OK" else "FAIL"
  88   printf "result of g(4,3): %3d\t\t%s\n" iresult2 kk2
  89
  90
  91 testCase :: B.ByteString -> B.ByteString -> IO (Ptr Word8, Int)
  92 testCase cf method = do
  93       cls <- getClassFile cf
  94       hmap <- parseMethod cls method
  95       printMapBB hmap
  96       case hmap of
  97         Nothing -> error "sorry, no code generation"
  98         Just hmap' -> do
  99               let ebb = emitFromBB method cls hmap'
 100               (_, Right ((entry, bbstarts, end, _), disasm)) <- runCodeGen ebb () ()
 101               let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Int)
 102               printf "disasm:\n"
 103               mapM_ (putStrLn . showAtt) disasm
 104               printf "basicblocks addresses:\n"
 105               let b = map (\(x,y) -> (x,y + int_entry)) $ M.toList bbstarts
 106               mapM_ (\(x,y) -> printf "\tBasicBlock %2d starts at 0x%08x\n" x y) b
 107               return (entry, end)
 108
 109 type EntryPoint = Ptr Word8
 110 type EntryPointOffset = Int
 111 type PatchInfo = (BlockID, EntryPointOffset)
 112
 113 type BBStarts = M.Map BlockID Int
 114
 115 type CompileInfo = (EntryPoint, BBStarts, Int, TMap)
 116
 117
 118 emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
 119 emitFromBB method cls hmap =  do
 120         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
 121         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
 122         ep <- getEntryPoint
 123         push ebp
 124         mov ebp esp
 125         -- TODO(bernhard): determine a reasonable value.
 126         --                 e.g. (locals used) * 4
 127         sub esp (0x60 :: Word32)
 128
 129         (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
 130         d <- disassemble
 131         end <- getCodeOffset
 132         return ((ep, bbstarts, end, calls), d)
 133   where
 134   getLabel :: BlockID -> [(BlockID, Label)] -> Label
 135   getLabel _ [] = error "label not found!"
 136   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
 137
 138   efBB :: (BlockID, BasicBlock) -> TMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TMap, BBStarts)
 139   efBB (bid, bb) calls bbstarts lmap =
 140         if M.member bid bbstarts then
 141           return (calls, bbstarts)
 142         else do
 143           bb_offset <- getCodeOffset
 144           let bbstarts' = M.insert bid bb_offset bbstarts
 145           defineLabel $ getLabel bid lmap
 146           cs <- mapM emit' $ code bb
 147           let calls' = calls `M.union` (M.fromList $ catMaybes cs)
 148           case successor bb of
 149             Return -> return (calls', bbstarts')
 150             FallThrough t -> do
 151               efBB (t, hmap M.! t) calls' bbstarts' lmap
 152             OneTarget t -> do
 153               efBB (t, hmap M.! t) calls' bbstarts' lmap
 154             TwoTarget t1 t2 -> do
 155               (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
 156               efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
 157     -- TODO(bernhard): also use metainformation
 158     -- TODO(bernhard): implement `emit' as function which accepts a list of
 159     --                 instructions, so we can use patterns for optimizations
 160     where
 161     getCurrentOffset :: CodeGen e s (Word32)
 162     getCurrentOffset = do
 163       ep <- getEntryPoint
 164       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
 165       offset <- getCodeOffset
 166       return $ w32_ep + (fromIntegral offset)
 167
 168     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 169     emit' (INVOKESTATIC cpidx) = do
 170         let l = buildMethodID cls cpidx
 171         calladdr <- getCurrentOffset
 172         newNamedLabel (show l) >>= defineLabel
 173         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 174         -- place a nop at the end, therefore the disasm doesn't screw up
 175         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 176         -- discard arguments on stack
 177         let argcnt = (methodGetArgsCount cls cpidx) * 4
 178         when (argcnt > 0) (add esp argcnt)
 179         -- push result on stack if method has a return value
 180         when (methodHaveReturnValue cls cpidx) (push eax)
 181         return $ Just $ (calladdr, MI l)
 182     emit' (PUTSTATIC cpidx) = do
 183         pop eax
 184         trapaddr <- getCurrentOffset
 185         mov (Addr 0x00000000) eax -- it's a trap
 186         return $ Just $ (trapaddr, SFI $ buildFieldID cls cpidx)
 187     emit' (GETSTATIC cpidx) = do
 188         trapaddr <- getCurrentOffset
 189         mov eax (Addr 0x00000000) -- it's a trap
 190         push eax
 191         return $ Just $ (trapaddr, SFI $ buildFieldID cls cpidx)
 192     emit' insn = emit insn >> return Nothing
 193
 194     emit :: J.Instruction -> CodeGen e s ()
 195     emit POP = do -- print dropped value
 196         calladdr <- getCurrentOffset
 197         -- '5' is the size of the `call' instruction ( + immediate)
 198         let w32_calladdr = 5 + calladdr
 199         let trapaddr = (fromIntegral getaddr :: Word32)
 200         call (trapaddr - w32_calladdr)
 201         add esp (4 :: Word32)
 202     emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
 203     emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
 204     emit (ICONST_0) = push (0 :: Word32)
 205     emit (ICONST_1) = push (1 :: Word32)
 206     emit (ICONST_2) = push (2 :: Word32)
 207     emit (ICONST_4) = push (4 :: Word32)
 208     emit (ICONST_5) = push (5 :: Word32)
 209     emit (ILOAD_ x) = do
 210         push (Disp (cArgs_ x), ebp)
 211     emit (ILOAD x) = do
 212         push (Disp (cArgs x), ebp)
 213     emit (ISTORE_ x) = do
 214         pop eax
 215         mov (Disp (cArgs_ x), ebp) eax
 216     emit (ISTORE x) = do
 217         pop eax
 218         mov (Disp (cArgs x), ebp) eax
 219     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 220     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 221     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 222     emit (IINC x imm) = do
 223         add (Disp (cArgs x), ebp) (s8_w32 imm)
 224
 225     emit (IF_ICMP cond _) = do
 226         pop eax -- value2
 227         pop ebx -- value1
 228         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 229         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 230         let l = getLabel sid lmap
 231         case cond of
 232           C_EQ -> je  l; C_NE -> jne l
 233           C_LT -> jl  l; C_GT -> jg  l
 234           C_GE -> jge l; C_LE -> jle l
 235
 236     emit (IF cond _) = do
 237         pop eax -- value1
 238         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 239         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 240         let l = getLabel sid lmap
 241         case cond of
 242           C_EQ -> je  l; C_NE -> jne l
 243           C_LT -> jl  l; C_GT -> jg  l
 244           C_GE -> jge l; C_LE -> jle l
 245
 246     emit (GOTO _ ) = do
 247         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 248         jmp $ getLabel sid lmap
 249
 250     emit RETURN = do mov esp ebp; pop ebp; ret
 251     emit IRETURN = do
 252         pop eax
 253         mov esp ebp
 254         pop ebp
 255         ret
 256     emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
 257
 258   -- for locals we use a different storage
 259   cArgs :: Word8 -> Word32
 260   cArgs x = if (x' >= thisMethodArgCnt)
 261       -- TODO(bernhard): maybe s/(-4)/(-8)/
 262       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 263       else 8 + (4 * x')
 264     where x' = fromIntegral x
 265
 266   cArgs_ :: IMM -> Word32
 267   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 268
 269   thisMethodArgCnt :: Word32
 270   thisMethodArgCnt = fromIntegral $ length args
 271     where
 272     (Just m) = lookupMethod method cls
 273     (MethodSignature args _) = methodSignature m
 274
 275   -- sign extension from w8 to w32 (over s8)
 276   --   unfortunately, hs-java is using Word8 everywhere (while
 277   --   it should be Int8 actually)
 278   s8_w32 :: Word8 -> Word32
 279   s8_w32 w8 = fromIntegral s8
 280     where s8 = (fromIntegral w8) :: Int8