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