Mate.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
   3 {-# LANGUAGE ForeignFunctionInterface #-}
   4 module Main where
   5
   6 import Data.Binary
   7 import Data.String
   8 import System.Environment hiding (getEnv)
   9 import qualified Data.Map as M
  10 import qualified Data.ByteString.Lazy as B
  11
  12 import Text.Printf
  13
  14 import Control.Monad
  15
  16 import qualified JVM.Assembler as J
  17 import JVM.Assembler hiding (Instruction)
  18 import JVM.Common
  19 import JVM.ClassFile
  20 import JVM.Converter
  21 import JVM.Dump
  22
  23 import Foreign
  24 import Foreign.Ptr
  25 import Foreign.C.Types
  26
  27 import Harpy
  28 import Harpy.X86Disassembler
  29
  30
  31 foreign import ccall "dynamic"
  32    code_void :: FunPtr (CInt -> IO CInt) -> (CInt -> IO CInt)
  33
  34
  35 $(callDecl "callAsWord32" [t|Word32|])
  36
  37 main = do
  38   args <- getArgs
  39   case args of
  40     [clspath] -> do
  41       clsFile <- decodeFile clspath
  42       let cp = constsPool (clsFile :: Class Pointers)
  43       putStrLn "==== constpool: ===="
  44       putStrLn $ showListIx $ M.elems cp
  45       cf <- parseClassFile clspath
  46       putStrLn "==== classfile dump: ===="
  47       dumpClass cf
  48       putStrLn "==== random stuff: ===="
  49       let mainmethod = lookupMethod "main" cf -- "main|([Ljava/lang/String;)V" cf
  50       case mainmethod of
  51         Nothing -> putStrLn "no main found"
  52         Just main ->
  53           case attrByName main "Code" of
  54             Nothing -> putStrLn "no code attr found"
  55             Just bytecode -> do
  56               putStrLn "woot, running now"
  57               allocaArray 26 (\ p -> mapM_ (\ i -> poke (advancePtr p i) 0) [0..25] >> runstuff p bytecode)
  58     _ -> error "Synopsis: dump-class File.class"
  59
  60 runstuff :: Ptr Int32 -> B.ByteString -> IO ()
  61 runstuff env bytecode = do
  62           let emittedcode = compile $ codeInstructions $ decodeMethod bytecode
  63           (_, Right ((entryPtr, endOffset), disasm)) <- runCodeGen emittedcode env ()
  64           printf "entry point: 0x%08x\n" ((fromIntegral $ ptrToIntPtr entryPtr) :: Int)
  65
  66           let entryFuncPtr = ((castPtrToFunPtr entryPtr) :: FunPtr (CInt -> IO CInt))
  67           result <- code_void entryFuncPtr (fromIntegral 0x1337)
  68           let iresult::Int; iresult = fromIntegral result
  69           printf "result: 0x%08x\n" iresult -- expecting (2 * 0x1337) + 0x42 = 0x26b0
  70
  71           result2 <- code_void entryFuncPtr (fromIntegral (-0x20))
  72           let iresult2::Int; iresult2 = fromIntegral result2
  73           printf "result: 0x%08x\n" iresult2 -- expecting 0x2
  74
  75
  76           -- s/mov ebx 0x6666/mov eax 0x6666/
  77           let patchit = plusPtr entryPtr 0xb
  78           poke patchit (0xb8 :: Word8)
  79
  80           result3 <- code_void entryFuncPtr (fromIntegral 0)
  81           let iresult3::Int; iresult3 = fromIntegral result3
  82           printf "result: 0x%08x\n" iresult3 -- expecting 0x6666
  83
  84           printf "disasm:\n"
  85           mapM_ (putStrLn . showAtt) disasm
  86
  87           printf "patched disasm:\n"
  88           Right newdisasm <- disassembleBlock entryPtr endOffset
  89           mapM_ (putStrLn . showAtt) $ newdisasm
  90
  91           return ()
  92
  93
  94 entryCode :: CodeGen e s ()
  95 entryCode = do push ebp
  96                mov ebp esp
  97
  98 exitCode :: CodeGen e s ()
  99 exitCode = do mov esp ebp
 100               pop ebp
 101               ret
 102
 103 compile :: [J.Instruction] -> CodeGen (Ptr Int32) s ((Ptr Word8, Int), [Instruction])
 104 compile insn = do
 105   entryCode
 106   mapM compile_ins insn
 107   exitCode
 108   d <- disassemble
 109   c <- getEntryPoint
 110   end <- getCodeOffset
 111   return ((c,end),d)
 112
 113 compile_ins :: J.Instruction -> CodeGen (Ptr Int32) s ()
 114 compile_ins (BIPUSH w8) = do mov eax ((fromIntegral w8) :: Word32)
 115 compile_ins (PUTSTATIC w16) = do add eax (Disp 8, ebp) -- add first argument to %eax
 116 compile_ins (GETSTATIC w16) = do nop
 117 compile_ins ICONST_2 = do mov ebx (0x6666 :: Word32) -- patch me!
 118 compile_ins IMUL = do nop
 119   -- mov eax (0 :: Word32)
 120   -- jmp eax
 121 compile_ins RETURN = do nop
 122 compile_ins _ = do nop
 123
 124 -- TODO: actually this function already exists in hs-java-0.3!
 125 lookupMethod :: B.ByteString -> Class Resolved -> Maybe (Method Resolved)
 126 lookupMethod name cls = look (classMethods cls)
 127   where
 128     look [] = Nothing
 129     look (f:fs)
 130       | methodName f == name = Just f
 131       | otherwise  = look fs