1{- 2 3 MackerelParser.hs: Mackerel parser for parsing dev file and building the 4 syntax tree. 5 6 Part of Mackerel: a strawman device definition DSL for Barrelfish 7 8 Copyright (c) 2007, ETH Zurich. 9 All rights reserved. 10 11 This file is distributed under the terms in the attached LICENSE file. 12 If you do not find this file, copies can be found by writing to: 13 ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group. 14-} 15 16-- TODO 17module MackerelParser where 18 19{- Extra testing code must be commented after testing 20-} 21--module Main where 22--import System 23{- End of testing code -} 24 25import Prelude 26import Text.ParserCombinators.Parsec 27import Text.ParserCombinators.Parsec.Expr 28import qualified Text.ParserCombinators.Parsec.Token as P 29import Text.ParserCombinators.Parsec.Language( javaStyle ) 30import Data.Char 31import Data.Maybe 32import qualified Poly 33import qualified Space 34 35import Attr 36 37lexer = P.makeTokenParser (javaStyle 38 { P.reservedNames = [ 39 -- "addr", 40 "also", 41 "bytewise", 42 "constants", 43 "datatype", 44 "io", 45 "lsbfirst", 46 "many", 47 "msbfirst", 48 "pci", 49 "regarray", 50 "register", 51 "regtype", 52 -- "space", 53 "stepwise", 54 "type", 55 "valuewise", 56 "device" 57 ] 58 59 , P.reservedOpNames = ["*","/","+","-"] 60 }) 61 62whiteSpace = P.whiteSpace lexer 63reserved = P.reserved lexer 64identifier = P.identifier lexer 65stringLit = P.stringLiteral lexer 66comma = P.comma lexer 67commaSep = P.commaSep lexer 68parens = P.parens lexer 69braces = P.braces lexer 70squares = P.squares lexer 71semiSep = P.semiSep lexer 72symbol = P.symbol lexer 73integer = try ((P.lexeme lexer) binLiteral) 74 <|> try ((P.lexeme lexer) binOnes) 75 <|> P.integer lexer 76commaSep1 = P.commaSep1 lexer 77 78op = P.reservedOp lexer 79 80data RegLoc = RegLoc String String Integer 81 | RegNoLoc 82 deriving Show 83 84data ArrayLoc = ArrayListLoc [ Integer ] 85 | ArrayStepLoc Integer Integer 86 deriving Show 87 88 89bin_op name fun assoc = Infix (do { op name; return fun}) assoc 90 91binDigit = oneOf "01" 92binLiteral = do { _ <- char '0' 93 ; _ <- oneOf "bB" 94 ; digits <- many1 binDigit 95 ; let n = foldl (\x d -> 2*x + (digitToInt d)) 0 digits 96 ; seq n (return (fromIntegral n)) 97 } 98 99binOnes = do { _ <- char '1' 100 ; _ <- char 's' 101 ; let n = -1 102 ; seq n (return (fromIntegral n)) 103 } 104 105data BitOrder = LSBFIRST | MSBFIRST | NOORDER 106 deriving (Eq,Show) 107 108data DeviceFile = DeviceFile AST [String] 109 110data AST = Device String BitOrder [ AST ] String [ AST ] 111-- name lsbfirst args desc defn 112 | Constants String String [ AST ] (Maybe Integer) SourcePos 113 | ConstVal String Expr String SourcePos 114 | RegField String Integer Attr AST String SourcePos 115 | SpaceDecl Space.Rec 116 | RegType String String AST SourcePos 117 | DataType String String AST BitOrder Integer SourcePos 118 | Register String Attr Bool RegLoc String AST SourcePos 119 | RegArray String Attr Bool RegLoc ArrayLoc String AST SourcePos 120 --Register name RO/RW also io/at desc regfields 121 | Arg String String 122 | NoBitFieldType 123 | TypeRef String (Maybe String) 124 | TypeDefn [ AST ] 125 | Error String 126 | Import String 127 deriving Show 128 129devfile = do { whiteSpace 130 ; imps <- many importdev 131 ; dev <- device 132 ; return (DeviceFile dev [i | (Import i) <- imps]) 133 } 134 135importdev = do { reserved "import" 136 ; i <- identifier 137 ; _ <- symbol ";" 138 ; return (Import i) 139 } 140 141device = do { reserved "device" 142 ; name <- identifier 143 ; order <- option LSBFIRST bitorder 144 ; args <- parens (commaSep devarg) 145 ; desc <- stringLit 146 ; decls <- braces (many1 (devdecl args)) 147 ; _ <- symbol ";" <?> " ';' missing from end of " ++ name ++ " device specification" 148 ; return (Device name order args desc decls) 149 } 150 151bitorder = do{ reserved "lsbfirst" ; return LSBFIRST } 152 <|> 153 do{ reserved "msbfirst"; return MSBFIRST } 154 155 156devarg = do { tp <- devargtype -- This must be a typename 157 ; v <- identifier -- This is variable name 158 ; return (Arg tp v) 159 } 160 161devargtype = do { reserved "addr"; return "addr" } 162 <|> do { reserved "io"; return "io" } 163 <|> do { reserved "pci"; return "pci" } 164 165-- Extra added structure to support register comprehension 166 167devdecl args = register 168 <|> constants args 169 <|> spacedecl 170 <|> regtype 171 <|> dataType 172 <|> regarray 173 174spacedecl = do { reserved "space" 175 ; p <- getPosition 176 ; i <- identifier 177 ; a <- parens (commaSep identifier) 178 ; t <- spaceType 179 ; d <- stringLit 180 ; _ <- symbol ";" 181 ; return (SpaceDecl (Space.make i a d t p)) 182 } 183 184spaceType = do{ reserved "bytewise" ; return (Space.BYTEWISE 1) } 185 <|> 186 do{ reserved "valuewise"; return Space.VALUEWISE } 187 <|> 188 do{ reserved "registerwise"; return Space.REGISTERWISE } 189 <|> 190 do{ reserved "stepwise"; 191 s <- parens integer; 192 return (Space.BYTEWISE s) 193 } 194 195register = do { reserved "register" 196 ; p <- getPosition 197 ; i <- identifier 198 ; a <- option RW regAttr 199 ; als <- option False scanAlso 200 ; loc <- regLoc 201 ; d <- option i stringLit 202 ; f <- format 203 ; _ <- symbol ";" 204 ; return (Register i a als loc d f p) 205 } 206 207regarray = do { reserved "regarray" 208 ; p <- getPosition 209 ; i <- identifier 210 ; a <- option RW regAttr 211 ; als <- option False scanAlso 212 ; loc <- regLoc 213 ; aspec <- squares arraySpec 214 ; d <- option i stringLit 215 ; f <- format 216 ; _ <- symbol ";" 217 ; return (RegArray i a als loc aspec d f p) 218 } 219 220scanAlso = do{ reserved "also" 221 ; return True 222 } 223 224regtype = do { reserved "regtype" 225 ; p <- getPosition 226 ; i <- identifier 227 ; d <- stringLit 228 ; f <- typeDefn 229 ; _ <- symbol ";" 230 ; return (RegType i d f p) 231 } 232 233format = typeDefn <|> typeLabel 234 235 236typeDefn = do { j <- braces (many1 regField) 237 ; return (TypeDefn j) } 238 239dataType = do { reserved "datatype" 240 ; p <- getPosition 241 ; i <- identifier 242 ; (o,w) <- option (NOORDER,0) dataBitOrder 243 ; d <- stringLit 244 ; f <- braces (many1 dataField) 245 ; _ <- symbol ";" 246 ; return (DataType i d (TypeDefn f) o w p) 247 } 248 249dataBitOrder = do { o <- bitorder 250 ; i <- parens integer 251 ; return (o,i) 252 } 253 254dataField = do { p <- getPosition 255 ; i <- identifier <|> symbol "_" 256 ; width <- integer 257 ; attr <- option NOATTR dataAttr 258 ; tpe <- option NoBitFieldType typeLabel 259 ; desc <- option i stringLit 260 ; _ <- symbol ";" 261 ; return (RegField i width attr tpe desc p) 262 } 263 264typeLabel = do { reserved "type" 265 ; i <- (parens typeReference) 266 ; return i 267 } 268 269typeReference = do { i1 <- identifier 270 ; i2 <- option Nothing typeQualifier 271 ; return (case i2 of 272 Just qual -> TypeRef qual (Just i1) 273 Nothing -> TypeRef i1 Nothing 274 ) 275 } 276 277typeQualifier = do { _ <- symbol "." 278 ; i <- identifier 279 ; return (Just i) 280 } 281 282regField = do { p <- getPosition 283 ; i <- identifier <|> symbol "_" 284 ; width <- integer 285 ; attr <- option NOATTR fieldAttr 286 ; tpe <- option NoBitFieldType typeLabel 287 ; desc <- option i stringLit 288 ; _ <- symbol ";" 289 ; return (RegField i width attr tpe desc p) 290 } 291 292numberFormat = do{ i <- integer 293 ; _ <- symbol "-" 294 ; j <- integer 295 ; return (j - i + 1) 296 } 297 298dataAttr = do { reserved "rw"; return RW } 299 <|> do { reserved "mbz"; return MBZ } 300 <|> do { reserved "mb1"; return MB1 } 301 <|> do { reserved "rsvd"; return RSVD } 302 303regAttr = do { reserved "rw" ; return RW } 304 <|> do { reserved "ro"; return RO } 305 <|> do { reserved "rc"; return RC } 306 <|> do { reserved "rwc"; return RWC } 307 <|> do { reserved "rw1c"; return RWC } 308 <|> do { reserved "wo"; return WO } 309 <|> do { reserved "rwzc"; return RWZC } 310 311fieldAttr = regAttr 312 <|> do { reserved "ros"; return ROS } 313 <|> do { reserved "rwo"; return RWO } 314 <|> do { reserved "rwcs"; return RWCS } 315 <|> do { reserved "rw1cs"; return RWCS } 316 <|> do { reserved "rws"; return RWS } 317 <|> do { reserved "rwl"; return RWL } 318 <|> do { reserved "mbz"; return MBZ } 319 <|> do { reserved "mb1"; return MB1 } 320 <|> do { reserved "rsvd"; return RSVD } 321 322binarySpace = do { reserved "addr" ; return "addr" } 323 <|> do { reserved "io" ; return "io" } 324 <|> do { reserved "pci" ; return "pci" } 325 326 327regLocIdentified = do { base <- identifier; return (base, 0) } 328 <|> do { offset <- integer; return ("", offset) } 329 330regLoc = do { reserved "noaddr" 331 ; return RegNoLoc 332 } 333 <|> 334 do { sp <- binarySpace 335 ; ( base, offset ) <- parens binLoc 336 ; return ( RegLoc sp base offset ) 337 } 338 <|> 339 do { sp <- identifier 340 ; (base, offset) <- parens regLocIdentified 341 ; return (RegLoc sp base offset) 342 } 343 344binLoc = do { e1 <- identifier 345 ; _ <- comma 346 ; e2 <- integer 347 ; return ( e1 , e2 ) } 348 349arraySpec = try( arrayStepSpec ) 350 <|> try( arrayListSpec ) 351 <|> arrayContigSpec 352 353arrayListSpec = do { l <- commaSep1 integer; 354 ; return ( if (length l) == 1 355 then (ArrayStepLoc (head l) 0) 356 else (ArrayListLoc l) ) 357 } 358 359arrayStepSpec = do { base <- integer 360 ; _ <- symbol ";" 361 ; step <- integer 362 ; return ( ArrayStepLoc base step ) 363 } 364 365arrayContigSpec = do { base <- integer 366 ; return ( ArrayStepLoc base 0 ) 367 } 368 369constants args = do { reserved "constants" 370 ; p <- getPosition 371 ; i <- identifier 372 ; w <- option Nothing constWidth 373 ; d <- stringLit 374 ; f <- braces (many1 (constField args)) 375 ; _ <- symbol ";" 376 ; return (Constants i d f w p) 377 } 378 379constWidth = do { _ <- reserved "width" 380 ; i <- parens integer 381 ; return (Just i) 382 } 383 384constField args = do { i <- identifier 385 ; p <- getPosition 386 ; _ <- symbol "=" 387 ; e <- expr 388 ; d <- option i stringLit 389 ; _ <- symbol ";" 390 ; return (ConstVal i e d p) 391 } 392 393 394expr = buildExpressionParser expr_tab expr_factor 395 396expr_tab :: OperatorTable Char () Expr 397expr_tab = [[bin_op "*" (enc_binop "*") AssocLeft 398 , bin_op "/"(enc_binop "/") AssocLeft ] 399 ,[bin_op "+" (enc_binop "+") AssocLeft 400 , bin_op "-" (enc_binop "-") AssocLeft ] 401 ] 402 403data Expr = ExprConstant Integer 404 | ExprIdentifer String 405 | ExprBinOp String Expr Expr 406 | ExprUnOp String Expr 407 | ExprPoly [ (Integer, [ String ]) ] 408 deriving (Show, Eq, Ord) 409 410enc_binop :: String -> Expr -> Expr -> Expr 411enc_binop o op1 op2 = ExprBinOp o op1 op2 412 413 414expr_factor 415 = do { i <- parens (expr); return i } 416 <|> do { i <- integer; return (ExprConstant i) } 417 <|> do { i <- identifier;return (ExprIdentifer i) } 418 419 420realbinop :: String -> Integer -> Integer -> Integer 421realbinop "+" = (+) 422realbinop "-" = (-) 423realbinop "*" = (*) 424realbinop "/" = div 425 426 427canonicalise :: Expr -> Expr 428canonicalise e = (ExprPoly (Poly.reduce (expr_to_poly (expr_to_dnf e)))) 429 430expr_to_multerms :: Expr -> [ Expr ] 431expr_to_multerms (ExprBinOp "*" op1 op2) = 432 (expr_to_multerms op1) ++ (expr_to_multerms op2) 433expr_to_multerms e = [e] 434 435expr_to_poly :: Expr -> [ (Integer, [ String ]) ] 436expr_to_poly (ExprBinOp "+" op1 op2) = 437 (expr_to_poly op1) ++ (expr_to_poly op2) 438expr_to_poly e@(ExprBinOp "*" _ _) = 439 [ reduce_multerms (expr_to_multerms e) ] 440expr_to_poly (ExprPoly p) = p 441expr_to_poly (ExprConstant i) = [ (i, []) ] 442expr_to_poly (ExprIdentifer i) = [ (1, [i]) ] 443 444reduce_multerms :: [ Expr ] -> ( Integer, [ String ] ) 445reduce_multerms ml = (prod, varterms) 446 where 447 prod = foldr (*) 1 [ e | (ExprConstant e) <- ml ] 448 varterms = [ i | (ExprIdentifer i) <- ml ] 449 450-- 451-- Turn an expression into DNF 452-- 453expr_to_dnf :: Expr -> Expr 454 455-- Remove substraction 456expr_to_dnf (ExprBinOp "-" e1 e2) = 457 expr_to_dnf (ExprBinOp "+" (expr_to_dnf e1) 458 (ExprBinOp "*" (ExprConstant (-1)) (expr_to_dnf e2))) 459 460-- Distributivity of *,+,-: expand parentheses 461expr_to_dnf (ExprBinOp "*" (ExprBinOp "+" e11 e12) e2) = 462 expr_to_dnf (ExprBinOp "+" 463 (expr_to_dnf (ExprBinOp "*" e11 e2)) 464 (expr_to_dnf (ExprBinOp "*" e12 e2))) 465 466expr_to_dnf (ExprBinOp "*" e2 (ExprBinOp "+" e11 e12)) = 467 expr_to_dnf (ExprBinOp "+" 468 (expr_to_dnf (ExprBinOp "*" e2 e11)) 469 (expr_to_dnf (ExprBinOp "*" e2 e12))) 470 471-- Recurse 472expr_to_dnf (ExprBinOp s e1 e2) = 473 let e1p = (expr_to_dnf e1) 474 e2p = (expr_to_dnf e2) 475 in if (e1p /= e1) || (e2p /= e2) then expr_to_dnf (ExprBinOp s e1p e2p) 476 else ExprBinOp s e1p e2p 477 478-- Fall through 479expr_to_dnf e = e 480 481{- 482 A little code for independent testing of parser 483-} 484{-- 485main = do { 486 args <- System.getArgs 487 ; result <- parseFromFile devfile (head args) 488 ; case(result) of 489 Left err -> print err 490 Right xs -> print xs 491 } 492 493--} 494