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 hiding (xor)
  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 IASTORE = do
 238         pop eax -- value
 239         pop ebx -- offset
 240         add ebx (1 :: Word32)
 241         pop ecx -- aref
 242         mov (ecx, ebx, S4) eax
 243     emit IALOAD = do
 244         pop ebx -- offset
 245         add ebx (1 :: Word32)
 246         pop ecx -- aref
 247         push (ecx, ebx, S4)
 248     emit ARRAYLENGTH = do
 249         pop eax
 250         push (Disp 0, eax)
 251     emit (NEWARRAY typ) = do
 252         let tsize = case decodeS (0 :: Integer) (B.pack [typ]) of
 253                     T_INT -> 4
 254                     _ -> error $ "newarray: type not implemented yet"
 255         -- get length from stack, but leave it there
 256         mov eax (Disp 0, esp)
 257         mov ebx (tsize :: Word32)
 258         -- multiple amount with native size of one element
 259         mul ebx -- result is in eax
 260         add eax (4 :: Word32) -- for "length" entry
 261         -- push amount of bytes to allocate
 262         push eax
 263         callMalloc
 264         pop eax -- ref to arraymemory
 265         pop ebx -- length
 266         mov (Disp 0, eax) ebx -- store length at offset 0
 267         push eax -- push ref again
 268     emit (NEW objidx) = do
 269         let objname = buildClassID cls objidx
 270         amount <- liftIO $ getMethodSize objname
 271         push (amount :: Word32)
 272         callMalloc
 273         -- TODO(bernhard): save reference somewhere for GC
 274         -- set method table pointer
 275         mtable <- liftIO $ getMethodTable objname
 276         mov (Disp 0, eax) mtable
 277     emit (CHECKCAST _) = nop -- TODO(bernhard): ...
 278     emit (BIPUSH val) = push ((fromIntegral val) :: Word32)
 279     emit (SIPUSH val) = push ((fromIntegral $ ((fromIntegral val) :: Int16)) :: Word32)
 280     emit (ICONST_0) = push (0 :: Word32)
 281     emit (ICONST_1) = push (1 :: Word32)
 282     emit (ICONST_2) = push (2 :: Word32)
 283     emit (ICONST_4) = push (4 :: Word32)
 284     emit (ICONST_5) = push (5 :: Word32)
 285     emit (ALOAD_ x) = emit (ILOAD_ x)
 286     emit (ILOAD_ x) = do
 287         push (Disp (cArgs_ x), ebp)
 288     emit (ALOAD x) = emit (ILOAD x)
 289     emit (ILOAD x) = do
 290         push (Disp (cArgs x), ebp)
 291     emit (ASTORE_ x) = emit (ISTORE_ x)
 292     emit (ISTORE_ x) = do
 293         pop eax
 294         mov (Disp (cArgs_ x), ebp) eax
 295     emit (ASTORE x) = emit (ISTORE x)
 296     emit (ISTORE x) = do
 297         pop eax
 298         mov (Disp (cArgs x), ebp) eax
 299
 300     emit (LDC1 x) = emit (LDC2 $ fromIntegral x)
 301     emit (LDC2 x) = do
 302         value <- case (constsPool cls) M.! x of
 303                       (CString s) -> liftIO $ getUniqueStringAddr s
 304                       _ -> error $ "LDCI... missing impl."
 305         push value
 306     emit (GETFIELD x) = do
 307         pop eax -- this pointer
 308         let (cname, fname) = buildFieldOffset cls x
 309         offset <- liftIO $ getFieldOffset cname fname
 310         push (Disp (fromIntegral $ offset * 4), eax) -- get field
 311     emit (PUTFIELD x) = do
 312         pop ebx -- value to write
 313         pop eax -- this pointer
 314         let (cname, fname) = buildFieldOffset cls x
 315         offset <- liftIO $ getFieldOffset cname fname
 316         mov (Disp (fromIntegral $ offset * 4), eax) ebx -- set field
 317
 318     emit IADD = do pop ebx; pop eax; add eax ebx; push eax
 319     emit ISUB = do pop ebx; pop eax; sub eax ebx; push eax
 320     emit IMUL = do pop ebx; pop eax; mul ebx; push eax
 321     emit IXOR = do pop ebx; pop eax; xor eax ebx; push eax
 322     emit (IINC x imm) = do
 323         add (Disp (cArgs x), ebp) (s8_w32 imm)
 324
 325     emit (IF_ACMP cond x) = emit (IF_ICMP cond x)
 326     emit (IF_ICMP cond _) = do
 327         pop eax -- value2
 328         pop ebx -- value1
 329         cmp ebx eax -- intel syntax is swapped (TODO(bernhard): test that plz)
 330         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 331         let l = getLabel sid lmap
 332         case cond of
 333           C_EQ -> je  l; C_NE -> jne l
 334           C_LT -> jl  l; C_GT -> jg  l
 335           C_GE -> jge l; C_LE -> jle l
 336
 337     emit (IF cond _) = do
 338         pop eax -- value1
 339         cmp eax (0 :: Word32) -- TODO(bernhard): test that plz
 340         let sid = case successor bb of TwoTarget _ t -> t; _ -> error "bad"
 341         let l = getLabel sid lmap
 342         case cond of
 343           C_EQ -> je  l; C_NE -> jne l
 344           C_LT -> jl  l; C_GT -> jg  l
 345           C_GE -> jge l; C_LE -> jle l
 346
 347     emit (GOTO _ ) = do
 348         let sid = case successor bb of OneTarget t -> t; _ -> error "bad"
 349         jmp $ getLabel sid lmap
 350
 351     emit RETURN = do mov esp ebp; pop ebp; ret
 352     emit ARETURN = emit IRETURN
 353     emit IRETURN = do
 354         pop eax
 355         mov esp ebp
 356         pop ebp
 357         ret
 358     emit invalid = error $ "insn not implemented yet: " ++ (show invalid)
 359
 360     callMalloc :: CodeGen e s ()
 361     callMalloc = do
 362         calladdr <- getCurrentOffset
 363         let w32_calladdr = 5 + calladdr
 364         let malloaddr = (fromIntegral getMallocAddr :: Word32)
 365         call (malloaddr - w32_calladdr)
 366         add esp (4 :: Word32)
 367         push eax
 368
 369   -- for locals we use a different storage
 370   cArgs :: Word8 -> Word32
 371   cArgs x = if (x' >= thisMethodArgCnt)
 372       -- TODO(bernhard): maybe s/(-4)/(-8)/
 373       then fromIntegral $ (-4) * (x' - thisMethodArgCnt + 1)
 374       else 4 + (thisMethodArgCnt * 4) - (4 * x')
 375     where x' = fromIntegral x
 376
 377   cArgs_ :: IMM -> Word32
 378   cArgs_ x = cArgs $ case x of I0 -> 0; I1 -> 1; I2 -> 2; I3 -> 3
 379
 380   thisMethodArgCnt :: Word32
 381   thisMethodArgCnt = isNonStatic + (fromIntegral $ length args)
 382     where
 383     (Just m) = lookupMethod method cls
 384     (MethodSignature args _) = methodSignature m
 385     isNonStatic = if S.member ACC_STATIC (methodAccessFlags m)
 386         then 0
 387         else 1 -- one argument for the this pointer
 388
 389
 390   -- sign extension from w8 to w32 (over s8)
 391   --   unfortunately, hs-java is using Word8 everywhere (while
 392   --   it should be Int8 actually)
 393   s8_w32 :: Word8 -> Word32
 394   s8_w32 w8 = fromIntegral s8
 395     where s8 = (fromIntegral w8) :: Int8