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