9a71c2dbb6
This feature was originally added to implement the state monad. It is not needed anymore since we have a better encoding that doesn't require this feature and avoids memory allocations.
172 lines
7.3 KiB
Text
172 lines
7.3 KiB
Text
/-
|
||
Copyright (c) 2018 Microsoft Corporation. All rights reserved.
|
||
Released under Apache 2.0 license as described in the file LICENSE.
|
||
Authors: Leonardo de Moura
|
||
-/
|
||
prelude
|
||
import init.lean.ir.ir init.lean.parser.parsec
|
||
import init.lean.parser.identifier init.lean.parser.string_literal
|
||
import init.lean.ir.reserved
|
||
|
||
namespace lean
|
||
namespace ir
|
||
open lean.parser
|
||
open lean.parser.monad_parsec
|
||
|
||
def symbol (s : string) : parsec' unit :=
|
||
(str s *> whitespace) <?> ("'" ++ s ++ "'")
|
||
|
||
def keyword (s : string) : parsec' unit :=
|
||
(try $ str s *> not_followed_by_sat is_id_rest *> whitespace) <?> ("'" ++ s ++ "'")
|
||
|
||
def parse_key2val {α : Type} (msg : string) : list (string × α) → parsec' α
|
||
| [] := error msg
|
||
| ((s, v) :: kvs) := (keyword s *> pure v) <|> parse_key2val kvs
|
||
|
||
def str2type : list (string × type) :=
|
||
[ ("object", type.object), ("bool", type.bool), ("byte", type.byte),
|
||
("uint16", type.uint16), ("uint32", type.uint32), ("uint64", type.uint64), ("usize", type.usize),
|
||
("int16", type.int16), ("int32", type.int32), ("int64", type.int64),
|
||
("float", type.float), ("double", type.double) ]
|
||
|
||
def parse_type : parsec' type :=
|
||
parse_key2val "type" str2type
|
||
|
||
def str2aunop : list (string × assign_unop) :=
|
||
[ ("not", assign_unop.not), ("neg", assign_unop.neg), ("ineg", assign_unop.ineg), ("nat2int", assign_unop.nat2int),
|
||
("is_scalar", assign_unop.is_scalar), ("is_shared", assign_unop.is_shared), ("is_null", assign_unop.is_null),
|
||
("array_copy", assign_unop.array_copy), ("sarray_copy", assign_unop.sarray_copy), ("box", assign_unop.box),
|
||
("unbox", assign_unop.unbox), ("cast", assign_unop.cast), ("array_size", assign_unop.array_size),
|
||
("sarray_size", assign_unop.sarray_size), ("string_len", assign_unop.string_len), ("succ", assign_unop.succ),
|
||
("tag", assign_unop.tag), ("tag_ref", assign_unop.tag_ref) ]
|
||
|
||
def parse_assign_unop : parsec' assign_unop :=
|
||
parse_key2val "unary operator" str2aunop
|
||
|
||
def str2abinop : list (string × assign_binop) :=
|
||
[ ("add", assign_binop.add), ("sub", assign_binop.sub), ("mul", assign_binop.mul), ("div", assign_binop.div), ("mod", assign_binop.mod),
|
||
("iadd", assign_binop.iadd), ("isub", assign_binop.isub), ("imul", assign_binop.imul), ("idiv", assign_binop.idiv), ("imod", assign_binop.imod),
|
||
("shl", assign_binop.shl), ("shr", assign_binop.shr), ("and", assign_binop.and), ("or", assign_binop.or), ("xor", assign_binop.xor), ("le", assign_binop.le),
|
||
("lt", assign_binop.lt), ("eq", assign_binop.eq), ("ne", assign_binop.ne), ("ile", assign_binop.ile), ("ilt", assign_binop.ilt), ("ieq", assign_binop.ieq),
|
||
("ine", assign_binop.ine), ("array_read", assign_binop.array_read), ("array_push", assign_binop.array_push), ("string_push", assign_binop.string_push),
|
||
("string_append", assign_binop.string_append) ]
|
||
|
||
def parse_assign_binop : parsec' assign_binop :=
|
||
parse_key2val "binary operator" str2abinop
|
||
|
||
def str2unop : list (string × unop) :=
|
||
[ ("inc_ref", unop.inc_ref), ("dec_ref", unop.dec_ref), ("inc", unop.inc), ("dec", unop.dec),
|
||
("dec_sref", unop.dec_sref), ("free", unop.free), ("dealloc", unop.dealloc), ("array_pop", unop.array_pop),
|
||
("sarray_pop", unop.sarray_pop) ]
|
||
|
||
def parse_unop : parsec' unop :=
|
||
parse_key2val "unary operator" str2unop
|
||
|
||
def parse_literal : parsec' literal :=
|
||
(keyword "tt" *> pure (literal.bool tt))
|
||
<|> (keyword "ff" *> pure (literal.bool ff))
|
||
<|> (do n ← lexeme num <?> "numeral", pure (literal.num n))
|
||
<|> (do n ← (ch '-' *> lexeme num), pure (literal.num (- n)))
|
||
<|> literal.str <$> parse_string_literal
|
||
|
||
def parse_uint16 : parsec' uint16 :=
|
||
try (do it ← left_over,
|
||
n ← lexeme num,
|
||
when (n ≥ uint16_sz) $ unexpected_at "big numeral, it does not fit in an uint16" it,
|
||
pure $ uint16.of_nat n)
|
||
<?> "uint16"
|
||
|
||
def parse_usize : parsec' usize :=
|
||
try (do it ← left_over,
|
||
n ← lexeme num,
|
||
when (n ≥ usize_sz) $ unexpected_at "big numeral, it does not fit in an usize" it,
|
||
pure $ usize.of_nat n)
|
||
<?> "usize"
|
||
|
||
def identifier : parsec' name :=
|
||
try (do it ← left_over,
|
||
n ← lean.parser.identifier,
|
||
when (is_reserved_name n) $ unexpected_at "keyword" it,
|
||
pure n)
|
||
<?> "identifier"
|
||
|
||
def parse_var : parsec' var :=
|
||
lexeme identifier <?> "variable"
|
||
|
||
def parse_fnid : parsec' fnid :=
|
||
lexeme identifier <?> "function name"
|
||
|
||
def parse_blockid : parsec' blockid :=
|
||
lexeme identifier <?> "label"
|
||
|
||
def parse_typed_assignment (x : var) : parsec' instr :=
|
||
do symbol ":",
|
||
ty ← parse_type,
|
||
symbol ":=",
|
||
(keyword "sget" *> instr.sget x ty <$> parse_var <*> parse_usize)
|
||
<|> (instr.assign x ty <$> parse_var)
|
||
<|> (instr.assign_unop x ty <$> parse_assign_unop <*> parse_var)
|
||
<|> (instr.assign_binop x ty <$> parse_assign_binop <*> parse_var <*> parse_var)
|
||
<|> (instr.assign_lit x ty <$> parse_literal)
|
||
|
||
def parse_untyped_assignment (x : var) : parsec' instr :=
|
||
do symbol ":=",
|
||
(keyword "closure" *> instr.closure x <$> parse_fnid <*> many parse_var)
|
||
<|> (keyword "apply" *> instr.apply x <$> many1 parse_var)
|
||
<|> (keyword "get" *> instr.get x <$> parse_var <*> parse_uint16)
|
||
<|> (keyword "call" *> instr.call x <$> parse_fnid <*> many parse_var)
|
||
<|> (keyword "cnstr" *> instr.cnstr x <$> parse_uint16 <*> parse_uint16 <*> parse_usize)
|
||
<|> (keyword "array" *> instr.array x <$> parse_var <*> parse_var)
|
||
<|> (keyword "sarray" *> instr.sarray x <$> parse_type <*> parse_var <*> parse_var)
|
||
|
||
def parse_assignment : parsec' instr :=
|
||
do x ← parse_var,
|
||
(parse_untyped_assignment x <|> parse_typed_assignment x)
|
||
|
||
def parse_instr : parsec' instr :=
|
||
(keyword "array_write" *> instr.array_write <$> parse_var <*> parse_var <*> parse_var)
|
||
<|> (keyword "set" *> instr.set <$> parse_var <*> parse_uint16 <*> parse_var)
|
||
<|> (keyword "sset" *> instr.sset <$> parse_var <*> parse_usize <*> parse_var)
|
||
<|> (instr.unop <$> parse_unop <*> parse_var)
|
||
<|> parse_assignment
|
||
|
||
def parse_phi : parsec' phi :=
|
||
do (x, ty) ← try $ do { x ← parse_var, symbol ":", ty ← parse_type, symbol ":=", keyword "phi", pure (x, ty) },
|
||
ys ← many1 parse_var,
|
||
pure {x := x, ty := ty, ys := ys}
|
||
|
||
def parse_terminator : parsec' terminator :=
|
||
(keyword "jmp" *> terminator.jmp <$> parse_blockid)
|
||
<|> (keyword "ret" *> terminator.ret <$> parse_var)
|
||
<|> (keyword "case" *> terminator.case <$> parse_var <*> (symbol "[" *> sep_by1 parse_blockid (symbol ",") <* symbol "]"))
|
||
|
||
def parse_block : parsec' block :=
|
||
do id ← try (parse_blockid <* symbol ":"),
|
||
ps ← many (parse_phi <* symbol ";"),
|
||
is ← many (parse_instr <* symbol ";"),
|
||
t ← parse_terminator <* symbol ";",
|
||
pure { id := id, phis := ps, instrs := is, term := t }
|
||
|
||
def parse_arg : parsec' arg :=
|
||
do symbol "(", x ← parse_var, symbol ":", ty ← parse_type, symbol ")", pure {n := x, ty := ty}
|
||
|
||
def parse_header (is_const : bool) : parsec' header :=
|
||
do n ← parse_fnid,
|
||
as ← if is_const then pure [] else many parse_arg,
|
||
r ← symbol ":" *> result.mk <$> parse_type,
|
||
pure { name := n, args := as, return := r, is_const := is_const }
|
||
|
||
def parse_def : parsec' decl :=
|
||
keyword "def" *> decl.defn <$> parse_header ff <*> (symbol ":=" *> many parse_block)
|
||
|
||
def parse_defconst : parsec' decl :=
|
||
keyword "defconst" *> decl.defn <$> parse_header tt <*> (symbol ":=" *> many parse_block)
|
||
|
||
def parse_external : parsec' decl :=
|
||
keyword "external" *> decl.external <$> parse_header ff
|
||
|
||
def parse_decl : parsec' decl :=
|
||
parse_def <|> parse_defconst <|> parse_external
|
||
|
||
end ir
|
||
end lean
|