494 lines
16 KiB
Haskell
494 lines
16 KiB
Haskell
{-
|
|
|
|
MackerelParser.hs: Mackerel parser for parsing dev file and building the
|
|
syntax tree.
|
|
|
|
Part of Mackerel: a strawman device definition DSL for Barrelfish
|
|
|
|
Copyright (c) 2007, ETH Zurich.
|
|
All rights reserved.
|
|
|
|
This file is distributed under the terms in the attached LICENSE file.
|
|
If you do not find this file, copies can be found by writing to:
|
|
ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group.
|
|
-}
|
|
|
|
-- TODO
|
|
module MackerelParser where
|
|
|
|
{- Extra testing code must be commented after testing
|
|
-}
|
|
--module Main where
|
|
--import System
|
|
{- End of testing code -}
|
|
|
|
import Prelude
|
|
import Text.ParserCombinators.Parsec
|
|
import Text.ParserCombinators.Parsec.Expr
|
|
import qualified Text.ParserCombinators.Parsec.Token as P
|
|
import Text.ParserCombinators.Parsec.Language( javaStyle )
|
|
import Data.Char
|
|
import Data.Maybe
|
|
import qualified Poly
|
|
import qualified Space
|
|
|
|
import Attr
|
|
|
|
lexer = P.makeTokenParser (javaStyle
|
|
{ P.reservedNames = [
|
|
-- "addr",
|
|
"also",
|
|
"bytewise",
|
|
"constants",
|
|
"datatype",
|
|
"io",
|
|
"lsbfirst",
|
|
"many",
|
|
"msbfirst",
|
|
"pci",
|
|
"regarray",
|
|
"register",
|
|
"regtype",
|
|
-- "space",
|
|
"stepwise",
|
|
"type",
|
|
"valuewise",
|
|
"device"
|
|
]
|
|
|
|
, P.reservedOpNames = ["*","/","+","-"]
|
|
})
|
|
|
|
whiteSpace = P.whiteSpace lexer
|
|
reserved = P.reserved lexer
|
|
identifier = P.identifier lexer
|
|
stringLit = P.stringLiteral lexer
|
|
comma = P.comma lexer
|
|
commaSep = P.commaSep lexer
|
|
parens = P.parens lexer
|
|
braces = P.braces lexer
|
|
squares = P.squares lexer
|
|
semiSep = P.semiSep lexer
|
|
symbol = P.symbol lexer
|
|
integer = try ((P.lexeme lexer) binLiteral)
|
|
<|> try ((P.lexeme lexer) binOnes)
|
|
<|> P.integer lexer
|
|
commaSep1 = P.commaSep1 lexer
|
|
|
|
op = P.reservedOp lexer
|
|
|
|
data RegLoc = RegLoc String String Integer
|
|
| RegNoLoc
|
|
deriving Show
|
|
|
|
data ArrayLoc = ArrayListLoc [ Integer ]
|
|
| ArrayStepLoc Integer Integer
|
|
deriving Show
|
|
|
|
|
|
bin_op name fun assoc = Infix (do { op name; return fun}) assoc
|
|
|
|
binDigit = oneOf "01"
|
|
binLiteral = do { _ <- char '0'
|
|
; _ <- oneOf "bB"
|
|
; digits <- many1 binDigit
|
|
; let n = foldl (\x d -> 2*x + (digitToInt d)) 0 digits
|
|
; seq n (return (fromIntegral n))
|
|
}
|
|
|
|
binOnes = do { _ <- char '1'
|
|
; _ <- char 's'
|
|
; let n = -1
|
|
; seq n (return (fromIntegral n))
|
|
}
|
|
|
|
data BitOrder = LSBFIRST | MSBFIRST | NOORDER
|
|
deriving (Eq,Show)
|
|
|
|
data DeviceFile = DeviceFile AST [String]
|
|
|
|
data AST = Device String BitOrder [ AST ] String [ AST ]
|
|
-- name lsbfirst args desc defn
|
|
| Constants String String [ AST ] (Maybe Integer) SourcePos
|
|
| ConstVal String Expr String SourcePos
|
|
| RegField String Integer Attr AST String SourcePos
|
|
| SpaceDecl Space.Rec
|
|
| RegType String String AST SourcePos
|
|
| DataType String String AST BitOrder Integer SourcePos
|
|
| Register String Attr Bool RegLoc String AST SourcePos
|
|
| RegArray String Attr Bool RegLoc ArrayLoc String AST SourcePos
|
|
--Register name RO/RW also io/at desc regfields
|
|
| Arg String String
|
|
| NoBitFieldType
|
|
| TypeRef String (Maybe String)
|
|
| TypeDefn [ AST ]
|
|
| Error String
|
|
| Import String
|
|
deriving Show
|
|
|
|
devfile = do { whiteSpace
|
|
; imps <- many importdev
|
|
; dev <- device
|
|
; return (DeviceFile dev [i | (Import i) <- imps])
|
|
}
|
|
|
|
importdev = do { reserved "import"
|
|
; i <- identifier
|
|
; _ <- symbol ";"
|
|
; return (Import i)
|
|
}
|
|
|
|
device = do { reserved "device"
|
|
; name <- identifier
|
|
; order <- option LSBFIRST bitorder
|
|
; args <- parens (commaSep devarg)
|
|
; desc <- stringLit
|
|
; decls <- braces (many1 (devdecl args))
|
|
; _ <- symbol ";" <?> " ';' missing from end of " ++ name ++ " device specification"
|
|
; return (Device name order args desc decls)
|
|
}
|
|
|
|
bitorder = do{ reserved "lsbfirst" ; return LSBFIRST }
|
|
<|>
|
|
do{ reserved "msbfirst"; return MSBFIRST }
|
|
|
|
|
|
devarg = do { tp <- devargtype -- This must be a typename
|
|
; v <- identifier -- This is variable name
|
|
; return (Arg tp v)
|
|
}
|
|
|
|
devargtype = do { reserved "addr"; return "addr" }
|
|
<|> do { reserved "io"; return "io" }
|
|
<|> do { reserved "pci"; return "pci" }
|
|
|
|
-- Extra added structure to support register comprehension
|
|
|
|
devdecl args = register
|
|
<|> constants args
|
|
<|> spacedecl
|
|
<|> regtype
|
|
<|> dataType
|
|
<|> regarray
|
|
|
|
spacedecl = do { reserved "space"
|
|
; p <- getPosition
|
|
; i <- identifier
|
|
; a <- parens (commaSep identifier)
|
|
; t <- spaceType
|
|
; d <- stringLit
|
|
; _ <- symbol ";"
|
|
; return (SpaceDecl (Space.make i a d t p))
|
|
}
|
|
|
|
spaceType = do{ reserved "bytewise" ; return (Space.BYTEWISE 1) }
|
|
<|>
|
|
do{ reserved "valuewise"; return Space.VALUEWISE }
|
|
<|>
|
|
do{ reserved "registerwise"; return Space.REGISTERWISE }
|
|
<|>
|
|
do{ reserved "stepwise";
|
|
s <- parens integer;
|
|
return (Space.BYTEWISE s)
|
|
}
|
|
|
|
register = do { reserved "register"
|
|
; p <- getPosition
|
|
; i <- identifier
|
|
; a <- option RW regAttr
|
|
; als <- option False scanAlso
|
|
; loc <- regLoc
|
|
; d <- option i stringLit
|
|
; f <- format
|
|
; _ <- symbol ";"
|
|
; return (Register i a als loc d f p)
|
|
}
|
|
|
|
regarray = do { reserved "regarray"
|
|
; p <- getPosition
|
|
; i <- identifier
|
|
; a <- option RW regAttr
|
|
; als <- option False scanAlso
|
|
; loc <- regLoc
|
|
; aspec <- squares arraySpec
|
|
; d <- option i stringLit
|
|
; f <- format
|
|
; _ <- symbol ";"
|
|
; return (RegArray i a als loc aspec d f p)
|
|
}
|
|
|
|
scanAlso = do{ reserved "also"
|
|
; return True
|
|
}
|
|
|
|
regtype = do { reserved "regtype"
|
|
; p <- getPosition
|
|
; i <- identifier
|
|
; d <- stringLit
|
|
; f <- typeDefn
|
|
; _ <- symbol ";"
|
|
; return (RegType i d f p)
|
|
}
|
|
|
|
format = typeDefn <|> typeLabel
|
|
|
|
|
|
typeDefn = do { j <- braces (many1 regField)
|
|
; return (TypeDefn j) }
|
|
|
|
dataType = do { reserved "datatype"
|
|
; p <- getPosition
|
|
; i <- identifier
|
|
; (o,w) <- option (NOORDER,0) dataBitOrder
|
|
; d <- stringLit
|
|
; f <- braces (many1 dataField)
|
|
; _ <- symbol ";"
|
|
; return (DataType i d (TypeDefn f) o w p)
|
|
}
|
|
|
|
dataBitOrder = do { o <- bitorder
|
|
; i <- parens integer
|
|
; return (o,i)
|
|
}
|
|
|
|
dataField = do { p <- getPosition
|
|
; i <- identifier <|> symbol "_"
|
|
; width <- integer
|
|
; attr <- option NOATTR dataAttr
|
|
; tpe <- option NoBitFieldType typeLabel
|
|
; desc <- option i stringLit
|
|
; _ <- symbol ";"
|
|
; return (RegField i width attr tpe desc p)
|
|
}
|
|
|
|
typeLabel = do { reserved "type"
|
|
; i <- (parens typeReference)
|
|
; return i
|
|
}
|
|
|
|
typeReference = do { i1 <- identifier
|
|
; i2 <- option Nothing typeQualifier
|
|
; return (case i2 of
|
|
Just qual -> TypeRef qual (Just i1)
|
|
Nothing -> TypeRef i1 Nothing
|
|
)
|
|
}
|
|
|
|
typeQualifier = do { _ <- symbol "."
|
|
; i <- identifier
|
|
; return (Just i)
|
|
}
|
|
|
|
regField = do { p <- getPosition
|
|
; i <- identifier <|> symbol "_"
|
|
; width <- integer
|
|
; attr <- option NOATTR fieldAttr
|
|
; tpe <- option NoBitFieldType typeLabel
|
|
; desc <- option i stringLit
|
|
; _ <- symbol ";"
|
|
; return (RegField i width attr tpe desc p)
|
|
}
|
|
|
|
numberFormat = do{ i <- integer
|
|
; _ <- symbol "-"
|
|
; j <- integer
|
|
; return (j - i + 1)
|
|
}
|
|
|
|
dataAttr = do { reserved "rw"; return RW }
|
|
<|> do { reserved "mbz"; return MBZ }
|
|
<|> do { reserved "mb1"; return MB1 }
|
|
<|> do { reserved "rsvd"; return RSVD }
|
|
|
|
regAttr = do { reserved "rw" ; return RW }
|
|
<|> do { reserved "ro"; return RO }
|
|
<|> do { reserved "rc"; return RC }
|
|
<|> do { reserved "rwc"; return RWC }
|
|
<|> do { reserved "rw1c"; return RWC }
|
|
<|> do { reserved "wo"; return WO }
|
|
<|> do { reserved "rwzc"; return RWZC }
|
|
|
|
fieldAttr = regAttr
|
|
<|> do { reserved "ros"; return ROS }
|
|
<|> do { reserved "rwo"; return RWO }
|
|
<|> do { reserved "rwcs"; return RWCS }
|
|
<|> do { reserved "rw1cs"; return RWCS }
|
|
<|> do { reserved "rws"; return RWS }
|
|
<|> do { reserved "rwl"; return RWL }
|
|
<|> do { reserved "mbz"; return MBZ }
|
|
<|> do { reserved "mb1"; return MB1 }
|
|
<|> do { reserved "rsvd"; return RSVD }
|
|
|
|
binarySpace = do { reserved "addr" ; return "addr" }
|
|
<|> do { reserved "io" ; return "io" }
|
|
<|> do { reserved "pci" ; return "pci" }
|
|
|
|
|
|
regLocIdentified = do { base <- identifier; return (base, 0) }
|
|
<|> do { offset <- integer; return ("", offset) }
|
|
|
|
regLoc = do { reserved "noaddr"
|
|
; return RegNoLoc
|
|
}
|
|
<|>
|
|
do { sp <- binarySpace
|
|
; ( base, offset ) <- parens binLoc
|
|
; return ( RegLoc sp base offset )
|
|
}
|
|
<|>
|
|
do { sp <- identifier
|
|
; (base, offset) <- parens regLocIdentified
|
|
; return (RegLoc sp base offset)
|
|
}
|
|
|
|
binLoc = do { e1 <- identifier
|
|
; _ <- comma
|
|
; e2 <- integer
|
|
; return ( e1 , e2 ) }
|
|
|
|
arraySpec = try( arrayStepSpec )
|
|
<|> try( arrayListSpec )
|
|
<|> arrayContigSpec
|
|
|
|
arrayListSpec = do { l <- commaSep1 integer;
|
|
; return ( if (length l) == 1
|
|
then (ArrayStepLoc (head l) 0)
|
|
else (ArrayListLoc l) )
|
|
}
|
|
|
|
arrayStepSpec = do { base <- integer
|
|
; _ <- symbol ";"
|
|
; step <- integer
|
|
; return ( ArrayStepLoc base step )
|
|
}
|
|
|
|
arrayContigSpec = do { base <- integer
|
|
; return ( ArrayStepLoc base 0 )
|
|
}
|
|
|
|
constants args = do { reserved "constants"
|
|
; p <- getPosition
|
|
; i <- identifier
|
|
; w <- option Nothing constWidth
|
|
; d <- stringLit
|
|
; f <- braces (many1 (constField args))
|
|
; _ <- symbol ";"
|
|
; return (Constants i d f w p)
|
|
}
|
|
|
|
constWidth = do { _ <- reserved "width"
|
|
; i <- parens integer
|
|
; return (Just i)
|
|
}
|
|
|
|
constField args = do { i <- identifier
|
|
; p <- getPosition
|
|
; _ <- symbol "="
|
|
; e <- expr
|
|
; d <- option i stringLit
|
|
; _ <- symbol ";"
|
|
; return (ConstVal i e d p)
|
|
}
|
|
|
|
|
|
expr = buildExpressionParser expr_tab expr_factor
|
|
|
|
expr_tab :: OperatorTable Char () Expr
|
|
expr_tab = [[bin_op "*" (enc_binop "*") AssocLeft
|
|
, bin_op "/"(enc_binop "/") AssocLeft ]
|
|
,[bin_op "+" (enc_binop "+") AssocLeft
|
|
, bin_op "-" (enc_binop "-") AssocLeft ]
|
|
]
|
|
|
|
data Expr = ExprConstant Integer
|
|
| ExprIdentifer String
|
|
| ExprBinOp String Expr Expr
|
|
| ExprUnOp String Expr
|
|
| ExprPoly [ (Integer, [ String ]) ]
|
|
deriving (Show, Eq, Ord)
|
|
|
|
enc_binop :: String -> Expr -> Expr -> Expr
|
|
enc_binop o op1 op2 = ExprBinOp o op1 op2
|
|
|
|
|
|
expr_factor
|
|
= do { i <- parens (expr); return i }
|
|
<|> do { i <- integer; return (ExprConstant i) }
|
|
<|> do { i <- identifier;return (ExprIdentifer i) }
|
|
|
|
|
|
realbinop :: String -> Integer -> Integer -> Integer
|
|
realbinop "+" = (+)
|
|
realbinop "-" = (-)
|
|
realbinop "*" = (*)
|
|
realbinop "/" = div
|
|
|
|
|
|
canonicalise :: Expr -> Expr
|
|
canonicalise e = (ExprPoly (Poly.reduce (expr_to_poly (expr_to_dnf e))))
|
|
|
|
expr_to_multerms :: Expr -> [ Expr ]
|
|
expr_to_multerms (ExprBinOp "*" op1 op2) =
|
|
(expr_to_multerms op1) ++ (expr_to_multerms op2)
|
|
expr_to_multerms e = [e]
|
|
|
|
expr_to_poly :: Expr -> [ (Integer, [ String ]) ]
|
|
expr_to_poly (ExprBinOp "+" op1 op2) =
|
|
(expr_to_poly op1) ++ (expr_to_poly op2)
|
|
expr_to_poly e@(ExprBinOp "*" _ _) =
|
|
[ reduce_multerms (expr_to_multerms e) ]
|
|
expr_to_poly (ExprPoly p) = p
|
|
expr_to_poly (ExprConstant i) = [ (i, []) ]
|
|
expr_to_poly (ExprIdentifer i) = [ (1, [i]) ]
|
|
|
|
reduce_multerms :: [ Expr ] -> ( Integer, [ String ] )
|
|
reduce_multerms ml = (prod, varterms)
|
|
where
|
|
prod = foldr (*) 1 [ e | (ExprConstant e) <- ml ]
|
|
varterms = [ i | (ExprIdentifer i) <- ml ]
|
|
|
|
--
|
|
-- Turn an expression into DNF
|
|
--
|
|
expr_to_dnf :: Expr -> Expr
|
|
|
|
-- Remove substraction
|
|
expr_to_dnf (ExprBinOp "-" e1 e2) =
|
|
expr_to_dnf (ExprBinOp "+" (expr_to_dnf e1)
|
|
(ExprBinOp "*" (ExprConstant (-1)) (expr_to_dnf e2)))
|
|
|
|
-- Distributivity of *,+,-: expand parentheses
|
|
expr_to_dnf (ExprBinOp "*" (ExprBinOp "+" e11 e12) e2) =
|
|
expr_to_dnf (ExprBinOp "+"
|
|
(expr_to_dnf (ExprBinOp "*" e11 e2))
|
|
(expr_to_dnf (ExprBinOp "*" e12 e2)))
|
|
|
|
expr_to_dnf (ExprBinOp "*" e2 (ExprBinOp "+" e11 e12)) =
|
|
expr_to_dnf (ExprBinOp "+"
|
|
(expr_to_dnf (ExprBinOp "*" e2 e11))
|
|
(expr_to_dnf (ExprBinOp "*" e2 e12)))
|
|
|
|
-- Recurse
|
|
expr_to_dnf (ExprBinOp s e1 e2) =
|
|
let e1p = (expr_to_dnf e1)
|
|
e2p = (expr_to_dnf e2)
|
|
in if (e1p /= e1) || (e2p /= e2) then expr_to_dnf (ExprBinOp s e1p e2p)
|
|
else ExprBinOp s e1p e2p
|
|
|
|
-- Fall through
|
|
expr_to_dnf e = e
|
|
|
|
{-
|
|
A little code for independent testing of parser
|
|
-}
|
|
{--
|
|
main = do {
|
|
args <- System.getArgs
|
|
; result <- parseFromFile devfile (head args)
|
|
; case(result) of
|
|
Left err -> print err
|
|
Right xs -> print xs
|
|
}
|
|
|
|
--}
|