■

data Reg = Zero | At | V0 | V1
         | A0 | A1 | A2 | A3
         | T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7
         | S0 | S1 | S2 | S3 | S4 | S5 | S6 | S7
         | T8 | T9
         | GP | SP | FP | RQ
         | PC
         deriving (Eq, Ord, Show, Enum, Bounded)

data Insn = Add Reg Reg Reg 
          | Sub Reg Reg Reg
          | J Word
          deriving (Eq, Ord, Show)
data PseudoInsn = Pseudo [Insn]
data Cell = W Word | I Insn deriving (Eq, Ord, Show)
data VM = VM (Map.Map Reg Cell) (Map.Map Word Cell) deriving (Eq, Show)

readReg r = gets $ \ (VM rs cs) -> fromMaybe err (Map.lookup r rs)
  where err = error $ "Invalid Register: " ++ show r
readMem a = gets $ \ (VM rs cs) -> fromMaybe err (Map.lookup a cs)
  where err = error $ "Invalid Address: " ++ show a
writeReg r x = modify $ \ (VM rs cs) -> VM (Map.insert r x rs) cs
writeMem a x = modify $ \ (VM rs cs) -> VM rs (Map.insert a x cs)

incr r = do
  W x <- readReg r
  writeReg r (W (x + 1))

fetch :: MonadState VM m => m Cell
fetch = do
  W pc <- readReg PC
  readMem pc

decode :: Cell -> Insn
decode (I x) = x
decode _ = error "Invalid Instruction"

exec :: MonadState VM m => m ()
exec = do
  op <- fetch
  case decode op of
    Add rs rt rd -> do
      W s <- readReg rs
      W t <- readReg rt
      writeReg rd (W (s + t))
      incr PC
      exec

Haskell で仮想マシンを書く fetch

仮想マシンなので命令はメモリから読もう。レジスタを２つ増やして、プログラムカウンタと計算結果を保存するレジスタを持つようにしてみる。命令は停止命令とACCレジスタをインクリメントする二つだけ用意しよう。

data Reg = PC | FP | ACC deriving (Eq, Ord, Show, Enum)
data Insn = INCR | STOP deriving (Eq, Ord, Show, Enum)

命令を PC から読み出す fetch と、それを decode する関数は、メモリアドレスとメモリの持つ値が両方とも同じ Int にしておくと簡単になる。

-- word = ptr
fetch :: (Ord x, Show x, MonadState (VM Reg x x) m) => m x
fetch = do
  pc <- loadReg PC
  load pc

decode :: Int -> Insn  
decode = toEnum

実行するのも簡単だ。fetch - decode と命令による分岐を書けば良い。とりあえずは ACC レジスタの値を返しておくことにする。ハンドアセンブルして命令列を作るほうが面倒なくらい。

exec ::  (MonadState (VM Reg Int Int) m) => m Int
exec = do
  op <- fetch
  case decode op of
    STOP -> do { loadReg ACC }
    INCR -> do { 
      acc <- loadReg ACC;
      storeReg ACC (acc + 1);
      pc <- loadReg PC;
      storeReg PC (pc + 1);
      exec }

適切なメモリとレジスタの状態を作って実行する。

*Main> evalStateT exec (makeVm [STOP])
0
*Main> evalStateT exec (makeVm [INCR, STOP])
1
*Main> evalStateT exec (makeVm [INCR, INCR, INCR, STOP])
3

