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 foreign import ccall "getaddr"
  35   getaddr :: CUInt
  36
  37 foreign import ccall "callertrap"
  38   callertrap :: IO ()
  39
  40
  41 $(callDecl "callAsWord32" [t|Word32|])
  42
  43 main = do
  44   args <- getArgs
  45   case args of
  46     [clspath] -> do
  47       clsFile <- decodeFile clspath
  48       let cp = constsPool (clsFile :: Class Pointers)
  49       putStrLn "==== constpool: ===="
  50       putStrLn $ showListIx $ M.elems cp
  51       cf <- parseClassFile clspath
  52       putStrLn "==== classfile dump: ===="
  53       dumpClass cf
  54       putStrLn "==== random stuff: ===="
  55       let mainmethod = lookupMethod "main" cf -- "main|([Ljava/lang/String;)V" cf
  56       case mainmethod of
  57         Nothing -> putStrLn "no main found"
  58         Just main ->
  59           case attrByName main "Code" of
  60             Nothing -> putStrLn "no code attr found"
  61             Just bytecode -> do
  62               putStrLn "woot, running now"
  63               allocaArray 26 (\ p -> mapM_ (\ i -> poke (advancePtr p i) 0) [0..25] >> runstuff p bytecode)
  64     _ -> error "Synopsis: dump-class File.class"
  65
  66 runstuff :: Ptr Int32 -> B.ByteString -> IO ()
  67 runstuff env bytecode = do
  68           let emittedcode = (compile (fromIntegral getaddr)) $ codeInstructions $ decodeMethod bytecode
  69           (_, Right ((entryPtr, endOffset), disasm)) <- runCodeGen emittedcode env ()
  70           printf "entry point: 0x%08x\n" ((fromIntegral $ ptrToIntPtr entryPtr) :: Int)
  71
  72           let entryFuncPtr = ((castPtrToFunPtr entryPtr) :: FunPtr (CInt -> IO CInt))
  73           result <- code_void entryFuncPtr (fromIntegral 0x1337)
  74           let iresult::Int; iresult = fromIntegral result
  75           printf "result: 0x%08x\n" iresult -- expecting (2 * 0x1337) + 0x42 = 0x26b0
  76
  77           result2 <- code_void entryFuncPtr (fromIntegral (-0x20))
  78           let iresult2::Int; iresult2 = fromIntegral result2
  79           printf "result: 0x%08x\n" iresult2 -- expecting 0x2
  80
  81
  82           -- s/mov ebx 0x6666/mov eax 0x6666/
  83           let patchit = plusPtr entryPtr 0xb
  84           poke patchit (0xb8 :: Word8)
  85
  86           result3 <- code_void entryFuncPtr (fromIntegral 0)
  87           let iresult3::Int; iresult3 = fromIntegral result3
  88           printf "result: 0x%08x\n" iresult3 -- expecting 0x6666
  89
  90           printf "disasm:\n"
  91           mapM_ (putStrLn . showAtt) disasm
  92
  93           printf "patched disasm:\n"
  94           Right newdisasm <- disassembleBlock entryPtr endOffset
  95           mapM_ (putStrLn . showAtt) $ newdisasm
  96
  97           let addr :: Int; addr = (fromIntegral getaddr :: Int)
  98           printf "getaddr: 0x%08x\n" addr
  99
 100           return ()
 101
 102
 103 entryCode :: CodeGen e s ()
 104 entryCode = do push ebp
 105                mov ebp esp
 106
 107 exitCode :: CodeGen e s ()
 108 exitCode = do mov esp ebp
 109               pop ebp
 110               ret
 111
 112 compile :: Word32 -> [J.Instruction] -> CodeGen (Ptr Int32) s ((Ptr Word8, Int), [Instruction])
 113 compile trapaddr insn = do
 114   entryCode
 115   mapM compile_ins insn
 116   push eax
 117   mov ecx (trapaddr :: Word32)
 118   call ecx
 119   -- call trapaddr -- Y U DON'T WORK? (ask mr. gdb for help)
 120   pop eax
 121   exitCode
 122   d <- disassemble
 123   c <- getEntryPoint
 124   end <- getCodeOffset
 125   return ((c,end),d)
 126
 127 compile_ins :: J.Instruction -> CodeGen (Ptr Int32) s ()
 128 compile_ins (BIPUSH w8) = do mov eax ((fromIntegral w8) :: Word32)
 129 compile_ins (PUTSTATIC w16) = do add eax (Disp 8, ebp) -- add first argument to %eax
 130 compile_ins (GETSTATIC w16) = do nop
 131 compile_ins ICONST_2 = do mov ebx (0x6666 :: Word32) -- patch me!
 132 compile_ins IMUL = do nop
 133   -- mov eax (0 :: Word32)
 134   -- jmp eax
 135 compile_ins RETURN = do nop
 136 compile_ins _ = do nop
 137
 138 -- TODO: actually this function already exists in hs-java-0.3!
 139 lookupMethod :: B.ByteString -> Class Resolved -> Maybe (Method Resolved)
 140 lookupMethod name cls = look (classMethods cls)
 141   where
 142     look [] = Nothing
 143     look (f:fs)
 144       | methodName f == name = Just f
 145       | otherwise  = look fs