Initial commit: fork of https://github.com/tomahawkins/verilog

Data/BitVec.hs

+-- | Unsigned bit vectors.
+module Data.BitVec
+  ( BitVec
+  , bitVec
+  , select
+  , width
+  , value
+  ) where
+
+import Data.Bits
+
+data BitVec = BitVec Int Integer deriving (Show, Eq)
+
+instance Num BitVec where
+  BitVec w1 v1 + BitVec w2 v2 = bitVec (max w1 w2) (v1 + v2)
+  BitVec w1 v1 - BitVec w2 v2 = bitVec (max w1 w2) (v1 - v2)
+  BitVec w1 v1 * BitVec w2 v2 = bitVec (max w1 w2) (v1 * v2)
+  abs = id
+  signum (BitVec _ v) = if v == 0 then bitVec 1 0 else bitVec 1 1
+  fromInteger i = bitVec (width i) i
+    where
+    width :: Integer -> Int
+    width a
+      | a ==  0   = 0
+      | a == -1   = 1
+      | otherwise = 1 + width (shiftR a 1)
+
+instance Bits BitVec where
+  BitVec w1 v1 .&.   BitVec w2 v2 = bitVec (max w1 w2) (v1 .&.   v2)
+  BitVec w1 v1 .|.   BitVec w2 v2 = bitVec (max w1 w2) (v1 .|.   v2)
+  BitVec w1 v1 `xor` BitVec w2 v2 = bitVec (max w1 w2) (v1 `xor` v2)
+  complement (BitVec w v) = bitVec w $ complement v
+  shift (BitVec w v) i = bitVec w $ shift v i
+  rotate _ _ = undefined --XXX  To lazy to implemented it now.
+  bit i = fromInteger $ bit i
+  testBit (BitVec _ v) i = testBit v i
+  bitSize (BitVec w _) = w
+  bitSizeMaybe (BitVec w _) = Just w
+  isSigned _ = False
+  popCount (BitVec _ v) = popCount v
+
+instance Monoid BitVec where
+  mempty = BitVec 0 0
+  mappend (BitVec w1 v1) (BitVec w2 v2) = BitVec (w1 + w2) (shiftL v1 w2 .|. v2)
+
+-- | BitVec construction, given width and value.
+bitVec :: Int -> Integer -> BitVec
+bitVec w v = BitVec w' $ v .&. ((2 ^ fromIntegral w') - 1)
+  where
+  w' = max w 0
+
+-- | Bit seclection.  LSB is 0.
+select :: BitVec -> (BitVec, BitVec) -> BitVec
+select (BitVec _ v) (msb, lsb) = bitVec (fromIntegral $ value $ msb - lsb + 1) $ shiftR v (fromIntegral $ value $ lsb)
+
+-- | Width of a 'BitVec'.
+width :: BitVec -> Int
+width (BitVec w _) = w
+
+-- | Value of a 'BitVec'.
+value :: BitVec -> Integer
+value (BitVec _ v) = v
+

LICENSE

+Copyright (c) Tom Hawkins 2011 - 2015
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

Language/Verilog.hs

+-- | A parser for Verilog.
+module Language.Verilog
+  ( module Language.Verilog.AST
+  , module Language.Verilog.Parser
+  ) where
+
+import Language.Verilog.AST
+import Language.Verilog.Parser
+

Language/Verilog/AST.hs

