Mate.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
   3 module Main where
   4
   5 import Data.Binary
   6 import Data.String
   7 import System.Environment hiding (getEnv)
   8 import qualified Data.Map as M
   9 import qualified Data.ByteString.Lazy as B
  10
  11 import Text.Printf
  12
  13 import Control.Monad
  14
  15 import qualified JVM.Assembler as J
  16 import JVM.Assembler hiding (Instruction)
  17 import JVM.Common
  18 import JVM.ClassFile
  19 import JVM.Converter
  20 import JVM.Dump
  21
  22 import Foreign
  23
  24 import Harpy
  25 import Harpy.X86Disassembler
  26
  27
  28 $(callDecl "callAsWord32" [t|Word32|])
  29
  30 main = do
  31   args <- getArgs
  32   case args of
  33     [clspath] -> do
  34       clsFile <- decodeFile clspath
  35       let cp = constsPool (clsFile :: Class Pointers)
  36       putStrLn "==== constpool: ===="
  37       putStrLn $ showListIx $ M.elems cp
  38       cf <- parseClassFile clspath
  39       putStrLn "==== classfile dump: ===="
  40       dumpClass cf
  41       putStrLn "==== random stuff: ===="
  42       let mainmethod = lookupMethod "main" cf -- "main|([Ljava/lang/String;)V" cf
  43       case mainmethod of
  44         Nothing -> putStrLn "no main found"
  45         Just main ->
  46           case attrByName main "Code" of
  47             Nothing -> putStrLn "no code attr found"
  48             Just bytecode -> do
  49               putStrLn "woot, running now"
  50               allocaArray 26 (\ p -> mapM_ (\ i -> poke (advancePtr p i) 0) [0..25] >> runstuff p bytecode)
  51     _ -> error "Synopsis: dump-class File.class"
  52
  53 runstuff :: Ptr Int32 -> B.ByteString -> IO ()
  54 runstuff env bytecode = do
  55           (_, Right (ret, disasm)) <- runCodeGen (compile $ codeInstructions $ decodeMethod bytecode) env ()
  56           printf "return value: 0x%08x\n" ret
  57           printf "disasm:\n"
  58           mapM_ (putStrLn . showAtt) disasm
  59           return ()
  60
  61 entryCode :: CodeGen e s ()
  62 entryCode = do push ebp
  63                mov ebp esp
  64
  65 exitCode :: CodeGen e s ()
  66 exitCode = do mov esp ebp
  67               pop ebp
  68               ret
  69
  70 compile :: [J.Instruction] -> CodeGen (Ptr Int32) s (Int32, [Instruction])
  71 compile insn = do
  72   entryCode
  73   mapM compile_ins insn
  74   exitCode
  75   d <- disassemble
  76   r <- callAsWord32
  77   return (fromIntegral r, d)
  78
  79 compile_ins :: J.Instruction -> CodeGen (Ptr Int32) s ()
  80 compile_ins (BIPUSH w8) = do mov eax ((fromIntegral w8) :: Word32)
  81 compile_ins (PUTSTATIC w16) = do nop
  82 compile_ins (GETSTATIC w16) = do nop
  83 compile_ins ICONST_2 = do nop
  84 compile_ins IMUL = do nop
  85 compile_ins RETURN = do nop
  86 compile_ins _ = do nop
  87
  88 -- TODO: actually this function already exists in hs-java-0.3!
  89 lookupMethod :: B.ByteString -> Class Resolved -> Maybe (Method Resolved)
  90 lookupMethod name cls = look (classMethods cls)
  91   where
  92     look [] = Nothing
  93     look (f:fs)
  94       | methodName f == name = Just f
  95       | otherwise  = look fs