Mate/X86CodeGen.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE ForeignFunctionInterface #-}
   3 module Mate.X86CodeGen where
   4
   5 import Data.Binary
   6 import Data.BinaryState
   7 import Data.Int
   8 import Data.Maybe
   9 import qualified Data.Map as M
  10 import qualified Data.Set as S
  11 import qualified Data.ByteString.Lazy as B
  12 import Control.Monad
  13
  14 import Foreign
  15 import Foreign.C.Types
  16
  17 import Text.Printf
  18
  19 import qualified JVM.Assembler as J
  20 import JVM.Assembler hiding (Instruction)
  21 import JVM.ClassFile
  22
  23 import Harpy
  24 import Harpy.X86Disassembler
  25
  26 import Mate.BasicBlocks
  27 import Mate.Types
  28 import Mate.Utilities
  29 import Mate.ClassPool
  30 import Mate.Strings
  31
  32
  33 foreign import ccall "dynamic"
  34    code_int :: FunPtr (CInt -> CInt -> IO CInt) -> (CInt -> CInt -> IO CInt)
  35
  36 foreign import ccall "getaddr"
  37   getaddr :: CUInt
  38
  39 foreign import ccall "getMallocAddr"
  40   getMallocAddr :: CUInt
  41
  42 foreign import ccall "callertrap"
  43   callertrap :: IO ()
  44
  45 foreign import ccall "register_signal"
  46   register_signal :: 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 method 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, TMap)
 123
 124
 125 emitFromBB :: B.ByteString -> Class Resolved -> MapBB -> CodeGen e s (CompileInfo, [Instruction])
 126 emitFromBB method 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         -- TODO(bernhard): determine a reasonable value.
 133         --                 e.g. (locals used) * 4
 134         sub esp (0x60 :: Word32)
 135
 136         (calls, bbstarts) <- efBB (0,(hmap M.! 0)) M.empty M.empty lmap
 137         d <- disassemble
 138         end <- getCodeOffset
 139         return ((ep, bbstarts, end, calls), d)
 140   where
 141   getLabel :: BlockID -> [(BlockID, Label)] -> Label
 142   getLabel _ [] = error "label not found!"
 143   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
 144
 145   efBB :: (BlockID, BasicBlock) -> TMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TMap, BBStarts)
 146   efBB (bid, bb) calls bbstarts lmap =
 147         if M.member bid bbstarts then
 148           return (calls, bbstarts)
 149         else do
 150           bb_offset <- getCodeOffset
 151           let bbstarts' = M.insert bid bb_offset bbstarts
 152           defineLabel $ getLabel bid lmap
 153           cs <- mapM emit' $ code bb
 154           let calls' = calls `M.union` (M.fromList $ catMaybes cs)
 155           case successor bb of
 156             Return -> return (calls', bbstarts')
 157             FallThrough t -> do
 158               efBB (t, hmap M.! t) calls' bbstarts' lmap
 159             OneTarget t -> do
 160               efBB (t, hmap M.! t) calls' bbstarts' lmap
 161             TwoTarget t1 t2 -> do
 162               (calls'', bbstarts'') <- efBB (t1, hmap M.! t1) calls' bbstarts' lmap
 163               efBB (t2, hmap M.! t2) calls'' bbstarts'' lmap
 164     -- TODO(bernhard): also use metainformation
 165     -- TODO(bernhard): implement `emit' as function which accepts a list of
 166     --                 instructions, so we can use patterns for optimizations
 167     where
 168     getCurrentOffset :: CodeGen e s (Word32)
 169     getCurrentOffset = do
 170       ep <- getEntryPoint
 171       let w32_ep = (fromIntegral $ ptrToIntPtr ep) :: Word32
 172       offset <- getCodeOffset
 173       return $ w32_ep + (fromIntegral offset)
 174
 175     emitInvoke :: Word16 -> Bool -> CodeGen e s (Maybe (Word32, TrapInfo))
 176     emitInvoke cpidx hasThis = do
 177         let l = buildMethodID cls cpidx
 178         calladdr <- getCurrentOffset
 179         newNamedLabel (show l) >>= defineLabel
 180         -- causes SIGILL. in the signal handler we patch it to the acutal call.
 181         -- place a nop at the end, therefore the disasm doesn't screw up
 182         emit32 (0xffff9090 :: Word32) >> emit8 (0x90 :: Word8)
 183         -- discard arguments on stack
 184         let argcnt = ((if hasThis then 1 else 0) + (methodGetArgsCount cls cpidx)) * 4
 185         when (argcnt > 0) (add esp argcnt)
 186         -- push result on stack if method has a return value
 187         when (methodHaveReturnValue cls cpidx) (push eax)
 188         return $ Just $ (calladdr, MI l)
 189
 190     emit' :: J.Instruction -> CodeGen e s (Maybe (Word32, TrapInfo))
 191     emit' (INVOKESPECIAL cpidx) = emitInvoke cpidx True
 192     emit' (INVOKESTATIC cpidx) = emitInvoke cpidx False
 193     emit' (INVOKEVIRTUAL cpidx) = do
 194         -- get methodInfo entry
 195         let mi@(MethodInfo methodname objname msig@(MethodSignature args _))  = buildMethodID cls cpidx
 196         newNamedLabel (show mi) >>= defineLabel
 197         -- objref lives somewhere on the argument stack
 198         mov eax (Disp ((*4) $ fromIntegral $ length args), esp)
 199         -- get method-table-ptr
 200         mov eax (Disp 0, eax)
 201         -- get method offset
 202         let nameAndSig = methodname `B.append` (encode msig)
 203         offset <- liftIO $ getMethodOffset objname nameAndSig
 204         -- make actual (indirect) call
 205         calladdr <- getCurrentOffset
 206         call (Disp offset, eax)
 207         -- discard arguments on stack (+4 for "this")
 208         let argcnt = 4 + ((methodGetArgsCount cls cpidx) * 4)
 209         when (argcnt > 0) (add esp argcnt)
 210         -- push result on stack if method has a return value
 211         when (methodHaveReturnValue cls cpidx) (push eax)
 212         -- note, the "mi" has the wrong class reference here.
 213         -- we figure that out at run-time, in the methodpool,
 214         -- depending on the method-table-ptr
 215         return $ Just $ (calladdr, VI mi)
 216     emit' (PUTSTATIC cpidx) = do
 217         pop eax
 218         trapaddr <- getCurrentOffset
 219         mov (Addr 0x00000000) eax -- it's a trap
 220         return $ Just $ (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 221     emit' (GETSTATIC cpidx) = do
 222         trapaddr <- getCurrentOffset
 223         mov eax (Addr 0x00000000) -- it's a trap
 224         push eax
 225         return $ Just $ (trapaddr, SFI $ buildStaticFieldID cls cpidx)
 226     emit' insn = emit insn >> return Nothing
 227
 228     emit :: J.Instruction -> CodeGen e s ()
 229     emit POP = do -- print dropped value
 230         calladdr <- getCurrentOffset
 231         -- '5' is the size of the `call' instruction ( + immediate)
 232         let w32_calladdr = 5 + calladdr
 233         let trapaddr = (fromIntegral getaddr :: Word32)
 234         call (trapaddr - w32_calladdr)
 235         add esp (4 :: Word32)
 236     emit DUP = push (Disp 0, esp)
 237     emit ARRAYLENGTH = do
 238         pop eax
 239         push (Disp 0, eax)
 240     emit (NEWARRAY typ) = do
 241         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 242                     T_INT -> 4
 243                     _ -> error $ "newarray: type not implemented yet"
 244         -- get length from stack, but leave it there
 245         mov eax (Disp 0, esp)
 246         mov ebx (tsize :: Word32)
 247         -- multiple amount with native size of one element
 248         mul ebx -- result is in eax
 249         add eax (4 :: Word32) -- for "length" entry
 250         -- push amount of bytes to allocate
 251         push eax
 252         callMalloc
 253         pop eax -- ref to arraymemory
 254         pop ebx -- length
 255         mov (Disp 0, eax) ebx -- store length at offset 0
 256         push eax -- push ref again
 257     emit (NEW objidx) = do
 258         let objname = buildClassID cls objidx
 259         amount <- liftIO $ getMethodSize objname
 260         push (amount :: Word32)
 261         callMalloc
 262         -- TODO(bernhard): save reference somewhere for GC
 263         -- set method table pointer
 264         mtable <- liftIO $ getMethodTable objname
 265         mov (Disp 0, eax) mtable
 266     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 267     emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
 268     emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
 269     emit (ICONST_0) = push (0 :: Word32)
 270     emit (ICONST_1) = push (1 :: Word32)
 271     emit (ICONST_2) = push (2 :: Word32)
 272     emit (ICONST_4) = push (4 :: Word32)
 273     emit (ICONST_5) = push (5 :: Word32)
 274     emit (ALOAD_ x) = emit (ILOAD_ x)
 275     emit (ILOAD_ x) = do
 276         push (Disp (cArgs_ x), ebp)
 277     emit (ALOAD x) = emit (ILOAD x)
 278     emit (ILOAD x) = do
 279         push (Disp (cArgs x), ebp)
 280     emit (ASTORE_ x) = emit (ISTORE_ x)
 281     emit (ISTORE_ x) = do
 282         pop eax
 283         mov (Disp (cArgs_ x), ebp) eax
 284     emit (ASTORE x) = emit (ISTORE x)
 285     emit (ISTORE x) = do
 286         pop eax
 287         mov (Disp (cArgs x), ebp) eax
 288
 289     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 290     emit (LDC2 x) = do
 291         value <- case (constsPool cls) M.! x of
 292                       (CString s) -> liftIO $ getUniqueStringAddr s
 293                       _ -> error $ "LDCI... missing impl."
 294         push value
 295     emit (GETFIELD x) = do
 296         pop eax -- this pointer
 297         let (cname, fname) = buildFieldOffset cls x
 298         offset <- liftIO $ getFieldOffset cname fname
 299         push (Disp (fromIntegral $ offset * 4), eax) -- get field
 300     emit (PUTFIELD x) = do
 301         pop ebx -- value to write
 302         pop eax -- this pointer
 303         let (cname, fname) = buildFieldOffset cls x
 304         offset <- liftIO $ getFieldOffset cname fname
 305         mov (Disp (fromIntegral $ offset * 4), eax) ebx -- set field
 306
 307     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 308     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 309     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 310     emit (IINC x imm) = do
 311         add (Disp (cArgs x), ebp) (s8_w32 imm)
 312
 313     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 314     emit (IF_ICMP cond _) = do
 315         pop eax -- value2
 316         pop ebx -- value1
 317         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 318         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 319         let l = getLabel sid lmap
 320         case cond of
 321           C_EQ -> je  l; C_NE -> jne l
 322           C_LT -> jl  l; C_GT -> jg  l
 323           C_GE -> jge l; C_LE -> jle l
 324
 325     emit (IF cond _) = do
 326         pop eax -- value1
 327         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 328         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 329         let l = getLabel sid lmap
 330         case cond of
 331           C_EQ -> je  l; C_NE -> jne l
 332           C_LT -> jl  l; C_GT -> jg  l
 333           C_GE -> jge l; C_LE -> jle l
 334
 335     emit (GOTO _ ) = do
 336         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 337         jmp $ getLabel sid lmap
 338
 339     emit RETURN = do mov esp ebp; pop ebp; ret
 340     emit ARETURN = emit IRETURN
 341     emit IRETURN = do
 342         pop eax
 343         mov esp ebp
 344         pop ebp
 345         ret
 346     emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
 347
 348     callMalloc :: CodeGen e s ()
 349     callMalloc = do
 350         calladdr <- getCurrentOffset
 351         let w32_calladdr = 5 + calladdr
 352         let malloaddr = (fromIntegral getMallocAddr :: Word32)
 353         call (malloaddr - w32_calladdr)
 354         add esp (4 :: Word32)
 355         push eax
 356
 357   -- for locals we use a different storage
 358   cArgs :: Word8 -> Word32
 359   cArgs x = if (x' >= thisMethodArgCnt)
 360       -- TODO(bernhard): maybe s/(-4)/(-8)/
 361       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 362       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 363     where x' = fromIntegral x
 364
 365   cArgs_ :: IMM -> Word32
 366   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 367
 368   thisMethodArgCnt :: Word32
 369   thisMethodArgCnt = isNonStatic + (fromIntegral $ length args)
 370     where
 371     (Just m) = lookupMethod method cls
 372     (MethodSignature args _) = methodSignature m
 373     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 374         then 0
 375         else 1 -- one argument for the this pointer
 376
 377
 378   -- sign extension from w8 to w32 (over s8)
 379   --   unfortunately, hs-java is using Word8 everywhere (while
 380   --   it should be Int8 actually)
 381   s8_w32 :: Word8 -> Word32
 382   s8_w32 w8 = fromIntegral s8
 383     where s8 = (fromIntegral w8) :: Int8