これではハンドアセンブルがあまりに辛い。TMR-Issue6 (https://wiki.haskell.org/wikiupload/1/14/TMR-Issue6.pdf) を斜め読みすると、DSL としてアセンブラを書いている（ように見える）。同じことを目指してみよう。

たぶん続く。

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

Template Haskell (TH) でデータ定義

列挙型とその文字表現を、データで定義できる TH を書いた。

-- モジュールA
defDataConstsType "T_Digit" (map (\x -> "T_" ++ [intToDigit x]) [0..10])

defShowType "T_Digit" (map (\x -> 
                             ("T_" ++ [intToDigit x],
                              "'" ++ [intToDigit x] ++ "'")) [0..10])

このように書くと、下と同じ意味になる（はず）。

data T_Digit = T_0 | T_1 ...
instance Show T_Digit where
  show T_0 = "'0'"
  show T_1 = "'1'"
  ...

TH のコード本体は利用する側と別モジュールに書かなくてはいけない（制限）。

-- モジュールB
defDataConstsType :: String -> [String] -> Q [Dec]
defDataConstsType name ns = return d
  where
    d = [DataD [] (mkName name) []
         (map (\n -> NormalC (mkName n) []) ns)
         [mkName "Eq", mkName "Enum"]]

defShowType :: String -> [(String, String)] -> Q [Dec]
defShowType name ht = return d
  where
    d = [InstanceD []
           (AppT (ConT (mkName "Show")) (ConT (mkName name))) 
           [FunD (mkName "show")
            [Clause [VarP x] 
             (NormalB (CaseE (VarE x) 
                       --
                       (map (\(n,s) ->
                              Match (ConP (mkName n) []) (NormalB (LitE (StringL s))) []) ht))) []]]]
      where x = mkName "x"

PEG

PEG モドキを Haskell で。データ構造を定義した。Show のインスタンスにする部分は省略。

data PExp nt = Eps -- epsilon
          | AtomT String -- Terminal symbol
          | AtomNT nt -- Non-Terminal symbol
          | PExp nt :. PExp nt -- e1 e2
          | PExp nt :/ PExp nt -- e1 / e2
          | Opt (PExp nt) -- e?
          | ZeroOrMore (PExp nt) -- e*
          | OneOrMore (PExp nt) -- e+
          | And (PExp nt) -- &e
          | Not (PExp nt) -- !e
          deriving Eq

data Rule nt = nt :<- (PExp nt) deriving Eq
data Grammer nt = Grammer [Rule nt] deriving Show

そして以下のようにサンプルのグラマーを定義してやる。

pp (Grammer rs) = mapM_ (putStrLn . show) rs

data NT01 = Underscore | Digit | LowerCase | UpperCase | Identifier 
          deriving (Eq, Show)  

g01 :: Grammer NT01
g01 = Grammer [ underScore, digit, lowerCase, upperCase, identifier ]
  where
    underScore = Underscore :<- AtomT "_"
    digit = Digit :<- e
      where f n = [intToDigit n]
            e = foldl1 (:/) $ map (AtomT . f) [0..9]
    lowerCase = LowerCase :<- foldl1 (:/) [AtomT [x] | x <- ['a'..'z']]
    upperCase = UpperCase :<- foldl1 (:/) [AtomT [x] | x <- ['A'..'Z']]
    identifier = Identifier :<- 
                 ((AtomNT LowerCase :/ AtomNT UpperCase :/ AtomNT Underscore) :. 
                  (Opt (AtomNT LowerCase :/ AtomNT UpperCase :/ AtomNT Underscore :/ AtomNT Digit)))

そうすると以下のように出力される。

Main> pp g01
Underscore <- _
Digit <- 0 / 1 / 2 / 3 / 4 / 5 / 6 / 7 / 8 / 9
LowerCase <- a / b / c / d / e / f / g / h / i / j / k / l / m / n / o / p / q / r / s / t / u / v / w / x / y / z
UpperCase <- A / B / C / D / E / F / G / H / I / J / K / L / M / N / O / P / Q / R / S / T / U / V / W / X / Y / Z
Identifier <- ( LowerCase / UpperCase / Underscore ) ( ( LowerCase / UpperCase / Underscore / Digit )? )
Main> 

Java コード生成へ向けて

lisp/scheme でS式からコード生成を行いたい。最終的なイメージは以下のような Java の S 式表現から Java コードを生成することだ。

gosh> (print (jise->java
	      '((System.out.println "Hello, Java!")
		(declare x 0)
		(assign x 3)
		(when (= x 3)
		  (System.out.println "oops")))))

System.out.println("Hello, Java!");
int x = 0;
x = 3;
if (x == 3) {
  System.out.println("oops");
}

Java の構文要素を調べれて、S 式表現を検討すれば、あとは util.match あたりを使って単なる静的な式変形をすればよい。

sxml の簡易シリアライズ

SXML (http://ja.wikipedia.org/wiki/SXML) の名前空間部分を無視して文字列化する、簡単なシリアライザーを gauche で書いた。
以下使用例。生成された文字列と、その前段階のリストを同時に返している。

gosh> (simple-sxml->xml '(tag))
"<tag/>"
("<" "tag" () "/>")
gosh> (simple-sxml->xml '(html (@ (lang "ja")) (body)))
"<html lang=\"ja\"><body/></html>"
("<" #0="html" ((" " "lang" "=\"" "ja" "\"")) ">" (("<body/>")) "</" #0# ">")
gosh> (simple-sxml->xml '(tag (@ (attr1 "v1") (attr2 "v2")) (nested "Text Node") (empty)))
"<tag attr1=\"v1\" attr2=\"v2\"><nested>Text Node</nested><empty/></tag>"
("<" #0="tag" ((#1=" " "attr1" #2="=\"" "v1" #3="\"") (#1# "attr2" #2# "v2" #3#)) ">" (("<nested>Text Node</nested>" "<empty/>")) "</" #0# ">")

パターンマッチには util.match を使う。string-append を使って文字列を逐次生成するのは冗長に感じられたので、一旦文字列のリストを生成した後、 text.tree で文字列にすることにした。

(use util.match)
(use text.tree)
(define (simple-sxml->xml x)
  (define (rep1 x attrs)
    `("<" ,(symbol->string x) ,attrs "/>"))
  (define (rep x attrs . body)
    (let1 s (symbol->string x)
      `("<" ,s ,attrs ">" ,body "</" ,s ">")))
  (define (iter tree)
    (match x
      ((tag) (rep1 tag '()))
      ((tag ('@ (attr value) ...))
       (rep1 tag
            (map (lambda (a v)
                   (list " " (symbol->string a) "=\"" v "\"")) attr value)))
      ((tag ('@ (attr value) ...) rest ...)
       (rep tag
            (map (lambda (a v)
                   (list " " (symbol->string a) "=\"" v "\"")) attr value)
            (map simple-sxml->xml rest)))
      ((tag rest ...)
       (rep tag '() (map simple-sxml->xml rest)))
      (() "")
      ((? string? s) s)))
  (let1 r (iter x)
    (values (tree->string r) r)))