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.List
   8 import Data.Maybe
   9 import qualified Data.Map as M
  10 import qualified Data.ByteString.Lazy as B
  11
  12 import Foreign
  13 import Foreign.Ptr
  14 import Foreign.C.Types
  15
  16 import Text.Printf
  17
  18 import qualified JVM.Assembler as J
  19 import JVM.Assembler hiding (Instruction)
  20
  21 import Harpy
  22 import Harpy.X86Disassembler
  23
  24 import Mate.BasicBlocks
  25
  26 foreign import ccall "dynamic"
  27    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
  28
  29 test_01, test_02, test_03 :: IO ()
  30 test_01 = do
  31   _ <- testCase "./tests/Fib.class" "fib"
  32   return ()
  33
  34
  35 test_02 = do
  36   entry <- testCase "./tests/While.class" "f"
  37   let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
  38   result <- code_int entryFuncPtr (fromIntegral 5) (fromIntegral 4)
  39   let iresult :: Int; iresult = fromIntegral result
  40   let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
  41   printf "result of f(5,4): %3d\t\t%s\n" iresult kk
  42
  43   result <- code_int entryFuncPtr (fromIntegral 4) (fromIntegral 3)
  44   let iresult :: Int; iresult = fromIntegral result
  45   let kk :: String; kk = if iresult == 10 then "OK" else "FAIL"
  46   printf "result of f(4,3): %3d\t\t%s\n" iresult kk
  47
  48
  49 test_03 = do
  50   entry <- testCase "./tests/While.class" "g"
  51   let entryFuncPtr = ((castPtrToFunPtr entry) :: FunPtr (CInt -> CInt -> IO CInt))
  52   result <- code_int entryFuncPtr (fromIntegral 5) (fromIntegral 4)
  53   let iresult :: Int; iresult = fromIntegral result
  54   let kk :: String; kk = if iresult == 15 then "OK" else "FAIL"
  55   printf "result of g(5,4): %3d\t\t%s\n" iresult kk
  56
  57   result <- code_int entryFuncPtr (fromIntegral 4) (fromIntegral 3)
  58   let iresult :: Int; iresult = fromIntegral result
  59   let kk :: String; kk = if iresult == 10 then "OK" else "FAIL"
  60   printf "result of g(4,3): %3d\t\t%s\n" iresult kk
  61
  62
  63 testCase :: String -> B.ByteString -> IO (Ptr Word8)
  64 testCase cf method = do
  65       hmap <- parseMethod cf method
  66       printMapBB hmap
  67       case hmap of
  68         Nothing -> error "sorry, no code generation"
  69         Just hmap -> do
  70               let ebb = emitFromBB hmap
  71               (_, Right ((entry, bbstarts), disasm)) <- runCodeGen ebb () ()
  72               let int_entry = ((fromIntegral $ ptrToIntPtr entry) :: Int)
  73               printf "disasm:\n"
  74               mapM_ (putStrLn . showAtt) disasm
  75               printf "basicblocks addresses:\n"
  76               let b = map (\(x,y) -> (x,y + int_entry)) $ M.toList bbstarts
  77               mapM_ (\(x,y) -> printf "\tBasicBlock %2d starts at 0x%08x\n" x y) b
  78               return entry
  79
  80 type EntryPoint = Ptr Word8
  81 type EntryPointOffset = Int
  82 type PatchInfo = (BlockID, EntryPointOffset)
  83
  84 type BBStarts = M.Map BlockID Int
  85
  86 type CompileInfo = (EntryPoint, BBStarts)
  87
  88 emitFromBB :: MapBB -> CodeGen e s (CompileInfo, [Instruction])
  89 emitFromBB hmap =  do
  90         llmap <- sequence [newNamedLabel ("bb_" ++ show x) | (x,_) <- M.toList hmap]
  91         let lmap = zip (Prelude.fst $ unzip $ M.toList hmap) llmap
  92         ep <- getEntryPoint
  93         push ebp
  94         mov ebp esp
  95         bbstarts <- efBB (0,(hmap M.! 0)) M.empty lmap
  96         mov esp ebp
  97         pop ebp
  98         ret
  99         d <- disassemble
 100         return ((ep, bbstarts), d)
 101   where
 102   getLabel :: BlockID -> [(BlockID, Label)] -> Label
 103   getLabel _ [] = error "label not found!"
 104   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
 105
 106   efBB :: (BlockID, BasicBlock) -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (BBStarts)
 107   efBB (bid, bb) bbstarts lmap =
 108         if M.member bid bbstarts then
 109           return bbstarts
 110         else do
 111           bb_offset <- getCodeOffset
 112           let bbstarts' = M.insert bid bb_offset bbstarts
 113           defineLabel $ getLabel bid lmap
 114           mapM emit $ code bb
 115           case successor bb of
 116             Return -> return bbstarts'
 117             OneTarget t -> do
 118               efBB (t, hmap M.! t) bbstarts' lmap
 119             TwoTarget t1 t2 -> do
 120               bbstarts'' <- efBB (t1, hmap M.! t1) bbstarts' lmap
 121               efBB (t2, hmap M.! t2) bbstarts'' lmap
 122     -- TODO(bernhard): also use metainformation
 123     -- TODO(bernhard): implement `emit' as function which accepts a list of
 124     --                 instructions, so we can use patterns for optimizations
 125     where
 126     emit :: J.Instruction -> CodeGen e s ()
 127     emit (ICONST_1) = push (1 :: Word32)
 128     emit (ICONST_2) = push (2 :: Word32)
 129     emit (ILOAD_ x) = do
 130         push (Disp (cArgs_ x), ebp)
 131     emit (ISTORE_ x) = do
 132         pop eax
 133         mov (Disp (cArgs_ x), ebp) eax
 134     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 135     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 136     emit (IINC x imm) = do
 137         add (Disp (cArgs x), ebp) (s8_w32 imm)
 138
 139     emit (IF_ICMP cond _) = do
 140         pop eax -- value2
 141         pop ebx -- value1
 142         cmp eax ebx -- intel syntax is swapped (TODO(bernhard): test that plz)
 143         let sid = case successor bb of TwoTarget _ t -> t
 144         let l = getLabel sid lmap
 145         case cond of
 146           C_EQ -> je  l; C_NE -> jne l
 147           C_LT -> jl  l; C_GT -> jg  l
 148           C_GE -> jge l; C_LE -> jle l
 149
 150     emit (IF cond _) = do
 151         pop eax -- value1
 152         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 153         let sid = case successor bb of TwoTarget _ t -> t
 154         let l = getLabel sid lmap
 155         case cond of
 156           C_EQ -> je  l; C_NE -> jne l
 157           C_LT -> jl  l; C_GT -> jg  l
 158           C_GE -> jge l; C_LE -> jle l
 159
 160     emit (GOTO _ ) = do
 161         let sid = case successor bb of OneTarget t -> t
 162         jmp $ getLabel sid lmap
 163
 164     emit IRETURN = do pop eax
 165     emit _ = do cmovbe eax eax -- dummy
 166
 167   cArgs x = (8 + 4 * (fromIntegral x))
 168   cArgs_ x = (8 + 4 * case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3)
 169
 170   -- sign extension from w8 to w32 (over s8)
 171   --   unfortunately, hs-java is using Word8 everywhere (while
 172   --   it should be Int8 actually)
 173   s8_w32 :: Word8 -> Word32
 174   s8_w32 w8 = fromIntegral s8
 175     where s8 = (fromIntegral w8) :: Int8