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