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, 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
  70
  71           result2 <- code_void entryFuncPtr (fromIntegral (-0x20))
  72           let iresult2::Int; iresult2 = fromIntegral result2
  73           printf "result: 0x%08x\n" iresult2
  74
  75           printf "disasm:\n"
  76           mapM_ (putStrLn . showAtt) disasm
  77           return ()
  78
  79
  80 entryCode :: CodeGen e s ()
  81 entryCode = do push ebp
  82                mov ebp esp
  83
  84 exitCode :: CodeGen e s ()
  85 exitCode = do mov esp ebp
  86               pop ebp
  87               ret
  88
  89 compile :: [J.Instruction] -> CodeGen (Ptr Int32) s (Ptr Word8, [Instruction])
  90 compile insn = do
  91   entryCode
  92   mapM compile_ins insn
  93   exitCode
  94   d <- disassemble
  95   c <- getEntryPoint
  96   return (c,d)
  97
  98 compile_ins :: J.Instruction -> CodeGen (Ptr Int32) s ()
  99 compile_ins (BIPUSH w8) = do mov eax ((fromIntegral w8) :: Word32)
 100 compile_ins (PUTSTATIC w16) = do add eax (Disp 8, ebp) -- add first argument to %eax
 101 compile_ins (GETSTATIC w16) = do nop
 102 compile_ins ICONST_2 = do nop
 103 compile_ins IMUL = do nop
 104 compile_ins RETURN = do nop
 105 compile_ins _ = do nop
 106
 107 -- TODO: actually this function already exists in hs-java-0.3!
 108 lookupMethod :: B.ByteString -> Class Resolved -> Maybe (Method Resolved)
 109 lookupMethod name cls = look (classMethods cls)
 110   where
 111     look [] = Nothing
 112     look (f:fs)
 113       | methodName f == name = Just f
 114       | otherwise  = look fs