1{- 2 Parser.hs: Parser for the Hamlet language 3 4 Copyright (c) 2009, ETH Zurich. 5 All rights reserved. 6 7 This file is distributed under the terms in the attached LICENSE file. 8 If you do not find this file, copies can be found by writing to: 9 ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group. 10-} 11 12module Parser where 13 14import HamletAst 15 16import Text.ParserCombinators.Parsec as Parsec 17import Text.ParserCombinators.Parsec.Expr 18import Text.ParserCombinators.Parsec.Pos 19import Text.ParserCombinators.Parsec.Char as C 20import qualified Text.ParserCombinators.Parsec.Token as P 21import Text.ParserCombinators.Parsec.Language( javaStyle ) 22import Data.Char 23import Numeric 24import Data.List 25import Data.Maybe 26import Text.Printf 27 28import System.Environment 29import System.Exit 30import System.Console.GetOpt 31import System.IO 32import System.FilePath.Posix 33 34 35parseCaps filename = parseFromFile capsFile filename 36 37lexer = P.makeTokenParser $! (javaStyle 38 { P.reservedNames = [ "is_always_copy" 39 , "is_never_copy" 40 , "from" 41 , "can_retype_multiple" 42 ] 43 , P.reservedOpNames = ["+"] 44 , P.identLetter = C.alphaNum <|> C.char '_' 45 }) 46 47whiteSpace = P.whiteSpace lexer 48reserved = P.reserved lexer 49identifier = P.identifier lexer 50reservedOp = P.reservedOp lexer 51integer = P.integer lexer 52stringLit = P.stringLiteral lexer 53comma = P.comma lexer 54commaSep = P.commaSep lexer 55commaSep1 = P.commaSep1 lexer 56parens = P.parens lexer 57braces = P.braces lexer 58brackets = P.brackets lexer 59semiSep = P.semiSep lexer 60symbol = P.symbol lexer 61 62missingSep name = 63 symbol ";" <?> " ';' missing from end of " ++ name 64 65capsFile = 66 do 67 whiteSpace 68 defs <- many definesCst 69 caps <- capDefFold [] 70 return $ Capabilities defs (nonAbsCaps caps) (absCaps caps) 71 where 72 capDefFold caps = do cap <- capabilitiesDef caps 73 capDefFold (cap:caps) 74 <|> (return $ reverse caps) 75 nonAbsCaps = filter (\c -> not $ abstract c) 76 absCaps = filter (\c -> abstract c) 77 78-- parse global definition 79definesCst = 80 do 81 reserved "define" 82 name <- identifier 83 val <- integer 84 missingSep (name ++ " define") 85 return $! Define name (fromInteger val) 86 87parseAbstract = do 88 (reserved "abstract" >> (return $ True)) 89 <|> (return False) 90 91parseInherit caps = do 92 (do reserved "inherit" 93 from <- choice $ map (\s -> reserved s >> return s) capNames 94 return $ Just $ findCap from) 95 <|> (return Nothing) 96 where 97 capNames = map (\(CapName n) -> n) $ map name caps 98 findCap name' = fromMaybe (error $ show name') $ find (\c -> name c == CapName name') caps 99 100-- parse a single capability definition 101capabilitiesDef caps = 102 do 103 reserved "cap" 104 name <- identifier 105 geq <- generalEqualityP name 106 from <- if isNothing geq then fromP caps else return Nothing 107 fromSelf <- if isNothing geq then fromSelfP name else return False 108 abstract <- parseAbstract 109 inheritCap <- parseInherit caps 110 (fields', rangeExpr', eqFields', multi', needsType') <- ((braces $ capabilityDef name inheritCap) 111 <|> if isJust inheritCap then do 112 let c = fromJust inheritCap 113 return (fields c, rangeExpr c, eqFields c, multiRetype c, False) 114 else unexpected ("Missing {} block")) 115 missingSep ("cap " ++ name ++ " definition") 116 let inheritName = maybe Nothing inherit inheritCap 117 return $ Capability (CapName name) geq from fromSelf multi' fields' rangeExpr' eqFields' abstract needsType' inheritName 118 119-- parse optional general equality (always/never copy) 120generalEqualityP name = do 121 (reserved "is_always_copy" >> (return $ Just True)) 122 <|> (reserved "is_never_copy" >> (return $ Just False)) 123 <|> (return Nothing) 124 125-- parse optional "from <base cap name>" 126fromP caps = withFromP <|> return Nothing 127 where withFromP = do 128 reserved "from" 129 from <- choice $ map (\s -> reserved s >> return s) capNames 130 return $ Just $ CapName from 131 capNames = map (\(CapName n) -> n) $ map name caps 132 133-- parse optional "from_self" 134fromSelfP name = (reserved "from_self" >> (return True)) <|> (return False) 135 136-- parse the body of a capability definition 137capabilityDef name inheritCap = do 138 139 -- check for "can_retype_multiple" 140 multi <- (do reserved "can_retype_multiple" 141 missingSep ("can_retype_multiple in " ++ name) 142 return True) 143 <|> (return $ maybe False multiRetype inheritCap) 144 -- read sequence of field, address, size, and equality definitions 145 annotatedFields <- many $ capFieldOrExpr name 146 (fields, addresses, sizes, eqExprs) <- return $ unzipDefs annotatedFields 147 148 -- lengths to check 149 let numAddrs = length addresses 150 numSizes = length sizes 151 152 -- check that there are either 0 or 1 of both address and size definitions 153 if numAddrs > 1 154 then unexpected ("multiple address definitions for cap " ++ name) 155 else return () 156 if numSizes > 1 157 then unexpected ("multiple size definitions for cap " ++ name) 158 else return () 159 if numAddrs < 1 && numSizes > 0 160 then unexpected ("have size definition but no address definition for cap " ++ name) 161 else return () 162 163 -- merge address and size expressions if present 164 let rangeExpr' = if null addresses 165 then maybe Nothing rangeExpr inheritCap 166 else Just $ 167 if null sizes 168 then (head addresses, ZeroSize) 169 else (head addresses, head sizes) 170 return (fields, rangeExpr', eqExprs, multi, True) 171 172 where 173 -- un-maybe lists from capfields parsing 174 unzipDefs annotatedFields = (fs, as, ss, es) 175 where fs = maybe [] fields inheritCap ++ catMaybes afs 176 as = eitherOr (catMaybes aas) fst 177 ss = eitherOr (catMaybes ass) snd 178 es = maybe [] eqFields inheritCap ++ catMaybes ess 179 (afs, aas, ass, ess) = unzip4 annotatedFields 180 eitherOr :: [a] -> ((AddressExpr, SizeExpr) -> a) -> [a] 181 eitherOr a what = if null a then 182 map (what) $ 183 maybeToList $ 184 maybe Nothing (rangeExpr) inheritCap 185 else a 186 187capFieldOrExpr name = (reserved "address" >> (addrField <|> addrExpr)) 188 <|> 189 (((reserved "size" >> (return False)) <|> 190 (reserved "size_bits" >> (return True))) 191 >>= (\isBits -> sizeField isBits <|> sizeExpr isBits)) 192 <|> 193 (reserved "eq" >> eqField) 194 <|> 195 regField 196 where 197 addrField = do 198 -- handle field marked as address 199 field <- capTypeField 200 return $ 201 let expr = AddressExpr $ NameExpr $ fieldName field 202 in (Just field, Just expr, Nothing, Nothing) 203 addrExpr = do 204 -- handle address expression 205 addrExpr <- braces addressExprP 206 missingSep ("address definition for " ++ name) 207 return (Nothing, Just addrExpr, Nothing, Nothing) 208 sizeField isBits = do 209 -- handle field marked as size or size_bits 210 field <- capTypeField 211 return $ 212 let mkSize = if isBits then SizeBitsExpr else SizeExpr 213 expr = mkSize $ NameExpr $ fieldName field 214 in (Just field, Nothing, Just expr, Nothing) 215 eqField = do 216 -- handle field marked as eq 217 field <- capTypeField 218 return (Just field, Nothing, Nothing, Just $ NameField $ fieldName field) 219 sizeExpr isBits = do 220 -- handle size expression 221 expr <- braces (if isBits then sizeBitsExprP else sizeExprP) 222 missingSep ("size definition for " ++ name) 223 return (Nothing, Nothing, Just expr, Nothing) 224 regField = do 225 -- handle regular field 226 field <- capTypeField 227 return (Just field, Nothing, Nothing, Nothing) 228 fieldName (CapField _ (NameField n)) = n 229 230-- parse cap field (name, type, semicolon) 231capTypeField = do 232 typ <- stringLit <|> identifier 233 name <- identifier 234 missingSep ("field " ++ name) 235 return $ CapField (read typ) (NameField name) 236 237-- parse address expression 238addressExprP = (reserved "mem_to_phys" >> parens exprP >>= (return . MemToPhysOp)) 239 <|> (reserved "get_address" >> parens exprP >>= (return . GetAddrOp)) 240 <|> (exprP >>= (return . AddressExpr)) 241-- parse size expression 242sizeExprP = exprP >>= (return . SizeExpr) 243-- parse size_bits expression 244sizeBitsExprP = exprP >>= (return . SizeBitsExpr) 245-- parse subexpression for the above 246exprP = do 247 left <- identifier 248 (do reservedOp "+" 249 right <- identifier 250 return $ AddExpr left right 251 <|> (return $ NameExpr left)) 252