To protect your data, the CISO officer has suggested users to enable GitLab 2FA as soon as possible.

Commit dea983cd authored by Adam Nelson's avatar Adam Nelson
Browse files

Parser improvements, comminst support

Removed a special case in the parser for FuncRefV constants, which
required every SSA variable to have a known type. This required
BundleParser to be rearranged to parse everything else before function
bodies, making functions available to functions defined above them
(something the spec requires, so that's progress!)

Also added support for COMMINST in the parser.
parent ff7ff016
......@@ -92,23 +92,42 @@ struct
get_global = get_env_const
}
(* Output: ``:bundle`` *)
fun parse_decl (lines : uir_token list list) : term =
type bundle = {
types : term list,
globals : term list,
functions : term list
}
val empty_bundle : bundle = {
types = [], globals = [], functions = []
}
fun parse_decl (lines : uir_token list list,
{types, globals, functions} : bundle)
: bundle =
let
val env = free_env_context
val (header::other_lines) = filter (fn l => l <> []) lines
in mk_abs(t_env,
in
case header of
Decl "typedef"::SSA (Global, name)::Eq::rhs =>
if other_lines = [] then
let val ty = mk_var("ty", ty_type) in
mk_lift(mk_abs(ty, add_env_type name ty), parse_type env rhs)
let
val ty = mk_var("ty", ty_type)
val def = mk_abs(t_env,
mk_lift(mk_abs(ty, add_env_type name ty), parse_type env rhs))
in
{types = types @ [def], globals = globals, functions = functions}
end
else raise ParseError "non-declaration line after .typedef"
| Decl "funcsig"::SSA (Global, name)::Eq::rhs =>
if other_lines = [] then
let val fs = mk_var("fs", ty_sig) in
mk_lift(mk_abs(fs, add_env_funcsig name fs), parse_funcsig env rhs)
let
val fs = mk_var("fs", ty_sig)
val def = mk_abs(t_env,
mk_lift(mk_abs(fs, add_env_funcsig name fs), parse_funcsig env rhs))
in
{types = types @ [def], globals = globals, functions = functions}
end
else raise ParseError "non-declaration line after .funcsig"
| Decl "const"::SSA (Global, name)::Type ty::Eq::rhs =>
......@@ -117,11 +136,13 @@ struct
let
val ty' = mk_var("ty'", ty_type)
val const = mk_var("const", ty_val)
val def = mk_abs(t_env,
mk_bind(parse_type env ty,
mk_abs(ty', mk_lift(
mk_abs(const, add_env_const name ty' const),
beta_conv(mk_comb(parse_value rhs, ty'))))))
in
mk_bind(parse_type env ty,
mk_abs(ty', mk_lift(
mk_abs(const, add_env_const name ty' const),
beta_conv(mk_comb(parse_value rhs, ty')))))
{types = types, globals = globals @ [def], functions = functions}
end
else raise ParseError "non-declaration line after .const"
| [Decl "global", SSA (Global, name), Type ty] =>
......@@ -130,8 +151,7 @@ struct
val t_gln = infer_comb("Global", [fromMLstring name], ty_gln)
val ty_gl = mk_prod(ty_gln, ty_type)
val t_gls = mk_var("gls", ty_list ty_gl)
in
mk_lift(
val def = mk_abs(t_env, mk_lift(
mk_abs(t_ty,
infer_comb("environment_globals_fupd", [
mk_abs(t_gls, infer_comb("CONS",
......@@ -139,7 +159,9 @@ struct
add_env_const name t_ty (infer_comb("RefV",
[t_ty, mk_some(infer_comb("GlobalAddr", [t_gln], ty_addr))], ty_val))
], ty_env)),
parse_type env ty)
parse_type env ty))
in
{types = types, globals = globals @ [def], functions = functions}
end
| [Decl "funcdecl", SSA (Global, name), Type fsig] =>
(* TODO: funcdecl *)
......@@ -147,11 +169,26 @@ struct
| [Decl "funcdef", SSA (Global, name), Word "VERSION", SSA (Local, v), Type fsig, OpenBrace] =>
if exists (fn l => l = [CloseBrace]) other_lines then
if List.last other_lines = [CloseBrace] then
mk_lift(
infer_comb("generate_function", [t_env, fromMLstring name],
mk_type("function", []) --> ty_env),
parse_func env (parse_funcsig env fsig)
(List.take(other_lines, length other_lines - 1)))
let
val r = mk_const("REF", mk_type("ref_type", []))
val ty_fno = mk_type("option", [ty_funcn])
val fsig' = parse_funcsig env fsig
val ty = mk_var("ty", ty_type)
val fr = mk_var("fr", ty_val)
val fref = mk_abs(t_env, list_mk_lift(
list_mk_abs([ty, fr], add_env_const name ty fr), [
mk_lift(infer_comb("FuncRef", [r], ty_sig --> ty_type), fsig'),
list_mk_lift(
infer_comb("FuncRefV", [r], ty_sig --> ty_fno --> ty_val), [fsig',
mk_return(infer_comb("SOME", [
infer_comb("Func", [fromMLstring name], ty_funcn)], ty_fno))])]))
val fdef = mk_abs(t_env, mk_lift(
infer_comb("generate_function", [t_env, fromMLstring name],
mk_type("function", []) --> ty_env),
parse_func env fsig' (List.take(other_lines, length other_lines - 1))))
in
{types = types, globals = globals @ [fref], functions = functions @ [fdef]}
end
else raise ParseError "non-declaration line after .funcdef's }"
else raise ParseError "unclosed { in .funcdef"
| Decl d::_ =>
......@@ -160,7 +197,7 @@ struct
else
raise ParseError ("." ^ d ^ " is not a toplevel declaration")
| _ =>
raise ParseError "expected toplevel declaration")
raise ParseError "expected toplevel declaration"
end
fun uir_bundle (quotation : 'a frag list) : term =
......@@ -170,7 +207,8 @@ struct
val lines = map tokenize (String.tokens (fn x => x = #"\n") str)
val decl_blocks = split_by_header (fn (Decl _::_) => true | _ => false)
(filter (fn l => l <> []) lines)
val decls : term list = map parse_decl decl_blocks
val {types, globals, functions} =
foldl parse_decl empty_bundle decl_blocks
in
mk_abs(t_env, list_mk_comb(
mk_thy_const{
......@@ -180,7 +218,7 @@ struct
}, [
mk_thy_const{Thy="sumMonad", Name="bind_left", Ty=ty_bind},
mk_return t_env,
mk_list(decls, ty_bundle)
mk_list(types @ globals @ functions, ty_bundle)
]))
end
end
......
......@@ -49,12 +49,13 @@ struct
"SEQ_CST"
]
val comm_insts = [
val comminsts = [
"uvm.new_stack", "uvm.current_stack"
]
val ty_ssa = mk_type("ssavar", [])
val ty_blabel = mk_type("block_label", [])
val ty_ci = mk_type("comminst", [ty_ssa])
fun or_const ty = ``:^ty or_const``
val t_Var = mk_const("INL", ty_ssa --> or_const ty_ssa)
......@@ -77,20 +78,8 @@ struct
(* Reads an SSA variable, replacing global variables with constants using the
given context. Returns a term of type ``:ssavar or_const or_error``.
*)
fun ssa_var _ _ (Local, v) = mk_return(mk_comb(t_Var, mk_ssa v))
| ssa_var (env : env_context) ty (Global, v) =
let
val t_rt = mk_var("rt", ty_reft)
val t_sig = mk_var("sig", ty_sig)
in
mk_lift(t_Const, mk_bind(ty, mk_pattern_fn[
(ty_pat "FuncRef" [t_rt, t_sig],
mk_return(infer_comb("FuncRefV",
[t_rt, t_sig, mk_some(infer_comb("Func", [fromMLstring v], ty_funcn))],
ty_val))),
(mk_var("ty", ty_type),
(#get_global env) v)]))
end
fun ssa_var _ (Local, v) = mk_return(mk_comb(t_Var, mk_ssa v))
| ssa_var (env : env_context) (Global, v) = mk_lift(t_Const, #get_global env v)
fun parse_mem_order (ord : string) : term =
if exists (fn x => x = ord) mem_orders then
......@@ -112,13 +101,13 @@ struct
case v of
SSA v => list_mk_lift(
mk_const(",", or_const ty_ssa --> ty_type --> ty_pair),
[ssa_var env ty v, ty])
[ssa_var env v, ty])
| _ => raise ParseError "PASS_VALUES expected SSA arguments")
(ListPair.zipEq(parse_type_list env tys, vals)),
ty_pair)), rest)
| Word "THROW_EXC" :: SSA exc :: rest =>
(mk_lift(mk_const("ThrowExc", or_const ty_ssa --> ty),
ssa_var env (mk_return ``Ref (INL Void)``) exc), rest)
ssa_var env exc), rest)
| _ => raise ParseError "expected newStackClause (PASS_VALUES or THROW_EXC)"
end
......@@ -175,13 +164,13 @@ struct
(* Identity instruction *)
[Word "ID", Type ty, SSA i] =>
let val ty' = parse_type env ty in
mk_assign("ID", ir_ap("Id", [ty', ssa_var env ty' i], ty_expr))
mk_assign("ID", ir_ap("Id", [ty', ssa_var env i], ty_expr))
end
(* TODO: Compound value operations *)
(* IRef instructions *)
| [Word "GETIREF", Type ty, SSA opnd] =>
mk_assign("GETIREF", ir_ap("GetIRef",
[parse_type env ty, ssa_var env t_void opnd], ty_expr))
[parse_type env ty, ssa_var env opnd], ty_expr))
(* TODO: PTR variants of iref instructions *)
| [Word "GETFIELDIREF", Type tys, SSA opnd] =>
let
......@@ -191,24 +180,24 @@ struct
in
mk_assign("GETFIELDIREF", ir_ap("GetFieldIRef", [
t_ref, parse_type env t1, mk_return(lift_num ty_num index),
ssa_var env t_void opnd
ssa_var env opnd
], ty_expr))
end
| [Word "GETELEMIREF", Type tys, SSA opnd, SSA index] =>
let val (t1, t2) = two_tys tys in
mk_assign("GETELEMIREF", ir_ap("GetElementIRef", [
t_ref, t1, t2, ssa_var env t_void opnd, ssa_var env t2 index
t_ref, t1, t2, ssa_var env opnd, ssa_var env index
], ty_expr))
end
| [Word "SHIFTIREF", Type tys, SSA opnd, SSA index] =>
let val (t1, t2) = two_tys tys in
mk_assign("SHIFTIREF", ir_ap("ShiftIRef", [
t_ref, t1, t2, ssa_var env t_void opnd, ssa_var env t2 index
t_ref, t1, t2, ssa_var env opnd, ssa_var env index
], ty_expr))
end
| [Word "GETVARPARTIREF", Type ty, SSA opnd] =>
mk_assign("GETVARPARTIREF", ir_ap("GetVarPartIRef",
[t_ref, parse_type env ty, ssa_var env t_void opnd], ty_expr))
[t_ref, parse_type env ty, ssa_var env opnd], ty_expr))
(* Load *)
| [Word "LOAD", Type ty, SSA src] => ir_ap("Load",
[lhs1 lhs "LOAD", t_ref, parse_type env ty, ssa_noconst src, t_na], ty_inst)
......@@ -227,21 +216,21 @@ struct
let val _ = lhs0 lhs "STORE"
val ty' = parse_type env ty
in ir_ap("Store", [
ssa_var env ty' src, t_ref, ty', ssa_noconst dst, t_na
ssa_var env src, t_ref, ty', ssa_noconst dst, t_na
], ty_inst)
end
| [Word "STORE", Word "PTR", Type ty, SSA dst, SSA src] =>
let val _ = lhs0 lhs "STORE"
val ty' = parse_type env ty
in ir_ap("Store", [
ssa_var env ty' src, t_ptr, ty', ssa_noconst dst, t_na
ssa_var env src, t_ptr, ty', ssa_noconst dst, t_na
], ty_inst)
end
| [Word "STORE", Word ord, Type ty, SSA dst, SSA src] =>
let val _ = lhs0 lhs "STORE"
val ty' = parse_type env ty
in ir_ap("Store", [
ssa_var env ty' src, t_ref, ty', ssa_noconst dst,
ssa_var env src, t_ref, ty', ssa_noconst dst,
mk_return(parse_mem_order ord)
], ty_inst)
end
......@@ -249,7 +238,7 @@ struct
let val _ = lhs0 lhs "STORE"
val ty' = parse_type env ty
in ir_ap("Store", [
ssa_var env ty' src, t_ptr, ty', ssa_noconst dst,
ssa_var env src, t_ptr, ty', ssa_noconst dst,
mk_return(parse_mem_order ord)
], ty_inst)
end
......@@ -263,13 +252,13 @@ struct
ir_ap("Alloca", [lhs1 lhs "ALLOCA", parse_type env ty], ty_inst)
| [Word "NEWHYBRID", Type tys, SSA len] =>
let val (t1, t2) = two_tys tys in
ir_ap("NewHybrid", [lhs1 lhs "NEWHYBRID", t1, t2, ssa_var env t2 len],
ir_ap("NewHybrid", [lhs1 lhs "NEWHYBRID", t1, t2, ssa_var env len],
ty_inst)
end
| [Word "ALLOCAHYBRID", Type tys, SSA len] =>
let val (t1, t2) = two_tys tys in
ir_ap("AllocaHybrid", [
lhs1 lhs "ALLOCAHYBRID", t1, t2, ssa_var env t2 len
lhs1 lhs "ALLOCAHYBRID", t1, t2, ssa_var env len
], ty_inst)
end
(* New Thread *)
......@@ -278,7 +267,7 @@ struct
case nil of
[] => ir_ap("NewThread", [
lhs1 lhs "NEWTHREAD",
ssa_var env (mk_return ``StackRef``) stack,
ssa_var env stack,
t_null, nsc
], ty_inst)
| _ => raise ParseError "invalid arguments for NEWTHREAD"
......@@ -289,12 +278,12 @@ struct
if exists (fn x => x = opn) bin_ops then
ir_ap("BinOp", [
mk_return(ir_const opn (mk_type("bin_op", []))),
ty', ssa_var env ty' l, ssa_var env ty' r
ty', ssa_var env l, ssa_var env r
], ty_expr)
else if exists (fn x => x = opn) cmp_ops then
ir_ap("CmpOp", [
mk_return(ir_const opn (mk_type("cmp_op", []))),
ty', ssa_var env ty' l, ssa_var env ty' r
ty', ssa_var env l, ssa_var env r
], ty_expr)
else raise ParseError (opn ^ " is not a binary operation"))
end
......@@ -304,7 +293,7 @@ struct
let val (t1', t2') = two_tys tys in mk_assign(opn,
ir_ap("ConvOp", [
mk_return(mk_thy_const{Thy="uvmTypes", Name=opn, Ty=``:convtype``}),
t1', t2', ssa_var env t1' opnd
t1', t2', ssa_var env opnd
], ty_expr))
end
else raise ParseError (opn ^ " is not a conversion operation")
......@@ -318,21 +307,49 @@ struct
| _ => raise ParseError "expected instruction"
end
fun parse_comminst (env : env_context)
(name : string)
(tokens : uir_token list)
: (term * uir_token list) =
let
fun fsig (SSA (Global, v)) = #get_funcsig env v
| fsig _ = raise ParseError "expected global SSA variable in <[]>"
fun arg (SSA v) = ssa_var env v
| arg _ = raise ParseError "expected SSA variable in ()"
val (flags, t1) =
case tokens of Brackets xs::t1 => (xs, t1) | _ => ([], tokens)
val (types, t2) =
case t1 of
Type [Brackets _]::_ => ([], t1)
| Type xs::t2 => (parse_type_list env xs, t2)
| _ => ([], t1)
val (fsigs, t3) =
case t2 of Type [Brackets xs]::t3 => (map fsig xs, t3) | _ => ([], t2)
val (args, t4) =
case t3 of Parens xs::t4 => (map arg xs, t4) | _ => ([], t3)
in ((
case (name, flags, types, fsigs, args) of
("uvm.new_stack", [], [], [s], [f]) => ir_ap("NewStack", [s, f], ty_ci)
| ("uvm.current_stack", [], [], [], []) =>
mk_return(mk_const("CurrentStack", ty_ci))
| _ =>
if exists (fn x => x = name) comminsts then
raise ParseError ("invalid arguments for " ^ name)
else
raise ParseError ("unsupported common instruction: " ^ name)),
t4)
end
(* Parses a list of tokens into a Mu IR terminating instruction. Returns a
term of type ``:ssavar terminst or_error``.
*)
fun parse_terminst (env : env_context) (tokens : uir_token list) : term =
let
(* HACK: Uses Void for the type of the SSA variable because return insts
and destination clauses don't specify types. This means that
global function names won't be dereferenced in destination
clauses. The final implementation should scan all basic blocks
for their argument types, and return errors on name/type/arity
mismatches. *)
fun param (SSA v) = ssa_var env (mk_return(mk_const("Void", ty_type))) v
fun param (SSA v) = ssa_var env v
| param _ = raise ParseError "expected SSA variable"
fun params vs = mk_sequence(map param vs, or_const ty_ssa)
val ty_dest = ``:ssavar destination``
val ty_destopt = mk_type("option", [ty_dest])
val x = mk_var("x", ty_list (or_const ty_ssa))
fun dest label vs = mk_lift(
mk_abs(x, mk_pair(infer_comb("BlockLabel",
......@@ -342,10 +359,7 @@ struct
let val fsig' = parse_funcsig env fsig in
lift_record(mk_type("calldata", [ty_ssa]), [
("name", mk_bind(
ssa_var env (mk_lift(
infer_comb("FuncRef", [mk_const("REF", ty_reft)],
ty_sig --> ty_type), fsig'
)) callee,
ssa_var env callee,
mk_const("get_callee",
or_const ty_ssa --> or_error (mk_sum(ty_ssa, ty_funcn))))),
("signature", fsig'),
......@@ -358,8 +372,12 @@ struct
lift_record(mk_type("resumption_data", [ty_ssa]), [
("normal_dest", dest l1 a1),
("exceptional_dest", mk_lift(
mk_const("SOME", ty_dest --> mk_type("option", [ty_dest])),
dest l2 a2))
mk_const("SOME", ty_dest --> ty_destopt), dest l2 a2))
])
| exc_clause [SSA (Local, l1), Parens a1] =
lift_record(mk_type("resumption_data", [ty_ssa]), [
("normal_dest", dest l1 a1),
("exceptional_dest", mk_return(mk_const("NONE", ty_destopt)))
])
| exc_clause _ = raise ParseError "invalid syntax for EXC clause"
val ty_inst = mk_type("terminst", [ty_ssa])
......@@ -390,7 +408,7 @@ struct
mk_const("Int", ty_num --> ty_type),
lift_num ty_num Arbnum.one))
in ir_ap("Branch2",
[ssa_var env ty_int1 cond, dest l1 a1, dest l2 a2],
[ssa_var env cond, dest l1 a1, dest l2 a2],
ty_inst)
end
| Word "SWITCH"::_ =>
......@@ -408,9 +426,22 @@ struct
| Word "SWAPSTACK"::_ =>
(* TODO: SWAPSTACK *)
raise ParseError "SWAPSTACK is not yet implemented"
| Word "COMMINST"::_ =>
(* TODO: COMMINST *)
raise ParseError "COMMINST is not yet implemented"
| Word "COMMINST"::SSA (Global, name)::args =>
let val (ci, rest) = parse_comminst env name args in
case rest of
[Word "EXC", Parens exc] => ir_ap("CommInst",
[mk_return(mk_list([], ty_ssa)), ci, exc_clause exc],
ty_inst)
| _ => raise ParseError "terminating COMMINST must have an EXC clause"
end
| lhs::Eq::Word "COMMINST"::SSA (Global, name)::args =>
let val (ci, rest) = parse_comminst env name args in
case rest of
[Word "EXC", Parens exc] => ir_ap("CommInst",
[mk_return(lhs_n lhs "COMMINST"), ci, exc_clause exc],
ty_inst)
| _ => raise ParseError "terminating COMMINST must have an EXC clause"
end
| _::Eq::_ =>
raise ParseError "assignment is not valid in terminating position"
| Word opn::_ =>
......
......@@ -18,7 +18,10 @@ struct
val mock_context = {
get_type = fn _ => ``ARB``,
get_funcsig = fn _ => ``ARB``,
get_funcsig = fn name =>
case name of
"sig" => ``OK (<| arg_types := []; return_types := [] |>): funcsig or_error``
| _ => ``ARB``,
get_global = fn _ => ``ARB``
}
......
......@@ -89,6 +89,17 @@ val _ =
normal_dest := (BlockLabel "n", [Var %"x"]);
exceptional_dest := SOME (BlockLabel "e", [])
|>``);
assert_parse_terminst("%x = COMMINST @uvm.new_stack <[@sig]> (%st) EXC (%n(%x))",
``CommInst [%"x"] (NewStack <|arg_types := []; return_types := []|> (Var %"st"))
<| normal_dest := (BlockLabel "n", [Var %"x"]);
exceptional_dest := NONE
|>``);
assert_parse_terminst("COMMINST @uvm.current_stack EXC (%n() %e())",
``CommInst [] CurrentStack <|
normal_dest := (BlockLabel "n", []);
exceptional_dest := SOME (BlockLabel "e", [])
|> : ssavar terminst``);
(* Equality testing for basic blocks and functions is nigh-impossible, so
instead just run the parsing functions and make sure they don't throw.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment