Verilogパーサで抽象構文木を生成するようにした

Verilogファイルから、抽象構文木を生成できるようにしました。
処理できる構文はまだまだ限定的ですが。。

Haskell Parsecで直接扱うことのできない左再帰の構文を
右再帰に変形している部分があるのですが (expression構文のところ)
ここをパースして右再帰に変形前の構造に戻して構文木を作る処理で
ちょっと頭がこんがらがりそうでしたが（こんがらがりました）。
（左再帰のところは、chainlとか chainl1をうまく使えばよいのかな？？）

このブログを書いてる時点のソースコード
 http://github.com/kei-os/vparsec/tree/ccd8e9ceea5794b7b64acc366725bd967f61aa08

データコンストラクタとかデータ型の名前に迷いがあったり
多相的な型を使えばパーサをもっと簡潔に書けるんじゃない？とか
いろいろ思うところはありますが、とにかく
Haskell慣れしながら改善していきたいと思います。

いまのところ、生成した抽象構文木を printで出力するしか
確認する方法を用意できていませんが
今後は、確認しやすい形式でダンプする仕組みを用意できればと思っています。
また、モジュールのインスタンス化など、モジュールの階層構造を
うまく表してみたいと思っています。
（あと、やっぱりこまめにブログに書いていこうかと思います。
　それとスピードが必要＞＜）

とりあえず、実装したものをいくつかと、パース実行結果を記載しておきます。

代数的データ型 (ソースから抜粋)
パース実行関数 (ソースから抜粋)
ghci実行例 (実行ログ)

代数的データ型

抽象構文木のノードに対応するデータ型を、次のように用意しました。
変更の可能性はありますが、いまのところ、ということで。

ふつけるでいうところの構造体スタイル、列挙型スタイル、共用体スタイルの
使い方になれてきました。
型クラスはまだうまく使えてない。
セレクタも使えてない。

data Module_ = MODULE
    { mName     :: String
    , mPorts    :: [String]
    , mItems    :: [ModuleItem_]
    } deriving (Eq, Show)

data ModuleItem_ = MI_PARAM_DECL    String              -- XXX TODO impl
                 | MI_CONT_ASSIGN   [NetAssign_]
                 | MI_PORT_DECL     Sig_
                 | MI_REG_DECL      Sig_
                 | MI_TIME_DECL     String              -- XXX TODO impl
                 | MI_INT_DECL      String              -- XXX TODO impl
                 | MI_NET_DECL      Sig_
                 | MI_INITIAL       Stmt_
                 | MI_ALWAYS        Stmt_
                   deriving (Eq, Show)

data Stmt_ = ST_BLOCKING_ASSIGN     BlockAssign_
           | ST_NON_BLOCKING_ASSIGN BlockAssign_
           | ST_PROCEDURAL_ASSIGN   RegAssign_
           | ST_TIMING_CONTROL_STMT TimingControl_
           | ST_CONDITIONAL_STMT    Condition_
--           | ST_CASE_STMT           String
--           | ST_LOOP_STMT           String
--           | ST_WAIT_STMT           String
--           | ST_DISABLE_STMT        String
--           | ST_EVENT_TRIGGER       String
             | ST_SEQ_BLOCK           Block_
--           | ST_PAR_BLOCK           String
--           | ST_TASK_ENABLE         String
--           | ST_SYSTEM_TASK_ENABLE  String
           | ST_NIL
             deriving (Eq, Show)

data RegAssign_ = REG_ASSIGN LValue_ Expr_ deriving (Eq, Show)        -- normal assignment (regAssignment)

data NBAssign_ = ASSIGN LValue_ DelayOrEvent_ Expr_ deriving (Eq, Show)     -- blockingAssignment
type BAssign_ = NBAssign_       -- nonBlockingAssignment

data NetAssign_ = NET_ASSIGN LValue_ Expr_ deriving (Eq, Show)

-- XXX first, support only "assign"
data ProcAssign_ = PROC_ASSIGN LValue_ Expr_ deriving (Eq, Show)

data TimingControl_ = TIMING_CONTROL DelayOrEvent_ Stmt_ deriving (Eq, Show)

data Condition_ = CONDITION CondExpr_ IfStmt_ ElseStmt_ deriving (Eq, Show)
type IfStmt_ = Stmt_
type ElseStmt_ = Stmt_

--data SeqBlock_ = SEQ_BLOCK Stmt_ NameOfBlock_ OutputDecl_ deriving (Eq, Show)   -- temp
--type NameOfBlock_ = String
--type OutputDecl_ = String       -- XXX temp

data DelayOrEvent_ = DE_DELAY_CONTROL DelayControl_
                   | DE_EVENT_CONTROL [Event_]
                   | DE_EXPR_EV Expr_ [Event_]
                   | DE_NIL
                     deriving (Eq, Show)

--data DelayControl_ = DL_NUM Integer | DL_IDENT String deriving (Eq, Show)
data DelayControl_ = DL_NUM Number_ | DL_IDENT String deriving (Eq, Show)

data Edge_ = POS | NEG | VALUE deriving (Eq, Show)
data Event_ = EVENT Edge_ Expr_ deriving (Eq, Show) -- new


data Primary_ = PR_NUMBER Number_       -- XXX TODO : test (Number_)
              | PR_IDENT String
              | PR_IDENT_EXPR String Expr_
              | PR_IDENT_RANGE String Range_
              | PR_CONCAT [Expr_]
              | PR_MINMAX_EXPR Expr_ Expr_ Expr_    -- min ( ,typ ,max)    -- XXX TODO : check order
                deriving (Eq, Show)

type UnaryOp_   = String
type BinaryOp_  = String
type CondExpr_  = Expr_
type IfExpr_    = Expr_
type ElseExpr_  = Expr_

data Expr_ = EX_PRIMARY Primary_
           | EX_U_PRIMARY UnaryOp_ Primary_
           | EX_NODE Expr_ BinaryOp_ Expr_             -- left op right
           | EX_COND CondExpr_ IfExpr_ ElseExpr_     -- cond ifexpr elseexpr
           | EX_STRING String
           | EX_NIL
             deriving (Eq, Show)

data LValue_ = LV_IDENT String
             | LV_IDENT_EXPR String Expr_
             | LV_IDENT_RANGE String Range_      -- identifier [ constant_expr : constant_expr ]
             | LV_CONCAT [Expr_]
               deriving (Eq, Show)

data BlockAssign_ = BLOCK_ASSIGN LValue_ DelayOrEvent_ Expr_ deriving (Eq, Show)

data BlockItem_ = BI_PARAM          -- XXX TODO impl
                | BI_REG Sig_
                | BI_INT            -- XXX TODO impl
                | BI_REAL           -- XXX TODO impl
                | BI_TIME           -- XXX TODO impl
                | BI_REALTIME       -- XXX TODO impl
                | BI_EVENT          -- XXX TODO impl
                  deriving (Eq, Show)

data Block_ = BLOCK String [BlockItem_] [Stmt_] deriving (Eq, Show)

------------------------------------------------------------

-- should i use Integer (not Int)??
type Typ_ = Int
--type Max_ = Int
type Max_ = Number_     -- XXX TODO : test
--type Min_ = Int
type Min_ = Number_     -- XXX TODO : test
--type Width_ = Int
type Width_ = String    -- XXX FIXME : temp for Number_
type Range_ = (Max_, Min_, Width_)

-- XXX TODO : reg / memory
data Sig_ = PORT_SIG { direction_ :: Direction_ , name_ :: [String] , range_ :: Range_ }
          | NET_SIG { netType_ :: NetType_, name_ :: [String], range_ :: Range_ }
          | REG_SIG { regType_ :: RegType_, name_ :: [String], range_ :: Range_ }
            deriving (Eq, Show, Ord)

data Direction_ = IN | OUT | INOUT | NONE deriving (Eq, Show, Ord)
data NetType_ = NET_WIRE | NET_TRI | NET_TRI1 | NET_SUPPLY0 | NET_WAND
              | NET_TRIAND | NET_TRI0 | NET_SUPPLY1 | NET_WOR | NET_TRIOR
                deriving (Eq, Show, Ord)

data RegType_ = REG | MEM deriving (Eq, Show, Ord)

data NumType_ = NUM_BIN | NUM_OCT | NUM_DEC | NUM_HEX deriving (Eq, Show, Ord)
data Number_ = NUMBER NumType_ String String deriving (Eq, Show, Ord)   -- type size value

パース実行関数

parseVerilogという関数にパースしたいファイル名を引数で渡して
パース処理を実行します。

parseVerilog :: FilePath -> IO ()
parseVerilog fname
    = do { input <- readFile fname
--         ; putStr input
         ; case parse verilog1995 fname input of
                Left err -> do { putStr "Error parsing at : " ; print err }
                Right x -> print x }

ghci実行例

たとえば次のような Verilogファイルを入力できます。

$ cat sample_dff.v

module sample_dff(
    clk,
    rst_n,
    en,
    d, q    
);

input clk, rst_n;
input en;
input [3:0] d;
output [3:0] q;

reg [3:0] q;

always@(posedge clk or negedge rst_n) begin
    if (!rst_n)     q <= 4'd0;
    else if (en)    q <= d;
    else            q <= q;
end

endmodule

GHCの対話型インタープリタ ghciを使った結果を貼っておきます。
MacOS X 10.5.6で GHC 6.10.1を使っています。

$ ghci
GHCi, version 6.10.1: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer ... linking ... done.
Loading package base ... linking ... done.

Prelude> :l Vparsec
Ok, modules loaded: Vparsec.

Prelude Vparsec> parseVerilog "sample_dff.v"
Loading package parsec-2.1.0.1 ... linking ... done.
MODULE {mName = "sample_dff", mPorts = ["clk","rst_n","en","d","q"],
mItems = [MI_PORT_DECL (PORT_SIG {direction_ = IN, name_ = ["clk","rst_n"], 
range_ = (NUMBER NUM_DEC "1" "0",NUMBER NUM_DEC "1" "0","1")}),
MI_PORT_DECL (PORT_SIG {direction_ = IN, name_ = ["en"], 
range_ = (NUMBER NUM_DEC "1" "0",NUMBER NUM_DEC "1" "0","1")}),
MI_PORT_DECL (PORT_SIG {direction_ = IN, name_ = ["d"], 
range_ = (NUMBER NUM_DEC "" "3",NUMBER NUM_DEC "" "0","width on impl ")}),
MI_PORT_DECL (PORT_SIG {direction_ = OUT, name_ = ["q"], 
range_ = (NUMBER NUM_DEC "" "3",NUMBER NUM_DEC "" "0","width on impl ")}),
MI_REG_DECL (REG_SIG {regType_ = REG, name_ = ["q"], 
range_ = (NUMBER NUM_DEC "" "3",NUMBER NUM_DEC "" "0","width on impl ")}),
MI_ALWAYS (ST_TIMING_CONTROL_STMT 
(TIMING_CONTROL (DE_EVENT_CONTROL [EVENT POS (EX_PRIMARY (PR_IDENT "clk")),
EVENT NEG (EX_PRIMARY (PR_IDENT "rst_n"))]) (ST_SEQ_BLOCK (BLOCK "" [] [ST_CONDITIONAL_STMT (CONDITION (EX_U_PRIMARY "!" (PR_IDENT "rst_n"))
(ST_NON_BLOCKING_ASSIGN (BLOCK_ASSIGN 
(LV_IDENT "q") DE_NIL (EX_PRIMARY (PR_NUMBER (NUMBER NUM_DEC "4" "0"))))) 
(ST_CONDITIONAL_STMT (CONDITION (EX_PRIMARY (PR_IDENT "en")) (ST_NON_BLOCKING_ASSIGN (BLOCK_ASSIGN 
(LV_IDENT "q") DE_NIL (EX_PRIMARY (PR_IDENT "d")))) 
(ST_NON_BLOCKING_ASSIGN (BLOCK_ASSIGN 
(LV_IDENT "q") DE_NIL (EX_PRIMARY (PR_IDENT "q")))))))]))))]}

んん、確認しづらい...です。
やはりうまくダンプしたいところです。