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