From 54c6c11c1557cd26f8bb6bc8309dd8772cc5cb9d Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 21 Mar 2023 11:36:05 -0500 Subject: [PATCH 01/51] Add nondeterministic choice operator to lexer, parser, AST, and lustreAstHelpers functions --- src/lustre/lustreAst.ml | 10 +++++++- src/lustre/lustreAst.mli | 1 + src/lustre/lustreAstHelpers.ml | 44 +++++++++++++++++++++++++++----- src/lustre/lustreLexer.mll | 1 + src/lustre/lustreParser.messages | 40 +++++++++++++++++++++++++++++ src/lustre/lustreParser.mly | 7 ++++- 6 files changed, 95 insertions(+), 8 deletions(-) diff --git a/src/lustre/lustreAst.ml b/src/lustre/lustreAst.ml index 3d601568a..4edb89cfc 100644 --- a/src/lustre/lustreAst.ml +++ b/src/lustre/lustreAst.ml @@ -108,6 +108,7 @@ type expr = | NArityOp of position * n_arity_operator * expr list | ConvOp of position * conversion_operator * expr | CompOp of position * comparison_operator * expr * expr + | ChooseOp of position * ident * expr (* Structured expressions *) | RecordExpr of position * ident * (ident * expr) list | GroupExpr of position * group_expr * expr list @@ -606,7 +607,14 @@ let rec pp_print_expr ppf = pp_print_ident id (pp_print_list pp_print_lustre_type "@ ") t (pp_print_list pp_print_expr ",@ ") l - + + | ChooseOp (p, id, e) -> + + Format.fprintf ppf + "%achoose %a: %a" + ppos p + pp_print_ident id + pp_print_expr e (* Pretty-print an array slice *) and pp_print_array_slice ppf (l, u) = diff --git a/src/lustre/lustreAst.mli b/src/lustre/lustreAst.mli index fd32647de..5c73a881b 100644 --- a/src/lustre/lustreAst.mli +++ b/src/lustre/lustreAst.mli @@ -144,6 +144,7 @@ and expr = | NArityOp of position * n_arity_operator * expr list | ConvOp of position * conversion_operator * expr | CompOp of position * comparison_operator * expr * expr + | ChooseOp of position * ident * expr (* Structured expressions *) | RecordExpr of position * ident * (ident * expr) list | GroupExpr of position * group_expr * expr list diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index 63889472a..f6b1d4f04 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -55,7 +55,7 @@ let pos_of_expr = function | Activate (pos , _ , _ , _ , _) | Merge (pos , _ , _ ) | Pre (pos , _) | RestartEvery (pos, _, _, _) | Fby (pos , _ , _ , _) | Arrow (pos , _ , _) | Call (pos , _ , _ ) - | CallParam (pos , _ , _ , _ ) + | CallParam (pos , _ , _ , _ ) | ChooseOp (pos, _, _) -> pos let type_arity ty = @@ -71,7 +71,7 @@ let rec expr_contains_call = function | Ident (_, _) | ModeRef (_, _) | Const (_, _) -> false | RecordProject (_, e, _) | TupleProject (_, e, _) | UnaryOp (_, _, e) | ConvOp (_, _, e) | Quantifier (_, _, _, e) | When (_, e, _) - | Current (_, e) | Pre (_, e) + | Current (_, e) | Pre (_, e) | ChooseOp (_, _, e) -> expr_contains_call e | BinaryOp (_, _, e1, e2) | CompOp (_, _, e1, e2) | StructUpdate (_, e1, _, e2) | ArrayConstr (_, e1, e2) | ArrayIndex (_, e1, e2) | ArrayConcat (_, e1, e2) @@ -116,6 +116,7 @@ let rec substitute (var:HString.t) t = function | ConvOp (pos, op, e) -> ConvOp (pos, op, substitute var t e) | CompOp (pos, op, e1, e2) -> CompOp (pos, op, substitute var t e1, substitute var t e2) + | ChooseOp (pos, i, e) -> ChooseOp(pos, i, substitute var t e) | RecordExpr (pos, ident, expr_list) -> RecordExpr (pos, ident, List.map (fun (i, e) -> (i, substitute var t e)) expr_list) | GroupExpr (pos, kind, expr_list) -> @@ -162,7 +163,8 @@ let rec has_unguarded_pre ung = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) -> has_unguarded_pre ung e + | TupleProject (_, e, _) | Quantifier (_, _, _, e) + | ChooseOp (_, _, e) -> has_unguarded_pre ung e | BinaryOp (_, _, e1, e2) | ArrayConstr (_, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) -> let u1 = has_unguarded_pre ung e1 in @@ -249,7 +251,8 @@ let rec has_unguarded_pre_no_warn ung = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) -> has_unguarded_pre_no_warn ung e + | TupleProject (_, e, _) | Quantifier (_, _, _, e) + | ChooseOp (_, _, e) -> has_unguarded_pre_no_warn ung e | BinaryOp (_, _, e1, e2) | ArrayConstr (_, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) -> let u1 = has_unguarded_pre_no_warn ung e1 in @@ -336,7 +339,8 @@ let rec has_pre_or_arrow = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) -> + | TupleProject (_, e, _) | Quantifier (_, _, _, e) + | ChooseOp (_, _, e) -> has_pre_or_arrow e | BinaryOp (_, _, e1, e2) | CompOp (_, _, e1, e2) @@ -355,6 +359,8 @@ let rec has_pre_or_arrow = function fun _ -> has_pre_or_arrow e3 ) ) + + | GroupExpr (_, _, l) | NArityOp (_, _, l) | Call (_, _, l) | CallParam (_, _, _, l) -> @@ -515,6 +521,12 @@ let rec replace_lasts allowed prefix acc ee = match ee with if e1 == e1' && e2 == e2' then ee, acc else CompOp (pos, op, e1', e2'), acc' + | ChooseOp (pos, i, e) -> + let e', acc' = replace_lasts allowed prefix acc e in + if e == e' then ee, acc + else ChooseOp (pos, i, e'), acc' + + | ArrayConcat (pos, e1, e2) -> let e1', acc' = replace_lasts allowed prefix acc e1 in let e2', acc' = replace_lasts allowed prefix acc' e2 in @@ -785,6 +797,7 @@ let rec vars_of_node_calls_h obs = | NArityOp (_, _,es) -> SI.flatten (List.map (vars obs) es) | ConvOp (_,_,e) -> vars obs e | CompOp (_,_,e1, e2) -> (vars obs e1) |> SI.union (vars obs e2) + | ChooseOp (_, i, e) -> SI.diff (vars obs e) (SI.singleton i) (* Structured expressions *) | RecordExpr (_, _, flds) -> SI.flatten (List.map (vars obs) (snd (List.split flds))) | GroupExpr (_, _, es) -> SI.flatten (List.map (vars obs) es) @@ -849,6 +862,7 @@ let rec vars: expr -> iset = function | Activate (_, _, e1, e2, es) -> SI.flatten (vars e1 :: vars e2 :: List.map vars es) | Merge (_, _, es) -> List.split es |> snd |> List.map vars |> SI.flatten | RestartEvery (_, i, es, e) -> SI.add i (SI.flatten (vars e :: List.map vars es)) + | ChooseOp (_, i, e) -> SI.diff (vars e) (SI.singleton i) (* Temporal operators *) | Pre (_, e) -> vars e | Fby (_, e1, _, e2) -> SI.union (vars e1) (vars e2) @@ -1030,6 +1044,7 @@ let rec replace_with_constants: expr -> expr = let e1' = replace_with_constants e1 in let e2' = replace_with_constants e2 in CompOp (p, op, e1', e2') + | ChooseOp (p, i, expr) -> ChooseOp (p, i, replace_with_constants expr) (* Structured expressions *) | RecordExpr (p, i, flds) -> RecordExpr (p, i, (List.map (fun (f, e) -> (f, replace_with_constants e)) flds)) @@ -1124,6 +1139,7 @@ let rec abstract_pre_subexpressions: expr -> expr = function let e1' = abstract_pre_subexpressions e1 in let e2' = abstract_pre_subexpressions e2 in CompOp (p, op, e1', e2') + | ChooseOp (p, i, e) -> ChooseOp (p, i, abstract_pre_subexpressions e) (* Structured expressions *) | RecordExpr (p, i, flds) -> RecordExpr (p, i, (List.map (fun (f, e) -> (f, abstract_pre_subexpressions e)) flds)) @@ -1205,10 +1221,10 @@ let rec replace_idents locals1 locals2 expr = | RecordProject (a, e, b) -> RecordProject (a, replace_idents locals1 locals2 e, b) | ConvOp (a, b, e) -> ConvOp (a, b, replace_idents locals1 locals2 e) | UnaryOp (a, b, e) -> UnaryOp (a, b, replace_idents locals1 locals2 e) + | Current (a, e) -> Current (a, replace_idents locals1 locals2 e) | When (a, e, b) -> When (a, replace_idents locals1 locals2 e, b) | TupleProject (a, e, b) -> TupleProject (a, replace_idents locals1 locals2 e, b) - | Quantifier (a, b, c, e) -> Quantifier (a, b, c, replace_idents locals1 locals2 e) | BinaryOp (a, b, e1, e2) -> BinaryOp (a, b, replace_idents locals1 locals2 e1, replace_idents locals1 locals2 e2) | CompOp (a, b, e1, e2) -> CompOp (a, b, replace_idents locals1 locals2 e1, replace_idents locals1 locals2 e2) | ArrayConcat (a, e1, e2) -> ArrayConcat (a, replace_idents locals1 locals2 e1, replace_idents locals1 locals2 e2) @@ -1223,6 +1239,18 @@ let rec replace_idents locals1 locals2 expr = | Call (a, b, l) -> Call (a, b, List.map (replace_idents locals1 locals2) l) | CallParam (a, b, c, l) -> CallParam (a, b, c, List.map (replace_idents locals1 locals2) l) + | ChooseOp (a, i, e) -> + (* Remove 'i' from locals because it's bound in 'e' *) + let locals = List.combine locals1 locals2 in + let locals1, locals2 = List.remove_assoc i locals |> List.split in + ChooseOp (a, i, replace_idents locals1 locals2 e) + | Quantifier (a, b, tis, e) -> + (* Remove 'tis' from locals because they're bound in 'e' *) + let locals = List.combine locals1 locals2 in + let is = List.map (fun (_, i, _) -> i) tis in + let locals1, locals2 = List.filter (fun (i, _) -> not (List.mem i is)) locals |> List.split in + Quantifier (a, b, tis, replace_idents locals1 locals2 e) + | Merge (a, b, l) -> Merge (a, b, List.combine (List.map fst l) @@ -1642,6 +1670,9 @@ let hash depth_limit expr = | CallParam (_, i, _, el) -> let el_hash = List.map (r (depth + 1)) el in Hashtbl.hash (30, HString.hash i, el_hash) + | ChooseOp (_, i, e) -> + let e_hash = r (depth + 1) e in + Hashtbl.hash (31, HString.hash i, e_hash) in r 0 expr @@ -1671,6 +1702,7 @@ let rec rename_contract_vars = function | ConvOp (pos, op, e) -> ConvOp (pos, op, rename_contract_vars e) | CompOp (pos, op, e1, e2) -> CompOp (pos, op, rename_contract_vars e1, rename_contract_vars e2) + | ChooseOp (pos, i, e) -> ChooseOp (pos, i, rename_contract_vars e) | RecordExpr (pos, ident, expr_list) -> RecordExpr (pos, ident, List.map (fun (i, e) -> (i, rename_contract_vars e)) expr_list) | GroupExpr (pos, kind, expr_list) -> diff --git a/src/lustre/lustreLexer.mll b/src/lustre/lustreLexer.mll index 7824b4241..901002d60 100644 --- a/src/lustre/lustreLexer.mll +++ b/src/lustre/lustreLexer.mll @@ -279,6 +279,7 @@ let keyword_table = mk_hashtbl [ "with", WITH ; "div", INTDIV ; "mod", MOD ; + "choose", CHOOSE ; (* Clock operators *) "when", WHEN ; diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 247a4d7e5..476b5c22c 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2696,3 +2696,43 @@ Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET IF ASSUME THEN MAIN_PSBLOCKSTART PSBLOCKEND XOR Syntax Error! + +one_expr: CHOOSE XOR + + + +one_expr: CHOOSE LCURLYBRACKET XOR + + + +one_expr: CHOOSE LCURLYBRACKET ASSUME XOR + + + +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON XOR + + + +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON DECIMAL WEAKLY + + + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE XOR + + + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET XOR + + + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME XOR + + + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON XOR + + + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON DECIMAL WEAKLY + + diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index dfe27cb12..ae2c15c3b 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -147,6 +147,7 @@ let mk_span start_pos end_pos = %token HASH %token FORALL %token EXISTS +%token CHOOSE (* Tokens for relations *) %token LTE @@ -190,7 +191,7 @@ let mk_span start_pos end_pos = %token EOF (* Priorities and associativity of operators, lowest first *) -%nonassoc UINT8 UINT16 UINT32 UINT64 INT8 INT16 INT32 INT64 +%nonassoc UINT8 UINT16 UINT32 UINT64 INT8 INT16 INT32 INT64 %nonassoc WHEN CURRENT %left PIPE %nonassoc ELSE @@ -843,6 +844,10 @@ pexpr(Q): | IF; e1 = pexpr(Q); THEN; e2 = pexpr(Q); ELSE; e3 = pexpr(Q) { A.TernaryOp (mk_pos $startpos, A.Ite, e1, e2, e3) } + (* Choose operation *) + | CHOOSE; LCURLYBRACKET; id = ident; COLON; e = pexpr(Q); RCURLYBRACKET + { A.ChooseOp (mk_pos $startpos, id, e) } + (* Recursive node call *) | WITH; e1 = pexpr(Q); THEN; e2 = pexpr(Q); ELSE; e3 = pexpr(Q) { A.TernaryOp (mk_pos $startpos, A.With, e1, e2, e3) } From cf28582c0cd24bf33da49c3421927288d3bd610c Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 22 Mar 2023 15:38:12 -0500 Subject: [PATCH 02/51] Make local variable explicitly typed in choose expression --- src/lustre/lustreAst.ml | 4 ++-- src/lustre/lustreAst.mli | 2 +- src/lustre/lustreAstHelpers.ml | 10 +++++----- src/lustre/lustreParser.messages | 18 +++++++++++------- src/lustre/lustreParser.mly | 2 +- 5 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/lustre/lustreAst.ml b/src/lustre/lustreAst.ml index 4edb89cfc..76ed278d6 100644 --- a/src/lustre/lustreAst.ml +++ b/src/lustre/lustreAst.ml @@ -108,7 +108,7 @@ type expr = | NArityOp of position * n_arity_operator * expr list | ConvOp of position * conversion_operator * expr | CompOp of position * comparison_operator * expr * expr - | ChooseOp of position * ident * expr + | ChooseOp of position * typed_ident * expr (* Structured expressions *) | RecordExpr of position * ident * (ident * expr) list | GroupExpr of position * group_expr * expr list @@ -613,7 +613,7 @@ let rec pp_print_expr ppf = Format.fprintf ppf "%achoose %a: %a" ppos p - pp_print_ident id + pp_print_typed_ident id pp_print_expr e (* Pretty-print an array slice *) diff --git a/src/lustre/lustreAst.mli b/src/lustre/lustreAst.mli index 5c73a881b..b0b92b865 100644 --- a/src/lustre/lustreAst.mli +++ b/src/lustre/lustreAst.mli @@ -144,7 +144,7 @@ and expr = | NArityOp of position * n_arity_operator * expr list | ConvOp of position * conversion_operator * expr | CompOp of position * comparison_operator * expr * expr - | ChooseOp of position * ident * expr + | ChooseOp of position * typed_ident * expr (* Structured expressions *) | RecordExpr of position * ident * (ident * expr) list | GroupExpr of position * group_expr * expr list diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index f6b1d4f04..be0dcb367 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -797,7 +797,7 @@ let rec vars_of_node_calls_h obs = | NArityOp (_, _,es) -> SI.flatten (List.map (vars obs) es) | ConvOp (_,_,e) -> vars obs e | CompOp (_,_,e1, e2) -> (vars obs e1) |> SI.union (vars obs e2) - | ChooseOp (_, i, e) -> SI.diff (vars obs e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e) -> SI.diff (vars obs e) (SI.singleton i) (* Structured expressions *) | RecordExpr (_, _, flds) -> SI.flatten (List.map (vars obs) (snd (List.split flds))) | GroupExpr (_, _, es) -> SI.flatten (List.map (vars obs) es) @@ -862,7 +862,7 @@ let rec vars: expr -> iset = function | Activate (_, _, e1, e2, es) -> SI.flatten (vars e1 :: vars e2 :: List.map vars es) | Merge (_, _, es) -> List.split es |> snd |> List.map vars |> SI.flatten | RestartEvery (_, i, es, e) -> SI.add i (SI.flatten (vars e :: List.map vars es)) - | ChooseOp (_, i, e) -> SI.diff (vars e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e) -> SI.diff (vars e) (SI.singleton i) (* Temporal operators *) | Pre (_, e) -> vars e | Fby (_, e1, _, e2) -> SI.union (vars e1) (vars e2) @@ -1239,11 +1239,11 @@ let rec replace_idents locals1 locals2 expr = | Call (a, b, l) -> Call (a, b, List.map (replace_idents locals1 locals2) l) | CallParam (a, b, c, l) -> CallParam (a, b, c, List.map (replace_idents locals1 locals2) l) - | ChooseOp (a, i, e) -> + | ChooseOp (a, (b, i, c), e) -> (* Remove 'i' from locals because it's bound in 'e' *) let locals = List.combine locals1 locals2 in let locals1, locals2 = List.remove_assoc i locals |> List.split in - ChooseOp (a, i, replace_idents locals1 locals2 e) + ChooseOp (a, (b, i, c), replace_idents locals1 locals2 e) | Quantifier (a, b, tis, e) -> (* Remove 'tis' from locals because they're bound in 'e' *) let locals = List.combine locals1 locals2 in @@ -1670,7 +1670,7 @@ let hash depth_limit expr = | CallParam (_, i, _, el) -> let el_hash = List.map (r (depth + 1)) el in Hashtbl.hash (30, HString.hash i, el_hash) - | ChooseOp (_, i, e) -> + | ChooseOp (_, (_, i, _), e) -> let e_hash = r (depth + 1) e in Hashtbl.hash (31, HString.hash i, e_hash) in diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 476b5c22c..52283412c 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2705,6 +2705,14 @@ one_expr: CHOOSE LCURLYBRACKET XOR +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA XOR + + + +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA DECIMAL WEAKLY + + + one_expr: CHOOSE LCURLYBRACKET ASSUME XOR @@ -2713,7 +2721,7 @@ one_expr: CHOOSE LCURLYBRACKET ASSUME COLON XOR -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON DECIMAL WEAKLY +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME SEMICOLON @@ -2725,14 +2733,10 @@ main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCUR -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME XOR - - - -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON XOR +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA XOR -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON DECIMAL WEAKLY +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA DECIMAL WEAKLY diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index ae2c15c3b..a9aaa3262 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -845,7 +845,7 @@ pexpr(Q): { A.TernaryOp (mk_pos $startpos, A.Ite, e1, e2, e3) } (* Choose operation *) - | CHOOSE; LCURLYBRACKET; id = ident; COLON; e = pexpr(Q); RCURLYBRACKET + | CHOOSE; LCURLYBRACKET; id = typed_ident; COMMA; e = pexpr(Q); RCURLYBRACKET { A.ChooseOp (mk_pos $startpos, id, e) } (* Recursive node call *) From 6a7f0ed179b5df96fb4759f5e4aa538666fc4e9c Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 23 Mar 2023 08:23:21 -0500 Subject: [PATCH 03/51] Fill out pattern matching for ChooseOp --- src/ivcMcs.ml | 3 +- src/lustre/lustreAbstractInterpretation.ml | 4 ++ src/lustre/lustreArrayDependencies.ml | 4 ++ src/lustre/lustreAstDependencies.ml | 6 ++ src/lustre/lustreAstInlineConstants.ml | 1 + src/lustre/lustreDesugarFrameBlocks.ml | 1 + src/lustre/lustreNodeGen.ml | 1 + src/lustre/lustreRemoveMultAssign.ml | 78 ++-------------------- src/lustre/lustreSimplify.ml | 4 ++ src/lustre/lustreSyntaxChecks.ml | 3 +- src/lustre/lustreTypeChecker.ml | 6 ++ 11 files changed, 35 insertions(+), 76 deletions(-) diff --git a/src/ivcMcs.ml b/src/ivcMcs.ml index ffe09d97c..d69b4f567 100644 --- a/src/ivcMcs.ml +++ b/src/ivcMcs.ml @@ -260,6 +260,7 @@ let rec minimize_node_call_args ue lst expr = | A.UnaryOp (p,op,e) -> A.UnaryOp (p,op,aux e) | A.BinaryOp (p,op,e1,e2) -> A.BinaryOp (p,op,aux e1,aux e2) | A.Quantifier (p,q,ids,e) -> A.Quantifier (p,q,ids,aux e) + | A.ChooseOp (p,ti,e) -> A.ChooseOp (p,ti,aux e) | A.NArityOp (p,op,es) -> A.NArityOp (p,op,List.map aux es) | A.TernaryOp (p,op,e1,e2,e3) -> A.TernaryOp (p,op,aux e1,aux e2,aux e3) | A.CompOp (p,op,e1,e2) -> A.CompOp (p,op,aux e1,aux e2) @@ -288,7 +289,7 @@ and ast_contains p ast = |> List.exists (fun x -> x) | A.ConvOp (_,_,e) | A.UnaryOp (_,_,e) | A.RecordProject (_,e,_) | A.TupleProject (_,e,_) | A.Quantifier (_,_,_,e) - | A.When (_,e,_) | A.Current (_,e) | A.Pre (_,e) -> + | A.When (_,e,_) | A.Current (_,e) | A.Pre (_,e) | A.ChooseOp (_,_,e) -> aux e | A.StructUpdate (_,e1,_,e2) | A.ArrayConstr (_,e1,e2) | A.ArrayConcat (_,e1,e2) | A.ArrayIndex (_,e1,e2) diff --git a/src/lustre/lustreAbstractInterpretation.ml b/src/lustre/lustreAbstractInterpretation.ml index 55d39e0f1..2fa353ace 100644 --- a/src/lustre/lustreAbstractInterpretation.ml +++ b/src/lustre/lustreAbstractInterpretation.ml @@ -447,6 +447,10 @@ and interpret_int_expr node_id ctx ty_ctx proj expr = | NArityOp _ -> assert false | ConvOp (_, _, e) -> interpret_int_expr node_id ctx ty_ctx proj e | CompOp _-> assert false + | ChooseOp (_, (_, i, ty), e) -> + let ty_ctx = Ctx.union ty_ctx (Ctx.singleton_ty i ty) in + let ctx = add_type ctx node_id i ty in + interpret_int_expr node_id ctx ty_ctx proj e | RecordExpr _ -> assert false | GroupExpr (_, ExprList, es) -> ( let g = interpret_int_expr node_id ctx ty_ctx in diff --git a/src/lustre/lustreArrayDependencies.ml b/src/lustre/lustreArrayDependencies.ml index 771c03c55..af8a7c343 100644 --- a/src/lustre/lustreArrayDependencies.ml +++ b/src/lustre/lustreArrayDependencies.ml @@ -197,6 +197,10 @@ and process_expr ind_vars ctx ns proj indices expr = vars in R.ok graph + | ChooseOp (_, (_, i, _), e) -> + let* graph = r e in + let graph = G.remove_vertex graph (i, [0]) + in R.ok graph (* Clock operators *) | When (_, e, _) -> r e | Current (_, e) -> r e diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 962d55ee1..0e2fcd528 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -385,6 +385,7 @@ let rec get_node_call_from_expr: LA.expr -> (LA.ident * Lib.position) list | LA.NArityOp (_, _, es) -> List.flatten (List.map get_node_call_from_expr es) | LA.ConvOp (_, _, e) -> get_node_call_from_expr e | LA.CompOp (_, _, e1, e2) -> (get_node_call_from_expr e1) @ (get_node_call_from_expr e2) + | LA.ChooseOp (_, _, e) -> get_node_call_from_expr e (* Structured expressions *) | LA.RecordExpr (_, _, id_exprs) -> List.flatten (List.map (fun (_, e) -> get_node_call_from_expr e) id_exprs) | LA.GroupExpr (_, _, es) -> List.flatten (List.map get_node_call_from_expr es) @@ -625,6 +626,11 @@ let rec vars_with_flattened_nodes: node_summary -> int -> LA.expr -> LA.SI.t (* Quantified expressions *) | Quantifier (_, _, qs, e) -> SI.diff (r e) (SI.flatten (List.map LH.vars_of_ty_ids qs)) + + (* Choose operator *) + | ChooseOp (_, (_, i, _), e) -> + SI.diff (r e) (SI.singleton i) + (* Clock operators *) | When (_, e, _) -> r e | Current (_, e) -> r e diff --git a/src/lustre/lustreAstInlineConstants.ml b/src/lustre/lustreAstInlineConstants.ml index 3f1f49503..7d81b651c 100644 --- a/src/lustre/lustreAstInlineConstants.ml +++ b/src/lustre/lustreAstInlineConstants.ml @@ -270,6 +270,7 @@ and push_pre is_guarded pos = | ArrayConcat (p, e1, e2) -> ArrayConcat (p, r e1, r e2) | ArraySlice (p, e1, (e2, e3)) -> ArraySlice (p, r e1, (e2, e3)) | Quantifier (p, e1, l, e2) -> Quantifier (p, e1, l, r e2) + | ChooseOp (p, i, e) -> ChooseOp (p, i, r e) | When _ as e -> LA.Pre (pos, e) | Current _ as e -> LA.Pre (pos, e) | Condact _ as e -> LA.Pre (pos, e) diff --git a/src/lustre/lustreDesugarFrameBlocks.ml b/src/lustre/lustreDesugarFrameBlocks.ml index 5827e03d4..afabc6556 100644 --- a/src/lustre/lustreDesugarFrameBlocks.ml +++ b/src/lustre/lustreDesugarFrameBlocks.ml @@ -115,6 +115,7 @@ let rec fill_ite_helper frame_pos node_id lhs id fill = function | Quantifier (a, b, c, e) -> Quantifier (a, b, c, fill_ite_helper frame_pos node_id lhs id fill e) | BinaryOp (a, b, e1, e2) -> BinaryOp (a, b, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) | CompOp (a, b, e1, e2) -> CompOp (a, b, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) + | ChooseOp (a, b, e) -> ChooseOp (a, b, fill_ite_helper frame_pos node_id lhs id fill e) | ArrayConcat (a, e1, e2) -> ArrayConcat (a, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) | ArrayIndex (a, e1, e2) -> ArrayIndex (a, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) | ArrayConstr (a, e1, e2) -> ArrayConstr (a, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) diff --git a/src/lustre/lustreNodeGen.ml b/src/lustre/lustreNodeGen.ml index 745192c9f..edb630eb4 100644 --- a/src/lustre/lustreNodeGen.ml +++ b/src/lustre/lustreNodeGen.ml @@ -1073,6 +1073,7 @@ and compile_ast_expr | A.Pre (_, expr) -> compile_pre bounds expr | A.Merge (_, clock_ident, merge_cases) -> compile_merge bounds clock_ident merge_cases + | A.ChooseOp _ -> assert false (* already desugared in lustreAstNormalizer *) (* ****************************************************************** *) (* Tuple and Record Operators *) (* ****************************************************************** *) diff --git a/src/lustre/lustreRemoveMultAssign.ml b/src/lustre/lustreRemoveMultAssign.ml index f54c0126e..0af379d33 100644 --- a/src/lustre/lustreRemoveMultAssign.ml +++ b/src/lustre/lustreRemoveMultAssign.ml @@ -20,6 +20,7 @@ module AH = LustreAstHelpers module Ctx = TypeCheckerContext module Chk = LustreTypeChecker module GI = GeneratedIdentifiers +module LAH = LustreAstHelpers (** [i] is module state used to guarantee newly created identifiers are unique *) let i = ref (0) @@ -45,74 +46,6 @@ let mk_fresh_temp_var ty = locals = GI.StringMap.singleton name (false, ty); } in name, gids2 - - -(** When pulling out temp variables for recursive array definitions, - we also have to modify the RHS to match the temp variable. - For example, we want equations of the form - 'temp[i] = if i = 0 then 0 else temp[i-1] + 1' rather than - 'temp[i] = if i = 0 then 0 else y[i-1] + 1', where 'y' was - the original LHS variable name. -*) -let rec modify_arraydefs_in_expr array_assoc_list = function - (* Replace all oracles with 'fill' *) - | A.Ident (pos, i1) -> ( - let update = List.assoc_opt i1 array_assoc_list in - match update with - | Some id -> A.Ident(pos, id) - | None -> A.Ident(pos, i1) - ) - (* Everything else is just recursing to find Idents *) - | Pre (a, e) -> Pre (a, (modify_arraydefs_in_expr array_assoc_list e)) - | Arrow (a, e1, e2) -> Arrow (a, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2)) - | Const _ as e -> e - | ModeRef _ as e -> e - | RecordProject (a, e, b) -> RecordProject (a, (modify_arraydefs_in_expr array_assoc_list e), b) - | ConvOp (a, b, e) -> ConvOp (a, b, (modify_arraydefs_in_expr array_assoc_list e)) - | UnaryOp (a, b, e) -> UnaryOp (a, b, (modify_arraydefs_in_expr array_assoc_list e)) - | Current (a, e) -> Current (a, (modify_arraydefs_in_expr array_assoc_list e)) - | When (a, e, b) -> When (a, (modify_arraydefs_in_expr array_assoc_list e), b) - | TupleProject (a, e, b) -> TupleProject (a, (modify_arraydefs_in_expr array_assoc_list e), b) - | Quantifier (a, b, c, e) -> Quantifier (a, b, c, (modify_arraydefs_in_expr array_assoc_list e)) - | BinaryOp (a, b, e1, e2) -> BinaryOp (a, b, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2)) - | CompOp (a, b, e1, e2) -> CompOp (a, b, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2)) - | ArrayConcat (a, e1, e2) -> ArrayConcat (a, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2)) - | ArrayIndex (a, e1, e2) -> ArrayIndex (a, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2)) - | ArrayConstr (a, e1, e2) -> ArrayConstr (a, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2)) - | Fby (a, e1, b, e2) -> Fby (a, (modify_arraydefs_in_expr array_assoc_list e1), b, (modify_arraydefs_in_expr array_assoc_list e2)) - | TernaryOp (a, b, e1, e2, e3) -> TernaryOp (a, b, (modify_arraydefs_in_expr array_assoc_list e1), (modify_arraydefs_in_expr array_assoc_list e2), (modify_arraydefs_in_expr array_assoc_list e3)) - | ArraySlice (a, e1, (e2, e3)) -> ArraySlice (a, (modify_arraydefs_in_expr array_assoc_list e1), ((modify_arraydefs_in_expr array_assoc_list e2), (modify_arraydefs_in_expr array_assoc_list e3))) - - | GroupExpr (a, b, l) -> GroupExpr (a, b, List.map (modify_arraydefs_in_expr array_assoc_list) l) - | NArityOp (a, b, l) -> NArityOp (a, b, List.map (modify_arraydefs_in_expr array_assoc_list) l) - | Call (a, b, l) -> Call (a, b, List.map (modify_arraydefs_in_expr array_assoc_list) l) - | CallParam (a, b, c, l) -> CallParam (a, b, c, List.map (modify_arraydefs_in_expr array_assoc_list) l) - - | Merge (a, b, l) -> Merge (a, b, - List.combine - (List.map fst l) - (List.map (modify_arraydefs_in_expr array_assoc_list) (List.map snd l))) - - | RecordExpr (a, b, l) -> RecordExpr (a, b, - List.combine - (List.map fst l) - (List.map (modify_arraydefs_in_expr array_assoc_list) (List.map snd l))) - - | RestartEvery (a, b, l, e) -> - RestartEvery (a, b, List.map (modify_arraydefs_in_expr array_assoc_list) l, modify_arraydefs_in_expr array_assoc_list e) - | Activate (a, b, e, r, l) -> - Activate (a, b, (modify_arraydefs_in_expr array_assoc_list) e, (modify_arraydefs_in_expr array_assoc_list) r, List.map (modify_arraydefs_in_expr array_assoc_list) l) - | Condact (a, e, r, b, l1, l2) -> - Condact (a, (modify_arraydefs_in_expr array_assoc_list) e, (modify_arraydefs_in_expr array_assoc_list) r, b, - List.map (modify_arraydefs_in_expr array_assoc_list) l1, List.map (modify_arraydefs_in_expr array_assoc_list) l2) - - | StructUpdate (a, e1, li, e2) -> - A.StructUpdate (a, modify_arraydefs_in_expr array_assoc_list e1, - List.map (function - | A.Label (a, b) -> A.Label (a, b) - | Index (a, e) -> Index (a, modify_arraydefs_in_expr array_assoc_list e) - ) li, - modify_arraydefs_in_expr array_assoc_list e2) (** Takes in an equation LHS and returns @@ -169,12 +102,9 @@ let create_new_eqs ctx lhs expr = | A.ArrayDef (_, id, _) -> Some id | _ -> None) in - let array_assoc_list = - let arrayids_original = get_array_ids ss in - let arrayids_new = get_array_ids sis in - List.combine arrayids_original arrayids_new - in - let expr = modify_arraydefs_in_expr array_assoc_list expr in + let arrayids_original = get_array_ids ss in + let arrayids_new = get_array_ids sis in + let expr = LAH.replace_idents arrayids_original arrayids_new expr in let gids2 = { (GI.empty ()) with equations = [([], [], A.StructDef(pos, sis), expr)]; } in diff --git a/src/lustre/lustreSimplify.ml b/src/lustre/lustreSimplify.ml index 33a3f3e86..3b1401ffc 100644 --- a/src/lustre/lustreSimplify.ml +++ b/src/lustre/lustreSimplify.ml @@ -1300,6 +1300,10 @@ let rec eval_ast_expr bounds ctx = fail_at_position pos "Parametric nodes not supported" + | A.ChooseOp (pos, _, _) -> + + fail_at_position pos "Choose operation not supported in old front end" + (* ******************************************************************** *) diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index 6f8a34ebb..3df9b081a 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -505,7 +505,8 @@ let rec expr_only_supported_in_merge observer expr = | ConvOp (_, _, e) | Pre (_, e) | Current (_, e) - | Quantifier (_, _, _, e) -> r observer e + | Quantifier (_, _, _, e) + | ChooseOp (_, _, e) -> r observer e | BinaryOp (_, _, e1, e2) | StructUpdate (_, e1, _, e2) | CompOp (_, _, e1, e2) diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index 8f4ed6a58..15784cf16 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -441,6 +441,9 @@ let rec infer_type_expr: tc_context -> LA.expr -> (tc_type, [> error]) result (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in infer_type_expr extn_ctx e + | ChooseOp (_, (_, i, ty), e) -> + let extn_ctx = union ctx (singleton_ty i ty) in + infer_type_expr extn_ctx e (* Clock operators *) | LA.When (_, e, _) -> infer_type_expr ctx e | LA.Current (_, e) -> infer_type_expr ctx e @@ -639,6 +642,9 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in check_type_expr extn_ctx e exp_ty + | ChooseOp (_, (_, i ,ty), e) -> + let extn_ctx = union ctx (singleton_ty i ty) in + check_type_expr extn_ctx e exp_ty (* Clock operators *) | When (_, e, _) -> check_type_expr ctx e exp_ty | Current (_, e) -> check_type_expr ctx e exp_ty From 94ba49d6c99442d3f73a44a92396ac4f1be48d79 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 23 Mar 2023 09:19:51 -0500 Subject: [PATCH 04/51] Update pattern matching ChooseOp --- src/lustre/lustreAbstractInterpretation.ml | 6 ++---- src/lustre/lustreAstDependencies.ml | 1 + src/lustre/lustreTypeChecker.ml | 9 ++++----- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/src/lustre/lustreAbstractInterpretation.ml b/src/lustre/lustreAbstractInterpretation.ml index 2fa353ace..6639360ba 100644 --- a/src/lustre/lustreAbstractInterpretation.ml +++ b/src/lustre/lustreAbstractInterpretation.ml @@ -447,10 +447,8 @@ and interpret_int_expr node_id ctx ty_ctx proj expr = | NArityOp _ -> assert false | ConvOp (_, _, e) -> interpret_int_expr node_id ctx ty_ctx proj e | CompOp _-> assert false - | ChooseOp (_, (_, i, ty), e) -> - let ty_ctx = Ctx.union ty_ctx (Ctx.singleton_ty i ty) in - let ctx = add_type ctx node_id i ty in - interpret_int_expr node_id ctx ty_ctx proj e + | ChooseOp (_, (_, _, ty), _) -> + extract_bounds_from_type ty | RecordExpr _ -> assert false | GroupExpr (_, ExprList, es) -> ( let g = interpret_int_expr node_id ctx ty_ctx in diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 0e2fcd528..3396a565a 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -800,6 +800,7 @@ let rec mk_graph_expr2: node_summary -> LA.expr -> (dependency_analysis_data lis empty_dependency_analysis_data (List.concat gs)] + | LA.ChooseOp (_, _, e) -> mk_graph_expr2 m e | LA.When (_, e, _) -> mk_graph_expr2 m e | LA.Current (_, e) -> mk_graph_expr2 m e | LA.Condact (pos, _, _, n, e1s, e2s) -> diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index 15784cf16..71ae093a9 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -441,9 +441,8 @@ let rec infer_type_expr: tc_context -> LA.expr -> (tc_type, [> error]) result (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in infer_type_expr extn_ctx e - | ChooseOp (_, (_, i, ty), e) -> - let extn_ctx = union ctx (singleton_ty i ty) in - infer_type_expr extn_ctx e + | ChooseOp (_, (_, _, ty), _) -> + R.ok ty (* Clock operators *) | LA.When (_, e, _) -> infer_type_expr ctx e | LA.Current (_, e) -> infer_type_expr ctx e @@ -642,9 +641,9 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in check_type_expr extn_ctx e exp_ty - | ChooseOp (_, (_, i ,ty), e) -> + | ChooseOp (pos, (_, i ,ty), e) -> let extn_ctx = union ctx (singleton_ty i ty) in - check_type_expr extn_ctx e exp_ty + check_type_expr extn_ctx e (Bool pos) (* Clock operators *) | When (_, e, _) -> check_type_expr ctx e exp_ty | Current (_, e) -> check_type_expr ctx e exp_ty From 890db8ac58fa95c251e7d18519121c6772ed1c94 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 28 Mar 2023 10:37:18 -0500 Subject: [PATCH 05/51] Add desugaring for ChooseOp in lustreAstNormalizer --- src/lustre/lustreAstNormalizer.ml | 449 ++++++++++++++++------------- src/lustre/lustreAstNormalizer.mli | 2 +- src/lustre/lustreInput.ml | 6 +- src/lustre/lustreNodeGen.ml | 1 + src/lustre/lustreTypeChecker.mli | 5 + 5 files changed, 259 insertions(+), 204 deletions(-) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index 6b633e9be..acc4b0db5 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -94,6 +94,7 @@ type warning = [ let mk_warning pos kind = `LustreAstNormalizerWarning (pos, kind) let (>>=) = Res.(>>=) + let unwrap result = match result with | Ok r -> r | Error e -> @@ -202,11 +203,12 @@ type info = { local_group_projection : int } -let split3 triples = - let xs = List.map (fun (x, _, _) -> x) triples in - let ys = List.map (fun (_, y, _) -> y) triples in - let zs = List.map (fun (_, _, z) -> z) triples in - xs, ys, zs +let split4 quads = + let xs = List.map (fun (x, _, _, _) -> x) quads in + let ys = List.map (fun (_, y, _, _) -> y) quads in + let zs = List.map (fun (_, _, z, _) -> z) quads in + let ns = List.map (fun (_, _, _, n) -> n) quads in + xs, ys, zs, ns let pp_print_generated_identifiers ppf gids = let locals_list = StringMap.bindings gids.locals @@ -385,6 +387,12 @@ let mk_fresh_node_arg_local info pos is_const ind_vars expr_type expr = NodeArgCache.add node_arg_cache expr nexpr; nexpr, gids +let mk_fresh_fn_name () = + i := !i + 1; + let prefix = HString.mk_hstring (string_of_int !i) in + let name = HString.concat2 prefix (HString.mk_hstring "_fn") in + name + let mk_range_expr ctx expr_type expr = let rec mk ctx n expr_type expr = let expr_type = Ctx.expand_nested_type_syn ctx expr_type in @@ -505,11 +513,11 @@ let get_type_of_id info node_id id = let should_not_abstract force expr = not force && AH.expr_is_id expr let normalize_list f list = - let over_list (nitems, gids, warnings1) item = - let (normal_item, ids, warnings2) = f item in - normal_item :: nitems, union ids gids, warnings1 @ warnings2 - in let list, gids, warnings = List.fold_left over_list ([], empty (), []) list in - List.rev list, gids, warnings + let over_list (nitems, gids, warnings1, fns1) item = + let (normal_item, ids, warnings2, fns2) = f item in + normal_item :: nitems, union ids gids, warnings1 @ warnings2, fns1 @ fns2 + in let list, gids, warnings, fns = List.fold_left over_list ([], empty (), [], []) list in + List.rev list, gids, warnings, fns let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = let info = { context = ctx; @@ -523,19 +531,27 @@ let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = interpretation = StringMap.empty; local_group_projection = -1 } in - let gids, warnings = normalize_gids info gids in - let over_declarations (nitems, accum, warnings_accum) item = + let gids, warnings, fns = normalize_gids info gids in + let over_declarations (nitems, accum, warnings_accum, fns_accum) item = clear_cache (); - let (normal_item, map, warnings) = + let (normal_item, map, warnings, fns) = normalize_declaration info accum item in (match normal_item with | Some ni -> ni :: nitems | None -> nitems), StringMap.merge union_keys2 map accum, - warnings @ warnings_accum - in let ast, map, warnings_map = List.fold_left over_declarations - ([], gids, warnings) decls - in let ast = List.rev ast in + warnings @ warnings_accum, + fns @ fns_accum + in let ast, map, warnings, fns = List.fold_left over_declarations + ([], gids, warnings, fns) decls + in let ast = List.rev ast + in let ctx = List.fold_left (fun ctx decl -> + match decl with + | A.FuncDecl (_, (id, _, _, ip, op, _, _, _)) -> + let fun_ty = (Chk.build_node_fun_ty Lib.dummy_pos ctx ip op) |> unwrap in + (Ctx.add_ty_node ctx id fun_ty) + | _ -> ctx + ) ctx fns in Debug.parse ("===============================================\n" ^^ "Generated Identifiers:\n%a\n\n" @@ -550,38 +566,40 @@ let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = (StringMap.bindings map) A.pp_print_program ast; - Res.ok (ast, map, warnings_map) + (*!! EXPAND CTX TO INCLUDE NEW IMPORTED NODES !!*) + Res.ok (fns @ ast, map, warnings, ctx) and normalize_declaration info map = function | A.NodeDecl (span, decl) -> - let normal_decl, map, warnings = normalize_node info map decl in - Some (A.NodeDecl(span, normal_decl)), map, warnings + let normal_decl, map, warnings, fns = normalize_node info map decl in + Some (A.NodeDecl(span, normal_decl)), map, warnings, fns | FuncDecl (span, decl) -> - let normal_decl, map, warnings = normalize_node info map decl in - Some (A.FuncDecl (span, normal_decl)), map, warnings - | ContractNodeDecl (_, _) -> None, StringMap.empty, [] - | decl -> Some decl, StringMap.empty, [] + let normal_decl, map, warnings, fns = normalize_node info map decl in + Some (A.FuncDecl (span, normal_decl)), map, warnings, fns + | ContractNodeDecl (_, _) -> None, StringMap.empty, [], [] + | decl -> Some decl, StringMap.empty, [], [] and normalize_gids info gids_map = (* Convert gids_map to a new gids_map with normalized equations *) - let gids_map, warnings = StringMap.fold (fun id gids (gids_map, warnings) -> + let gids_map, warnings, fns = StringMap.fold (fun id gids (gids_map, warnings, fns) -> (* Normalize all equations in gids *) let res = List.map (fun (_, _, lhs, expr) -> - let nexpr, gids, warnings = normalize_expr info gids_map expr in - gids, warnings, (info.quantified_variables, info.contract_scope, lhs, nexpr) + let nexpr, gids, warnings, fns = normalize_expr id info gids_map expr in + gids, warnings, fns, (info.quantified_variables, info.contract_scope, lhs, nexpr) ) gids.equations in - let gids_list, warnings2, eqs = split3 res in + let gids_list, warnings2, fns2, eqs = split4 res in (* Take out old equations that were not normalized *) let gids = { gids with equations = [] } in let gids = List.fold_left (fun acc g -> union g acc) gids gids_list in let warnings2 = List.flatten warnings2 in + let fns2 = List.flatten fns2 in (* Keep equations generated during normalization *) let eqs2 = gids.equations in let gids = { gids with equations = eqs @ eqs2; } in let gids_map = StringMap.add id gids gids_map in - (gids_map, warnings @ warnings2) - ) gids_map (gids_map, []) in - gids_map, warnings + (gids_map, warnings @ warnings2, fns @ fns2) + ) gids_map (gids_map, [], []) in + gids_map, warnings, fns and normalize_node_contract info map cref inputs outputs (id, _, ivars, ovars, body) = let contract_ref = cref in @@ -611,30 +629,19 @@ and normalize_node_contract info map cref inputs outputs (id, _, ivars, ovars, b interpretation = interp; contract_ref; } in - let nbody, gids, warnings = normalize_contract info map id body in - nbody, gids, warnings, StringMap.empty - -(* -and normalize_const_declaration info map = function - | A.UntypedConst (pos, id, expr) -> - let nexpr, gids = normalize_expr ?guard:None false info map expr in - A.UntypedConst (pos, id, nexpr), gids - | TypedConst (pos, id, expr, ty) -> - let nexpr, gids = normalize_expr ?guard:None false info map expr in - A.TypedConst (pos, id, nexpr, ty), gids - | e -> e, empty () -*) + let nbody, gids, warnings, fns = normalize_contract info map id body in + nbody, gids, warnings, fns, StringMap.empty -and normalize_ghost_declaration info map = function +and normalize_ghost_declaration node_id info map = function | A.UntypedConst (pos, id, expr) -> let new_id = StringMap.find id info.interpretation in - let nexpr, gids, warnings = normalize_expr ?guard:None info map expr in - A.UntypedConst (pos, new_id, nexpr), gids, warnings + let nexpr, map, warnings, fns = normalize_expr node_id ?guard:None info map expr in + A.UntypedConst (pos, new_id, nexpr), map, warnings, fns | TypedConst (pos, id, expr, ty) -> let new_id = StringMap.find id info.interpretation in - let nexpr, gids, warnings = normalize_expr ?guard:None info map expr in - A.TypedConst (pos, new_id, nexpr, ty), gids, warnings - | e -> e, empty (), [] + let nexpr, map, warnings, fns = normalize_expr node_id ?guard:None info map expr in + A.TypedConst (pos, new_id, nexpr, ty), map, warnings, fns + | e -> e, empty (), [], [] and normalize_node info map (node_id, is_extern, params, inputs, outputs, locals, items, contracts) = @@ -679,16 +686,16 @@ and normalize_node info map in (* We have to handle contracts before locals Otherwise the typing contexts collide *) - let ncontracts, gids5, warnings1 = match contracts with + let ncontracts, gids5, warnings1, fns1 = match contracts with | Some contracts -> let ctx = Chk.tc_ctx_of_contract info.context contracts |> unwrap in let contract_ref = new_contract_reference () in let info = { info with context = ctx; contract_ref } in - let ncontracts, gids, warnings = normalize_contract info map node_id + let ncontracts, gids, warnings, fns = normalize_contract info map node_id contracts in - (Some ncontracts), gids, warnings - | None -> None, empty (), [] + (Some ncontracts), gids, warnings, fns + | None -> None, empty (), [], [] in (* Record subrange constraints on locals and finish setting up the typing context for the node body *) @@ -713,21 +720,21 @@ and normalize_node info map (empty ()) in (* Normalize equations and the contract *) - let nitems, gids4, warnings2 = normalize_list (normalize_item info map) items in + let nitems, gids4, warnings2, fns2 = normalize_list (normalize_item node_id info map) items in let gids = union_list [gids1; gids2; gids3; gids4; gids5] in let map = StringMap.singleton node_id gids in - (node_id, is_extern, params, inputs, outputs, locals, nitems, ncontracts), map, warnings1 @ warnings2 + (node_id, is_extern, params, inputs, outputs, locals, nitems, ncontracts), map, warnings1 @ warnings2, fns1 @ fns2 -and normalize_item info map = function +and normalize_item node_id info map = function | A.Body equation -> - let nequation, gids, warnings = normalize_equation info map equation in - A.Body nequation, gids, warnings + let nequation, gids, warnings, fns = normalize_equation node_id info map equation in + A.Body nequation, gids, warnings, fns (* shouldn't be possible *) | IfBlock _ | FrameBlock _ -> assert false - | AnnotMain (pos, b) -> AnnotMain (pos, b), empty (), [] + | AnnotMain (pos, b) -> AnnotMain (pos, b), empty (), [], [] | AnnotProperty (pos, name, expr) -> let name' = match name with @@ -740,8 +747,8 @@ and normalize_item info map = function ) | Some _ as n -> n in - let nexpr, gids, warnings = abstract_expr false info map false expr in - AnnotProperty (pos, name', nexpr), gids, warnings + let nexpr, gids, warnings, fns = abstract_expr false node_id info map false expr in + AnnotProperty (pos, name', nexpr), gids, warnings, fns and rename_ghost_variables info node_id contract = let sep = HString.mk_hstring "_contract_" in @@ -768,6 +775,7 @@ and rename_ghost_variables info node_id contract = and normalize_contract info map node_id items = let gids = ref (empty ()) in let warnings = ref [] in + let fns = ref [] in let result = ref [] in let ghost_interp, info = rename_ghost_variables info node_id items in let ghost_interp = List.fold_left (StringMap.merge union_keys) @@ -779,26 +787,26 @@ and normalize_contract info map node_id items = for j = 0 to (List.length items) - 1 do let info = { info with interpretation = !interpretation } in let item = List.nth items j in - let nitem, gids', warnings', interpretation' = match item with + let nitem, gids', warnings', fns', interpretation' = match item with | Assume (pos, name, soft, expr) -> - let nexpr, gids, warnings = abstract_expr force_fresh info map true expr in - A.Assume (pos, name, soft, nexpr), gids, warnings, StringMap.empty + let nexpr, gids, warnings, fns = abstract_expr force_fresh node_id info map true expr in + A.Assume (pos, name, soft, nexpr), gids, warnings, fns, StringMap.empty | Guarantee (pos, name, soft, expr) -> - let nexpr, gids, warnings = abstract_expr force_fresh info map true expr in - Guarantee (pos, name, soft, nexpr), gids, warnings, StringMap.empty + let nexpr, gids, warnings, fns = abstract_expr force_fresh node_id info map true expr in + Guarantee (pos, name, soft, nexpr), gids, warnings, fns, StringMap.empty | Mode (pos, name, requires, ensures) -> (* let new_name = info.contract_ref ^ "_contract_" ^ name in let interpretation = StringMap.singleton name new_name in let info = { info with interpretation } in *) let over_property info map (pos, name, expr) = - let nexpr, gids, warnings = abstract_expr true info map true expr in - (pos, name, nexpr), gids, warnings + let nexpr, gids, warnings, fns = abstract_expr true node_id info map true expr in + (pos, name, nexpr), gids, warnings, fns in - let nrequires, gids1, warnings1 = normalize_list (over_property info map) requires in - let nensures, gids2, warnings2 = normalize_list (over_property info map) ensures in - Mode (pos, name, nrequires, nensures), union gids1 gids2, warnings1 @ warnings2, StringMap.empty + let nrequires, gids1, warnings1, fns1 = normalize_list (over_property info map) requires in + let nensures, gids2, warnings2, fns2 = normalize_list (over_property info map) ensures in + Mode (pos, name, nrequires, nensures), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2, StringMap.empty | ContractCall (pos, name, inputs, outputs) -> - let ninputs, gids1, warnings1 = normalize_list (abstract_expr false info map false) inputs in + let ninputs, gids1, warnings1, fns1 = normalize_list (abstract_expr false node_id info map false) inputs in let noutputs = List.map (fun id -> match StringMap.find_opt id info.interpretation with | Some new_id -> new_id @@ -818,21 +826,22 @@ and normalize_contract info map node_id items = } in let called_node = StringMap.find name info.contract_calls_info in - let normalized_call, gids2, warnings2, interp = + let normalized_call, gids2, warnings2, fns2, interp = normalize_node_contract info map cref ninputs noutputs called_node in let gids = union gids1 gids2 in let warnings = warnings1 @ warnings2 in + let fns = fns1 @ fns2 in let gids = { gids with contract_calls = StringMap.add info.contract_ref (pos, info.contract_scope, normalized_call) gids.contract_calls } in - ContractCall (pos, cref, inputs, outputs), gids, warnings, interp + ContractCall (pos, cref, inputs, outputs), gids, warnings, fns, interp | GhostConst decl -> - let ndecl, gids, warnings = normalize_ghost_declaration info map decl in - GhostConst ndecl, gids, warnings, StringMap.empty + let ndecl, map, warnings, fns = normalize_ghost_declaration node_id info map decl in + GhostConst ndecl, map, warnings, fns, StringMap.empty | GhostVars (pos, ((GhostVarDec (pos2, tis)) as lhs), expr) -> let items = match lhs with | A.GhostVarDec (_, items) -> items in let lhs_arity = List.length items in @@ -852,24 +861,25 @@ and normalize_contract info map node_id items = (fun acc v -> acc || StringMap.mem v info.inductive_variables) false in - let (nexpr, gids1, warnings), expanded = ( + let (nexpr, gids1, warnings, fns), expanded = ( if has_inductive && lhs_arity <> rhs_arity then (match StringMap.choose_opt info.inductive_variables with | Some (ivar, ty) -> let size = extract_array_size ty in let expanded_expr = expand_node_calls_in_place info ivar size expr in - let exprs, gids, warnings = split3 (List.init lhs_arity + let exprs, gids, warnings, fns = split4 (List.init lhs_arity ( fun i -> let info = { info with local_group_projection = i } in - normalize_expr ?guard:None info map expanded_expr + normalize_expr ?guard:None node_id info map expanded_expr ) ) in let gids = List.fold_left (fun acc g -> union g acc) (empty ()) gids in let warnings = List.flatten warnings in - (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings), true - | None -> normalize_expr ?guard:None info map expr, false) + let fns = List.flatten fns in + (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings, fns), true + | None -> normalize_expr ?guard:None node_id info map expr, false) else if has_inductive && lhs_arity = rhs_arity then let expanded_expr = List.fold_left @@ -879,8 +889,8 @@ and normalize_contract info map node_id items = expr (StringMap.bindings info.inductive_variables) in - normalize_expr ?guard:None info map expanded_expr, true - else normalize_expr ?guard:None info map expr, false + normalize_expr ?guard:None node_id info map expanded_expr, true + else normalize_expr ?guard:None node_id info map expr, false ) in let gids2 = ( @@ -909,23 +919,24 @@ and normalize_contract info map node_id items = (* Get new identifiers for LHS *) let new_tis = List.map (fun (p, id, e) -> (p, StringMap.find id info.interpretation, e)) tis in - GhostVars (pos, GhostVarDec(pos2, new_tis), nexpr), union (union gids1 gids2) gids3, warnings, StringMap.empty + GhostVars (pos, GhostVarDec(pos2, new_tis), nexpr), union (union gids1 gids2) gids3, warnings, fns, StringMap.empty | AssumptionVars decl -> - AssumptionVars decl, empty (), [], StringMap.empty + AssumptionVars decl, empty (), [], [], StringMap.empty in interpretation := StringMap.merge union_keys !interpretation interpretation'; result := nitem :: !result; gids := union !gids gids'; warnings := !warnings @ warnings'; + fns := !fns @ fns'; done; - !result, !gids, !warnings + !result, !gids, !warnings, !fns -and normalize_equation info map = function +and normalize_equation node_id info map = function | Assert (pos, expr) -> - let nexpr, gids, warnings = abstract_expr true info map true expr in - A.Assert (pos, nexpr), gids, warnings + let nexpr, map, warnings, fns = abstract_expr true node_id info map true expr in + A.Assert (pos, nexpr), map, warnings, fns | Equation (pos, lhs, expr) -> (* Need to track array indexes of the left hand side if there are any *) let items = match lhs with | A.StructDef (_, items) -> items in @@ -959,21 +970,22 @@ and normalize_equation info map = function (fun acc v -> acc || StringMap.mem v info.inductive_variables) false in - let (nexpr, gids1, warnings), expanded = ( + let (nexpr, gids1, warnings, fns), expanded = ( if has_inductive && lhs_arity <> rhs_arity then (match StringMap.choose_opt info.inductive_variables with | Some (ivar, ty) -> let size = extract_array_size ty in let expanded_expr = expand_node_calls_in_place info ivar size expr in - let exprs, gids, warnings = split3 (List.init lhs_arity + let exprs, gids, warnings, fns = split4 (List.init lhs_arity (fun i -> let info = { info with local_group_projection = i } in - normalize_expr info map expanded_expr)) + normalize_expr node_id info map expanded_expr)) in let gids = List.fold_left (fun acc g -> union g acc) (empty ()) gids in let warnings = List.flatten warnings in - (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings), true - | None -> normalize_expr info map expr, false) + let fns = List.flatten fns in + (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings, fns), true + | None -> normalize_expr node_id info map expr, false) else if has_inductive && lhs_arity = rhs_arity then let expanded_expr = List.fold_left (fun acc (v, ty) -> @@ -982,8 +994,8 @@ and normalize_equation info map = function expr (StringMap.bindings info.inductive_variables) in - normalize_expr info map expanded_expr, true - else normalize_expr info map expr, false) + normalize_expr node_id info map expanded_expr, true + else normalize_expr node_id info map expr, false) in let gids2 = if expanded then let items = match lhs with | StructDef (_, items) -> items in @@ -995,7 +1007,7 @@ and normalize_equation info map = function { (empty ()) with expanded_variables = StringSet.of_list ids } else empty () in - Equation (pos, lhs, nexpr), union gids1 gids2, warnings + Equation (pos, lhs, nexpr), union gids1 gids2, warnings, fns and rename_id info = function | A.Ident (pos, id) -> @@ -1004,10 +1016,10 @@ and rename_id info = function | None -> A.Ident (pos, id)) | _ -> assert false -and abstract_expr ?guard force info map is_ghost expr = - let nexpr, gids1, warnings = normalize_expr ?guard info map expr in +and abstract_expr ?guard force node_id info map is_ghost expr = + let nexpr, gids1, warnings, fns = normalize_expr node_id ?guard info map expr in if should_not_abstract force nexpr then - nexpr, gids1, warnings + nexpr, gids1, warnings, fns else let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in @@ -1016,7 +1028,7 @@ and abstract_expr ?guard force info map is_ghost expr = else Chk.infer_type_expr info.context expr |> unwrap in let iexpr, gids2 = mk_fresh_local force info pos is_ghost ivars ty nexpr in - iexpr, union gids1 gids2, warnings + iexpr, union gids1 gids2, warnings, fns and expand_node_call info expr var count = let ty = Chk.infer_type_expr info.context expr |> unwrap in @@ -1053,11 +1065,11 @@ and combine_args_with_const info args flags = List.fold_left over_args_arity (0, []) (List.combine args output_arity) |> snd |> List.rev -and normalize_expr ?guard info map = +and normalize_expr ?guard node_id info map = let abstract_node_arg ?guard force is_const info map expr = - let nexpr, gids1, warnings = normalize_expr ?guard info map expr in + let nexpr, gids1, warnings, fns = normalize_expr ?guard node_id info map expr in if should_not_abstract force nexpr then - nexpr, gids1, warnings + nexpr, gids1, warnings, fns else let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in @@ -1066,7 +1078,7 @@ and normalize_expr ?guard info map = else Chk.infer_type_expr info.context expr |> unwrap in let iexpr, gids2 = mk_fresh_node_arg_local info pos is_const ivars ty nexpr in - iexpr, union gids1 gids2, warnings + iexpr, union gids1 gids2, warnings, [] in function (* ************************************************************************ *) (* Node calls *) @@ -1075,95 +1087,97 @@ and normalize_expr ?guard info map = let flags = StringMap.find id info.node_is_input_const in let cond = A.Const (Lib.dummy_pos, A.True) in let restart = A.Const (Lib.dummy_pos, A.False) in - let nargs, gids1, warnings = normalize_list + let nargs, gids1, warnings, fns = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids2 = mk_fresh_call info id map pos cond restart nargs None in - nexpr, union gids1 gids2, warnings + nexpr, union gids1 gids2, warnings, fns | Condact (pos, cond, restart, id, args, defaults) -> let flags = StringMap.find id info.node_is_input_const in - let ncond, gids1, warnings1 = if AH.expr_is_true cond then cond, empty (), [] - else abstract_expr ?guard true info map false cond in - let nrestart, gids2, warnings2 = if AH.expr_is_const restart then restart, empty (), [] - else abstract_expr ?guard true info map false restart - in let nargs, gids3, warnings3 = normalize_list + let ncond, gids1, warnings1, fns1 = if AH.expr_is_true cond then cond, empty (), [], [] + else abstract_expr ?guard true node_id info map false cond in + let nrestart, gids2, warnings2, fns2 = if AH.expr_is_const restart then restart, empty (), [], [] + else abstract_expr ?guard true node_id info map false restart + in let nargs, gids3, warnings3, fns3 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in - let ndefaults, gids4, warnings4 = normalize_list (normalize_expr ?guard info map) defaults in + let ndefaults, gids4, warnings4, fns4 = normalize_list (normalize_expr ?guard node_id info map) defaults in let nexpr, gids5 = mk_fresh_call info id map pos ncond nrestart nargs (Some ndefaults) in let gids = union_list [gids1; gids2; gids3; gids4; gids5] in let warnings = warnings1 @ warnings2 @ warnings3 @ warnings4 in - nexpr, gids, warnings + let fns = fns1 @ fns2 @ fns3 @ fns4 in + nexpr, gids, warnings, fns | RestartEvery (pos, id, args, restart) -> let flags = StringMap.find id info.node_is_input_const in let cond = A.Const (dummy_pos, A.True) in - let nrestart, gids1, warnings1 = if AH.expr_is_const restart then restart, empty (), [] - else abstract_expr ?guard true info map false restart - in let nargs, gids2, warnings2 = normalize_list + let nrestart, gids1, warnings1, fns1 = if AH.expr_is_const restart then restart, empty (), [], [] + else abstract_expr ?guard true node_id info map false restart + in let nargs, gids2, warnings2, fns2 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids3 = mk_fresh_call info id map pos cond nrestart nargs None in let gids = union_list [gids1; gids2; gids3] in - nexpr, gids, warnings1 @ warnings2 + nexpr, gids, warnings1 @ warnings2, fns1 @ fns2 | Merge (pos, clock_id, cases) -> let normalize' info map ?guard = function | clock_value, A.Activate (pos, id, cond, restart, args) -> let flags = StringMap.find id info.node_is_input_const in - let ncond, gids1, warnings1 = if AH.expr_is_true cond then cond, empty (), [] - else abstract_expr ?guard false info map false cond in - let nrestart, gids2 , warnings2 = if AH.expr_is_const restart then restart, empty (), [] - else abstract_expr ?guard false info map false restart in - let nargs, gids3, warnings3 = normalize_list + let ncond, gids1, warnings1, fns1 = if AH.expr_is_true cond then cond, empty (), [], [] + else abstract_expr ?guard false node_id info map false cond in + let nrestart, gids2 , warnings2, fns2 = if AH.expr_is_const restart then restart, empty (), [], [] + else abstract_expr ?guard false node_id info map false restart in + let nargs, gids3, warnings3, fns3 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids4 = mk_fresh_call info id map pos ncond nrestart nargs None in let gids = union_list [gids1; gids2; gids3; gids4] in let warnings = warnings1 @ warnings2 @ warnings3 in - (clock_value, nexpr), gids, warnings + (clock_value, nexpr), gids, warnings, fns1 @ fns2 @ fns3 | clock_value, A.Call (pos, id, args) -> let flags = StringMap.find id info.node_is_input_const in let cond_expr = match HString.string_of_hstring clock_value with | "true" -> A.Ident (pos, clock_id) | "false" -> A.UnaryOp (pos, A.Not, A.Ident (pos, clock_id)) | _ -> A.CompOp (pos, A.Eq, A.Ident (pos, clock_id), A.Ident (pos, clock_value)) - in let ncond, gids1, warnings1 = abstract_expr ?guard false info map false cond_expr in + in let ncond, gids1, warnings1, fns1 = abstract_expr ?guard false node_id info map false cond_expr in let restart = A.Const (Lib.dummy_pos, A.False) in - let nargs, gids2, warnings2 = normalize_list + let nargs, gids2, warnings2, fns2 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids3 = mk_fresh_call info id map pos ncond restart nargs None in let gids = union_list [gids1; gids2; gids3] in let warnings = warnings1 @ warnings2 in - (clock_value, nexpr), gids, warnings + let fns = fns1 @ fns2 in + (clock_value, nexpr), gids, warnings, fns | clock_value, expr -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - (clock_value, nexpr), gids, warnings - in let ncases, gids, warnings = normalize_list (normalize' ?guard info map) cases in - Merge (pos, clock_id, ncases), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + (clock_value, nexpr), gids, warnings, fns + in let ncases, gids, warnings, fns = normalize_list (normalize' ?guard info map) cases in + Merge (pos, clock_id, ncases), gids, warnings, fns (* ************************************************************************ *) (* Guarding and abstracting pres *) (* ************************************************************************ *) | Arrow (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard:(Some nexpr1) info map expr2 in + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard:(Some nexpr1) node_id info map expr2 in let gids = union gids1 gids2 in let warnings = warnings1 @ warnings2 in - Arrow (pos, nexpr1, nexpr2), gids, warnings + Arrow (pos, nexpr1, nexpr2), gids, warnings, fns1 @ fns2 | Pre (pos1, ArrayIndex (pos2, expr1, expr2)) -> let expr = A.ArrayIndex (pos2, Pre (pos1, expr1), expr2) in - normalize_expr ?guard info map expr + normalize_expr ?guard node_id info map expr | Pre (pos, expr) -> let ivars = info.inductive_variables in let ty = if expr_has_inductive_var ivars expr |> is_some then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in - let nexpr, gids1, warnings1 = abstract_expr ?guard:None false info map false expr in + let nexpr, gids1, warnings1, fns = abstract_expr ?guard:None false node_id info map false expr in let guard, gids2, warnings2, previously_guarded = match guard with | Some guard -> guard, empty (), [], true | None -> @@ -1178,8 +1192,8 @@ and normalize_expr ?guard info map = A.ArrayIndex (pos2, Pre (pos, expr1), expr2) | e -> Pre (pos, e) in - if previously_guarded then nexpr', gids, warnings - else Arrow (pos, guard, nexpr'), gids, warnings + if previously_guarded then nexpr', gids, warnings, fns + else Arrow (pos, guard, nexpr'), gids, warnings, fns (* ************************************************************************ *) (* Misc. abstractions *) (* ************************************************************************ *) @@ -1189,84 +1203,114 @@ and normalize_expr ?guard info map = (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in - let nexpr, gids1, warnings = normalize_expr ?guard info map expr in + let nexpr, gids1, warnings, fns = normalize_expr ?guard node_id info map expr in let ivars = info.inductive_variables in let iexpr, gids2= mk_fresh_array_ctor info pos ivars ty nexpr size_expr in - ArrayConstr (pos, iexpr, size_expr), union gids1 gids2, warnings + ArrayConstr (pos, iexpr, size_expr), union gids1 gids2, warnings, fns (* ************************************************************************ *) (* Variable renaming to ease handling contract scopes *) (* ************************************************************************ *) - | Ident _ as e -> rename_id info e, empty (), [] + | Ident _ as e -> rename_id info e, empty (), [], [] (* ************************************************************************ *) (* The remaining expr kinds are all just structurally recursive *) (* ************************************************************************ *) - | ModeRef _ as expr -> expr, empty (), [] + | ModeRef _ as expr -> expr, empty (), [], [] | RecordProject (pos, expr, i) -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - RecordProject (pos, nexpr, i), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + RecordProject (pos, nexpr, i), gids, warnings, fns | TupleProject (pos, expr, i) -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - TupleProject (pos, nexpr, i), gids, warnings - | Const _ as expr -> expr, empty (), [] + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + TupleProject (pos, nexpr, i), gids, warnings, fns + | Const _ as expr -> expr, empty (), [], [] | UnaryOp (pos, op, expr) -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - UnaryOp (pos, op, nexpr), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + UnaryOp (pos, op, nexpr), gids, warnings, fns | BinaryOp (pos, op, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - BinaryOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + BinaryOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 | TernaryOp (pos, op, expr1, expr2, expr3) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - let nexpr3, gids3, warnings3 = normalize_expr ?guard info map expr3 in + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + let nexpr3, gids3, warnings3, fns3 = normalize_expr ?guard node_id info map expr3 in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in - TernaryOp (pos, op, nexpr1, nexpr2, nexpr3), gids, warnings + let fns = fns1 @ fns2 @ fns3 in + TernaryOp (pos, op, nexpr1, nexpr2, nexpr3), gids, warnings, fns | NArityOp (pos, op, expr_list) -> - let nexpr_list, gids, warnings = normalize_list - (normalize_expr ?guard info map) + let nexpr_list, gids, warnings, fns = normalize_list + (normalize_expr ?guard node_id info map) expr_list in - NArityOp (pos, op, nexpr_list), gids, warnings + NArityOp (pos, op, nexpr_list), gids, warnings, fns | ConvOp (pos, op, expr) -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - ConvOp (pos, op, nexpr), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + ConvOp (pos, op, nexpr), gids, warnings, fns | CompOp (pos, op, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - CompOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + CompOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 + | ChooseOp (pos, (_, id, ty), expr) -> + let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in + let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in + let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in + let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in + let ctx = Ctx.add_ty info.context id ty in + let info = { info with context = ctx } in + let inputs = List.map (fun input -> (pos, input, Ctx.lookup_ty ctx input, A.ClockTrue)) inputs in + let inputs = List.map (fun (p, inp, opt, cl) -> match opt with Some ty -> p, inp, ty, cl, false | None -> assert false) inputs in + let name = mk_fresh_fn_name () in + let map = StringMap.add name (empty ()) map in + let generated_fn = + A.FuncDecl (span, + (name, true, [], inputs, + [Lib.dummy_pos, id, ty, A.ClockTrue], [], [], Some contract)) + in + let cond = A.Const (dummy_pos, A.True) in + let restart = A.Const (Lib.dummy_pos, A.False) in + let nargs, gids1, warnings, fns = normalize_list + (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) + (combine_args_with_const info inputs_call [false]) + in + let nexpr, gids2 = mk_fresh_call info name map pos cond restart nargs None in + let (normalized_fn, map, warnings2, fns2) = normalize_declaration info map generated_fn in + let normalized_fn = match normalized_fn with + | Some normalized_fn -> normalized_fn + | None -> assert false in + nexpr, union gids1 gids2, warnings @ warnings2, normalized_fn :: fns @ fns2 | RecordExpr (pos, id, id_expr_list) -> let normalize' info map ?guard (id, expr) = - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - (id, nexpr), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + (id, nexpr), gids, warnings, fns in - let nid_expr_list, gids, warnings = normalize_list + let nid_expr_list, gids, warnings, fns = normalize_list (normalize' ?guard info map) id_expr_list in - RecordExpr (pos, id, nid_expr_list), gids, warnings + RecordExpr (pos, id, nid_expr_list), gids, warnings, fns | GroupExpr (pos, kind, expr_list) -> - let nexpr_list, gids, warnings = normalize_list - (normalize_expr ?guard info map) + let nexpr_list, gids, warnings, fns = normalize_list + (normalize_expr ?guard node_id info map) expr_list in - GroupExpr (pos, kind, nexpr_list), gids, warnings + GroupExpr (pos, kind, nexpr_list), gids, warnings, fns | StructUpdate (pos, expr1, i, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - StructUpdate (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2 + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + StructUpdate (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 | ArraySlice (pos, expr1, (expr2, expr3)) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - let nexpr3, gids3, warnings3 = normalize_expr ?guard info map expr3 in + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + let nexpr3, gids3, warnings3, fns3 = normalize_expr ?guard node_id info map expr3 in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in - ArraySlice (pos, nexpr1, (nexpr2, nexpr3)), gids, warnings + let fns = fns1 @ fns2 @ fns3 in + ArraySlice (pos, nexpr1, (nexpr2, nexpr3)), gids, warnings, fns | ArrayIndex (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - ArrayIndex (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + ArrayIndex (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 | ArrayConcat (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - ArrayConcat (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + ArrayConcat (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 | Quantifier (pos, kind, vars, expr) -> let ctx = List.fold_left Ctx.union info.context (List.map (fun (_, i, ty) -> Ctx.singleton_ty i ty) vars) @@ -1275,32 +1319,33 @@ and normalize_expr ?guard info map = info with context = ctx; quantified_variables = info.quantified_variables @ vars } in - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - Quantifier (pos, kind, vars, nexpr), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + Quantifier (pos, kind, vars, nexpr), gids, warnings, fns | When (pos, expr, clock_expr) -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - When (pos, nexpr, clock_expr), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + When (pos, nexpr, clock_expr), gids, warnings, fns | Current (pos, expr) -> - let nexpr, gids, warnings = normalize_expr ?guard info map expr in - Current (pos, nexpr), gids, warnings + let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in + Current (pos, nexpr), gids, warnings, fns | Activate (pos, id, expr1, expr2, expr_list) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - let nexpr_list, gids3, warnings3 = normalize_list - (normalize_expr ?guard info map) + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + let nexpr_list, gids3, warnings3, fns3 = normalize_list + (normalize_expr ?guard node_id info map) expr_list in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in - Activate (pos, id, nexpr1, nexpr2, nexpr_list), gids, warnings + let fns = fns1 @ fns2 @ fns3 in + Activate (pos, id, nexpr1, nexpr2, nexpr_list), gids, warnings, fns | Fby (pos, expr1, i, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in - Fby (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2 + let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in + Fby (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 | CallParam (pos, id, type_list, expr_list) -> - let nexpr_list, gids, warnings = normalize_list - (normalize_expr ?guard info map) + let nexpr_list, gids, warnings, fns = normalize_list + (normalize_expr ?guard node_id info map) expr_list in - CallParam (pos, id, type_list, nexpr_list), gids, warnings + CallParam (pos, id, type_list, nexpr_list), gids, warnings, fns and expand_node_calls_in_place info var count expr = let r = expand_node_calls_in_place info var count in diff --git a/src/lustre/lustreAstNormalizer.mli b/src/lustre/lustreAstNormalizer.mli index c95d37f7c..f73d960c8 100644 --- a/src/lustre/lustreAstNormalizer.mli +++ b/src/lustre/lustreAstNormalizer.mli @@ -84,7 +84,7 @@ val normalize : TypeCheckerContext.tc_context -> LustreAst.t -> GeneratedIdentifiers.t GeneratedIdentifiers.StringMap.t -> (LustreAst.declaration list * GeneratedIdentifiers.t GeneratedIdentifiers.StringMap.t * - [> `LustreAstNormalizerWarning of Lib.position * warning_kind ] list, [> error]) + [> `LustreAstNormalizerWarning of Lib.position * warning_kind] list * TypeCheckerContext.tc_context, [> error]) result val pp_print_generated_identifiers : Format.formatter -> GeneratedIdentifiers.t -> unit diff --git a/src/lustre/lustreInput.ml b/src/lustre/lustreInput.ml index 8047301dc..3ace5a1ac 100644 --- a/src/lustre/lustreInput.ml +++ b/src/lustre/lustreInput.ml @@ -179,9 +179,13 @@ let type_check declarations = let abstract_interp_ctx = LIA.interpret_program inlined_global_ctx gids const_inlined_nodes_and_contracts in (* Step 14. Normalize AST: guard pres, abstract to locals where appropriate *) - let* (normalized_nodes_and_contracts, gids, warnings2) = + let* (normalized_nodes_and_contracts, gids, warnings2, inlined_global_ctx) = LAN.normalize inlined_global_ctx abstract_interp_ctx const_inlined_nodes_and_contracts gids in + + List.iter (LA.pp_print_declaration Format.std_formatter) normalized_nodes_and_contracts; + TypeCheckerContext.pp_print_tc_context Format.std_formatter inlined_global_ctx; + GeneratedIdentifiers.StringMap.iter (fun _ -> (LAN.pp_print_generated_identifiers Format.std_formatter)) gids; Res.ok (inlined_global_ctx, gids, diff --git a/src/lustre/lustreNodeGen.ml b/src/lustre/lustreNodeGen.ml index edb630eb4..448a6bda5 100644 --- a/src/lustre/lustreNodeGen.ml +++ b/src/lustre/lustreNodeGen.ml @@ -2205,6 +2205,7 @@ and compile_declaration cstate gids ctx decl = let empty_map = ref (empty_identifier_maps None) in compile_const_decl cstate ctx empty_map [] const_decl | A.FuncDecl (_, (i, ext, [], inputs, outputs, locals, items, contract)) -> + print_endline (HString.string_of_hstring i); let gids = GI.StringMap.find i gids in compile_node_decl gids true cstate ctx i ext inputs outputs locals items contract | A.NodeDecl (_, (i, ext, [], inputs, outputs, locals, items, contract)) -> diff --git a/src/lustre/lustreTypeChecker.mli b/src/lustre/lustreTypeChecker.mli index b6cf546cb..16c4ff29d 100644 --- a/src/lustre/lustreTypeChecker.mli +++ b/src/lustre/lustreTypeChecker.mli @@ -109,6 +109,11 @@ val get_node_ctx : tc_context -> 'a * 'b * 'c * LA.const_clocked_typed_decl list * LA.clocked_typed_decl list * LA.node_local_decl list * 'd * 'e -> (tc_context, [> error ]) result + +val build_node_fun_ty : Lib.position -> + tc_context -> + LA.const_clocked_typed_decl list -> + LA.clocked_typed_decl list -> (tc_type, [> error ]) result val infer_type_expr: tc_context -> LA.expr -> (tc_type, [> error]) result (** Infer type of Lustre expression given a typing context *) From 0837616817cd24f4bb9847fb0802df572dc4a3d3 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 29 Mar 2023 16:58:52 -0500 Subject: [PATCH 06/51] Move desugaring earlier in the pipeline --- src/lustre/lustreAstNormalizer.ml | 387 +++++++++++--------------- src/lustre/lustreDesugarChooseOps.ml | 203 ++++++++++++++ src/lustre/lustreDesugarChooseOps.mli | 20 ++ src/lustre/lustreInput.ml | 18 +- 4 files changed, 404 insertions(+), 224 deletions(-) create mode 100644 src/lustre/lustreDesugarChooseOps.ml create mode 100644 src/lustre/lustreDesugarChooseOps.mli diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index acc4b0db5..df52ac721 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -210,6 +210,12 @@ let split4 quads = let ns = List.map (fun (_, _, _, n) -> n) quads in xs, ys, zs, ns +let split3 triples = + let xs = List.map (fun (x, _, _) -> x) triples in + let ys = List.map (fun (_, y, _) -> y) triples in + let zs = List.map (fun (_, _, z) -> z) triples in + xs, ys, zs + let pp_print_generated_identifiers ppf gids = let locals_list = StringMap.bindings gids.locals |> List.map (fun (x, (y, z)) -> x, y, z) @@ -387,12 +393,6 @@ let mk_fresh_node_arg_local info pos is_const ind_vars expr_type expr = NodeArgCache.add node_arg_cache expr nexpr; nexpr, gids -let mk_fresh_fn_name () = - i := !i + 1; - let prefix = HString.mk_hstring (string_of_int !i) in - let name = HString.concat2 prefix (HString.mk_hstring "_fn") in - name - let mk_range_expr ctx expr_type expr = let rec mk ctx n expr_type expr = let expr_type = Ctx.expand_nested_type_syn ctx expr_type in @@ -513,11 +513,11 @@ let get_type_of_id info node_id id = let should_not_abstract force expr = not force && AH.expr_is_id expr let normalize_list f list = - let over_list (nitems, gids, warnings1, fns1) item = - let (normal_item, ids, warnings2, fns2) = f item in - normal_item :: nitems, union ids gids, warnings1 @ warnings2, fns1 @ fns2 - in let list, gids, warnings, fns = List.fold_left over_list ([], empty (), [], []) list in - List.rev list, gids, warnings, fns + let over_list (nitems, gids, warnings1) item = + let (normal_item, ids, warnings2) = f item in + normal_item :: nitems, union ids gids, warnings1 @ warnings2 + in let list, gids, warnings = List.fold_left over_list ([], empty (), []) list in + List.rev list, gids, warnings let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = let info = { context = ctx; @@ -531,27 +531,19 @@ let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = interpretation = StringMap.empty; local_group_projection = -1 } in - let gids, warnings, fns = normalize_gids info gids in - let over_declarations (nitems, accum, warnings_accum, fns_accum) item = + let gids, warnings = normalize_gids info gids in + let over_declarations (nitems, accum, warnings_accum) item = clear_cache (); - let (normal_item, map, warnings, fns) = + let (normal_item, map, warnings) = normalize_declaration info accum item in (match normal_item with | Some ni -> ni :: nitems | None -> nitems), StringMap.merge union_keys2 map accum, - warnings @ warnings_accum, - fns @ fns_accum - in let ast, map, warnings, fns = List.fold_left over_declarations - ([], gids, warnings, fns) decls - in let ast = List.rev ast - in let ctx = List.fold_left (fun ctx decl -> - match decl with - | A.FuncDecl (_, (id, _, _, ip, op, _, _, _)) -> - let fun_ty = (Chk.build_node_fun_ty Lib.dummy_pos ctx ip op) |> unwrap in - (Ctx.add_ty_node ctx id fun_ty) - | _ -> ctx - ) ctx fns in + warnings @ warnings_accum + in let ast, map, warnings = List.fold_left over_declarations + ([], gids, warnings) decls + in let ast = List.rev ast in Debug.parse ("===============================================\n" ^^ "Generated Identifiers:\n%a\n\n" @@ -566,40 +558,38 @@ let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = (StringMap.bindings map) A.pp_print_program ast; - (*!! EXPAND CTX TO INCLUDE NEW IMPORTED NODES !!*) - Res.ok (fns @ ast, map, warnings, ctx) + Res.ok (ast, map, warnings, ctx) and normalize_declaration info map = function | A.NodeDecl (span, decl) -> - let normal_decl, map, warnings, fns = normalize_node info map decl in - Some (A.NodeDecl(span, normal_decl)), map, warnings, fns + let normal_decl, map, warnings = normalize_node info map decl in + Some (A.NodeDecl(span, normal_decl)), map, warnings | FuncDecl (span, decl) -> - let normal_decl, map, warnings, fns = normalize_node info map decl in - Some (A.FuncDecl (span, normal_decl)), map, warnings, fns - | ContractNodeDecl (_, _) -> None, StringMap.empty, [], [] - | decl -> Some decl, StringMap.empty, [], [] + let normal_decl, map, warnings = normalize_node info map decl in + Some (A.FuncDecl (span, normal_decl)), map, warnings + | ContractNodeDecl (_, _) -> None, StringMap.empty, [] + | decl -> Some decl, StringMap.empty, [] and normalize_gids info gids_map = (* Convert gids_map to a new gids_map with normalized equations *) - let gids_map, warnings, fns = StringMap.fold (fun id gids (gids_map, warnings, fns) -> + let gids_map, warnings = StringMap.fold (fun id gids (gids_map, warnings) -> (* Normalize all equations in gids *) let res = List.map (fun (_, _, lhs, expr) -> - let nexpr, gids, warnings, fns = normalize_expr id info gids_map expr in - gids, warnings, fns, (info.quantified_variables, info.contract_scope, lhs, nexpr) + let nexpr, gids, warnings = normalize_expr id info gids_map expr in + gids, warnings, (info.quantified_variables, info.contract_scope, lhs, nexpr) ) gids.equations in - let gids_list, warnings2, fns2, eqs = split4 res in + let gids_list, warnings2, eqs = split3 res in (* Take out old equations that were not normalized *) let gids = { gids with equations = [] } in let gids = List.fold_left (fun acc g -> union g acc) gids gids_list in let warnings2 = List.flatten warnings2 in - let fns2 = List.flatten fns2 in (* Keep equations generated during normalization *) let eqs2 = gids.equations in let gids = { gids with equations = eqs @ eqs2; } in let gids_map = StringMap.add id gids gids_map in - (gids_map, warnings @ warnings2, fns @ fns2) - ) gids_map (gids_map, [], []) in - gids_map, warnings, fns + (gids_map, warnings @ warnings2) + ) gids_map (gids_map, []) in + gids_map, warnings and normalize_node_contract info map cref inputs outputs (id, _, ivars, ovars, body) = let contract_ref = cref in @@ -629,19 +619,19 @@ and normalize_node_contract info map cref inputs outputs (id, _, ivars, ovars, b interpretation = interp; contract_ref; } in - let nbody, gids, warnings, fns = normalize_contract info map id body in - nbody, gids, warnings, fns, StringMap.empty + let nbody, gids, warnings = normalize_contract info map id body in + nbody, gids, warnings, StringMap.empty and normalize_ghost_declaration node_id info map = function | A.UntypedConst (pos, id, expr) -> let new_id = StringMap.find id info.interpretation in - let nexpr, map, warnings, fns = normalize_expr node_id ?guard:None info map expr in - A.UntypedConst (pos, new_id, nexpr), map, warnings, fns + let nexpr, map, warnings = normalize_expr node_id ?guard:None info map expr in + A.UntypedConst (pos, new_id, nexpr), map, warnings | TypedConst (pos, id, expr, ty) -> let new_id = StringMap.find id info.interpretation in - let nexpr, map, warnings, fns = normalize_expr node_id ?guard:None info map expr in - A.TypedConst (pos, new_id, nexpr, ty), map, warnings, fns - | e -> e, empty (), [], [] + let nexpr, map, warnings = normalize_expr node_id ?guard:None info map expr in + A.TypedConst (pos, new_id, nexpr, ty), map, warnings + | e -> e, empty (), [] and normalize_node info map (node_id, is_extern, params, inputs, outputs, locals, items, contracts) = @@ -686,16 +676,16 @@ and normalize_node info map in (* We have to handle contracts before locals Otherwise the typing contexts collide *) - let ncontracts, gids5, warnings1, fns1 = match contracts with + let ncontracts, gids5, warnings1 = match contracts with | Some contracts -> let ctx = Chk.tc_ctx_of_contract info.context contracts |> unwrap in let contract_ref = new_contract_reference () in let info = { info with context = ctx; contract_ref } in - let ncontracts, gids, warnings, fns = normalize_contract info map node_id + let ncontracts, gids, warnings = normalize_contract info map node_id contracts in - (Some ncontracts), gids, warnings, fns - | None -> None, empty (), [], [] + (Some ncontracts), gids, warnings + | None -> None, empty (), [] in (* Record subrange constraints on locals and finish setting up the typing context for the node body *) @@ -720,21 +710,21 @@ and normalize_node info map (empty ()) in (* Normalize equations and the contract *) - let nitems, gids4, warnings2, fns2 = normalize_list (normalize_item node_id info map) items in + let nitems, gids4, warnings2 = normalize_list (normalize_item node_id info map) items in let gids = union_list [gids1; gids2; gids3; gids4; gids5] in let map = StringMap.singleton node_id gids in - (node_id, is_extern, params, inputs, outputs, locals, nitems, ncontracts), map, warnings1 @ warnings2, fns1 @ fns2 + (node_id, is_extern, params, inputs, outputs, locals, nitems, ncontracts), map, warnings1 @ warnings2 and normalize_item node_id info map = function | A.Body equation -> - let nequation, gids, warnings, fns = normalize_equation node_id info map equation in - A.Body nequation, gids, warnings, fns + let nequation, gids, warnings = normalize_equation node_id info map equation in + A.Body nequation, gids, warnings (* shouldn't be possible *) | IfBlock _ | FrameBlock _ -> assert false - | AnnotMain (pos, b) -> AnnotMain (pos, b), empty (), [], [] + | AnnotMain (pos, b) -> AnnotMain (pos, b), empty (), [] | AnnotProperty (pos, name, expr) -> let name' = match name with @@ -747,8 +737,8 @@ and normalize_item node_id info map = function ) | Some _ as n -> n in - let nexpr, gids, warnings, fns = abstract_expr false node_id info map false expr in - AnnotProperty (pos, name', nexpr), gids, warnings, fns + let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + AnnotProperty (pos, name', nexpr), gids, warnings and rename_ghost_variables info node_id contract = let sep = HString.mk_hstring "_contract_" in @@ -775,7 +765,6 @@ and rename_ghost_variables info node_id contract = and normalize_contract info map node_id items = let gids = ref (empty ()) in let warnings = ref [] in - let fns = ref [] in let result = ref [] in let ghost_interp, info = rename_ghost_variables info node_id items in let ghost_interp = List.fold_left (StringMap.merge union_keys) @@ -787,26 +776,26 @@ and normalize_contract info map node_id items = for j = 0 to (List.length items) - 1 do let info = { info with interpretation = !interpretation } in let item = List.nth items j in - let nitem, gids', warnings', fns', interpretation' = match item with + let nitem, gids', warnings', interpretation' = match item with | Assume (pos, name, soft, expr) -> - let nexpr, gids, warnings, fns = abstract_expr force_fresh node_id info map true expr in - A.Assume (pos, name, soft, nexpr), gids, warnings, fns, StringMap.empty + let nexpr, gids, warnings = abstract_expr force_fresh node_id info map true expr in + A.Assume (pos, name, soft, nexpr), gids, warnings, StringMap.empty | Guarantee (pos, name, soft, expr) -> - let nexpr, gids, warnings, fns = abstract_expr force_fresh node_id info map true expr in - Guarantee (pos, name, soft, nexpr), gids, warnings, fns, StringMap.empty + let nexpr, gids, warnings = abstract_expr force_fresh node_id info map true expr in + Guarantee (pos, name, soft, nexpr), gids, warnings, StringMap.empty | Mode (pos, name, requires, ensures) -> (* let new_name = info.contract_ref ^ "_contract_" ^ name in let interpretation = StringMap.singleton name new_name in let info = { info with interpretation } in *) let over_property info map (pos, name, expr) = - let nexpr, gids, warnings, fns = abstract_expr true node_id info map true expr in - (pos, name, nexpr), gids, warnings, fns + let nexpr, gids, warnings = abstract_expr true node_id info map true expr in + (pos, name, nexpr), gids, warnings in - let nrequires, gids1, warnings1, fns1 = normalize_list (over_property info map) requires in - let nensures, gids2, warnings2, fns2 = normalize_list (over_property info map) ensures in - Mode (pos, name, nrequires, nensures), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2, StringMap.empty + let nrequires, gids1, warnings1 = normalize_list (over_property info map) requires in + let nensures, gids2, warnings2 = normalize_list (over_property info map) ensures in + Mode (pos, name, nrequires, nensures), union gids1 gids2, warnings1 @ warnings2, StringMap.empty | ContractCall (pos, name, inputs, outputs) -> - let ninputs, gids1, warnings1, fns1 = normalize_list (abstract_expr false node_id info map false) inputs in + let ninputs, gids1, warnings1 = normalize_list (abstract_expr false node_id info map false) inputs in let noutputs = List.map (fun id -> match StringMap.find_opt id info.interpretation with | Some new_id -> new_id @@ -826,22 +815,21 @@ and normalize_contract info map node_id items = } in let called_node = StringMap.find name info.contract_calls_info in - let normalized_call, gids2, warnings2, fns2, interp = + let normalized_call, gids2, warnings2, interp = normalize_node_contract info map cref ninputs noutputs called_node in let gids = union gids1 gids2 in let warnings = warnings1 @ warnings2 in - let fns = fns1 @ fns2 in let gids = { gids with contract_calls = StringMap.add info.contract_ref (pos, info.contract_scope, normalized_call) gids.contract_calls } in - ContractCall (pos, cref, inputs, outputs), gids, warnings, fns, interp + ContractCall (pos, cref, inputs, outputs), gids, warnings, interp | GhostConst decl -> - let ndecl, map, warnings, fns = normalize_ghost_declaration node_id info map decl in - GhostConst ndecl, map, warnings, fns, StringMap.empty + let ndecl, map, warnings = normalize_ghost_declaration node_id info map decl in + GhostConst ndecl, map, warnings, StringMap.empty | GhostVars (pos, ((GhostVarDec (pos2, tis)) as lhs), expr) -> let items = match lhs with | A.GhostVarDec (_, items) -> items in let lhs_arity = List.length items in @@ -861,13 +849,13 @@ and normalize_contract info map node_id items = (fun acc v -> acc || StringMap.mem v info.inductive_variables) false in - let (nexpr, gids1, warnings, fns), expanded = ( + let (nexpr, gids1, warnings), expanded = ( if has_inductive && lhs_arity <> rhs_arity then (match StringMap.choose_opt info.inductive_variables with | Some (ivar, ty) -> let size = extract_array_size ty in let expanded_expr = expand_node_calls_in_place info ivar size expr in - let exprs, gids, warnings, fns = split4 (List.init lhs_arity + let exprs, gids, warnings = split3 (List.init lhs_arity ( fun i -> let info = { info with local_group_projection = i } in @@ -877,8 +865,7 @@ and normalize_contract info map node_id items = in let gids = List.fold_left (fun acc g -> union g acc) (empty ()) gids in let warnings = List.flatten warnings in - let fns = List.flatten fns in - (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings, fns), true + (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings), true | None -> normalize_expr ?guard:None node_id info map expr, false) else if has_inductive && lhs_arity = rhs_arity then @@ -919,24 +906,23 @@ and normalize_contract info map node_id items = (* Get new identifiers for LHS *) let new_tis = List.map (fun (p, id, e) -> (p, StringMap.find id info.interpretation, e)) tis in - GhostVars (pos, GhostVarDec(pos2, new_tis), nexpr), union (union gids1 gids2) gids3, warnings, fns, StringMap.empty + GhostVars (pos, GhostVarDec(pos2, new_tis), nexpr), union (union gids1 gids2) gids3, warnings, StringMap.empty | AssumptionVars decl -> - AssumptionVars decl, empty (), [], [], StringMap.empty + AssumptionVars decl, empty (), [], StringMap.empty in interpretation := StringMap.merge union_keys !interpretation interpretation'; result := nitem :: !result; gids := union !gids gids'; warnings := !warnings @ warnings'; - fns := !fns @ fns'; done; - !result, !gids, !warnings, !fns + !result, !gids, !warnings and normalize_equation node_id info map = function | Assert (pos, expr) -> - let nexpr, map, warnings, fns = abstract_expr true node_id info map true expr in - A.Assert (pos, nexpr), map, warnings, fns + let nexpr, map, warnings = abstract_expr true node_id info map true expr in + A.Assert (pos, nexpr), map, warnings | Equation (pos, lhs, expr) -> (* Need to track array indexes of the left hand side if there are any *) let items = match lhs with | A.StructDef (_, items) -> items in @@ -970,21 +956,20 @@ and normalize_equation node_id info map = function (fun acc v -> acc || StringMap.mem v info.inductive_variables) false in - let (nexpr, gids1, warnings, fns), expanded = ( + let (nexpr, gids1, warnings), expanded = ( if has_inductive && lhs_arity <> rhs_arity then (match StringMap.choose_opt info.inductive_variables with | Some (ivar, ty) -> let size = extract_array_size ty in let expanded_expr = expand_node_calls_in_place info ivar size expr in - let exprs, gids, warnings, fns = split4 (List.init lhs_arity + let exprs, gids, warnings = split3 (List.init lhs_arity (fun i -> let info = { info with local_group_projection = i } in normalize_expr node_id info map expanded_expr)) in let gids = List.fold_left (fun acc g -> union g acc) (empty ()) gids in let warnings = List.flatten warnings in - let fns = List.flatten fns in - (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings, fns), true + (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings), true | None -> normalize_expr node_id info map expr, false) else if has_inductive && lhs_arity = rhs_arity then let expanded_expr = List.fold_left @@ -1007,7 +992,7 @@ and normalize_equation node_id info map = function { (empty ()) with expanded_variables = StringSet.of_list ids } else empty () in - Equation (pos, lhs, nexpr), union gids1 gids2, warnings, fns + Equation (pos, lhs, nexpr), union gids1 gids2, warnings and rename_id info = function | A.Ident (pos, id) -> @@ -1017,9 +1002,9 @@ and rename_id info = function | _ -> assert false and abstract_expr ?guard force node_id info map is_ghost expr = - let nexpr, gids1, warnings, fns = normalize_expr node_id ?guard info map expr in + let nexpr, gids1, warnings = normalize_expr node_id ?guard info map expr in if should_not_abstract force nexpr then - nexpr, gids1, warnings, fns + nexpr, gids1, warnings else let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in @@ -1028,7 +1013,7 @@ and abstract_expr ?guard force node_id info map is_ghost expr = else Chk.infer_type_expr info.context expr |> unwrap in let iexpr, gids2 = mk_fresh_local force info pos is_ghost ivars ty nexpr in - iexpr, union gids1 gids2, warnings, fns + iexpr, union gids1 gids2, warnings and expand_node_call info expr var count = let ty = Chk.infer_type_expr info.context expr |> unwrap in @@ -1067,9 +1052,9 @@ and combine_args_with_const info args flags = and normalize_expr ?guard node_id info map = let abstract_node_arg ?guard force is_const info map expr = - let nexpr, gids1, warnings, fns = normalize_expr ?guard node_id info map expr in + let nexpr, gids1, warnings = normalize_expr ?guard node_id info map expr in if should_not_abstract force nexpr then - nexpr, gids1, warnings, fns + nexpr, gids1, warnings else let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in @@ -1078,7 +1063,7 @@ and normalize_expr ?guard node_id info map = else Chk.infer_type_expr info.context expr |> unwrap in let iexpr, gids2 = mk_fresh_node_arg_local info pos is_const ivars ty nexpr in - iexpr, union gids1 gids2, warnings, [] + iexpr, union gids1 gids2, warnings in function (* ************************************************************************ *) (* Node calls *) @@ -1087,87 +1072,85 @@ and normalize_expr ?guard node_id info map = let flags = StringMap.find id info.node_is_input_const in let cond = A.Const (Lib.dummy_pos, A.True) in let restart = A.Const (Lib.dummy_pos, A.False) in - let nargs, gids1, warnings, fns = normalize_list + let nargs, gids1, warnings = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids2 = mk_fresh_call info id map pos cond restart nargs None in - nexpr, union gids1 gids2, warnings, fns + nexpr, union gids1 gids2, warnings | Condact (pos, cond, restart, id, args, defaults) -> let flags = StringMap.find id info.node_is_input_const in - let ncond, gids1, warnings1, fns1 = if AH.expr_is_true cond then cond, empty (), [], [] + let ncond, gids1, warnings1 = if AH.expr_is_true cond then cond, empty (), [] else abstract_expr ?guard true node_id info map false cond in - let nrestart, gids2, warnings2, fns2 = if AH.expr_is_const restart then restart, empty (), [], [] + let nrestart, gids2, warnings2 = if AH.expr_is_const restart then restart, empty (), [] else abstract_expr ?guard true node_id info map false restart - in let nargs, gids3, warnings3, fns3 = normalize_list + in let nargs, gids3, warnings3 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in - let ndefaults, gids4, warnings4, fns4 = normalize_list (normalize_expr ?guard node_id info map) defaults in + let ndefaults, gids4, warnings4 = normalize_list (normalize_expr ?guard node_id info map) defaults in let nexpr, gids5 = mk_fresh_call info id map pos ncond nrestart nargs (Some ndefaults) in let gids = union_list [gids1; gids2; gids3; gids4; gids5] in let warnings = warnings1 @ warnings2 @ warnings3 @ warnings4 in - let fns = fns1 @ fns2 @ fns3 @ fns4 in - nexpr, gids, warnings, fns + nexpr, gids, warnings | RestartEvery (pos, id, args, restart) -> let flags = StringMap.find id info.node_is_input_const in let cond = A.Const (dummy_pos, A.True) in - let nrestart, gids1, warnings1, fns1 = if AH.expr_is_const restart then restart, empty (), [], [] + let nrestart, gids1, warnings1 = if AH.expr_is_const restart then restart, empty (), [] else abstract_expr ?guard true node_id info map false restart - in let nargs, gids2, warnings2, fns2 = normalize_list + in let nargs, gids2, warnings2 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids3 = mk_fresh_call info id map pos cond nrestart nargs None in let gids = union_list [gids1; gids2; gids3] in - nexpr, gids, warnings1 @ warnings2, fns1 @ fns2 + nexpr, gids, warnings1 @ warnings2 | Merge (pos, clock_id, cases) -> let normalize' info map ?guard = function | clock_value, A.Activate (pos, id, cond, restart, args) -> let flags = StringMap.find id info.node_is_input_const in - let ncond, gids1, warnings1, fns1 = if AH.expr_is_true cond then cond, empty (), [], [] + let ncond, gids1, warnings1 = if AH.expr_is_true cond then cond, empty (), [] else abstract_expr ?guard false node_id info map false cond in - let nrestart, gids2 , warnings2, fns2 = if AH.expr_is_const restart then restart, empty (), [], [] + let nrestart, gids2 , warnings2 = if AH.expr_is_const restart then restart, empty (), [] else abstract_expr ?guard false node_id info map false restart in - let nargs, gids3, warnings3, fns3 = normalize_list + let nargs, gids3, warnings3 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids4 = mk_fresh_call info id map pos ncond nrestart nargs None in let gids = union_list [gids1; gids2; gids3; gids4] in let warnings = warnings1 @ warnings2 @ warnings3 in - (clock_value, nexpr), gids, warnings, fns1 @ fns2 @ fns3 + (clock_value, nexpr), gids, warnings | clock_value, A.Call (pos, id, args) -> let flags = StringMap.find id info.node_is_input_const in let cond_expr = match HString.string_of_hstring clock_value with | "true" -> A.Ident (pos, clock_id) | "false" -> A.UnaryOp (pos, A.Not, A.Ident (pos, clock_id)) | _ -> A.CompOp (pos, A.Eq, A.Ident (pos, clock_id), A.Ident (pos, clock_value)) - in let ncond, gids1, warnings1, fns1 = abstract_expr ?guard false node_id info map false cond_expr in + in let ncond, gids1, warnings1 = abstract_expr ?guard false node_id info map false cond_expr in let restart = A.Const (Lib.dummy_pos, A.False) in - let nargs, gids2, warnings2, fns2 = normalize_list + let nargs, gids2, warnings2 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in let nexpr, gids3 = mk_fresh_call info id map pos ncond restart nargs None in let gids = union_list [gids1; gids2; gids3] in let warnings = warnings1 @ warnings2 in - let fns = fns1 @ fns2 in - (clock_value, nexpr), gids, warnings, fns + (clock_value, nexpr), gids, warnings | clock_value, expr -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - (clock_value, nexpr), gids, warnings, fns - in let ncases, gids, warnings, fns = normalize_list (normalize' ?guard info map) cases in - Merge (pos, clock_id, ncases), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + (clock_value, nexpr), gids, warnings + in let ncases, gids, warnings = normalize_list (normalize' ?guard info map) cases in + Merge (pos, clock_id, ncases), gids, warnings (* ************************************************************************ *) (* Guarding and abstracting pres *) (* ************************************************************************ *) | Arrow (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard:(Some nexpr1) node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard:(Some nexpr1) node_id info map expr2 in let gids = union gids1 gids2 in let warnings = warnings1 @ warnings2 in - Arrow (pos, nexpr1, nexpr2), gids, warnings, fns1 @ fns2 + Arrow (pos, nexpr1, nexpr2), gids, warnings | Pre (pos1, ArrayIndex (pos2, expr1, expr2)) -> let expr = A.ArrayIndex (pos2, Pre (pos1, expr1), expr2) in normalize_expr ?guard node_id info map expr @@ -1177,7 +1160,7 @@ and normalize_expr ?guard node_id info map = (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in - let nexpr, gids1, warnings1, fns = abstract_expr ?guard:None false node_id info map false expr in + let nexpr, gids1, warnings1 = abstract_expr ?guard:None false node_id info map false expr in let guard, gids2, warnings2, previously_guarded = match guard with | Some guard -> guard, empty (), [], true | None -> @@ -1192,8 +1175,8 @@ and normalize_expr ?guard node_id info map = A.ArrayIndex (pos2, Pre (pos, expr1), expr2) | e -> Pre (pos, e) in - if previously_guarded then nexpr', gids, warnings, fns - else Arrow (pos, guard, nexpr'), gids, warnings, fns + if previously_guarded then nexpr', gids, warnings + else Arrow (pos, guard, nexpr'), gids, warnings (* ************************************************************************ *) (* Misc. abstractions *) (* ************************************************************************ *) @@ -1203,114 +1186,85 @@ and normalize_expr ?guard node_id info map = (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in - let nexpr, gids1, warnings, fns = normalize_expr ?guard node_id info map expr in + let nexpr, gids1, warnings = normalize_expr ?guard node_id info map expr in let ivars = info.inductive_variables in let iexpr, gids2= mk_fresh_array_ctor info pos ivars ty nexpr size_expr in - ArrayConstr (pos, iexpr, size_expr), union gids1 gids2, warnings, fns + ArrayConstr (pos, iexpr, size_expr), union gids1 gids2, warnings (* ************************************************************************ *) (* Variable renaming to ease handling contract scopes *) (* ************************************************************************ *) - | Ident _ as e -> rename_id info e, empty (), [], [] + | Ident _ as e -> rename_id info e, empty (), [] (* ************************************************************************ *) (* The remaining expr kinds are all just structurally recursive *) (* ************************************************************************ *) - | ModeRef _ as expr -> expr, empty (), [], [] + | ModeRef _ as expr -> expr, empty (), [] | RecordProject (pos, expr, i) -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - RecordProject (pos, nexpr, i), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + RecordProject (pos, nexpr, i), gids, warnings | TupleProject (pos, expr, i) -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - TupleProject (pos, nexpr, i), gids, warnings, fns - | Const _ as expr -> expr, empty (), [], [] + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + TupleProject (pos, nexpr, i), gids, warnings + | Const _ as expr -> expr, empty (), [] | UnaryOp (pos, op, expr) -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - UnaryOp (pos, op, nexpr), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + UnaryOp (pos, op, nexpr), gids, warnings | BinaryOp (pos, op, expr1, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - BinaryOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + BinaryOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | TernaryOp (pos, op, expr1, expr2, expr3) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - let nexpr3, gids3, warnings3, fns3 = normalize_expr ?guard node_id info map expr3 in + let nexpr1, gids1, warnings1= normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr3, gids3, warnings3 = normalize_expr ?guard node_id info map expr3 in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in - let fns = fns1 @ fns2 @ fns3 in - TernaryOp (pos, op, nexpr1, nexpr2, nexpr3), gids, warnings, fns + TernaryOp (pos, op, nexpr1, nexpr2, nexpr3), gids, warnings | NArityOp (pos, op, expr_list) -> - let nexpr_list, gids, warnings, fns = normalize_list + let nexpr_list, gids, warnings = normalize_list (normalize_expr ?guard node_id info map) expr_list in - NArityOp (pos, op, nexpr_list), gids, warnings, fns + NArityOp (pos, op, nexpr_list), gids, warnings | ConvOp (pos, op, expr) -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - ConvOp (pos, op, nexpr), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + ConvOp (pos, op, nexpr), gids, warnings | CompOp (pos, op, expr1, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - CompOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 - | ChooseOp (pos, (_, id, ty), expr) -> - let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in - let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in - let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in - let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in - let ctx = Ctx.add_ty info.context id ty in - let info = { info with context = ctx } in - let inputs = List.map (fun input -> (pos, input, Ctx.lookup_ty ctx input, A.ClockTrue)) inputs in - let inputs = List.map (fun (p, inp, opt, cl) -> match opt with Some ty -> p, inp, ty, cl, false | None -> assert false) inputs in - let name = mk_fresh_fn_name () in - let map = StringMap.add name (empty ()) map in - let generated_fn = - A.FuncDecl (span, - (name, true, [], inputs, - [Lib.dummy_pos, id, ty, A.ClockTrue], [], [], Some contract)) - in - let cond = A.Const (dummy_pos, A.True) in - let restart = A.Const (Lib.dummy_pos, A.False) in - let nargs, gids1, warnings, fns = normalize_list - (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) - (combine_args_with_const info inputs_call [false]) - in - let nexpr, gids2 = mk_fresh_call info name map pos cond restart nargs None in - let (normalized_fn, map, warnings2, fns2) = normalize_declaration info map generated_fn in - let normalized_fn = match normalized_fn with - | Some normalized_fn -> normalized_fn - | None -> assert false in - nexpr, union gids1 gids2, warnings @ warnings2, normalized_fn :: fns @ fns2 + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + CompOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 + | ChooseOp _ -> assert false (* desugared earlier in pipeline *) | RecordExpr (pos, id, id_expr_list) -> let normalize' info map ?guard (id, expr) = - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - (id, nexpr), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + (id, nexpr), gids, warnings in - let nid_expr_list, gids, warnings, fns = normalize_list + let nid_expr_list, gids, warnings = normalize_list (normalize' ?guard info map) id_expr_list in - RecordExpr (pos, id, nid_expr_list), gids, warnings, fns + RecordExpr (pos, id, nid_expr_list), gids, warnings | GroupExpr (pos, kind, expr_list) -> - let nexpr_list, gids, warnings, fns = normalize_list + let nexpr_list, gids, warnings = normalize_list (normalize_expr ?guard node_id info map) expr_list in - GroupExpr (pos, kind, nexpr_list), gids, warnings, fns + GroupExpr (pos, kind, nexpr_list), gids, warnings | StructUpdate (pos, expr1, i, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - StructUpdate (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + StructUpdate (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2 | ArraySlice (pos, expr1, (expr2, expr3)) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - let nexpr3, gids3, warnings3, fns3 = normalize_expr ?guard node_id info map expr3 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr3, gids3, warnings3 = normalize_expr ?guard node_id info map expr3 in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in - let fns = fns1 @ fns2 @ fns3 in - ArraySlice (pos, nexpr1, (nexpr2, nexpr3)), gids, warnings, fns + ArraySlice (pos, nexpr1, (nexpr2, nexpr3)), gids, warnings | ArrayIndex (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - ArrayIndex (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + ArrayIndex (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | ArrayConcat (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - ArrayConcat (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + ArrayConcat (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | Quantifier (pos, kind, vars, expr) -> let ctx = List.fold_left Ctx.union info.context (List.map (fun (_, i, ty) -> Ctx.singleton_ty i ty) vars) @@ -1319,33 +1273,32 @@ and normalize_expr ?guard node_id info map = info with context = ctx; quantified_variables = info.quantified_variables @ vars } in - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - Quantifier (pos, kind, vars, nexpr), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + Quantifier (pos, kind, vars, nexpr), gids, warnings | When (pos, expr, clock_expr) -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - When (pos, nexpr, clock_expr), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + When (pos, nexpr, clock_expr), gids, warnings | Current (pos, expr) -> - let nexpr, gids, warnings, fns = normalize_expr ?guard node_id info map expr in - Current (pos, nexpr), gids, warnings, fns + let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + Current (pos, nexpr), gids, warnings | Activate (pos, id, expr1, expr2, expr_list) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - let nexpr_list, gids3, warnings3, fns3 = normalize_list + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr_list, gids3, warnings3 = normalize_list (normalize_expr ?guard node_id info map) expr_list in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in - let fns = fns1 @ fns2 @ fns3 in - Activate (pos, id, nexpr1, nexpr2, nexpr_list), gids, warnings, fns + Activate (pos, id, nexpr1, nexpr2, nexpr_list), gids, warnings | Fby (pos, expr1, i, expr2) -> - let nexpr1, gids1, warnings1, fns1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2, fns2 = normalize_expr ?guard node_id info map expr2 in - Fby (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2, fns1 @ fns2 + let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + Fby (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2 | CallParam (pos, id, type_list, expr_list) -> - let nexpr_list, gids, warnings, fns = normalize_list + let nexpr_list, gids, warnings = normalize_list (normalize_expr ?guard node_id info map) expr_list in - CallParam (pos, id, type_list, nexpr_list), gids, warnings, fns + CallParam (pos, id, type_list, nexpr_list), gids, warnings and expand_node_calls_in_place info var count expr = let r = expand_node_calls_in_place info var count in diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml new file mode 100644 index 000000000..71a6398b2 --- /dev/null +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -0,0 +1,203 @@ +(* This file is part of the Kind 2 model checker. + + Copyright (c) 2022 by the Board of Trustees of the University of Iowa + + Licensed under the Apache License, Version 2.0 (the "License"); you + may not use this file except in compliance with the License. You + may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied. See the License for the specific language governing + permissions and limitations under the License. + *) + +module A = LustreAst +module Ctx = TypeCheckerContext +module Chk = LustreTypeChecker +module AH = LustreAstHelpers + +(* [i] is module state used to guarantee newly created identifiers are unique *) +let i = ref 0 + +(* This looks unsafe, but we only apply unwrap when we know from earlier stages + in the pipeline that an error is not possible. *) + let unwrap result = match result with + | Ok r -> r + | Error _ -> assert false + +let mk_fresh_fn_name () = + i := !i + 1; + let prefix = HString.mk_hstring (string_of_int !i) in + let name = HString.concat2 (HString.mk_hstring "@desugar") prefix in + name + +let rec desugar_expr ctx = function + | A.ChooseOp (pos, (_, id, ty), expr) -> + let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in + let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in + let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in + let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in + let ctx = Ctx.add_ty ctx id ty in + let inputs = List.map (fun input -> (pos, input, Ctx.lookup_ty ctx input, A.ClockTrue)) inputs in + let inputs = List.map (fun (p, inp, opt, cl) -> match opt with + | Some ty -> p, inp, ty, cl, false + | None -> assert false + ) inputs in + let name = mk_fresh_fn_name () in + let generated_node = + A.NodeDecl (span, + (name, true, [], inputs, + [Lib.dummy_pos, id, ty, A.ClockTrue], [], [], Some contract)) + in + A.Call(pos, name, inputs_call), [generated_node] + + | Ident _ as e -> e, [] + | ModeRef (_, _) as e -> e, [] + | Const (_, _) as e -> e, [] + | RecordProject (pos, e, idx) -> + let e, gen_nodes = desugar_expr ctx e in + RecordProject (pos, e, idx), gen_nodes + | TupleProject (pos, e, idx) -> + let e, gen_nodes = desugar_expr ctx e in + TupleProject (pos, e, idx), gen_nodes + | UnaryOp (pos, op, e) -> + let e, gen_nodes = desugar_expr ctx e in + UnaryOp (pos, op, e), gen_nodes + | BinaryOp (pos, op, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + BinaryOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 + | TernaryOp (pos, op, e1, e2, e3) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + let e3, gen_nodes3 = desugar_expr ctx e3 in + TernaryOp (pos, op, e1, e2, e3), gen_nodes1 @ gen_nodes2 @ gen_nodes3 + | NArityOp (pos, op, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + NArityOp (pos, op, expr_list), List.flatten gen_nodes + | ConvOp (pos, op, e) -> + let e, gen_nodes = desugar_expr ctx e in + ConvOp (pos, op, e), gen_nodes + | CompOp (pos, op, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + CompOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 + | RecordExpr (pos, ident, expr_list) -> + let id_list, exprs_gen_nodes = + List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split + in + let expr_list, gen_nodes = List.split exprs_gen_nodes in + RecordExpr (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes + | GroupExpr (pos, kind, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + GroupExpr (pos, kind, expr_list), List.flatten gen_nodes + | StructUpdate (pos, e1, idx, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + StructUpdate (pos, e1, idx, e2), gen_nodes1 @ gen_nodes2 + | ArrayConstr (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + ArrayConstr (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | ArraySlice (pos, e1, (e2, e3)) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + let e3, gen_nodes3 = desugar_expr ctx e3 in + ArraySlice (pos, e1, (e2, e3)), gen_nodes1 @ gen_nodes2 @ gen_nodes3 + | ArrayIndex (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + ArrayIndex (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | ArrayConcat (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + ArrayConcat (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | Quantifier (pos, kind, idents, e) -> + let e, gen_nodes = desugar_expr ctx e in + Quantifier (pos, kind, idents, e), gen_nodes + | When (pos, e, clock) -> + let e, gen_nodes = desugar_expr ctx e in + When (pos, e, clock), gen_nodes + | Current (pos, e) -> + let e, gen_nodes = desugar_expr ctx e in + Current (pos, e), gen_nodes + | Condact (pos, e1, e2, id, expr_list1, expr_list2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + let expr_list1, gen_nodes3 = List.map (desugar_expr ctx) expr_list1 |> List.split in + let expr_list2, gen_nodes4 = List.map (desugar_expr ctx) expr_list2 |> List.split in + Condact (pos, e1, e2, id, expr_list1, expr_list2), gen_nodes1 @ gen_nodes2 @ + List.flatten gen_nodes3 @ List.flatten gen_nodes4 + | Activate (pos, ident, e1, e2, expr_list) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + Activate (pos, ident, e1, e2, expr_list), gen_nodes1 @ gen_nodes2 + | Merge (pos, ident, expr_list) -> + let id_list, exprs_gen_nodes = + List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split + in + let expr_list, gen_nodes = List.split exprs_gen_nodes in + Merge (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes + | RestartEvery (pos, ident, expr_list, e) -> + let expr_list, gen_nodes1 = List.map (desugar_expr ctx) expr_list |> List.split in + let e, gen_nodes2 = desugar_expr ctx e in + RestartEvery (pos, ident, expr_list, e), List.flatten gen_nodes1 @ gen_nodes2 + | Pre (pos, e) -> + let e, gen_nodes = desugar_expr ctx e in + Pre (pos, e), gen_nodes + | Fby (pos, e1, i, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + Fby (pos, e1, i, e2), gen_nodes1 @ gen_nodes2 + | Arrow (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + Arrow (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | Call (pos, id, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + Call (pos, id, expr_list), List.flatten gen_nodes + | CallParam (pos, id, types, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + CallParam (pos, id, types, expr_list), List.flatten gen_nodes + +let rec desugar_node_item ctx ni = + match ni with + | A.Body (Equation (pos, lhs, rhs)) -> + let rhs, gen_nodes = desugar_expr ctx rhs in + A.Body (Equation (pos, lhs, rhs)), gen_nodes + | IfBlock (pos, cond, nis1, nis2) -> + let nis1, gen_nodes1 = List.map (desugar_node_item ctx) nis1 |> List.split in + let nis2, gen_nodes2 = List.map (desugar_node_item ctx) nis2 |> List.split in + A.IfBlock (pos, cond, nis1, nis2), List.flatten gen_nodes1 @ List.flatten gen_nodes2 + | FrameBlock (pos, vars, nes, nis) -> + let nes = List.map (fun x -> A.Body x) nes in + let nes, gen_nodes1 = List.map (desugar_node_item ctx) nes |> List.split in + let nes = List.map (fun ne -> match ne with + | A.Body (A.Equation _ as eq) -> eq + | _ -> assert false (*!! CHECK ON THIS !!*) + ) nes in + let nis, gen_nodes2 = List.map (desugar_node_item ctx) nis |> List.split in + FrameBlock(pos, vars, nes, nis), List.flatten gen_nodes1 @ List.flatten gen_nodes2 + | AnnotMain _ + | AnnotProperty _ + | Body (Assert _) -> ni, [] + +let desugar_choose_ops ctx decls = + let decls = + List.map (fun decl -> + match decl with + | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> + let ctx = Chk.get_node_ctx ctx d |> unwrap in + let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in + (List.flatten gen_nodes) @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))] + | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> + let ctx = Chk.get_node_ctx ctx d |> unwrap in + let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in + (List.flatten gen_nodes) @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))] + | _ -> [decl] + ) decls |> List.flatten in + decls diff --git a/src/lustre/lustreDesugarChooseOps.mli b/src/lustre/lustreDesugarChooseOps.mli new file mode 100644 index 000000000..545ca42e5 --- /dev/null +++ b/src/lustre/lustreDesugarChooseOps.mli @@ -0,0 +1,20 @@ +(* This file is part of the Kind 2 model checker. + + Copyright (c) 2023 by the Board of Trustees of the University of Iowa + + Licensed under the Apache License, Version 2.0 (the "License"); you + may not use this file except in compliance with the License. You + may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied. See the License for the specific language governing + permissions and limitations under the License. + *) + + (** @author Rob Lorch *) + +val desugar_choose_ops : TypeCheckerContext.tc_context -> LustreAst.declaration list -> LustreAst.declaration list diff --git a/src/lustre/lustreInput.ml b/src/lustre/lustreInput.ml index 3ace5a1ac..546fd8552 100644 --- a/src/lustre/lustreInput.ml +++ b/src/lustre/lustreInput.ml @@ -44,6 +44,7 @@ module LDI = LustreDesugarIfBlocks module LDF = LustreDesugarFrameBlocks module RMA = LustreRemoveMultAssign module LAD = LustreArrayDependencies +module LDN = LustreDesugarChooseOps type error = [ | `LustreArrayDependencies of Lib.position * LustreArrayDependencies.error_kind @@ -158,27 +159,30 @@ let type_check declarations = (* Step 7. type check nodes and contracts *) let* global_ctx = TC.type_check_infer_nodes_and_contracts inlined_ctx sorted_node_contract_decls in - (* Step 8. Remove multiple assignment from if blocks and frame blocks *) + (* Step 8. Desugar nondeterministic choice operators *) + let sorted_node_contract_decls = LDN.desugar_choose_ops global_ctx sorted_node_contract_decls in + + (* Step 9. Remove multiple assignment from if blocks and frame blocks *) let sorted_node_contract_decls, gids = RMA.remove_mult_assign global_ctx sorted_node_contract_decls in - (* Step 9. Desugar imperative if block to ITEs *) + (* Step 10. Desugar imperative if block to ITEs *) let* (sorted_node_contract_decls, gids) = (LDI.desugar_if_blocks global_ctx sorted_node_contract_decls gids) in - (* Step 10. Desugar frame blocks by adding node equations and guarding oracles. *) + (* Step 11. Desugar frame blocks by adding node equations and guarding oracles. *) let* (sorted_node_contract_decls, warnings) = LDF.desugar_frame_blocks sorted_node_contract_decls in - (* Step 11. Inline constants in node equations *) + (* Step 12. Inline constants in node equations *) let* (inlined_global_ctx, const_inlined_nodes_and_contracts) = IC.inline_constants global_ctx sorted_node_contract_decls in - (* Step 12. Check that inductive array equations are well-founded *) + (* Step 13. Check that inductive array equations are well-founded *) let* _ = LAD.check_inductive_array_dependencies inlined_global_ctx node_summary const_inlined_nodes_and_contracts in - (* Step 13. Infer tighter subrange constraints with abstract interpretation *) + (* Step 14. Infer tighter subrange constraints with abstract interpretation *) let abstract_interp_ctx = LIA.interpret_program inlined_global_ctx gids const_inlined_nodes_and_contracts in - (* Step 14. Normalize AST: guard pres, abstract to locals where appropriate *) + (* Step 15. Normalize AST: guard pres, abstract to locals where appropriate *) let* (normalized_nodes_and_contracts, gids, warnings2, inlined_global_ctx) = LAN.normalize inlined_global_ctx abstract_interp_ctx const_inlined_nodes_and_contracts gids in From 8aa459dc97cee89925702b972f11a77888cada46 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 29 Mar 2023 17:11:44 -0500 Subject: [PATCH 07/51] Clean up --- src/lustre/lustreAstNormalizer.ml | 7 ------- src/lustre/lustreInput.ml | 1 + 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index df52ac721..641146afb 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -203,13 +203,6 @@ type info = { local_group_projection : int } -let split4 quads = - let xs = List.map (fun (x, _, _, _) -> x) quads in - let ys = List.map (fun (_, y, _, _) -> y) quads in - let zs = List.map (fun (_, _, z, _) -> z) quads in - let ns = List.map (fun (_, _, _, n) -> n) quads in - xs, ys, zs, ns - let split3 triples = let xs = List.map (fun (x, _, _) -> x) triples in let ys = List.map (fun (_, y, _) -> y) triples in diff --git a/src/lustre/lustreInput.ml b/src/lustre/lustreInput.ml index 546fd8552..e90f0b077 100644 --- a/src/lustre/lustreInput.ml +++ b/src/lustre/lustreInput.ml @@ -187,6 +187,7 @@ let type_check declarations = LAN.normalize inlined_global_ctx abstract_interp_ctx const_inlined_nodes_and_contracts gids in + (*!! debug printing !!*) List.iter (LA.pp_print_declaration Format.std_formatter) normalized_nodes_and_contracts; TypeCheckerContext.pp_print_tc_context Format.std_formatter inlined_global_ctx; GeneratedIdentifiers.StringMap.iter (fun _ -> (LAN.pp_print_generated_identifiers Format.std_formatter)) gids; From 31609dc24c9b0a910c360b13d92a84933c8f72a1 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 30 Mar 2023 08:40:13 -0500 Subject: [PATCH 08/51] Debug chooseop desugaring --- src/lustre/lustreAstDependencies.mli | 2 + src/lustre/lustreDesugarChooseOps.ml | 402 ++++++++++++++------------ src/lustre/lustreDesugarChooseOps.mli | 4 +- src/lustre/lustreInput.ml | 7 +- 4 files changed, 223 insertions(+), 192 deletions(-) diff --git a/src/lustre/lustreAstDependencies.mli b/src/lustre/lustreAstDependencies.mli index 59a077fc5..3cbbfd14e 100644 --- a/src/lustre/lustreAstDependencies.mli +++ b/src/lustre/lustreAstDependencies.mli @@ -64,6 +64,8 @@ val error_message: error_kind -> string type node_summary = ((int list) IntMap.t) IMap.t +val pp_print_node_summary: Format.formatter -> int list IntMap.t IMap.t -> unit + val sort_globals: LA.t -> (LA.t, [> error]) result (** Returns a topological order to resolve forward references of globals. This step processes 1. type declarations, and 2. constant declarations *) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 71a6398b2..14a575c81 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -15,189 +15,221 @@ permissions and limitations under the License. *) -module A = LustreAst -module Ctx = TypeCheckerContext -module Chk = LustreTypeChecker -module AH = LustreAstHelpers + module A = LustreAst + module Ctx = TypeCheckerContext + module Chk = LustreTypeChecker + module AH = LustreAstHelpers + module AD = LustreAstDependencies + + (* [i] is module state used to guarantee newly created identifiers are unique *) + let i = ref 0 + + (* This looks unsafe, but we only apply unwrap when we know from earlier stages + in the pipeline that an error is not possible. *) + let unwrap result = match result with + | Ok r -> r + | Error _ -> assert false + + let mk_fresh_fn_name () = + i := !i + 1; + let prefix = HString.mk_hstring (string_of_int !i) in + let name = HString.concat2 (HString.mk_hstring "@desugar") prefix in + name + + let update_node_summary node_summary gen_nodes = + List.fold_left (fun node_summary node -> match node with + | A.NodeDecl (_, (node_id, _, _, _, outputs, _, _, _)) -> + (AD.IMap.add node_id + ((List.fold_left + (fun (op_idx, m) _ -> (op_idx+1, AD.IntMap.add op_idx [] m)) + (0, AD.IntMap.empty) + outputs) + |> snd)) + node_summary + | _ -> assert false + ) node_summary gen_nodes + + let rec desugar_expr ctx = function + | A.ChooseOp (pos, (_, id, ty), expr) -> + let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in + let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in + let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in + let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in + let ctx = Ctx.add_ty ctx id ty in + let inputs = List.map (fun input -> (pos, input, Ctx.lookup_ty ctx input, A.ClockTrue)) inputs in + let inputs = List.map (fun (p, inp, opt, cl) -> match opt with + | Some ty -> p, inp, ty, cl, false + | None -> assert false + ) inputs in + let name = mk_fresh_fn_name () in + let generated_node = + A.NodeDecl (span, + (name, true, [], inputs, + [Lib.dummy_pos, id, ty, A.ClockTrue], [], [], Some contract)) + in + A.Call(pos, name, inputs_call), [generated_node] + + | Ident _ as e -> e, [] + | ModeRef (_, _) as e -> e, [] + | Const (_, _) as e -> e, [] + | RecordProject (pos, e, idx) -> + let e, gen_nodes = desugar_expr ctx e in + RecordProject (pos, e, idx), gen_nodes + | TupleProject (pos, e, idx) -> + let e, gen_nodes = desugar_expr ctx e in + TupleProject (pos, e, idx), gen_nodes + | UnaryOp (pos, op, e) -> + let e, gen_nodes = desugar_expr ctx e in + UnaryOp (pos, op, e), gen_nodes + | BinaryOp (pos, op, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + BinaryOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 + | TernaryOp (pos, op, e1, e2, e3) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + let e3, gen_nodes3 = desugar_expr ctx e3 in + TernaryOp (pos, op, e1, e2, e3), gen_nodes1 @ gen_nodes2 @ gen_nodes3 + | NArityOp (pos, op, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + NArityOp (pos, op, expr_list), List.flatten gen_nodes + | ConvOp (pos, op, e) -> + let e, gen_nodes = desugar_expr ctx e in + ConvOp (pos, op, e), gen_nodes + | CompOp (pos, op, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + CompOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 + | RecordExpr (pos, ident, expr_list) -> + let id_list, exprs_gen_nodes = + List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split + in + let expr_list, gen_nodes = List.split exprs_gen_nodes in + RecordExpr (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes + | GroupExpr (pos, kind, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + GroupExpr (pos, kind, expr_list), List.flatten gen_nodes + | StructUpdate (pos, e1, idx, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + StructUpdate (pos, e1, idx, e2), gen_nodes1 @ gen_nodes2 + | ArrayConstr (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + ArrayConstr (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | ArraySlice (pos, e1, (e2, e3)) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + let e3, gen_nodes3 = desugar_expr ctx e3 in + ArraySlice (pos, e1, (e2, e3)), gen_nodes1 @ gen_nodes2 @ gen_nodes3 + | ArrayIndex (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + ArrayIndex (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | ArrayConcat (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + ArrayConcat (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | Quantifier (pos, kind, idents, e) -> + let e, gen_nodes = desugar_expr ctx e in + Quantifier (pos, kind, idents, e), gen_nodes + | When (pos, e, clock) -> + let e, gen_nodes = desugar_expr ctx e in + When (pos, e, clock), gen_nodes + | Current (pos, e) -> + let e, gen_nodes = desugar_expr ctx e in + Current (pos, e), gen_nodes + | Condact (pos, e1, e2, id, expr_list1, expr_list2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + let expr_list1, gen_nodes3 = List.map (desugar_expr ctx) expr_list1 |> List.split in + let expr_list2, gen_nodes4 = List.map (desugar_expr ctx) expr_list2 |> List.split in + Condact (pos, e1, e2, id, expr_list1, expr_list2), gen_nodes1 @ gen_nodes2 @ + List.flatten gen_nodes3 @ List.flatten gen_nodes4 + | Activate (pos, ident, e1, e2, expr_list) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + Activate (pos, ident, e1, e2, expr_list), gen_nodes1 @ gen_nodes2 + | Merge (pos, ident, expr_list) -> + let id_list, exprs_gen_nodes = + List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split + in + let expr_list, gen_nodes = List.split exprs_gen_nodes in + Merge (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes + | RestartEvery (pos, ident, expr_list, e) -> + let expr_list, gen_nodes1 = List.map (desugar_expr ctx) expr_list |> List.split in + let e, gen_nodes2 = desugar_expr ctx e in + RestartEvery (pos, ident, expr_list, e), List.flatten gen_nodes1 @ gen_nodes2 + | Pre (pos, e) -> + let e, gen_nodes = desugar_expr ctx e in + Pre (pos, e), gen_nodes + | Fby (pos, e1, i, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + Fby (pos, e1, i, e2), gen_nodes1 @ gen_nodes2 + | Arrow (pos, e1, e2) -> + let e1, gen_nodes1 = desugar_expr ctx e1 in + let e2, gen_nodes2 = desugar_expr ctx e2 in + Arrow (pos, e1, e2), gen_nodes1 @ gen_nodes2 + | Call (pos, id, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + Call (pos, id, expr_list), List.flatten gen_nodes + | CallParam (pos, id, types, expr_list) -> + let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + CallParam (pos, id, types, expr_list), List.flatten gen_nodes + + let rec desugar_node_item ctx ni = + match ni with + | A.Body (Equation (pos, lhs, rhs)) -> + let rhs, gen_nodes = desugar_expr ctx rhs in + A.Body (Equation (pos, lhs, rhs)), gen_nodes + | IfBlock (pos, cond, nis1, nis2) -> + let nis1, gen_nodes1 = List.map (desugar_node_item ctx) nis1 |> List.split in + let nis2, gen_nodes2 = List.map (desugar_node_item ctx) nis2 |> List.split in + A.IfBlock (pos, cond, nis1, nis2), List.flatten gen_nodes1 @ List.flatten gen_nodes2 + | FrameBlock (pos, vars, nes, nis) -> + let nes = List.map (fun x -> A.Body x) nes in + let nes, gen_nodes1 = List.map (desugar_node_item ctx) nes |> List.split in + let nes = List.map (fun ne -> match ne with + | A.Body (A.Equation _ as eq) -> eq + | _ -> assert false (*!! CHECK ON THIS !!*) + ) nes in + let nis, gen_nodes2 = List.map (desugar_node_item ctx) nis |> List.split in + FrameBlock(pos, vars, nes, nis), List.flatten gen_nodes1 @ List.flatten gen_nodes2 + | AnnotMain _ + | AnnotProperty _ + | Body (Assert _) -> ni, [] + + let desugar_choose_ops ctx node_summary decls = + let decls, node_summary = + List.fold_left (fun (decls, summary) decl -> + match decl with + | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> + let ctx = Chk.get_node_ctx ctx d |> unwrap in + let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in + let gen_nodes = List.flatten gen_nodes in + let summary = update_node_summary summary gen_nodes in + decls @ gen_nodes @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], + summary + | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> + let ctx = Chk.get_node_ctx ctx d |> unwrap in + let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in + let gen_nodes = List.flatten gen_nodes in + let summary = update_node_summary summary gen_nodes in + decls @ gen_nodes @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], + summary + | _ -> decl :: decls, node_summary + ) ([], node_summary) decls in + (* Update global context to include generated nodes *) + let ctx = List.fold_left (fun ctx decl -> + match decl with + | A.NodeDecl (_, (id, _, _, ip, op, _, _, _)) -> + let fun_ty = (Chk.build_node_fun_ty Lib.dummy_pos ctx ip op) |> unwrap in + (Ctx.add_ty_node ctx id fun_ty) + | A.FuncDecl (_, (id, _, _, ip, op, _, _, _)) -> + let fun_ty = (Chk.build_node_fun_ty Lib.dummy_pos ctx ip op) |> unwrap in + (Ctx.add_ty_node ctx id fun_ty) + | _ -> ctx + ) ctx decls in + decls, ctx, node_summary -(* [i] is module state used to guarantee newly created identifiers are unique *) -let i = ref 0 - -(* This looks unsafe, but we only apply unwrap when we know from earlier stages - in the pipeline that an error is not possible. *) - let unwrap result = match result with - | Ok r -> r - | Error _ -> assert false - -let mk_fresh_fn_name () = - i := !i + 1; - let prefix = HString.mk_hstring (string_of_int !i) in - let name = HString.concat2 (HString.mk_hstring "@desugar") prefix in - name - -let rec desugar_expr ctx = function - | A.ChooseOp (pos, (_, id, ty), expr) -> - let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in - let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in - let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in - let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in - let ctx = Ctx.add_ty ctx id ty in - let inputs = List.map (fun input -> (pos, input, Ctx.lookup_ty ctx input, A.ClockTrue)) inputs in - let inputs = List.map (fun (p, inp, opt, cl) -> match opt with - | Some ty -> p, inp, ty, cl, false - | None -> assert false - ) inputs in - let name = mk_fresh_fn_name () in - let generated_node = - A.NodeDecl (span, - (name, true, [], inputs, - [Lib.dummy_pos, id, ty, A.ClockTrue], [], [], Some contract)) - in - A.Call(pos, name, inputs_call), [generated_node] - - | Ident _ as e -> e, [] - | ModeRef (_, _) as e -> e, [] - | Const (_, _) as e -> e, [] - | RecordProject (pos, e, idx) -> - let e, gen_nodes = desugar_expr ctx e in - RecordProject (pos, e, idx), gen_nodes - | TupleProject (pos, e, idx) -> - let e, gen_nodes = desugar_expr ctx e in - TupleProject (pos, e, idx), gen_nodes - | UnaryOp (pos, op, e) -> - let e, gen_nodes = desugar_expr ctx e in - UnaryOp (pos, op, e), gen_nodes - | BinaryOp (pos, op, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - BinaryOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 - | TernaryOp (pos, op, e1, e2, e3) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - let e3, gen_nodes3 = desugar_expr ctx e3 in - TernaryOp (pos, op, e1, e2, e3), gen_nodes1 @ gen_nodes2 @ gen_nodes3 - | NArityOp (pos, op, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in - NArityOp (pos, op, expr_list), List.flatten gen_nodes - | ConvOp (pos, op, e) -> - let e, gen_nodes = desugar_expr ctx e in - ConvOp (pos, op, e), gen_nodes - | CompOp (pos, op, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - CompOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 - | RecordExpr (pos, ident, expr_list) -> - let id_list, exprs_gen_nodes = - List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split - in - let expr_list, gen_nodes = List.split exprs_gen_nodes in - RecordExpr (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes - | GroupExpr (pos, kind, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in - GroupExpr (pos, kind, expr_list), List.flatten gen_nodes - | StructUpdate (pos, e1, idx, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - StructUpdate (pos, e1, idx, e2), gen_nodes1 @ gen_nodes2 - | ArrayConstr (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - ArrayConstr (pos, e1, e2), gen_nodes1 @ gen_nodes2 - | ArraySlice (pos, e1, (e2, e3)) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - let e3, gen_nodes3 = desugar_expr ctx e3 in - ArraySlice (pos, e1, (e2, e3)), gen_nodes1 @ gen_nodes2 @ gen_nodes3 - | ArrayIndex (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - ArrayIndex (pos, e1, e2), gen_nodes1 @ gen_nodes2 - | ArrayConcat (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - ArrayConcat (pos, e1, e2), gen_nodes1 @ gen_nodes2 - | Quantifier (pos, kind, idents, e) -> - let e, gen_nodes = desugar_expr ctx e in - Quantifier (pos, kind, idents, e), gen_nodes - | When (pos, e, clock) -> - let e, gen_nodes = desugar_expr ctx e in - When (pos, e, clock), gen_nodes - | Current (pos, e) -> - let e, gen_nodes = desugar_expr ctx e in - Current (pos, e), gen_nodes - | Condact (pos, e1, e2, id, expr_list1, expr_list2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - let expr_list1, gen_nodes3 = List.map (desugar_expr ctx) expr_list1 |> List.split in - let expr_list2, gen_nodes4 = List.map (desugar_expr ctx) expr_list2 |> List.split in - Condact (pos, e1, e2, id, expr_list1, expr_list2), gen_nodes1 @ gen_nodes2 @ - List.flatten gen_nodes3 @ List.flatten gen_nodes4 - | Activate (pos, ident, e1, e2, expr_list) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - Activate (pos, ident, e1, e2, expr_list), gen_nodes1 @ gen_nodes2 - | Merge (pos, ident, expr_list) -> - let id_list, exprs_gen_nodes = - List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split - in - let expr_list, gen_nodes = List.split exprs_gen_nodes in - Merge (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes - | RestartEvery (pos, ident, expr_list, e) -> - let expr_list, gen_nodes1 = List.map (desugar_expr ctx) expr_list |> List.split in - let e, gen_nodes2 = desugar_expr ctx e in - RestartEvery (pos, ident, expr_list, e), List.flatten gen_nodes1 @ gen_nodes2 - | Pre (pos, e) -> - let e, gen_nodes = desugar_expr ctx e in - Pre (pos, e), gen_nodes - | Fby (pos, e1, i, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - Fby (pos, e1, i, e2), gen_nodes1 @ gen_nodes2 - | Arrow (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - Arrow (pos, e1, e2), gen_nodes1 @ gen_nodes2 - | Call (pos, id, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in - Call (pos, id, expr_list), List.flatten gen_nodes - | CallParam (pos, id, types, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in - CallParam (pos, id, types, expr_list), List.flatten gen_nodes - -let rec desugar_node_item ctx ni = - match ni with - | A.Body (Equation (pos, lhs, rhs)) -> - let rhs, gen_nodes = desugar_expr ctx rhs in - A.Body (Equation (pos, lhs, rhs)), gen_nodes - | IfBlock (pos, cond, nis1, nis2) -> - let nis1, gen_nodes1 = List.map (desugar_node_item ctx) nis1 |> List.split in - let nis2, gen_nodes2 = List.map (desugar_node_item ctx) nis2 |> List.split in - A.IfBlock (pos, cond, nis1, nis2), List.flatten gen_nodes1 @ List.flatten gen_nodes2 - | FrameBlock (pos, vars, nes, nis) -> - let nes = List.map (fun x -> A.Body x) nes in - let nes, gen_nodes1 = List.map (desugar_node_item ctx) nes |> List.split in - let nes = List.map (fun ne -> match ne with - | A.Body (A.Equation _ as eq) -> eq - | _ -> assert false (*!! CHECK ON THIS !!*) - ) nes in - let nis, gen_nodes2 = List.map (desugar_node_item ctx) nis |> List.split in - FrameBlock(pos, vars, nes, nis), List.flatten gen_nodes1 @ List.flatten gen_nodes2 - | AnnotMain _ - | AnnotProperty _ - | Body (Assert _) -> ni, [] - -let desugar_choose_ops ctx decls = - let decls = - List.map (fun decl -> - match decl with - | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> - let ctx = Chk.get_node_ctx ctx d |> unwrap in - let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in - (List.flatten gen_nodes) @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))] - | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> - let ctx = Chk.get_node_ctx ctx d |> unwrap in - let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in - (List.flatten gen_nodes) @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))] - | _ -> [decl] - ) decls |> List.flatten in - decls diff --git a/src/lustre/lustreDesugarChooseOps.mli b/src/lustre/lustreDesugarChooseOps.mli index 545ca42e5..48ccb24ac 100644 --- a/src/lustre/lustreDesugarChooseOps.mli +++ b/src/lustre/lustreDesugarChooseOps.mli @@ -17,4 +17,6 @@ (** @author Rob Lorch *) -val desugar_choose_ops : TypeCheckerContext.tc_context -> LustreAst.declaration list -> LustreAst.declaration list +val desugar_choose_ops : TypeCheckerContext.tc_context -> LustreAstDependencies.node_summary -> + LustreAst.declaration list -> + LustreAst.declaration list * TypeCheckerContext.tc_context * LustreAstDependencies.node_summary diff --git a/src/lustre/lustreInput.ml b/src/lustre/lustreInput.ml index e90f0b077..5880a6512 100644 --- a/src/lustre/lustreInput.ml +++ b/src/lustre/lustreInput.ml @@ -160,7 +160,7 @@ let type_check declarations = let* global_ctx = TC.type_check_infer_nodes_and_contracts inlined_ctx sorted_node_contract_decls in (* Step 8. Desugar nondeterministic choice operators *) - let sorted_node_contract_decls = LDN.desugar_choose_ops global_ctx sorted_node_contract_decls in + let sorted_node_contract_decls, global_ctx, node_summary = LDN.desugar_choose_ops global_ctx node_summary sorted_node_contract_decls in (* Step 9. Remove multiple assignment from if blocks and frame blocks *) let sorted_node_contract_decls, gids = RMA.remove_mult_assign global_ctx sorted_node_contract_decls in @@ -186,11 +186,6 @@ let type_check declarations = let* (normalized_nodes_and_contracts, gids, warnings2, inlined_global_ctx) = LAN.normalize inlined_global_ctx abstract_interp_ctx const_inlined_nodes_and_contracts gids in - - (*!! debug printing !!*) - List.iter (LA.pp_print_declaration Format.std_formatter) normalized_nodes_and_contracts; - TypeCheckerContext.pp_print_tc_context Format.std_formatter inlined_global_ctx; - GeneratedIdentifiers.StringMap.iter (fun _ -> (LAN.pp_print_generated_identifiers Format.std_formatter)) gids; Res.ok (inlined_global_ctx, gids, From 9e0463a5e5e8653ccd9517d3d2744576586d516a Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 30 Mar 2023 09:39:51 -0500 Subject: [PATCH 09/51] Update syntax and desugaring --- src/lustre/lustreDesugarChooseOps.ml | 2 +- src/lustre/lustreLexer.mll | 1 + src/lustre/lustreParser.messages | 8 ++++---- src/lustre/lustreParser.mly | 3 ++- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 14a575c81..60b8ceb73 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -33,7 +33,7 @@ let mk_fresh_fn_name () = i := !i + 1; let prefix = HString.mk_hstring (string_of_int !i) in - let name = HString.concat2 (HString.mk_hstring "@desugar") prefix in + let name = HString.concat2 (HString.mk_hstring "@ChooseOp") prefix in name let update_node_summary node_summary gen_nodes = diff --git a/src/lustre/lustreLexer.mll b/src/lustre/lustreLexer.mll index 901002d60..6ed324da6 100644 --- a/src/lustre/lustreLexer.mll +++ b/src/lustre/lustreLexer.mll @@ -436,6 +436,7 @@ rule token = parse | '=' { EQUALS } | ':' { COLON } | ',' { COMMA } + | '|' { MID } | '[' { LSQBRACKET } | ']' { RSQBRACKET } | '(' { LPAREN } diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 52283412c..644364b95 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2705,11 +2705,11 @@ one_expr: CHOOSE LCURLYBRACKET XOR -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA XOR +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID XOR -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA DECIMAL WEAKLY +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID DECIMAL WEAKLY @@ -2733,10 +2733,10 @@ main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCUR -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA XOR +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID XOR -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME COMMA DECIMAL WEAKLY +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID DECIMAL WEAKLY diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index a9aaa3262..304b4bbf0 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -36,6 +36,7 @@ let mk_span start_pos end_pos = %token EQUALS %token COLON %token COMMA +%token MID %token LSQBRACKET %token RSQBRACKET %token LPAREN @@ -845,7 +846,7 @@ pexpr(Q): { A.TernaryOp (mk_pos $startpos, A.Ite, e1, e2, e3) } (* Choose operation *) - | CHOOSE; LCURLYBRACKET; id = typed_ident; COMMA; e = pexpr(Q); RCURLYBRACKET + | CHOOSE; LCURLYBRACKET; id = typed_ident; MID; e = pexpr(Q); RCURLYBRACKET { A.ChooseOp (mk_pos $startpos, id, e) } (* Recursive node call *) From 8e459c372f7023218207c35826fd0fa24f19890d Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Mon, 3 Apr 2023 14:11:28 -0500 Subject: [PATCH 10/51] Update nondeterministic choice generated node name --- src/lustre/lustreDesugarChooseOps.ml | 10 ++++++---- src/utils/lib.ml | 21 +++++++++++++++++++++ src/utils/lib.mli | 3 +++ 3 files changed, 30 insertions(+), 4 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 60b8ceb73..b42f32788 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -30,10 +30,12 @@ | Ok r -> r | Error _ -> assert false - let mk_fresh_fn_name () = + let mk_fresh_fn_name pos = i := !i + 1; - let prefix = HString.mk_hstring (string_of_int !i) in - let name = HString.concat2 (HString.mk_hstring "@ChooseOp") prefix in + let pos = Lib.string_of_t Lib.pp_print_position2 pos in + let pos = HString.mk_hstring pos in + let name = HString.concat2 (HString.mk_hstring "choose") (HString.mk_hstring "@") in + let name = HString.concat2 name pos in name let update_node_summary node_summary gen_nodes = @@ -61,7 +63,7 @@ | Some ty -> p, inp, ty, cl, false | None -> assert false ) inputs in - let name = mk_fresh_fn_name () in + let name = mk_fresh_fn_name pos in let generated_node = A.NodeDecl (span, (name, true, [], inputs, diff --git a/src/utils/lib.ml b/src/utils/lib.ml index af3464265..85fdeadc0 100644 --- a/src/utils/lib.ml +++ b/src/utils/lib.ml @@ -1230,6 +1230,27 @@ let pp_print_position ppf ( fprintf ppf "%s:%d:%d" fname pos_lnum pos_cnum +(* Pretty-print a position with alternate formatting *) +let pp_print_position2 ppf ( + { pos_fname; pos_lnum; pos_cnum } as pos +) = + + if pos = dummy_pos then + + fprintf ppf "(unknown)" + + else if pos_lnum = 0 && pos_cnum = -1 then + + fprintf ppf "%s" pos_fname + + else + + let fname = + if pos_fname = "" then "(stdin)" else pos_fname + in + + fprintf ppf "%s/l%d,c%d" fname pos_lnum pos_cnum + (** Pretty-print line and column *) let pp_print_line_and_column ppf { pos_lnum; pos_cnum } = diff --git a/src/utils/lib.mli b/src/utils/lib.mli index 525906450..dafc68269 100644 --- a/src/utils/lib.mli +++ b/src/utils/lib.mli @@ -474,6 +474,9 @@ val is_dummy_pos : position -> bool (** Pretty-print a position *) val pp_print_position : Format.formatter -> position -> unit +(** Pretty-print a position with alternate formatting *) +val pp_print_position2 : Format.formatter -> position -> unit + (** Pretty-print line and column *) val pp_print_line_and_column : Format.formatter -> position -> unit From b1f73db3b7b9e234685d35fe569a1869dd2e71b6 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Mon, 3 Apr 2023 14:21:21 -0500 Subject: [PATCH 11/51] Update syntax for array concatenation to not overlap with choice operator --- src/lustre/lustreLexer.mll | 2 +- src/lustre/lustreParser.messages | 52 ++++++++++---------- src/lustre/lustreParser.mly | 6 +-- tests/regression/success/test_const_prop.lus | 2 +- 4 files changed, 32 insertions(+), 30 deletions(-) diff --git a/src/lustre/lustreLexer.mll b/src/lustre/lustreLexer.mll index 6ed324da6..8c4adc6c1 100644 --- a/src/lustre/lustreLexer.mll +++ b/src/lustre/lustreLexer.mll @@ -449,7 +449,6 @@ rule token = parse | '}' { RCURLYBRACKET } | '}' { RCURLYBRACKET } | ".%" { DOTPERCENT } - | '|' { PIPE } | "<<" { LPARAMBRACKET } | ">>" { RPARAMBRACKET } | "=>" { IMPL } @@ -461,6 +460,7 @@ rule token = parse | "<>" { NEQ } | '-' { MINUS } | '+' { PLUS } + | "++" { CONCAT } | '/' { DIV } | '*' { MULT } | "->" { ARROW } diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 644364b95..eed789434 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -952,15 +952,7 @@ one_expr: WEAKLY OR XOR Syntax Error! -one_expr: WEAKLY PIPE TRUE WEAKLY -Syntax Error! - -one_expr: WEAKLY PIPE XOR - -Syntax Error! Possible diagnosis includes: -1. A missing delimiter such as a semicolon at the end of the statement. -2. Malformed arithmetic expression one_expr: WEAKLY PLUS TRUE WEAKLY @@ -2216,13 +2208,7 @@ main: NODE WEAKLY LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT WEAKLY OR XOR Syntax Error! -main: NODE WEAKLY LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT WEAKLY PIPE TRUE WEAKLY - -Syntax Error! - -main: NODE WEAKLY LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT WEAKLY PIPE XOR -Syntax Error! main: NODE WEAKLY LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT WEAKLY PLUS TRUE WEAKLY @@ -2699,44 +2685,60 @@ Syntax Error! one_expr: CHOOSE XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID XOR - +Syntax Error! + +one_expr: ASSUME CONCAT XOR + +Syntax Error! + +one_expr: ASSUME CONCAT DECIMAL WEAKLY + +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID DECIMAL WEAKLY - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME SEMICOLON - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID DECIMAL WEAKLY - +Syntax Error! + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME CONCAT XOR + +Syntax Error! + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME CONCAT DECIMAL WEAKLY + +Syntax Error! diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index 304b4bbf0..b24f4e1f6 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -81,7 +81,7 @@ let mk_span start_pos end_pos = (* %token ARRAY *) %token CARET %token DOTDOT -%token PIPE +%token CONCAT (* Token for constant declarations *) %token CONST @@ -194,7 +194,7 @@ let mk_span start_pos end_pos = (* Priorities and associativity of operators, lowest first *) %nonassoc UINT8 UINT16 UINT32 UINT64 INT8 INT16 INT32 INT64 %nonassoc WHEN CURRENT -%left PIPE +%left CONCAT %nonassoc ELSE %right ARROW %nonassoc prec_forall prec_exists @@ -778,7 +778,7 @@ pexpr(Q): { A.RecordExpr (mk_pos $startpos, t, f) } (* An array concatenation *) - | e1 = pexpr(Q); PIPE; e2 = pexpr(Q) { A.ArrayConcat (mk_pos $startpos, e1, e2) } + | e1 = pexpr(Q); CONCAT; e2 = pexpr(Q) { A.ArrayConcat (mk_pos $startpos, e1, e2) } (* with operator for updating fields of a structure (not quantified) *) | LPAREN; diff --git a/tests/regression/success/test_const_prop.lus b/tests/regression/success/test_const_prop.lus index c1d3212d3..47b4d2b2a 100644 --- a/tests/regression/success/test_const_prop.lus +++ b/tests/regression/success/test_const_prop.lus @@ -10,7 +10,7 @@ const r2 = 1.1 + r1; const t:int = t1; -- should inline to 1 const t2 = c < t; -- should inline to false -const arr = false ^ 3 | true ^ 3; +const arr = false ^ 3 ++ true ^ 3; const arr2 = (3+c) ^ 3; -- should inline to 4 const f = arr[fc]; -- should not inline From 29b082cd8bbc9b754709fe56bb3b6d8bf784c4fa Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 4 Apr 2023 12:35:01 -0500 Subject: [PATCH 12/51] Update lexing and parsing for choose operator --- src/lustre/lustreLexer.mll | 3 +- src/lustre/lustreParser.messages | 32 ++++++++++++++------ src/lustre/lustreParser.mly | 11 +++---- tests/regression/success/test_const_prop.lus | 2 +- 4 files changed, 30 insertions(+), 18 deletions(-) diff --git a/src/lustre/lustreLexer.mll b/src/lustre/lustreLexer.mll index 8c4adc6c1..6a9005960 100644 --- a/src/lustre/lustreLexer.mll +++ b/src/lustre/lustreLexer.mll @@ -436,7 +436,6 @@ rule token = parse | '=' { EQUALS } | ':' { COLON } | ',' { COMMA } - | '|' { MID } | '[' { LSQBRACKET } | ']' { RSQBRACKET } | '(' { LPAREN } @@ -460,7 +459,7 @@ rule token = parse | "<>" { NEQ } | '-' { MINUS } | '+' { PLUS } - | "++" { CONCAT } + | '|' { BAR } | '/' { DIV } | '*' { MULT } | "->" { ARROW } diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index eed789434..ef96f0fa6 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2683,6 +2683,20 @@ main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET IF ASSUME THEN MAI Syntax Error! + + + + + + + + + + + + + + one_expr: CHOOSE XOR Syntax Error! @@ -2691,19 +2705,19 @@ one_expr: CHOOSE LCURLYBRACKET XOR Syntax Error! -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID XOR +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR XOR Syntax Error! -one_expr: ASSUME CONCAT XOR +one_expr: ASSUME BAR XOR Syntax Error! -one_expr: ASSUME CONCAT DECIMAL WEAKLY +one_expr: ASSUME BAR DECIMAL WEAKLY Syntax Error! -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID DECIMAL WEAKLY +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR DECIMAL WEAKLY Syntax Error! @@ -2715,7 +2729,7 @@ one_expr: CHOOSE LCURLYBRACKET ASSUME COLON XOR Syntax Error! -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME SEMICOLON +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME WHEN Syntax Error! @@ -2727,18 +2741,18 @@ main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCUR Syntax Error! -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID XOR +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR XOR Syntax Error! -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME MID DECIMAL WEAKLY +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR DECIMAL WEAKLY Syntax Error! -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME CONCAT XOR +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME BAR XOR Syntax Error! -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME CONCAT DECIMAL WEAKLY +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME BAR DECIMAL WEAKLY Syntax Error! diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index b24f4e1f6..b5b36cd96 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -36,7 +36,6 @@ let mk_span start_pos end_pos = %token EQUALS %token COLON %token COMMA -%token MID %token LSQBRACKET %token RSQBRACKET %token LPAREN @@ -81,7 +80,7 @@ let mk_span start_pos end_pos = (* %token ARRAY *) %token CARET %token DOTDOT -%token CONCAT +%token BAR (* Token for constant declarations *) %token CONST @@ -194,7 +193,7 @@ let mk_span start_pos end_pos = (* Priorities and associativity of operators, lowest first *) %nonassoc UINT8 UINT16 UINT32 UINT64 INT8 INT16 INT32 INT64 %nonassoc WHEN CURRENT -%left CONCAT +%left BAR %nonassoc ELSE %right ARROW %nonassoc prec_forall prec_exists @@ -778,7 +777,7 @@ pexpr(Q): { A.RecordExpr (mk_pos $startpos, t, f) } (* An array concatenation *) - | e1 = pexpr(Q); CONCAT; e2 = pexpr(Q) { A.ArrayConcat (mk_pos $startpos, e1, e2) } + | e1 = pexpr(Q); BAR; e2 = pexpr(Q) { A.ArrayConcat (mk_pos $startpos, e1, e2) } (* with operator for updating fields of a structure (not quantified) *) | LPAREN; @@ -846,8 +845,8 @@ pexpr(Q): { A.TernaryOp (mk_pos $startpos, A.Ite, e1, e2, e3) } (* Choose operation *) - | CHOOSE; LCURLYBRACKET; id = typed_ident; MID; e = pexpr(Q); RCURLYBRACKET - { A.ChooseOp (mk_pos $startpos, id, e) } + | CHOOSE; LCURLYBRACKET; id = typed_ident; BAR; e = pexpr(Q); RCURLYBRACKET + { A.ChooseOp (mk_pos $startpos, id, e) } (* Recursive node call *) | WITH; e1 = pexpr(Q); THEN; e2 = pexpr(Q); ELSE; e3 = pexpr(Q) diff --git a/tests/regression/success/test_const_prop.lus b/tests/regression/success/test_const_prop.lus index 47b4d2b2a..c1d3212d3 100644 --- a/tests/regression/success/test_const_prop.lus +++ b/tests/regression/success/test_const_prop.lus @@ -10,7 +10,7 @@ const r2 = 1.1 + r1; const t:int = t1; -- should inline to 1 const t2 = c < t; -- should inline to false -const arr = false ^ 3 ++ true ^ 3; +const arr = false ^ 3 | true ^ 3; const arr2 = (3+c) ^ 3; -- should inline to 4 const f = arr[fc]; -- should not inline From 84eecffd1296564bc65350ae7f9ee25b9e343f4c Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 25 May 2023 15:52:09 -0400 Subject: [PATCH 13/51] Update naming of generated function for choose op --- src/lustre/lustreDesugarChooseOps.ml | 119 ++++++++++++++------------- src/utils/lib.ml | 22 ----- src/utils/lib.mli | 3 - 3 files changed, 60 insertions(+), 84 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index b42f32788..731a937d2 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -30,13 +30,14 @@ | Ok r -> r | Error _ -> assert false - let mk_fresh_fn_name pos = + let mk_fresh_fn_name pos node_name = i := !i + 1; - let pos = Lib.string_of_t Lib.pp_print_position2 pos in - let pos = HString.mk_hstring pos in - let name = HString.concat2 (HString.mk_hstring "choose") (HString.mk_hstring "@") in + let node_name = HString.concat2 node_name (HString.mk_hstring ".") in + let pos = Lib.string_of_t Lib.pp_print_line_and_column pos in + let pos = String.sub pos 1 (String.length pos - 2) |> HString.mk_hstring in + let name = (HString.mk_hstring "choose_") in let name = HString.concat2 name pos in - name + HString.concat2 node_name name let update_node_summary node_summary gen_nodes = List.fold_left (fun node_summary node -> match node with @@ -51,7 +52,7 @@ | _ -> assert false ) node_summary gen_nodes - let rec desugar_expr ctx = function + let rec desugar_expr ctx node_name = function | A.ChooseOp (pos, (_, id, ty), expr) -> let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in @@ -63,7 +64,7 @@ | Some ty -> p, inp, ty, cl, false | None -> assert false ) inputs in - let name = mk_fresh_fn_name pos in + let name = mk_fresh_fn_name pos node_name in let generated_node = A.NodeDecl (span, (name, true, [], inputs, @@ -75,128 +76,128 @@ | ModeRef (_, _) as e -> e, [] | Const (_, _) as e -> e, [] | RecordProject (pos, e, idx) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in RecordProject (pos, e, idx), gen_nodes | TupleProject (pos, e, idx) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in TupleProject (pos, e, idx), gen_nodes | UnaryOp (pos, op, e) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in UnaryOp (pos, op, e), gen_nodes | BinaryOp (pos, op, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in BinaryOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 | TernaryOp (pos, op, e1, e2, e3) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - let e3, gen_nodes3 = desugar_expr ctx e3 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in + let e3, gen_nodes3 = desugar_expr ctx node_name e3 in TernaryOp (pos, op, e1, e2, e3), gen_nodes1 @ gen_nodes2 @ gen_nodes3 | NArityOp (pos, op, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + let expr_list, gen_nodes = List.map (desugar_expr ctx node_name) expr_list |> List.split in NArityOp (pos, op, expr_list), List.flatten gen_nodes | ConvOp (pos, op, e) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in ConvOp (pos, op, e), gen_nodes | CompOp (pos, op, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in CompOp (pos, op, e1, e2), gen_nodes1 @ gen_nodes2 | RecordExpr (pos, ident, expr_list) -> let id_list, exprs_gen_nodes = - List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split + List.map (fun (i, e) -> (i, (desugar_expr ctx node_name) e)) expr_list |> List.split in let expr_list, gen_nodes = List.split exprs_gen_nodes in RecordExpr (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes | GroupExpr (pos, kind, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + let expr_list, gen_nodes = List.map (desugar_expr ctx node_name) expr_list |> List.split in GroupExpr (pos, kind, expr_list), List.flatten gen_nodes | StructUpdate (pos, e1, idx, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in StructUpdate (pos, e1, idx, e2), gen_nodes1 @ gen_nodes2 | ArrayConstr (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in ArrayConstr (pos, e1, e2), gen_nodes1 @ gen_nodes2 | ArraySlice (pos, e1, (e2, e3)) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - let e3, gen_nodes3 = desugar_expr ctx e3 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in + let e3, gen_nodes3 = desugar_expr ctx node_name e3 in ArraySlice (pos, e1, (e2, e3)), gen_nodes1 @ gen_nodes2 @ gen_nodes3 | ArrayIndex (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in ArrayIndex (pos, e1, e2), gen_nodes1 @ gen_nodes2 | ArrayConcat (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in ArrayConcat (pos, e1, e2), gen_nodes1 @ gen_nodes2 | Quantifier (pos, kind, idents, e) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in Quantifier (pos, kind, idents, e), gen_nodes | When (pos, e, clock) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in When (pos, e, clock), gen_nodes | Current (pos, e) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in Current (pos, e), gen_nodes | Condact (pos, e1, e2, id, expr_list1, expr_list2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in - let expr_list1, gen_nodes3 = List.map (desugar_expr ctx) expr_list1 |> List.split in - let expr_list2, gen_nodes4 = List.map (desugar_expr ctx) expr_list2 |> List.split in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in + let expr_list1, gen_nodes3 = List.map (desugar_expr ctx node_name) expr_list1 |> List.split in + let expr_list2, gen_nodes4 = List.map (desugar_expr ctx node_name) expr_list2 |> List.split in Condact (pos, e1, e2, id, expr_list1, expr_list2), gen_nodes1 @ gen_nodes2 @ List.flatten gen_nodes3 @ List.flatten gen_nodes4 | Activate (pos, ident, e1, e2, expr_list) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in Activate (pos, ident, e1, e2, expr_list), gen_nodes1 @ gen_nodes2 | Merge (pos, ident, expr_list) -> let id_list, exprs_gen_nodes = - List.map (fun (i, e) -> (i, (desugar_expr ctx) e)) expr_list |> List.split + List.map (fun (i, e) -> (i, (desugar_expr ctx node_name) e)) expr_list |> List.split in let expr_list, gen_nodes = List.split exprs_gen_nodes in Merge (pos, ident, List.combine id_list expr_list), List.flatten gen_nodes | RestartEvery (pos, ident, expr_list, e) -> - let expr_list, gen_nodes1 = List.map (desugar_expr ctx) expr_list |> List.split in - let e, gen_nodes2 = desugar_expr ctx e in + let expr_list, gen_nodes1 = List.map (desugar_expr ctx node_name) expr_list |> List.split in + let e, gen_nodes2 = desugar_expr ctx node_name e in RestartEvery (pos, ident, expr_list, e), List.flatten gen_nodes1 @ gen_nodes2 | Pre (pos, e) -> - let e, gen_nodes = desugar_expr ctx e in + let e, gen_nodes = desugar_expr ctx node_name e in Pre (pos, e), gen_nodes | Fby (pos, e1, i, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in Fby (pos, e1, i, e2), gen_nodes1 @ gen_nodes2 | Arrow (pos, e1, e2) -> - let e1, gen_nodes1 = desugar_expr ctx e1 in - let e2, gen_nodes2 = desugar_expr ctx e2 in + let e1, gen_nodes1 = desugar_expr ctx node_name e1 in + let e2, gen_nodes2 = desugar_expr ctx node_name e2 in Arrow (pos, e1, e2), gen_nodes1 @ gen_nodes2 | Call (pos, id, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + let expr_list, gen_nodes = List.map (desugar_expr ctx node_name) expr_list |> List.split in Call (pos, id, expr_list), List.flatten gen_nodes | CallParam (pos, id, types, expr_list) -> - let expr_list, gen_nodes = List.map (desugar_expr ctx) expr_list |> List.split in + let expr_list, gen_nodes = List.map (desugar_expr ctx node_name) expr_list |> List.split in CallParam (pos, id, types, expr_list), List.flatten gen_nodes - let rec desugar_node_item ctx ni = + let rec desugar_node_item ctx node_name ni = match ni with | A.Body (Equation (pos, lhs, rhs)) -> - let rhs, gen_nodes = desugar_expr ctx rhs in + let rhs, gen_nodes = desugar_expr ctx node_name rhs in A.Body (Equation (pos, lhs, rhs)), gen_nodes | IfBlock (pos, cond, nis1, nis2) -> - let nis1, gen_nodes1 = List.map (desugar_node_item ctx) nis1 |> List.split in - let nis2, gen_nodes2 = List.map (desugar_node_item ctx) nis2 |> List.split in + let nis1, gen_nodes1 = List.map (desugar_node_item ctx node_name) nis1 |> List.split in + let nis2, gen_nodes2 = List.map (desugar_node_item ctx node_name) nis2 |> List.split in A.IfBlock (pos, cond, nis1, nis2), List.flatten gen_nodes1 @ List.flatten gen_nodes2 | FrameBlock (pos, vars, nes, nis) -> let nes = List.map (fun x -> A.Body x) nes in - let nes, gen_nodes1 = List.map (desugar_node_item ctx) nes |> List.split in + let nes, gen_nodes1 = List.map (desugar_node_item ctx node_name) nes |> List.split in let nes = List.map (fun ne -> match ne with | A.Body (A.Equation _ as eq) -> eq | _ -> assert false (*!! CHECK ON THIS !!*) ) nes in - let nis, gen_nodes2 = List.map (desugar_node_item ctx) nis |> List.split in + let nis, gen_nodes2 = List.map (desugar_node_item ctx node_name) nis |> List.split in FrameBlock(pos, vars, nes, nis), List.flatten gen_nodes1 @ List.flatten gen_nodes2 | AnnotMain _ | AnnotProperty _ @@ -208,14 +209,14 @@ match decl with | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> let ctx = Chk.get_node_ctx ctx d |> unwrap in - let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in + let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in let gen_nodes = List.flatten gen_nodes in let summary = update_node_summary summary gen_nodes in decls @ gen_nodes @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], summary | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> let ctx = Chk.get_node_ctx ctx d |> unwrap in - let items, gen_nodes = List.map (desugar_node_item ctx) items |> List.split in + let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in let gen_nodes = List.flatten gen_nodes in let summary = update_node_summary summary gen_nodes in decls @ gen_nodes @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], diff --git a/src/utils/lib.ml b/src/utils/lib.ml index 85fdeadc0..dbab8b61b 100644 --- a/src/utils/lib.ml +++ b/src/utils/lib.ml @@ -1230,28 +1230,6 @@ let pp_print_position ppf ( fprintf ppf "%s:%d:%d" fname pos_lnum pos_cnum -(* Pretty-print a position with alternate formatting *) -let pp_print_position2 ppf ( - { pos_fname; pos_lnum; pos_cnum } as pos -) = - - if pos = dummy_pos then - - fprintf ppf "(unknown)" - - else if pos_lnum = 0 && pos_cnum = -1 then - - fprintf ppf "%s" pos_fname - - else - - let fname = - if pos_fname = "" then "(stdin)" else pos_fname - in - - fprintf ppf "%s/l%d,c%d" fname pos_lnum pos_cnum - - (** Pretty-print line and column *) let pp_print_line_and_column ppf { pos_lnum; pos_cnum } = diff --git a/src/utils/lib.mli b/src/utils/lib.mli index dafc68269..525906450 100644 --- a/src/utils/lib.mli +++ b/src/utils/lib.mli @@ -474,9 +474,6 @@ val is_dummy_pos : position -> bool (** Pretty-print a position *) val pp_print_position : Format.formatter -> position -> unit -(** Pretty-print a position with alternate formatting *) -val pp_print_position2 : Format.formatter -> position -> unit - (** Pretty-print line and column *) val pp_print_line_and_column : Format.formatter -> position -> unit From 4fa4f03c6a1a419ddbe21045211e2d8878fcb1f9 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 25 May 2023 16:18:22 -0400 Subject: [PATCH 14/51] Update user documentation for nondeterministic choice operator --- doc/usr/source/2_input/1_lustre.rst | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/doc/usr/source/2_input/1_lustre.rst b/doc/usr/source/2_input/1_lustre.rst index 7e49afe2a..de56c7abb 100644 --- a/doc/usr/source/2_input/1_lustre.rst +++ b/doc/usr/source/2_input/1_lustre.rst @@ -1032,11 +1032,13 @@ will also generate the two warnings as discussed in the previous paragraph. .. code-block:: none frame (y1, y2) - if cond - then - y1 = 0; - else - y2 = 1; + let + if cond + then + y1 = 0; + else + y2 = 1; + tel Restrictions ^^^^^^^^^^^^ @@ -1073,3 +1075,12 @@ cannot be placed within if statements or frame blocks. Since an initialization only defines a variable at the first timestep, it need not be stateful. Therefore, a frame block initialization cannot contain any ``pre`` or ``->`` operators. This restriction also ensures that initializations are never undefined. + +Nondeterministic choice operator +---------------------------------- +The expression ``choose { var: ty | expression }`` evaluates to a variable +``var`` that of type ``ty`` that satisfies ``expression``. For example, +``choose { y: int | y < 50 }`` nondeterminsitically evaluates to +some value less than 50. The body ``expression`` can +reference variable ``var`` as well as any inputs, outputs, or locals +that are currently in scope. \ No newline at end of file From 870b26f5a92b32e8db2c4f87b97cbd081d1632b9 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 25 May 2023 16:36:56 -0400 Subject: [PATCH 15/51] Add tests for choice op --- .../lustre/lustreTypeChecker/nondeterministic_choice.lus | 7 +++++++ tests/ounit/lustre/testLustreFrontend.ml | 4 ++++ tests/regression/success/choose_simple.lus | 9 +++++++++ 3 files changed, 20 insertions(+) create mode 100644 tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice.lus create mode 100644 tests/regression/success/choose_simple.lus diff --git a/tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice.lus b/tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice.lus new file mode 100644 index 000000000..31626128e --- /dev/null +++ b/tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice.lus @@ -0,0 +1,7 @@ +node main () returns (y: int); +let + y = choose { x: bool | x < 50 }; + + check y < 100; +tel; + diff --git a/tests/ounit/lustre/testLustreFrontend.ml b/tests/ounit/lustre/testLustreFrontend.ml index 8797860f6..395b97d19 100644 --- a/tests/ounit/lustre/testLustreFrontend.ml +++ b/tests/ounit/lustre/testLustreFrontend.ml @@ -583,6 +583,10 @@ let _ = run_test_tt_main ("frontend LustreTypeChecker error tests" >::: [ match load_file "./lustreTypeChecker/open_interval.lus" with | Error (`LustreTypeCheckerError (_, IntervalMustHaveBound)) -> true | _ -> false); + mk_test "test nondeterministic choice type error" (fun () -> + match load_file "./lustreTypeChecker/nondeterministic_choice.lus" with + | Error (`LustreTypeCheckerError (_, ExpectedType _)) -> true + | _ -> false); ]) (* *************************************************************************** *) diff --git a/tests/regression/success/choose_simple.lus b/tests/regression/success/choose_simple.lus new file mode 100644 index 000000000..9b4007996 --- /dev/null +++ b/tests/regression/success/choose_simple.lus @@ -0,0 +1,9 @@ +node main () returns (y: int); +var x2: int; +let + x2 = choose {x: int | x > 0 }; + y = choose { x: int | x + x2 < 50 }; + + check y < 100; +tel; + From a24f9168fbcd5de3f2f7d9eec2849981bd42ae0a Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 25 May 2023 16:38:57 -0400 Subject: [PATCH 16/51] Update printing choose op --- src/lustre/lustreAst.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lustre/lustreAst.ml b/src/lustre/lustreAst.ml index 3a560dca2..b370eef92 100644 --- a/src/lustre/lustreAst.ml +++ b/src/lustre/lustreAst.ml @@ -622,7 +622,7 @@ let rec pp_print_expr ppf = | ChooseOp (p, id, e) -> Format.fprintf ppf - "%achoose %a: %a" + "%achoose { %a | %a }" ppos p pp_print_typed_ident id pp_print_expr e From a1f219365c576cbd8fb2e251ac1ce38606528c42 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 25 May 2023 16:40:14 -0400 Subject: [PATCH 17/51] Clean up lustreParser.messages --- src/lustre/lustreParser.messages | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 2245c94d1..4834a7e9b 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2870,60 +2870,60 @@ Syntax Error! one_expr: CHOOSE XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR XOR - +Syntax Error! one_expr: ASSUME BAR XOR - +Syntax Error! one_expr: ASSUME BAR DECIMAL WEAKLY - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR DECIMAL WEAKLY - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON XOR - +Syntax Error! one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME WHEN - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR DECIMAL WEAKLY - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME BAR XOR - +Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME BAR DECIMAL WEAKLY - +Syntax Error! From 5d019c2035fd97a804ddec30f990ae55a2b8b48e Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Tue, 22 Aug 2023 09:56:04 -0500 Subject: [PATCH 18/51] Resolve conflict --- src/lustre/lustreAstNormalizer.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index d651a13c7..0268b7734 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -1176,7 +1176,7 @@ and combine_args_with_const info args flags = List.fold_left over_args_arity (0, []) (List.combine args output_arity) |> snd |> List.rev -and normalize_expr ?guard info map = +and normalize_expr ?guard node_id info map = let abstract_array_literal info expr nexpr = let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in @@ -1338,7 +1338,7 @@ and normalize_expr ?guard info map = ArrayConstr (pos, iexpr, size_expr), union gids1 gids2, warnings | GroupExpr (pos, ArrayExpr, expr_list) as expr -> let nexpr_list, gids1, warnings = normalize_list - (normalize_expr ?guard:None info map) + (normalize_expr ?guard:None node_id info map) expr_list in let nexpr = A.GroupExpr (pos, ArrayExpr, nexpr_list) in From fe47d2e63175932d3f6afb4ec781a6866385e742 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 22 Aug 2023 14:08:24 -0500 Subject: [PATCH 19/51] Update choose operator type checking --- src/lustre/lustreTypeChecker.ml | 8 ++++++-- tests/ounit/lustre/testLustreFrontend.ml | 4 ++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index 330e144dd..394db9182 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -443,7 +443,8 @@ let rec infer_type_expr: tc_context -> LA.expr -> (tc_type, [> error]) result (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in infer_type_expr extn_ctx e - | ChooseOp (_, (_, _, ty), _) -> + | ChooseOp (_, (_, _, ty), _) as e -> + check_type_expr ctx e ty >> R.ok ty (* Clock operators *) | LA.When (_, e, _) -> infer_type_expr ctx e @@ -645,7 +646,10 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul | ChooseOp (pos, (_, i ,ty), e) -> let extn_ctx = union ctx (singleton_ty i ty) in - check_type_expr extn_ctx e (Bool pos) + infer_type_expr extn_ctx e + >>= (function + | Bool _ -> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) + | ty -> type_error pos (ExpectedType ((Bool pos), ty))) (* Clock operators *) | When (_, e, _) -> check_type_expr ctx e exp_ty | Current (_, e) -> check_type_expr ctx e exp_ty diff --git a/tests/ounit/lustre/testLustreFrontend.ml b/tests/ounit/lustre/testLustreFrontend.ml index 395b97d19..f48af0baa 100644 --- a/tests/ounit/lustre/testLustreFrontend.ml +++ b/tests/ounit/lustre/testLustreFrontend.ml @@ -585,6 +585,10 @@ let _ = run_test_tt_main ("frontend LustreTypeChecker error tests" >::: [ | _ -> false); mk_test "test nondeterministic choice type error" (fun () -> match load_file "./lustreTypeChecker/nondeterministic_choice.lus" with + | Error (`LustreTypeCheckerError (_, ExpectedIntegerTypes _)) -> true + | _ -> false); + mk_test "test nondeterministic choice type error 2" (fun () -> + match load_file "./lustreTypeChecker/nondeterministic_choice_2.lus" with | Error (`LustreTypeCheckerError (_, ExpectedType _)) -> true | _ -> false); ]) From 02844cc8fb230af0ee7e8af3e5bbe51bc512c214 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 22 Aug 2023 14:17:45 -0500 Subject: [PATCH 20/51] Add test file --- .../lustre/lustreTypeChecker/nondeterministic_choice_2.lus | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice_2.lus diff --git a/tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice_2.lus b/tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice_2.lus new file mode 100644 index 000000000..952a29ddb --- /dev/null +++ b/tests/ounit/lustre/lustreTypeChecker/nondeterministic_choice_2.lus @@ -0,0 +1,6 @@ +node N(y: int) returns (z: int); +let + z = choose { x : int | 0 -> pre x + 1 }; + check z >= 0; + check true -> z > pre z; +tel \ No newline at end of file From e3860186714f4c4d332dd5dcfe938b4b4d4a1543 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Tue, 22 Aug 2023 15:22:47 -0500 Subject: [PATCH 21/51] Fix arrow operator type checking --- src/lustre/lustreTypeChecker.ml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index 394db9182..910b1d1de 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -144,8 +144,8 @@ let error_message kind = match kind with | IlltypedCall (ty1, ty2) -> "Node arguments at call expect to have type " ^ string_of_tc_type ty1 ^ " but found type " ^ string_of_tc_type ty2 | ExpectedFunctionType ty -> "Expected node type to be a function type, but found type " ^ string_of_tc_type ty - | IlltypedIdentifier (id, ty1, ty2) -> "Identifier: " ^ HString.string_of_hstring id - ^ " does not match expected type " ^ string_of_tc_type ty1 ^ " with inferred type " ^ string_of_tc_type ty2 + | IlltypedIdentifier (id, ty1, ty2) -> "Identifier '" ^ HString.string_of_hstring id + ^ "' does not match expected type " ^ string_of_tc_type ty1 ^ " with inferred type " ^ string_of_tc_type ty2 | UnificationFailed (ty1, ty2) -> "Cannot unify type " ^ string_of_tc_type ty1 ^ " with inferred type " ^ string_of_tc_type ty2 | ExpectedType (ty1, ty2) -> "Expected type " ^ string_of_tc_type ty1 ^ " but found type " ^ string_of_tc_type ty2 @@ -646,10 +646,8 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul | ChooseOp (pos, (_, i ,ty), e) -> let extn_ctx = union ctx (singleton_ty i ty) in - infer_type_expr extn_ctx e - >>= (function - | Bool _ -> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) - | ty -> type_error pos (ExpectedType ((Bool pos), ty))) + check_type_expr extn_ctx e (Bool pos) + >> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) (* Clock operators *) | When (_, e, _) -> check_type_expr ctx e exp_ty | Current (_, e) -> check_type_expr ctx e exp_ty @@ -681,8 +679,8 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul check_type_expr ctx e1 exp_ty >> check_type_expr ctx e2 exp_ty | Arrow (_, e1, e2) -> - infer_type_expr ctx e1 - >>= fun ty1 -> check_type_expr ctx e2 ty1 + check_type_expr ctx e1 exp_ty + >> check_type_expr ctx e2 exp_ty (* Node calls *) | Call (pos, i, args) -> From fa94022a7359861087f9f50162136b2e0844f3c9 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Tue, 22 Aug 2023 15:36:21 -0500 Subject: [PATCH 22/51] Update expected error in test --- tests/ounit/lustre/testLustreFrontend.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/ounit/lustre/testLustreFrontend.ml b/tests/ounit/lustre/testLustreFrontend.ml index f48af0baa..b0a8143ab 100644 --- a/tests/ounit/lustre/testLustreFrontend.ml +++ b/tests/ounit/lustre/testLustreFrontend.ml @@ -589,7 +589,7 @@ let _ = run_test_tt_main ("frontend LustreTypeChecker error tests" >::: [ | _ -> false); mk_test "test nondeterministic choice type error 2" (fun () -> match load_file "./lustreTypeChecker/nondeterministic_choice_2.lus" with - | Error (`LustreTypeCheckerError (_, ExpectedType _)) -> true + | Error (`LustreTypeCheckerError (_, UnificationFailed _)) -> true | _ -> false); ]) From 0d1f66b119f17b1e3e80182d107ddb9b0957850a Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 23 Aug 2023 14:06:48 -0500 Subject: [PATCH 23/51] Remove garbage code --- src/lustre/lustreNodeGen.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/lustre/lustreNodeGen.ml b/src/lustre/lustreNodeGen.ml index 9f4ec81c5..de4135885 100644 --- a/src/lustre/lustreNodeGen.ml +++ b/src/lustre/lustreNodeGen.ml @@ -2231,7 +2231,6 @@ and compile_declaration cstate gids ctx decl = let empty_map = ref (empty_identifier_maps None) in compile_const_decl cstate ctx empty_map [] const_decl | A.FuncDecl (_, (i, ext, [], inputs, outputs, locals, items, contract)) -> - print_endline (HString.string_of_hstring i); let gids = GI.StringMap.find i gids in compile_node_decl gids true cstate ctx i ext inputs outputs locals items contract | A.NodeDecl (_, (i, ext, [], inputs, outputs, locals, items, contract)) -> From 98162f061fbbaab53c464809e57fd010c337d827 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 23 Aug 2023 14:11:23 -0500 Subject: [PATCH 24/51] Update unreachable areas for ChooseOp in pattern matching --- src/lustre/lustreAbstractInterpretation.ml | 3 +-- src/lustre/lustreArrayDependencies.ml | 5 +---- src/lustre/lustreAstDependencies.mli | 2 -- src/lustre/lustreAstInlineConstants.ml | 2 +- src/lustre/lustreDesugarFrameBlocks.ml | 2 +- src/lustre/lustreNodeGen.ml | 2 +- 6 files changed, 5 insertions(+), 11 deletions(-) diff --git a/src/lustre/lustreAbstractInterpretation.ml b/src/lustre/lustreAbstractInterpretation.ml index a3b670a0b..954e887d0 100644 --- a/src/lustre/lustreAbstractInterpretation.ml +++ b/src/lustre/lustreAbstractInterpretation.ml @@ -503,8 +503,7 @@ and interpret_int_expr node_id ctx ty_ctx proj expr = | NArityOp _ -> assert false | ConvOp (_, _, e) -> interpret_int_expr node_id ctx ty_ctx proj e | CompOp _-> assert false - | ChooseOp (_, (_, _, ty), _) -> - extract_bounds_from_type ty + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) | RecordExpr _ -> assert false | GroupExpr (_, ExprList, es) -> ( let g = interpret_int_expr node_id ctx ty_ctx in diff --git a/src/lustre/lustreArrayDependencies.ml b/src/lustre/lustreArrayDependencies.ml index a4b2da818..dbd34dff4 100644 --- a/src/lustre/lustreArrayDependencies.ml +++ b/src/lustre/lustreArrayDependencies.ml @@ -199,10 +199,7 @@ and process_expr ind_vars ctx ns proj indices expr = vars in R.ok graph - | ChooseOp (_, (_, i, _), e) -> - let* graph = r e in - let graph = G.remove_vertex graph (i, [0]) - in R.ok graph + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) (* Clock operators *) | When (_, e, _) -> r e | Current (_, e) -> r e diff --git a/src/lustre/lustreAstDependencies.mli b/src/lustre/lustreAstDependencies.mli index 3cbbfd14e..59a077fc5 100644 --- a/src/lustre/lustreAstDependencies.mli +++ b/src/lustre/lustreAstDependencies.mli @@ -64,8 +64,6 @@ val error_message: error_kind -> string type node_summary = ((int list) IntMap.t) IMap.t -val pp_print_node_summary: Format.formatter -> int list IntMap.t IMap.t -> unit - val sort_globals: LA.t -> (LA.t, [> error]) result (** Returns a topological order to resolve forward references of globals. This step processes 1. type declarations, and 2. constant declarations *) diff --git a/src/lustre/lustreAstInlineConstants.ml b/src/lustre/lustreAstInlineConstants.ml index f3d4e68d7..f92c8295e 100644 --- a/src/lustre/lustreAstInlineConstants.ml +++ b/src/lustre/lustreAstInlineConstants.ml @@ -275,7 +275,7 @@ and push_pre is_guarded pos = | ArrayConcat (p, e1, e2) -> ArrayConcat (p, r e1, r e2) | ArraySlice (p, e1, (e2, e3)) -> ArraySlice (p, r e1, (e2, e3)) | Quantifier (p, e1, l, e2) -> Quantifier (p, e1, l, r e2) - | ChooseOp (p, i, e) -> ChooseOp (p, i, r e) + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) | When _ as e -> LA.Pre (pos, e) | Current _ as e -> LA.Pre (pos, e) | Condact _ as e -> LA.Pre (pos, e) diff --git a/src/lustre/lustreDesugarFrameBlocks.ml b/src/lustre/lustreDesugarFrameBlocks.ml index ac5cd2a12..6384b98b3 100644 --- a/src/lustre/lustreDesugarFrameBlocks.ml +++ b/src/lustre/lustreDesugarFrameBlocks.ml @@ -115,7 +115,7 @@ let rec fill_ite_helper frame_pos node_id lhs id fill = function | Quantifier (a, b, c, e) -> Quantifier (a, b, c, fill_ite_helper frame_pos node_id lhs id fill e) | BinaryOp (a, b, e1, e2) -> BinaryOp (a, b, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) | CompOp (a, b, e1, e2) -> CompOp (a, b, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) - | ChooseOp (a, b, e) -> ChooseOp (a, b, fill_ite_helper frame_pos node_id lhs id fill e) + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) | ArrayConcat (a, e1, e2) -> ArrayConcat (a, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) | ArrayIndex (a, e1, e2) -> ArrayIndex (a, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) | ArrayConstr (a, e1, e2) -> ArrayConstr (a, fill_ite_helper frame_pos node_id lhs id fill e1, fill_ite_helper frame_pos node_id lhs id fill e2) diff --git a/src/lustre/lustreNodeGen.ml b/src/lustre/lustreNodeGen.ml index de4135885..d3d567ba9 100644 --- a/src/lustre/lustreNodeGen.ml +++ b/src/lustre/lustreNodeGen.ml @@ -1099,7 +1099,7 @@ and compile_ast_expr | A.Pre (_, expr) -> compile_pre bounds expr | A.Merge (_, clock_ident, merge_cases) -> compile_merge bounds clock_ident merge_cases - | A.ChooseOp _ -> assert false (* already desugared in lustreAstNormalizer *) + | A.ChooseOp _ -> assert false (* already desugared in lustreDesugarChooseOps *) (* ****************************************************************** *) (* Tuple and Record Operators *) (* ****************************************************************** *) From 5787087e10f17c70c9f8efcc9995a9777349e662 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 23 Aug 2023 14:25:51 -0500 Subject: [PATCH 25/51] Remove some unnecessary instances of node_id being passed around the module --- src/lustre/lustreAstNormalizer.ml | 160 +++++++++++++++--------------- 1 file changed, 80 insertions(+), 80 deletions(-) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index 0268b7734..d386cd787 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -609,7 +609,7 @@ and normalize_gids info gids_map = let gids_map, warnings = StringMap.fold (fun id gids (gids_map, warnings) -> (* Normalize all equations in gids *) let res = List.map (fun (_, _, lhs, expr) -> - let nexpr, gids, warnings = normalize_expr id info gids_map expr in + let nexpr, gids, warnings = normalize_expr info gids_map expr in gids, warnings, (info.quantified_variables, info.contract_scope, lhs, nexpr) ) gids.equations in let gids_list, warnings2, eqs = split3 res in @@ -656,14 +656,14 @@ and normalize_node_contract info map cref inputs outputs (id, _, ivars, ovars, b let nbody, gids, warnings = normalize_contract info map id body in nbody, gids, warnings, StringMap.empty -and normalize_ghost_declaration node_id info map = function +and normalize_ghost_declaration info map = function | A.UntypedConst (pos, id, expr) -> let new_id = StringMap.find id info.interpretation in - let nexpr, map, warnings = normalize_expr node_id ?guard:None info map expr in + let nexpr, map, warnings = normalize_expr ?guard:None info map expr in A.UntypedConst (pos, new_id, nexpr), map, warnings | TypedConst (pos, id, expr, ty) -> let new_id = StringMap.find id info.interpretation in - let nexpr, map, warnings = normalize_expr node_id ?guard:None info map expr in + let nexpr, map, warnings = normalize_expr ?guard:None info map expr in A.TypedConst (pos, new_id, nexpr, ty), map, warnings | e -> e, empty (), [] @@ -769,15 +769,15 @@ and normalize_node info map info, empty () in (* Normalize equations and the contract *) - let nitems, gids4, warnings2 = normalize_list (normalize_item node_id info map) items in + let nitems, gids4, warnings2 = normalize_list (normalize_item info map) items in let gids = union_list [gids1; gids2; gids3; gids4; gids5; gids6] in let map = StringMap.singleton node_id gids in (node_id, is_extern, params, inputs, outputs, locals, List.flatten nitems, ncontracts), map, warnings1 @ warnings2 -and normalize_item node_id info map = function +and normalize_item info map = function | A.Body equation -> - let nequation, gids, warnings = normalize_equation node_id info map equation in + let nequation, gids, warnings = normalize_equation info map equation in [A.Body nequation], gids, warnings (* shouldn't be possible *) | IfBlock _ @@ -794,7 +794,7 @@ and normalize_item node_id info map = function A.CompOp(pos, A.Lt, Ident(dpos, ctr_id), Const (dpos, Num (HString.mk_hstring (string_of_int b))))) in - let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + let nexpr, gids, warnings = abstract_expr false info map false expr in [AnnotProperty (pos, name', nexpr, k)], gids, warnings (* expr or counter != b *) @@ -804,7 +804,7 @@ and normalize_item node_id info map = function A.CompOp(pos, A.Neq, Ident(dpos, ctr_id), Const (dpos, Num (HString.mk_hstring (string_of_int b))))) in - let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + let nexpr, gids, warnings = abstract_expr false info map false expr in [AnnotProperty (pos, name', nexpr, k)], gids, warnings (* expr or counter > b *) @@ -814,7 +814,7 @@ and normalize_item node_id info map = function A.CompOp(pos, A.Gt, Ident(dpos, ctr_id), Const (dpos, Num (HString.mk_hstring (string_of_int b))))) in - let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + let nexpr, gids, warnings = abstract_expr false info map false expr in [AnnotProperty (pos, name', nexpr, k)], gids, warnings (* expr or counter < b1 or counter > b2 *) @@ -828,22 +828,22 @@ and normalize_item node_id info map = function Const (dpos, Num (HString.mk_hstring (string_of_int b2))))) ) in - let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + let nexpr, gids, warnings = abstract_expr false info map false expr in [AnnotProperty (pos, name', nexpr, k)], gids, warnings | Reachable _ -> let expr = A.UnaryOp (pos, A.Not, expr) in - let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + let nexpr, gids, warnings = abstract_expr false info map false expr in [AnnotProperty (pos, name', nexpr, k)], gids, warnings | Provided expr2 -> let expr1 = A.BinaryOp (pos, A.Impl, expr2, expr) in - let nexpr1, gids1, warnings1 = abstract_expr false node_id info map false expr1 in + let nexpr1, gids1, warnings1 = abstract_expr false info map false expr1 in let inv_prop = A.AnnotProperty (pos, name', nexpr1, Invariant) in if Flags.check_nonvacuity () then ( let pos' = AH.pos_of_expr expr2 in let expr2 = A.UnaryOp (pos', A.Not, expr2) in - let nexpr2, gids2, warnings2 = abstract_expr false node_id info map false expr2 in + let nexpr2, gids2, warnings2 = abstract_expr false info map false expr2 in let name'', gids2 = match name' with | Some name -> let name'' = HString.concat2 (HString.mk_hstring "Guard of ") name in @@ -860,7 +860,7 @@ and normalize_item node_id info map = function ) | _ -> - let nexpr, gids, warnings = abstract_expr false node_id info map false expr in + let nexpr, gids, warnings = abstract_expr false info map false expr in [AnnotProperty (pos, name', nexpr, k)], gids, warnings ) @@ -904,24 +904,24 @@ and normalize_contract info map node_id items = let item = List.nth items j in let nitem, gids', warnings', interpretation' = match item with | Assume (pos, name, soft, expr) -> - let nexpr, gids, warnings = abstract_expr force_fresh node_id info map true expr in + let nexpr, gids, warnings = abstract_expr force_fresh info map true expr in A.Assume (pos, name, soft, nexpr), gids, warnings, StringMap.empty | Guarantee (pos, name, soft, expr) -> - let nexpr, gids, warnings = abstract_expr force_fresh node_id info map true expr in + let nexpr, gids, warnings = abstract_expr force_fresh info map true expr in Guarantee (pos, name, soft, nexpr), gids, warnings, StringMap.empty | Mode (pos, name, requires, ensures) -> (* let new_name = info.contract_ref ^ "_contract_" ^ name in let interpretation = StringMap.singleton name new_name in let info = { info with interpretation } in *) let over_property info map (pos, name, expr) = - let nexpr, gids, warnings = abstract_expr true node_id info map true expr in + let nexpr, gids, warnings = abstract_expr true info map true expr in (pos, name, nexpr), gids, warnings in let nrequires, gids1, warnings1 = normalize_list (over_property info map) requires in let nensures, gids2, warnings2 = normalize_list (over_property info map) ensures in Mode (pos, name, nrequires, nensures), union gids1 gids2, warnings1 @ warnings2, StringMap.empty | ContractCall (pos, name, inputs, outputs) -> - let ninputs, gids1, warnings1 = normalize_list (abstract_expr false node_id info map false) inputs in + let ninputs, gids1, warnings1 = normalize_list (abstract_expr false info map false) inputs in let noutputs = List.map (fun id -> match StringMap.find_opt id info.interpretation with | Some new_id -> new_id @@ -954,7 +954,7 @@ and normalize_contract info map node_id items = in ContractCall (pos, cref, inputs, outputs), gids, warnings, interp | GhostConst decl -> - let ndecl, map, warnings = normalize_ghost_declaration node_id info map decl in + let ndecl, map, warnings = normalize_ghost_declaration info map decl in GhostConst ndecl, map, warnings, StringMap.empty | GhostVars (pos, ((GhostVarDec (pos2, tis)) as lhs), expr) -> let items = match lhs with | A.GhostVarDec (_, items) -> items in @@ -985,14 +985,14 @@ and normalize_contract info map node_id items = ( fun i -> let info = { info with local_group_projection = i } in - normalize_expr ?guard:None node_id info map expanded_expr + normalize_expr ?guard:None info map expanded_expr ) ) in let gids = List.fold_left (fun acc g -> union g acc) (empty ()) gids in let warnings = List.flatten warnings in (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings), true - | None -> normalize_expr ?guard:None node_id info map expr, false) + | None -> normalize_expr ?guard:None info map expr, false) else if has_inductive && lhs_arity = rhs_arity then let expanded_expr = List.fold_left @@ -1002,8 +1002,8 @@ and normalize_contract info map node_id items = expr (StringMap.bindings info.inductive_variables) in - normalize_expr ?guard:None node_id info map expanded_expr, true - else normalize_expr ?guard:None node_id info map expr, false + normalize_expr ?guard:None info map expanded_expr, true + else normalize_expr ?guard:None info map expr, false ) in let gids2 = ( @@ -1045,9 +1045,9 @@ and normalize_contract info map node_id items = !result, !gids, !warnings -and normalize_equation node_id info map = function +and normalize_equation info map = function | Assert (pos, expr) -> - let nexpr, map, warnings = abstract_expr true node_id info map true expr in + let nexpr, map, warnings = abstract_expr true info map true expr in A.Assert (pos, nexpr), map, warnings | Equation (pos, lhs, expr) -> (* Need to track array indexes of the left hand side if there are any *) @@ -1091,12 +1091,12 @@ and normalize_equation node_id info map = function let exprs, gids, warnings = split3 (List.init lhs_arity (fun i -> let info = { info with local_group_projection = i } in - normalize_expr node_id info map expanded_expr)) + normalize_expr info map expanded_expr)) in let gids = List.fold_left (fun acc g -> union g acc) (empty ()) gids in let warnings = List.flatten warnings in (A.GroupExpr (dpos, A.ExprList, exprs), gids, warnings), true - | None -> normalize_expr node_id info map expr, false) + | None -> normalize_expr info map expr, false) else if has_inductive && lhs_arity = rhs_arity then let expanded_expr = List.fold_left (fun acc (v, ty) -> @@ -1105,8 +1105,8 @@ and normalize_equation node_id info map = function expr (StringMap.bindings info.inductive_variables) in - normalize_expr node_id info map expanded_expr, true - else normalize_expr node_id info map expr, false) + normalize_expr info map expanded_expr, true + else normalize_expr info map expr, false) in let gids2 = if expanded then let items = match lhs with | StructDef (_, items) -> items in @@ -1127,8 +1127,8 @@ and rename_id info = function | None -> A.Ident (pos, id)) | _ -> assert false -and abstract_expr ?guard force node_id info map is_ghost expr = - let nexpr, gids1, warnings = normalize_expr node_id ?guard info map expr in +and abstract_expr ?guard force info map is_ghost expr = + let nexpr, gids1, warnings = normalize_expr ?guard info map expr in if should_not_abstract force nexpr then nexpr, gids1, warnings else @@ -1176,7 +1176,7 @@ and combine_args_with_const info args flags = List.fold_left over_args_arity (0, []) (List.combine args output_arity) |> snd |> List.rev -and normalize_expr ?guard node_id info map = +and normalize_expr ?guard info map = let abstract_array_literal info expr nexpr = let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in @@ -1198,7 +1198,7 @@ and normalize_expr ?guard node_id info map = nexpr, gids in let abstract_node_arg ?guard force is_const info map expr = - let nexpr, gids1, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids1, warnings = normalize_expr ?guard info map expr in if should_not_abstract force nexpr then nexpr, gids1, warnings else @@ -1227,14 +1227,14 @@ and normalize_expr ?guard node_id info map = | Condact (pos, cond, restart, id, args, defaults) -> let flags = StringMap.find id info.node_is_input_const in let ncond, gids1, warnings1 = if AH.expr_is_true cond then cond, empty (), [] - else abstract_expr ?guard true node_id info map false cond in + else abstract_expr ?guard true info map false cond in let nrestart, gids2, warnings2 = if AH.expr_is_const restart then restart, empty (), [] - else abstract_expr ?guard true node_id info map false restart + else abstract_expr ?guard true info map false restart in let nargs, gids3, warnings3 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) in - let ndefaults, gids4, warnings4 = normalize_list (normalize_expr ?guard node_id info map) defaults in + let ndefaults, gids4, warnings4 = normalize_list (normalize_expr ?guard info map) defaults in let nexpr, gids5 = mk_fresh_call info id map pos ncond nrestart nargs (Some ndefaults) in let gids = union_list [gids1; gids2; gids3; gids4; gids5] in let warnings = warnings1 @ warnings2 @ warnings3 @ warnings4 in @@ -1243,7 +1243,7 @@ and normalize_expr ?guard node_id info map = let flags = StringMap.find id info.node_is_input_const in let cond = A.Const (dummy_pos, A.True) in let nrestart, gids1, warnings1 = if AH.expr_is_const restart then restart, empty (), [] - else abstract_expr ?guard true node_id info map false restart + else abstract_expr ?guard true info map false restart in let nargs, gids2, warnings2 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) @@ -1256,9 +1256,9 @@ and normalize_expr ?guard node_id info map = | clock_value, A.Activate (pos, id, cond, restart, args) -> let flags = StringMap.find id info.node_is_input_const in let ncond, gids1, warnings1 = if AH.expr_is_true cond then cond, empty (), [] - else abstract_expr ?guard false node_id info map false cond in + else abstract_expr ?guard false info map false cond in let nrestart, gids2 , warnings2 = if AH.expr_is_const restart then restart, empty (), [] - else abstract_expr ?guard false node_id info map false restart in + else abstract_expr ?guard false info map false restart in let nargs, gids3, warnings3 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) (combine_args_with_const info args flags) @@ -1273,7 +1273,7 @@ and normalize_expr ?guard node_id info map = | "true" -> A.Ident (pos, clock_id) | "false" -> A.UnaryOp (pos, A.Not, A.Ident (pos, clock_id)) | _ -> A.CompOp (pos, A.Eq, A.Ident (pos, clock_id), A.Ident (pos, clock_value)) - in let ncond, gids1, warnings1 = abstract_expr ?guard false node_id info map false cond_expr in + in let ncond, gids1, warnings1 = abstract_expr ?guard false info map false cond_expr in let restart = A.Const (Lib.dummy_pos, A.False) in let nargs, gids2, warnings2 = normalize_list (fun (arg, is_const) -> abstract_node_arg ?guard:None false is_const info map arg) @@ -1284,7 +1284,7 @@ and normalize_expr ?guard node_id info map = let warnings = warnings1 @ warnings2 in (clock_value, nexpr), gids, warnings | clock_value, expr -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in (clock_value, nexpr), gids, warnings in let ncases, gids, warnings = normalize_list (normalize' ?guard info map) cases in Merge (pos, clock_id, ncases), gids, warnings @@ -1292,21 +1292,21 @@ and normalize_expr ?guard node_id info map = (* Guarding and abstracting pres *) (* ************************************************************************ *) | Arrow (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard:(Some nexpr1) node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard:(Some nexpr1) info map expr2 in let gids = union gids1 gids2 in let warnings = warnings1 @ warnings2 in Arrow (pos, nexpr1, nexpr2), gids, warnings | Pre (pos1, ArrayIndex (pos2, expr1, expr2)) -> let expr = A.ArrayIndex (pos2, Pre (pos1, expr1), expr2) in - normalize_expr ?guard node_id info map expr + normalize_expr ?guard info map expr | Pre (pos, expr) -> let ivars = info.inductive_variables in let ty = if expr_has_inductive_var ivars expr |> is_some then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in - let nexpr, gids1, warnings1 = abstract_expr ?guard:None false node_id info map false expr in + let nexpr, gids1, warnings1 = abstract_expr ?guard:None false info map false expr in let guard, gids2, warnings2, previously_guarded = match guard with | Some guard -> guard, empty (), [], true | None -> @@ -1332,13 +1332,13 @@ and normalize_expr ?guard node_id info map = (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in - let nexpr, gids1, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids1, warnings = normalize_expr ?guard info map expr in let ivars = info.inductive_variables in let iexpr, gids2= mk_fresh_array_ctor info pos ivars ty nexpr size_expr in ArrayConstr (pos, iexpr, size_expr), union gids1 gids2, warnings | GroupExpr (pos, ArrayExpr, expr_list) as expr -> let nexpr_list, gids1, warnings = normalize_list - (normalize_expr ?guard:None node_id info map) + (normalize_expr ?guard:None info map) expr_list in let nexpr = A.GroupExpr (pos, ArrayExpr, nexpr_list) in @@ -1353,42 +1353,42 @@ and normalize_expr ?guard node_id info map = (* ************************************************************************ *) | ModeRef _ as expr -> expr, empty (), [] | RecordProject (pos, expr, i) -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in RecordProject (pos, nexpr, i), gids, warnings | TupleProject (pos, expr, i) -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in TupleProject (pos, nexpr, i), gids, warnings | Const _ as expr -> expr, empty (), [] | UnaryOp (pos, op, expr) -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in UnaryOp (pos, op, nexpr), gids, warnings | BinaryOp (pos, op, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in BinaryOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | TernaryOp (pos, op, expr1, expr2, expr3) -> - let nexpr1, gids1, warnings1= normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in - let nexpr3, gids3, warnings3 = normalize_expr ?guard node_id info map expr3 in + let nexpr1, gids1, warnings1= normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in + let nexpr3, gids3, warnings3 = normalize_expr ?guard info map expr3 in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in TernaryOp (pos, op, nexpr1, nexpr2, nexpr3), gids, warnings | NArityOp (pos, op, expr_list) -> let nexpr_list, gids, warnings = normalize_list - (normalize_expr ?guard node_id info map) + (normalize_expr ?guard info map) expr_list in NArityOp (pos, op, nexpr_list), gids, warnings | ConvOp (pos, op, expr) -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in ConvOp (pos, op, nexpr), gids, warnings | CompOp (pos, op, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in CompOp (pos, op, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | ChooseOp _ -> assert false (* desugared earlier in pipeline *) | RecordExpr (pos, id, id_expr_list) -> let normalize' info map ?guard (id, expr) = - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in (id, nexpr), gids, warnings in let nid_expr_list, gids, warnings = normalize_list @@ -1397,27 +1397,27 @@ and normalize_expr ?guard node_id info map = RecordExpr (pos, id, nid_expr_list), gids, warnings | GroupExpr (pos, kind, expr_list) -> let nexpr_list, gids, warnings = normalize_list - (normalize_expr ?guard node_id info map) + (normalize_expr ?guard info map) expr_list in GroupExpr (pos, kind, nexpr_list), gids, warnings | StructUpdate (pos, expr1, i, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in StructUpdate (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2 | ArraySlice (pos, expr1, (expr2, expr3)) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in - let nexpr3, gids3, warnings3 = normalize_expr ?guard node_id info map expr3 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in + let nexpr3, gids3, warnings3 = normalize_expr ?guard info map expr3 in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in ArraySlice (pos, nexpr1, (nexpr2, nexpr3)), gids, warnings | ArrayIndex (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in ArrayIndex (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | ArrayConcat (pos, expr1, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in ArrayConcat (pos, nexpr1, nexpr2), union gids1 gids2, warnings1 @ warnings2 | Quantifier (pos, kind, vars, expr) -> let ctx = List.fold_left Ctx.union info.context @@ -1427,30 +1427,30 @@ and normalize_expr ?guard node_id info map = info with context = ctx; quantified_variables = info.quantified_variables @ vars } in - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in Quantifier (pos, kind, vars, nexpr), gids, warnings | When (pos, expr, clock_expr) -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in When (pos, nexpr, clock_expr), gids, warnings | Current (pos, expr) -> - let nexpr, gids, warnings = normalize_expr ?guard node_id info map expr in + let nexpr, gids, warnings = normalize_expr ?guard info map expr in Current (pos, nexpr), gids, warnings | Activate (pos, id, expr1, expr2, expr_list) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in let nexpr_list, gids3, warnings3 = normalize_list - (normalize_expr ?guard node_id info map) + (normalize_expr ?guard info map) expr_list in let gids = union (union gids1 gids2) gids3 in let warnings = warnings1 @ warnings2 @ warnings3 in Activate (pos, id, nexpr1, nexpr2, nexpr_list), gids, warnings | Fby (pos, expr1, i, expr2) -> - let nexpr1, gids1, warnings1 = normalize_expr ?guard node_id info map expr1 in - let nexpr2, gids2, warnings2 = normalize_expr ?guard node_id info map expr2 in + let nexpr1, gids1, warnings1 = normalize_expr ?guard info map expr1 in + let nexpr2, gids2, warnings2 = normalize_expr ?guard info map expr2 in Fby (pos, nexpr1, i, nexpr2), union gids1 gids2, warnings1 @ warnings2 | CallParam (pos, id, type_list, expr_list) -> let nexpr_list, gids, warnings = normalize_list - (normalize_expr ?guard node_id info map) + (normalize_expr ?guard info map) expr_list in CallParam (pos, id, type_list, nexpr_list), gids, warnings From e94d36c74f63d394752a9023b7b66f9e885e3bad Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 23 Aug 2023 14:34:17 -0500 Subject: [PATCH 26/51] remove more unnecessary node_id in lustreAstNormalizer --- src/lustre/lustreAstNormalizer.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index d386cd787..7a4d5ff71 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -653,7 +653,7 @@ and normalize_node_contract info map cref inputs outputs (id, _, ivars, ovars, b interpretation = interp; contract_ref; } in - let nbody, gids, warnings = normalize_contract info map id body in + let nbody, gids, warnings = normalize_contract info map body in nbody, gids, warnings, StringMap.empty and normalize_ghost_declaration info map = function @@ -716,7 +716,7 @@ and normalize_node info map in let contract_ref = new_contract_reference () in let info = { info with context = ctx; contract_ref } in - let ncontracts, gids, warnings = normalize_contract info map node_id + let ncontracts, gids, warnings = normalize_contract info map contracts in (Some ncontracts), gids, warnings | None -> None, empty (), [] @@ -866,7 +866,7 @@ and normalize_item info map = function -and rename_ghost_variables info node_id contract = +and rename_ghost_variables info contract = let sep = HString.mk_hstring "_contract_" in match contract with | [] -> [StringMap.empty], info @@ -876,7 +876,7 @@ and rename_ghost_variables info node_id contract = let ty = Ctx.expand_nested_type_syn info.context ty in let new_id = HString.concat sep [info.contract_ref;id] in let info = { info with context = Ctx.add_ty info.context new_id ty } in - let tail, info = rename_ghost_variables info node_id t in + let tail, info = rename_ghost_variables info t in (StringMap.singleton id new_id) :: tail, info (* Recurse through each declaration one at a time *) | GhostVars (pos1, A.GhostVarDec(pos2, (_, id, _)::tis), e) :: t -> @@ -884,15 +884,15 @@ and rename_ghost_variables info node_id contract = let ty = Ctx.expand_nested_type_syn info.context ty in let new_id = HString.concat sep [info.contract_ref;id] in let info = { info with context = Ctx.add_ty info.context new_id ty } in - let tail, info = rename_ghost_variables info node_id (A.GhostVars (pos1, A.GhostVarDec(pos2, tis), e) :: t) in + let tail, info = rename_ghost_variables info (A.GhostVars (pos1, A.GhostVarDec(pos2, tis), e) :: t) in (StringMap.singleton id new_id) :: tail, info - | _ :: t -> rename_ghost_variables info node_id t + | _ :: t -> rename_ghost_variables info t -and normalize_contract info map node_id items = +and normalize_contract info map items = let gids = ref (empty ()) in let warnings = ref [] in let result = ref [] in - let ghost_interp, info = rename_ghost_variables info node_id items in + let ghost_interp, info = rename_ghost_variables info items in let ghost_interp = List.fold_left (StringMap.merge union_keys) StringMap.empty ghost_interp in From c5dc6db8583cbe148efe7ccfa4d829a51222bc51 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 23 Aug 2023 18:16:36 -0500 Subject: [PATCH 27/51] Remove context return from interface of normalize function --- src/lustre/lustreAstNormalizer.ml | 2 +- src/lustre/lustreAstNormalizer.mli | 2 +- src/lustre/lustreInput.ml | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index 7a4d5ff71..96b37c8c5 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -592,7 +592,7 @@ let rec normalize ctx ai_ctx (decls:LustreAst.t) gids = (StringMap.bindings map) A.pp_print_program ast; - Res.ok (ast, map, warnings, ctx) + Res.ok (ast, map, warnings) and normalize_declaration info map = function | A.NodeDecl (span, decl) -> diff --git a/src/lustre/lustreAstNormalizer.mli b/src/lustre/lustreAstNormalizer.mli index bf7ca1e74..68841137e 100644 --- a/src/lustre/lustreAstNormalizer.mli +++ b/src/lustre/lustreAstNormalizer.mli @@ -84,7 +84,7 @@ val normalize : TypeCheckerContext.tc_context -> LustreAst.t -> GeneratedIdentifiers.t GeneratedIdentifiers.StringMap.t -> (LustreAst.declaration list * GeneratedIdentifiers.t GeneratedIdentifiers.StringMap.t * - [> `LustreAstNormalizerWarning of Lib.position * warning_kind] list * TypeCheckerContext.tc_context, [> error]) + [> `LustreAstNormalizerWarning of Lib.position * warning_kind] list, [> error]) result val pp_print_generated_identifiers : Format.formatter -> GeneratedIdentifiers.t -> unit diff --git a/src/lustre/lustreInput.ml b/src/lustre/lustreInput.ml index 0fc47a468..a8d92ab86 100644 --- a/src/lustre/lustreInput.ml +++ b/src/lustre/lustreInput.ml @@ -183,9 +183,10 @@ let type_check declarations = let abstract_interp_ctx = LIA.interpret_program inlined_global_ctx gids const_inlined_nodes_and_contracts in (* Step 15. Normalize AST: guard pres, abstract to locals where appropriate *) - let* (normalized_nodes_and_contracts, gids, warnings2, inlined_global_ctx) = + let* (normalized_nodes_and_contracts, gids, warnings2) = LAN.normalize inlined_global_ctx abstract_interp_ctx const_inlined_nodes_and_contracts gids in + Res.ok (inlined_global_ctx, gids, From 7be34feded730097f5ea47ab5dfb2a594ace12fb Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 24 Aug 2023 12:08:45 -0500 Subject: [PATCH 28/51] Expand desugaring to properties and if statement conditions --- src/lustre/lustreDesugarChooseOps.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 731a937d2..ec6df92f1 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -186,10 +186,14 @@ | A.Body (Equation (pos, lhs, rhs)) -> let rhs, gen_nodes = desugar_expr ctx node_name rhs in A.Body (Equation (pos, lhs, rhs)), gen_nodes + | AnnotProperty (pos, name, e, k) -> + let e, gen_nodes = desugar_expr ctx node_name e in + AnnotProperty(pos, name, e, k), gen_nodes | IfBlock (pos, cond, nis1, nis2) -> let nis1, gen_nodes1 = List.map (desugar_node_item ctx node_name) nis1 |> List.split in let nis2, gen_nodes2 = List.map (desugar_node_item ctx node_name) nis2 |> List.split in - A.IfBlock (pos, cond, nis1, nis2), List.flatten gen_nodes1 @ List.flatten gen_nodes2 + let cond, gen_nodes3 = desugar_expr ctx node_name cond in + A.IfBlock (pos, cond, nis1, nis2), List.flatten gen_nodes1 @ List.flatten gen_nodes2 @ gen_nodes3 | FrameBlock (pos, vars, nes, nis) -> let nes = List.map (fun x -> A.Body x) nes in let nes, gen_nodes1 = List.map (desugar_node_item ctx node_name) nes |> List.split in @@ -200,7 +204,7 @@ let nis, gen_nodes2 = List.map (desugar_node_item ctx node_name) nis |> List.split in FrameBlock(pos, vars, nes, nis), List.flatten gen_nodes1 @ List.flatten gen_nodes2 | AnnotMain _ - | AnnotProperty _ + | Body (Assert _) -> ni, [] let desugar_choose_ops ctx node_summary decls = From 75467a2718d6861476099de226dc8eced7cea453 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 24 Aug 2023 12:23:16 -0500 Subject: [PATCH 29/51] Expand choose op desugaring to asserts --- src/lustre/lustreDesugarChooseOps.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index ec6df92f1..3bff3c2fd 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -199,13 +199,15 @@ let nes, gen_nodes1 = List.map (desugar_node_item ctx node_name) nes |> List.split in let nes = List.map (fun ne -> match ne with | A.Body (A.Equation _ as eq) -> eq - | _ -> assert false (*!! CHECK ON THIS !!*) + | _ -> assert false ) nes in let nis, gen_nodes2 = List.map (desugar_node_item ctx node_name) nis |> List.split in FrameBlock(pos, vars, nes, nis), List.flatten gen_nodes1 @ List.flatten gen_nodes2 - | AnnotMain _ + | Body (Assert (pos, e)) -> + let e, gen_nodes = desugar_expr ctx node_name e in + Body (Assert (pos, e)), gen_nodes + | AnnotMain _ -> ni, [] - | Body (Assert _) -> ni, [] let desugar_choose_ops ctx node_summary decls = let decls, node_summary = From 7dd84da5d54b334cfa2b4e794fd9744405d3f90b Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Thu, 24 Aug 2023 13:00:03 -0500 Subject: [PATCH 30/51] Expand choose op desugaring to contracts --- src/lustre/lustreDesugarChooseOps.ml | 29 ++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 3bff3c2fd..20737d5b3 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -180,6 +180,29 @@ | CallParam (pos, id, types, expr_list) -> let expr_list, gen_nodes = List.map (desugar_expr ctx node_name) expr_list |> List.split in CallParam (pos, id, types, expr_list), List.flatten gen_nodes + + let desugar_contract_item ctx node_name ci = + match ci with + | A.GhostVars (pos, lhs, e) -> + let e, gen_nodes = desugar_expr ctx node_name e in + A.GhostVars (pos, lhs, e), gen_nodes + | Assume (pos, name, b, e) -> + let e, gen_nodes = desugar_expr ctx node_name e in + Assume (pos, name, b, e), gen_nodes + | Guarantee (pos, name, b, e) -> + let e, gen_nodes = desugar_expr ctx node_name e in + Guarantee (pos, name, b, e), gen_nodes + | GhostConst _ + | Mode _ + | ContractCall _ + | AssumptionVars _ -> ci, [] + + let desugar_contract ctx node_name contract = + match contract with + | Some contract_items -> + let items, gen_nodes = (List.map (desugar_contract_item ctx node_name) contract_items) |> List.split in + Some items, List.flatten gen_nodes + | None -> None, [] let rec desugar_node_item ctx node_name ni = match ni with @@ -216,16 +239,18 @@ | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> let ctx = Chk.get_node_ctx ctx d |> unwrap in let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in + let contract, gen_nodes2 = desugar_contract ctx id contract in let gen_nodes = List.flatten gen_nodes in let summary = update_node_summary summary gen_nodes in - decls @ gen_nodes @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], + decls @ gen_nodes @ gen_nodes2 @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], summary | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> let ctx = Chk.get_node_ctx ctx d |> unwrap in let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in + let contract, gen_nodes2 = desugar_contract ctx id contract in let gen_nodes = List.flatten gen_nodes in let summary = update_node_summary summary gen_nodes in - decls @ gen_nodes @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], + decls @ gen_nodes @ gen_nodes2 @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], summary | _ -> decl :: decls, node_summary ) ([], node_summary) decls in From 25889c11daec413b642b09956eff6800c429a8c5 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Fri, 25 Aug 2023 10:56:53 -0500 Subject: [PATCH 31/51] Fix choose op bug in lustreSyntaxChecks --- src/lustre/lustreSyntaxChecks.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index 39ddd8786..3d9a38a12 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -531,8 +531,8 @@ let rec expr_only_supported_in_merge observer expr = | ConvOp (_, _, e) | Pre (_, e) | Current (_, e) - | Quantifier (_, _, _, e) - | ChooseOp (_, _, e) -> r observer e + | Quantifier (_, _, _, e) -> r observer e + | ChooseOp (_, _, e) -> r false e | BinaryOp (_, _, e1, e2) | StructUpdate (_, e1, _, e2) | CompOp (_, _, e1, e2) From ddb665f8667f5d11e2622722fc2e74deb12b2c10 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 29 Aug 2023 11:36:39 -0500 Subject: [PATCH 32/51] Move choose op desugaring earlier in pipeline, and make some updates to how choose ops are handled in lustreAstHelpers --- src/lustre/lustreAstDependencies.ml | 1 + src/lustre/lustreAstHelpers.ml | 216 +------------------------- src/lustre/lustreAstHelpers.mli | 7 - src/lustre/lustreDesugarChooseOps.ml | 81 ++++------ src/lustre/lustreDesugarChooseOps.mli | 4 +- src/lustre/lustreInput.ml | 10 +- 6 files changed, 38 insertions(+), 281 deletions(-) diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 7ae3fad5f..0561e2a8d 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -344,6 +344,7 @@ and mk_graph_expr ?(only_modes = false) | LA.Call (_, _, es) -> List.fold_left union_dependency_analysis_data empty_dependency_analysis_data (List.map (mk_graph_expr ~only_modes) es) + | LA.ChooseOp _ -> assert false (* Already desugared in lustreDesugarChooseOps *) | _ -> empty_dependency_analysis_data (* | e -> Log.log L_trace "%a located at %a" diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index 571ccc5b9..6f3b623e3 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -71,7 +71,7 @@ let rec expr_contains_call = function | Ident (_, _) | ModeRef (_, _) | Const (_, _) -> false | RecordProject (_, e, _) | TupleProject (_, e, _) | UnaryOp (_, _, e) | ConvOp (_, _, e) | Quantifier (_, _, _, e) | When (_, e, _) - | Current (_, e) | Pre (_, e) | ChooseOp (_, _, e) + | Current (_, e) | Pre (_, e) -> expr_contains_call e | BinaryOp (_, _, e1, e2) | CompOp (_, _, e1, e2) | StructUpdate (_, e1, _, e2) | ArrayConstr (_, e1, e2) | ArrayIndex (_, e1, e2) | ArrayConcat (_, e1, e2) @@ -87,7 +87,7 @@ let rec expr_contains_call = function | Activate (_, _, e1, e2, expr_list) -> expr_contains_call e1 || expr_contains_call e2 || List.fold_left (fun acc x -> acc || expr_contains_call x) false expr_list - | Call (_, _, _) | Condact (_, _, _, _, _, _) | RestartEvery (_, _, _, _) + | Call (_, _, _) | Condact (_, _, _, _, _, _) | RestartEvery (_, _, _, _) | ChooseOp (_, _, _) -> true let rec type_contains_subrange = function @@ -464,218 +464,6 @@ let rec lasts_of_expr acc = function lasts_of_expr (lasts_of_expr acc e1) e2 *) -let rec replace_lasts allowed prefix acc ee = match ee with - | Const _ | Ident _ | ModeRef _ -> - ee, acc - - | RecordProject (pos, e, i) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else RecordProject (pos, e', i), acc' - - | ConvOp (pos, op, e) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else ConvOp (pos, op, e'), acc' - - | UnaryOp (pos, op, e) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else UnaryOp (pos, op, e'), acc' - - | Current (pos, e) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else Current (pos, e'), acc' - - | When (pos, e, c) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else When (pos, e', c), acc' - - | Quantifier (pos, q, vs, e) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else Quantifier (pos, q, vs, e'), acc' - - | TupleProject (pos, e1, i) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - if e1 == e1' then ee, acc - else TupleProject (pos, e1', i), acc' - - | ArrayConstr (pos, e1, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else ArrayConstr (pos, e1', e2'), acc' - - | BinaryOp (pos, op, e1, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else BinaryOp (pos, op, e1', e2'), acc' - - | CompOp (pos, op, e1, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else CompOp (pos, op, e1', e2'), acc' - - | ChooseOp (pos, i, e) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc - else ChooseOp (pos, i, e'), acc' - - - | ArrayConcat (pos, e1, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else ArrayConcat (pos, e1', e2'), acc' - - | TernaryOp (pos, op, e1, e2, e3) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - let e3', acc' = replace_lasts allowed prefix acc' e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then ee, acc - else TernaryOp (pos, op, e1', e2', e3'), acc' - - | ArraySlice (pos, e1, (e2, e3)) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - let e3', acc' = replace_lasts allowed prefix acc' e3 in - if e1 == e1' && e2 == e2' && e3 == e3' then ee, acc - else ArraySlice (pos, e1', (e2', e3')), acc' - - | ArrayIndex (pos, e1, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else ArrayIndex (pos, e1', e2'), acc' - - | GroupExpr (_, _, l) | NArityOp (_, _, l) - | Call (_, _, l) | CallParam (_, _, _, l) -> - let l', acc' = - List.fold_left (fun (l, acc) e -> - let e, acc = replace_lasts allowed prefix acc e in - e :: l, acc - ) ([], acc) l in - let l' = List.rev l' in - if try List.for_all2 (==) l l' with _ -> false then ee, acc - else (match ee with - | GroupExpr (pos, g, _) -> GroupExpr (pos, g, l') - | NArityOp (pos, op, _) -> NArityOp (pos, op, l') - | Call (pos, n, _) -> Call (pos, n, l') - | CallParam (pos, n, t, _) -> CallParam (pos, n, t, l') - | _ -> assert false - ), acc' - - | Merge (pos, c, l) -> - let l', acc' = - List.fold_left (fun (l, acc) (c, e) -> - let e, acc = replace_lasts allowed prefix acc e in - (c, e) :: l, acc - ) ([], acc) l in - let l' = List.rev l' in - if try List.for_all2 (fun (_, x) (_, x') -> x == x') l l' with _ -> false - then ee, acc - else Merge (pos, c, l'), acc' - - | RestartEvery (pos, n, l, e) -> - let l', acc' = - List.fold_left (fun (l, acc) e -> - let e, acc = replace_lasts allowed prefix acc e in - e :: l, acc - ) ([], acc) l in - let l' = List.rev l' in - let e', acc' = replace_lasts allowed prefix acc' e in - if try e == e' && List.for_all2 (==) l l' with _ -> false then ee, acc' - else RestartEvery (pos, n, l', e'), acc' - - | Activate (pos, n, e, r, l) -> - let l', acc' = - List.fold_left (fun (l, acc) e -> - let e, acc = replace_lasts allowed prefix acc e in - e :: l, acc - ) ([], acc) l in - let l' = List.rev l' in - let e', acc' = replace_lasts allowed prefix acc' e in - let r', acc' = replace_lasts allowed prefix acc' r in - if try e == e' && r == r' && - List.for_all2 (==) l l' with _ -> false then ee, acc - else Activate (pos, n, e', r', l'), acc' - - | Condact (pos, e, r, n, l1, l2) -> - let l1', acc' = - List.fold_left (fun (l, acc) e -> - let e, acc = replace_lasts allowed prefix acc e in - e :: l, acc - ) ([], acc) l1 in - let l1' = List.rev l1' in - let l2', acc' = - List.fold_left (fun (l, acc) e -> - let e, acc = replace_lasts allowed prefix acc e in - e :: l, acc - ) ([], acc') l2 in - let l2' = List.rev l2' in - let e', acc' = replace_lasts allowed prefix acc' e in - let r', acc' = replace_lasts allowed prefix acc' r in - if try e == e' && r == r' && - List.for_all2 (==) l1 l1' && - List.for_all2 (==) l2 l2' - with _ -> false then ee, acc - else Condact (pos, e', r', n, l1', l2'), acc' - - | RecordExpr (pos, n, ie) -> - let ie', acc' = - List.fold_left (fun (ie, acc) (i, e) -> - let e, acc = replace_lasts allowed prefix acc e in - (i, e) :: ie, acc - ) ([], acc) ie in - let ie' = List.rev ie' in - if try List.for_all2 (fun (_, e) (_, e') -> e == e') ie ie' with _ -> false - then ee, acc - else RecordExpr (pos, n, ie'), acc' - - | StructUpdate (pos, e1, li, e2) -> - let li', acc' = - List.fold_left (fun (li, acc) -> function - | Label _ as s -> s :: li, acc - | Index (i, e) as s -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then s :: li, acc' - else Index (i, e') :: li, acc' - ) ([], acc) li in - let li' = List.rev li' in - let e1', acc' = replace_lasts allowed prefix acc' e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if try e1 == e1' && e2 == e2' && - List.for_all2 (fun ei ei' -> match ei, ei' with - | Label _, Label _ -> true - | Index (_, e), Index (_, e') -> e == e' - | _ -> false - ) li li' - with _ -> false then ee, acc - else StructUpdate (pos, e1', li', e2'), acc' - - | Fby (pos, e1, i, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else Fby (pos, e1', i, e2'), acc' - - | Pre (pos, e) -> - let e', acc' = replace_lasts allowed prefix acc e in - if e == e' then ee, acc else Pre (pos, e'), acc' - - | Arrow (pos, e1, e2) -> - let e1', acc' = replace_lasts allowed prefix acc e1 in - let e2', acc' = replace_lasts allowed prefix acc' e2 in - if e1 == e1' && e2 == e2' then ee, acc - else Arrow (pos, e1', e2'), acc' - - - (** Checks whether a struct item has a `pre` or a `->`. *) let rec struct_item_has_pre_or_arrow = function | SingleIdent _ | FieldSelection _ | ArrayDef _ -> None diff --git a/src/lustre/lustreAstHelpers.mli b/src/lustre/lustreAstHelpers.mli index 906eeb0ea..38fdc8a8e 100644 --- a/src/lustre/lustreAstHelpers.mli +++ b/src/lustre/lustreAstHelpers.mli @@ -71,13 +71,6 @@ val node_local_decl_has_pre_or_arrow : node_local_decl -> Lib.position option val node_item_has_pre_or_arrow : node_item -> Lib.position option (** Checks whether a node equation has a `pre` or a `->`. *) -val replace_lasts : LustreAst.index list -> string -> SI.t -> expr -> expr * SI.t -(** [replace_lasts allowed prefix acc e] replaces [last x] expressions in AST - [e] by abstract identifiers prefixed with [prefix]. Only identifiers that - appear in the list [allowed] are allowed to appear under a last. It returns - the new AST expression and a set of identifers for which the last - application was replaced. *) - val vars_of_node_calls: expr -> SI.t (** returns all identifiers from the [expr] ast that are inside node calls *) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 20737d5b3..efb54c493 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -19,17 +19,10 @@ module Ctx = TypeCheckerContext module Chk = LustreTypeChecker module AH = LustreAstHelpers - module AD = LustreAstDependencies (* [i] is module state used to guarantee newly created identifiers are unique *) let i = ref 0 - (* This looks unsafe, but we only apply unwrap when we know from earlier stages - in the pipeline that an error is not possible. *) - let unwrap result = match result with - | Ok r -> r - | Error _ -> assert false - let mk_fresh_fn_name pos node_name = i := !i + 1; let node_name = HString.concat2 node_name (HString.mk_hstring ".") in @@ -39,19 +32,6 @@ let name = HString.concat2 name pos in HString.concat2 node_name name - let update_node_summary node_summary gen_nodes = - List.fold_left (fun node_summary node -> match node with - | A.NodeDecl (_, (node_id, _, _, _, outputs, _, _, _)) -> - (AD.IMap.add node_id - ((List.fold_left - (fun (op_idx, m) _ -> (op_idx+1, AD.IntMap.add op_idx [] m)) - (0, AD.IntMap.empty) - outputs) - |> snd)) - node_summary - | _ -> assert false - ) node_summary gen_nodes - let rec desugar_expr ctx node_name = function | A.ChooseOp (pos, (_, id, ty), expr) -> let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in @@ -232,38 +212,33 @@ | AnnotMain _ -> ni, [] - let desugar_choose_ops ctx node_summary decls = - let decls, node_summary = - List.fold_left (fun (decls, summary) decl -> + let desugar_choose_ops ctx decls = + let decls = + List.fold_left (fun decls decl -> match decl with - | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> - let ctx = Chk.get_node_ctx ctx d |> unwrap in - let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in - let contract, gen_nodes2 = desugar_contract ctx id contract in - let gen_nodes = List.flatten gen_nodes in - let summary = update_node_summary summary gen_nodes in - decls @ gen_nodes @ gen_nodes2 @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], - summary - | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> - let ctx = Chk.get_node_ctx ctx d |> unwrap in - let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in - let contract, gen_nodes2 = desugar_contract ctx id contract in - let gen_nodes = List.flatten gen_nodes in - let summary = update_node_summary summary gen_nodes in - decls @ gen_nodes @ gen_nodes2 @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))], - summary - | _ -> decl :: decls, node_summary - ) ([], node_summary) decls in - (* Update global context to include generated nodes *) - let ctx = List.fold_left (fun ctx decl -> - match decl with - | A.NodeDecl (_, (id, _, _, ip, op, _, _, _)) -> - let fun_ty = (Chk.build_node_fun_ty Lib.dummy_pos ctx ip op) |> unwrap in - (Ctx.add_ty_node ctx id fun_ty) - | A.FuncDecl (_, (id, _, _, ip, op, _, _, _)) -> - let fun_ty = (Chk.build_node_fun_ty Lib.dummy_pos ctx ip op) |> unwrap in - (Ctx.add_ty_node ctx id fun_ty) - | _ -> ctx - ) ctx decls in - decls, ctx, node_summary + | A.NodeDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> + ( + match Chk.get_node_ctx ctx d with + | Ok ctx -> + let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in + let contract, gen_nodes2 = desugar_contract ctx id contract in + let gen_nodes = List.flatten gen_nodes in + decls @ gen_nodes @ gen_nodes2 @ [A.NodeDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))] + (* If there is an error in context collection, it will be detected later in type checking *) + | Error _ -> decl :: decls + ) + | A.FuncDecl (span, ((id, ext, params, inputs, outputs, locals, items, contract) as d)) -> + ( + match Chk.get_node_ctx ctx d with + | Ok ctx -> + let items, gen_nodes = List.map (desugar_node_item ctx id) items |> List.split in + let contract, gen_nodes2 = desugar_contract ctx id contract in + let gen_nodes = List.flatten gen_nodes in + decls @ gen_nodes @ gen_nodes2 @ [A.FuncDecl (span, (id, ext, params, inputs, outputs, locals, items, contract))] + (* If there is an error in context collection, it will be detected later in type checking *) + | Error _ -> decl :: decls + ) + | _ -> decl :: decls + ) [] decls in + decls diff --git a/src/lustre/lustreDesugarChooseOps.mli b/src/lustre/lustreDesugarChooseOps.mli index 48ccb24ac..1f2e6b92d 100644 --- a/src/lustre/lustreDesugarChooseOps.mli +++ b/src/lustre/lustreDesugarChooseOps.mli @@ -17,6 +17,6 @@ (** @author Rob Lorch *) -val desugar_choose_ops : TypeCheckerContext.tc_context -> LustreAstDependencies.node_summary -> +val desugar_choose_ops : TypeCheckerContext.tc_context -> LustreAst.declaration list -> - LustreAst.declaration list * TypeCheckerContext.tc_context * LustreAstDependencies.node_summary + LustreAst.declaration list diff --git a/src/lustre/lustreInput.ml b/src/lustre/lustreInput.ml index a8d92ab86..2f9088884 100644 --- a/src/lustre/lustreInput.ml +++ b/src/lustre/lustreInput.ml @@ -152,16 +152,16 @@ let type_check declarations = (* Step 5: Inline type toplevel decls *) let* (inlined_ctx, const_inlined_type_and_consts) = IC.inline_constants ctx sorted_const_type_decls in + + (* Step 6. Desugar nondeterministic choice operators *) + let node_contract_src = LDN.desugar_choose_ops inlined_ctx node_contract_src in - (* Step 6. Dependency analysis on nodes and contracts *) + (* Step 7. Dependency analysis on nodes and contracts *) let* (sorted_node_contract_decls, toplevel_nodes, node_summary) = AD.sort_and_check_nodes_contracts node_contract_src in - (* Step 7. type check nodes and contracts *) + (* Step 8. type check nodes and contracts *) let* global_ctx = TC.type_check_infer_nodes_and_contracts inlined_ctx sorted_node_contract_decls in - (* Step 8. Desugar nondeterministic choice operators *) - let sorted_node_contract_decls, global_ctx, node_summary = LDN.desugar_choose_ops global_ctx node_summary sorted_node_contract_decls in - (* Step 9. Remove multiple assignment from if blocks and frame blocks *) let sorted_node_contract_decls, gids = RMA.remove_mult_assign global_ctx sorted_node_contract_decls in From 6a637c9503a807c728fd3c614eb942747f58a9e9 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 29 Aug 2023 11:55:15 -0500 Subject: [PATCH 33/51] Fix choose op bug involving a constant in choose op predicate --- src/lustre/lustreDesugarChooseOps.ml | 2 ++ tests/regression/success/choose_simple.lus | 5 +++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index efb54c493..4afd7b57e 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -37,6 +37,8 @@ let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in + (* Constants don't need to be passed as a parameter to generated node *) + let inputs = List.filter (fun i -> not (Ctx.member_val ctx i)) inputs in let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in let ctx = Ctx.add_ty ctx id ty in let inputs = List.map (fun input -> (pos, input, Ctx.lookup_ty ctx input, A.ClockTrue)) inputs in diff --git a/tests/regression/success/choose_simple.lus b/tests/regression/success/choose_simple.lus index 9b4007996..e1267fb0e 100644 --- a/tests/regression/success/choose_simple.lus +++ b/tests/regression/success/choose_simple.lus @@ -1,9 +1,10 @@ +const x1: int = 0; + node main () returns (y: int); var x2: int; let - x2 = choose {x: int | x > 0 }; + x2 = choose {x: int | x > x1 }; y = choose { x: int | x + x2 < 50 }; check y < 100; tel; - From 61f0bfcb4ca380ed4dd67ad348d5882af7f9ab87 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 5 Sep 2023 13:32:33 -0500 Subject: [PATCH 34/51] Allow assumptions to be specified in choose operation --- src/ivcMcs.ml | 6 ++- src/lustre/lustreAst.ml | 13 ++++++- src/lustre/lustreAst.mli | 2 +- src/lustre/lustreAstDependencies.ml | 14 +++++-- src/lustre/lustreAstHelpers.ml | 56 ++++++++++++++++++++-------- src/lustre/lustreDesugarChooseOps.ml | 9 +++-- src/lustre/lustreParser.messages | 16 ++++++++ src/lustre/lustreParser.mly | 4 +- src/lustre/lustreSimplify.ml | 2 +- src/lustre/lustreSyntaxChecks.ml | 3 +- src/lustre/lustreTypeChecker.ml | 9 ++++- 11 files changed, 102 insertions(+), 32 deletions(-) diff --git a/src/ivcMcs.ml b/src/ivcMcs.ml index dd6e9f2cd..c144cfd43 100644 --- a/src/ivcMcs.ml +++ b/src/ivcMcs.ml @@ -260,7 +260,8 @@ let rec minimize_node_call_args ue lst expr = | A.UnaryOp (p,op,e) -> A.UnaryOp (p,op,aux e) | A.BinaryOp (p,op,e1,e2) -> A.BinaryOp (p,op,aux e1,aux e2) | A.Quantifier (p,q,ids,e) -> A.Quantifier (p,q,ids,aux e) - | A.ChooseOp (p,ti,e) -> A.ChooseOp (p,ti,aux e) + | A.ChooseOp (p,ti,e, None) -> A.ChooseOp (p,ti,aux e, None) + | A.ChooseOp (p,ti,e1,Some e2) -> A.ChooseOp (p,ti,aux e1,Some (aux e2)) | A.NArityOp (p,op,es) -> A.NArityOp (p,op,List.map aux es) | A.TernaryOp (p,op,e1,e2,e3) -> A.TernaryOp (p,op,aux e1,aux e2,aux e3) | A.CompOp (p,op,e1,e2) -> A.CompOp (p,op,aux e1,aux e2) @@ -289,8 +290,9 @@ and ast_contains p ast = |> List.exists (fun x -> x) | A.ConvOp (_,_,e) | A.UnaryOp (_,_,e) | A.RecordProject (_,e,_) | A.TupleProject (_,e,_) | A.Quantifier (_,_,_,e) - | A.When (_,e,_) | A.Current (_,e) | A.Pre (_,e) | A.ChooseOp (_,_,e) -> + | A.When (_,e,_) | A.Current (_,e) | A.Pre (_,e) | A.ChooseOp (_,_,e,None) -> aux e + | A.ChooseOp (_,_,e1,Some e2) -> aux e1 || aux e2 | A.StructUpdate (_,e1,_,e2) | A.ArrayConstr (_,e1,e2) | A.ArrayConcat (_,e1,e2) | A.ArrayIndex (_,e1,e2) | A.BinaryOp (_,_,e1,e2) | A.CompOp (_,_,e1,e2) | A.Fby (_,e1,_,e2) diff --git a/src/lustre/lustreAst.ml b/src/lustre/lustreAst.ml index b370eef92..bbfbb7f5d 100644 --- a/src/lustre/lustreAst.ml +++ b/src/lustre/lustreAst.ml @@ -108,7 +108,7 @@ type expr = | NArityOp of position * n_arity_operator * expr list | ConvOp of position * conversion_operator * expr | CompOp of position * comparison_operator * expr * expr - | ChooseOp of position * typed_ident * expr + | ChooseOp of position * typed_ident * expr * expr option (* Structured expressions *) | RecordExpr of position * ident * (ident * expr) list | GroupExpr of position * group_expr * expr list @@ -619,7 +619,16 @@ let rec pp_print_expr ppf = (pp_print_list pp_print_lustre_type "@ ") t (pp_print_list pp_print_expr ",@ ") l - | ChooseOp (p, id, e) -> + | ChooseOp (p, id, e1, Some e2) -> + + Format.fprintf ppf + "%achoose { %a | %a provided %a }" + ppos p + pp_print_typed_ident id + pp_print_expr e1 + pp_print_expr e2 + + | ChooseOp (p, id, e, None) -> Format.fprintf ppf "%achoose { %a | %a }" diff --git a/src/lustre/lustreAst.mli b/src/lustre/lustreAst.mli index c7c718335..de9fc0e97 100644 --- a/src/lustre/lustreAst.mli +++ b/src/lustre/lustreAst.mli @@ -144,7 +144,7 @@ and expr = | NArityOp of position * n_arity_operator * expr list | ConvOp of position * conversion_operator * expr | CompOp of position * comparison_operator * expr * expr - | ChooseOp of position * typed_ident * expr + | ChooseOp of position * typed_ident * expr * expr option (* Structured expressions *) | RecordExpr of position * ident * (ident * expr) list | GroupExpr of position * group_expr * expr list diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 0561e2a8d..3b5a0e1a9 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -395,7 +395,8 @@ let rec get_node_call_from_expr: LA.expr -> (LA.ident * Lib.position) list | LA.NArityOp (_, _, es) -> List.flatten (List.map get_node_call_from_expr es) | LA.ConvOp (_, _, e) -> get_node_call_from_expr e | LA.CompOp (_, _, e1, e2) -> (get_node_call_from_expr e1) @ (get_node_call_from_expr e2) - | LA.ChooseOp (_, _, e) -> get_node_call_from_expr e + | LA.ChooseOp (_, _, e, None) -> get_node_call_from_expr e + | LA.ChooseOp (_, _, e1, Some e2) -> (get_node_call_from_expr e1) @ (get_node_call_from_expr e2) (* Structured expressions *) | LA.RecordExpr (_, _, id_exprs) -> List.flatten (List.map (fun (_, e) -> get_node_call_from_expr e) id_exprs) | LA.GroupExpr (_, _, es) -> List.flatten (List.map get_node_call_from_expr es) @@ -638,8 +639,10 @@ let rec vars_with_flattened_nodes: node_summary -> int -> LA.expr -> LA.SI.t SI.diff (r e) (SI.flatten (List.map LH.vars_of_ty_ids qs)) (* Choose operator *) - | ChooseOp (_, (_, i, _), e) -> + | ChooseOp (_, (_, i, _), e, None) -> SI.diff (r e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e1, Some e2) -> + SI.diff (SI.union (r e1) (r e2)) (SI.singleton i) (* Clock operators *) | When (_, e, _) -> r e @@ -813,7 +816,12 @@ let rec mk_graph_expr2: node_summary -> LA.expr -> (dependency_analysis_data lis empty_dependency_analysis_data (List.concat gs)] - | LA.ChooseOp (_, _, e) -> mk_graph_expr2 m e + | LA.ChooseOp (_, _, e, None) -> mk_graph_expr2 m e + | LA.ChooseOp (_, _, e1, Some e2) -> + mk_graph_expr2 m e1 >>= fun g1 -> + mk_graph_expr2 m e2 >>= fun g2 -> + R.ok [List.fold_left union_dependency_analysis_data empty_dependency_analysis_data + (g1 @ g2) ] | LA.When (_, e, _) -> mk_graph_expr2 m e | LA.Current (_, e) -> mk_graph_expr2 m e | LA.Condact (pos, _, _, n, e1s, e2s) -> diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index 6f3b623e3..a17d02e2b 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -55,7 +55,7 @@ let pos_of_expr = function | Activate (pos , _ , _ , _ , _) | Merge (pos , _ , _ ) | Pre (pos , _) | RestartEvery (pos, _, _, _) | Fby (pos , _ , _ , _) | Arrow (pos , _ , _) | Call (pos , _ , _ ) - | CallParam (pos , _ , _ , _ ) | ChooseOp (pos, _, _) + | CallParam (pos , _ , _ , _ ) | ChooseOp (pos, _, _, _) -> pos let type_arity ty = @@ -87,7 +87,7 @@ let rec expr_contains_call = function | Activate (_, _, e1, e2, expr_list) -> expr_contains_call e1 || expr_contains_call e2 || List.fold_left (fun acc x -> acc || expr_contains_call x) false expr_list - | Call (_, _, _) | Condact (_, _, _, _, _, _) | RestartEvery (_, _, _, _) | ChooseOp (_, _, _) + | Call (_, _, _) | Condact (_, _, _, _, _, _) | RestartEvery (_, _, _, _) | ChooseOp (_, _, _, _) -> true let rec type_contains_subrange = function @@ -116,7 +116,8 @@ let rec substitute (var:HString.t) t = function | ConvOp (pos, op, e) -> ConvOp (pos, op, substitute var t e) | CompOp (pos, op, e1, e2) -> CompOp (pos, op, substitute var t e1, substitute var t e2) - | ChooseOp (pos, i, e) -> ChooseOp(pos, i, substitute var t e) + | ChooseOp (pos, i, e1, None) -> ChooseOp(pos, i, substitute var t e1, None) + | ChooseOp (pos, i, e1, Some e2) -> ChooseOp(pos, i, substitute var t e1, Some (substitute var t e2)) | RecordExpr (pos, ident, expr_list) -> RecordExpr (pos, ident, List.map (fun (i, e) -> (i, substitute var t e)) expr_list) | GroupExpr (pos, kind, expr_list) -> @@ -163,8 +164,11 @@ let rec has_unguarded_pre ung = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) - | ChooseOp (_, _, e) -> has_unguarded_pre ung e + | TupleProject (_, e, _) | Quantifier (_, _, _, e) | ChooseOp (_, _, e, None) -> has_unguarded_pre ung e + | ChooseOp (_, _, e1, Some e2) -> + let u1 = has_unguarded_pre ung e1 in + let u2 = has_unguarded_pre ung e2 in + u1 || u2 | BinaryOp (_, _, e1, e2) | ArrayConstr (_, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) -> let u1 = has_unguarded_pre ung e1 in @@ -251,8 +255,11 @@ let rec has_unguarded_pre_no_warn ung = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) - | ChooseOp (_, _, e) -> has_unguarded_pre_no_warn ung e + | TupleProject (_, e, _) | Quantifier (_, _, _, e) | ChooseOp (_, _, e, None) -> has_unguarded_pre_no_warn ung e + | ChooseOp (_, _, e1, Some e2) -> + let u1 = has_unguarded_pre_no_warn ung e1 in + let u2 = has_unguarded_pre_no_warn ung e2 in + u1 || u2 | BinaryOp (_, _, e1, e2) | ArrayConstr (_, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) -> let u1 = has_unguarded_pre_no_warn ung e1 in @@ -340,9 +347,12 @@ let rec has_pre_or_arrow = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) | TupleProject (_, e, _) | Quantifier (_, _, _, e) - | ChooseOp (_, _, e) -> + | ChooseOp (_, _, e, None) -> has_pre_or_arrow e + | ChooseOp (_, _, e1, Some e2) -> + has_pre_or_arrow e1 |> unwrap_or (fun _ -> has_pre_or_arrow e2) + | BinaryOp (_, _, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) | ArrayIndex (_, e1, e2) | ArrayConstr (_, e1, e2) -> ( match has_pre_or_arrow e1 with @@ -585,7 +595,8 @@ let rec vars_of_node_calls_h obs = | NArityOp (_, _,es) -> SI.flatten (List.map (vars obs) es) | ConvOp (_,_,e) -> vars obs e | CompOp (_,_,e1, e2) -> (vars obs e1) |> SI.union (vars obs e2) - | ChooseOp (_, (_, i, _), e) -> SI.diff (vars obs e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e, None) -> SI.diff (vars obs e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e1, Some e2) -> SI.diff (SI.union (vars obs e1) (vars obs e2)) (SI.singleton i) (* Structured expressions *) | RecordExpr (_, _, flds) -> SI.flatten (List.map (vars obs) (snd (List.split flds))) | GroupExpr (_, _, es) -> SI.flatten (List.map (vars obs) es) @@ -650,7 +661,8 @@ let rec vars: expr -> iset = function | Activate (_, _, e1, e2, es) -> SI.flatten (vars e1 :: vars e2 :: List.map vars es) | Merge (_, _, es) -> List.split es |> snd |> List.map vars |> SI.flatten | RestartEvery (_, i, es, e) -> SI.add i (SI.flatten (vars e :: List.map vars es)) - | ChooseOp (_, (_, i, _), e) -> SI.diff (vars e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e, None) -> SI.diff (vars e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e1, Some e2) -> SI.diff (SI.union (vars e1) (vars e2)) (SI.singleton i) (* Temporal operators *) | Pre (_, e) -> vars e | Fby (_, e1, _, e2) -> SI.union (vars e1) (vars e2) @@ -832,7 +844,8 @@ let rec replace_with_constants: expr -> expr = let e1' = replace_with_constants e1 in let e2' = replace_with_constants e2 in CompOp (p, op, e1', e2') - | ChooseOp (p, i, expr) -> ChooseOp (p, i, replace_with_constants expr) + | ChooseOp (p, i, expr, None) -> ChooseOp (p, i, replace_with_constants expr, None) + | ChooseOp (p, i, expr1, Some expr2) -> ChooseOp (p, i, replace_with_constants expr1, Some (replace_with_constants expr2)) (* Structured expressions *) | RecordExpr (p, i, flds) -> RecordExpr (p, i, (List.map (fun (f, e) -> (f, replace_with_constants e)) flds)) @@ -927,7 +940,8 @@ let rec abstract_pre_subexpressions: expr -> expr = function let e1' = abstract_pre_subexpressions e1 in let e2' = abstract_pre_subexpressions e2 in CompOp (p, op, e1', e2') - | ChooseOp (p, i, e) -> ChooseOp (p, i, abstract_pre_subexpressions e) + | ChooseOp (p, i, e, None) -> ChooseOp (p, i, abstract_pre_subexpressions e, None) + | ChooseOp (p, i, e1, Some e2) -> ChooseOp (p, i, abstract_pre_subexpressions e1, Some (abstract_pre_subexpressions e2)) (* Structured expressions *) | RecordExpr (p, i, flds) -> RecordExpr (p, i, (List.map (fun (f, e) -> (f, abstract_pre_subexpressions e)) flds)) @@ -1027,11 +1041,16 @@ let rec replace_idents locals1 locals2 expr = | Call (a, b, l) -> Call (a, b, List.map (replace_idents locals1 locals2) l) | CallParam (a, b, c, l) -> CallParam (a, b, c, List.map (replace_idents locals1 locals2) l) - | ChooseOp (a, (b, i, c), e) -> + | ChooseOp (a, (b, i, c), e, None) -> (* Remove 'i' from locals because it's bound in 'e' *) let locals = List.combine locals1 locals2 in let locals1, locals2 = List.remove_assoc i locals |> List.split in - ChooseOp (a, (b, i, c), replace_idents locals1 locals2 e) + ChooseOp (a, (b, i, c), replace_idents locals1 locals2 e, None) + | ChooseOp (a, (b, i, c), e1, Some e2) -> + (* Remove 'i' from locals because it's bound in 'e' *) + let locals = List.combine locals1 locals2 in + let locals1, locals2 = List.remove_assoc i locals |> List.split in + ChooseOp (a, (b, i, c), replace_idents locals1 locals2 e1, Some (replace_idents locals1 locals2 e2)) | Quantifier (a, b, tis, e) -> (* Remove 'tis' from locals because they're bound in 'e' *) let locals = List.combine locals1 locals2 in @@ -1466,9 +1485,13 @@ let hash depth_limit expr = | CallParam (_, i, _, el) -> let el_hash = List.map (r (depth + 1)) el in Hashtbl.hash (30, HString.hash i, el_hash) - | ChooseOp (_, (_, i, _), e) -> + | ChooseOp (_, (_, i, _), e, None) -> let e_hash = r (depth + 1) e in Hashtbl.hash (31, HString.hash i, e_hash) + | ChooseOp (_, (_, i, _), e1, Some e2) -> + let e1_hash = r (depth + 1) e1 in + let e2_hash = r (depth + 1) e2 in + Hashtbl.hash (31, HString.hash i, e1_hash, e2_hash) in r 0 expr @@ -1498,7 +1521,8 @@ let rec rename_contract_vars = function | ConvOp (pos, op, e) -> ConvOp (pos, op, rename_contract_vars e) | CompOp (pos, op, e1, e2) -> CompOp (pos, op, rename_contract_vars e1, rename_contract_vars e2) - | ChooseOp (pos, i, e) -> ChooseOp (pos, i, rename_contract_vars e) + | ChooseOp (pos, i, e, None) -> ChooseOp (pos, i, rename_contract_vars e, None) + | ChooseOp (pos, i, e1, Some e2) -> ChooseOp (pos, i, rename_contract_vars e1, Some (rename_contract_vars e2)) | RecordExpr (pos, ident, expr_list) -> RecordExpr (pos, ident, List.map (fun (i, e) -> (i, rename_contract_vars e)) expr_list) | GroupExpr (pos, kind, expr_list) -> diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 4afd7b57e..b14419a7c 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -33,10 +33,13 @@ HString.concat2 node_name name let rec desugar_expr ctx node_name = function - | A.ChooseOp (pos, (_, id, ty), expr) -> + | A.ChooseOp (pos, (_, id, ty), expr1, expr2_opt) -> let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in - let contract = [A.Guarantee (Lib.dummy_pos, None, false, expr)] in - let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr) (Ctx.SI.singleton id)) in + let contract = match expr2_opt with + | None -> [A.Guarantee (Lib.dummy_pos, None, false, expr1)] + | Some expr2 -> [A.Assume (Lib.dummy_pos, None, false, expr2); + A.Guarantee (Lib.dummy_pos, None, false, expr1)] in + let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr1) (Ctx.SI.singleton id)) in (* Constants don't need to be passed as a parameter to generated node *) let inputs = List.filter (fun i -> not (Ctx.member_val ctx i)) inputs in let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 4834a7e9b..3aa2d5887 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2927,3 +2927,19 @@ Syntax Error! main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME BAR DECIMAL WEAKLY Syntax Error! + +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED XOR + +Syntax Error! + +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED DECIMAL WEAKLY + +Syntax Error! + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED XOR + +Syntax Error! + +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED DECIMAL WEAKLY + +Syntax Error! diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index 35180ab47..12757114b 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -913,7 +913,9 @@ pexpr(Q): (* Choose operation *) | CHOOSE; LCURLYBRACKET; id = typed_ident; BAR; e = pexpr(Q); RCURLYBRACKET - { A.ChooseOp (mk_pos $startpos, id, e) } + { A.ChooseOp (mk_pos $startpos, id, e, None) } + | CHOOSE; LCURLYBRACKET; id = typed_ident; BAR; e1 = pexpr(Q); PROVIDED; e2 = pexpr(Q); RCURLYBRACKET + { A.ChooseOp (mk_pos $startpos, id, e1, Some e2) } (* Recursive node call *) | WITH; e1 = pexpr(Q); THEN; e2 = pexpr(Q); ELSE; e3 = pexpr(Q) diff --git a/src/lustre/lustreSimplify.ml b/src/lustre/lustreSimplify.ml index c819f7953..56b967cf9 100644 --- a/src/lustre/lustreSimplify.ml +++ b/src/lustre/lustreSimplify.ml @@ -1300,7 +1300,7 @@ let rec eval_ast_expr bounds ctx = fail_at_position pos "Parametric nodes not supported" - | A.ChooseOp (pos, _, _) -> + | A.ChooseOp (pos, _, _, _) -> fail_at_position pos "Choose operation not supported in old front end" diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index 3d9a38a12..ec5d23731 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -532,7 +532,8 @@ let rec expr_only_supported_in_merge observer expr = | Pre (_, e) | Current (_, e) | Quantifier (_, _, _, e) -> r observer e - | ChooseOp (_, _, e) -> r false e + | ChooseOp (_, _, e, None) -> r false e + | ChooseOp (_, _, e1, Some e2) -> r false e1 >> r false e2 | BinaryOp (_, _, e1, e2) | StructUpdate (_, e1, _, e2) | CompOp (_, _, e1, e2) diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index 910b1d1de..378e2afa6 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -443,7 +443,7 @@ let rec infer_type_expr: tc_context -> LA.expr -> (tc_type, [> error]) result (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in infer_type_expr extn_ctx e - | ChooseOp (_, (_, _, ty), _) as e -> + | ChooseOp (_, (_, _, ty), _, _) as e -> check_type_expr ctx e ty >> R.ok ty (* Clock operators *) @@ -644,10 +644,15 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in check_type_expr extn_ctx e exp_ty - | ChooseOp (pos, (_, i ,ty), e) -> + | ChooseOp (pos, (_, i ,ty), e, None) -> let extn_ctx = union ctx (singleton_ty i ty) in check_type_expr extn_ctx e (Bool pos) >> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) + | ChooseOp (pos, (_, i ,ty), e1, Some e2) -> + let extn_ctx = union ctx (singleton_ty i ty) in + check_type_expr extn_ctx e1 (Bool pos) + >> check_type_expr extn_ctx e2 (Bool pos) + >> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) (* Clock operators *) | When (_, e, _) -> check_type_expr ctx e exp_ty | Current (_, e) -> check_type_expr ctx e exp_ty From a1168613bfacec20de26ca8714467ab3ce70c32a Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Mon, 11 Sep 2023 13:16:16 -0500 Subject: [PATCH 35/51] Expand choose op desugaring to modes, contract calls, and contract node decls --- src/lustre/lustreDesugarChooseOps.ml | 29 +++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index b14419a7c..9782c4524 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -177,9 +177,20 @@ | Guarantee (pos, name, b, e) -> let e, gen_nodes = desugar_expr ctx node_name e in Guarantee (pos, name, b, e), gen_nodes + | Mode (pos, i, reqs, enss) -> + let (reqs, gen_nodes1) = + List.map (fun (pos, id, expr) -> (pos, id, desugar_expr ctx node_name expr)) reqs |> + List.map (fun (pos, id, (expr, decls)) -> ((pos, id, expr), decls)) |> + List.split in + let (enss, gen_nodes2) = + List.map (fun (pos, id, expr) -> (pos, id, desugar_expr ctx node_name expr)) enss |> + List.map (fun (pos, id, (expr, decls)) -> ((pos, id, expr), decls)) |> + List.split in + Mode (pos, i, reqs, enss), (List.flatten gen_nodes1) @ (List.flatten gen_nodes2) + | ContractCall (pos, i, exprs, ids) -> + let (exprs, gen_nodes) = List.map (desugar_expr ctx node_name) exprs |> List.split in + ContractCall (pos, i, exprs, ids), List.flatten gen_nodes | GhostConst _ - | Mode _ - | ContractCall _ | AssumptionVars _ -> ci, [] let desugar_contract ctx node_name contract = @@ -243,7 +254,19 @@ (* If there is an error in context collection, it will be detected later in type checking *) | Error _ -> decl :: decls ) - | _ -> decl :: decls + | A.ContractNodeDecl (span, (id, params, inputs, outputs, contract)) -> + ( + match Chk.get_node_ctx ctx ((), (), (), inputs, outputs, [], (), ()) with (* Unit type params are unused in function *) + | Ok ctx -> + let contract, gen_nodes = desugar_contract ctx id (Some contract) in + let contract = match contract with + | Some contract -> contract + | None -> assert false in (* Must have a contract *) + decls @ gen_nodes @ [A.ContractNodeDecl (span, (id, params, inputs, outputs, contract))] + (* If there is an error in context collection, it will be detected later in type checking *) + | Error _ -> decl :: decls + ) + | _ -> decl :: decls ) [] decls in decls From 95423d44a27be082aa8e5a1e02b819c067f619f7 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Mon, 11 Sep 2023 13:54:53 -0500 Subject: [PATCH 36/51] Do best effort to pinpoint choose op items --- src/lustre/lustreDesugarChooseOps.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 9782c4524..24df925f3 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -34,11 +34,11 @@ let rec desugar_expr ctx node_name = function | A.ChooseOp (pos, (_, id, ty), expr1, expr2_opt) -> - let span = { A.start_pos = Lib.dummy_pos; A.end_pos = Lib.dummy_pos } in + let span = { A.start_pos = pos; A.end_pos = Lib.dummy_pos } in let contract = match expr2_opt with - | None -> [A.Guarantee (Lib.dummy_pos, None, false, expr1)] - | Some expr2 -> [A.Assume (Lib.dummy_pos, None, false, expr2); - A.Guarantee (Lib.dummy_pos, None, false, expr1)] in + | None -> [A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] + | Some expr2 -> [A.Assume (AH.pos_of_expr expr2, None, false, expr2); + A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] in let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr1) (Ctx.SI.singleton id)) in (* Constants don't need to be passed as a parameter to generated node *) let inputs = List.filter (fun i -> not (Ctx.member_val ctx i)) inputs in @@ -53,7 +53,7 @@ let generated_node = A.NodeDecl (span, (name, true, [], inputs, - [Lib.dummy_pos, id, ty, A.ClockTrue], [], [], Some contract)) + [pos, id, ty, A.ClockTrue], [], [], Some contract)) in A.Call(pos, name, inputs_call), [generated_node] From 33a06436a0a78534c686b05281426358a774f4f2 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Mon, 11 Sep 2023 15:49:01 -0500 Subject: [PATCH 37/51] Pass variables from 'provided' clause of choose op into generated node (bug fix) --- src/lustre/lustreDesugarChooseOps.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 24df925f3..0e5c3198b 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -36,10 +36,14 @@ | A.ChooseOp (pos, (_, id, ty), expr1, expr2_opt) -> let span = { A.start_pos = pos; A.end_pos = Lib.dummy_pos } in let contract = match expr2_opt with - | None -> [A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] - | Some expr2 -> [A.Assume (AH.pos_of_expr expr2, None, false, expr2); - A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] in - let inputs = Ctx.SI.elements (Ctx.SI.diff (AH.vars expr1) (Ctx.SI.singleton id)) in + | None -> [A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] + | Some expr2 -> [A.Assume (AH.pos_of_expr expr2, None, false, expr2); + A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] + in + let inputs = match expr2_opt with + | None -> Ctx.SI.elements (Ctx.SI.diff (AH.vars expr1) (Ctx.SI.singleton id)) + | Some expr2 -> Ctx.SI.elements (Ctx.SI.diff (Ctx.SI.union (AH.vars expr1) (AH.vars expr2)) (Ctx.SI.singleton id)) + in (* Constants don't need to be passed as a parameter to generated node *) let inputs = List.filter (fun i -> not (Ctx.member_val ctx i)) inputs in let inputs_call = List.map (fun str -> A.Ident (pos, str)) inputs in From 6aee3176444e337314afa5de6811587539f0e154 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 12 Sep 2023 11:17:24 -0500 Subject: [PATCH 38/51] Finish pending issue of choose op pipeline reordering by commenting out/removing unused code --- src/lustre/lustreAstDependencies.ml | 12 ++---------- src/lustre/lustreAstHelpers.ml | 2 +- src/lustre/lustreTypeChecker.ml | 14 ++++++++------ 3 files changed, 11 insertions(+), 17 deletions(-) diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 3b5a0e1a9..2f0780afc 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -639,10 +639,7 @@ let rec vars_with_flattened_nodes: node_summary -> int -> LA.expr -> LA.SI.t SI.diff (r e) (SI.flatten (List.map LH.vars_of_ty_ids qs)) (* Choose operator *) - | ChooseOp (_, (_, i, _), e, None) -> - SI.diff (r e) (SI.singleton i) - | ChooseOp (_, (_, i, _), e1, Some e2) -> - SI.diff (SI.union (r e1) (r e2)) (SI.singleton i) + | ChooseOp _ -> assert false (* Already desugared in lustreDesugarChooseOps *) (* Clock operators *) | When (_, e, _) -> r e @@ -816,12 +813,7 @@ let rec mk_graph_expr2: node_summary -> LA.expr -> (dependency_analysis_data lis empty_dependency_analysis_data (List.concat gs)] - | LA.ChooseOp (_, _, e, None) -> mk_graph_expr2 m e - | LA.ChooseOp (_, _, e1, Some e2) -> - mk_graph_expr2 m e1 >>= fun g1 -> - mk_graph_expr2 m e2 >>= fun g2 -> - R.ok [List.fold_left union_dependency_analysis_data empty_dependency_analysis_data - (g1 @ g2) ] + | LA.ChooseOp _ -> assert false (* Already desugared in lustreDesugarChooseOps *) | LA.When (_, e, _) -> mk_graph_expr2 m e | LA.Current (_, e) -> mk_graph_expr2 m e | LA.Condact (pos, _, _, n, e1s, e2s) -> diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index a17d02e2b..91d9db36b 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -668,7 +668,7 @@ let rec vars: expr -> iset = function | Fby (_, e1, _, e2) -> SI.union (vars e1) (vars e2) | Arrow (_, e1, e2) -> SI.union (vars e1) (vars e2) (* Node calls *) - | Call (_, i, es) -> SI.add i (SI.flatten (List.map vars es)) + | Call (_, _, es) -> SI.flatten (List.map vars es) | CallParam (_, i, _, es) -> SI.add i (SI.flatten (List.map vars es)) let rec vars_of_struct_item_with_pos = function diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index 378e2afa6..a35935cc1 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -443,9 +443,10 @@ let rec infer_type_expr: tc_context -> LA.expr -> (tc_type, [> error]) result (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in infer_type_expr extn_ctx e - | ChooseOp (_, (_, _, ty), _, _) as e -> - check_type_expr ctx e ty >> - R.ok ty + | ChooseOp _ -> assert false + (* Already desugared in lustreDesugarChooseOps *) + (*check_type_expr ctx e ty >> + R.ok ty*) (* Clock operators *) | LA.When (_, e, _) -> infer_type_expr ctx e | LA.Current (_, e) -> infer_type_expr ctx e @@ -644,15 +645,16 @@ and check_type_expr: tc_context -> LA.expr -> tc_type -> (unit, [> error]) resul (List.map (fun (_, i, ty) -> singleton_ty i ty) qs) in check_type_expr extn_ctx e exp_ty - | ChooseOp (pos, (_, i ,ty), e, None) -> - let extn_ctx = union ctx (singleton_ty i ty) in + | ChooseOp _ -> assert false + (* Already desugared in lustreDesugarChooseOps *) + (*let extn_ctx = union ctx (singleton_ty i ty) in check_type_expr extn_ctx e (Bool pos) >> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) | ChooseOp (pos, (_, i ,ty), e1, Some e2) -> let extn_ctx = union ctx (singleton_ty i ty) in check_type_expr extn_ctx e1 (Bool pos) >> check_type_expr extn_ctx e2 (Bool pos) - >> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty))) + >> R.guard_with (eq_lustre_type ctx exp_ty ty) (type_error pos (UnificationFailed (exp_ty, ty)))*) (* Clock operators *) | When (_, e, _) -> check_type_expr ctx e exp_ty | Current (_, e) -> check_type_expr ctx e exp_ty From 6381c89c5c27927f0d6f935873bc9c5721c07f72 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 12 Sep 2023 11:28:18 -0500 Subject: [PATCH 39/51] Revert 'vars' function in LAH to its original state as Daniel will handle this issue --- src/lustre/lustreAstHelpers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index 91d9db36b..47d7cd76c 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -668,7 +668,7 @@ let rec vars: expr -> iset = function | Fby (_, e1, _, e2) -> SI.union (vars e1) (vars e2) | Arrow (_, e1, e2) -> SI.union (vars e1) (vars e2) (* Node calls *) - | Call (_, _, es) -> SI.flatten (List.map vars es) + | Call (_, i, es) -> SI.add i (SI.flatten (List.map vars es)) | CallParam (_, i, _, es) -> SI.add i (SI.flatten (List.map vars es)) let rec vars_of_struct_item_with_pos = function From 2e5e85032f0d5532123c031cb8038578affb1d56 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 12 Sep 2023 11:38:44 -0500 Subject: [PATCH 40/51] Update substitute function to error out on cases that introduce bound variables --- src/lustre/lustreArrayDependencies.ml | 2 +- src/lustre/lustreAstHelpers.ml | 69 +++++++++++++-------------- src/lustre/lustreAstHelpers.mli | 5 +- src/lustre/lustreAstNormalizer.ml | 2 +- 4 files changed, 39 insertions(+), 39 deletions(-) diff --git a/src/lustre/lustreArrayDependencies.ml b/src/lustre/lustreArrayDependencies.ml index dbd34dff4..af53fd267 100644 --- a/src/lustre/lustreArrayDependencies.ml +++ b/src/lustre/lustreArrayDependencies.ml @@ -178,7 +178,7 @@ and process_expr ind_vars ctx ns proj indices expr = (match ind_vars with | Some ind_vars' -> let ind_var = List.hd ind_vars' in - let idx' = AH.substitute ind_var zero idx in + let idx' = AH.substitute_naive ind_var zero idx in (match AIC.eval_int_expr ctx idx' with | Ok idx' -> let idx_vars = AH.vars idx in diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index 47d7cd76c..b0af3f7f3 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -100,64 +100,63 @@ let rec type_contains_subrange = function | ArrayType (_, (ty, _)) -> type_contains_subrange ty | _ -> false -let rec substitute (var:HString.t) t = function +(* Substitute t for var. ChooseOp and Quantifier are not supported due to introduction of bound variables. *) +let rec substitute_naive (var:HString.t) t = function | Ident (_, i) as e -> if i = var then t else e | ModeRef (_, _) as e -> e - | RecordProject (pos, e, idx) -> RecordProject (pos, substitute var t e, idx) - | TupleProject (pos, e, idx) -> TupleProject (pos, substitute var t e, idx) + | RecordProject (pos, e, idx) -> RecordProject (pos, substitute_naive var t e, idx) + | TupleProject (pos, e, idx) -> TupleProject (pos, substitute_naive var t e, idx) | Const (_, _) as e -> e - | UnaryOp (pos, op, e) -> UnaryOp (pos, op, substitute var t e) + | UnaryOp (pos, op, e) -> UnaryOp (pos, op, substitute_naive var t e) | BinaryOp (pos, op, e1, e2) -> - BinaryOp (pos, op, substitute var t e1, substitute var t e2) + BinaryOp (pos, op, substitute_naive var t e1, substitute_naive var t e2) | TernaryOp (pos, op, e1, e2, e3) -> - TernaryOp (pos, op, substitute var t e1, substitute var t e2, substitute var t e3) + TernaryOp (pos, op, substitute_naive var t e1, substitute_naive var t e2, substitute_naive var t e3) | NArityOp (pos, op, expr_list) -> - NArityOp (pos, op, List.map (fun e -> substitute var t e) expr_list) - | ConvOp (pos, op, e) -> ConvOp (pos, op, substitute var t e) + NArityOp (pos, op, List.map (fun e -> substitute_naive var t e) expr_list) + | ConvOp (pos, op, e) -> ConvOp (pos, op, substitute_naive var t e) | CompOp (pos, op, e1, e2) -> - CompOp (pos, op, substitute var t e1, substitute var t e2) - | ChooseOp (pos, i, e1, None) -> ChooseOp(pos, i, substitute var t e1, None) - | ChooseOp (pos, i, e1, Some e2) -> ChooseOp(pos, i, substitute var t e1, Some (substitute var t e2)) + CompOp (pos, op, substitute_naive var t e1, substitute_naive var t e2) + | ChooseOp _ -> assert false (* Not supported due to introduction of bound variables *) + | Quantifier _ -> assert false (* Not supported due to introduction of bound variables *) | RecordExpr (pos, ident, expr_list) -> - RecordExpr (pos, ident, List.map (fun (i, e) -> (i, substitute var t e)) expr_list) + RecordExpr (pos, ident, List.map (fun (i, e) -> (i, substitute_naive var t e)) expr_list) | GroupExpr (pos, kind, expr_list) -> - GroupExpr (pos, kind, List.map (fun e -> substitute var t e) expr_list) + GroupExpr (pos, kind, List.map (fun e -> substitute_naive var t e) expr_list) | StructUpdate (pos, e1, idx, e2) -> - StructUpdate (pos, substitute var t e1, idx, substitute var t e2) + StructUpdate (pos, substitute_naive var t e1, idx, substitute_naive var t e2) | ArrayConstr (pos, e1, e2) -> - ArrayConstr (pos, substitute var t e1, substitute var t e2) + ArrayConstr (pos, substitute_naive var t e1, substitute_naive var t e2) | ArraySlice (pos, e1, (e2, e3)) -> - ArraySlice (pos, substitute var t e1, (substitute var t e2, substitute var t e3)) + ArraySlice (pos, substitute_naive var t e1, (substitute_naive var t e2, substitute_naive var t e3)) | ArrayIndex (pos, e1, e2) -> - ArrayIndex (pos, substitute var t e1, substitute var t e2) + ArrayIndex (pos, substitute_naive var t e1, substitute_naive var t e2) | ArrayConcat (pos, e1, e2) -> - ArrayConcat (pos, substitute var t e1, substitute var t e2) - | Quantifier (pos, kind, idents, e) -> - Quantifier (pos, kind, idents, substitute var t e) - | When (pos, e, clock) -> When (pos, substitute var t e, clock) - | Current (pos, e) -> Current (pos, substitute var t e) + ArrayConcat (pos, substitute_naive var t e1, substitute_naive var t e2) + | When (pos, e, clock) -> When (pos, substitute_naive var t e, clock) + | Current (pos, e) -> Current (pos, substitute_naive var t e) | Condact (pos, e1, e2, id, expr_list1, expr_list2) -> - let e1, e2 = substitute var t e1, substitute var t e2 in - let expr_list1 = List.map (fun e -> substitute var t e) expr_list1 in - let expr_list2 = List.map (fun e -> substitute var t e) expr_list2 in + let e1, e2 = substitute_naive var t e1, substitute_naive var t e2 in + let expr_list1 = List.map (fun e -> substitute_naive var t e) expr_list1 in + let expr_list2 = List.map (fun e -> substitute_naive var t e) expr_list2 in Condact (pos, e1, e2, id, expr_list1, expr_list2) | Activate (pos, ident, e1, e2, expr_list) -> - let e1, e2 = substitute var t e1, substitute var t e2 in - let expr_list = List.map (fun e -> substitute var t e) expr_list in + let e1, e2 = substitute_naive var t e1, substitute_naive var t e2 in + let expr_list = List.map (fun e -> substitute_naive var t e) expr_list in Activate (pos, ident, e1, e2, expr_list) | Merge (pos, ident, expr_list) -> - Merge (pos, ident, List.map (fun (i, e) -> (i, substitute var t e)) expr_list) + Merge (pos, ident, List.map (fun (i, e) -> (i, substitute_naive var t e)) expr_list) | RestartEvery (pos, ident, expr_list, e) -> - let expr_list = List.map (fun e -> substitute var t e) expr_list in - let e = substitute var t e in + let expr_list = List.map (fun e -> substitute_naive var t e) expr_list in + let e = substitute_naive var t e in RestartEvery (pos, ident, expr_list, e) - | Pre (pos, e) -> Pre (pos, substitute var t e) - | Fby (pos, e1, i, e2) -> Fby (pos, substitute var t e1, i, substitute var t e2) - | Arrow (pos, e1, e2) -> Arrow (pos, substitute var t e1, substitute var t e2) + | Pre (pos, e) -> Pre (pos, substitute_naive var t e) + | Fby (pos, e1, i, e2) -> Fby (pos, substitute_naive var t e1, i, substitute_naive var t e2) + | Arrow (pos, e1, e2) -> Arrow (pos, substitute_naive var t e1, substitute_naive var t e2) | Call (pos, id, expr_list) -> - Call (pos, id, List.map (fun e -> substitute var t e) expr_list) + Call (pos, id, List.map (fun e -> substitute_naive var t e) expr_list) | CallParam (pos, id, types, expr_list) -> - CallParam (pos, id, types, List.map (fun e -> substitute var t e) expr_list) + CallParam (pos, id, types, List.map (fun e -> substitute_naive var t e) expr_list) let rec has_unguarded_pre ung = function | Const _ | Ident _ | ModeRef _ -> false diff --git a/src/lustre/lustreAstHelpers.mli b/src/lustre/lustreAstHelpers.mli index 38fdc8a8e..6f49a4459 100644 --- a/src/lustre/lustreAstHelpers.mli +++ b/src/lustre/lustreAstHelpers.mli @@ -48,8 +48,9 @@ val type_arity : lustre_type -> int * int val type_contains_subrange : lustre_type -> bool (** Returns true if the lustre type expression contains an IntRange or if it is an IntRange *) -val substitute : HString.t -> expr -> expr -> expr -(** Subsitute the supplied identifier and expression into the last expression *) +val substitute_naive : HString.t -> expr -> expr -> expr +(** Substitute second param for first param in third param. + ChooseOp and Quantifier are not supported due to introduction of bound variables. *) val has_unguarded_pre : expr -> bool (** Returns true if the expression has unguareded pre's *) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index 96b37c8c5..d163f86bf 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -1144,7 +1144,7 @@ and abstract_expr ?guard force info map is_ghost expr = and expand_node_call info expr var count = let ty = Chk.infer_type_expr info.context expr |> unwrap in let mk_index i = A.Const (dpos, Num (HString.mk_hstring (string_of_int i))) in - let expr_array = List.init count (fun i -> AH.substitute var (mk_index i) expr) in + let expr_array = List.init count (fun i -> AH.substitute_naive var (mk_index i) expr) in match ty with | A.ArrayType _ -> A.GroupExpr (dpos, ArrayExpr, expr_array) | _ -> List.fold_left From cd58f4e776d261dfae5cc0ca5ac9e2016d9012ba Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 12 Sep 2023 13:14:10 -0500 Subject: [PATCH 41/51] Disallow node calls and choose ops in constants --- src/lustre/lustreSyntaxChecks.ml | 30 +++++++++++++++++++----------- src/lustre/lustreSyntaxChecks.mli | 1 + 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index ec5d23731..40a8849a5 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -48,6 +48,7 @@ type error_kind = Unknown of string | SymbolicArrayIndexInNodeArgument of HString.t * HString.t | NodeCallInFunction of HString.t | NodeCallInRefinableContract of string * HString.t + | NodeCallInConstant of HString.t | IllegalTemporalOperator of string * string | IllegalImportOfStatefulContract of HString.t | UnsupportedClockedInputOrOutput @@ -95,6 +96,7 @@ let error_message kind = match kind with | NodeCallInRefinableContract (kind, node) -> "Illegal call to " ^ kind ^ " '" ^ HString.string_of_hstring node ^ "' in the cone of influence of this contract: " ^ kind ^ " " ^ HString.string_of_hstring node ^ " has a refinable contract" + | NodeCallInConstant id -> "Illegal node call or choose operator in definition of constant " ^ HString.string_of_hstring id | IllegalTemporalOperator (kind, variant) -> "Illegal " ^ kind ^ " in " ^ variant ^ " definition, " ^ variant ^ "s cannot have state" | IllegalImportOfStatefulContract contract -> "Illegal import of stateful contract '" @@ -405,6 +407,9 @@ let no_dangling_identifiers ctx = function no_a_dangling_identifier ctx pos i | _ -> Ok () +let no_node_calls_in_constant pos i e = + if LAH.expr_contains_call e then syntax_error pos (NodeCallInConstant i) else Ok () + let no_quant_var_or_symbolic_index_in_node_call ctx = function | LA.Call (pos, i, args) -> let vars = List.flatten (List.map (fun e -> LA.SI.elements (LAH.vars e)) args) in @@ -570,8 +575,8 @@ and check_declaration ctx = function | ConstDecl (span, decl) -> let check = match decl with | LA.FreeConst _ -> Ok () - | UntypedConst (_, _, e) - | TypedConst (_, _, e, _) -> check_const_expr_decl ctx e + | UntypedConst (pos, i, e) + | TypedConst (pos, i, e, _) -> check_const_expr_decl pos i ctx e in check >> Ok (LA.ConstDecl (span, decl)) | NodeDecl (span, decl) -> check_node_decl ctx span decl @@ -579,12 +584,13 @@ and check_declaration ctx = function | ContractNodeDecl (span, decl) -> check_contract_node_decl ctx span decl | NodeParamInst (span, _) -> syntax_error span.start_pos UnsupportedParametricDeclaration -and check_const_expr_decl ctx expr = - let composed_checks ctx e = +and check_const_expr_decl pos i ctx expr = + let composed_checks pos i ctx e = (no_temporal_operator "constant" e) >> (no_dangling_identifiers ctx e) + >> (no_node_calls_in_constant pos i e) in - check_expr ctx composed_checks expr + check_expr ctx (composed_checks pos i) expr and common_node_equations_checks ctx e = (unsupported_expr e) @@ -611,8 +617,10 @@ and check_input_items (pos, _id, _ty, clock, _const) = and check_output_items (pos, _id, _ty, clock) = no_clock_inputs_or_outputs pos clock -and check_local_items local = match local with - | LA.NodeConstDecl _ -> Ok () +and check_local_items ctx local = match local with + | LA.NodeConstDecl (_, FreeConst _) -> Ok () + | LA.NodeConstDecl (pos, UntypedConst (_, i, e)) -> check_const_expr_decl pos i ctx e + | LA.NodeConstDecl (pos, TypedConst (_, i, e, _)) -> check_const_expr_decl pos i ctx e | NodeVarDecl (_, (_, _, _, LA.ClockTrue)) -> Ok () | NodeVarDecl (_, (pos, i, _, _)) -> syntax_error pos (UnsupportedClockedLocal i) @@ -637,7 +645,7 @@ and check_node_decl ctx span (id, ext, params, inputs, outputs, locals, items, c ) >> (Res.seq_ (List.map check_input_items inputs)) >> (Res.seq_ (List.map check_output_items outputs)) - >> (Res.seq_ (List.map check_local_items locals)) + >> (Res.seq_ (List.map (check_local_items ctx) locals)) >> (Ok decl) and check_func_decl ctx span (id, ext, params, inputs, outputs, locals, items, contract) = @@ -667,7 +675,7 @@ and check_func_decl ctx span (id, ext, params, inputs, outputs, locals, items, c >> (Res.seq_ (List.map no_reachability_modifiers items)) >> (Res.seq_ (List.map check_input_items inputs)) >> (Res.seq_ (List.map check_output_items outputs)) - >> (Res.seq_ (List.map check_local_items locals)) + >> (Res.seq_ (List.map (check_local_items ctx) locals)) >> (Ok decl) and check_contract_node_decl ctx span (id, params, inputs, outputs, contract) = @@ -757,8 +765,8 @@ and check_contract is_contract_node ctx f contract = | GhostConst decl -> ( let check = match decl with | LA.FreeConst _ -> Ok () - | UntypedConst (_, _, e) - | TypedConst (_, _, e, _) -> check_const_expr_decl ctx e + | UntypedConst (pos, i, e) + | TypedConst (pos, i, e, _) -> check_const_expr_decl pos i ctx e in check >> Ok () ) diff --git a/src/lustre/lustreSyntaxChecks.mli b/src/lustre/lustreSyntaxChecks.mli index ce4ae29d1..9d0ce741b 100644 --- a/src/lustre/lustreSyntaxChecks.mli +++ b/src/lustre/lustreSyntaxChecks.mli @@ -31,6 +31,7 @@ type error_kind = Unknown of string | SymbolicArrayIndexInNodeArgument of HString.t * HString.t | NodeCallInFunction of HString.t | NodeCallInRefinableContract of string * HString.t + | NodeCallInConstant of HString.t | IllegalTemporalOperator of string * string | IllegalImportOfStatefulContract of HString.t | UnsupportedClockedInputOrOutput From 434d87c3930d2a1b76da6d44615f0803fc206af7 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Tue, 12 Sep 2023 15:34:45 -0500 Subject: [PATCH 42/51] Change vars function so that it does not return node call ids --- src/lustre/lustreArrayDependencies.ml | 10 +++++--- src/lustre/lustreAstDependencies.ml | 2 +- src/lustre/lustreAstHelpers.ml | 37 +++++++++++++++------------ src/lustre/lustreAstHelpers.mli | 16 +++++++----- src/lustre/lustreAstNormalizer.ml | 33 ++++++++++++------------ src/lustre/lustreDesugarChooseOps.ml | 12 ++++++--- src/lustre/lustreNodeGen.ml | 5 +--- src/lustre/lustreSyntaxChecks.ml | 11 +++++--- src/lustre/lustreTypeChecker.ml | 13 +++++++--- 9 files changed, 82 insertions(+), 57 deletions(-) diff --git a/src/lustre/lustreArrayDependencies.ml b/src/lustre/lustreArrayDependencies.ml index af53fd267..289efd4d3 100644 --- a/src/lustre/lustreArrayDependencies.ml +++ b/src/lustre/lustreArrayDependencies.ml @@ -181,11 +181,15 @@ and process_expr ind_vars ctx ns proj indices expr = let idx' = AH.substitute_naive ind_var zero idx in (match AIC.eval_int_expr ctx idx' with | Ok idx' -> - let idx_vars = AH.vars idx in - if A.SI.cardinal idx_vars = 1 && A.SI.mem ind_var idx_vars then + let idx_vars = AH.vars_without_node_call_ids idx in + if A.SI.cardinal idx_vars = 1 && + A.SI.mem ind_var idx_vars && + not (AH.expr_contains_call idx) + then let ind_vars = Some (List.tl ind_vars') in process_expr ind_vars ctx ns proj (idx' :: indices) e - else mk_error p (ExprMissingIndex (ind_var, idx)) + else + mk_error p (ExprMissingIndex (ind_var, idx)) | Error _ -> mk_error p (ComplicatedExpr idx)) | None -> r e) else r e diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 2f0780afc..7732691e9 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -1026,7 +1026,7 @@ let check_eqn_no_current_vals: LA.SI.t -> dependency_analysis_data -> LA.expr -> Debug.parse "node_params: %a non pre vars of e: %a" (Lib.pp_print_list LA.pp_print_ident ", ") (SI.elements node_out_streams) (Lib.pp_print_list LA.pp_print_ident ", ") - (SI.elements (LH.vars (LH.abstract_pre_subexpressions e))); + (SI.elements (LH.vars_without_node_call_ids (LH.abstract_pre_subexpressions e))); R.guard_with (R.ok (SI.is_empty assume_vars_out_streams)) (graph_error (LH.pos_of_expr e) (ContractDependencyOnCurrentOutput assume_vars_out_streams)) diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index b0af3f7f3..6f4356664 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -578,11 +578,15 @@ let vars_of_clock_expr: clock_expr -> iset = function | ClockNeg i -> SI.singleton i | ClockConstr (i1, i2) -> SI.of_list [i1; i2] +let mk_mode_ref_id ids = + Format.asprintf "%a" (Lib.pp_print_list pp_print_ident "::") ids + |> HString.mk_hstring + let rec vars_of_node_calls_h obs = let vars obs = vars_of_node_calls_h obs in function | Ident (_, i) -> if obs then SI.singleton i else SI.empty - | ModeRef (_, is) -> if obs then SI.of_list is else SI.empty + | ModeRef (_, is) -> if obs then SI.singleton (mk_mode_ref_id is) else SI.empty | RecordProject (_, e, _) -> vars obs e | TupleProject (_, e, _) -> vars obs e (* Values *) @@ -594,8 +598,8 @@ let rec vars_of_node_calls_h obs = | NArityOp (_, _,es) -> SI.flatten (List.map (vars obs) es) | ConvOp (_,_,e) -> vars obs e | CompOp (_,_,e1, e2) -> (vars obs e1) |> SI.union (vars obs e2) - | ChooseOp (_, (_, i, _), e, None) -> SI.diff (vars obs e) (SI.singleton i) - | ChooseOp (_, (_, i, _), e1, Some e2) -> SI.diff (SI.union (vars obs e1) (vars obs e2)) (SI.singleton i) + | ChooseOp (_, (_, i, _), e, None) -> SI.diff (vars true e) (SI.singleton i) + | ChooseOp (_, (_, i, _), e1, Some e2) -> SI.diff (SI.union (vars true e1) (vars true e2)) (SI.singleton i) (* Structured expressions *) | RecordExpr (_, _, flds) -> SI.flatten (List.map (vars obs) (snd (List.split flds))) | GroupExpr (_, _, es) -> SI.flatten (List.map (vars obs) es) @@ -610,26 +614,27 @@ let rec vars_of_node_calls_h obs = (* Clock operators *) | When (_, e, clkE) -> SI.union (vars obs e) (vars_of_clock_expr clkE) | Current (_, e) -> vars obs e - | Condact (_, e1, e2, i, es1, es2) -> - SI.add i (SI.flatten (vars obs e1 :: vars obs e2:: (List.map (vars obs) es1) @ (List.map (vars obs) es2))) + | Condact (_, e1, e2, _, es1, es2) -> + SI.flatten (vars obs e1 :: vars obs e2:: (List.map (vars obs) es1) @ (List.map (vars obs) es2)) | Activate (_, _, e1, e2, es) -> SI.flatten (vars obs e1 :: vars obs e2 :: List.map (vars obs) es) | Merge (_, _, es) -> List.split es |> snd |> List.map (vars obs) |> SI.flatten - | RestartEvery (_, i, es, e) -> SI.add i (SI.flatten (vars obs e :: List.map (vars obs) es)) + | RestartEvery (_, _, es, e) -> SI.flatten (vars obs e :: List.map (vars obs) es) (* Temporal operators *) | Pre (_, e) -> vars obs e | Fby (_, e1, _, e2) -> SI.union (vars obs e1) (vars obs e2) | Arrow (_, e1, e2) -> SI.union (vars obs e1) (vars obs e2) (* Node calls *) - | Call (_, i, es) -> SI.add i (SI.flatten (List.map (vars true) es)) - | CallParam (_, i, _, es) -> SI.add i (SI.flatten (List.map (vars obs) es)) + | Call (_, _, es) -> SI.flatten (List.map (vars true) es) + | CallParam (_, _, _, es) -> SI.flatten (List.map (vars obs) es) (** returns all identifiers from the [expr] ast that are inside node calls *) let vars_of_node_calls = vars_of_node_calls_h false -(** returns all identifiers from the [expr] ast*) -let rec vars: expr -> iset = function +let rec vars_without_node_call_ids: expr -> iset = + let vars = vars_without_node_call_ids in + function | Ident (_, i) -> SI.singleton i - | ModeRef (_, is) -> SI.of_list is + | ModeRef (_, is) -> SI.singleton (mk_mode_ref_id is) | RecordProject (_, e, _) -> vars e | TupleProject (_, e, _) -> vars e (* Values *) @@ -655,11 +660,11 @@ let rec vars: expr -> iset = function (* Clock operators *) | When (_, e, clkE) -> SI.union (vars e) (vars_of_clock_expr clkE) | Current (_, e) -> vars e - | Condact (_, e1, e2, i, es1, es2) -> - SI.add i (SI.flatten (vars e1 :: vars e2:: (List.map vars es1) @ (List.map vars es2))) + | Condact (_, e1, e2, _, es1, es2) -> + SI.flatten (vars e1 :: vars e2:: (List.map vars es1) @ (List.map vars es2)) | Activate (_, _, e1, e2, es) -> SI.flatten (vars e1 :: vars e2 :: List.map vars es) | Merge (_, _, es) -> List.split es |> snd |> List.map vars |> SI.flatten - | RestartEvery (_, i, es, e) -> SI.add i (SI.flatten (vars e :: List.map vars es)) + | RestartEvery (_, _, es, e) -> SI.flatten (vars e :: List.map vars es) | ChooseOp (_, (_, i, _), e, None) -> SI.diff (vars e) (SI.singleton i) | ChooseOp (_, (_, i, _), e1, Some e2) -> SI.diff (SI.union (vars e1) (vars e2)) (SI.singleton i) (* Temporal operators *) @@ -667,8 +672,8 @@ let rec vars: expr -> iset = function | Fby (_, e1, _, e2) -> SI.union (vars e1) (vars e2) | Arrow (_, e1, e2) -> SI.union (vars e1) (vars e2) (* Node calls *) - | Call (_, i, es) -> SI.add i (SI.flatten (List.map vars es)) - | CallParam (_, i, _, es) -> SI.add i (SI.flatten (List.map vars es)) + | Call (_, _, es) -> SI.flatten (List.map vars es) + | CallParam (_, _, _, es) -> SI.flatten (List.map vars es) let rec vars_of_struct_item_with_pos = function | SingleIdent (p, i) -> [(p, i)] diff --git a/src/lustre/lustreAstHelpers.mli b/src/lustre/lustreAstHelpers.mli index 6f49a4459..7d3209fe4 100644 --- a/src/lustre/lustreAstHelpers.mli +++ b/src/lustre/lustreAstHelpers.mli @@ -73,22 +73,24 @@ val node_item_has_pre_or_arrow : node_item -> Lib.position option (** Checks whether a node equation has a `pre` or a `->`. *) val vars_of_node_calls: expr -> SI.t -(** returns all identifiers from the [expr] ast that are inside node calls *) +(** [vars_of_node_calls e] returns all variable identifiers within arguments of node calls that + appear in the expression [e] (while excluding node call identifiers) *) -val vars: expr -> SI.t -(** returns all the [ident] that appear in the expr ast*) +val vars_without_node_call_ids: expr -> SI.t +(** [vars_without_node_call_ids e] returns all variable identifiers that appear in the expression [e] + while excluding node call identifiers *) val vars_of_struct_item_with_pos: struct_item -> (Lib.position * index) list -(** returns all variables that appear in a [struct_item] with associated positions *) +(** returns all variables that appear in a [struct_item] (the lhs of an equation) with associated positions *) val vars_of_struct_item: struct_item -> SI.t -(** returns all variables that appear in a [struct_item] *) +(** returns all variables that appear in a [struct_item] (the lhs of an equation) *) val defined_vars_with_pos: node_item -> (Lib.position * index) list (** returns all the variables that appear in the lhs of the equation of the node body with associated positions *) val vars_of_ty_ids: typed_ident -> SI.t -(** returns all the variables that occur in the expression of a typed identifier declaration *) +(** returns a singleton set with the only identifier in a typed identifier declaration *) val add_exp: Lib.position -> expr -> expr -> expr (** Return an AST that adds two expressions*) @@ -185,4 +187,4 @@ val rename_contract_vars : expr -> expr (** Rename contract variables from internal names (with format #_contract_var) to syntax names *) val name_of_prop : Lib.position -> HString.t option -> LustreAst.prop_kind -> HString.t -(** Get the name associated with a property *) \ No newline at end of file +(** Get the name associated with a property *) diff --git a/src/lustre/lustreAstNormalizer.ml b/src/lustre/lustreAstNormalizer.ml index d163f86bf..96af2cac0 100644 --- a/src/lustre/lustreAstNormalizer.ml +++ b/src/lustre/lustreAstNormalizer.ml @@ -315,13 +315,15 @@ let dpos = Lib.dummy_pos let union_list ids = List.fold_left (fun x y -> union x y ) (empty ()) ids +let get_inductive_vars ind_vars expr = + let vars = AH.vars_without_node_call_ids expr in + let ind_vars = List.map fst (StringMap.bindings ind_vars) in + List.filter (fun x -> A.SI.mem x vars) ind_vars + let expr_has_inductive_var ind_vars expr = - let vars = AH.vars expr in - let ind_vars = List.map (fun (i, _) -> i) (StringMap.bindings ind_vars) in - let ind_vars = List.filter (fun x -> A.SI.mem x vars) ind_vars in - match ind_vars with - | [] -> None - | h :: _ -> Some h + match get_inductive_vars ind_vars expr with + | [] -> false + | _ -> true let new_contract_reference () = contract_ref := ! contract_ref + 1; @@ -333,15 +335,12 @@ let extract_array_size = function | _ -> assert false) | _ -> assert false -let generalize_to_array_expr name ind_vars expr nexpr = - let vars = AH.vars expr in - let ind_vars = List.map fst (StringMap.bindings ind_vars) in - let ind_vars = List.filter (fun x -> A.SI.mem x vars) ind_vars in +let generalize_to_array_expr name ind_vars expr nexpr = let (eq_lhs, nexpr) = - match ind_vars with + match get_inductive_vars ind_vars expr with | [] -> A.StructDef (dpos, [SingleIdent (dpos, name)]), nexpr - | _ -> + | ind_vars -> A.StructDef (dpos, [ArrayDef (dpos, name, ind_vars)]), A.ArrayIndex (dpos, nexpr, A.Ident (dpos, List.hd ind_vars)) in @@ -1134,7 +1133,7 @@ and abstract_expr ?guard force info map is_ghost expr = else let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in - let ty = if expr_has_inductive_var ivars expr |> is_some then + let ty = if expr_has_inductive_var ivars expr then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in @@ -1180,7 +1179,7 @@ and normalize_expr ?guard info map = let abstract_array_literal info expr nexpr = let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in - let ty = if expr_has_inductive_var ivars expr |> is_some then + let ty = if expr_has_inductive_var ivars expr then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in @@ -1204,7 +1203,7 @@ and normalize_expr ?guard info map = else let ivars = info.inductive_variables in let pos = AH.pos_of_expr expr in - let ty = if expr_has_inductive_var ivars expr |> is_some then + let ty = if expr_has_inductive_var ivars expr then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in @@ -1302,7 +1301,7 @@ and normalize_expr ?guard info map = normalize_expr ?guard info map expr | Pre (pos, expr) -> let ivars = info.inductive_variables in - let ty = if expr_has_inductive_var ivars expr |> is_some then + let ty = if expr_has_inductive_var ivars expr then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in @@ -1328,7 +1327,7 @@ and normalize_expr ?guard info map = (* ************************************************************************ *) | ArrayConstr (pos, expr, size_expr) -> let ivars = info.inductive_variables in - let ty = if expr_has_inductive_var ivars expr |> is_some then + let ty = if expr_has_inductive_var ivars expr then (StringMap.choose_opt info.inductive_variables) |> get |> snd else Chk.infer_type_expr info.context expr |> unwrap in diff --git a/src/lustre/lustreDesugarChooseOps.ml b/src/lustre/lustreDesugarChooseOps.ml index 0e5c3198b..b84242783 100644 --- a/src/lustre/lustreDesugarChooseOps.ml +++ b/src/lustre/lustreDesugarChooseOps.ml @@ -40,9 +40,15 @@ | Some expr2 -> [A.Assume (AH.pos_of_expr expr2, None, false, expr2); A.Guarantee (AH.pos_of_expr expr1, None, false, expr1)] in - let inputs = match expr2_opt with - | None -> Ctx.SI.elements (Ctx.SI.diff (AH.vars expr1) (Ctx.SI.singleton id)) - | Some expr2 -> Ctx.SI.elements (Ctx.SI.diff (Ctx.SI.union (AH.vars expr1) (AH.vars expr2)) (Ctx.SI.singleton id)) + let inputs = + let vars_of_expr1 = AH.vars_without_node_call_ids expr1 in + match expr2_opt with + | None -> Ctx.SI.elements (Ctx.SI.diff vars_of_expr1 (Ctx.SI.singleton id)) + | Some expr2 -> + let vars_of_expr1_and_expr2 = + Ctx.SI.union vars_of_expr1 (AH.vars_without_node_call_ids expr2) + in + Ctx.SI.elements (Ctx.SI.diff vars_of_expr1_and_expr2 (Ctx.SI.singleton id)) in (* Constants don't need to be passed as a parameter to generated node *) let inputs = List.filter (fun i -> not (Ctx.member_val ctx i)) inputs in diff --git a/src/lustre/lustreNodeGen.ml b/src/lustre/lustreNodeGen.ml index d3d567ba9..910c75788 100644 --- a/src/lustre/lustreNodeGen.ml +++ b/src/lustre/lustreNodeGen.ml @@ -726,14 +726,11 @@ and compile_ast_expr and compile_mode_reference path' = let path' = List.map HString.string_of_hstring path' in - let rpath = List.rev path' in - let path1 = (rpath |> List.tl |> List.rev) in let path2 = List.map (fun (_, s) -> HString.string_of_hstring s) !map.contract_scope in - let path3 = [(rpath |> List.hd)] in - let path' = path2 @ path1 @ path3 in + let path' = path2 @ path' in let rec find_mode = function | { C.path ; C.requires } :: tail -> if path = path' then diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index 40a8849a5..5d377cb2f 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -277,7 +277,7 @@ let build_equation_ctx ctx = function let is_symbolic = match output_type_opt with | Some ty -> (match ty with | ArrayType (_, (_, e)) -> - let vars = LAH.vars e in + let vars = LAH.vars_without_node_call_ids e in let check_var e = StringMap.mem e ctx.free_consts || StringMap.mem e ctx.locals in @@ -412,7 +412,12 @@ let no_node_calls_in_constant pos i e = let no_quant_var_or_symbolic_index_in_node_call ctx = function | LA.Call (pos, i, args) -> - let vars = List.flatten (List.map (fun e -> LA.SI.elements (LAH.vars e)) args) in + let vars = + List.fold_left + (fun acc e -> LA.SI.union acc (LAH.vars_without_node_call_ids e)) + LA.SI.empty + args + in let over_vars j = let found_quant = StringMap.mem j ctx.quant_vars in let found_symbolic_index = StringMap.mem j ctx.symbolic_array_indices in @@ -421,7 +426,7 @@ let no_quant_var_or_symbolic_index_in_node_call ctx = function | _, true -> syntax_error pos (SymbolicArrayIndexInNodeArgument (j, i)) | false, false -> Ok ()) in - let check = List.map over_vars vars in + let check = List.map over_vars (LA.SI.elements vars) in List.fold_left (>>) (Ok ()) check | _ -> Ok () diff --git a/src/lustre/lustreTypeChecker.ml b/src/lustre/lustreTypeChecker.ml index a35935cc1..12f39c4cb 100644 --- a/src/lustre/lustreTypeChecker.ml +++ b/src/lustre/lustreTypeChecker.ml @@ -1190,7 +1190,12 @@ and check_contract_node_eqn: (LA.SI.t * LA.SI.t) -> tc_context -> LA.contract_no (Bool pos)) | ContractCall (pos, cname, args, rets) -> - let arg_ids = List.fold_left (fun a s -> LA.SI.union a s) LA.SI.empty (List.map LH.vars args) in + let arg_ids = + List.fold_left + (fun a s -> LA.SI.union a s) + LA.SI.empty + (List.map LH.vars_without_node_call_ids args) + in let ret_ids = LA.SI.of_list rets in let common_ids = LA.SI.inter arg_ids ret_ids in if (LA.SI.equal common_ids LA.SI.empty) @@ -1557,8 +1562,10 @@ and is_expr_int_type: tc_context -> LA.expr -> bool = fun ctx e -> * while declaring the array type *) and is_expr_of_consts: tc_context -> LA.expr -> bool = fun ctx e -> - List.fold_left (&&) true (List.map (member_val ctx) (LA.SI.elements (LH.vars e))) -(** checks if all the variables in the expression are constants *) + not (LH.expr_contains_call e) && + List.map (member_val ctx) (LA.SI.elements (LH.vars_without_node_call_ids e)) + |> List.fold_left (&&) true +(** checks if the expression only contains constant variables *) and eq_typed_ident: tc_context -> LA.typed_ident -> LA.typed_ident -> (bool, [> error]) result = fun ctx (_, _, ty1) (_, _, ty2) -> eq_lustre_type ctx ty1 ty2 From aa9a3624750093b8b671730600596f558d620c97 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 12 Sep 2023 15:46:30 -0500 Subject: [PATCH 43/51] Switch 'provided' keyword to 'assuming' in choose ops --- src/lustre/lustreLexer.mll | 3 +++ src/lustre/lustreParser.messages | 8 ++++---- src/lustre/lustreParser.mly | 3 ++- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/lustre/lustreLexer.mll b/src/lustre/lustreLexer.mll index c9be0b13f..00dd29ba3 100644 --- a/src/lustre/lustreLexer.mll +++ b/src/lustre/lustreLexer.mll @@ -286,7 +286,10 @@ let keyword_table = mk_hashtbl [ "with", WITH ; "div", INTDIV ; "mod", MOD ; + + (* Choose operator *) "choose", CHOOSE ; + "assuming", ASSUMING ; (* Clock operators *) "when", WHEN ; diff --git a/src/lustre/lustreParser.messages b/src/lustre/lustreParser.messages index 3aa2d5887..d73135b95 100644 --- a/src/lustre/lustreParser.messages +++ b/src/lustre/lustreParser.messages @@ -2928,18 +2928,18 @@ main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT ASSUME BAR Syntax Error! -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED XOR +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME ASSUMING XOR Syntax Error! -one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED DECIMAL WEAKLY +one_expr: CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME ASSUMING DECIMAL WEAKLY Syntax Error! -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED XOR +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME ASSUMING XOR Syntax Error! -main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME PROVIDED DECIMAL WEAKLY +main: FUNCTION ASSUME LPAREN RPAREN RETURNS LPAREN RPAREN LET ASSERT CHOOSE LCURLYBRACKET ASSUME COLON ASSUME BAR ASSUME ASSUMING DECIMAL WEAKLY Syntax Error! diff --git a/src/lustre/lustreParser.mly b/src/lustre/lustreParser.mly index 12757114b..1728f7be1 100644 --- a/src/lustre/lustreParser.mly +++ b/src/lustre/lustreParser.mly @@ -131,6 +131,7 @@ let mk_span start_pos end_pos = %token CHECK %token REACHABLE %token PROVIDED +%token ASSUMING %token INVARIANT %token FROM %token AT @@ -914,7 +915,7 @@ pexpr(Q): (* Choose operation *) | CHOOSE; LCURLYBRACKET; id = typed_ident; BAR; e = pexpr(Q); RCURLYBRACKET { A.ChooseOp (mk_pos $startpos, id, e, None) } - | CHOOSE; LCURLYBRACKET; id = typed_ident; BAR; e1 = pexpr(Q); PROVIDED; e2 = pexpr(Q); RCURLYBRACKET + | CHOOSE; LCURLYBRACKET; id = typed_ident; BAR; e1 = pexpr(Q); ASSUMING; e2 = pexpr(Q); RCURLYBRACKET { A.ChooseOp (mk_pos $startpos, id, e1, Some e2) } (* Recursive node call *) From a8ef04136fc6b3d473e9e767635006d63c77675c Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Tue, 12 Sep 2023 16:06:06 -0500 Subject: [PATCH 44/51] Remove unused code from get_node_call_from_expr --- src/lustre/lustreAstDependencies.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/lustre/lustreAstDependencies.ml b/src/lustre/lustreAstDependencies.ml index 7732691e9..d10ad6266 100644 --- a/src/lustre/lustreAstDependencies.ml +++ b/src/lustre/lustreAstDependencies.ml @@ -395,8 +395,7 @@ let rec get_node_call_from_expr: LA.expr -> (LA.ident * Lib.position) list | LA.NArityOp (_, _, es) -> List.flatten (List.map get_node_call_from_expr es) | LA.ConvOp (_, _, e) -> get_node_call_from_expr e | LA.CompOp (_, _, e1, e2) -> (get_node_call_from_expr e1) @ (get_node_call_from_expr e2) - | LA.ChooseOp (_, _, e, None) -> get_node_call_from_expr e - | LA.ChooseOp (_, _, e1, Some e2) -> (get_node_call_from_expr e1) @ (get_node_call_from_expr e2) + | LA.ChooseOp _ -> assert false (* Already desugared in lustreDesugarChooseOps *) (* Structured expressions *) | LA.RecordExpr (_, _, id_exprs) -> List.flatten (List.map (fun (_, e) -> get_node_call_from_expr e) id_exprs) | LA.GroupExpr (_, _, es) -> List.flatten (List.map get_node_call_from_expr es) From 4d8b4e749dd35ce9cd18e4b1ae4001f170ba34de Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Tue, 12 Sep 2023 16:37:03 -0500 Subject: [PATCH 45/51] Update choose op printing function (provided -> assuming) --- src/lustre/lustreAst.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lustre/lustreAst.ml b/src/lustre/lustreAst.ml index bbfbb7f5d..e45a48dc1 100644 --- a/src/lustre/lustreAst.ml +++ b/src/lustre/lustreAst.ml @@ -622,7 +622,7 @@ let rec pp_print_expr ppf = | ChooseOp (p, id, e1, Some e2) -> Format.fprintf ppf - "%achoose { %a | %a provided %a }" + "%achoose { %a | %a assuming %a }" ppos p pp_print_typed_ident id pp_print_expr e1 From fd041a1618155e8f25ce9732ca3a3883704a9d36 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Wed, 13 Sep 2023 08:02:36 -0500 Subject: [PATCH 46/51] Remove unreachable code from lustreAstHelpers --- src/lustre/lustreAstHelpers.ml | 34 ++++++++-------------------------- 1 file changed, 8 insertions(+), 26 deletions(-) diff --git a/src/lustre/lustreAstHelpers.ml b/src/lustre/lustreAstHelpers.ml index 6f4356664..8a898cb2c 100644 --- a/src/lustre/lustreAstHelpers.ml +++ b/src/lustre/lustreAstHelpers.ml @@ -163,11 +163,8 @@ let rec has_unguarded_pre ung = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) | ChooseOp (_, _, e, None) -> has_unguarded_pre ung e - | ChooseOp (_, _, e1, Some e2) -> - let u1 = has_unguarded_pre ung e1 in - let u2 = has_unguarded_pre ung e2 in - u1 || u2 + | TupleProject (_, e, _) | Quantifier (_, _, _, e) -> has_unguarded_pre ung e + | ChooseOp (pos, _, _, _) -> fail_at_position pos "Choose operations are not supported in the old front end" | BinaryOp (_, _, e1, e2) | ArrayConstr (_, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) -> let u1 = has_unguarded_pre ung e1 in @@ -254,11 +251,8 @@ let rec has_unguarded_pre_no_warn ung = function | RecordProject (_, e, _) | ConvOp (_, _, e) | UnaryOp (_, _, e) | Current (_, e) | When (_, e, _) - | TupleProject (_, e, _) | Quantifier (_, _, _, e) | ChooseOp (_, _, e, None) -> has_unguarded_pre_no_warn ung e - | ChooseOp (_, _, e1, Some e2) -> - let u1 = has_unguarded_pre_no_warn ung e1 in - let u2 = has_unguarded_pre_no_warn ung e2 in - u1 || u2 + | TupleProject (_, e, _) | Quantifier (_, _, _, e) -> has_unguarded_pre_no_warn ung e + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) | BinaryOp (_, _, e1, e2) | ArrayConstr (_, e1, e2) | CompOp (_, _, e1, e2) | ArrayConcat (_, e1, e2) -> let u1 = has_unguarded_pre_no_warn ung e1 in @@ -848,8 +842,7 @@ let rec replace_with_constants: expr -> expr = let e1' = replace_with_constants e1 in let e2' = replace_with_constants e2 in CompOp (p, op, e1', e2') - | ChooseOp (p, i, expr, None) -> ChooseOp (p, i, replace_with_constants expr, None) - | ChooseOp (p, i, expr1, Some expr2) -> ChooseOp (p, i, replace_with_constants expr1, Some (replace_with_constants expr2)) + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) (* Structured expressions *) | RecordExpr (p, i, flds) -> RecordExpr (p, i, (List.map (fun (f, e) -> (f, replace_with_constants e)) flds)) @@ -944,8 +937,7 @@ let rec abstract_pre_subexpressions: expr -> expr = function let e1' = abstract_pre_subexpressions e1 in let e2' = abstract_pre_subexpressions e2 in CompOp (p, op, e1', e2') - | ChooseOp (p, i, e, None) -> ChooseOp (p, i, abstract_pre_subexpressions e, None) - | ChooseOp (p, i, e1, Some e2) -> ChooseOp (p, i, abstract_pre_subexpressions e1, Some (abstract_pre_subexpressions e2)) + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) (* Structured expressions *) | RecordExpr (p, i, flds) -> RecordExpr (p, i, (List.map (fun (f, e) -> (f, abstract_pre_subexpressions e)) flds)) @@ -1045,16 +1037,7 @@ let rec replace_idents locals1 locals2 expr = | Call (a, b, l) -> Call (a, b, List.map (replace_idents locals1 locals2) l) | CallParam (a, b, c, l) -> CallParam (a, b, c, List.map (replace_idents locals1 locals2) l) - | ChooseOp (a, (b, i, c), e, None) -> - (* Remove 'i' from locals because it's bound in 'e' *) - let locals = List.combine locals1 locals2 in - let locals1, locals2 = List.remove_assoc i locals |> List.split in - ChooseOp (a, (b, i, c), replace_idents locals1 locals2 e, None) - | ChooseOp (a, (b, i, c), e1, Some e2) -> - (* Remove 'i' from locals because it's bound in 'e' *) - let locals = List.combine locals1 locals2 in - let locals1, locals2 = List.remove_assoc i locals |> List.split in - ChooseOp (a, (b, i, c), replace_idents locals1 locals2 e1, Some (replace_idents locals1 locals2 e2)) + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) | Quantifier (a, b, tis, e) -> (* Remove 'tis' from locals because they're bound in 'e' *) let locals = List.combine locals1 locals2 in @@ -1525,8 +1508,7 @@ let rec rename_contract_vars = function | ConvOp (pos, op, e) -> ConvOp (pos, op, rename_contract_vars e) | CompOp (pos, op, e1, e2) -> CompOp (pos, op, rename_contract_vars e1, rename_contract_vars e2) - | ChooseOp (pos, i, e, None) -> ChooseOp (pos, i, rename_contract_vars e, None) - | ChooseOp (pos, i, e1, Some e2) -> ChooseOp (pos, i, rename_contract_vars e1, Some (rename_contract_vars e2)) + | ChooseOp _ -> assert false (* desugared in lustreDesugarChooseOps *) | RecordExpr (pos, ident, expr_list) -> RecordExpr (pos, ident, List.map (fun (i, e) -> (i, rename_contract_vars e)) expr_list) | GroupExpr (pos, kind, expr_list) -> From 4b0c6c8cfd4e6335f0e72d2a6a334034e21ef40a Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Wed, 13 Sep 2023 08:02:55 -0500 Subject: [PATCH 47/51] Disallow choose ops in functions --- src/lustre/lustreSyntaxChecks.ml | 6 +++++- src/lustre/lustreSyntaxChecks.mli | 1 + 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index 5d377cb2f..c7ad7b6cb 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -46,6 +46,7 @@ type error_kind = Unknown of string | DanglingIdentifier of HString.t | QuantifiedVariableInNodeArgument of HString.t * HString.t | SymbolicArrayIndexInNodeArgument of HString.t * HString.t + | ChooseOpInFunction | NodeCallInFunction of HString.t | NodeCallInRefinableContract of string * HString.t | NodeCallInConstant of HString.t @@ -91,6 +92,7 @@ let error_message kind = match kind with | SymbolicArrayIndexInNodeArgument (idx, node) -> "Symbolic array index '" ^ HString.string_of_hstring idx ^ "' is not allowed in an argument to the node call '" ^ HString.string_of_hstring node ^ "'" + | ChooseOpInFunction -> "Illegal choose operator in function" | NodeCallInFunction node -> "Illegal call to node '" ^ HString.string_of_hstring node ^ "', functions can only call other functions, not nodes" | NodeCallInRefinableContract (kind, node) -> "Illegal call to " ^ kind ^ " '" @@ -433,10 +435,12 @@ let no_quant_var_or_symbolic_index_in_node_call ctx = function let no_calls_to_node ctx = function | LA.Condact (pos, _, _, i, _, _) | Activate (pos, i, _, _, _) + | RestartEvery (pos, i, _, _) | Call (pos, i, _) -> let check_nodes = StringMap.mem i ctx.nodes in if check_nodes then syntax_error pos (NodeCallInFunction i) else Ok () + | ChooseOp (pos, _, _, _) -> syntax_error pos ChooseOpInFunction | _ -> Ok () (* Note: this check is simpler if done after the contract imports have all been @@ -664,7 +668,7 @@ and check_func_decl ctx span (id, ext, params, inputs, outputs, locals, items, c let composed_items_checks ctx e = (common_node_equations_checks ctx e) >> (no_calls_to_node ctx e) - >> (no_temporal_operator "constant" e) + >> (no_temporal_operator "function" e) in (parametric_nodes_unsupported span.start_pos params) >> (match contract with diff --git a/src/lustre/lustreSyntaxChecks.mli b/src/lustre/lustreSyntaxChecks.mli index 9d0ce741b..40ac76dc9 100644 --- a/src/lustre/lustreSyntaxChecks.mli +++ b/src/lustre/lustreSyntaxChecks.mli @@ -29,6 +29,7 @@ type error_kind = Unknown of string | DanglingIdentifier of HString.t | QuantifiedVariableInNodeArgument of HString.t * HString.t | SymbolicArrayIndexInNodeArgument of HString.t * HString.t + | ChooseOpInFunction | NodeCallInFunction of HString.t | NodeCallInRefinableContract of string * HString.t | NodeCallInConstant of HString.t From a1aa1517fe3fcef777d3ee2fa9e925143fda7f0f Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 13 Sep 2023 10:53:04 -0500 Subject: [PATCH 48/51] Fix dangling identifier checks for choose ops --- src/lustre/lustreSyntaxChecks.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index c7ad7b6cb..27c1e416b 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -832,6 +832,10 @@ and check_expr ctx f (expr:LustreAst.expr) = (check_expr ctx f e1) >> (check_expr ctx f e2) >> (check_expr_list ctx f e3) | RestartEvery (_, _, e1, e2) -> (check_expr_list ctx f e1) >> (check_expr ctx f e2) + | ChooseOp (_, _, e1, None) -> + (check_expr ctx f e1) + | ChooseOp (_, _, e1, Some e2) -> + (check_expr ctx f e1) >> (check_expr ctx f e2) | _ -> Ok () in expr' >> r From e9c24e387063c5798dd47114489ec5d8e37503e6 Mon Sep 17 00:00:00 2001 From: Rob Lorch Date: Wed, 13 Sep 2023 10:59:00 -0500 Subject: [PATCH 49/51] Fix bug with last commit --- src/lustre/lustreSyntaxChecks.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/lustre/lustreSyntaxChecks.ml b/src/lustre/lustreSyntaxChecks.ml index 27c1e416b..0025650cd 100644 --- a/src/lustre/lustreSyntaxChecks.ml +++ b/src/lustre/lustreSyntaxChecks.ml @@ -832,10 +832,12 @@ and check_expr ctx f (expr:LustreAst.expr) = (check_expr ctx f e1) >> (check_expr ctx f e2) >> (check_expr_list ctx f e3) | RestartEvery (_, _, e1, e2) -> (check_expr_list ctx f e1) >> (check_expr ctx f e2) - | ChooseOp (_, _, e1, None) -> - (check_expr ctx f e1) - | ChooseOp (_, _, e1, Some e2) -> - (check_expr ctx f e1) >> (check_expr ctx f e2) + | ChooseOp (_, (_, i, ty), e1, None) -> + let extn_ctx = ctx_add_local ctx i (Some ty) in + (check_expr extn_ctx f e1) + | ChooseOp (_, (_, i, ty), e1, Some e2) -> + let extn_ctx = ctx_add_local ctx i (Some ty) in + (check_expr extn_ctx f e1) >> (check_expr extn_ctx f e2) | _ -> Ok () in expr' >> r From 52cc7861a54f99462a1968dc5fe2e9de7fbf8fc3 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Wed, 13 Sep 2023 13:05:47 -0500 Subject: [PATCH 50/51] Update user doc for choose op --- doc/usr/source/2_input/1_lustre.rst | 88 ++++++++++++++++++++++++++--- 1 file changed, 81 insertions(+), 7 deletions(-) diff --git a/doc/usr/source/2_input/1_lustre.rst b/doc/usr/source/2_input/1_lustre.rst index de56c7abb..1eb8f4479 100644 --- a/doc/usr/source/2_input/1_lustre.rst +++ b/doc/usr/source/2_input/1_lustre.rst @@ -1077,10 +1077,84 @@ stateful. Therefore, a frame block initialization cannot contain any ``pre`` or operators. This restriction also ensures that initializations are never undefined. Nondeterministic choice operator ----------------------------------- -The expression ``choose { var: ty | expression }`` evaluates to a variable -``var`` that of type ``ty`` that satisfies ``expression``. For example, -``choose { y: int | y < 50 }`` nondeterminsitically evaluates to -some value less than 50. The body ``expression`` can -reference variable ``var`` as well as any inputs, outputs, or locals -that are currently in scope. \ No newline at end of file +-------------------------------- +There are situations in the design of reactive systems where +nondeterministic behaviors must be modeled. +Kind 2 offers a convenient binder of the form +``choose { x: T | P(x) }`` which denotes an arbitrary stream of +values of type ``T`` each satisfying the predicate ``P``. +In the expression above ``x`` is a locally bound variable of type ``T``, +and ``P(x)`` is a Boolean expression that typically, +but not necessarily, contains ``x``. The expression ``P(x)`` +may also contain any input, output, or local variable that +are in the scope of the ``choose`` expression. +The following example shows a component using the ``choose`` +operator to define a local stream ``l`` of arbitrary odd values. + +.. code-block:: none + + node N(y: int) returns (z:int); + (*@contract + assume "y is odd" y mod 2 = 1; + guarantee "z is even" z mod 2 = 0; + *) + var l: int; + let + l = choose { x: int | x mod 2 = 1 }; + z = y + l; + tel + +A challenge for the user with the use of ``choose`` expressions arises if +the specified condition is inconsistent, or more generally, unrealizable. +In that case, the system model may be satisfied by no execution trace. +As a consequence, any property, even an inconsistent one, would be trivially +satisfied by the (inconsistent) system model. +For instance, the condition of the ``choose`` operator in the node of +the following example is inconsistent, and thus, there is no realization of +the system model. As a result, Kind 2 proves the property P1 valid. + +.. code-block:: none + + node N(y: int) returns (z: int); + var l: int; + let + l = choose { x : int | x < 0 and x > 0 }; + z = y + l; + check "P1" z > 0 and z < 0; + tel + +This problem is mitigated by the possibility for +the user to check that the predicate ``P(x)`` in +the ``choose`` expression is realizable. +This is possible because, for each ``choose`` expression occurring in +a model, Kind 2 introduces an internal imported node whose +contract restricts the values of the returned output using +the given predicate as a guarantee. +The user can take advantage of this fact to detect issues with +the conditions of ``choose`` expressions by enabling +Kind 2's functionality that checks +the :ref:`realizability of contracts<9_other/11_contract_checks>` of +imported nodes. When this functionality is enabled, Kind 2 is able to +detect the problem illustrated in the example above. + +It is worth mentioning that Kind 2 does not consider the surrounding +context when checking the realizability of the introduced imported node. +Because of this limitation, some checks may fail even if, +in a broader context where all constraints included in +the model are considered, the imported node would actually be considered +realizable. To mitigate this issue, Kind 2 offers an extended version of +the binder, ``choose { x: T | P(x) assuming Q }``, that +allows the user to specify an assumption ``Q`` that +should be taken into account in the realizability check. +For instance, the realizability check for the ``choose`` expression +in the following example would fail if the assumption ``a <= b`` +was not included. + +.. code-block:: none + + node N(a: int) returns (z: int); + var b: int; + let + b = a + 10; + z = choose { x: int | a <= x and x <= b assuming a<=b }; + tel \ No newline at end of file From 1f568464e1c002edc106a87d692e43fc4aea0330 Mon Sep 17 00:00:00 2001 From: Daniel Larraz Date: Wed, 13 Sep 2023 13:22:18 -0500 Subject: [PATCH 51/51] Update choose_simple test --- tests/regression/success/choose_simple.lus | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/tests/regression/success/choose_simple.lus b/tests/regression/success/choose_simple.lus index e1267fb0e..10848bd07 100644 --- a/tests/regression/success/choose_simple.lus +++ b/tests/regression/success/choose_simple.lus @@ -1,10 +1,13 @@ const x1: int = 0; -node main () returns (y: int); -var x2: int; +node main (a: int) returns (y, z: int); +var x2, b: int; let x2 = choose {x: int | x > x1 }; y = choose { x: int | x + x2 < 50 }; - check y < 100; + + b = a + 10; + z = choose { x: int | a <= x and x <= b assuming a<=b }; + check a <= z and z <= b; tel;