+module Language.Verilog.AST
+  ( Identifier
+  , Module     (..)
+  , ModuleItem (..)
+  , Stmt       (..)
+  , LHS        (..)
+  , Expr       (..)
+  , UniOp      (..)
+  , BinOp      (..)
+  , Sense      (..)
+  , Call       (..)
+  , PortBinding
+  , Case
+  , Range
+  ) where
+
+import Data.Bits
+import Data.List
+import Data.Maybe
+import Text.Printf
+
+import Data.BitVec
+
+type Identifier = String
+
+data Module = Module Identifier [Identifier] [ModuleItem] deriving Eq
+
+instance Show Module where
+  show (Module name ports items) = unlines
+    [ "module " ++ name ++ (if null ports then "" else "(" ++ commas ports ++ ")") ++ ";"
+    , unlines' $ map show items
+    , "endmodule"
+    ]
+
+data ModuleItem
+  = Comment    String
+  | Parameter  (Maybe Range) Identifier Expr
+  | Localparam (Maybe Range) Identifier Expr
+  | Input      (Maybe Range) [Identifier]
+  | Output     (Maybe Range) [Identifier]
+  | Inout      (Maybe Range) [Identifier]
+  | Wire       (Maybe Range) [(Identifier, Maybe Expr)]
+  | Reg        (Maybe Range) [(Identifier, Maybe Range)]
+  | Integer    [Identifier]
+  | Initial    Stmt
+  | Always     (Maybe Sense) Stmt
+  | Assign     LHS Expr
+  | Instance   Identifier [PortBinding] Identifier [PortBinding]
+  deriving Eq
+
+type PortBinding = (Identifier, Maybe Expr)
+
+instance Show ModuleItem where
+  show a = case a of
+    Comment    a     -> "// " ++ a
+    Parameter  r n e -> printf "parameter %s%s = %s;"  (showRange r) n (showExprConst e)
+    Localparam r n e -> printf "localparam %s%s = %s;" (showRange r) n (showExprConst e)
+    Input      r a   -> printf "input  %s%s;" (showRange r) (commas a)
+    Output     r a   -> printf "output %s%s;" (showRange r) (commas a)
+    Inout      r a   -> printf "inout  %s%s;" (showRange r) (commas a)
+    Wire       r a   -> printf "wire   %s%s;" (showRange r) (commas [ a ++ showAssign r | (a, r) <- a ])
+    Reg        r a   -> printf "reg    %s%s;" (showRange r) (commas [ a ++ showRange  r | (a, r) <- a ])
+    Integer      a   -> printf "integer %s;"  $ commas a
+    Initial    a     -> printf "initial\n%s" $ indent $ show a
+    Always     Nothing  b -> printf "always\n%s" $ indent $ show b
+    Always     (Just a) b -> printf "always @(%s)\n%s" (show a) $ indent $ show b
+    Assign     a b   -> printf "assign %s = %s;" (show a) (show b)
+    Instance   m params i ports
+      | null params -> printf "%s %s %s;"     m                                  i (showPorts show ports)
+      | otherwise   -> printf "%s #%s %s %s;" m (showPorts showExprConst params) i (showPorts show ports)
+    where
+    showPorts :: (Expr -> String) -> [(Identifier, Maybe Expr)] -> String
+    showPorts s ports = printf "(%s)" $ commas [ printf ".%s(%s)" i (if isJust arg then s $ fromJust arg else "") | (i, arg) <- ports ]
+    showAssign :: Maybe Expr -> String
+    showAssign a = case a of
+      Nothing -> ""
+      Just a -> printf " = %s" $ show a
+  
+showRange :: Maybe Range -> String
+showRange Nothing = ""
+showRange (Just (h, l)) = printf "[%s:%s] " (showExprConst h) (showExprConst l)
+
+indent :: String -> String
+indent a = '\t' : f a
+  where
+  f [] = []
+  f (a : rest)
+    | a == '\n' = "\n\t" ++ f rest
+    | otherwise = a : f rest
+
+unlines' :: [String] -> String
+unlines' = intercalate "\n"
+
+data Expr
+  = String     String
+  | Number     BitVec
+  | ConstBool  Bool
+  | Ident      Identifier
+  | IdentRange Identifier Range
+  | IdentBit   Identifier Expr
+  | Repeat     Expr [Expr]
+  | Concat     [Expr]
+  | ExprCall   Call
+  | UniOp      UniOp Expr
+  | BinOp      BinOp Expr Expr
+  | Mux        Expr Expr Expr
+  | Bit        Expr Int
+  deriving Eq
+
+data UniOp = Not | BWNot | UAdd | USub deriving Eq
+
+instance Show UniOp where
+  show a = case a of
+    Not   -> "!"
+    BWNot -> "~"
+    UAdd  -> "+"
+    USub  -> "-"
+
+data BinOp
+  = And   
+  | Or    
+  | BWAnd 
+  | BWXor 
+  | BWOr  
+  | Mul   
+  | Div   
+  | Mod   
+  | Add   
+  | Sub   
+  | ShiftL
+  | ShiftR
+  | Eq    
+  | Ne    
+  | Lt    
+  | Le    
+  | Gt    
+  | Ge    
+  deriving Eq
+
+instance Show BinOp where
+  show a = case a of
+    And    -> "&&"
+    Or     -> "||"
+    BWAnd  -> "&"
+    BWXor  -> "^"
+    BWOr   -> "|"
+    Mul    -> "*"
+    Div    -> "/"
+    Mod    -> "%"
+    Add    -> "+"
+    Sub    -> "-"
+    ShiftL -> "<<"
+    ShiftR -> ">>"
+    Eq     -> "=="
+    Ne     -> "!="
+    Lt     -> "<"
+    Le     -> "<="
+    Gt     -> ">"
+    Ge     -> ">="
+
+showBitVecDefault :: BitVec -> String
+showBitVecDefault a = printf "%d'h%x" (width a) (value a)
+
+showBitVecConst :: BitVec -> String
+showBitVecConst a = show $ value a
+
+instance Show Expr where show = showExpr showBitVecDefault
+
+showExprConst :: Expr -> String
+showExprConst = showExpr showBitVecConst
+
+showExpr :: (BitVec -> String) -> Expr -> String
+showExpr bv a = case a of
+  String     a        -> printf "\"%s\"" a
+  Number     a        -> bv a
+  ConstBool  a        -> printf "1'b%s" (if a then "1" else "0")
+  Ident      a        -> a
+  IdentBit   a b      -> printf "%s[%s]"    a (showExprConst b)
+  IdentRange a (b, c) -> printf "%s[%s:%s]" a (showExprConst b) (showExprConst c)
+  Repeat     a b      -> printf "{%s {%s}}" (showExprConst a) (commas $ map s b)
+  Concat     a        -> printf "{%s}" (commas $ map show a)
+  ExprCall   a        -> show a
+  UniOp      a b      -> printf "(%s %s)" (show a) (s b)
+  BinOp      a b c    -> printf "(%s %s %s)" (s b) (show a) (s c)
+  Mux        a b c    -> printf "(%s ? %s : %s)" (s a) (s b) (s c)
+  Bit        a b      -> printf "(%s [%d])" (s a) b
+  where
+  s = showExpr bv
+
+instance Num Expr where
+  (+) = BinOp Add
+  (-) = BinOp Sub
+  (*) = BinOp Mul
+  negate = UniOp USub
+  abs = undefined
+  signum = undefined
+  fromInteger = Number . fromInteger
+
+instance Bits Expr where
+  (.&.) = BinOp BWAnd
+  (.|.) = BinOp BWOr
+  xor   = BinOp BWXor
+  complement = UniOp BWNot
+  isSigned _ = False
+  shift        = error "Not supported: shift"
+  rotate       = error "Not supported: rotate"
+  bitSize      = error "Not supported: bitSize"
+  bitSizeMaybe = error "Not supported: bitSizeMaybe"
+  testBit      = error "Not supported: testBit"
+  bit          = error "Not supported: bit"
+  popCount     = error "Not supported: popCount"
+
+
+instance Monoid Expr where
+  mempty      = 0
+  mappend a b = mconcat [a, b]
+  mconcat     = Concat
+
+data LHS
+  = LHS       Identifier
+  | LHSBit    Identifier Expr
+  | LHSRange  Identifier Range
+  | LHSConcat [LHS]
+  deriving Eq
+
+instance Show LHS where
+  show a = case a of
+    LHS        a        -> a
+    LHSBit     a b      -> printf "%s[%s]"    a (showExprConst b)
+    LHSRange   a (b, c) -> printf "%s[%s:%s]" a (showExprConst b) (showExprConst c)
+    LHSConcat  a        -> printf "{%s}" (commas $ map show a)
+
+data Stmt
+  = Block                 (Maybe Identifier) [Stmt]
+  | StmtReg               (Maybe Range) [(Identifier, Maybe Range)]
+  | StmtInteger           [Identifier]
+  | Case                  Expr [Case] (Maybe Stmt)
+  | BlockingAssignment    LHS Expr
+  | NonBlockingAssignment LHS Expr
+  | For                   (Identifier, Expr) Expr (Identifier, Expr) Stmt
+  | If                    Expr Stmt Stmt
+  | StmtCall              Call
+  | Delay                 Expr Stmt
+  | Null
+  deriving Eq
+
+commas :: [String] -> String
+commas = intercalate ", "
+
+instance Show Stmt where
+  show a = case a of
+    Block                 Nothing  b        -> printf "begin\n%s\nend" $ indent $ unlines' $ map show b
+    Block                 (Just a) b        -> printf "begin : %s\n%s\nend" a $ indent $ unlines' $ map show b
+    StmtReg               a b               -> printf "reg    %s%s;" (showRange a) (commas [ a ++ showRange  r | (a, r) <- b ])
+    StmtInteger           a                 -> printf "integer %s;" $ commas a
+    Case                  a b Nothing       -> printf "case (%s)\n%s\nendcase"                 (show a) (indent $ unlines' $ map showCase b)
+    Case                  a b (Just c)      -> printf "case (%s)\n%s\n\tdefault:\n%s\nendcase" (show a) (indent $ unlines' $ map showCase b) (indent $ indent $ show c)
+    BlockingAssignment    a b               -> printf "%s = %s;" (show a) (show b)
+    NonBlockingAssignment a b               -> printf "%s <= %s;" (show a) (show b)
+    For                   (a, b) c (d, e) f -> printf "for (%s = %s; %s; %s = %s)\n%s" a (show b) (show c) d (show e) $ indent $ show f
+    If                    a b Null          -> printf "if (%s)\n%s"           (show a) (indent $ show b)
+    If                    a b c             -> printf "if (%s)\n%s\nelse\n%s" (show a) (indent $ show b) (indent $ show c)
+    StmtCall              a                 -> printf "%s;" (show a)
+    Delay                 a b               -> printf "#%s %s" (showExprConst a) (show b)
+    Null                                    -> ";"
+
+type Case = ([Expr], Stmt)
+
+showCase :: Case -> String
+showCase (a, b) = printf "%s:\n%s" (commas $ map show a) (indent $ show b)
+
+data Call = Call Identifier [Expr] deriving Eq
+
+instance Show Call where
+  show (Call a b) = printf "%s(%s)" a (commas $ map show b)
+
+data Sense
+  = Sense        LHS
+  | SenseOr      Sense Sense
+  | SensePosedge LHS
+  | SenseNegedge LHS
+  deriving Eq
+
+instance Show Sense where
+  show a = case a of
+    Sense        a -> show a
+    SenseOr      a b -> printf "%s or %s" (show a) (show b)
+    SensePosedge a   -> printf "posedge %s" (show a)
+    SenseNegedge a   -> printf "negedge %s" (show a)
+
+type Range = (Expr, Expr)
+

Language/Verilog/Parser.hs

+module Language.Verilog.Parser
+  ( parseFile
+  , preprocess
+  ) where
+
+import Language.Verilog.AST
+import Language.Verilog.Parser.Lex
+import Language.Verilog.Parser.Parse
+import Language.Verilog.Parser.Preprocess
+import Language.Verilog.Parser.Tokens
+
+-- | Parses a file given a table of predefined macros, the file name, and the file contents.
+parseFile :: [(String, String)] -> FilePath -> String -> [Module]
+parseFile env file content = modules tokens
+  where
+  tokens = map relocate $ alexScanTokens $ preprocess env file content
+  relocate :: Token -> Token
+  relocate (Token t s (Position _ l c)) = Token t s $ Position file l c
+

Language/Verilog/Parser/Lex.x

+{
+{-# OPTIONS_GHC -w #-}
+module Language.Verilog.Parser.Lex
+  ( alexScanTokens
+  ) where
+
+import Language.Verilog.Parser.Tokens
+
+}
+
+%wrapper "posn"
+
+-- Numbers
+
+$nonZeroDecimalDigit = [1-9]
+$decimalDigit = [0-9]
+@binaryDigit  = [0-1]
+@octalDigit   = [0-7]
+@hexDigit     = [0-9a-fA-F]
+
+@decimalBase = "'" [dD]
+@binaryBase  = "'" [bB]
+@octalBase   = "'" [oO]
+@hexBase     = "'" [hH]
+
+@binaryValue         = @binaryDigit ("_" | @binaryDigit)*
+@octalValue  = @octalDigit  ("_" | @octalDigit)*
+@hexValue    = @hexDigit    ("_" | @hexDigit)*
+
+@unsignedNumber = $decimalDigit ("_" | $decimalDigit)*
+
+@size = @unsignedNumber
+
+@decimalNumber
+  = @unsignedNumber
+  | @size? @decimalBase @unsignedNumber
+
+@binaryNumber = @size? @binaryBase @binaryValue
+@octalNumber  = @size? @octalBase  @octalValue
+@hexNumber    = @size? @hexBase    @hexValue
+  
+-- $exp  = [eE]
+-- $sign = [\+\-]
+-- @realNumber = unsignedNumber "." unsignedNumber | unsignedNumber ( "." unsignedNumber)? exp sign? unsignedNumber
+@number = @decimalNumber | @octalNumber | @binaryNumber | @hexNumber
+
+-- Strings
+
+@string = \" [^\r\n]* \"
+
+-- Identifiers
+
+@escapedIdentifier = "\" ($printable # $white)+ $white
+@simpleIdentifier  = [a-zA-Z_] [a-zA-Z0-9_\$]*
+@systemIdentifier = "$" [a-zA-Z0-9_\$]+
+
+
+tokens :-
+
+  "always"           { tok KW_always     }
+  "assign"           { tok KW_assign     }
+  "begin"            { tok KW_begin      }
+  "case"             { tok KW_case       }
+  "default"          { tok KW_default    }
+  "else"             { tok KW_else       }
+  "end"              { tok KW_end        }
+  "endcase"          { tok KW_endcase    }
+  "endmodule"        { tok KW_endmodule  }
+  "for"              { tok KW_for        }
+  "if"               { tok KW_if         }
+  "initial"          { tok KW_initial    }
+  "inout"            { tok KW_inout      }
+  "input"            { tok KW_input      }
+  "integer"          { tok KW_integer    }
+  "localparam"       { tok KW_localparam }
+  "module"           { tok KW_module     }
+  "negedge"          { tok KW_negedge    }
+  "or"               { tok KW_or         }
+  "output"           { tok KW_output     }
+  "parameter"        { tok KW_parameter  }
+  "posedge"          { tok KW_posedge    }
+  "reg"              { tok KW_reg        }
+  "wire"             { tok KW_wire       }
+
+  @simpleIdentifier  { tok Id_simple  }
+  @escapedIdentifier { tok Id_escaped }
+  @systemIdentifier  { tok Id_system  }
+
+  @number            { tok Lit_number }
+  @string            { tok Lit_string }
+
+  "("                { tok Sym_paren_l }
+  ")"                { tok Sym_paren_r }
+  "["                { tok Sym_brack_l }
+  "]"                { tok Sym_brack_r }
+  "{"                { tok Sym_brace_l }
+  "}"                { tok Sym_brace_r }
+  "~"                { tok Sym_tildy }
+  "!"                { tok Sym_bang }
+  "@"                { tok Sym_at }
+  "#"                { tok Sym_pound }
+  "%"                { tok Sym_percent }
+  "^"                { tok Sym_hat }
+  "&"                { tok Sym_amp }
+  "|"                { tok Sym_bar }
+  "*"                { tok Sym_aster }
+  "."                { tok Sym_dot }
+  ","                { tok Sym_comma }
+  ":"                { tok Sym_colon }
+  ";"                { tok Sym_semi }
+  "="                { tok Sym_eq }
+  "<"                { tok Sym_lt }
+  ">"                { tok Sym_gt }
+  "+"                { tok Sym_plus }
+  "-"                { tok Sym_dash }
+  "?"                { tok Sym_question }
+  "/"                { tok Sym_slash }
+  "$"                { tok Sym_dollar }
+  "'"                { tok Sym_s_quote }
+
+  "~&"               { tok Sym_tildy_amp }
+  "~|"               { tok Sym_tildy_bar }
+  "~^"               { tok Sym_tildy_hat }
+  "^~"               { tok Sym_hat_tildy }
+  "=="               { tok Sym_eq_eq }
+  "!="               { tok Sym_bang_eq }
+  "&&"               { tok Sym_amp_amp }
+  "||"               { tok Sym_bar_bar }
+  "**"               { tok Sym_aster_aster }
+  "<="               { tok Sym_lt_eq }
+  ">="               { tok Sym_gt_eq }
+  ">>"               { tok Sym_gt_gt }
+  "<<"               { tok Sym_lt_lt }
+  "++"               { tok Sym_plus_plus }
+  "--"               { tok Sym_dash_dash }
+  "+="               { tok Sym_plus_eq }
+  "-="               { tok Sym_dash_eq }
+  "*="               { tok Sym_aster_eq }
+  "/="               { tok Sym_slash_eq }
+  "%="               { tok Sym_percent_eq }
+  "&="               { tok Sym_amp_eq }
+  "|="               { tok Sym_bar_eq }
+  "^="               { tok Sym_hat_eq }
+  "+:"               { tok Sym_plus_colon }
+  "-:"               { tok Sym_dash_colon }
+  "::"               { tok Sym_colon_colon }
+  ".*"               { tok Sym_dot_aster }
+  "->"               { tok Sym_dash_gt }
+  ":="               { tok Sym_colon_eq }
+  ":/"               { tok Sym_colon_slash }
+  "##"               { tok Sym_pound_pound }
+  "[*"               { tok Sym_brack_l_aster }
+  "[="               { tok Sym_brack_l_eq }
+  "=>"               { tok Sym_eq_gt }
+  "@*"               { tok Sym_at_aster }
+  "(*"               { tok Sym_paren_l_aster }
+  "*)"               { tok Sym_aster_paren_r }
+  "*>"               { tok Sym_aster_gt }
+
+  "==="              { tok Sym_eq_eq_eq }
+  "!=="              { tok Sym_bang_eq_eq }
+  "=?="              { tok Sym_eq_question_eq }
+  "!?="              { tok Sym_bang_question_eq }
+  ">>>"              { tok Sym_gt_gt_gt }
+  "<<<"              { tok Sym_lt_lt_lt }
+  "<<="              { tok Sym_lt_lt_eq }
+  ">>="              { tok Sym_gt_gt_eq }
+  "|->"              { tok Sym_bar_dash_gt }
+  "|=>"              { tok Sym_bar_eq_gt }
+  "[->"              { tok Sym_brack_l_dash_gt }
+  "@@("              { tok Sym_at_at_paren_l }
+  "(*)"              { tok Sym_paren_l_aster_paren_r }
+  "->>"              { tok Sym_dash_gt_gt }
+  "&&&"              { tok Sym_amp_amp_amp }
+
+  "<<<="             { tok Sym_lt_lt_lt_eq }
+  ">>>="             { tok Sym_gt_gt_gt_eq }
+
+  $white             ;
+
+  .                  { tok Unknown }
+
+{
+tok :: TokenName -> AlexPosn -> String -> Token
+tok t (AlexPn _ l c) s = Token t s $ Position "" l c
+}
+
+

Language/Verilog/Parser/Preprocess.hs

+module Language.Verilog.Parser.Preprocess
+  ( uncomment
+  , preprocess
+  ) where
+
+-- | Remove comments from code.
+uncomment :: FilePath -> String -> String
+uncomment file a = uncomment a
+  where
+  uncomment a = case a of
+    ""               -> ""
+    '/' : '/' : rest -> "  " ++ removeEOL rest
+    '/' : '*' : rest -> "  " ++ remove rest
+    '"'       : rest -> '"' : ignoreString rest
+    a         : rest -> a   : uncomment rest
+
+  removeEOL a = case a of
+    ""          -> ""
+    '\n' : rest -> '\n' : uncomment rest 
+    '\t' : rest -> '\t' : removeEOL rest
+    _    : rest -> ' '  : removeEOL rest
+
+  remove a = case a of
+    ""               -> error $ "File ended without closing comment (*/): " ++ file
+    '"' : rest       -> removeString rest
+    '\n' : rest      -> '\n' : remove rest
+    '\t' : rest      -> '\t' : remove rest
+    '*' : '/' : rest -> "  " ++ uncomment rest
+    _ : rest         -> " "  ++ remove rest
+
+  removeString a = case a of
+    ""                -> error $ "File ended without closing string: " ++ file
+    '"' : rest        -> " "  ++ remove       rest
+    '\\' : '"' : rest -> "  " ++ removeString rest
+    '\n' : rest       -> '\n' :  removeString rest
+    '\t' : rest       -> '\t' :  removeString rest
+    _    : rest       -> ' '  :  removeString rest
+
+  ignoreString a = case a of
+    ""                -> error $ "File ended without closing string: " ++ file
+    '"' : rest        -> '"' : uncomment rest
+    '\\' : '"' : rest -> "\\\"" ++ ignoreString rest
+    a : rest          -> a : ignoreString rest
+
+-- | A simple `define preprocessor.  
+preprocess :: [(String, String)] -> FilePath -> String -> String
+preprocess env file content = unlines $ pp True [] env $ lines $ uncomment file content
+  where
+  pp :: Bool -> [Bool] -> [(String, String)] -> [String] -> [String]
+  pp _ _ _ [] = []
+  pp on stack env (a : rest) = case words a of
+    "`define" : name : value -> "" : pp on stack (if on then (name, ppLine env $ unwords value) : env else env) rest
+    "`ifdef"  : name : _     -> "" : pp (on && (elem    name $ fst $ unzip env)) (on : stack) env rest 
+    "`ifndef" : name : _     -> "" : pp (on && (notElem name $ fst $ unzip env)) (on : stack) env rest 
+    "`else" : _
+      | not $ null stack     -> "" : pp (head stack && not on) stack env rest
+      | otherwise            -> error $ "`else  without associated `ifdef/`ifndef: " ++ file
+    "`endif" : _
+      | not $ null stack     -> "" : pp (head stack) (tail stack) env rest
+      | otherwise            -> error $ "`endif  without associated `ifdef/`ifndef: " ++ file
+    _                        -> (if on then ppLine env a else "") : pp on stack env rest
+
+ppLine :: [(String, String)] -> String -> String
+ppLine _ "" = ""
+ppLine env ('`' : a) = case lookup name env of
+  Just value -> value ++ ppLine env rest
+  Nothing    -> error $ "Undefined macro: `" ++ name ++ "  Env: " ++ show env
+  where
+  name = takeWhile (flip elem $ ['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9'] ++ ['_']) a
+  rest = drop (length name) a
+ppLine env (a : b) = a : ppLine env b
+

Language/Verilog/Simulator.hs

+module Language.Verilog.Simulator
+  ( Simulator
+  , SimCommand  (..)
+  , SimResponse (..)
+  , simulator
+  ) where
+
+import Control.Monad (when)
+import Data.Array.IO
+import Data.Bits
+import Data.IORef
+import Data.Monoid
+import System.IO
+
+import Data.VCD hiding (Var, step)
+import qualified Data.VCD as VCD
+
+import Data.BitVec
+import Language.Verilog.Netlist
+
+--check msg = putStrLn msg >> hFlush stdout
+
+-- | A Simulator executes 'SimCommand's.
+type Simulator = SimCommand -> IO (Maybe SimResponse)
+
+-- | Simulation commands.
+data SimCommand
+  = Init         (Maybe FilePath)
+  | Step
+  | GetSignalId  Path
+  | GetSignal    NetId
+  | Close
+
+-- | Simulation responses.
+data SimResponse
+  = Id    NetId  -- ^ Response to GetSignalId.
+  | Value BitVec -- ^ Response to GetSignal.
+
+-- | Builds a 'Simulator' given a 'Netlist'.
+simulator :: Netlist BlackBoxInit -> IO Simulator
+simulator netlist' = do
+  let netlist = sortTopo netlist'
+  memory <- memory netlist
+  vcd    <- newIORef Nothing
+  sample <- newIORef $ return ()
+  step   <- newIORef $ return ()
+  return $ \ cmd -> case cmd of
+    Init        file -> initialize netlist memory vcd file sample step
+    Step             -> readIORef step >>= id >> return Nothing
+    GetSignalId path -> return $ getSignalId netlist path
+    GetSignal   id   -> readArray memory id >>= return . Just . Value
+    Close            -> close vcd sample step >> return Nothing
+
+getSignalId :: Netlist BlackBoxInit -> Path -> Maybe SimResponse
+getSignalId netlist path = case lookup path paths' of
+  Nothing -> Nothing
+  Just i  -> Just $ Id i
+  where
+  paths = [ (paths, id) | Reg id _ paths _ <- netlist ] ++ [ (paths, id) | Var id _ paths _ <- netlist ] 
+  paths' = [ (path, id) | (paths, id) <- paths, path <- paths ]
+
+type Memory = IOArray Int BitVec
+
+memory :: Netlist BlackBoxInit -> IO Memory
+memory netlist
+  | null netlist = error "Empty netlist, nothing to simulate."
+  | otherwise    = newArray (0, maximum ids) 0
+  where
+  ids = concatMap f netlist
+  f a = case a of
+    Var  a _ _ _ -> [a]
+    Reg  a _ _ _ -> [a]
+    BBox _ _ _   -> []
+
+initialize :: Netlist BlackBoxInit -> Memory -> IORef (Maybe VCDHandle) -> Maybe FilePath -> IORef (IO ()) -> IORef (IO ()) -> IO (Maybe SimResponse)
+initialize netlist memory vcd file sample step = do
+  close vcd sample step
+  mapM_ (initializeNet memory) netlist 
+  case file of
+    Nothing -> return ()
+    Just file -> do
+      h <- openFile file WriteMode
+      vcd' <- newVCD h S
+      writeIORef vcd $ Just vcd'
+      writeIORef sample $ VCD.step vcd' 1
+      mapM_ (f memory vcd' sample) netlist
+  netlist <- mapM initializeBBox netlist
+  initializeStep netlist memory sample step
+  return Nothing
+  where
+  f :: Memory -> VCDHandle -> IORef (IO ()) -> Net BlackBoxInit -> IO ()
+  f memory vcd sample a = case a of
+    BBox _ _ _ -> return ()
+    _ -> mapM_ (\ signal -> do
+      sample' <- var vcd signal $ bitVec width 0
+      modifyIORef sample (>> (readArray memory i >>= sample'))
+      ) signals
+    where
+    (i, width, signals) = case a of
+      Reg i w p _ -> (i, w, p)
+      Var i w p _ -> (i, w, p)
+      BBox _ _ _ -> undefined
+
+initializeNet :: Memory -> Net BlackBoxInit -> IO ()
+initializeNet memory a = case a of
+  Var  i w _ _ -> writeArray memory i $ bitVec w 0
+  Reg  i w _ _ -> writeArray memory i $ bitVec w 0
+  BBox _ _ _   -> return ()
+
+initializeBBox :: Net BlackBoxInit -> IO (Net BlackBoxStep)
+initializeBBox a = case a of
+  Var a b c d -> return $ Var a b c d
+  Reg a b c d -> return $ Reg a b c d
+  BBox i o init -> init >>= return . BBox i o
+
+initializeStep :: Netlist BlackBoxStep -> Memory -> IORef (IO ()) -> IORef (IO ()) -> IO ()
+initializeStep netlist memory sample step = do
+  let steps = map stepNet netlist
+  writeIORef step $ do
+    sequence_ steps
+    readIORef sample >>= id
+  where
+  read   = readArray memory
+  write' = writeMemory memory
+  stepNet :: Net BlackBoxStep -> IO ()
+  stepNet a = case a of
+    BBox inputs outputs f -> do
+      outs <- mapM read inputs >>= f
+      sequence_ [ write' a b | (a, b) <- zip outputs outs ]
+    Reg q _ _ d -> read d >>= write' q
+    Var i _ _ expr -> case expr of
+      AInput        -> return ()
+      AVar    a     -> read a >>= write
+      AConst  a     -> write a
+      ASelect a b c -> do { a <- read a; b <- read b; c <- read c; write $ select a (b, c) }
+      ABWNot  a     -> read a >>= write . complement
+      ABWAnd  a b   -> do { a <- read a; b <- read b; write $ a .&. b }
+      ABWXor  a b   -> do { a <- read a; b <- read b; write $ a `xor` b }
+      ABWOr   a b   -> do { a <- read a; b <- read b; write $ a .|. b }
+      AMul    a b   -> do { a <- read a; b <- read b; write $ a * b }
+      AAdd    a b   -> do { a <- read a; b <- read b; write $ a + b }
+      ASub    a b   -> do { a <- read a; b <- read b; write $ a - b }
+      AShiftL a b   -> do { a <- read a; b <- read b; write $ shiftL a $ fromIntegral $ value b }
+      AShiftR a b   -> do { a <- read a; b <- read b; write $ shiftR a $ fromIntegral $ value b }
+      AEq     a b   -> do { a <- read a; b <- read b; write $ bitVec 1 (if value a == value b then 1 else 0) }
+      ANe     a b   -> do { a <- read a; b <- read b; write $ bitVec 1 (if value a /= value b then 1 else 0) }
+      ALt     a b   -> do { a <- read a; b <- read b; write $ bitVec 1 (if value a <  value b then 1 else 0) }
+      ALe     a b   -> do { a <- read a; b <- read b; write $ bitVec 1 (if value a <= value b then 1 else 0) }
+      AGt     a b   -> do { a <- read a; b <- read b; write $ bitVec 1 (if value a >  value b then 1 else 0) }
+      AGe     a b   -> do { a <- read a; b <- read b; write $ bitVec 1 (if value a >= value b then 1 else 0) }
+      AMux    a b c -> do { a <- read a; b <- read b; c <- read c; write (if value a /= 0 then b else c) }
+      AConcat a b   -> do { a <- read a; b <- read b; write $ mappend a b }
+      where
+      write = write' i
+
+writeMemory :: Memory -> Int -> BitVec -> IO ()
+writeMemory memory i a = do
+  b <- readArray memory i
+  when (width b /= width a) $ error $ "Memory update with different bit-vector width:  index: " ++ show i ++ "  old: " ++ show b ++ "  new: " ++ show a
+  writeArray memory i a
+
+close :: IORef (Maybe VCDHandle) -> IORef (IO ()) -> IORef (IO ()) -> IO ()
+close vcd sample step = do
+  vcd' <- readIORef vcd
+  case vcd' of
+    Nothing -> return ()
+    Just vcd -> hClose $ handle vcd
+  writeIORef vcd    $ Nothing
+  writeIORef sample $ return ()
+  writeIORef step   $ return ()
+

Setup.hs

+module Main (main) where
+
+import Distribution.Simple (defaultMain)
+
+main :: IO ()
+main = defaultMain

verilog.cabal

+name:    verilog
+version: 0.0.12
+
+category: Language, Hardware, Embedded
+
+synopsis: Verilog preprocessor, parser, and AST.
+
+description:
+  A parser and supporting a small subset of Verilog.
+  Intended for machine generated, synthesizable code.
+
+author:     Tom Hawkins <tomahawkins@gmail.com>
+maintainer: Tom Hawkins <tomahawkins@gmail.com>
+
+license:      BSD3
+license-file: LICENSE
+
+homepage: http://github.com/tomahawkins/verilog
+
+build-type:    Simple
+cabal-version: >= 1.10
+
+library
+  default-language: Haskell2010
+  build-tools:
+    alex  >= 3 && < 4,
+    happy >= 1 && < 2
+  build-depends:
+    base       >= 4.8.2.0   && < 5.0,
+    array      >= 0.5.1.0   && < 0.6
+
+  exposed-modules:
+    Data.BitVec
+    Language.Verilog
+    Language.Verilog.AST
+    Language.Verilog.Parser
+    Language.Verilog.Parser.Lex
+    Language.Verilog.Parser.Parse
+    Language.Verilog.Parser.Preprocess
+    Language.Verilog.Parser.Tokens
+
+  ghc-options: -W
+
+source-repository head
+  type:     git
+  location: git://github.com/tomahawkins/verilog.git
+