examples/evaluator/Evaluator.hs

   1 module Main(main) where
   2
   3 import ArithTypes
   4 import ArithParser
   5
   6 import Harpy
   7 import Harpy.X86Disassembler
   8
   9 import Foreign
  10
  11 import Control.Monad
  12
  13 import System.Console.Readline
  14
  15 import Text.ParserCombinators.Parsec
  16
  17 $(callDecl "callAsWord32" [t|Word32|])
  18
  19 main :: IO ()
  20 main = do putStrLn "\n\n\n\nHarpy Interpreter"
  21           putStrLn "(type :help to see a help message)"
  22           allocaArray 26 (\ p -> mapM_ (\ i -> poke (advancePtr p i) 0) [0..25] >> repl p False)
  23
  24 repl :: Ptr Int32 -> Bool -> IO ()
  25 repl env verbose =
  26     do s <- readline "@ "
  27        case s of
  28          Nothing -> return ()
  29          Just s' -> do addHistory s'
  30                        interpret env verbose s'
  31
  32 interpret :: Ptr Int32 -> Bool -> String -> IO ()
  33 interpret env verbose s =
  34     do let e = parse statement "<standard input>" s
  35        case e of
  36          Left err -> do putStrLn (show err)
  37                         repl env verbose
  38          Right stmt -> run env verbose stmt
  39
  40 run :: Ptr Int32 -> Bool -> Stmt -> IO ()
  41 run env verbose (Cmd Help) =
  42     do putStrLn "Enter an arithmetic expression to evaluate it"
  43        putStrLn "  e.g. 5 / 2"
  44        putStrLn "Enter an assignment to set a variable"
  45        putStrLn "  e.g. a := 4 * 2 - (6 + 1)"
  46        putStrLn "Enter :help to see this message again"
  47        putStrLn "Enter :quit to exit"
  48        putStrLn "Enter :verbose to toggle disassembly output"
  49        repl env verbose
  50
  51 run env _ (Cmd Quit) = return ()
  52
  53 run env verbose (Cmd Verbose) = repl env (Prelude.not verbose)
  54
  55 run env verbose stmt@(Assign var exp) =
  56     do (i, ins) <- eval' env stmt
  57        when verbose (mapM_ (putStrLn . showIntel) ins)
  58        repl env verbose
  59
  60 run env verbose stmt@(Print exp) =
  61     do (i, ins) <- eval' env stmt
  62        putStrLn (show i)
  63        when verbose (mapM_ (putStrLn . showIntel) ins)
  64        repl env verbose
  65
  66 -- Function for compiling and executing statements.
  67 eval' :: Ptr Int32 -> Stmt -> IO (Int32, [Instruction])
  68 eval' env e = do (_, Right v) <- runCodeGen (compileAndRun e) env ()
  69                  return v
  70
  71 compileAndRun :: Stmt -> CodeGen (Ptr Int32) s (Int32, [Instruction])
  72 compileAndRun (Assign c exp) =
  73     do entryCode
  74        compileExp exp
  75        env <- getEnv
  76        mov (variableAddress env c) eax
  77        exitCode
  78        d <- disassemble
  79        callAsVoid
  80        return (0, d)
  81 compileAndRun (Print exp) =
  82     do entryCode
  83        compileExp exp
  84        exitCode
  85        d <- disassemble
  86        r <- callAsWord32
  87        return (fromIntegral r, d)
  88
  89 compileExp :: Exp -> CodeGen (Ptr Int32) s ()
  90 compileExp (Add e1 e2) = compileBinOp e1 e2 (add eax (Ind esp))
  91 compileExp (Sub e1 e2) = compileBinOp e1 e2 (sub eax (Ind esp))
  92 compileExp (Mul e1 e2) = compileBinOp e1 e2 (imul InPlace eax (Ind esp))
  93 compileExp (Div e1 e2) = compileBinOp e1 e2 (cdq >> idiv (Ind esp))
  94 compileExp (Lit i) = mov eax ((fromIntegral i) :: Word32)
  95 compileExp (Var c) = do env <- getEnv
  96                         mov eax (variableAddress env c)
  97
  98 compileBinOp :: Exp -> Exp -> CodeGen (Ptr Int32) s a -> CodeGen (Ptr Int32) s ()
  99 compileBinOp e1 e2 op = do compileExp e2
 100                            push eax
 101                            compileExp e1
 102                            op
 103                            add esp (4 :: Word32)
 104
 105 entryCode :: CodeGen e s ()
 106 entryCode = do push ebp
 107                mov ebp esp
 108
 109 exitCode :: CodeGen e s ()
 110 exitCode = do mov esp ebp
 111               pop ebp
 112               ret
 113
 114 variableAddress :: Ptr Int32 -> Char -> Addr
 115 variableAddress env c =
 116     let ofs = fromEnum c - fromEnum 'a'
 117         env' = advancePtr env ofs
 118     in Addr (fromIntegral (ptrToWordPtr env'))