Haskell で仮想マシンを書く

モナドの練習として仮想マシンを書く。レジスタとメモリを、キーをレジスタまたはアドレスとし値を保持できる Map で表すことにしよう。

type Regs r x = Map.Map r x
type Memory p x = Map.Map p x
data VM r p x = VM (Regs r x) (Memory p x) deriving (Eq, Show)

この仮想マシンを状態モナドにして、メモリとレジスタを更新／参照する関数 store, load, storeReg, loadReg を用意し、runStateT や evalStateT で実行することを考える。

利用しているメモリアドレスの上限をレジスタで管理することにすると、単純化したメモリアロケーションを行う関数 alloc が書ける。

alloc r = do
  fp <- loadReg r
  modifyReg (Map.insert r (succ fp))
  return $ succ fp

具体的にレジスタ FP をもった仮想マシン vm0 を考えることにする。

data Reg = FP deriving (Eq, Ord, Show, Enum)
vm0 :: VM Reg Int Int
vm0 = VM (Map.fromList $ zip (enumFrom FP) [0 .. ]) Map.empty

メモリをアロケートしてそこに値を書き込む処理 assign は以下のように書ける。

assign x = do
  p <- alloc FP
  store x p
  return p

これを使うと、以下のような手続き型言語のような処理が書ける。ここで var はアドレス値から値を取得する関数で、全体を計算の連鎖として書くために必要だった。
また plus は liftM2 (+) で定義されるモナドで、 m r -> m r -> m r の型を持つ。

test00 = do
  x <- assign 10
  y <- assign 3
  (plus (var x) (var y))

Main> run0 test00
(13,VM (fromList [(FP,2)]) (fromList [(1,10),(2,3)]))

続く。

以下、全コード。

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
import qualified Data.Map as Map
import Control.Monad.State
import Data.Maybe

type Regs r x = Map.Map r x
type Memory p x = Map.Map p x
data VM r p x = VM (Regs r x) (Memory p x) deriving (Eq, Show)

-- Register の更新
modifyReg :: MonadState (VM r p x) m => (Regs r x -> Regs r x) -> m ()
modifyReg f = modify $ \(VM rs ms) -> VM (f rs) ms
-- Memory の更新
modifyMem :: MonadState (VM r p x) m => (Memory p x -> Memory p x) -> m ()
modifyMem f = modify $ \(VM rs ms) -> VM rs (f ms)

-- load from Register
loadReg :: (Ord r, MonadState (VM r t x) m) => r -> m x
loadReg r = do
  VM rs _ <- get
  return $ fromMaybe (error "un-initialized reg") (Map.lookup r rs)
-- store to Register
storeReg :: (Ord r, MonadState (VM r p x) m) => r -> x -> m ()
storeReg r x = modifyReg (Map.insert r x)

-- load from memory
load :: (Ord p, MonadState (VM r p x) m) => p -> m x
load p = do
  VM _ ms <- get
  return $ fromMaybe (error "un-initialized memory") (Map.lookup p ms)
-- store to memory
store :: (Ord p, MonadState (VM r p x) m) => x -> p -> m ()  
store x p = modifyMem (Map.insert p x)

-- memory allocate use register r as free pointer.
alloc :: (Enum x, Ord r, MonadState (VM r p x) m) => r -> m x
alloc r = do
  fp <- loadReg r
  modifyReg (Map.insert r (succ fp))
  return $ succ fp

-- test machine with one register
data Reg = FP deriving (Eq, Ord, Show, Enum)
vm0 :: VM Reg Int Int
vm0 = VM (Map.fromList $ zip (enumFrom FP) [0 .. ]) Map.empty

-- 新規の領域に x を保存
assign x = do
  p <- alloc FP
  store x p
  return p

assign' p = do
  x <- p
  assign x

-- 変数 p を参照
var :: (Ord p, MonadState (VM r p x) m) => p -> m x
var = load

plus :: (Monad m, Num r) => m r -> m r -> m r
plus = liftM2 (+)
  
minus :: (Monad m, Num r) => m r -> m r -> m r
minus = liftM2 (-)

run0 f = runStateT f vm0

eval0 f = evalStateT f vm0

test00 :: Monad m => StateT (VM Reg Int Int) m Int
test00 = do
  x <- assign 10
  y <- assign 3
  (plus (var x) (var y))

test01 :: Monad m => StateT (VM Reg Int Int) m Int
test01 = do
  x <- assign 10                      -- x = 10
  y <- assign 3                       -- y = 3
  z <- assign' (plus (var x) (var x)) -- z = x + x
  (minus (var z) (var y))             -- return z - y