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